Merging dev changes

CHANGELOG.md

+## Version 0.0.7.3.6
+
+* [BACK][FIX][Store execution time of Phylomemy graph (#409)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/409)
+* [BACK][FIX][[Meta] Mistmatch between compound words representation in frontend and in database. (#386)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/386)
+* [FRONT][FIX][[Node Graph] Legend tab improvements (#689)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/689)
+* [FRONT][FIX][Display graph parameters in legend (#706)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/706)
+
+## Version 0.0.7.3.5
+
+* [FRONT][FIX][[Topbar] Update the navigation bar links in the "Info" dropdown (#710)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/710)
+
+## Version 0.0.7.3.4
+
+* [FRONT][FIX][Sigma settings don't apply sometimes (#708)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/708)
+
 ## Version 0.0.7.3.3
 
 * [FRONT][FIX][Display graph parameters in legend (#706)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/706)

README.md

@@ -346,6 +346,7 @@ Maybe you need to restore the gargantua password
 ```shell
 $ ALTER ROLE gargantua PASSWORD 'yourPasswordIn_gargantext-settings.toml'
 ```
+
 Maybe you need to change the port to 5433 for database connection in your gargantext.ini file.
 
 ## `haskell-language-server`
@@ -421,3 +422,34 @@ Also, the `haskell-bee` framework allows to add custom hooks to the
 worker. In particular, search for `onJobError`/`onJobTimeout` in
 `Worker.State`. We could trigger some `IO` action on these hooks
 (logging, sending mail, firing rockets).
+
+## Running the tests
+
+Running the tests can be done via the following command:
+
+```hs
+cabal v2-test --test-show-details=streaming --flags 'test-crypto no-phylo-debug-logs'
+```
+
+The flags have the following meaning:
+
+* `test-crypto`: Switch to use very fast (but not production-secure) cryptography, so that tests runs
+  faster;
+* `no-phylo-debug-logs`: Suppresses the debugging logs which would normally be present in phylo pure (!) code.
+
+In order for some tests to run (like the phylo ones) is **required** to install the `gargantext-cli` via:
+
+```hs
+cabal v2-install gargantext:exe:gargantext-cli
+```
+
+### Modifying a golden test to accept a new (expected) output
+
+Some tests, like the Phylo one, use golden testing to ensure that the JSON Phylo we generate is
+the same as an expected one. This allows us to catch regressions in the serialisation or in the algorithm.
+Sometimes, however, we genuinely want to modify the output so that it's the new reference (i.e. the new
+golden reference). To do so, it's enough to run the testsuite passing the `--accept` flag, for example:
+
+```hs
+cabal v2-test garg-test-tasty --test-show-details=streaming --flags 'test-crypto no-phylo-debug-logs' --test-option=--pattern='/Phylo/' --test-option=--accept"
+```

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 3.4
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.7.3.3
+version: 0.0.7.3.6
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data
@@ -852,6 +852,7 @@ test-suite garg-test-tasty
       Test.Utils
       Test.Utils.Crypto
       Test.Utils.Db
+      Test.Utils.Crypto
       Test.Utils.Jobs
       Test.Utils.Jobs.Types
       Test.Utils.Notifications

src/Gargantext/API/Node/Update.hs

@@ -9,10 +9,13 @@ Portability : POSIX
 
 -}
 
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators    #-}
+
 module Gargantext.API.Node.Update
       where
 
-import Control.Lens (view)
+import Control.Lens (view, (^?), _Just)
 import Data.Set qualified as Set
 import Gargantext.API.Admin.EnvTypes (Env)
 import Gargantext.API.Errors.Types ( BackendInternalError )
@@ -26,17 +29,17 @@ import Gargantext.Core.NodeStory.Types (HasNodeStory)
 import Gargantext.Core.Text.Ngrams (NgramsType(NgramsTerms))
 import Gargantext.Core.Types.Main (ListType(..))
 import Gargantext.Core.Viz.Graph.API (recomputeGraph)
-import Gargantext.Core.Viz.Phylo (subConfigAPI2config)
+import Gargantext.Core.Viz.Phylo (subConfigAPI2config, phylo_computeTime)
 import Gargantext.Core.Viz.Phylo.API.Tools (flowPhyloAPI)
 import Gargantext.Core.Worker.Jobs.Types qualified as Jobs
 import Gargantext.Database.Action.Flow (reIndexWith)
 import Gargantext.Database.Action.Flow.Pairing (pairing)
 import Gargantext.Database.Action.Metrics (updateNgramsOccurrences, updateContextScore)
-import Gargantext.Database.Admin.Types.Hyperdata.Phylo ( HyperdataPhylo(HyperdataPhylo) )
+import Gargantext.Database.Admin.Types.Hyperdata.Phylo ( HyperdataPhylo(HyperdataPhylo), hp_data )
 import Gargantext.Database.Admin.Types.Node ( NodeId, NodeType(NodeCorpus, NodeAnnuaire, NodeTexts, NodeGraph, NodePhylo, NodeList) )
-import Gargantext.Database.Query.Table.Node (defaultList, getNode, getChildrenByType)
+import Gargantext.Database.Query.Table.Node (defaultList, getNode, getChildrenByType, getNodeWith)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
-import Gargantext.Database.Schema.Node (node_parent_id)
+import Gargantext.Database.Schema.Node (node_parent_id, node_hyperdata)
 import Gargantext.Prelude
 import Gargantext.System.Logging ( MonadLogger )
 import Gargantext.Utils.Jobs.Monad (MonadJobStatus(..))
@@ -113,12 +116,14 @@ updateNode lId (UpdateNodeParamsList _mode) jobHandle = do
 
 updateNode phyloId (UpdateNodePhylo config) jobHandle = do
   markStarted 3 jobHandle
-  corpusId' <- view node_parent_id <$> getNode phyloId
+  oldPhylo      <- getNodeWith phyloId (Proxy @HyperdataPhylo)
+  let corpusId' = view node_parent_id oldPhylo
+  let mbComputeHistory = oldPhylo ^? node_hyperdata . hp_data . traverse . phylo_computeTime . _Just
   markProgress 1 jobHandle
 
   let corpusId = fromMaybe (panicTrace "no corpus id") corpusId'
 
-  phy <- timeMeasured "updateNode.flowPhyloAPI" $ flowPhyloAPI (subConfigAPI2config config) corpusId
+  phy <- timeMeasured "updateNode.flowPhyloAPI" $ flowPhyloAPI (subConfigAPI2config config) mbComputeHistory corpusId
   markProgress 2 jobHandle
 
 {-

src/Gargantext/Core/Text/Terms/Mono.hs

@@ -33,7 +33,7 @@ words = monoTexts
 
 -- | Sentence split separators
 isSep :: Char -> Bool
-isSep = (`elem` (",.:;?!(){}[]\"\'" :: String))
+isSep = (`elem` (",.:;?!(){}[]" :: String))
 
 monoTerms :: Lang -> Text -> [TermsWithCount]
 monoTerms l txt = map (\t -> (monoText2term l t, 1)) $ monoTexts txt

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

@@ -76,8 +76,9 @@ getGraph nId = do
         let defaultBridgenessMethod = BridgenessMethod_Basic
         graph' <- computeGraph cId defaultPartitionMethod defaultBridgenessMethod (withMetric defaultMetric) defaultEdgesStrength (NgramsTerms, NgramsTerms) repo
         mt     <- defaultGraphMetadata cId listId "Title" repo defaultMetric defaultEdgesStrength
+        let mt' = set gm_legend (generateLegend graph') mt
         let
-          graph'' = set graph_metadata (Just mt) graph'
+          graph'' = set graph_metadata (Just mt') graph'
           hg = HyperdataGraphAPI graph'' camera
        -- _      <- updateHyperdata nId hg
         _ <- updateHyperdata nId (HyperdataGraph (Just graph'') camera)
@@ -127,20 +128,27 @@ recomputeGraph nId partitionMethod bridgeMethod maybeSimilarity maybeStrength nt
 
   let computeG mt = do
         !g <- computeGraph cId partitionMethod bridgeMethod similarity strength (nt1,nt2) repo
-        let g' = set graph_metadata mt g
+        let mt' = set gm_legend (generateLegend g) mt
+        let g' = set graph_metadata (Just mt') g
         _nentries <- updateHyperdata nId (HyperdataGraph (Just g') camera)
         pure g'
 
   case graph of
     Nothing     -> do
       mt     <- defaultGraphMetadata cId listId "Title" repo (fromMaybe Order1 maybeSimilarity) strength
-      g <- computeG $ Just mt
+      g <- computeG mt
       pure $ trace ("[G.V.G.API.recomputeGraph] Graph empty, computed" :: Text) g
     Just graph' -> if (listVersion == Just v) && (not force')
                      then pure graph'
                      else do
-                       g <- computeG graphMetadata
-                       pure $ trace ("[G.V.G.API] Graph exists, recomputing" :: Text) g
+                       case graphMetadata of
+                         Nothing -> do
+                           mt <- defaultGraphMetadata cId listId "Title" repo (fromMaybe Order1 maybeSimilarity) strength
+                           g <- computeG mt
+                           pure $ trace ("[G.V.G.API] Graph exists, no metadata, recomputing" :: Text) g
+                         Just mt -> do
+                           g <- computeG mt
+                           pure $ trace ("[G.V.G.API] Graph exists, recomputing" :: Text) g
 
 
 -- TODO remove repo

src/Gargantext/Core/Viz/Graph/Tools.hs

@@ -34,7 +34,7 @@ import Gargantext.Core.Viz.Graph.Bridgeness (bridgeness, Bridgeness(..), Partiti
 import Gargantext.Core.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map, Index, MatrixShape(..))
 import Gargantext.Core.Viz.Graph.Tools.IGraph (mkGraphUfromEdges, spinglass, spinglass')
 import Gargantext.Core.Viz.Graph.Tools.Infomap (infomap)
-import Gargantext.Core.Viz.Graph.Types (Attributes(..), Edge(..), Graph(..), MultiPartite(..), Node(..), Partite(..), Strength(..))
+import Gargantext.Core.Viz.Graph.Types (Attributes(..), Edge(..), Graph(..), MultiPartite(..), Node(..), Partite(..), Strength(..), LegendField(..))
 import Gargantext.Core.Viz.Graph.Utils (edgesFilter, nodesFilter)
 import Gargantext.Prelude
 import Graph.BAC.ProxemyOptim qualified as BAC
@@ -377,3 +377,11 @@ filterByNeighbours threshold distanceMap = filteredMap
                                        $ Map.filterWithKey (\(from', _) _ -> idx == from') distanceMap
                            in List.take (round threshold) selected
                       ) indexes
+
+generateLegend :: Graph -> [LegendField]
+generateLegend (Graph { _graph_nodes = nodes }) = List.sortBy (\(LegendField {_lf_id = a}) (LegendField {_lf_id = b}) -> compare a b) $ foldl' f [] nodes
+  where
+    f :: [LegendField] -> Node -> [LegendField]
+    f acc (Node {node_attributes = Attributes {clust_default = i}}) = case List.find (\(LegendField {_lf_id}) -> _lf_id == i) acc of
+      Just _  -> acc
+      Nothing -> acc ++ [LegendField {_lf_id = i, _lf_label = "Cluster" <> show i, _lf_color = "#FFF"}]

src/Gargantext/Core/Viz/Phylo.hs

@@ -23,16 +23,23 @@ one 8, e54847.
 
 {-# LANGUAGE DeriveAnyClass   #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Gargantext.Core.Viz.Phylo where
 
+import Control.Lens (over)
 import Data.Swagger
-import Data.Text (pack)
 import Data.Text.Lazy qualified as TextLazy
-import Data.TreeDiff (ToExpr)
+import Data.Text (pack)
+import Data.TreeDiff (ToExpr (..))
 import Data.Vector (Vector)
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
 import Gargantext.Prelude
+import Gargantext.Utils.UTCTime (ElapsedSeconds)
+import qualified Data.Aeson.Types as JS
+import qualified Data.List.NonEmpty as NE
 import Test.QuickCheck
 import Test.QuickCheck.Instances.Text()
 import Test.QuickCheck.Instances.Vector()
@@ -110,8 +117,6 @@ data Synchrony =
 instance ToSchema Synchrony where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_")
 
-
-
 data TimeUnit =
       Epoch
       { _epoch_period :: Int
@@ -425,7 +430,13 @@ type Period = (Date,Date)
 type PeriodStr = (DateStr,DateStr)
 
 
+newtype ComputeTimeHistory
+  = ComputeTimeHistory (NonEmpty ElapsedSeconds)
+  deriving stock (Show, Eq, Generic)
+  deriving newtype ToExpr
 
+instance ToSchema ComputeTimeHistory where
+  declareNamedSchema _ = declareNamedSchema (Proxy @[ElapsedSeconds])
 
 -- | Phylo datatype of a phylomemy
 --  foundations : the foundations of the phylo
@@ -442,6 +453,12 @@ data Phylo =
            , _phylo_periods      :: Map Period PhyloPeriod
            , _phylo_quality      :: Double
            , _phylo_level        :: Double
+           -- See #409, store historical data on
+           -- how many seconds it took to generate
+           -- a given phylomemy graph, to give a rough
+           -- estimate to end users. The field is optional
+           -- to make it backward compatible.
+           , _phylo_computeTime  :: !(Maybe ComputeTimeHistory)
            }
            deriving (Generic, Show, Eq, ToExpr)
 
@@ -685,6 +702,15 @@ instance ToJSON Software
 instance FromJSON PhyloGroup
 instance ToJSON PhyloGroup
 
+instance ToJSON ComputeTimeHistory where
+ toJSON = \case
+   ComputeTimeHistory runs
+     -> toJSON runs
+
+instance FromJSON ComputeTimeHistory where
+  parseJSON (JS.Array runs) = ComputeTimeHistory <$> parseJSON (JS.Array runs)
+  parseJSON ty              = JS.typeMismatch "ComputeTimeHistory" ty
+
 $(deriveJSON (unPrefix "_foundations_"  ) ''PhyloFoundations)
 
 instance FromJSON Phylo
@@ -708,6 +734,7 @@ instance NFData PhyloParam
 instance NFData PhyloFoundations
 instance NFData PhyloCounts
 instance NFData PhyloSources
+instance NFData ComputeTimeHistory
 instance NFData Phylo
 instance NFData PhyloPeriod
 instance NFData PhyloScale
@@ -798,3 +825,36 @@ instance Arbitrary Filter where
 
 instance Arbitrary PhyloParam where
   arbitrary = pure defaultPhyloParam
+
+instance Arbitrary ComputeTimeHistory where
+  arbitrary = oneof [ ComputeTimeHistory . NE.fromList . getNonEmpty <$> arbitrary ]
+
+-- The 'resize' ensure our tests won't take too long as
+-- we won't be generating very long lists.
+instance Arbitrary Phylo where
+  arbitrary = Phylo <$> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+                    <*> resize 6 arbitrary
+
+--
+-- Functions that uses the lenses
+--
+
+-- | Adds the input 'ElapsedSeconds' to the 'Philo', in the 'ComputeTimeHistory'.
+trackComputeTime :: ElapsedSeconds -> Phylo -> Phylo
+trackComputeTime elapsedSecs = over phylo_computeTime update_time
+  where
+    -- In case we have more than one historical data available, we take only the last 5
+    -- runs, to not make the list unbounded.
+    update_time :: Maybe ComputeTimeHistory -> Maybe ComputeTimeHistory
+    update_time Nothing
+      = Just $ ComputeTimeHistory (NE.singleton elapsedSecs)
+    update_time (Just (ComputeTimeHistory (r NE.:| runs))) =
+      Just $ ComputeTimeHistory (elapsedSecs NE.:| (r : take 3 runs))
+

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

@@ -101,7 +101,9 @@ postPhylo phyloId = Named.PostPhylo $ \_lId -> do
     -- _sft = Just (Software "Gargantext" "4")
     -- _prm = initPhyloParam vrs sft (Just q)
   corpusId <- getClosestParentIdByType phyloId NodeCorpus
-  phy <- flowPhyloAPI defaultConfig (fromMaybe (panicTrace "[G.C.V.P.API] no corpus ID found") corpusId) -- params
+  -- Being the first time we ask for the Phylo, there is no historical data
+  -- available about computing time, so we pass 'Nothing'.
+  phy <- flowPhyloAPI defaultConfig Nothing (fromMaybe (panicTrace "[G.C.V.P.API] no corpus ID found") corpusId) -- params
   -- phyloId <- insertNodes [node NodePhylo "Phylo" (HyperdataPhylo Nothing (Just phy)) (Just corpusId) userId]
   _ <- updateHyperdata phyloId (HyperdataPhylo Nothing (Just phy))
   pure phyloId

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

@@ -33,7 +33,7 @@ import Gargantext.Core.NodeStory.Types (HasNodeStory)
 import Gargantext.Core.Text.Ngrams (NgramsType(..))
 import Gargantext.Core.Text.Terms.WithList (Patterns, buildPatterns, termsInText)
 import Gargantext.Core.Types.Main (ListType(MapTerm))
-import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo)
+import Gargantext.Core.Viz.Phylo (TimeUnit(..), Date, Document(..), PhyloConfig(..), Phylo (_phylo_computeTime), trackComputeTime, ComputeTimeHistory)
 import Gargantext.Core.Viz.Phylo.PhyloExport (toPhyloExport, dotToFile)
 import Gargantext.Core.Viz.Phylo.PhyloMaker  (toPhylo, toPhyloWithoutLink)
 import Gargantext.Core.Viz.Phylo.PhyloTools  ({-printIOMsg, printIOComment,-} setConfig)
@@ -49,7 +49,7 @@ import Gargantext.Database.Schema.Context ( ContextPoly(_context_hyperdata, _con
 import Gargantext.Database.Schema.Node ( NodePoly(_node_hyperdata), node_hyperdata )
 import Gargantext.Prelude hiding (to)
 import Gargantext.System.Logging ( MonadLogger, LogLevel(DEBUG), logLocM )
-import Gargantext.Utils.UTCTime (timeMeasured)
+import Gargantext.Utils.UTCTime (timeMeasured, timeMeasured'')
 import Prelude qualified
 import System.FilePath ((</>))
 import System.IO.Temp (withTempDirectory)
@@ -111,19 +111,23 @@ phylo2dot phylo = do
 
 
 flowPhyloAPI :: (HasNodeStory env err m, HasNodeError err, MonadLogger m)
-             => PhyloConfig -> CorpusId -> m Phylo
-flowPhyloAPI config cId = do
-  corpus <- corpusIdtoDocuments (timeUnit config) cId
-  let !phyloWithCliques = toPhyloWithoutLink corpus config
+             => PhyloConfig
+             -> Maybe ComputeTimeHistory
+             -- ^ Previous compute time historical data, if any.
+             -> CorpusId
+             -> m Phylo
+flowPhyloAPI config mbOldComputeHistory cId = do
+  corpus <- timeMeasured "flowPhyloAPI.corpusIdtoDocuments" $ corpusIdtoDocuments (timeUnit config) cId
   -- writePhylo phyloWithCliquesFile phyloWithCliques
   $(logLocM) DEBUG $ "PhyloConfig old: " <> show config
 
-  _ <- timeMeasured "flowPhyloAPI.phyloWithCliques" (pure $! phyloWithCliques)
+  (t1, phyloWithCliques) <- timeMeasured'' DEBUG "flowPhyloAPI.phyloWithCliques" (pure $! toPhyloWithoutLink corpus config)
+  (t2, phyloConfigured)  <- timeMeasured'' DEBUG "flowPhyloAPI.phyloConfigured" (pure $! setConfig config phyloWithCliques)
+  (t3, finalPhylo)       <- timeMeasured'' DEBUG "flowPhyloAPI.toPhylo" (pure $! toPhylo phyloConfigured)
 
-  let !phyloConfigured = setConfig config phyloWithCliques
-  _ <- timeMeasured "flowPhyloAPI.phyloConfigured" (pure $! phyloConfigured)
-
-  pure $! toPhylo phyloConfigured
+  -- As the phylo is computed fresh every time, without looking at the one stored (if any), we
+  -- have to manually propagate computing time across.
+  pure $! trackComputeTime (t1 + t2 + t3) (finalPhylo { _phylo_computeTime = mbOldComputeHistory })
 
 --------------------------------------------------------------------
 corpusIdtoDocuments :: (HasNodeStory env err m, HasNodeError err)

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

@@ -551,3 +551,4 @@ initPhylo docs conf =
                (fromList $ map (\prd -> (prd, PhyloPeriod prd ("","") (initPhyloScales 1 prd))) periods)
                0
                (_qua_granularity $ phyloQuality $ _phyloParam_config params)
+               Nothing

src/Gargantext/Utils/UTCTime.hs

@@ -12,20 +12,25 @@ Portability : POSIX
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Gargantext.Utils.UTCTime where
 
+import Data.Fixed (Fixed(..))
 import Data.Morpheus.Kind (SCALAR)
 import Data.Morpheus.Types (GQLType(..), DecodeScalar(..), EncodeScalar(..))
 import Data.Morpheus.Types qualified as DMT
 import Data.String (fromString)
-import Data.Swagger (ToSchema)
+import Data.Swagger (ToSchema (..))
 import Data.Text qualified as T
-import Data.Time (UTCTime)
-import Data.Time.Clock.POSIX (getPOSIXTime)
+import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)
+import Data.Time (UTCTime, nominalDiffTimeToSeconds)
+import Data.TreeDiff.Class
 import Gargantext.Prelude
 import Gargantext.System.Logging
 import Prelude (String)
+import Test.QuickCheck hiding (label)
 
 
 newtype NUTCTime = NUTCTime UTCTime
@@ -43,6 +48,23 @@ instance FromJSON NUTCTime
 instance ToJSON NUTCTime
 instance ToSchema NUTCTime
 
+newtype ElapsedSeconds = ElapsedSeconds { _Seconds :: POSIXTime }
+  deriving stock (Show, Eq, Generic)
+  deriving newtype (FromJSON, ToJSON, Num)
+
+instance NFData ElapsedSeconds
+
+instance ToExpr ElapsedSeconds where
+  toExpr (ElapsedSeconds x) =
+    let (MkFixed secs) = nominalDiffTimeToSeconds x
+    in toExpr secs
+
+instance ToSchema ElapsedSeconds where
+  declareNamedSchema _ = declareNamedSchema (Proxy @Int)
+
+instance Arbitrary ElapsedSeconds where
+  arbitrary = ElapsedSeconds . fromInteger . getPositive <$> arbitrary
+
 timeMeasured :: (MonadLogger m, MonadBase IO m, HasCallStack)
              => String
              -- ^ A label
@@ -51,18 +73,31 @@ timeMeasured :: (MonadLogger m, MonadBase IO m, HasCallStack)
              -> m a
 timeMeasured = withFrozenCallStack $ timeMeasured' DEBUG
 
-timeMeasured' :: (MonadLogger m, MonadBase IO m, HasCallStack)
+-- | A version of timeMeasured that also returns the elapsed time, in seconds.
+timeMeasured'' :: (MonadLogger m, MonadBase IO m, HasCallStack)
              => LogLevel
              -- ^ The severity of the log
              -> String
              -- ^ A label to identify the action.
              -> m a
              -- ^ The action to run
-             -> m a
-timeMeasured' severity label action = withFrozenCallStack $ do
+             -> m (ElapsedSeconds, a)
+timeMeasured'' severity label action = withFrozenCallStack $ do
   startTime <- liftBase getPOSIXTime
   res       <- action
   endTime   <- liftBase getPOSIXTime
-  let msg = label <> " took " <> (show $ endTime - startTime) <> " seconds to execute."
+  let finalTime = endTime - startTime
+  let msg = label <> " took " <> (show finalTime) <> " seconds to execute."
   $(logLocM) severity (fromString msg)
-  return res
+  pure (ElapsedSeconds finalTime, res)
+
+timeMeasured' :: (MonadLogger m, MonadBase IO m, HasCallStack)
+             => LogLevel
+             -- ^ The severity of the log
+             -> String
+             -- ^ A label to identify the action.
+             -> m a
+             -- ^ The action to run
+             -> m a
+timeMeasured' severity label action = withFrozenCallStack $
+  snd <$> timeMeasured'' severity label action

test/Test/API/Notifications.hs

@@ -40,8 +40,6 @@ import Test.Instances ()
 import Test.Utils.Notifications
 
 
-
--- tests :: D.Dispatcher -> Spec
 tests :: Spec
 tests = sequential $ aroundAll withTestDBAndPort $ do
   describe "Notifications" $ do

test/Test/API/Private.hs

@@ -9,8 +9,8 @@ module Test.API.Private (
 
 import Gargantext.API.Routes.Named.Node
 import Gargantext.API.Routes.Named.Private
-import Gargantext.Core.Types (Node)
 import Gargantext.Core.Types.Individu
+import Gargantext.Core.Types (Node)
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
 import Gargantext.Prelude hiding (get)
 import Network.HTTP.Client hiding (Proxy)

test/Test/Ngrams/Lang/Occurrences.hs

@@ -14,7 +14,28 @@ commentary with @some markup@.
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Test.Ngrams.Lang.Occurrences where
+import Test.Hspec
+import Data.Either
+import Gargantext.Core.Text.Terms.WithList
+import Gargantext.Core (Lang(ZH, EN))
+import Gargantext.Prelude
 
+test :: Spec
+test = do 
+    describe "terms in text counting" $ do
+            it "words with quotes should match" $ do
+                let ngrams = ["j'aime"]
+                let doc = "j'aime"
+                let output = []
+                    
+                termsInText EN (buildPatternsWith EN ngrams) doc `shouldBe` [("j'aime", 1)] 
+                
+            -- it "words with quotes should match and be case sentive" $ do
+            --     let ngrams = ["j'aIme"]
+            --     let doc = "j'aime"
+            --     let output = []
+                    
+            --     termsInText EN (buildPatternsWith EN ngrams) doc `shouldNotBe` [("j'aime", 1)] 
 {-
 import Test.Hspec
 

test/Test/Offline/JSON.hs

@@ -6,14 +6,15 @@
 module Test.Offline.JSON (tests) where
 
 import Data.Aeson
-import Data.ByteString qualified as B
 import Data.ByteString.Lazy.Char8 qualified as C8
+import Data.ByteString qualified as B
 import Data.Either
 import Gargantext.API.Errors
 import Gargantext.API.Node.Corpus.Types
 import Gargantext.API.Node.Types
 import Gargantext.API.Viz.Types
 import Gargantext.Core.Types.Phylo
+import qualified Gargantext.Core.Viz.Phylo as VizPhylo
 import Gargantext.Database.Admin.Types.Node
 import Paths_gargantext
 import Prelude
@@ -62,6 +63,8 @@ tests = testGroup "JSON" [
   , testProperty "GraphDataData" (jsonRoundtrip @GraphDataData)
   , testProperty "ObjectData"    (jsonRoundtrip @ObjectData)
   , testProperty "PhyloData"     (jsonRoundtrip @PhyloData)
+  , testProperty "ComputeTimeHistory" (jsonRoundtrip @VizPhylo.ComputeTimeHistory)
+  , testProperty "Phylo"         (jsonRoundtrip @VizPhylo.Phylo)
   , testProperty "LayerData"     (jsonRoundtrip @LayerData)
   , testCase "can parse bpa_phylo_test.json" testParseBpaPhylo
   , testCase "can parse open_science.json" testOpenSciencePhylo

test/Test/Offline/Phylo.hs

 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TupleSections #-}
 
 module Test.Offline.Phylo (tests) where
 
 import CLI.Phylo.Common
 import Data.Aeson as JSON
 import Data.Aeson.Types qualified as JSON
+import Data.Aeson.Encode.Pretty qualified as JSON
+import Data.ByteString.Lazy qualified as BL
 import Data.GraphViz.Attributes.Complete qualified as Graphviz
 import Data.Text.Lazy as TL
 import Data.TreeDiff
 import Data.Vector qualified as V
 import Gargantext.Core.Text.List.Formats.TSV
 import Gargantext.Core.Types.Phylo hiding (Phylo(..))
-import Gargantext.Core.Viz.Phylo hiding (EdgeType(..))
 import Gargantext.Core.Viz.Phylo.API.Tools (readPhylo, phylo2dot2json)
 import Gargantext.Core.Viz.Phylo.Example qualified as Cleopatre
+import Gargantext.Core.Viz.Phylo hiding (EdgeType(..))
 import Gargantext.Core.Viz.Phylo.PhyloExport
 import Gargantext.Core.Viz.Phylo.PhyloMaker (toPhylo, toPhyloWithoutLink)
 import Gargantext.Core.Viz.Phylo.PhyloTools
 import Paths_gargantext
 import Prelude
 import Test.Tasty
+import Test.Tasty.Golden (goldenVsStringDiff)
 import Test.Tasty.HUnit
+import qualified Test.Tasty.Golden.Advanced as Advanced
 
 phyloTestConfig :: PhyloConfig
 phyloTestConfig = PhyloConfig {
@@ -48,6 +53,32 @@ phyloTestConfig = PhyloConfig {
   , exportFilter = [ByBranchSize {_branch_size = 3.0}]
   }
 
+phyloGolden :: TestName -> (FilePath, IO BL.ByteString) -> TestTree
+phyloGolden testName (fp, action) =
+  goldenVsStringDiff testName differ fp action
+  where
+    differ ref new = [ "diff", "-u", "-w", "--color=always", ref, new]
+
+-- | Use this variant for those tests which requires a more sophisticated way of
+-- comparing outputs directly on the GraphData
+phyloGoldenGraphData :: TestName -> (FilePath, IO GraphData) -> TestTree
+phyloGoldenGraphData testName (goldenPath, getActual) =
+  Advanced.goldenTest testName getGolden getActual differ updateGolden
+  where
+    differ ref new = pure $ case compareGraphDataFuzzy ref new of
+      True  -> Nothing
+      False -> Just $ show (ansiWlEditExprCompact $ ediff ref new)
+
+    updateGolden :: GraphData -> IO ()
+    updateGolden gd = BL.writeFile goldenPath (JSON.encodePretty gd)
+
+    getGolden :: IO GraphData
+    getGolden = do
+      expected_e <- JSON.eitherDecodeFileStrict' =<< getDataFileName goldenPath
+      case expected_e of
+        Left err -> fail err
+        Right (expected :: GraphData) -> pure expected
+
 tests :: TestTree
 tests = testGroup "Phylo" [
   testGroup "Export" [
@@ -56,14 +87,14 @@ tests = testGroup "Phylo" [
   ]
   , testGroup "toPhyloWithoutLink" [
     testCase "returns expected data" testSmallPhyloWithoutLinkExpectedOutput
-  , testCase "phyloCleopatre returns expected data" testCleopatreWithoutLinkExpectedOutput
-  , testCase "Nadal canned corpus returns expected data" testNadalWithoutLinkExpectedOutput
+  , phyloGolden "phyloCleopatre returns expected data" testCleopatreWithoutLinkExpectedOutput
+  , phyloGolden "Nadal canned corpus returns expected data" testNadalWithoutLinkExpectedOutput
   ]
   , testGroup "phylo2dot2json" [
-    testCase "is deterministic" testPhylo2dot2json
+    phyloGoldenGraphData "is deterministic" testPhylo2dot2json
   ]
   , testGroup "toPhylo" [
-    testCase "is deterministic" testToPhyloDeterminism
+    phyloGolden "is deterministic" testToPhyloDeterminism
   ]
   , testGroup "relatedComponents" [
     testCase "finds simple connection" testRelComp_Connected
@@ -71,14 +102,13 @@ tests = testGroup "Phylo" [
   , testCase "parses csv phylo" testCsvPhylo
   ]
 
-testCleopatreWithoutLinkExpectedOutput :: Assertion
-testCleopatreWithoutLinkExpectedOutput = do
+testCleopatreWithoutLinkExpectedOutput :: (FilePath, IO BL.ByteString)
+testCleopatreWithoutLinkExpectedOutput =
   let actual = toPhyloWithoutLink Cleopatre.docs Cleopatre.config
-  expected <- readPhylo =<< getDataFileName "test-data/phylo/cleopatre.golden.json"
-  assertBool (show $ ansiWlEditExprCompact $ ediff expected actual) (expected == actual)
+  in ("test-data/phylo/cleopatre.golden.json", pure $ JSON.encodePretty actual)
 
-testNadalWithoutLinkExpectedOutput :: Assertion
-testNadalWithoutLinkExpectedOutput = do
+testNadalWithoutLinkExpectedOutput :: (FilePath, IO BL.ByteString)
+testNadalWithoutLinkExpectedOutput = ("test-data/phylo/nadal.golden.json",) $ do
   corpusPath'    <- getDataFileName "test-data/phylo/nadal_docslist.golden.tsv"
   listPath'      <- getDataFileName "test-data/phylo/nadal_ngramslist.golden.tsv"
   let config  = phyloTestConfig { corpusPath = corpusPath'
@@ -90,9 +120,7 @@ testNadalWithoutLinkExpectedOutput = do
                         (corpusPath config)
                         [Year 3 1 5,Month 3 1 5,Week 4 2 5]
                         mapList
-  let actual = setConfig phyloTestConfig $ toPhyloWithoutLink corpus config
-  expected   <- setConfig phyloTestConfig <$> (readPhylo =<< getDataFileName "test-data/phylo/nadal.golden.json")
-  assertBool (show $ ansiWlEditExprCompact $ ediff expected actual) (expected == actual)
+  pure $ JSON.encodePretty $ setConfig phyloTestConfig $ toPhyloWithoutLink corpus config
 
 testSmallPhyloWithoutLinkExpectedOutput :: Assertion
 testSmallPhyloWithoutLinkExpectedOutput = do
@@ -111,17 +139,12 @@ testSmallPhyloWithoutLinkExpectedOutput = do
   expected   <- setConfig phyloTestConfig <$> (readPhylo =<< getDataFileName "test-data/phylo/small-phylo.golden.json")
   assertBool (show $ ansiWlEditExprCompact $ ediff expected actual) (expected == actual)
 
-testPhylo2dot2json :: Assertion
-testPhylo2dot2json = do
-  expected_e <- JSON.eitherDecodeFileStrict' =<< getDataFileName "test-data/phylo/phylo2dot2json.golden.json"
-  case expected_e of
+testPhylo2dot2json :: (FilePath, IO GraphData)
+testPhylo2dot2json = ("test-data/phylo/phylo2dot2json.golden.json",) $ do
+  actual_e <- JSON.parseEither JSON.parseJSON <$> phylo2dot2json Cleopatre.phyloCleopatre
+  case actual_e of
     Left err -> fail err
-    Right (expected :: GraphData) -> do
-      actual_e <- JSON.parseEither JSON.parseJSON <$> phylo2dot2json Cleopatre.phyloCleopatre
-      case actual_e of
-        Left err -> fail err
-        Right (actual :: GraphData) -> do
-          assertBool ("Phylo mismatch!" <> show (ansiWlEditExprCompact $ ediff expected actual)) (expected `compareGraphDataFuzzy` actual)
+    Right (actual :: GraphData) -> pure actual
 
 compareGraphDataFuzzy :: GraphData -> GraphData -> Bool
 compareGraphDataFuzzy gd1 gd2 =
@@ -232,8 +255,8 @@ testRelComp_Connected = do
   (relatedComponents @Int) [[1,2], [3,5], [2,4],[9,5],[5,4]] @?= [[1,2,4,3,5,9]]
   (relatedComponents @Int) [[1,2,5], [4,5,9]]                @?= [[1,2,5,4,9]]
 
-testToPhyloDeterminism :: Assertion
-testToPhyloDeterminism = do
+testToPhyloDeterminism :: (FilePath, IO BL.ByteString)
+testToPhyloDeterminism = ("test-data/phylo/187481.json",) $ do
   corpusPath' <- getDataFileName "test-data/phylo/GarganText_DocsList-nodeId-187481.tsv"
   listPath'   <- getDataFileName "test-data/phylo/GarganText_NgramsList-187482.tsv"
   let config  = phyloTestConfig { corpusPath = corpusPath'
@@ -246,8 +269,7 @@ testToPhyloDeterminism = do
                               [Year 3 1 5,Month 3 1 5,Week 4 2 5]
                               mapList
   let actual = setConfig phyloTestConfig $ toPhylo $ toPhyloWithoutLink corpus config
-  expected    <- setConfig phyloTestConfig <$> (readPhylo =<< getDataFileName "test-data/phylo/187481.json")
-  assertBool ("Phylo mismatch! " <> show (ansiWlEditExprCompact $ ediff expected actual)) (expected == actual)
+  pure $ JSON.encodePretty actual
 
 testCsvPhylo :: Assertion
 testCsvPhylo = do

test/drivers/tasty/Main.hs

@@ -17,6 +17,7 @@ import qualified Test.Core.Text.Corpus.TSV       as TSVParser
 import qualified Test.Core.Utils                 as Utils
 import qualified Test.Core.Worker                as Worker
 import qualified Test.Graph.Clustering           as Graph
+import qualified Test.Ngrams.Lang.Occurrences    as Occurrences
 import qualified Test.Ngrams.NLP                 as NLP
 import qualified Test.Ngrams.Query               as NgramsQuery
 import qualified Test.Offline.JSON               as JSON
@@ -42,6 +43,7 @@ main = do
   jobsSpec         <- testSpec "Jobs" Jobs.test
   similaritySpec   <- testSpec "Similarity" Similarity.test
   asyncUpdatesSpec <- testSpec "Notifications" Notifications.test
+  occurrencesSpec  <- testSpec "Occurrences" Occurrences.test
 
   defaultMain $ testGroup "Gargantext"
     [ utilSpec
@@ -51,6 +53,7 @@ main = do
     , nlpSpec
     , jobsSpec
     , NgramsQuery.tests
+    , occurrencesSpec
     , CorpusQuery.tests
     , TSVParser.tests
     , JSON.tests