src/Gargantext/Database/Action/Flow/List.hs

   1 {-|
   2 Module      : Gargantext.Database.Flow.List
   3 Description : List Flow
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# OPTIONS_GHC -fno-warn-orphans    #-}
  13
  14 {-# LANGUAGE ConstraintKinds         #-}
  15 {-# LANGUAGE RankNTypes              #-}
  16 {-# LANGUAGE ConstrainedClassMethods #-}
  17 {-# LANGUAGE ConstraintKinds         #-}
  18 {-# LANGUAGE DeriveGeneric           #-}
  19 {-# LANGUAGE FlexibleContexts        #-}
  20 {-# LANGUAGE InstanceSigs            #-}
  21 {-# LANGUAGE NoImplicitPrelude       #-}
  22 {-# LANGUAGE OverloadedStrings       #-}
  23
  24 module Gargantext.Database.Action.Flow.List
  25     where
  26 import Data.Text (Text)
  27 import Control.Monad (mapM_)
  28 import Data.Map (Map, toList)
  29 import Data.Maybe (Maybe(..), catMaybes)
  30 import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams)
  31 import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams,  NgramsType(..), text2ngrams, ngramsTypeId)
  32 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
  33 import Gargantext.Database.Schema.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
  34 import Gargantext.Database.Schema.Node_NodeNgramsNodeNgrams -- (insert_Node_NodeNgrams_NodeNgrams, Node_NodeNgrams_NodeNgrams(..))
  35 import Gargantext.Database.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
  36 import Gargantext.Database.Flow.Types
  37 import Gargantext.Prelude
  38 import qualified Data.List as List
  39 import qualified Data.Map  as Map
  40
  41
  42 -- FLOW LIST
  43 -- | TODO check optimization
  44 mapNodeIdNgrams :: [DocumentIdWithNgrams a]
  45                 -> Map Ngrams (Map NgramsType (Map NodeId Int))
  46 mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
  47   where
  48     f :: DocumentIdWithNgrams a
  49       -> Map Ngrams (Map NgramsType (Map NodeId Int))
  50     f d = fmap (fmap (Map.singleton nId)) $ document_ngrams d
  51       where
  52         nId = documentId $ documentWithId d
  53
  54 ------------------------------------------------------------------------
  55 flowList_DbRepo :: FlowCmdM env err m
  56          => ListId
  57          -> Map NgramsType [NgramsElement]
  58          -> m ListId
  59 flowList_DbRepo lId ngs = do
  60   -- printDebug "listId flowList" lId
  61   mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
  62   let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> parent)
  63                                  <*>  getCgramsId mapCgramsId ntype ngram
  64                            | (ntype, ngs') <- Map.toList ngs
  65                            , NgramsElement ngram _ _ _ _ parent _ <- ngs'
  66                            ]
  67   -- Inserting groups of ngrams
  68   _r <- insert_Node_NodeNgrams_NodeNgrams
  69      $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert
  70   listInsert lId ngs
  71   --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
  72   pure lId
  73 ------------------------------------------------------------------------
  74 ------------------------------------------------------------------------
  75
  76 toNodeNgramsW :: ListId
  77               -> [(NgramsType, [NgramsElement])]
  78               -> [NodeNgramsW]
  79 toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
  80   where
  81     toNodeNgramsW'' :: ListId
  82                   -> (NgramsType, [NgramsElement])
  83                   -> [NodeNgramsW]
  84     toNodeNgramsW'' l' (ngrams_type, elms) =
  85       [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
  86        (NgramsElement ngrams_terms' _size list_type _occ _root _parent _children) <- elms
  87       ]
  88
  89 toNodeNgramsW' :: ListId
  90                -> [(Text, [NgramsType])]
  91                -> [NodeNgramsW]
  92 toNodeNgramsW' l'' ngs = [ NodeNgrams Nothing l'' CandidateTerm terms ngrams_type Nothing Nothing Nothing 0
  93                          | (terms, ngrams_types) <- ngs
  94                          , ngrams_type <- ngrams_types
  95                          ]
  96
  97
  98 listInsert :: FlowCmdM env err m
  99              => ListId
 100              -> Map NgramsType [NgramsElement]
 101              -> m ()
 102 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 103                              -> putListNgrams lId typeList ngElmts
 104                              ) $ toList ngs
 105
 106 ------------------------------------------------------------------------
 107 ------------------------------------------------------------------------