Skip to content

haskell-gargantext
haskell-gargantext
Commit 428fbf84 authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[REFACTORING] Hyperdata Nodes (Texts for now).

parent b206e162
Hide whitespace changes
Inline Side-by-side
Showing with 92 additions and 67 deletions
src/Gargantext/Core/Types.hs
View file @ 428fbf84
......@@ -21,6 +21,7 @@ module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
, TokenTag(..), POS(..), NER(..)
, Label, Stems
, HasInvalidError(..), assertValid
, Name
) where
import Control.Lens (Prism', (#))
......@@ -42,6 +43,7 @@ import Gargantext.Prelude
import GHC.Generics
------------------------------------------------------------------------
type Name = Text
type Term = Text
type Stems = Set Text
type Label = [Text]
......
src/Gargantext/Database/Flow.hs
View file @ 428fbf84
......@@ -186,7 +186,8 @@ flowCorpusUser l userName corpusName ctype ids = do
(userId, _rootId, userCorpusId) <- getOrMkRootWithCorpus userName corpusName ctype
-- TODO: check if present already, ignore
_ <- Doc.add userCorpusId ids
tId <- mkTexts userCorpusId userId
tId <- mkNode NodeTexts userCorpusId userId
printDebug "Node Text Id" tId
-- User List Flow
......
src/Gargantext/Database/Node/Contact.hs
View file @ 428fbf84
......@@ -28,7 +28,8 @@ import Data.Time (UTCTime)
import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import GHC.Generics (Generic)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Schema.Node (NodeWrite, Name, node)
import Gargantext.Core.Types (Name)
import Gargantext.Database.Schema.Node (NodeWrite, node)
import Gargantext.Database.Types.Node (Node,Hyperdata,NodeType(..), UserId, AnnuaireId)
import Gargantext.Database.Utils (fromField')
import Gargantext.Prelude
......
src/Gargantext/Database/Node/Update.hs
View file @ 428fbf84
......@@ -21,9 +21,9 @@ import qualified Data.Text as DT
import Database.PostgreSQL.Simple
import Gargantext.Prelude
import Gargantext.Core.Types (Name)
import Gargantext.Database.Utils
import Gargantext.Database.Types.Node (NodeId, ParentId)
import Gargantext.Database.Schema.Node (Name)
-- import Data.ByteString
--rename :: NodeId -> Text -> IO ByteString
......
src/Gargantext/Database/Schema/Node.hs
View file @ 428fbf84
......@@ -173,10 +173,6 @@ instance QueryRunnerColumnDefault (Nullable PGInt4) NodeId
queryRunnerColumnDefault = fieldQueryRunnerColumn
------------------------------------------------------------------------
-- WIP
-- TODO Classe HasDefault where
-- default NodeType = Hyperdata
------------------------------------------------------------------------
$(makeAdaptorAndInstance "pNode" ''NodePoly)
$(makeLensesWith abbreviatedFields ''NodePoly)
......@@ -292,7 +288,6 @@ runGetNodes = runOpaQuery
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | order by publication date
-- Favorites (Bool), node_ngrams
selectNodesWith :: ParentId -> Maybe NodeType
......@@ -381,7 +376,6 @@ getNodePhylo nId = do
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
getNode' :: NodeId -> Cmd err (Node Value)
getNode' nId = fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
......@@ -436,27 +430,34 @@ nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Jus
------------------------------------------------------------------------
arbitraryTexts :: HyperdataTexts
arbitraryTexts = HyperdataTexts (Just "Preferences")
class HasDefault a where
hasDefaultData :: a -> HyperData
hasDefaultName :: a -> Text
instance HasDefault NodeType where
hasDefaultData nt = case nt of
NodeTexts -> HyperdataTexts (Just "Preferences")
NodeList -> HyperdataList' (Just "Preferences")
_ -> undefined
--NodeAnnuaire -> HyperdataAnnuaire (Just "Title") (Just "Description")
hasDefaultName nt = case nt of
NodeTexts -> "Texts"
NodeList -> "Lists"
_ -> undefined
nodeTextsW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
nodeTextsW maybeName maybeList pId = node NodeTexts name list (Just pId)
------------------------------------------------------------------------
nodeDefault :: NodeType -> ParentId -> UserId -> NodeWrite
nodeDefault nt parent = node nt name hyper (Just parent)
where
name = maybe "Texts" identity maybeName
list = maybe arbitraryList identity maybeList
name = (hasDefaultName nt)
hyper = (hasDefaultData nt)
------------------------------------------------------------------------
arbitraryList :: HyperdataList
arbitraryList = HyperdataList (Just "Preferences")
nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
where
name = maybe "Lists" identity maybeName
list = maybe arbitraryList identity maybeList
--------------------
arbitraryListModel :: HyperdataListModel
arbitraryListModel = HyperdataListModel (400,500) "data/models/test.model" (Just 0.83)
......@@ -495,12 +496,6 @@ nodePhyloW maybeName maybePhylo pId = node NodePhylo name graph (Just pId)
arbitraryDashboard :: HyperdataDashboard
arbitraryDashboard = HyperdataDashboard (Just "Preferences")
nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
where
name = maybe "Dashboard" identity maybeName
dashboard = maybe arbitraryDashboard identity maybeDashboard
------------------------------------------------------------------------
node :: (ToJSON a, Hyperdata a) => NodeType -> Name -> a -> Maybe ParentId -> UserId -> NodeWrite
node nodeType name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
......@@ -548,8 +543,8 @@ data Node' = Node' { _n_type :: NodeType
, _n_children :: [Node']
} deriving (Show)
mkNode :: [NodeWrite] -> Cmd err Int64
mkNode ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
mkNodes :: [NodeWrite] -> Cmd err Int64
mkNodes ns = mkCmd $ \conn -> runInsertMany conn nodeTable ns
mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
mkNodeR ns = mkCmd $ \conn -> runInsertManyReturning conn nodeTable ns (_node_id)
......@@ -584,8 +579,6 @@ childWith uId pId (Node' NodeContact txt v []) = node2table uId (Just pId) (Nod
childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"
type Name = Text
-- | TODO mk all others nodes
mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
mkNodeWithParent NodeUser (Just _) _ _ = nodeError UserNoParent
......@@ -632,17 +625,33 @@ defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
defaultList cId =
maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
mkTexts :: ParentId -> UserId -> Cmd err [NodeId]
mkTexts p u = insertNodesR [nodeTextsW Nothing Nothing p u]
mkNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
mkNode nt p u = insertNodesR [nodeDefault nt p u]
mkList :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
mkList p u = insertNodesR [nodeListW Nothing Nothing p u]
where
nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
where
name = maybe "Lists" identity maybeName
list = maybe arbitraryList identity maybeList
mkGraph :: ParentId -> UserId -> Cmd err [GraphId]
mkGraph p u = insertNodesR [nodeGraphW Nothing Nothing p u]
mkDashboard :: ParentId -> UserId -> Cmd err [NodeId]
mkDashboard p u = insertNodesR [nodeDashboardW Nothing Nothing p u]
where
nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
where
name = maybe "Board" identity maybeName
dashboard = maybe arbitraryDashboard identity maybeDashboard
mkPhylo :: ParentId -> UserId -> Cmd err [NodeId]
mkPhylo p u = insertNodesR [nodePhyloW Nothing Nothing p u]
......
src/Gargantext/Database/Types/Node.hs
View file @ 428fbf84
......@@ -76,6 +76,36 @@ instance FromField NodeId where
instance ToSchema NodeId
-- type Node json = NodePoly NodeId NodeTypeId UserId ParentId NodeName UTCTime json
type NodeTypeId = Int
type NodeName = Text
type TSVector = Text
------------------------------------------------------------------------
data NodePoly id typename userId
parentId name date
hyperdata = Node { _node_id :: id
, _node_typename :: typename
, _node_userId :: userId
, _node_parentId :: parentId
, _node_name :: name
, _node_date :: date
, _node_hyperdata :: hyperdata
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_node_") ''NodePoly)
$(makeLenses ''NodePoly)
-- | NodePoly indicates that Node has a Polymorphism Type
type Node json = NodePoly NodeId NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json
------------------------------------------------------------------------
instance FromHttpApiData NodeId where
parseUrlPiece n = pure $ NodeId $ (read . cs) n
......@@ -127,7 +157,6 @@ $(deriveJSON (unPrefix "statusV3_") ''StatusV3)
------------------------------------------------------------------------
-- Only Hyperdata types should be member of this type class.
class Hyperdata a
------------------------------------------------------------------------
data HyperdataDocumentV3 = HyperdataDocumentV3 { hyperdataDocumentV3_publication_day :: !(Maybe Int)
......@@ -150,6 +179,7 @@ data HyperdataDocumentV3 = HyperdataDocumentV3 { hyperdataDocumentV3_publication
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataDocumentV3_") ''HyperdataDocumentV3)
class Hyperdata a
instance Hyperdata HyperdataDocumentV3
------------------------------------------------------------------------
......@@ -307,11 +337,6 @@ instance Arbitrary HyperdataCorpus where
arbitrary = pure hyperdataCorpus -- TODO
------------------------------------------------------------------------
data HyperdataTexts = HyperdataTexts { hyperdataTexts_desc :: Maybe Text
} deriving (Show, Generic)
$(deriveJSON (unPrefix "hyperdataTexts_") ''HyperdataTexts)
instance Hyperdata HyperdataTexts
------------------------------------------------------------------------
data HyperdataAnnuaire = HyperdataAnnuaire { hyperdataAnnuaire_title :: !(Maybe Text)
, hyperdataAnnuaire_desc :: !(Maybe Text)
......@@ -406,21 +431,25 @@ $(deriveJSON (unPrefix "hyperdataNotebook_") ''HyperdataNotebook)
instance Hyperdata HyperdataNotebook
-- | NodePoly indicates that Node has a Polymorphism Type
type Node json = NodePoly NodeId NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json
-- type Node json = NodePoly NodeId NodeTypeId UserId ParentId NodeName UTCTime json
type NodeTypeId = Int
type NodeName = Text
type TSVector = Text
-- | Then a Node can be either a Folder or a Corpus or a Document
type NodeUser = Node HyperdataUser
type NodeFolder = Node HyperdataFolder
type NodeCorpus = Node HyperdataCorpus
type NodeTexts = Node HyperdataTexts
data HyperData = HyperdataTexts { hd_texts :: Maybe Text }
| HyperdataList' { hd_lists :: Maybe Text}
deriving (Show, Generic)
$(deriveJSON (unPrefix "hd_") ''HyperData)
instance Hyperdata HyperData
type NodeTexts = Node HyperData
type NodeCorpusV3 = Node HyperdataCorpus
type NodeDocument = Node HyperdataDocument
......@@ -463,23 +492,6 @@ instance FromHttpApiData NodeType
instance ToParamSchema NodeType
instance ToSchema NodeType
------------------------------------------------------------------------
data NodePoly id typename userId
parentId name date
hyperdata = Node { _node_id :: id
, _node_typename :: typename
, _node_userId :: userId
, _node_parentId :: parentId
, _node_name :: name
, _node_date :: date
, _node_hyperdata :: hyperdata
} deriving (Show, Generic)
$(deriveJSON (unPrefix "_node_") ''NodePoly)
$(makeLenses ''NodePoly)
data NodePolySearch id typename userId
parentId name date
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment