[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/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