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