[Scores of PatchMap] main fun (WIP)

src/Gargantext/API/Ngrams/Types.hs

@@ -342,11 +342,13 @@ 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
 

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

@@ -11,15 +11,16 @@ Portability : POSIX
 module Gargantext.Core.Text.List.Social.History
   where
 
-import Data.Map (Map)
 import Control.Lens hiding (cons)
+import Data.Map (Map)
 import Gargantext.API.Ngrams.Types
+import Gargantext.Core.Text.List.Social.Prelude
+import Gargantext.Core.Types (ListId)
+import Gargantext.Database.Schema.Ngrams (NgramsType(..))
 import Gargantext.Prelude
-import Gargantext.Core.Types (ListId, NodeId)
-import qualified Data.Map.Strict.Patch as PatchMap
-import qualified Data.Map.Strict as Map
 import qualified Data.List as List
-import Gargantext.Database.Schema.Ngrams (NgramsType(..))
+import qualified Data.Map.Strict as Map
+import qualified Data.Map.Strict.Patch as PatchMap
 
 
 userHistory :: [NgramsType]
@@ -57,7 +58,7 @@ merge = Map.unionsWith merge'
 
 
 toMap :: PatchMap NgramsType
-           (PatchMap NodeId
+           (PatchMap ListId
             (NgramsTablePatch
             )
           )
@@ -66,11 +67,6 @@ toMap :: PatchMap NgramsType
             (Map NgramsTerm NgramsPatch
             )
            )
