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
  27 import Control.Monad (mapM_)
  28 import Data.Map (Map, toList)
  29 import Data.Maybe (Maybe(..), catMaybes)
  30 import Data.Text (Text)
  31 import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams)
  32 import Gargantext.Core.Types.Main (ListType(CandidateTerm))
  33 import Gargantext.Core.Flow.Types
  34 import Gargantext.Database.Action.Flow.Types
  35 import Gargantext.Database.Admin.Types.Node -- (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
  36 import Gargantext.Database.Schema.Ngrams -- (insertNgrams, Ngrams(..), NgramsIndexed(..), indexNgrams,  NgramsType(..), text2ngrams, ngramsTypeId)
  37 import Gargantext.Database.Schema.NodeNgrams (NodeNgramsPoly(..), NodeNgramsW, listInsertDb, getCgramsId)
  38 import Gargantext.Database.Schema.Node_NodeNgramsNodeNgrams -- (insert_Node_NodeNgrams_NodeNgrams, Node_NodeNgrams_NodeNgrams(..))
  39 import Gargantext.Prelude
  40 import qualified Data.List as List
  41 import qualified Data.Map  as Map
  42
  43
  44 -- FLOW LIST
  45 -- | TODO check optimization
  46 mapNodeIdNgrams :: [DocumentIdWithNgrams a]
  47                 -> Map Ngrams (Map NgramsType (Map NodeId Int))
  48 mapNodeIdNgrams = Map.unionsWith (Map.unionWith (Map.unionWith (+))) . fmap f
  49   where
  50     f :: DocumentIdWithNgrams a
  51       -> Map Ngrams (Map NgramsType (Map NodeId Int))
  52     f d = fmap (fmap (Map.singleton nId)) $ document_ngrams d
  53       where
  54         nId = documentId $ documentWithId d
  55
  56 ------------------------------------------------------------------------
  57 flowList_DbRepo :: FlowCmdM env err m
  58          => ListId
  59          -> Map NgramsType [NgramsElement]
  60          -> m ListId
  61 flowList_DbRepo lId ngs = do
  62   -- printDebug "listId flowList" lId
  63   mapCgramsId <- listInsertDb lId toNodeNgramsW (Map.toList ngs)
  64   let toInsert = catMaybes [ (,) <$> (getCgramsId mapCgramsId ntype <$> parent)
  65                                  <*>  getCgramsId mapCgramsId ntype ngram
  66                            | (ntype, ngs') <- Map.toList ngs
  67                            , NgramsElement ngram _ _ _ _ parent _ <- ngs'
  68                            ]
  69   -- Inserting groups of ngrams
  70   _r <- insert_Node_NodeNgrams_NodeNgrams
  71      $ map (\(a,b) -> Node_NodeNgrams_NodeNgrams lId a b Nothing) toInsert
  72
  73   listInsert lId ngs
  74
  75   --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
  76   pure lId
  77 ------------------------------------------------------------------------
  78 ------------------------------------------------------------------------
  79
  80 toNodeNgramsW :: ListId
  81               -> [(NgramsType, [NgramsElement])]
  82               -> [NodeNgramsW]
  83 toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
  84   where
  85     toNodeNgramsW'' :: ListId
  86                   -> (NgramsType, [NgramsElement])
  87                   -> [NodeNgramsW]
  88     toNodeNgramsW'' l' (ngrams_type, elms) =
  89       [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
  90        (NgramsElement ngrams_terms' _size list_type _occ _root _parent _children) <- elms
  91       ]
  92
  93
  94 toNodeNgramsW' :: ListId
  95                -> [(Text, [NgramsType])]
  96                -> [NodeNgramsW]
  97 toNodeNgramsW' l'' ngs = [ NodeNgrams Nothing l'' CandidateTerm terms ngrams_type Nothing Nothing Nothing 0
  98                          | (terms, ngrams_types) <- ngs
  99                          , ngrams_type <- ngrams_types
 100                          ]
 101
 102
 103 listInsert :: FlowCmdM env err m
 104              => ListId
 105              -> Map NgramsType [NgramsElement]
 106              -> m ()
 107 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 108                              -> putListNgrams lId typeList ngElmts) (toList ngs)
 109
 110 ------------------------------------------------------------------------
 111 ------------------------------------------------------------------------