{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE Arrows #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE Arrows #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TemplateHaskell #-}
-- TODO NodeNgrams
module Gargantext.Database.Schema.NodeNgram where
+import Data.ByteString (ByteString)
import Data.Text (Text)
-import Control.Lens.TH (makeLensesWith, abbreviatedFields)
+import Control.Lens.TH (makeLenses)
+import Control.Monad (void)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
-import Gargantext.Core.Types.Main (ListId, ListTypeId)
-import Gargantext.Database.Utils (mkCmd, Cmd, runPGSQuery)
-import Gargantext.Database.Schema.NodeNgramsNgrams
+import Gargantext.Database.Utils (mkCmd, Cmd, execPGSQuery)
+import Gargantext.Core.Types.Main (ListTypeId)
+import Gargantext.Database.Types.Node (NodeId, ListId)
+import Gargantext.Database.Schema.Node (pgNodeId)
+import Gargantext.Database.Schema.Ngrams (NgramsTypeId, pgNgramsTypeId)
import Gargantext.Prelude
+import Gargantext.Database.Utils (formatPGSQuery)
import Opaleye
-import qualified Database.PostgreSQL.Simple as PGS (Only(..))
+import qualified Database.PostgreSQL.Simple as DPS
-- | TODO : remove id
-data NodeNgramPoly id node_id ngram_id weight ngrams_type
- = NodeNgram { nodeNgram_id :: id
- , nodeNgram_node_id :: node_id
- , nodeNgram_ngrams_id :: ngram_id
- , nodeNgram_weight :: weight
- , nodeNgram_type :: ngrams_type
+data NodeNgramPoly node_id ngrams_id parent_id ngrams_type list_type weight
+ = NodeNgram { nng_node_id :: node_id
+ , nng_ngrams_id :: ngrams_id
+ , nng_parent_id :: parent_id
+
+ , nng_ngramsType :: ngrams_type
+ , nng_listType :: list_type
+ , nng_weight :: weight
} deriving (Show)
type NodeNgramWrite =
NodeNgramPoly
- (Maybe (Column PGInt4 ))
(Column PGInt4 )
(Column PGInt4 )
- (Column PGFloat8)
+ (Maybe (Column PGInt4))
+
+ (Column PGInt4 )
(Column PGInt4 )
+ (Column PGFloat8)
type NodeNgramRead =
NodeNgramPoly
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
- (Column PGFloat8)
+
+ (Column PGInt4 )
(Column PGInt4 )
+ (Column PGFloat8)
type NodeNgramReadNull =
NodeNgramPoly
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
- (Column (Nullable PGFloat8))
+
+ (Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
+ (Column (Nullable PGFloat8))
type NodeNgram =
- NodeNgramPoly (Maybe Int) Int Int Double Int
+ NodeNgramPoly NodeId Int (Maybe NgramsParentId) NgramsTypeId Int Double
-$(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
-$(makeLensesWith abbreviatedFields ''NodeNgramPoly)
+newtype NgramsParentId = NgramsParentId Int
+ deriving (Show, Eq, Num)
+pgNgramsParentId :: NgramsParentId -> Column PGInt4
+pgNgramsParentId (NgramsParentId n) = pgInt4 n
+
+$(makeAdaptorAndInstance "pNodeNgram" ''NodeNgramPoly)
+makeLenses ''NodeNgramPoly
nodeNgramTable :: Table NodeNgramWrite NodeNgramRead
nodeNgramTable = Table "nodes_ngrams"
( pNodeNgram NodeNgram
- { nodeNgram_id = optional "id"
- , nodeNgram_node_id = required "node_id"
- , nodeNgram_ngrams_id = required "ngram_id"
- , nodeNgram_weight = required "weight"
- , nodeNgram_type = required "ngrams_type"
+ { nng_node_id = required "node_id"
+ , nng_ngrams_id = required "ngrams_id"
+ , nng_parent_id = optional "parent_id"
+ , nng_ngramsType = required "ngrams_type"
+ , nng_listType = required "list_type"
+ , nng_weight = required "weight"
}
)
queryNodeNgramTable :: Query NodeNgramRead
queryNodeNgramTable = queryTable nodeNgramTable
+--{-
insertNodeNgrams :: [NodeNgram] -> Cmd err Int
insertNodeNgrams = insertNodeNgramW
- . map (\(NodeNgram _ n g w t) ->
- NodeNgram Nothing (pgInt4 n) (pgInt4 g)
- (pgDouble w) (pgInt4 t)
+ . map (\(NodeNgram n g p ngt lt w) ->
+ NodeNgram (pgNodeId n)
+ (pgInt4 g)
+ (pgNgramsParentId <$> p)
+ (pgNgramsTypeId ngt)
+ (pgInt4 lt)
+ (pgDouble w)
)
-
insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
insertNodeNgramW nns =
mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
, iReturning = rCount
, iOnConflict = (Just DoNothing)
})
-
+--}
type NgramsText = Text
-updateNodeNgrams' :: [(ListId, NgramsText, ListTypeId)] -> Cmd err [Int]
-updateNodeNgrams' [] = pure []
-updateNodeNgrams' input = map (\(PGS.Only a) -> a) <$>
- runPGSQuery updateQuery (PGS.Only $ Values fields $ input)
+updateNodeNgrams' :: ListId -> [(NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ()
+updateNodeNgrams' _ [] = pure ()
+updateNodeNgrams' listId input = void $ execPGSQuery updateQuery (DPS.Only $ Values fields input')
+ where
+ fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
+ input' = map (\(nt,t,lt) -> (listId, nt, t, lt)) input
+
+updateNodeNgrams'_debug :: ListId -> [(NgramsTypeId, NgramsText, ListTypeId)] -> Cmd err ByteString
+updateNodeNgrams'_debug listId input = formatPGSQuery updateQuery (DPS.Only $ Values fields input')
where
- fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","text","int4"]
- updateQuery = [sql| UPDATE nodes_ngrams as old SET
- ngrams_type = new.typeList
- from (?) as new(node_id,terms,typeList)
- JOIN ngrams ON ngrams.terms = new.terms
- WHERE old.node_id = new.node_id
- AND old.ngram_id = ngrams.id;
- -- RETURNING new.ngram_id
- |]
-
-data NodeNgramsUpdate = NodeNgramsUpdate
- { _nnu_lists_update :: [(ListId, NgramsText, ListTypeId)]
- , _nnu_add_children :: [(ListId, NgramsParent, NgramsChild, Maybe Double)]
- , _nnu_rem_children :: [(ListId, NgramsParent, NgramsChild, Maybe Double)]
- }
-
--- TODO wrap these updates in a transaction.
-updateNodeNgrams :: NodeNgramsUpdate -> Cmd err [Int]
-updateNodeNgrams nnu = do
- xs <- updateNodeNgrams' $ _nnu_lists_update nnu
- ys <- ngramsGroup Del $ _nnu_rem_children nnu
- zs <- ngramsGroup Add $ _nnu_add_children nnu
- pure $ xs <> ys <> zs
+ fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","text","int4"]
+ input' = map (\(nt,t,lt) -> (listId, nt, t, lt)) input
+
+updateQuery :: DPS.Query
+updateQuery = [sql|
+WITH new(node_id,ngrams_type,terms,typeList) as (?)
+
+INSERT into nodes_ngrams (node_id,ngrams_id,ngrams_type,list_type,weight)
+
+SELECT node_id,ngrams.id,ngrams_type,typeList,1 FROM new
+JOIN ngrams ON ngrams.terms = new.terms
+ON CONFLICT (node_id, ngrams_id, ngrams_type) DO
+-- DO NOTHING
+
+UPDATE SET list_type = excluded.list_type
+;
+ |]