WIP singletons

bed9ba48 · Nicolas Pouillard · f7adbd9d · bed9ba48 · bed9ba48 · bed9ba48
Unverified Commit bed9ba48 authored Feb 12, 2019 by Nicolas Pouillard
9 changed files
--- a/package.yaml
+++ b/package.yaml
@@ -161,6 +161,7 @@ library:
  - servant-swagger-ui
  - servant-static-th
  - serialise
+  - singletons
  - split
  - stemmer
  - string-conversions

--- a/src/Gargantext/API.hs
+++ b/src/Gargantext/API.hs
@@ -52,6 +52,7 @@ import           Control.Monad.IO.Class (liftIO)
 import           Control.Monad.Reader (ReaderT, runReaderT)
 import           Data.Aeson.Encode.Pretty (encodePretty)
 import qualified Data.ByteString.Lazy.Char8 as BL8
+import           Data.Singletons.Prelude
 import           Data.Swagger
 import           Data.Text (Text)
 import qualified Data.Text.IO as T
@@ -85,6 +86,7 @@ import Gargantext.API.Node ( GargServer
                           , NodesAPI , nodesAPI
                           , GraphAPI , graphAPI
                           , TreeAPI  , treeAPI
+                           -- , ChildrenAPI , childrenAPI
                           , HyperdataAny
                           , HyperdataCorpus
                           , HyperdataAnnuaire

--- a/src/Gargantext/API/Node.hs
+++ b/src/Gargantext/API/Node.hs
@@ -15,6 +15,7 @@ Node API
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveGeneric      #-}
 {-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE KindSignatures     #-}
 {-# LANGUAGE NoImplicitPrelude  #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE RankNTypes         #-}
@@ -134,7 +135,7 @@ type NodeAPI a = Get '[JSON] (Node a)
             :<|> PostNodeApi -- TODO move to children POST
             :<|> Put    '[JSON] Int
             :<|> Delete '[JSON] Int
-             :<|> "children"  :> ChildrenApi a
+             :<|> "children"  :> ChildrenAPI

             -- TODO gather it
             :<|> "table"     :> TableApi
@@ -163,11 +164,26 @@ type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
                 :> ReqBody '[JSON] PostNode
                 :> Post    '[JSON] [NodeId]

-type ChildrenApi a = Summary " Summary children"
-                 :> QueryParam "type"   NodeType
-                 :> QueryParam "offset" Int
-                 :> QueryParam "limit"  Int
-                 :> Get '[JSON] [Node a]
+-- Ideally we would like to hide `t` existentially.
+type ChildrenAPI' (t :: NodeType)
+  =  Summary " Summary children"
+  :> QueryParam "type"   (Sing t)
+  :> QueryParam "offset" Int
+  :> QueryParam "limit"  Int
+  :> Get '[JSON] [Node (Hyperdata t)]
+
+type ChildrenAPI
+    =  ChildrenAPI' 'NodeCorpus
+  :<|> ChildrenAPI' 'NodeList
+  :<|> ChildrenAPI' 'NodeContact
+  -- ...
+
+childrenAPI :: NodeId -> GargServer ChildrenAPI
+childrenAPI n
+    =  getChildren n
+  :<|> getChildren n
+  :<|> getChildren n
+
 ------------------------------------------------------------------------
 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
@@ -177,7 +193,7 @@ nodeAPI p uId id
           :<|> postNode    uId id
           :<|> putNode     id
           :<|> deleteNode  id
-           :<|> getChildren id p
+           :<|> childrenAPI id

           -- TODO gather it
           :<|> getTable         id

--- a/src/Gargantext/Core/Types/Main.hs
+++ b/src/Gargantext/Core/Types/Main.hs
@@ -40,7 +40,7 @@ import GHC.Generics (Generic)
 import Servant.API (FromHttpApiData(..))
 import Test.QuickCheck (elements)
 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-import Text.Read (read)
+import Web.HttpApiData (readTextData)

 ------------------------------------------------------------------------
 data NodeTree = NodeTree { _nt_name :: Text

--- a/src/Gargantext/Database/Flow/Utils.hs
+++ b/src/Gargantext/Database/Flow/Utils.hs
@@ -20,24 +20,24 @@ import Data.Map (Map)
 import qualified Data.Map as DM
 import Gargantext.Prelude
 import Gargantext.Database.Schema.Ngrams
-import Gargantext.Database.Types.Node (NodeId, Node, NodePoly(..), Hyperdata)
+import Gargantext.Database.Types.Node (NodeId, Node, NodePoly(..))
 import Gargantext.Database.Utils (Cmd)
 import Gargantext.Database.Schema.NodeNgram
 import Gargantext.Core.Types.Main (ListType(..), listTypeId)

-toMaps :: Hyperdata a => (a -> Map (NgramsT Ngrams) Int) -> [Node a] -> Map (NgramsT Ngrams) (Map NodeId Int)
+toMaps :: (a -> Map (NgramsT Ngrams) Int) -> [Node a] -> Map (NgramsT Ngrams) (Map NodeId Int)
 toMaps fun ns = mapNodeIdNgrams $ documentIdWithNgrams fun ns'
  where
    ns' = map (\(Node nId _ _ _ _ _ json) -> DocumentWithId nId json) ns

-mapNodeIdNgrams :: Hyperdata a => [DocumentIdWithNgrams a] -> Map (NgramsT Ngrams) (Map NodeId Int)
+mapNodeIdNgrams :: [DocumentIdWithNgrams a] -> Map (NgramsT Ngrams) (Map NodeId Int)
 mapNodeIdNgrams ds = DM.map (DM.fromListWith (+)) $ DM.fromListWith (<>) xs
  where
    xs  = [(ng, [(nId, i)]) | (nId, n2i') <- n2i ds, (ng, i) <- DM.toList n2i']
    n2i = map (\d -> ((documentId . documentWithId) d, document_ngrams d))


-documentIdWithNgrams :: Hyperdata a => (a -> Map (NgramsT Ngrams) Int)
+documentIdWithNgrams :: (a -> Map (NgramsT Ngrams) Int)
                                     -> [DocumentWithId a] -> [DocumentIdWithNgrams a]
 documentIdWithNgrams f = map (\d -> DocumentIdWithNgrams d ((f . documentData) d))


--- a/src/Gargantext/Database/Node/Children.hs
+++ b/src/Gargantext/Database/Node/Children.hs
@@ -12,8 +12,10 @@ Portability : POSIX
 {-# OPTIONS_GHC -fno-warn-orphans        #-}

 {-# LANGUAGE Arrows                 #-}
+{-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE KindSignatures         #-}
 {-# LANGUAGE RankNTypes             #-}

 module Gargantext.Database.Node.Children where
@@ -28,17 +30,20 @@ import Gargantext.Database.Queries.Filter
 import Gargantext.Database.Node.Contact (HyperdataContact)
 import Gargantext.Database.Schema.Node (pgNodeId)
 import Control.Arrow (returnA)
+import Data.Singletons.Prelude

 -- | TODO: use getChildren with Proxy ?
 getContacts :: ParentId -> Maybe NodeType -> Cmd err [Node HyperdataContact]
 getContacts pId maybeNodeType = runOpaQuery $ selectChildren pId maybeNodeType


-getChildren :: JSONB a => ParentId -> proxy a -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
-getChildren pId _ maybeNodeType maybeOffset maybeLimit = runOpaQuery
+getChildren :: forall (t :: NodeType) err. JSONB (Hyperdata t) =>
+               ParentId -> Maybe (Sing t) ->
+               Maybe Offset -> Maybe Limit -> Cmd err [Node (Hyperdata t)]
+getChildren pId maybeNodeType maybeOffset maybeLimit = runOpaQuery
                  $ limit' maybeLimit $ offset' maybeOffset
                  $ orderBy (asc _node_id)
-                  $ selectChildren pId maybeNodeType
+                  $ selectChildren pId (fromSing <$> maybeNodeType)

 selectChildren :: ParentId -> Maybe NodeType -> Query NodeRead
 selectChildren parentId maybeNodeType = proc () -> do

--- a/src/Gargantext/Database/Node/Contact.hs
+++ b/src/Gargantext/Database/Node/Contact.hs
@@ -9,6 +9,7 @@ Portability : POSIX

 -}

+{-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE DeriveGeneric          #-}
 {-# LANGUAGE NoImplicitPrelude      #-}
 {-# LANGUAGE FunctionalDependencies #-}
@@ -16,6 +17,7 @@ Portability : POSIX
 {-# LANGUAGE FlexibleInstances      #-}
 {-# LANGUAGE MultiParamTypeClasses  #-}
 {-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE TypeFamilies           #-}

 module Gargantext.Database.Node.Contact
  where
@@ -29,7 +31,7 @@ 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.Database.Types.Node (Node,Hyperdata,NodeType(..), UserId, AnnuaireId)
+import Gargantext.Database.Types.Node (Node, Sing(SNodeContact), Hyperdata,NodeType(..), UserId, AnnuaireId)
 import Gargantext.Database.Utils (fromField')
 import Gargantext.Prelude
 import Opaleye (QueryRunnerColumnDefault, queryRunnerColumnDefault, PGJsonb, fieldQueryRunnerColumn)
@@ -98,7 +100,7 @@ data ContactTouch =
 nodeContactW :: Maybe Name -> Maybe HyperdataContact
             -> AnnuaireId -> UserId -> NodeWrite
 nodeContactW maybeName maybeContact aId = 
-  node NodeContact name contact (Just aId)
+  node SNodeContact name contact (Just aId)
    where
      name    = maybe "Contact" identity maybeName
      contact = maybe arbitraryHyperdataContact identity maybeContact
@@ -115,7 +117,7 @@ instance Arbitrary HyperdataContact where


 -- | Specific Gargantext instance
-instance Hyperdata HyperdataContact
+type instance Hyperdata 'NodeContact = HyperdataContact

 -- | Database (Posgresql-simple instance)
 instance FromField HyperdataContact where

--- a/src/Gargantext/Database/Schema/Node.hs
+++ b/src/Gargantext/Database/Schema/Node.hs
@@ -32,6 +32,7 @@ import Control.Monad.Error.Class (MonadError(..))
 import Data.Aeson
 import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
+import Data.Singletons.Prelude
 import Data.Text (Text, pack)
 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
 import GHC.Int (Int64)
@@ -374,7 +375,7 @@ defaultUser :: HyperdataUser
 defaultUser = HyperdataUser (Just $ (pack . show) EN)

 nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
-nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
+nodeUserW maybeName maybeHyperdata = node SNodeUser name user Nothing
  where
    name = maybe "User" identity maybeName
    user = maybe defaultUser identity maybeHyperdata
@@ -383,13 +384,13 @@ defaultFolder :: HyperdataFolder
 defaultFolder = HyperdataFolder (Just "Markdown Description")

 nodeFolderW :: Maybe Name -> Maybe HyperdataFolder -> ParentId -> UserId -> NodeWrite
-nodeFolderW maybeName maybeFolder pid = node NodeFolder name folder (Just pid)
+nodeFolderW maybeName maybeFolder pid = node SNodeFolder name folder (Just pid)
  where
    name   = maybe "Folder" identity maybeName
    folder = maybe defaultFolder identity maybeFolder
 ------------------------------------------------------------------------
 nodeCorpusW :: Maybe Name -> Maybe HyperdataCorpus -> ParentId -> UserId -> NodeWrite
-nodeCorpusW maybeName maybeCorpus pId = node NodeCorpus name corpus (Just pId)
+nodeCorpusW maybeName maybeCorpus pId = node SNodeCorpus name corpus (Just pId)
  where
    name   = maybe "Corpus" identity maybeName
    corpus = maybe defaultCorpus identity maybeCorpus
@@ -398,7 +399,7 @@ defaultDocument :: HyperdataDocument
 defaultDocument = hyperdataDocument

 nodeDocumentW :: Maybe Name -> Maybe HyperdataDocument -> CorpusId -> UserId -> NodeWrite
-nodeDocumentW maybeName maybeDocument cId = node NodeDocument name doc (Just cId)
+nodeDocumentW maybeName maybeDocument cId = node SNodeDocument name doc (Just cId)
  where
    name = maybe "Document" identity maybeName
    doc  = maybe defaultDocument identity maybeDocument
@@ -407,7 +408,7 @@ defaultAnnuaire :: HyperdataAnnuaire
 defaultAnnuaire = HyperdataAnnuaire (Just "Title") (Just "Description")

 nodeAnnuaireW :: Maybe Name -> Maybe HyperdataAnnuaire -> ParentId -> UserId -> NodeWrite
-nodeAnnuaireW maybeName maybeAnnuaire pId = node NodeAnnuaire name annuaire (Just pId)
+nodeAnnuaireW maybeName maybeAnnuaire pId = node SNodeAnnuaire name annuaire (Just pId)
  where
    name     = maybe "Annuaire" identity maybeName
    annuaire = maybe defaultAnnuaire identity maybeAnnuaire
@@ -417,7 +418,7 @@ arbitraryList :: HyperdataList
 arbitraryList = HyperdataList (Just "Preferences")

 nodeListW :: Maybe Name -> Maybe HyperdataList -> ParentId -> UserId -> NodeWrite
-nodeListW maybeName maybeList pId = node NodeList name list (Just pId)
+nodeListW maybeName maybeList pId = node SNodeList name list (Just pId)
  where
    name = maybe "Listes" identity maybeName
    list = maybe arbitraryList identity maybeList
@@ -431,7 +432,7 @@ mkListModelNode :: HasNodeError err => ParentId -> UserId -> Cmd err [NodeId]
 mkListModelNode p u = insertNodesR [nodeListModelW Nothing Nothing p u]

 nodeListModelW :: Maybe Name -> Maybe HyperdataListModel -> ParentId -> UserId -> NodeWrite
-nodeListModelW maybeName maybeListModel pId = node NodeListModel name list (Just pId)
+nodeListModelW maybeName maybeListModel pId = node SNodeListModel name list (Just pId)
  where
    name = maybe "List Model" identity maybeName
    list = maybe arbitraryListModel identity maybeListModel
@@ -441,7 +442,7 @@ arbitraryGraph :: HyperdataGraph
 arbitraryGraph = HyperdataGraph (Just "Preferences")

 nodeGraphW :: Maybe Name -> Maybe HyperdataGraph -> ParentId -> UserId -> NodeWrite
-nodeGraphW maybeName maybeGraph pId = node NodeGraph name graph (Just pId)
+nodeGraphW maybeName maybeGraph pId = node SNodeGraph name graph (Just pId)
  where
    name = maybe "Graph" identity maybeName
    graph = maybe arbitraryGraph identity maybeGraph
@@ -452,16 +453,16 @@ arbitraryDashboard :: HyperdataDashboard
 arbitraryDashboard = HyperdataDashboard (Just "Preferences")

 nodeDashboardW :: Maybe Name -> Maybe HyperdataDashboard -> ParentId -> UserId -> NodeWrite
-nodeDashboardW maybeName maybeDashboard pId = node NodeDashboard name dashboard (Just pId)
+nodeDashboardW maybeName maybeDashboard pId = node SNodeDashboard 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)
+node :: ToJSON (Hyperdata t) => Sing t -> Name -> Hyperdata t -> Maybe ParentId -> UserId -> NodeWrite
+node nodeTypeS name hyperData parentId userId = Node Nothing (pgInt4 typeId) (pgInt4 userId) (pgNodeId <$> parentId) (pgStrictText name) Nothing (pgJSONB $ cs $ encode hyperData)
  where
-    typeId = nodeTypeId nodeType
+    typeId = nodeTypeId (fromSing nodeTypeS)

                  -------------------------------
 insertNodes :: [NodeWrite] -> Cmd err Int64
@@ -546,7 +547,7 @@ type Name = Text
 mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
 mkNodeWithParent NodeUser (Just _) _   _    = nodeError UserNoParent
 mkNodeWithParent NodeUser Nothing  uId name =
-  insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
+  insertNodesWithParentR Nothing [node SNodeUser name hd Nothing uId]
    where
      hd = HyperdataUser . Just . pack $ show EN
 mkNodeWithParent _ Nothing _ _ = nodeError HasParent

--- a/src/Gargantext/Database/Types/Node.hs
+++ b/src/Gargantext/Database/Types/Node.hs
@@ -12,13 +12,21 @@ Portability : POSIX
 {-# OPTIONS_GHC -fno-warn-orphans #-}

 {-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE DataKinds                  #-}
 {-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE EmptyCase                  #-}
 {-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs               #-}
+{-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE NoImplicitPrelude          #-}
 {-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
 -- {-# LANGUAGE DuplicateRecordFields #-}

 module Gargantext.Database.Types.Node
@@ -40,20 +48,22 @@ import           Data.ByteString.Lazy (ByteString)
 import           Data.Either
 import           Data.Eq (Eq)
 import           Data.Monoid (mempty)
-import           Data.Text (Text, unpack, pack)
+import           Data.Text (Text, pack)
 import           Data.Time (UTCTime)
 import           Data.Time.Segment (jour, timesAfter, Granularity(D))
+import           Data.Singletons.Prelude
+import           Data.Singletons.TH
 import           Data.Swagger

-import           Text.Read (read)
 import           Text.Show (Show())

 import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
-import           Servant
+import           Servant hiding (STrue, SFalse)

 import           Test.QuickCheck.Arbitrary
 import           Test.QuickCheck (elements)
+import           Web.HttpApiData (readTextData)

 import           Gargantext.Prelude
 import           Gargantext.Core.Utils.Prefix (unPrefix)
@@ -75,7 +85,7 @@ instance FromField NodeId where
 instance ToSchema NodeId

 instance FromHttpApiData NodeId where
-  parseUrlPiece n = pure $ NodeId $ (read . cs) n
+  parseUrlPiece = fmap NodeId . parseUrlPiece

 instance ToParamSchema NodeId
 instance Arbitrary NodeId where
@@ -123,8 +133,63 @@ data StatusV3  = StatusV3 { statusV3_error  :: !(Maybe Text)
 $(deriveJSON (unPrefix "statusV3_") ''StatusV3)
 ------------------------------------------------------------------------

-- Only Hyperdata types should be member of this type class.
-class Hyperdata a
+singletons [d|
+  data NodeType = NodeUser
+                | NodeFolder
+                | NodeCorpus     | NodeCorpusV3 | NodeDocument
+                | NodeAnnuaire   | NodeContact
+                -- | NodeOccurrences
+                | NodeGraph
+                | NodeDashboard  | NodeChart
+                -- | Classification
+                | NodeList | NodeListModel
+                -- | Metrics
+                deriving (Show, Read, Eq, Generic, Bounded)
+  |]
+
+-- Singletons claims to support Enum but this yields an error.
+deriving instance Enum NodeType
+
+allNodeTypes :: [NodeType]
+allNodeTypes = [minBound ..]
+
+-- This could be better as a `data family`.
+-- The change would be a bit more invasive though.
+type family Hyperdata (t :: NodeType)
+
+instance FromJSON NodeType
+instance ToJSON NodeType
+
+instance FromHttpApiData NodeType where parseUrlPiece = readTextData
+
+instance ToParamSchema NodeType
+instance ToSchema      NodeType
+
+instance ToParamSchema (Sing 'NodeCorpus) where
+  toParamSchema _ = toParamSchema (Proxy :: Proxy NodeType)
+  -- Here we weaken the spec by approximating a NodeCorpus as any NodeType.
+
+instance ToParamSchema (Sing 'NodeContact) where
+  toParamSchema _ = toParamSchema (Proxy :: Proxy NodeType)
+  -- Same remark as above.
+
+instance ToParamSchema (Sing 'NodeList) where
+  toParamSchema _ = toParamSchema (Proxy :: Proxy NodeType)
+  -- Same remark as above.
+
+parseUrlPieceSing :: Text -> a -> Text -> Either Text a
+parseUrlPieceSing s a t | s == t    = Right a
+                        | otherwise = Left $ "could not parse: `" <> t <>
+                                             "', expecting `" <> s <> "'"
+
+instance FromHttpApiData (Sing 'NodeCorpus) where
+  parseUrlPiece = parseUrlPieceSing "NodeCorpus" SNodeCorpus
+
+instance FromHttpApiData (Sing 'NodeList) where
+  parseUrlPiece = parseUrlPieceSing "NodeList" SNodeList
+
+instance FromHttpApiData (Sing 'NodeContact) where
+  parseUrlPiece = parseUrlPieceSing "NodeContact" SNodeContact

 ------------------------------------------------------------------------
 data HyperdataDocumentV3 = HyperdataDocumentV3 { hyperdataDocumentV3_publication_day    :: !(Maybe Int)
@@ -147,7 +212,8 @@ data HyperdataDocumentV3 = HyperdataDocumentV3 { hyperdataDocumentV3_publication
                                               } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataDocumentV3_") ''HyperdataDocumentV3)

-instance Hyperdata HyperdataDocumentV3
+-- type instance Hyperdata 'NodeDocumentV3 HyperdataDocumentV3
+------------------------------------------------------------------------

 ------------------------------------------------------------------------
 data HyperdataDocument = HyperdataDocument { _hyperdataDocument_bdd                :: !(Maybe Text)
@@ -187,7 +253,7 @@ instance Eq HyperdataDocument where
 instance Ord HyperdataDocument where
  compare h1 h2 = compare (_hyperdataDocument_publication_date h1) (_hyperdataDocument_publication_date h2)

-instance Hyperdata HyperdataDocument
+type instance Hyperdata 'NodeDocument = HyperdataDocument

 instance ToField HyperdataDocument where
  toField = toJSONField
@@ -271,13 +337,14 @@ data HyperdataUser = HyperdataUser { hyperdataUser_language       :: Maybe Text
                                       } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataUser_") ''HyperdataUser)

-instance Hyperdata HyperdataUser
+type instance Hyperdata 'NodeUser = HyperdataUser
+
 ------------------------------------------------------------------------
 data HyperdataFolder = HyperdataFolder { hyperdataFolder_desc    :: Maybe Text
                                       } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataFolder_") ''HyperdataFolder)

-instance Hyperdata HyperdataFolder
+type instance Hyperdata 'NodeFolder = HyperdataFolder
 ------------------------------------------------------------------------
 data HyperdataCorpus = HyperdataCorpus { hyperdataCorpus_title        :: !(Maybe Text)
                                       , hyperdataCorpus_desc         :: !(Maybe Text)
@@ -287,7 +354,7 @@ data HyperdataCorpus = HyperdataCorpus { hyperdataCorpus_title        :: !(Maybe
                                       } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataCorpus_") ''HyperdataCorpus)

-instance Hyperdata HyperdataCorpus
+type instance Hyperdata 'NodeCorpus = HyperdataCorpus

 corpusExample :: ByteString
 corpusExample = "" -- TODO
@@ -309,7 +376,7 @@ data HyperdataAnnuaire = HyperdataAnnuaire { hyperdataAnnuaire_title        :: !
                                           } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataAnnuaire_") ''HyperdataAnnuaire)

-instance Hyperdata HyperdataAnnuaire
+type instance Hyperdata 'NodeAnnuaire = HyperdataAnnuaire

 hyperdataAnnuaire :: HyperdataAnnuaire
 hyperdataAnnuaire = HyperdataAnnuaire (Just "Annuaire Title") (Just "Annuaire Description")
@@ -321,7 +388,7 @@ instance Arbitrary HyperdataAnnuaire where
 newtype HyperdataAny = HyperdataAny Object
  deriving (Show, Generic, ToJSON, FromJSON)

-instance Hyperdata HyperdataAny
+-- instance Hyperdata HyperdataAny

 instance Arbitrary HyperdataAny where
    arbitrary = pure $ HyperdataAny mempty -- TODO produce arbitrary objects
@@ -331,7 +398,7 @@ data HyperdataList = HyperdataList { hyperdataList_preferences   :: !(Maybe Text
                                   } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataList_") ''HyperdataList)

-instance Hyperdata HyperdataList
+type instance Hyperdata 'NodeList = HyperdataList

 instance Arbitrary HyperdataList where
  arbitrary = elements [HyperdataList (Just "from list A")]
@@ -342,7 +409,7 @@ data HyperdataListModel = HyperdataListModel { _hlm_params  :: !(Int, Int)
                                             , _hlm_score   :: !(Maybe Double)
                                   } deriving (Show, Generic)

-instance Hyperdata HyperdataListModel
+type instance Hyperdata 'NodeListModel = HyperdataListModel
 instance Arbitrary HyperdataListModel where
  arbitrary = elements [HyperdataListModel (100,100) "models/example.model" Nothing]

@@ -354,7 +421,7 @@ data HyperdataScore = HyperdataScore { hyperdataScore_preferences   :: !(Maybe T
                                   } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataScore_") ''HyperdataScore)

-instance Hyperdata HyperdataScore
+-- type instance Hyperdata 'NodeScore = HyperdataScore

 ------------------------------------------------------------------------

@@ -362,21 +429,21 @@ data HyperdataResource = HyperdataResource { hyperdataResource_preferences   ::
                                   } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataResource_") ''HyperdataResource)

-instance Hyperdata HyperdataResource
+-- type instance Hyperdata 'NodeResource = HyperdataResource

 ------------------------------------------------------------------------
 data HyperdataDashboard = HyperdataDashboard { hyperdataDashboard_preferences   :: !(Maybe Text)
                                   } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataDashboard_") ''HyperdataDashboard)

-instance Hyperdata HyperdataDashboard
+type instance Hyperdata 'NodeDashboard = HyperdataDashboard

 -- TODO add the Graph Structure here
 data HyperdataGraph = HyperdataGraph { hyperdataGraph_preferences   :: !(Maybe Text)
                                   } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataGraph_") ''HyperdataGraph)

-instance Hyperdata HyperdataGraph
+type instance Hyperdata 'NodeGraph = HyperdataGraph
 ------------------------------------------------------------------------

 -- TODO add the Graph Structure here
@@ -384,7 +451,7 @@ data HyperdataPhylo = HyperdataPhylo { hyperdataPhylo_preferences   :: !(Maybe T
                                   } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataPhylo_") ''HyperdataPhylo)

-instance Hyperdata HyperdataPhylo
+-- type instance Hyperdata 'NodePhylo = HyperdataPhylo

 ------------------------------------------------------------------------
 -- | TODO FEATURE: Notebook saved in the node
@@ -392,7 +459,7 @@ data HyperdataNotebook = HyperdataNotebook { hyperdataNotebook_preferences   ::
                                   } deriving (Show, Generic)
 $(deriveJSON (unPrefix "hyperdataNotebook_") ''HyperdataNotebook)

-instance Hyperdata HyperdataNotebook
+-- type instance Hyperdata 'NodeNotebook = HyperdataNotebook


 -- | NodePoly indicates that Node has a Polymorphism Type
@@ -423,30 +490,6 @@ type NodeGraph    = Node HyperdataGraph
 type NodePhylo    = Node HyperdataPhylo
 type NodeNotebook = Node HyperdataNotebook
 ------------------------------------------------------------------------
-data NodeType = NodeUser 
-              | NodeFolder
-              | NodeCorpus     | NodeCorpusV3 | NodeDocument
-              | NodeAnnuaire   | NodeContact
-              -- | NodeOccurrences
-              | NodeGraph
-              | NodeDashboard  | NodeChart
-              -- | Classification
-              | NodeList | NodeListModel
-              -- | Metrics
-              deriving (Show, Read, Eq, Generic, Bounded, Enum)
-
-allNodeTypes :: [NodeType]
-allNodeTypes = [minBound ..]
-
-instance FromJSON NodeType
-instance ToJSON NodeType
-
-instance FromHttpApiData NodeType
-  where
-      parseUrlPiece = Right . read . unpack
-
-instance ToParamSchema NodeType
-instance ToSchema      NodeType

 ------------------------------------------------------------------------
 data NodePoly id        typename userId 
@@ -538,6 +581,11 @@ instance ToSchema HyperdataDocument where
    & mapped.schema.description ?~ "a document"
    & mapped.schema.example ?~ toJSON hyperdataDocument

+instance ToSchema HyperdataList where
+  declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
+    & mapped.schema.description ?~ "a list"
+    & mapped.schema.example ?~ emptyObject -- TODO: toJSON hyperdataList
+
 instance ToSchema HyperdataAny where
  declareNamedSchema proxy =
    pure $ genericNameSchema defaultSchemaOptions proxy mempty
@@ -577,4 +625,3 @@ instance ToSchema hyperdata =>

 instance ToSchema Status

-