[ngrams] some type refactoring

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.5.8.9.9
+version:        0.0.5.8.9.9
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -210,6 +210,7 @@ library
       Gargantext.Core.Text.Terms.Multi.Group
       Gargantext.Core.Text.Terms.Multi.PosTagging
       Gargantext.Core.Text.Terms.Multi.PosTagging.Types
+      Gargantext.Core.Types.Ngrams
       Gargantext.Core.Types.Phylo
       Gargantext.Core.Utils
       Gargantext.Core.Utils.DateUtils
@@ -269,6 +270,7 @@ library
       Gargantext.Database.Admin.Types.Hyperdata.User
       Gargantext.Database.Admin.Types.Metrics
       Gargantext.Database.GargDB
+      Gargantext.Database.NodeStory
       Gargantext.Database.Query
       Gargantext.Database.Query.Facet
       Gargantext.Database.Query.Filter

src/Gargantext/API/Ngrams/NgramsTree.hs

@@ -22,8 +22,8 @@ import Data.Swagger
 import Data.Text (Text)
 import Data.Tree
 import GHC.Generics (Generic)
-import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types (ListType(..), NodeId)
+import Gargantext.Core.Types.Ngrams (NgramsRepoElement(..), NgramsTerm(..), mSetToList)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Prelude
 import Test.QuickCheck

src/Gargantext/API/Ngrams/Tools.hs

@@ -21,8 +21,8 @@ import Data.HashMap.Strict (HashMap)
 import Data.Hashable (Hashable)
 import Data.Set (Set)
 import Data.Validity
-import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types (ListType(..), NodeId, ListId)
+import Gargantext.Core.Types.Ngrams (NgramsRepoElement(..), NgramsTerm(..))
 import Gargantext.Database.Schema.Ngrams (NgramsType)
 import Gargantext.Prelude
 import qualified Data.HashMap.Strict as HM

src/Gargantext/API/Ngrams/Types.hs

@@ -11,31 +11,28 @@ module Gargantext.API.Ngrams.Types where
 
 import Codec.Serialise (Serialise())
 import Control.Category ((>>>))
-import Control.DeepSeq (NFData)
 import Control.Lens (makeLenses, makePrisms, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^?), (%~), (.~), (%=), at, _Just, Each(..), itraverse_, both, forOf_, (?~))
 import Control.Monad.State
 import Data.Aeson hiding ((.=))
 import Data.Aeson.TH (deriveJSON)
 import Data.Either (Either(..))
-import Data.Foldable
 import Data.Hashable (Hashable)
 import Data.Map.Strict (Map)
 import Data.Maybe (fromMaybe)
 import Data.Monoid
 import Data.Patch.Class (Replace, replace, Action(act), Group, Applicable(..), Composable(..), Transformable(..), PairPatch(..), Patched, ConflictResolution, ConflictResolutionReplace, MaybePatch(Mod), unMod, old, new)
 import Data.Set (Set)
-import Data.String (IsString, fromString)
 import Data.Swagger hiding (version, patch)
-import Data.Text (Text, pack, strip)
+import Data.Text (Text, pack)
 import Data.Validity
-import Database.PostgreSQL.Simple.FromField (FromField, fromField, ResultError(ConversionFailed), returnError)
+import Database.PostgreSQL.Simple.FromField (FromField, fromField)
 import GHC.Generics (Generic)
 import Gargantext.Core.Text (size)
 import Gargantext.Core.Types (ListType(..), ListId, NodeId, TODO)
+import Gargantext.Core.Types.Ngrams
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixUntagged, unPrefixSwagger, wellNamedSchema)
 import Gargantext.Database.Prelude (fromField', HasConnectionPool, HasConfig, CmdM')
 import Gargantext.Prelude
-import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
 import Protolude (maybeToEither)
 import Servant hiding (Patch)
 import Servant.Job.Utils (jsonOptions)
@@ -43,11 +40,9 @@ import Servant.Job.Utils (jsonOptions)
 import Test.QuickCheck (elements, frequency)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 import qualified Data.HashMap.Strict.InsOrd             as InsOrdHashMap
-import qualified Data.List                              as List
 import qualified Data.Map.Strict                        as Map
 import qualified Data.Map.Strict.Patch                  as PM
-import qualified Data.Set                               as Set
-import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
+import qualified Gargantext.Database.Schema.Ngrams      as SchemaNgrams
 
 ------------------------------------------------------------------------
 
@@ -90,63 +85,7 @@ instance FromJSONKey TabType where
 instance ToJSONKey TabType where
   toJSONKey = genericToJSONKey defaultJSONKeyOptions
 
-newtype MSet a = MSet (Map a ())
-  deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
-
-instance ToJSON a => ToJSON (MSet a) where
-  toJSON     (MSet m) = toJSON     (Map.keys m)
-  toEncoding (MSet m) = toEncoding (Map.keys m)
-
-mSetFromSet :: Set a -> MSet a
-mSetFromSet = MSet . Map.fromSet (const ())
-
-mSetFromList :: Ord a => [a] -> MSet a
-mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
-
--- mSetToSet :: Ord a => MSet a -> Set a
--- mSetToSet (MSet a) = Set.fromList ( Map.keys a)
-mSetToSet :: Ord a => MSet a -> Set a
-mSetToSet = Set.fromList . mSetToList
-
-mSetToList :: MSet a -> [a]
-mSetToList (MSet a) = Map.keys a
-
-instance Foldable MSet where
-  foldMap f (MSet m) = Map.foldMapWithKey (\k _ -> f k) m
-
-instance (Ord a, FromJSON a) => FromJSON (MSet a) where
-  parseJSON = fmap mSetFromList . parseJSON
-
-instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
-  -- TODO
-  declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
-
 ------------------------------------------------------------------------
-newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text }
-  deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable, NFData)
-
-instance IsHashable NgramsTerm where
-  hash (NgramsTerm t) = hash t
-
-instance Monoid NgramsTerm where
-  mempty = NgramsTerm ""
-
-instance FromJSONKey NgramsTerm where
-  fromJSONKey = FromJSONKeyTextParser $ \t -> pure $ NgramsTerm $ strip t
-
-instance IsString NgramsTerm where
-  fromString s = NgramsTerm $ pack s
-
-instance FromField NgramsTerm
-  where
-    fromField field mb = do
-      v <- fromField field mb
-      case fromJSON v of
-        Success a -> pure $ NgramsTerm $ strip a
-        Error _err -> returnError ConversionFailed field
-                      $ List.intercalate " " [ "cannot parse hyperdata for JSON: "
-                                             , show v
-                                             ]
 
 data RootParent = RootParent
   { _rp_root   :: NgramsTerm
@@ -156,29 +95,6 @@ data RootParent = RootParent
 
 deriveJSON (unPrefix "_rp_") ''RootParent
 makeLenses ''RootParent
-
-data NgramsRepoElement = NgramsRepoElement
-  { _nre_size        :: !Int
-  , _nre_list        :: !ListType
-  , _nre_root        :: !(Maybe NgramsTerm)
-  , _nre_parent      :: !(Maybe NgramsTerm)
-  , _nre_children    :: !(MSet NgramsTerm)
-  }
-  deriving (Ord, Eq, Show, Generic)
-
-deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
--- TODO
--- if ngrams & not size => size
--- drop occurrences
-
-makeLenses ''NgramsRepoElement
-
-instance ToSchema NgramsRepoElement where
-  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
-
-instance Serialise (MSet NgramsTerm)
-instance Serialise NgramsRepoElement
-
 data NgramsElement =
      NgramsElement { _ne_ngrams      :: NgramsTerm
                    , _ne_size        :: Int
@@ -272,8 +188,6 @@ instance Arbitrary NgramsTable where
 
 instance ToSchema NgramsTable
 
-------------------------------------------------------------------------
-type NgramsTableMap = Map NgramsTerm NgramsRepoElement
 ------------------------------------------------------------------------
 -- On the Client side:
 --data Action = InGroup     NgramsId NgramsId
@@ -338,10 +252,6 @@ instance Ord a => Transformable (PatchSet a) where
 instance ToSchema a => ToSchema (PatchSet a)
 -}
 
-type AddRem = Replace (Maybe ())
-
-instance Serialise AddRem
-
 remPatch, addPatch :: AddRem
 remPatch = replace (Just ()) Nothing
 addPatch = replace Nothing (Just ())
@@ -351,19 +261,6 @@ isRem = (== remPatch)
 
 type PatchMap = PM.PatchMap
 
-newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
-  deriving (Eq, Show, Generic, Validity, Semigroup, Monoid, Group,
-            Transformable, Composable)
-
-unPatchMSet :: PatchMSet a -> PatchMap a AddRem
-unPatchMSet (PatchMSet a) = a
-
-type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
-type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
-
-instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
-instance (Serialise a, Ord a) => Serialise (PatchMSet a)
-
 -- TODO this breaks module abstraction
 makePrisms ''PM.PatchMap
 
@@ -418,134 +315,6 @@ instance ToSchema a => ToSchema (Replace a) where
                 ]
             & required .~ [ "old", "new" ]
 
