WIP singletons

package.yaml

@@ -161,6 +161,7 @@ library:
   - servant-swagger-ui
   - servant-static-th
   - serialise
+  - singletons
   - split
   - stemmer
   - string-conversions

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

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

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

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))
 

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

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

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