]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Query/Table/NodeNgrams.hs
Merge branch 'dev-list-charts' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell...
[gargantext.git] / src / Gargantext / Database / Query / Table / NodeNgrams.hs
1 {-|
2 Module : Gargantext.Database.Query.Table.NodeNgrams
3 Description :
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 NodeNgrams register Context of Ngrams (named Cgrams then)
11
12 -}
13
14 {-# OPTIONS_GHC -fno-warn-orphans #-}
15
16 {-# LANGUAGE Arrows #-}
17 {-# LANGUAGE FunctionalDependencies #-}
18 {-# LANGUAGE QuasiQuotes #-}
19 {-# LANGUAGE TemplateHaskell #-}
20
21 module Gargantext.Database.Query.Table.NodeNgrams
22 ( getCgramsId
23 , listInsertDb
24 , module Gargantext.Database.Schema.NodeNgrams
25 )
26 where
27
28 import Data.List.Extra (nubOrd)
29 import Data.Map (Map)
30 import Data.Maybe (Maybe, fromMaybe)
31 import Data.Text (Text)
32 import Database.PostgreSQL.Simple (FromRow)
33 import Database.PostgreSQL.Simple.FromRow (fromRow, field)
34 import Database.PostgreSQL.Simple.SqlQQ (sql)
35 import Database.PostgreSQL.Simple.ToField (toField)
36 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
37 import Gargantext.Core.Types
38 import Gargantext.Database.Prelude
39 import Gargantext.Database.Schema.Ngrams (NgramsType, ngramsTypeId, fromNgramsTypeId)
40 import Gargantext.Database.Schema.NodeNgrams
41 import Gargantext.Prelude
42 import qualified Data.List as List
43 import qualified Data.Map as Map
44 import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
45
46
47 -- | Type for query return
48 data Returning = Returning { re_type :: !(Maybe NgramsType)
49 , re_terms :: !Text
50 , re_ngrams_id :: !Int
51 }
52 deriving (Show)
53
54 instance FromRow Returning where
55 fromRow = Returning <$> (fromNgramsTypeId <$> field) <*> field <*> field
56
57 getCgramsId :: Map NgramsType (Map Text Int) -> NgramsType -> Text -> Maybe Int
58 getCgramsId mapId nt t = case Map.lookup nt mapId of
59 Nothing -> Nothing
60 Just mapId' -> Map.lookup t mapId'
61
62
63 -- insertDb :: ListId -> Map NgramsType [NgramsElement] -> Cmd err [Result]
64 listInsertDb :: Show a => ListId
65 -> (ListId -> a -> [NodeNgramsW])
66 -> a
67 -- -> Cmd err [Returning]
68 -> Cmd err (Map NgramsType (Map Text Int))
69 listInsertDb l f ngs = Map.map Map.fromList
70 <$> Map.fromListWith (<>)
71 <$> List.map (\(Returning t tx id) -> (fromJust t, [(tx, id)]))
72 <$> List.filter (\(Returning t _ _) -> isJust t)
73 <$> insertNodeNgrams (f l ngs)
74
75 -- TODO optimize with size of ngrams
76 insertNodeNgrams :: [NodeNgramsW] -> Cmd err [Returning]
77 insertNodeNgrams nns = runPGSQuery query (PGS.Only $ Values fields nns')
78 where
79 fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"
80 ,"int4","int4","int4","int4"
81 ,"float8"]
82 -- nns' :: [(Int, ListTypeId, NgramsText, NgramsTypeId ,NgramsField, NgramsTag, NgramsClass, Double)]
83 nns' = map (\(NodeNgrams _id (NodeId node_id'') node_subtype ngrams_terms ngrams_type ngrams_field ngrams_tag ngrams_class weight)
84 -> [ toField node_id''
85 , toField $ listTypeId node_subtype
86 , toField $ ngrams_terms
87 , toField $ ngramsTypeId ngrams_type
88 , toField $ fromMaybe 0 ngrams_field
89 , toField $ fromMaybe 0 ngrams_tag
90 , toField $ fromMaybe 0 ngrams_class
91 , toField weight
92 ]
93 ) $ nubOrd nns
94
95 query :: PGS.Query
96 query = [sql|
97 WITH input(node_id, node_subtype, ngrams_terms, ngrams_type, ngrams_field, ngrams_tag, ngrams_class, weight) AS (?),
98 return(id, ngrams_type, ngrams_id) AS (
99 INSERT INTO node_ngrams (node_id, node_subtype, ngrams_id, ngrams_type, ngrams_field, ngrams_tag, ngrams_class, weight)
100 SELECT i.node_id, i.node_subtype, ng.id, i.ngrams_type, i.ngrams_field, i.ngrams_tag, i.ngrams_class, i.weight FROM input as i
101 INNER JOIN ngrams as ng ON ng.terms = i.ngrams_terms
102 ON CONFLICT(node_id, node_subtype, ngrams_id) DO NOTHING
103 -- DO UPDATE SET node_subtype = excluded.node_subtype, ngrams_type = excluded.ngrams_type, ngrams_field = excluded.ngrams_field, ngrams_tag = excluded.ngrams_tag, ngrams_class = excluded.ngrams_class, weight = excluded.weight
104 RETURNING id, ngrams_type, ngrams_id
105 )
106 SELECT return.ngrams_type, ng.terms, return.id FROM return
107 INNER JOIN ngrams ng ON return.ngrams_id = ng.id;
108 |]