-data NgramsPatch
-   = NgramsPatch { _patch_children :: !(PatchMSet NgramsTerm)
-                 , _patch_list     :: !(Replace ListType)   -- TODO Map UserId ListType
-                 }
-   | NgramsReplace { _patch_old :: !(Maybe NgramsRepoElement)
-                   , _patch_new :: !(Maybe NgramsRepoElement)
-                   }
-      deriving (Eq, Show, Generic)
-
--- The JSON encoding is untagged, this is OK since the field names are disjoints and thus the encoding is unambiguous.
--- TODO: the empty object should be accepted and treated as mempty.
-deriveJSON (unPrefixUntagged "_") ''NgramsPatch
-makeLenses ''NgramsPatch
-
--- TODO: This instance is simplified since we should either have the fields children and/or list
--- or the fields old and/or new.
-instance ToSchema NgramsPatch where
-  declareNamedSchema _ = do
-    childrenSch <- declareSchemaRef (Proxy :: Proxy (PatchMSet NgramsTerm))
-    listSch <- declareSchemaRef (Proxy :: Proxy (Replace ListType))
-    nreSch <- declareSchemaRef (Proxy :: Proxy NgramsRepoElement)
-    return $ NamedSchema (Just "NgramsPatch") $ mempty
-            & type_ ?~ SwaggerObject
-            & properties .~
-                InsOrdHashMap.fromList
-                [ ("children", childrenSch)
-                , ("list",     listSch)
-                , ("old",      nreSch)
-                , ("new",      nreSch)
-                ]
-
-instance Arbitrary NgramsPatch where
-  arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
-                        , (1, NgramsReplace <$> arbitrary <*> arbitrary)
-                        ]
-
-instance Serialise NgramsPatch
-instance Serialise (Replace ListType)
-
-instance Serialise ListType
-
-type NgramsPatchIso =
-  MaybePatch NgramsRepoElement (PairPatch (PatchMSet NgramsTerm) (Replace ListType))
-
-_NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
-_NgramsPatch = iso unwrap wrap
-  where
-    unwrap (NgramsPatch c l) = Mod $ PairPatch (c, l)
-    unwrap (NgramsReplace o n) = replace o n
-    wrap x =
-      case unMod x of
-        Just (PairPatch (c, l)) -> NgramsPatch c l
-        Nothing -> NgramsReplace (x ^? old . _Just) (x ^? new . _Just)
-
-instance Semigroup NgramsPatch where
-  p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
-
-instance Monoid NgramsPatch where
-  mempty = _NgramsPatch # mempty
-
-instance Validity NgramsPatch where
-  validate p = p ^. _NgramsPatch . to validate
-
-instance Transformable NgramsPatch where
-  transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
-
-  conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
-
-  transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
-    where
-      (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
-
-type ConflictResolutionNgramsPatch =
-  ( ConflictResolutionReplace (Maybe NgramsRepoElement)
-  , ( ConflictResolutionPatchMSet NgramsTerm
-    , ConflictResolutionReplace ListType
-    )
-  , (Bool, Bool)
-  )
-type instance ConflictResolution NgramsPatch =
-  ConflictResolutionNgramsPatch
-
-type PatchedNgramsPatch = Maybe NgramsRepoElement
-type instance Patched NgramsPatch = PatchedNgramsPatch
-
-instance Applicable (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
-  applicable (PairPatch (c, l)) n = applicable c (n ^. nre_children) <> applicable l (n ^. nre_list)
-
-instance Action (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
-  act (PairPatch (c, l)) = (nre_children %~ act c)
-                         . (nre_list     %~ act l)
-
-instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
-  applicable p = applicable (p ^. _NgramsPatch)
-
-instance Action NgramsPatch (Maybe NgramsRepoElement) where
-  act p = act (p ^. _NgramsPatch)
-
-newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
-  deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
-
-instance Serialise NgramsTablePatch
-instance Serialise (PatchMap NgramsTerm NgramsPatch)
-
-instance FromField NgramsTablePatch
-  where
-    fromField = fromField'
-
-instance FromField (PatchMap TableNgrams.NgramsType (PatchMap NodeId NgramsTablePatch))
-  where
-    fromField = fromField'
-
-type instance ConflictResolution NgramsTablePatch =
-  NgramsTerm -> ConflictResolutionNgramsPatch
-
-
-type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
-  -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
-type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
-
-makePrisms ''NgramsTablePatch
-instance ToSchema  (PatchMap NgramsTerm NgramsPatch)
-instance ToSchema  NgramsTablePatch
-
-instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
-  applicable p = applicable (p ^. _NgramsTablePatch)
-
-
 ngramsElementToRepo :: NgramsElement -> NgramsRepoElement
 ngramsElementToRepo
   (NgramsElement { _ne_size     = s
@@ -713,21 +482,21 @@ instance Arbitrary NgramsRepoElement where
     where
       NgramsTable ns = mockTable
 
-instance FromHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
+instance FromHttpApiData (Map SchemaNgrams.NgramsType (Versioned NgramsTableMap))
   where
     parseUrlPiece x = maybeToEither x (decode $ cs x)
 
-instance ToHttpApiData (Map TableNgrams.NgramsType (Versioned NgramsTableMap)) where
+instance ToHttpApiData (Map SchemaNgrams.NgramsType (Versioned NgramsTableMap)) where
   toUrlPiece m = cs (encode m)
 
-ngramsTypeFromTabType :: TabType -> TableNgrams.NgramsType
+ngramsTypeFromTabType :: TabType -> SchemaNgrams.NgramsType
 ngramsTypeFromTabType tabType =
   let here = "Garg.API.Ngrams: " :: Text in
     case tabType of
-      Sources    -> TableNgrams.Sources
-      Authors    -> TableNgrams.Authors
-      Institutes -> TableNgrams.Institutes
-      Terms      -> TableNgrams.NgramsTerms
+      Sources    -> SchemaNgrams.Sources
+      Authors    -> SchemaNgrams.Authors
+      Institutes -> SchemaNgrams.Institutes
+      Terms      -> SchemaNgrams.NgramsTerms
       _          -> panic $ here <> "No Ngrams for this tab"
       -- TODO: This `panic` would disapear with custom NgramsType.
 
@@ -750,5 +519,5 @@ instance ToSchema UpdateTableNgramsCharts where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_utn_")
 
 ------------------------------------------------------------------------
-type NgramsList = (Map TableNgrams.NgramsType (Versioned NgramsTableMap))
+type NgramsList = (Map SchemaNgrams.NgramsType (Versioned NgramsTableMap))
 

src/Gargantext/Core/Text/List/Group/Prelude.hs

@@ -22,8 +22,9 @@ import Data.Maybe (fromMaybe)
 import Data.Monoid
 import Data.Semigroup
 import Data.Set (Set)
-import Gargantext.API.Ngrams.Types (NgramsElement, mkNgramsElement, NgramsTerm(..), RootParent(..), mSetFromList)
-import Gargantext.Core.Types (ListType(..))
+import Gargantext.API.Ngrams (RootParent(..))
+import Gargantext.Core.Types (ListType(..), NgramsTerm(..), mSetFromList)
+import Gargantext.Core.Types.Ngrams (NgramsElement, mkNgramsElement)
 import Gargantext.Prelude
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.List as List

src/Gargantext/Core/Text/List/Social/Prelude.hs

@@ -25,8 +25,9 @@ import Data.Hashable (Hashable)
 import Data.Monoid
 import Data.Semigroup (Semigroup(..))
 import GHC.Generics (Generic)
-import Gargantext.API.Ngrams.Types
+import Gargantext.API.Ngrams (PatchMap, NgramsPatch, NgramsTablePatch)
 import Gargantext.Core.Types.Main
+import Gargantext.Core.Types.Ngrams (NgramsTerm)
 import Gargantext.Prelude
 import qualified Gargantext.Data.HashMap.Strict.Utils as HashMap
 import qualified Data.Map.Strict       as Map

src/Gargantext/Core/Types/Main.hs

@@ -17,12 +17,14 @@ Portability : POSIX
 module Gargantext.Core.Types.Main where
 ------------------------------------------------------------------------
 
+import Codec.Serialise (Serialise)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Aeson.TH (deriveJSON)
 import Data.Either (Either(..))
 import Data.Hashable (Hashable)
 import Data.Map (fromList, lookup)
 import Data.Maybe (fromMaybe)
+import Data.Patch.Class (Replace)
 import Data.Semigroup (Semigroup(..))
 import Data.Swagger
 import Data.Text (Text, unpack, pack)
@@ -63,7 +65,8 @@ instance ToParamSchema ListType
 instance Arbitrary ListType where
   arbitrary = elements [minBound..maxBound]
 instance Hashable ListType
-
+instance Serialise (Replace ListType)
+instance Serialise ListType
 instance Semigroup ListType
   where
     MapTerm  <> _             = MapTerm

src/Gargantext/Core/Types/Ngrams.hs

+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TypeFamilies   #-}
+
+module Gargantext.Core.Types.Ngrams where
+
+import Codec.Serialise (Serialise())
+import Control.DeepSeq (NFData)
+import Control.Lens
+import Data.Aeson hiding ((.=))
+import Data.Aeson.TH (deriveJSON)
+import Data.Hashable (Hashable)
+import qualified Data.HashMap.Strict.InsOrd             as InsOrdHashMap
+import Data.Foldable (foldMap)
+import qualified Data.List as List
+import Data.Map.Strict.Patch (PatchMap)
+import Data.Patch.Class (Composable, ConflictResolution, ConflictResolutionReplace, Group, Patched, Replace, Transformable(..))
+import Data.Proxy (Proxy(..))
+import Data.Semigroup (Semigroup)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Monoid
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.String (IsString, fromString)
+import Data.Swagger hiding (version, patch)
+import Data.Text (Text, pack, strip)
+import Data.Validity
+import Database.PostgreSQL.Simple.FromField (FromField, fromField, ResultError(ConversionFailed), returnError)
+import Gargantext.Core.Types (ListType(..), NodeId, TODO)
+import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, unPrefixUntagged, wellNamedSchema)
+import qualified Gargantext.Database.Schema.Ngrams      as SchemaNgrams
+import Gargantext.Prelude
+import Gargantext.Prelude.Crypto.Hash (IsHashable(..))
+import GHC.Generics (Generic)
+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
+
+
+newtype MSet a = MSet (Map a ())
+  deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
+
+instance ToJSON a => ToJSON (MSet a) where
+  toJSON     (MSet m) = toJSON     (Map.keys m)
+  toEncoding (MSet m) = toEncoding (Map.keys m)
+
+instance Foldable MSet where
+  foldMap f (MSet m) = Map.foldMapWithKey (\k _ -> f k) m
+
+instance (Ord a, FromJSON a) => FromJSON (MSet a) where
+  parseJSON = fmap mSetFromList . parseJSON
+
+instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
+  -- TODO
+  declareNamedSchema _ = wellNamedSchema "" (Proxy :: Proxy TODO)
+
+mSetFromSet :: Set a -> MSet a
+mSetFromSet = MSet . Map.fromSet (const ())
+
+mSetFromList :: Ord a => [a] -> MSet a
+mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
+
+-- mSetToSet :: Ord a => MSet a -> Set a
+-- mSetToSet (MSet a) = Set.fromList ( Map.keys a)
+mSetToSet :: Ord a => MSet a -> Set a
+mSetToSet = Set.fromList . mSetToList
+
+mSetToList :: MSet a -> [a]
+mSetToList (MSet a) = Map.keys a
+
+
+
+newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text }
+  deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable, NFData)
+
+instance IsHashable NgramsTerm where
+  hash (NgramsTerm t) = hash t
+
+instance Monoid NgramsTerm where
+  mempty = NgramsTerm ""
+
+instance FromJSONKey NgramsTerm where
+  fromJSONKey = FromJSONKeyTextParser $ \t -> pure $ NgramsTerm $ strip t
+
+instance IsString NgramsTerm where
+  fromString s = NgramsTerm $ pack s
+
+instance FromField NgramsTerm
+  where
+    fromField field mb = do
+      v <- fromField field mb
+      case fromJSON v of
+        Success a -> pure $ NgramsTerm $ strip a
+        Error _err -> returnError ConversionFailed field
+                      $ List.intercalate " " [ "cannot parse hyperdata for JSON: "
+                                             , show v
+                                             ]
+
+
+data NgramsRepoElement = NgramsRepoElement
+  { _nre_size        :: !Int
+  , _nre_list        :: !ListType
+  , _nre_root        :: !(Maybe NgramsTerm)
+  , _nre_parent      :: !(Maybe NgramsTerm)
+  , _nre_children    :: !(MSet NgramsTerm)
+  }
+  deriving (Ord, Eq, Show, Generic)
+
+deriveJSON (unPrefix "_nre_") ''NgramsRepoElement
+-- TODO
+-- if ngrams & not size => size
+-- drop occurrences
+
+makeLenses ''NgramsRepoElement
+
+instance ToSchema NgramsRepoElement where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_nre_")
+
+instance Serialise (MSet NgramsTerm)
+instance Serialise NgramsRepoElement
+
+
+
+newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
+  deriving (Eq, Show, Generic, Validity, Semigroup, Monoid, Group,
+            Transformable, Composable)
+
+unPatchMSet :: PatchMSet a -> PatchMap a AddRem
+unPatchMSet (PatchMSet a) = a
+
+type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
+type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
+
+instance (Serialise a, Ord a) => Serialise (PatchMap a AddRem)
+instance (Serialise a, Ord a) => Serialise (PatchMSet a)
+
+
+type AddRem = Replace (Maybe ())
+instance Serialise AddRem
+
+
+data NgramsPatch
+   = NgramsPatch { _patch_children :: !(PatchMSet NgramsTerm)
+                 , _patch_list     :: !(Replace ListType)   -- TODO Map UserId ListType
+                 }
+   | NgramsReplace { _patch_old :: !(Maybe NgramsRepoElement)
+                   , _patch_new :: !(Maybe NgramsRepoElement)
+                   }
+      deriving (Eq, Show, Generic)
+
+instance Semigroup NgramsPatch where
+  p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
+instance Monoid NgramsPatch where
+  mempty = _NgramsPatch # mempty
+instance Validity NgramsPatch where
+  validate p = p ^. _NgramsPatch . to validate
+instance Transformable NgramsPatch where
+  transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
+
+  conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
+
+  transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
+    where
+      (p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
+
+-- The JSON encoding is untagged, this is OK since the field names are disjoints and thus the encoding is unambiguous.
+-- TODO: the empty object should be accepted and treated as mempty.
+deriveJSON (unPrefixUntagged "_") ''NgramsPatch
+makeLenses ''NgramsPatch
+
+-- TODO: This instance is simplified since we should either have the fields children and/or list
+-- or the fields old and/or new.
+instance ToSchema NgramsPatch where
+  declareNamedSchema _ = do
+    childrenSch <- declareSchemaRef (Proxy :: Proxy (PatchMSet NgramsTerm))
+    listSch <- declareSchemaRef (Proxy :: Proxy (Replace ListType))
+    nreSch <- declareSchemaRef (Proxy :: Proxy NgramsRepoElement)
+    return $ NamedSchema (Just "NgramsPatch") $ mempty
+            & type_ ?~ SwaggerObject
+            & properties .~
+                InsOrdHashMap.fromList
+                [ ("children", childrenSch)
+                , ("list",     listSch)
+                , ("old",      nreSch)
+                , ("new",      nreSch)
+                ]
+
+instance Arbitrary NgramsPatch where
+  arbitrary = frequency [ (9, NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary))
+                        , (1, NgramsReplace <$> arbitrary <*> arbitrary)
+                        ]
+
+instance Serialise NgramsPatch
+
+
+------------------------------------------------------------------------
+type NgramsTableMap = Map NgramsTerm NgramsRepoElement
+
+
+newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
+  deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
+
+instance Serialise NgramsTablePatch
+instance Serialise (PatchMap NgramsTerm NgramsPatch)
+
+instance FromField NgramsTablePatch
+  where
+    fromField = fromField'
+
+instance FromField (PatchMap SchemaNgrams.NgramsType (PatchMap NodeId NgramsTablePatch))
+  where
+    fromField = fromField'
+
+
+
+type PatchedNgramsPatch = Maybe NgramsRepoElement
+type instance Patched NgramsPatch = PatchedNgramsPatch
+
+type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
+  -- ~ Patched (PatchMap NgramsTerm NgramsPatch)
+type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
+
+makePrisms ''NgramsTablePatch
+instance ToSchema  (PatchMap NgramsTerm NgramsPatch)
+instance ToSchema  NgramsTablePatch
+
+instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
+  applicable p = applicable (p ^. _NgramsTablePatch)
+
+
+
+type ConflictResolutionNgramsPatch =
+  ( ConflictResolutionReplace (Maybe NgramsRepoElement)
+  , ( ConflictResolutionPatchMSet NgramsTerm
+    , ConflictResolutionReplace ListType
+    )
+  , (Bool, Bool)
+  )
+type instance ConflictResolution NgramsPatch =
+  ConflictResolutionNgramsPatch
+
+type instance ConflictResolution NgramsTablePatch =
+  NgramsTerm -> ConflictResolutionNgramsPatch
+
+instance Applicable (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
+  applicable (PairPatch (c, l)) n = applicable c (n ^. nre_children) <> applicable l (n ^. nre_list)
+
+instance Action (PairPatch (PatchMSet NgramsTerm) (Replace ListType)) NgramsRepoElement where
+  act (PairPatch (c, l)) = (nre_children %~ act c)
+                         . (nre_list     %~ act l)
+
+instance Applicable NgramsPatch (Maybe NgramsRepoElement) where
+  applicable p = applicable (p ^. _NgramsPatch)
+
+instance Action NgramsPatch (Maybe NgramsRepoElement) where
+  act p = act (p ^. _NgramsPatch)
+
+
+type NgramsPatchIso =
+  MaybePatch NgramsRepoElement (PairPatch (PatchMSet NgramsTerm) (Replace ListType))
+
+_NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
+_NgramsPatch = iso unwrap wrap
+  where
+    unwrap (NgramsPatch c l) = Mod $ PairPatch (c, l)
+    unwrap (NgramsReplace o n) = replace o n
+    wrap x =
+      case unMod x of
+        Just (PairPatch (c, l)) -> NgramsPatch c l
+        Nothing -> NgramsReplace (x ^? old . _Just) (x ^? new . _Just)
+

src/Gargantext/Core/Viz/Graph.hs

@@ -24,9 +24,9 @@ import qualified Data.Aeson as DA
 import qualified Data.Text as T
 import qualified Text.Read as T
 
-import Gargantext.API.Ngrams.Types (NgramsTerm(..), NgramsRepoElement(..), mSetToList)
 import Gargantext.Core.Methods.Distances (GraphMetric)
 import Gargantext.Core.Types (ListId)
+import Gargantext.Core.Types.Ngrams (NgramsTerm(..), NgramsRepoElement(..), mSetToList)
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
 import Gargantext.Database.Admin.Types.Node (NodeId)
 import Gargantext.Prelude

src/Gargantext/Core/Viz/Graph/Tools.hs

@@ -21,11 +21,11 @@ import Data.Maybe (fromMaybe)
 import Data.Swagger hiding (items)
 import GHC.Float (sin, cos)
 import GHC.Generics (Generic)
-import Gargantext.API.Ngrams.Types (NgramsTerm(..))
 import Gargantext.Core.Methods.Distances (Distance(..), measure)
 import Gargantext.Core.Methods.Distances.Conditional (conditional)
 import Gargantext.Core.Methods.Graph.BAC.Proxemy (confluence)
 import Gargantext.Core.Statistics
+import Gargantext.Core.Types.Ngrams (NgramsTerm(..))
 import Gargantext.Core.Viz.Graph
 import Gargantext.Core.Viz.Graph.Bridgeness (bridgeness, Partitions, ToComId(..))
 import Gargantext.Core.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map, Index, MatrixShape(..))

src/Gargantext/Database/Action/Metrics/NgramsByContext.hs

@@ -26,8 +26,8 @@ import Data.Text (Text)
 import Data.Tuple.Extra (first, second, swap)
 import Database.PostgreSQL.Simple.SqlQQ (sql)
 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
-import Gargantext.API.Ngrams.Types (NgramsTerm(..))
 import Gargantext.Core
+import Gargantext.Core.Types.Ngrams (NgramsTerm(..))
 import Gargantext.Data.HashMap.Strict.Utils as HM
 import Gargantext.Database.Admin.Types.Node (ListId, CorpusId, NodeId(..), ContextId, MasterCorpusId, NodeType(NodeDocument), UserCorpusId, DocId)
 import Gargantext.Database.Prelude (Cmd, runPGSQuery)

src/Gargantext/Database/Action/Metrics/TFICF.hs

@@ -21,6 +21,7 @@ import qualified Data.HashMap.Strict as HM
 import Data.Maybe (fromMaybe)
 import Gargantext.Core
 import Gargantext.Core.Text.Metrics.TFICF
+import Gargantext.Core.Types.Ngrams (NgramsTerm)
 import Gargantext.Database.Action.Metrics.NgramsByContext (getContextsByNgramsUser, {-getOccByNgramsOnlyFast,-} getOccByNgramsOnlyFast_withSample)
 import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
 import Gargantext.Database.Prelude (Cmd)

src/Gargantext/Database/NodeStory.hs

+{-# LANGUAGE TemplateHaskell           #-}
+
+module Gargantext.Database.NodeStory where
+
+import Data.Map.Strict (Map)
+import Data.Map.Strict.Patch (PatchMap)
+import Gargantext.Core.NodeStory (Archive(..), NodeStory(..))
+import Gargantext.Core.Types (NodeId)
+import Gargantext.Core.Types.Ngrams (NgramsTableMap, NgramsTablePatch)
+import Gargantext.Database.Prelude (Cmd)
+import Gargantext.Database.Query.Table.Ngrams (NgramsType)
+import Gargantext.Database.Schema.Ngrams (NgramsType(..))
+import Gargantext.Prelude
+import Opaleye
+
+getNodeStory :: NodeId -> Cmd err [NodeStory]
+getNodeStory nodeId = runOpaQuery query
+  where
+    query = do
+      restrict -< _node_id
+
+--queryNodeStories :: Select (Node)
+
+type NodeListStory     = NodeStory NgramsState' NgramsStatePatch'
+
+data NodeStory' a b = NodeStory' { node_id :: a
+                                 , archive :: b }
+type NodeListStoryQ = NodeStory' Int (Archive NgramsState' NgramsStatePatch')
+type NgramsState'      = Map       NgramsType NgramsTableMap
+type NgramsStatePatch' = PatchMap  NgramsType NgramsTablePatch
+
+type NodeStoryField = NodeStory' (Field SqlInt4) (Field SqlJsonb)
+
+$(makeAdaptorAndInstance "pNodeStory" ''NodeStory')
+
+nodeStoryTable :: Table NodeStoryField NodeStoryField
+nodeStoryTable =
+  Table "node_stories"
+    ( pNodeStory NodeListStoryQ { node_id = tableField "node_id"
+                                , archive = tableField "archive" } )
+
+nodeStorySelect :: Select NodeStoryField
+nodeStorySelect = selectTable nodeStoryTable