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   listInsert lId ngs
  73   --trace (show $ List.filter (\n -> _ne_ngrams n == "versatile") $ List.concat $ Map.elems ngs) $ listInsert lId ngs
  74   pure lId
  75 ------------------------------------------------------------------------
  76 ------------------------------------------------------------------------
  77
  78 toNodeNgramsW :: ListId
  79               -> [(NgramsType, [NgramsElement])]
  80               -> [NodeNgramsW]
  81 toNodeNgramsW l ngs = List.concat $ map (toNodeNgramsW'' l) ngs
  82   where
  83     toNodeNgramsW'' :: ListId
  84                   -> (NgramsType, [NgramsElement])
  85                   -> [NodeNgramsW]
  86     toNodeNgramsW'' l' (ngrams_type, elms) =
  87       [ NodeNgrams Nothing l' list_type ngrams_terms' ngrams_type Nothing Nothing Nothing 0 |
  88        (NgramsElement ngrams_terms' _size list_type _occ _root _parent _children) <- elms
  89       ]
  90
  91 toNodeNgramsW' :: ListId
  92                -> [(Text, [NgramsType])]
  93                -> [NodeNgramsW]
  94 toNodeNgramsW' l'' ngs = [ NodeNgrams Nothing l'' CandidateTerm terms ngrams_type Nothing Nothing Nothing 0
  95                          | (terms, ngrams_types) <- ngs
  96                          , ngrams_type <- ngrams_types
  97                          ]
  98
  99
 100 listInsert :: FlowCmdM env err m
 101              => ListId
 102              -> Map NgramsType [NgramsElement]
 103              -> m ()
 104 listInsert lId ngs = mapM_ (\(typeList, ngElmts)
 105                              -> putListNgrams lId typeList ngElmts
 106                              ) $ toList ngs
 107
 108 ------------------------------------------------------------------------
 109 ------------------------------------------------------------------------