Merge remote-tracking branch 'origin/adinapoli/fix-phylo-types' into dev-merge

src-test/Offline/JSON.hs

@@ -9,6 +9,7 @@ import Data.Aeson
 import Data.Either
 import Gargantext.API.Node.Corpus.New
 import Gargantext.API.Node.Corpus.Types
+import Gargantext.Core.Viz.Phylo.API
 import Prelude
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -24,6 +25,9 @@ tests = testGroup "JSON" [
     testProperty "Datafield roundtrips" (jsonRoundtrip @Datafield)
   , testProperty "WithQuery roundtrips" (jsonRoundtrip @WithQuery)
   , testCase "WithQuery frontend compliance" testWithQueryFrontend
+  , testGroup "Phylo" [
+    testProperty "PhyloData" (jsonRoundtrip @PhyloData)
+  ]
   ]
 
 testWithQueryFrontend :: Assertion

src/Gargantext/Core/Types/Phylo.hs

@@ -19,16 +19,25 @@ Phylomemy was first described in Chavalarias, D., Cointet, J.-P., 2013. Phylomem
 .
 -}
 
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE TypeApplications   #-}
 
 module Gargantext.Core.Types.Phylo where
 
+import Control.Monad.Fail (fail)
 import Control.Lens (makeLenses)
 
+import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
+import Data.Monoid
 import Data.Swagger
 import Data.Text    (Text)
 import Data.Time.Clock.POSIX  (POSIXTime)
+import qualified Data.Text as T
+import Test.QuickCheck
+import Test.QuickCheck.Instances.Text()
 
 import GHC.Generics (Generic)
 
@@ -94,6 +103,63 @@ type PhyloGroupId = (PhyloLevelId, Int)
 type Edge         = (PhyloGroupId, Weight)
 type Weight       = Double
 
+------------------------------------------------------------------------
+-- | Phylo 'GraphData' datatype descriptor. It must be isomorphic to
+-- the 'GraphData' type of the purecript frontend.
+
+data GraphData =
+  GraphData {
+      _gd__subgraph_cnt :: Int
+    , _gd_directed      :: Bool
+    , _gd_edges         :: [EdgeData]
+    , _gd_objects       :: [ObjectData]
+    , _gd_strict        :: Bool
+    } deriving (Show, Eq, Generic)
+
+-- temp placeholder.
+newtype ObjectData = ObjectData { _ObjectData :: Value }
+  deriving stock (Show, Eq, Generic)
+  deriving newtype (FromJSON, ToJSON)
+
+data EdgeCommonData =
+  EdgeCommonData {
+    _ed_color :: !Text
+  , _ed_head  :: !Int
+  , _ed_pos   :: !Text
+  , _ed_tail  :: !Int
+  , _ed_width :: !Text
+  } deriving (Show, Eq, Generic)
+
+newtype GvId = GvId { _GvId :: Int }
+  deriving (Show, Eq, Generic)
+
+data EdgeData
+  = GroupToAncestor !GvId !EdgeCommonData !GroupToAncestorData
+  | GroupToGroup    !GvId !EdgeCommonData !GroupToGroupData
+  | BranchToGroup   !GvId !EdgeCommonData !BranchToGroupData
+  deriving (Show, Eq, Generic)
+
+data GroupToAncestorData
+  = GroupToAncestorData
+    { _gta_arrowhead :: !Text
+    , _gta_lbl       :: !Text
+    , _gta_penwidth  :: !Text
+    , _gta_style     :: !Text
+    } deriving (Show, Eq, Generic)
+
+data GroupToGroupData
+  = GroupToGroupData
+    { _gtg_constraint :: !Text
+    , _gtg_lbl        :: !Text
+    , _gtg_penwidth   :: !Text
+    } deriving (Show, Eq, Generic)
+
+data BranchToGroupData
+  = BranchToGroupData
+    { _btg_arrowhead :: !Text
+    , _btg_style :: Maybe Text
+    } deriving (Show, Eq, Generic)
+
 -- | Lenses
 makeLenses ''Phylo
 makeLenses ''PhyloPeriod
