[FIX] lang + algo for select + fix warnings
[gargantext.git] / src / Gargantext / Database / Action / Flow / List.hs
index b11ab8a217ae6e87dac22c58f52f4363698e49ee..224545e535d0c787ad8513471ae3362dc43ec8f0 100644 (file)
@@ -9,37 +9,34 @@ Portability : POSIX
 
 -}
 
-{-# OPTIONS_GHC -fno-warn-orphans    #-}
-
 {-# LANGUAGE ConstraintKinds         #-}
-{-# LANGUAGE RankNTypes              #-}
 {-# LANGUAGE ConstrainedClassMethods #-}
 {-# LANGUAGE ConstraintKinds         #-}
-{-# LANGUAGE DeriveGeneric           #-}
-{-# LANGUAGE FlexibleContexts        #-}
 {-# LANGUAGE InstanceSigs            #-}
-{-# LANGUAGE NoImplicitPrelude       #-}
-{-# LANGUAGE OverloadedStrings       #-}
 
 module Gargantext.Database.Action.Flow.List
     where
 
-import Control.Monad (mapM_)
-import qualified Data.List as List
-import qualified Data.Map  as Map
+import Control.Concurrent
+import Control.Lens (view, (^.), (+~), (%~), at)
+import Control.Monad.Reader
 import Data.Map (Map, toList)
-import Data.Maybe (Maybe(..), catMaybes)
+import Data.Maybe (catMaybes)
 import Data.Text (Text)
-
-import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams)
-import Gargantext.Core.Flow.Types
+import Gargantext.API.Ngrams.Types (HasRepoSaver(..), NgramsElement(..), NgramsPatch(..), NgramsRepoElement(..), NgramsTablePatch(..), NgramsTerm(..), RepoCmdM, ne_ngrams, ngramsElementToRepo, r_history, r_state, r_version, repoVar)
+import Gargantext.Core.Types (HasInvalidError(..), assertValid)
 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
+import Gargantext.Core.Utils (something)
+import Gargantext.Database.Action.Flow.Types
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
-import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams,  NgramsType(..), text2ngrams, ngramsTypeId)
-import Gargantext.Database.Action.Flow.Types
 import Gargantext.Database.Query.Table.Node_NodeNgramsNodeNgrams
+import Gargantext.Database.Schema.Ngrams (NgramsType(..))
 import Gargantext.Prelude
+import qualified Data.List as List
+import qualified Data.Map  as Map
+import qualified Data.Map.Strict.Patch as PM
+import qualified Gargantext.Database.Query.Table.Ngrams as TableNgrams
 
 -- FLOW LIST
 -- 1. select specific terms of the corpus when compared with others langs
@@ -83,21 +80,6 @@ flowList_Tficf' u m nt f = do
 -}
 
 
-
-
-
-
--- | TODO check optimization
-mapNodeIdNgrams :: [DocumentIdWithNgrams a]
-                -> Map Ngrams (Map NgramsType (Map NodeId Int))
-mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
-  where
-    f :: DocumentIdWithNgrams a
-      -> Map Ngrams (Map NgramsType (Map NodeId Int))
-    f d = fmap (fmap (Map.singleton nId)) $ document_ngrams d
-      where
-        nId = documentId $ documentWithId d
-
 ------------------------------------------------------------------------
 flowList_DbRepo :: FlowCmdM env err m
          => ListId
@@ -106,10 +88,10 @@ flowList_DbRepo :: FlowCmdM env err m
 flowList_DbRepo lId ngs = do
   -- printDebug "listId flowList" lId
   mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
-  let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> parent)
+  let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> (unNgramsTerm <$> parent))
                                  <*>  getCgramsId mapCgramsId ntype ngram
                            | (ntype, ngs') <- Map.toList ngs
-                           , NgramsElement ngram _ _ _ _ parent _ <- ngs'
+                           , NgramsElement (NgramsTerm ngram) _ _ _ _ parent _ <- ngs'
                            ]
   -- Inserting groups of ngrams
   _r <- insert_Node_NodeNgrams_NodeNgrams
@@ -132,7 +114,7 @@ toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
                   -> [NodeNgramsW]
     toNodeNgramsW'' l' (ngrams_type, elms) =
       [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
-       (NgramsElement ngrams_terms' _size list_type _occ _root _parent _children) <- elms
+       (NgramsElement (NgramsTerm ngrams_terms') _size list_type _occ _root _parent _children) <- elms
       ]
 
 
@@ -154,3 +136,65 @@ listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------
+
+
+-- NOTE
+-- This is no longer part of the API.
+-- This function is maintained for its usage in Database.Action.Flow.List.
+-- If the given list of ngrams elements contains ngrams already in
+-- the repo, they will be ignored.
+putListNgrams :: (HasInvalidError err, RepoCmdM env err m)
+              => NodeId
+              -> TableNgrams.NgramsType
+              -> [NgramsElement]
+              -> m ()
+putListNgrams _ _ [] = pure ()
+putListNgrams nodeId ngramsType nes = putListNgrams' nodeId ngramsType m
+  where
+    m = Map.fromList $ map (\n -> (n ^. ne_ngrams, ngramsElementToRepo n)) nes
+
+putListNgrams' :: (HasInvalidError err, RepoCmdM env err m)
+               => NodeId
+               -> TableNgrams.NgramsType
+               -> Map NgramsTerm NgramsRepoElement
+               -> m ()
+putListNgrams' nodeId ngramsType ns = do
+  -- printDebug "[putListNgrams'] nodeId" nodeId
+  -- printDebug "[putListNgrams'] ngramsType" ngramsType
+  -- printDebug "[putListNgrams'] ns" ns
+
+  let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
+      (p0, p0_validity) = PM.singleton nodeId p1
+      (p, p_validity) = PM.singleton ngramsType p0
+  assertValid p0_validity
+  assertValid p_validity
+  {-
+  -- TODO
+  v <- currentVersion
+  q <- commitStatePatch (Versioned v p)
+  assert empty q
+  -- What if another commit comes in between?
+  -- Shall we have a blindCommitStatePatch? It would not ask for a version but just a patch.
+  -- The modifyMVar_ would test the patch with applicable first.
+  -- If valid the rest would be atomic and no merge is required.
+  -}
+  var <- view repoVar
+  liftBase $ modifyMVar_ var $ \r -> do
+    pure $ r & r_version +~ 1
+             & r_history %~ (p :)
+             & r_state . at ngramsType %~
+               (Just .
+                 (at nodeId %~
+                   ( Just
+                   . (<> ns)
+                   . something
+                   )
+                 )
+                 . something
+               )
+  saveRepo
+
+
+saveRepo :: ( MonadReader env m, MonadBase IO m, HasRepoSaver env )
+         => m ()
+saveRepo = liftBase =<< view repoSaver