Introduce the ToCustomAttribute typeclass

This will allow us to render properly some Phylo attributes into the
graphviz `.dot` in the PhyloExport.

bin/gargantext-phylo-profile/Main.hs

@@ -13,7 +13,6 @@ import GHC.IO.Encoding
 import GHC.Stack
 import Paths_gargantext
 import Prelude
-import qualified Data.Text as T
 import Shelly
 import System.Directory
 

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

@@ -10,6 +10,9 @@ Portability : POSIX
 
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
+{-# LANGUAGE DerivingVia          #-}
+{-# LANGUAGE StandaloneDeriving   #-}
+{-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 
 module Gargantext.Core.Viz.Phylo.PhyloExport where
@@ -33,6 +36,48 @@ import Gargantext.Core.Viz.Phylo
 import Gargantext.Core.Viz.Phylo.PhyloTools
 import Gargantext.Core.Viz.Phylo.TemporalMatching (filterDocs, filterDiago, reduceDiagos, toSimilarity, getNextPeriods)
 import Gargantext.Prelude hiding (empty, scale, toList)
+import qualified Prelude
+
+-- | Temporary compat shim for older Phylo attributes which we still export
+-- \"the old way\", i.e. via their 'Show' instance.
+newtype ShowableAsIs a = ShowableAsIs a
+  deriving stock Eq
+  deriving newtype Show
+
+-- | A typeclass to render the input type into a suitable
+-- representation for the Graphviz graph. This avoids mindlessly
+-- calling 'show' on types like 'Maybe' which would otherwise
+-- render badly.
+class ToCustomAttribute a where
+  toCustomAttribute :: a -> Text.Text
+
+instance ToCustomAttribute Lazy.Text where
+  toCustomAttribute = Lazy.toStrict
+
+instance ToCustomAttribute Text where
+  toCustomAttribute = identity
+
+instance ToCustomAttribute Int where
+  toCustomAttribute = toCustomAttribute . Text.pack. Prelude.show
+
+instance ToCustomAttribute Double where
+  toCustomAttribute = toCustomAttribute . Text.pack . Prelude.show
+
+instance ToCustomAttribute Char where
+  toCustomAttribute = toCustomAttribute . Text.singleton
+
+instance ToCustomAttribute a => ToCustomAttribute [a] where
+  toCustomAttribute xs = "[" <> Text.intercalate "," (map toCustomAttribute xs) <> "]"
+
+instance ToCustomAttribute a => ToCustomAttribute (Vector a) where
+  toCustomAttribute = toCustomAttribute . Vector.toList
+
+instance Show a => ToCustomAttribute (ShowableAsIs a) where
+  toCustomAttribute = toCustomAttribute . Text.pack . show
+
+-- FIXME(adinapoli) The following are derived using 'deriving via' and
+-- defaults to the old style.
+deriving via (ShowableAsIs Cooc) instance ToCustomAttribute Cooc
 
 --------------------
 -- | Dot export | --
@@ -61,8 +106,15 @@ pickLabelColor lst
 toDotLabel :: Text.Text -> Label
 toDotLabel lbl = StrLabel $ fromStrict lbl
 
-toAttr :: AttributeName -> Lazy.Text -> CustomAttribute
-toAttr k v = customAttribute k v
+toAttr :: ToCustomAttribute a => AttributeName -> a -> CustomAttribute
+toAttr k = customAttribute k . Lazy.fromStrict . toCustomAttribute
+
+-- | Monomorphic version of 'toAttr' that works on (strict) 'Text'.
+toTextAttr :: AttributeName -> Text.Text -> CustomAttribute
+toTextAttr = toAttr
+
+toAttrDefault :: ToCustomAttribute a => a -> AttributeName -> Maybe a -> CustomAttribute
+toAttrDefault def k mb_v = customAttribute k . Lazy.fromStrict $ toCustomAttribute (fromMaybe def mb_v)
 
 metaToAttr :: Map Text.Text [Double] -> [CustomAttribute]
 metaToAttr meta = map (\(k, v) -> toAttr (fromStrict k) $ (fromStrict . unwords) $ map show v) $ toList meta
@@ -85,13 +137,13 @@ branchToDotNode b bId =
            , FontSize 40
            , Shape Egg
            , Style [SItem Bold []] ]
-         <> (metaToAttr $ b ^. branch_meta)
-         <> [ toAttr "nodeType" "branch"
-            , toAttr "bId"      (show bId)
+         <> metaToAttr (b ^. branch_meta)
+         <> [ toAttr @Lazy.Text "nodeType" "branch"
+            , toAttr "bId"      bId
             , toAttr "branchId" (fromStrict $ unwords (map show $ snd $ b ^. branch_id))
-            , toAttr "branch_x" (fromStrict $ show $ b ^. branch_x)
-            , toAttr "branch_y" (fromStrict $ show $ b ^. branch_y)
-            , toAttr "label"    (show $ b ^. branch_label)
+            , toAttr "branch_x" (b ^. branch_x)
+            , toAttr "branch_y" (b ^. branch_y)
+            , toAttr "label"    (b ^. branch_label)
             ])
 
 periodToDotNode :: (Date,Date) -> (Text.Text,Text.Text) -> Dot DotId
@@ -100,58 +152,76 @@ periodToDotNode prd prd' =
          [ Shape BoxShape
          , FontSize 50
          , Label $ toDotLabel $ Text.pack $ show (fst prd) <> " " <> show (snd prd) ]
-         <> [ toAttr "nodeType" "period"
-            , toAttr "strFrom" $ fromStrict $ show $ fst prd'
-            , toAttr "strTo"   $ fromStrict $ show $ snd prd'
-            , toAttr "from" $ fromStrict $ show $ fst prd
-            , toAttr "to"   $ fromStrict $ show $ snd prd ]
+         <> [ toAttr @Text.Text "nodeType" "period"
+            , toAttr "strFrom" $ fst prd'
+            , toAttr "strTo"   $ snd prd'
+            , toAttr "from"    $ fst prd
+            , toAttr "to"      $ snd prd ]
 
 
 groupToDotNode :: Vector Ngrams -> PhyloGroup -> Int -> Dot DotId
 groupToDotNode fdt g bId =
     node (groupIdToDotId $ getGroupId g)
                      ([FontName "Arial", Shape Square, penWidth 4]
-                      <> [ toAttr "nodeType" "group"
+                      <> [ toAttr @Text.Text "nodeType" "group"
                          , toAttr "gid" (groupIdToDotId $ getGroupId g)
-                         , toAttr "from" (show (fst $ g ^. phylo_groupPeriod))
-                         , toAttr "to"   (show (snd $ g ^. phylo_groupPeriod))
-                         , toAttr "strFrom" (show (fst $ g ^. phylo_groupPeriod'))
-                         , toAttr "strTo"   (show (snd $ g ^. phylo_groupPeriod'))
+                         , toAttr "from" (fst $ g ^. phylo_groupPeriod)
+                         , toAttr "to"   (snd $ g ^. phylo_groupPeriod)
+                         , toAttr "strFrom" (fst $ g ^. phylo_groupPeriod')
+                         , toAttr "strTo"   (snd $ g ^. phylo_groupPeriod')
                          , toAttr "branchId" (fromStrict $ unwords (init $ map show $ snd $ g ^. phylo_groupBranchId))
-                         , toAttr "bId" (show bId)
-                         , toAttr "support" (show (g ^. phylo_groupSupport))
-                         , toAttr "weight" (show (g ^. phylo_groupWeight))
-                         , toAttr "source" (show (nub $ g ^. phylo_groupSources))
-                         , toAttr "sourceFull" (show (g ^. phylo_groupSources))
-                         , toAttr "density" (show (g ^. phylo_groupDensity))
-                         , toAttr "cooc" (show (g ^. phylo_groupCooc))
-                         , toAttr "lbl" (show (ngramsToLabel fdt (g ^. phylo_groupNgrams)))
-                         , toAttr "foundation" (show (idxToLabel (g ^. phylo_groupNgrams)))
-                         , toAttr "role" (show (idxToLabel' ((g ^. phylo_groupMeta) ! "dynamics")))
-                         , toAttr "frequence" (show (idxToLabel' ((g ^. phylo_groupMeta) ! "frequence")))
-                         , toAttr "seaLvl" (show ((g ^. phylo_groupMeta) ! "seaLevels"))
+                         , toAttr "bId" bId
+                         , toAttr "support" (g ^. phylo_groupSupport)
+                         , toAttrDefault 1.0 "weight" (g ^. phylo_groupWeight)
+                         , toAttr "source" (nub $ g ^. phylo_groupSources)
+                         , toAttr "sourceFull" (g ^. phylo_groupSources)
+                         , toAttr "density" (g ^. phylo_groupDensity)
+                         , toAttr "cooc" (g ^. phylo_groupCooc)
+                         , toAttr "lbl" (ngramsToLabel fdt (g ^. phylo_groupNgrams))
+                         , toAttr "foundation" (idxToLabel (g ^. phylo_groupNgrams))
+                         , toAttr "role" (idxToLabel' ((g ^. phylo_groupMeta) ! "dynamics"))
+                         , toAttr "frequence" (idxToLabel' ((g ^. phylo_groupMeta) ! "frequence"))
+                         , toAttr "seaLvl" ((g ^. phylo_groupMeta) ! "seaLevels")
                          ])
 
-toDotEdge' :: DotId -> DotId -> [Char] -> [Char] -> EdgeType -> Dot DotId
-toDotEdge' source target thr w edgeType = edge source target
-    (case edgeType of
-        GroupToGroup    -> undefined
-        GroupToGroupMemory  -> [ Width 3, penWidth 4, Color [toWColor Black], Constraint True] <> [toAttr "edgeType" "memoryLink", toAttr "thr" (pack thr), toAttr "weight" (pack w)]
-        BranchToGroup   -> undefined
-        BranchToBranch  -> undefined
-        GroupToAncestor -> undefined
-        PeriodToPeriod  -> undefined)
-
-
 toDotEdge :: DotId -> DotId -> [Char] -> EdgeType -> Dot DotId
-toDotEdge source target lbl edgeType = edge source target
-    (case edgeType of
-        GroupToGroup    -> [ Width 3, penWidth 4, Color [toWColor Black], Constraint True] <> [toAttr "edgeType" "link", toAttr "lbl" (pack lbl), toAttr "source" source, toAttr "target" target]
-        GroupToGroupMemory  -> undefined
-        BranchToGroup   -> [ Width 3, Color [toWColor Black], ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])] <> [toAttr "edgeType" "branchLink" ]
-        BranchToBranch  -> [ Width 2, Color [toWColor Black], Style [SItem Dashed []], ArrowHead (AType [(ArrMod FilledArrow BothSides,DotArrow)])]
-        GroupToAncestor -> [ Width 3, Color [toWColor Red], Style [SItem Dashed []], ArrowHead (AType [(ArrMod FilledArrow BothSides,NoArrow)]), PenWidth 4] <> [toAttr "edgeType" "ancestorLink", toAttr "lbl" (pack lbl), toAttr "source" source, toAttr "target" target]
-        PeriodToPeriod  -> [ Width 5, Color [toWColor Black]])
+toDotEdge source target lbl edgeType = edge source target $ case edgeType of
+        GroupToGroup
+          -> [ Width 3
+             , penWidth 4
+             , Color [toWColor Black]
+             , Constraint True
+             ] <> [ toTextAttr "edgeType" "link"
+                  , toAttr "lbl" (pack lbl)
+                  , toAttr "source" source
+                  , toAttr "target" target
+                  ]
+        GroupToGroupMemory
+          -> undefined
+        BranchToGroup
+          -> [ Width 3
+             , Color [toWColor Black]
+             , ArrowHead (AType [(ArrMod FilledArrow RightSide,DotArrow)])
+             ] <> [toTextAttr "edgeType" "branchLink" ]
+        BranchToBranch
+          -> [ Width 2
+             , Color [toWColor Black]
+             , Style [SItem Dashed []]
+             , ArrowHead (AType [(ArrMod FilledArrow BothSides,DotArrow)])
+             ]
+        GroupToAncestor
+          -> [ Width 3
+             , Color [toWColor Red]
+             , Style [SItem Dashed []]
+             , ArrowHead (AType [(ArrMod FilledArrow BothSides,NoArrow)])
+             , PenWidth 4
+             ] <> [ toTextAttr "edgeType" "ancestorLink"
+                  , toAttr "lbl" (pack lbl)
+                  , toAttr "source" source
+                  , toAttr "target" target
+                  ]
+        PeriodToPeriod
+          -> [ Width 5, Color [toWColor Black]]
 
 
 mergePointers :: [PhyloGroup] -> Map (PhyloGroupId,PhyloGroupId) Double
@@ -193,18 +263,18 @@ exportToDot phylo export =
                      -- , Ratio AutoRatio
                      , Style [SItem Filled []],Color [toWColor White]]
                   {-- home made attributes -}
-                  <> [ toAttr (fromStrict "phyloFoundations") $ show (length $ Vector.toList $ getRoots phylo)
-                     , toAttr (fromStrict "phyloTerms") $ show (length $ nub $ concat $ map (^. phylo_groupNgrams) $ export ^. export_groups)
-                     , toAttr (fromStrict "phyloDocs") $ show (sum $ elems $ getDocsByDate phylo)
-                     , toAttr (fromStrict "phyloPeriods") $ show (length $ elems $ phylo ^. phylo_periods)
-                     , toAttr (fromStrict "phyloBranches") $ show (length $ export ^. export_branches)
-                     , toAttr (fromStrict "phyloGroups") $ show (length $ export ^. export_groups)
-                     , toAttr (fromStrict "phyloSources") $ show (Vector.toList $ getSources phylo)
-                     , toAttr (fromStrict "phyloTimeScale") $ pack $ getTimeScale phylo
-                     , toAttr (fromStrict "PhyloScale") $ show (getLevel phylo)
-                     , toAttr (fromStrict "phyloQuality") $ show (phylo ^. phylo_quality)
-                     , toAttr (fromStrict "phyloSeaRiseStart") $ show (getPhyloSeaRiseStart phylo)
-                     , toAttr (fromStrict "phyloSeaRiseSteps") $ show (getPhyloSeaRiseSteps phylo)
+                  <> [ toAttr "phyloFoundations" $ (length $ Vector.toList $ getRoots phylo)
+                     , toAttr "phyloTerms" $ (length $ nub $ concat $ map (^. phylo_groupNgrams) $ export ^. export_groups)
+                     , toAttr "phyloDocs" $ (sum $ elems $ getDocsByDate phylo)
+                     , toAttr "phyloPeriods" $ (length $ elems $ phylo ^. phylo_periods)
+                     , toAttr "phyloBranches" $ (length $ export ^. export_branches)
+                     , toAttr "phyloGroups" $ (length $ export ^. export_groups)
+                     , toAttr "phyloSources" $ (getSources phylo)
+                     , toAttr "phyloTimeScale" $ pack $ getTimeScale phylo
+                     , toAttr "PhyloScale" $ (getLevel phylo)
+                     , toAttr "phyloQuality" $ (phylo ^. phylo_quality)
+                     , toAttr "phyloSeaRiseStart" $ (getPhyloSeaRiseStart phylo)
+                     , toAttr "phyloSeaRiseSteps" $ (getPhyloSeaRiseSteps phylo)
                      -- ,(toAttr (fromStrict "phyloTermsFreq") $ show (toList $ _phylo_lastTermFreq phylo))
                      ])