]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Tree.hs
fix the weightedlogjaccard
[gargantext.git] / src / Gargantext / Database / Tree.hs
1 {-|
2 Module : Gargantext.Database.Tree
3 Description : Tree of Resource Nodes built from Database
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 Let a Root Node, return the Tree of the Node as a directed acyclic graph
11 (Tree).
12
13 -}
14
15 {-# LANGUAGE NoImplicitPrelude #-}
16 {-# LANGUAGE QuasiQuotes #-}
17 {-# LANGUAGE RankNTypes #-}
18
19 module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..), dbTree, toNodeTree, DbTreeNode) where
20
21 import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
22 import Control.Monad.Error.Class (MonadError(throwError))
23 import Data.Map (Map, fromListWith, lookup)
24 import Data.Text (Text)
25 import Database.PostgreSQL.Simple
26 import Database.PostgreSQL.Simple.SqlQQ
27
28 import Gargantext.Prelude
29 import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
30 import Gargantext.Database.Types.Node (NodeId)
31 import Gargantext.Database.Config (fromNodeTypeId)
32 import Gargantext.Database.Utils (Cmd, runPGSQuery)
33 ------------------------------------------------------------------------
34 -- import Gargantext.Database.Utils (runCmdDev)
35 -- treeTest :: IO (Tree NodeTree)
36 -- treeTest = runCmdDev $ treeDB 347474
37 ------------------------------------------------------------------------
38
39 data TreeError = NoRoot | EmptyRoot | TooManyRoots
40 deriving (Show)
41
42 class HasTreeError e where
43 _TreeError :: Prism' e TreeError
44
45 treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
46 treeError te = throwError $ _TreeError # te
47
48 -- | Returns the Tree of Nodes in Database
49 treeDB :: HasTreeError err => RootId -> Cmd err (Tree NodeTree)
50 treeDB r = toTree =<< (toTreeParent <$> dbTree r)
51
52 type RootId = NodeId
53 type ParentId = NodeId
54 ------------------------------------------------------------------------
55 toTree :: (MonadError e m, HasTreeError e)
56 => Map (Maybe ParentId) [DbTreeNode] -> m (Tree NodeTree)
57 toTree m =
58 case lookup Nothing m of
59 Just [n] -> pure $ toTree' m n
60 Nothing -> treeError NoRoot
61 Just [] -> treeError EmptyRoot
62 Just _ -> treeError TooManyRoots
63
64 toTree' :: Map (Maybe ParentId) [DbTreeNode] -> DbTreeNode -> Tree NodeTree
65 toTree' m n =
66 TreeN (toNodeTree n) $
67 m ^.. at (Just $ dt_nodeId n) . _Just . each . to (toTree' m)
68
69 ------------------------------------------------------------------------
70 toNodeTree :: DbTreeNode -> NodeTree
71 toNodeTree (DbTreeNode nId tId _ n) = NodeTree n nodeType nId
72 where
73 nodeType = fromNodeTypeId tId
74 ------------------------------------------------------------------------
75 toTreeParent :: [DbTreeNode] -> Map (Maybe ParentId) [DbTreeNode]
76 toTreeParent = fromListWith (<>) . map (\n -> (dt_parentId n, [n]))
77 ------------------------------------------------------------------------
78 data DbTreeNode = DbTreeNode { dt_nodeId :: NodeId
79 , dt_typeId :: Int
80 , dt_parentId :: Maybe NodeId
81 , dt_name :: Text
82 } deriving (Show)
83
84 -- | Main DB Tree function
85 -- TODO add typenames as parameters
86 dbTree :: RootId -> Cmd err [DbTreeNode]
87 dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGSQuery [sql|
88 WITH RECURSIVE
89 tree (id, typename, parent_id, name) AS
90 (
91 SELECT p.id, p.typename, p.parent_id, p.name
92 FROM nodes AS p
93 WHERE p.id = ?
94
95 UNION
96
97 SELECT c.id, c.typename, c.parent_id, c.name
98 FROM nodes AS c
99
100 INNER JOIN tree AS s ON c.parent_id = s.id
101 WHERE c.typename IN (2,3,5,30,31,40,7,9,90)
102 )
103 SELECT * from tree;
104 |] (Only rootId)
105
106
107
108
109