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