src/Gargantext/Database/Schema/NodeNgrams.hs

   1 {-|
   2 Module      : Gargantext.Database.Schema.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
  15 {-# OPTIONS_GHC -fno-warn-orphans #-}
  16
  17 {-# LANGUAGE Arrows                 #-}
  18 {-# LANGUAGE FlexibleContexts       #-}
  19 {-# LANGUAGE FlexibleInstances      #-}
  20 {-# LANGUAGE FunctionalDependencies #-}
  21 {-# LANGUAGE QuasiQuotes            #-}
  22 {-# LANGUAGE MultiParamTypeClasses  #-}
  23 {-# LANGUAGE NoImplicitPrelude      #-}
  24 {-# LANGUAGE OverloadedStrings      #-}
  25 {-# LANGUAGE RankNTypes             #-}
  26 {-# LANGUAGE TemplateHaskell        #-}
  27
  28 module Gargantext.Database.Schema.NodeNgrams where
  29
  30 import Data.List.Extra (nubOrd)
  31 import Data.Map (Map)
  32 import Data.Maybe (Maybe, fromMaybe)
  33 import Data.Text (Text)
  34 import Database.PostgreSQL.Simple (FromRow)
  35 import Database.PostgreSQL.Simple.FromRow (fromRow, field)
  36 import Database.PostgreSQL.Simple.SqlQQ (sql)
  37 import Database.PostgreSQL.Simple.ToField (toField)
  38 import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
  39 import Gargantext.Core.Types
  40 import Gargantext.Database.Admin.Utils
  41 import Gargantext.Database.Schema.Ngrams (NgramsType, ngramsTypeId, fromNgramsTypeId)
  42 import Gargantext.Prelude
  43 import qualified Data.List as List
  44 import qualified Data.Map as Map
  45 import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
  46
  47 type NodeNgramsId = Int
  48
  49 data NodeNgramsPoly id
  50                     node_id'
  51                     node_subtype
  52                     ngrams_id
  53                     ngrams_type
  54                     ngrams_field
  55                     ngrams_tag
  56                     ngrams_class
  57                     weight
  58                    = NodeNgrams { _nng_id            :: !id
  59                                 , _nng_node_id       :: !node_id'
  60                                 , _nng_node_subtype  :: !node_subtype
  61                                 , _nng_ngrams_id     :: !ngrams_id
  62                                 , _nng_ngrams_type   :: !ngrams_type
  63                                 , _nng_ngrams_field  :: !ngrams_field
  64                                 , _nng_ngrams_tag    :: !ngrams_tag
  65                                 , _nng_ngrams_class  :: !ngrams_class
  66                                 , _nng_ngrams_weight :: !weight
  67                               } deriving (Show, Eq, Ord)
  68
  69 {-
  70
  71 type NodeNgramsWrite = NodeNgramsPoly (Maybe (Column (PGInt4)))
  72                                       (Column (PGInt4))
  73                                       (Maybe  (Column (PGInt4)))
  74                                       (Column (PGInt4))
  75                                       (Maybe  (Column (PGInt4)))
  76                                       (Maybe  (Column (PGInt4)))
  77                                       (Maybe  (Column (PGInt4)))
  78                                       (Maybe  (Column (PGInt4)))
  79                                       (Maybe  (Column (PGFloat8)))
  80
  81 type NodeNodeRead    = NodeNgramsPoly (Column PGInt4)
  82                                       (Column PGInt4)
  83                                       (Column PGInt4)
  84                                       (Column PGInt4)
  85                                       (Column PGInt4)
  86                                       (Column PGInt4)
  87                                       (Column PGInt4)
  88                                       (Column PGInt4)
  89                                       (Column PGFloat8)
  90
  91 type NodeNgramsReadNull = NodeNgramsPoly (Column (Nullable PGInt4))
  92                                          (Column (Nullable PGInt4))
  93                                          (Column (Nullable PGInt4))
  94                                          (Column (Nullable PGInt4))
  95
  96                                          (Column (Nullable PGInt4))
  97                                          (Column (Nullable PGInt4))
  98                                          (Column (Nullable PGInt4))
  99                                          (Column (Nullable PGInt4))
 100                                          (Column (Nullable PGFloat8))
 101 -}
 102 type NgramsId = Int
 103 type NgramsField = Int
 104 type NgramsTag   = Int
 105 type NgramsClass = Int
 106 type NgramsText  = Text
 107
 108 -- Example of list Ngrams
 109 -- type ListNgrams = NodeNgramsPoly (Maybe Int) ListType Text
 110
 111 type NodeNgramsW =
 112   NodeNgramsPoly (Maybe Int) NodeId ListType NgramsText
 113                   NgramsType (Maybe NgramsField) (Maybe NgramsTag) (Maybe NgramsClass)
 114                   Double
 115
 116 data Returning = Returning { re_type      :: !(Maybe NgramsType)
 117                            , re_terms     :: !Text
 118                            , re_ngrams_id :: !Int
 119                            }
 120   deriving (Show)
 121
 122 instance FromRow Returning where
 123   fromRow = Returning <$> (fromNgramsTypeId <$> field) <*> field <*> field
 124
 125 getCgramsId :: Map NgramsType (Map Text Int) -> NgramsType -> Text -> Maybe Int
 126 getCgramsId mapId nt t = case Map.lookup nt mapId of
 127   Nothing     -> Nothing
 128   Just mapId' -> Map.lookup t mapId'
 129
 130
 131 -- insertDb :: ListId -> Map NgramsType [NgramsElement] -> Cmd err [Result]
 132 listInsertDb :: Show a => ListId
 133              -> (ListId -> a -> [NodeNgramsW])
 134              -> a
 135              -- -> Cmd err [Returning]
 136              -> Cmd err (Map NgramsType (Map Text Int))
 137 listInsertDb l f ngs = Map.map Map.fromList
 138                     <$> Map.fromListWith (<>)
 139                     <$> List.map (\(Returning t tx id) -> (fromJust t, [(tx, id)]))
 140                     <$> List.filter (\(Returning t _ _) -> isJust t)
 141                     <$> insertNodeNgrams (f l ngs)
 142
 143 -- TODO optimize with size of ngrams
 144 insertNodeNgrams :: [NodeNgramsW] -> Cmd err [Returning]
 145 insertNodeNgrams nns = runPGSQuery query (PGS.Only $ Values fields nns')
 146   where
 147     fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"
 148                                                       ,"int4","int4","int4","int4"
 149                                                       ,"float8"]
 150     -- nns' :: [(Int, ListTypeId, NgramsText, NgramsTypeId ,NgramsField, NgramsTag, NgramsClass, Double)]
 151     nns' = map (\(NodeNgrams _id (NodeId node_id'') node_subtype ngrams_terms ngrams_type ngrams_field ngrams_tag ngrams_class weight)
 152                               -> [ toField node_id''
 153                                  , toField $ listTypeId node_subtype
 154                                  , toField $ ngrams_terms
 155                                  , toField $ ngramsTypeId ngrams_type
 156                                  , toField $ fromMaybe 0 ngrams_field
 157                                  , toField $ fromMaybe 0 ngrams_tag
 158                                  , toField $ fromMaybe 0 ngrams_class
 159                                  , toField weight
 160                                  ]
 161                   ) $ nubOrd nns
 162
 163     query :: PGS.Query
 164     query = [sql|
 165           WITH input(node_id, node_subtype, ngrams_terms, ngrams_type, ngrams_field, ngrams_tag, ngrams_class, weight) AS (?),
 166           return(id, ngrams_type, ngrams_id) AS (
 167             INSERT INTO node_ngrams (node_id, node_subtype, ngrams_id, ngrams_type, ngrams_field, ngrams_tag, ngrams_class, weight)
 168             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
 169             INNER JOIN ngrams as ng ON ng.terms = i.ngrams_terms
 170             ON CONFLICT(node_id, node_subtype, ngrams_id) DO NOTHING
 171             -- 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
 172             RETURNING id, ngrams_type, ngrams_id
 173           )
 174           SELECT return.ngrams_type, ng.terms, return.id FROM return
 175           INNER JOIN ngrams ng ON return.ngrams_id = ng.id;
 176   |]