List.hs 8.18 KB
{-|
Module      : Gargantext.Database.Flow.List
Description : List Flow
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}

{-# LANGUAGE ConstraintKinds         #-}
{-# LANGUAGE ConstrainedClassMethods #-}

module Gargantext.Database.Action.Flow.List
    where

import Control.Lens ((+~), (%~), at)
import Data.List qualified as List
import Data.Map.Strict (toList)
import Data.Map.Strict qualified as Map
import Data.Map.Strict.Patch qualified as PM
import Gargantext.API.Ngrams (saveNodeStory)
import Gargantext.API.Ngrams.Tools (getNodeStory)
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory (HasNodeStory, a_history, a_state, a_version)
import Gargantext.Core.Text.Ngrams (NgramsType(..))
import Gargantext.Core.Types (HasValidationError(..), assertValid)
import Gargantext.Core.Types.Main (ListType(CandidateTerm))
import Gargantext.Database.Admin.Types.Node (ListId, NodeId)
import Gargantext.Database.Query.Table.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb,{- getCgramsId -})
import Gargantext.Prelude hiding (toList)

-- FLOW LIST
-- 1. select specific terms of the corpus when compared with others langs
-- (for now, suppose english)
-- 2. select specific terms of the corpus when compared with others corpora (same database)
-- 3. select clusters of terms (generic and specific)

{-
data FlowList = FlowListLang
              | FlowListTficf
              | FlowListSpeGen


flowList_Tficf :: UserCorpusId
               -> MasterCorpusId
               -> NgramsType
               -> (Text -> Text)
               -> Cmd err (Map Text (Double, Set Text))
flowList_Tficf u m nt f = do

  u' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsUser   u nt
  m' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsMaster u m

  pure $ sortTficf Down
       $ toTficfData (countNodesByNgramsWith f u')
                     (countNodesByNgramsWith f m')

flowList_Tficf' :: UserCorpusId
               -> MasterCorpusId
               -> NgramsType
               -> Cmd err (Map Text (Double, Set Text))
flowList_Tficf' u m nt f = do

  u' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsUser   u nt
  m' <- Map.filter (\s -> Set.size s > 1) <$> getNodesByNgramsMaster u m

  pure $ sortTficf Down
       $ toTficfData (countNodesByNgramsWith f u')
                     (countNodesByNgramsWith f m')

-}


------------------------------------------------------------------------
flowList_DbRepo :: (HasValidationError err, HasNodeStory env err m)
                => ListId
                -> Map NgramsType [NgramsElement]
                -> m ListId
flowList_DbRepo lId ngs = do
  -- printDebug "listId flowList" lId
  _mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
{-
  let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> (unNgramsTerm <$> parent))
                                 <*>  getCgramsId mapCgramsId ntype ngram
                           | (ntype, ngs') <- Map.toList ngs
                           , NgramsElement { _ne_ngrams = NgramsTerm ngram
                                           , _ne_parent = parent } <- ngs'
                           ]
-}
  -- Inserting groups of ngrams
  -- _r <- insert_Node_NodeNgrams_NodeNgrams
  --   $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert

  -- printDebug "flowList_Tficf':ngs" ngs
  listInsert lId ngs

  --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
  pure lId
------------------------------------------------------------------------
------------------------------------------------------------------------

toNodeNgramsW :: ListId
              -> [(NgramsType, [NgramsElement])]
              -> [NodeNgramsW]
toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
  where
    toNodeNgramsW'' :: ListId
                  -> (NgramsType, [NgramsElement])
                  -> [NodeNgramsW]
    toNodeNgramsW'' l' (ngrams_type, elms) =
      [ NodeNgrams { _nng_id            = Nothing
                   , _nng_node_id       = l'
                   , _nng_node_subtype  = list_type
                   , _nng_ngrams_id     = ngrams_terms'
                   , _nng_ngrams_type   = ngrams_type
                   , _nng_ngrams_field  = Nothing
                   , _nng_ngrams_tag    = Nothing
                   , _nng_ngrams_class  = Nothing
                   , _nng_ngrams_weight = 0 } |
       (NgramsElement { _ne_ngrams      = NgramsTerm ngrams_terms'
                      , _ne_size        = _size
                      , _ne_list        = list_type
                      , _ne_occurrences = _occ
                      , _ne_root        = _root
                      , _ne_parent      = _parent
                      , _ne_children    = _children
                      }
        ) <- elms
      ]


toNodeNgramsW' :: ListId
               -> [(Text, [NgramsType])]
               -> [NodeNgramsW]
toNodeNgramsW' l'' ngs = [ NodeNgrams { _nng_id            = Nothing
                                      , _nng_node_id       = l''
                                      , _nng_node_subtype  = CandidateTerm
                                      , _nng_ngrams_id     = terms
                                      , _nng_ngrams_type   = ngrams_type
                                      , _nng_ngrams_field  = Nothing
                                      , _nng_ngrams_tag    = Nothing
                                      , _nng_ngrams_class  = Nothing
                                      , _nng_ngrams_weight = 0
                                      }
                         | (terms, ngrams_types) <- ngs
                         , ngrams_type <- ngrams_types
                         ]


listInsert :: (HasValidationError err, HasNodeStory env err m)
           => ListId
           -> Map NgramsType [NgramsElement]
           -> m ()
listInsert lId ngs = mapM_ (\(typeList, ngElmts)
                             -> putListNgrams lId typeList ngElmts) (toList ngs)

------------------------------------------------------------------------
------------------------------------------------------------------------
-- 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 :: (HasValidationError err, HasNodeStory env err m)
              => NodeId
              -> 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' :: (HasValidationError err, HasNodeStory env err m)
                   => NodeId
                   -> NgramsType
                   -> Map NgramsTerm NgramsRepoElement
                   -> m ()
    putListNgrams' listId ngramsType' ns = do
      -- printDebug "[putListNgrams'] nodeId" nodeId
      -- printDebug "[putListNgrams'] ngramsType" ngramsType
      -- printDebug "[putListNgrams'] ns" ns

      let p1 = NgramsTablePatch . PM.fromMap $ NgramsReplace Nothing . Just <$> ns
          (p, p_validity) = PM.singleton ngramsType' p1
      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.
      -}
      a <- getNodeStory listId
      let a' = a & a_version +~ 1
                 & a_history %~ (p :)
                 & a_state . at ngramsType' .~ Just ns
      -- liftBase $ atomically $ do
      --   r <- readTVar var
      --   writeTVar var $
      --     r & unNodeStory . at listId . _Just . a_version +~ 1
      --       & unNodeStory . at listId . _Just . a_history %~ (p :)
      --       & unNodeStory . at listId . _Just . a_state . at ngramsType' .~ Just ns
      saveNodeStory listId a'