@@ -106,6 +172,118 @@ $(deriveJSON (unPrefix "_phylo_Period" ) ''PhyloPeriod )
 $(deriveJSON (unPrefix "_phylo_Level"  ) ''PhyloLevel  )
 $(deriveJSON (unPrefix "_phylo_Group"  ) ''PhyloGroup  )
 
+instance ToJSON GraphData where
+  toJSON GraphData{..} = object
+    [ "_subgraph_cnt" .= _gd__subgraph_cnt
+    , "directed"      .= _gd_directed
+    , "edges"         .= _gd_edges
+    , "objects"       .= _gd_objects
+    , "strict"        .= _gd_strict
+    ]
+
+instance FromJSON GraphData where
+  parseJSON = withObject "GraphData" $ \o -> do
+    _gd__subgraph_cnt <- o .: "_subgraph_cnt"
+    _gd_directed      <- o .: "directed"
+    _gd_edges         <- o .: "edges"
+    _gd_objects       <- o .: "objects"
+    _gd_strict        <- o .: "strict"
+    pure GraphData{..}
+
+instance ToJSON GvId where
+  toJSON GvId{..} = toJSON _GvId
+instance FromJSON GvId where
+  parseJSON v = GvId <$> parseJSON v
+
+instance ToJSON EdgeData where
+  toJSON = \case
+    GroupToAncestor gvid commonData edgeTypeData
+      -> mkNode "ancestorLink" gvid commonData edgeTypeData
+    GroupToGroup gvid commonData edgeTypeData
+      -> mkNode "link" gvid commonData edgeTypeData
+    BranchToGroup gvid commonData edgeTypeData
+      -> mkNode "branchLink" gvid commonData edgeTypeData
+
+mkNode :: ToJSON a => Text -> GvId -> EdgeCommonData -> a -> Value
+mkNode edgeType gvid commonData edgeTypeData =
+  let commonDataJSON   = toJSON commonData
+      edgeTypeDataJSON = toJSON edgeTypeData
+      header           = object $ [ "edgeType" .= toJSON edgeType
+                                  , "_gvid"    .= toJSON gvid
+                                  ]
+  in case (commonDataJSON, edgeTypeDataJSON, header) of
+    (Object hdr, Object cdJSON, Object etDataJSON)
+      -> Object $ hdr <> cdJSON <> etDataJSON
+    _ -> panic "[Gargantext.Core.Types.Phylo.mkNode] impossible: commonData, header or edgeTypeDataJSON didn't convert back to JSON Object."
+
+
+instance FromJSON EdgeData where
+  parseJSON = withObject "EdgeData" $ \o -> do
+    edgeType  <- o .: "edgeType"
+    gvid      <- o .: "_gvid"
+    _ed_color <- o .: "color"
+    _ed_head  <- o .: "head"
+    _ed_pos   <- o .: "pos"
+    _ed_tail  <- o .: "tail"
+    _ed_width <- o .: "width"
+    case (edgeType :: Text) of
+      "ancestorLink" -> GroupToAncestor <$> pure gvid <*> pure EdgeCommonData{..} <*> parseJSON (Object o)
+      "link"         -> GroupToGroup    <$> pure gvid <*> pure EdgeCommonData{..} <*> parseJSON (Object o)
+      "branchLink"   -> BranchToGroup   <$> pure gvid <*> pure EdgeCommonData{..} <*> parseJSON (Object o)
+      _              -> fail $ "EdgeData: unrecognised edgeType for Phylo graph: " <> T.unpack edgeType
+
+instance ToJSON EdgeCommonData where
+  toJSON EdgeCommonData{..} = object
+    [ "color" .= _ed_color
+    , "head"  .= _ed_head
+    , "pos"   .= _ed_pos
+    , "tail"  .= _ed_tail
+    , "width" .= _ed_width
+    ]
+
+instance ToJSON GroupToAncestorData where
+  toJSON GroupToAncestorData{..} =
+    object [ "arrowhead" .= _gta_arrowhead
+           , "lbl"       .= _gta_lbl
+           , "penwidth"  .= _gta_penwidth
+           , "style"     .= _gta_style
+           ]
+
+instance FromJSON GroupToAncestorData where
+  parseJSON = withObject "GroupToAncestorData" $ \o -> do
+    _gta_arrowhead <- o .: "arrowhead"
+    _gta_lbl       <- o .: "lbl"
+    _gta_penwidth  <- o .: "penwidth"
+    _gta_style     <- o .: "style"
+    pure GroupToAncestorData{..}
+
+instance ToJSON GroupToGroupData where
+  toJSON GroupToGroupData{..} =
+    object [ "constraint" .= _gtg_constraint
+           , "lbl"        .= _gtg_lbl
+           , "penwidth"   .= _gtg_penwidth
+           ]
+
+instance FromJSON GroupToGroupData where
+  parseJSON = withObject "BranchToGroupData" $ \o -> do
+    _gtg_constraint <- o .: "constraint"
+    _gtg_lbl        <- o .: "lbl"
+    _gtg_penwidth   <- o .: "penwidth"
+    pure GroupToGroupData{..}
+
+instance ToJSON BranchToGroupData where
+  toJSON BranchToGroupData{..} =
+    object [ "arrowhead" .= _btg_arrowhead
+           , "style"     .= _btg_style
+           ]
+
+instance FromJSON BranchToGroupData where
+  parseJSON = withObject "BranchToGroupData" $ \o -> do
+    _btg_arrowhead <- o .:  "arrowhead"
+    _btg_style     <- o .:? "style"
+    pure BranchToGroupData{..}
+
+
 -- | ToSchema instances
 instance ToSchema Phylo where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_")