-toMap = Map.map (Map.map unNgramsTablePatch) . (Map.map toMap') . toMap'
-  where
-    toMap' :: Ord a => PatchMap a b -> Map a b
-    toMap' = Map.fromList . PatchMap.toList
+toMap = Map.map (Map.map unNgramsTablePatch) . (Map.map unPatchMap) . unPatchMap
 
-    unNgramsTablePatch :: NgramsTablePatch -> Map NgramsTerm NgramsPatch
-    unNgramsTablePatch (NgramsTablePatch p) = toMap' p
 

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

@@ -11,21 +11,50 @@ Portability : POSIX
 module Gargantext.Core.Text.List.Social.Patch
   where
 
-import Data.Text (Text)
-import Data.Monoid
 import Control.Lens hiding (cons)
-import Gargantext.Prelude
-import Gargantext.Core.Text.List.Social.Prelude
+import Data.Map (Map)
+import Data.Maybe (fromMaybe, maybe)
+import Data.Monoid
+import Data.Text (Text)
 import Gargantext.API.Ngrams.Types
+import Gargantext.Core.Text.List.Social.Prelude
+import Gargantext.Core.Types (ListId)
 import Gargantext.Core.Types.Main (ListType)
+import Gargantext.Database.Schema.Ngrams (NgramsType(..))
+import Gargantext.Prelude
+import qualified Data.List as List
+import qualified Data.Map  as Map
 import qualified Data.Patch.Class as Patch (Replace(..))
 
 {-
 fromList [(NgramsTerms,fromList [(NodeId 189,
 -}
 
-addScorePatch :: (NgramsTerm , NgramsPatch)
-              -> FlowCont Text FlowListScores
+addScorePaches :: NgramsType -> [ListId]
+               -> Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch])
+               -> FlowCont Text FlowListScores
+               -> FlowCont Text FlowListScores
+addScorePaches nt listes repo fl = foldl' (addScorePachesList nt repo) fl listes
+
+
+addScorePachesList :: NgramsType
+                   -> Map NgramsType (Map ListId [Map NgramsTerm NgramsPatch])
+                   -> FlowCont Text FlowListScores
+                   -> ListId
+                   -> FlowCont Text FlowListScores
+addScorePachesList nt repo fl lid = foldl' addScorePatch fl patches
+  where
+    patches = maybe [] (List.concat . (map Map.toList)) patches'
+
+    patches' = do
+      lists      <- Map.lookup nt repo
+      mapPatches <- Map.lookup lid lists
+      pure mapPatches
+
+
+
+addScorePatch :: FlowCont Text FlowListScores
+              -> (NgramsTerm , NgramsPatch)
               -> FlowCont Text FlowListScores
 {- | Case of changing listType only. Patches look like:
 
@@ -41,7 +70,7 @@ Children are not modified in this specific case.
 -- New list get +1 score
 -- Hence others lists lay around 0 score
 -- TODO add children
-addScorePatch (NgramsTerm t, (NgramsPatch _children (Patch.Replace old_list new_list))) fl =
+addScorePatch fl (NgramsTerm t, (NgramsPatch _children (Patch.Replace old_list new_list))) =
   fl & flc_scores . at t %~ (score fls_listType old_list (-1))
      & flc_scores . at t %~ (score fls_listType new_list ( 1))
      
@@ -49,24 +78,26 @@ addScorePatch (NgramsTerm t, (NgramsPatch _children (Patch.Replace old_list new_
 [fromList [(NgramsTerm {unNgramsTerm = "approach"},NgramsPatch {_patch_children = PatchMSet (PatchMap (fromList [(NgramsTerm {unNgramsTerm = "order"},Replace {_old = Just (), _new = Nothing})])), _patch_list = Keep})]
 ,fromList [(NgramsTerm {unNgramsTerm = "approach"},NgramsPatch {_patch_children = PatchMSet (PatchMap (fromList [(NgramsTerm {unNgramsTerm = "order"},Replace {_old = Nothing, _new = Just ()})])), _patch_list = Keep})]
 -}
-addScorePatch (NgramsTerm t, NgramsPatch children Patch.Keep) fl = undefined
-{-
-      addParent = flc_scores . at t %~ (score MapTerm  1)
+addScorePatch fl (NgramsTerm t, NgramsPatch children Patch.Keep) = foldl' add fl $ toList children
+  where
+      add fl' (NgramsTerm t, Patch.Replace Nothing (Just _)) = doLink ( 1) t fl'
+      add fl' (NgramsTerm t, Patch.Replace (Just _) Nothing) = doLink (-1) t fl'
+      add _ _ = panic "addScorePatch: Error should not happen"
 
+      toList :: Ord a => PatchMSet a -> [(a,AddRem)]
+      toList = Map.toList . unPatchMap . unPatchMSet
 
-      parent term n m = (Just mempty <> m)
-                     & _Just
-                     . fls_listType
-                     . at list
-                     %~ (<> Just n)
--}
+      doLink n child fl' = fl' & flc_scores . at child %~ (score fls_parents child n)
 
 
+-- | TODO
+addScorePatch _ (NgramsTerm _, NgramsReplace _nre Nothing) =
+  panic "[G.C.T.L.S.P.addScorePatch] TODO needs nre"
 
 {- | Inserting a new Ngrams
 fromList [(NgramsTerm {unNgramsTerm = "journal"},NgramsReplace {_patch_old = Nothing, _patch_new = Just (NgramsRepoElement {_nre_size = 1, _nre_list = CandidateTerm, _nre_root = Nothing, _nre_parent = Nothing, _nre_children = MSet (fromList [])})})],f
 -}
-addScorePatch (NgramsTerm t, NgramsReplace _ (Just nre)) fl        =
+addScorePatch fl (NgramsTerm t, NgramsReplace _ (Just nre)) =
   fl & flc_scores . at t %~ (score fls_listType $ nre ^. nre_list) ( 1)
 
 

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

@@ -19,14 +19,16 @@ module Gargantext.Core.Text.List.Social.Prelude
   where
 
 import Control.Lens
-import Data.Semigroup (Semigroup(..))
-import Data.Monoid
 import Data.Map (Map)
+import Data.Monoid
+import Data.Semigroup (Semigroup(..))
 import Data.Text (Text)
+import GHC.Generics (Generic)
+import Gargantext.API.Ngrams.Types
 import Gargantext.Core.Types.Main
 import Gargantext.Prelude
-import GHC.Generics (Generic)
 import qualified Data.Map   as Map
+import qualified Data.Map.Strict.Patch as PatchMap
 
 ------------------------------------------------------------------------
 type Parent = Text
@@ -108,3 +110,12 @@ hasParent t m = case Map.lookup t m of
 keyWithMaxValue :: Map a b -> Maybe a
 keyWithMaxValue m = (fst . fst) <$> Map.maxViewWithKey m
 
+
+------------------------------------------------------------------------
+unPatchMap :: Ord a => PatchMap a b -> Map a b
+unPatchMap = Map.fromList . PatchMap.toList
+
+unNgramsTablePatch :: NgramsTablePatch -> Map NgramsTerm NgramsPatch
+unNgramsTablePatch (NgramsTablePatch p) = unPatchMap p
+
+

stack.yaml

@@ -3,8 +3,8 @@ flags: {}
 extra-package-dbs: []
 packages:
 - .
-#- 'deps/patches-class'
-#- 'deps/patches-map'
+- 'deps/patches-class'
+- 'deps/patches-map'
 #- 'deps/servant-job'
 #- 'deps/clustering-louvain'
 
@@ -44,14 +44,15 @@ extra-deps:
 - git: https://gitlab.iscpif.fr/gargantext/crawlers/isidore.git
   commit: 3db385e767d2100d8abe900833c6e7de3ac55e1b
     #
-- git: https://gitlab.com/npouillard/patches-class.git  
-  commit: 4712bfb055888fae63cd2e88431972375f979b94
+
+  #- git: https://gitlab.com/npouillard/patches-class.git  
+  #commit: 4712bfb055888fae63cd2e88431972375f979b94
 
   #- git: https://github.com/np/servant-job.git # waiting for PR
 - git: https://github.com/delanoe/servant-job.git
   commit: a9d8ec247b60906ae0ad76ea017cacd6ff36a7a1
-- git: https://github.com/np/patches-map
-  commit: d42c37de5046ba22abcb5e21c121d1072126f3cc
+  #- git: https://github.com/np/patches-map
+  #commit: d42c37de5046ba22abcb5e21c121d1072126f3cc
 - git: https://github.com/delanoe/haskell-opaleye.git  #- opaleye-0.6.7002.0
   commit: 63ee65d974e9d20eaaf17a2e83652175988cbb79
 - git: https://github.com/delanoe/hsparql.git