@@ -115,3 +293,53 @@ instance ToSchema PhyloLevel where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_Level")
 instance ToSchema PhyloGroup where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_phylo_Group")
+instance ToSchema BranchToGroupData where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_btg_")
+instance ToSchema GroupToGroupData where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gtg_")
+instance ToSchema GroupToAncestorData where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gta_")
+instance ToSchema EdgeCommonData where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_ed_")
+instance ToSchema ObjectData where
+  declareNamedSchema _ = pure $ NamedSchema (Just "ObjectData") $ mempty
+instance ToSchema GvId where
+  declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
+instance ToSchema EdgeData where
+  declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
+instance ToSchema GraphData where
+  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_gd_")
+
+-- | Arbitrary instances
+instance Arbitrary BranchToGroupData where
+  arbitrary = BranchToGroupData <$> arbitrary <*> arbitrary
+instance Arbitrary GroupToGroupData where
+  arbitrary = GroupToGroupData <$> arbitrary
+                               <*> arbitrary
+                               <*> arbitrary
+instance Arbitrary GroupToAncestorData where
+  arbitrary = GroupToAncestorData <$> arbitrary
+                                  <*> arbitrary
+                                  <*> arbitrary
+                                  <*> arbitrary
+instance Arbitrary EdgeCommonData where
+  arbitrary = EdgeCommonData <$> arbitrary
+                             <*> arbitrary
+                             <*> arbitrary
+                             <*> arbitrary
+                             <*> arbitrary
+instance Arbitrary ObjectData where
+  arbitrary = ObjectData <$> (String <$> arbitrary) -- temporary, it doesn't matter.
+instance Arbitrary GvId where
+  arbitrary = GvId <$> arbitrary
+instance Arbitrary EdgeData where
+  arbitrary = oneof [ GroupToAncestor <$> arbitrary <*> arbitrary <*> arbitrary
+                    , GroupToGroup    <$> arbitrary <*> arbitrary <*> arbitrary
+                    , BranchToGroup   <$> arbitrary <*> arbitrary <*> arbitrary
+                    ]
+instance Arbitrary GraphData where
+  arbitrary = GraphData <$> arbitrary
+                        <*> arbitrary
+                        <*> arbitrary
+                        <*> arbitrary
+                        <*> arbitrary

src/Gargantext/Core/Viz/Phylo/API.hs

@@ -19,11 +19,13 @@ module Gargantext.Core.Viz.Phylo.API
 
 import GHC.Generics (Generic)
 import Data.Aeson
+import Data.Aeson.Types (parseEither)
 import Data.Either
 import Data.Maybe (fromMaybe)
 import Data.Swagger
 import Gargantext.API.Prelude
 import Gargantext.Core.Types (TODO(..))
+import Gargantext.Core.Types.Phylo (GraphData(..))
 import Gargantext.Core.Viz.LegacyPhylo
 import Gargantext.Core.Viz.Phylo (defaultConfig)
 import Gargantext.Core.Viz.Phylo.API.Tools
@@ -41,6 +43,7 @@ import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
 import Web.HttpApiData (readTextData)
 import qualified Data.ByteString as DB
 import qualified Data.ByteString.Lazy as DBL
+import qualified Data.Text as T
 
 ------------------------------------------------------------------------
 type PhyloAPI = Summary "Phylo API"
@@ -68,14 +71,33 @@ instance ToSchema Value where declareNamedSchema _ = declareNamedSchema (Proxy :
 
 ------------------------------------------------------------------------
 
+-- | This type is emitted by the backend and the frontend expects to deserialise it
+-- as a 'PhyloJSON'. see module 'Gargantext.Components.PhyloExplorer.JSON' of the
+-- 'purescript-gargantext' package.
 data PhyloData = PhyloData { pd_corpusId :: NodeId
                            , pd_listId   :: NodeId
-                           , pd_data     :: Value
+                           , pd_data     :: GraphData
                            }
-  deriving (Generic)
+  deriving (Generic, Show, Eq)
+
+instance ToJSON PhyloData where
+  toJSON PhyloData{..} =
+    object [
+      "pd_corpusId" .= toJSON pd_corpusId
+    , "pd_listId"   .= toJSON pd_listId
+    , "pd_data"     .= toJSON pd_data
+    ]
+
+instance FromJSON PhyloData where
+  parseJSON = withObject "PhyloData" $ \o -> do
+    pd_corpusId <- o .: "pd_corpusId"
+    pd_listId   <- o .: "pd_listId"
+    pd_data     <- o .: "pd_data"
+    pure $ PhyloData{..}
+
+instance Arbitrary PhyloData where
+  arbitrary = PhyloData <$> arbitrary <*> arbitrary <*> arbitrary
 
-instance FromJSON PhyloData
-instance ToJSON PhyloData
 instance ToSchema PhyloData
 
 type GetPhylo =  QueryParam "listId"      ListId
@@ -116,12 +138,14 @@ getPhylo phyloId lId _level _minSizeBranch = do
 
 
 
-getPhyloDataJson :: PhyloId -> GargNoServer Value
+getPhyloDataJson :: PhyloId -> GargNoServer GraphData
 getPhyloDataJson phyloId = do
   maybePhyloData <- getPhyloData phyloId
   let phyloData = fromMaybe phyloCleopatre maybePhyloData
   phyloJson <- liftBase $ phylo2dot2json phyloData
-  pure phyloJson
+  case parseEither parseJSON phyloJson of
+    Left err -> panic $ T.pack $ "[Gargantext.Core.Viz.Phylo.API] getPhyloDataJson: " <> err
+    Right gd -> pure gd
 
 
 -- getPhyloDataSVG phId _lId l msb  = do