Skip to content

haskell-gargantext
haskell-gargantext
Commit b6f257b3 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli
Browse files
Options

Merge branch 'adinapoli/issue-342' into 'dev' 

Forest of trees: restore hierarchical grouping of terms

Closes #313

See merge request !424
parents 3755ded0 186214c6
Pipeline #7785 passed with stages
          in 98 minutes and 52 seconds
          Hide whitespace changes
          Inline Side-by-side
          Showing with 829 additions and 276 deletions
          gargantext.cabal
          View file @ b6f257b3
          ...@@ -570,6 +570,7 @@ library ...@@ -570,6 +570,7 @@ library
          , json-stream ^>= 0.4.2.4 , json-stream ^>= 0.4.2.4
          , lens >= 5.2.2 && < 5.3 , lens >= 5.2.2 && < 5.3
          , lens-aeson < 1.3 , lens-aeson < 1.3
          , list-zipper
          , massiv < 1.1 , massiv < 1.1
          , matrix ^>= 0.3.6.1 , matrix ^>= 0.3.6.1
          , mime-mail >= 0.5.1 , mime-mail >= 0.5.1
          ......
          src/Gargantext/API/Ngrams.hs
          View file @ b6f257b3
          ...@@ -18,12 +18,13 @@ add get ...@@ -18,12 +18,13 @@ add get
          {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
          {-# OPTIONS_GHC -fno-warn-deprecations #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}
          {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-}
          {-# LANGUAGE ConstraintKinds #-}
          {-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE IncoherentInstances #-}
          {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
          {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
          {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
          {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
          module Gargantext.API.Ngrams module Gargantext.API.Ngrams
          ...@@ -82,10 +83,21 @@ module Gargantext.API.Ngrams ...@@ -82,10 +83,21 @@ module Gargantext.API.Ngrams
          -- * Handlers to be used when serving top-level API requests -- * Handlers to be used when serving top-level API requests
          , getTableNgramsCorpusHandler , getTableNgramsCorpusHandler
          -- * Internals for testing
          , compute_new_state_patches
          , PatchHistory(..)
          , newNgramsFromNgramsStatePatch
          , filterNgramsNodes
          -- * Operations on a forest
          , buildForest
          , destroyForest
          , pruneForest
          ) )
          where where
          import Control.Lens (view, (^..), (+~), (%~), msumOf, at, ix, _Just, Each(..), (%%~), ifolded, to, withIndex, over) import Control.Lens (view, (^..), (+~), (%~), msumOf, at, ix, _Just, Each(..), (%%~), ifolded, to, withIndex)
          import Data.Aeson.Text qualified as DAT import Data.Aeson.Text qualified as DAT
          import Data.List qualified as List import Data.List qualified as List
          import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
          ...@@ -94,9 +106,11 @@ import Data.Patch.Class (Action(act), Transformable(..), ours) ...@@ -94,9 +106,11 @@ import Data.Patch.Class (Action(act), Transformable(..), ours)
          import Data.Set qualified as Set import Data.Set qualified as Set
          import Data.Text (isInfixOf, toLower, unpack) import Data.Text (isInfixOf, toLower, unpack)
          import Data.Text.Lazy.IO as DTL ( writeFile ) import Data.Text.Lazy.IO as DTL ( writeFile )
          import Data.Tree
          import Gargantext.API.Ngrams.Tools (getNodeStory) import Gargantext.API.Ngrams.Tools (getNodeStory)
          import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
          import Gargantext.Core.NodeStory (ArchiveList, HasNodeStory, NgramsStatePatch', a_history, a_state, a_version, currentVersion, NodeStoryEnv, hasNodeArchiveStoryImmediateSaver, hasNodeStoryImmediateSaver, HasNodeStoryEnv (..)) import Gargantext.Core.NodeStory hiding (buildForest)
          import Gargantext.Core.NodeStory qualified as NodeStory
          import Gargantext.Core.Text.Ngrams (Ngrams, NgramsType) import Gargantext.Core.Text.Ngrams (Ngrams, NgramsType)
          import Gargantext.Core.Types (ListType(..), NodeId, ListId, TODO, assertValid, ContextId, HasValidationError) import Gargantext.Core.Types (ListType(..), NodeId, ListId, TODO, assertValid, ContextId, HasValidationError)
          import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..)) import Gargantext.Core.Types.Query (Limit(..), Offset(..), MinSize(..), MaxSize(..))
          ...@@ -107,7 +121,6 @@ import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf) ...@@ -107,7 +121,6 @@ import Gargantext.Prelude hiding (log, to, toLower, (%), isInfixOf)
          import Text.Collate qualified as Unicode import Text.Collate qualified as Unicode
          {- {-
          -- TODO sequences of modifications (Patchs) -- TODO sequences of modifications (Patchs)
          type NgramsIdPatch = Patch NgramsId NgramsPatch type NgramsIdPatch = Patch NgramsId NgramsPatch
          ...@@ -261,25 +274,11 @@ commitStatePatch :: NodeStoryEnv err ...@@ -261,25 +274,11 @@ commitStatePatch :: NodeStoryEnv err
          -> Versioned NgramsStatePatch' -> Versioned NgramsStatePatch'
          -> DBUpdate err (Versioned NgramsStatePatch') -> DBUpdate err (Versioned NgramsStatePatch')
          commitStatePatch env listId (Versioned _p_version p) = do commitStatePatch env listId (Versioned _p_version p) = do
          -- printDebug "[commitStatePatch]" listId
          a <- getNodeStory env listId a <- getNodeStory env listId
          let archiveSaver = view hasNodeArchiveStoryImmediateSaver env let archiveSaver = view hasNodeArchiveStoryImmediateSaver env
          -- ns <- liftBase $ atomically $ readTVar var
          let
          -- a = ns ^. unNodeStory . at listId . non initArchive
          -- apply patches from version p_version to a ^. a_version
          -- TODO Check this
          --q = mconcat $ take (a ^. a_version - p_version) (a ^. a_history)
          q = mconcat $ a ^. a_history
          --printDebug "[commitStatePatch] transformWith" (p,q)
          -- let tws s = case s of
          -- (Mod p) -> "Mod"
          -- _ -> "Rpl"
          -- printDebug "[commitStatePatch] transformWith" (tws $ p ^. _NgramsPatch, tws $ q ^. _NgramsPatch)
          let let
          (p', q') = transformWith ngramsStatePatchConflictResolution p q (p', q') = compute_new_state_patches p (PatchHistory $ a ^. a_history)
          a' = a & a_version +~ 1 a' = a & a_version +~ 1
          & a_state %~ act p' & a_state %~ act p'
          & a_history %~ (p' :) & a_history %~ (p' :)
          ...@@ -335,6 +334,27 @@ commitStatePatch env listId (Versioned _p_version p) = do ...@@ -335,6 +334,27 @@ commitStatePatch env listId (Versioned _p_version p) = do
          pure newA pure newA
          newtype PatchHistory =
          PatchHistory { _PatchHistory :: [ NgramsStatePatch' ] }
          deriving (Show, Eq)
          -- | Computes the new state patch from the new patch and
          -- the history of patches applied up to this point.
          -- Returns a pair of patches (p,q) following the semantic of
          -- the 'Transformable' class, that says:
          --
          -- Given two diverging patches @p@ and @q@, @transformWith m p q@ returns
          -- a pair of updated patches @(p',q')@ such that @p' <> q@ and
          -- @q' <> p@ are equivalent patches that incorporate the changes
          -- of /both/ @p@ and @q@, up to merge conflicts, which are handled by
          -- the provided function @m@.
          compute_new_state_patches :: NgramsStatePatch'
          -> PatchHistory
          -> (NgramsStatePatch', NgramsStatePatch')
          compute_new_state_patches latest_patch (PatchHistory history) =
          let squashed_history = mconcat history
          in transformWith ngramsStatePatchConflictResolution latest_patch squashed_history
          -- This is a special case of tableNgramsPut where the input patch is empty. -- This is a special case of tableNgramsPut where the input patch is empty.
          tableNgramsPull :: NodeStoryEnv err tableNgramsPull :: NodeStoryEnv err
          ...@@ -410,6 +430,60 @@ dumpJsonTableMap fpath nodeId ngramsType = do ...@@ -410,6 +430,60 @@ dumpJsonTableMap fpath nodeId ngramsType = do
          liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m) liftBase $ DTL.writeFile (unpack fpath) (DAT.encodeToLazyText m)
          pure () pure ()
          -- | Filters the given `tableMap` with the search criteria. It returns
          -- the input map, where each bucket indexed by a 'NgramsTerm' has been
          -- filtered via the given predicate. Removes the key from the map if
          -- the filtering would result in the empty set.
          filterNgramsNodes :: Maybe ListType
          -> Maybe MinSize
          -> Maybe MaxSize
          -> (NgramsTerm -> Bool)
          -> Map NgramsTerm NgramsElement
          -> Map NgramsTerm NgramsElement
          filterNgramsNodes listTy minSize maxSize searchFn tblMap =
          flip Map.mapMaybe tblMap $ \e ->
          case matchingNode listTy minSize maxSize searchFn e of
          False -> Nothing
          True -> Just e
          -- | Returns 'True' if the input 'NgramsElement' satisfies the search criteria
          -- mandated by 'NgramsSearchQuery'.
          matchingNode :: Maybe ListType
          -> Maybe MinSize
          -> Maybe MaxSize
          -> (NgramsTerm -> Bool)
          -> NgramsElement
          -> Bool
          matchingNode listType minSize maxSize searchQuery inputNode =
          let nodeSize = inputNode ^. ne_size
          matchesListType = maybe (const True) (==) listType
          respectsMinSize = maybe (const True) ((<=) . getMinSize) minSize
          respectsMaxSize = maybe (const True) ((>=) . getMaxSize) maxSize
          in respectsMinSize nodeSize
          && respectsMaxSize nodeSize
          && searchQuery (inputNode ^. ne_ngrams)
          && matchesListType (inputNode ^. ne_list)
          -- | Version of 'buildForest' specialised over the 'NgramsElement' as the values of the tree.
          -- We can't use a single function to \"rule them all\" because the 'NgramsRepoElement', that
          -- the 'NodeStory' uses does not have an 'ngrams' we can use as the key when building and
          -- destroying a forest.
          buildForest :: Map NgramsTerm NgramsElement -> Forest NgramsElement
          buildForest = map (fmap snd) . NodeStory.buildForest
          -- | Folds an Ngrams forest back to a table map.
          -- This function doesn't aggregate information, but merely just recostructs the original
          -- map without loss of information. To perform operations on the forest, use the appropriate
          -- functions.
          destroyForest :: Forest NgramsElement -> Map NgramsTerm NgramsElement
          destroyForest f = Map.fromList . map (foldTree destroyTree) $ f
          where
          destroyTree :: NgramsElement -> [(NgramsTerm, NgramsElement)] -> (NgramsTerm, NgramsElement)
          destroyTree rootEl childrenEl = (_ne_ngrams rootEl, squashElements rootEl childrenEl)
          squashElements :: NgramsElement -> [(NgramsTerm, NgramsElement)] -> NgramsElement
          squashElements r _ = r
          -- | TODO Errors management -- | TODO Errors management
          -- TODO: polymorphic for Annuaire or Corpus or ... -- TODO: polymorphic for Annuaire or Corpus or ...
          ...@@ -417,7 +491,7 @@ dumpJsonTableMap fpath nodeId ngramsType = do ...@@ -417,7 +491,7 @@ dumpJsonTableMap fpath nodeId ngramsType = do
          -- TODO: should take only one ListId -- TODO: should take only one ListId
          -- | /pure/ function to query a 'Map NgramsTerm NgramsElement', according to a -- | /pure/ function to query a 'Map NgramsTerm NgramsElement', according to a
          -- search function. Returns a /versioned/ 'NgramsTable' which is paginated and -- search function. Returns a /versioned/ 'NgramsTable' which is paginated and
          -- sorted according to the input 'NgramsSearchQuery', together with the -- sorted according to the input 'NgramsSearchQuery', together with the
          -- occurrences of the elements. -- occurrences of the elements.
          searchTableNgrams :: Versioned (Map NgramsTerm NgramsElement) searchTableNgrams :: Versioned (Map NgramsTerm NgramsElement)
          ...@@ -426,42 +500,14 @@ searchTableNgrams :: Versioned (Map NgramsTerm NgramsElement) ...@@ -426,42 +500,14 @@ searchTableNgrams :: Versioned (Map NgramsTerm NgramsElement)
          -> VersionedWithCount NgramsTable -> VersionedWithCount NgramsTable
          searchTableNgrams versionedTableMap NgramsSearchQuery{..} = searchTableNgrams versionedTableMap NgramsSearchQuery{..} =
          let tableMap = versionedTableMap ^. v_data let tableMap = versionedTableMap ^. v_data
          filteredData = filterNodes tableMap filteredData = filterNgramsNodes _nsq_listType _nsq_minSize _nsq_maxSize _nsq_searchQuery tableMap
          forestRoots = Set.fromList . Map.elems . destroyForest . buildForest $ filteredData
          tableMapSorted = versionedTableMap tableMapSorted = versionedTableMap
          & v_data .~ (NgramsTable . sortAndPaginate . withInners tableMap $ filteredData) & v_data .~ (NgramsTable . sortAndPaginate . withInners tableMap $ forestRoots)
          in toVersionedWithCount (Set.size filteredData) tableMapSorted in toVersionedWithCount (Set.size forestRoots) tableMapSorted
          where where
          -- | Returns the \"root\" of the 'NgramsElement', or it falls back to the input
          -- 'NgramsElement' itself, if no root can be found.
          -- /CAREFUL/: The root we select might /not/ have the same 'listType' we are
          -- filtering for, in which case we have to change its type to match, if needed.
          rootOf :: Map NgramsTerm NgramsElement -> NgramsElement -> NgramsElement
          rootOf tblMap ne = case ne ^. ne_root of
          Nothing -> ne
          Just rootKey
          | Just r <- tblMap ^. at rootKey
          -- NOTE(adinapoli) It's unclear what is the correct behaviour here: should
          -- we override the type or we filter out the node altogether?
          -> over ne_list (\oldList -> fromMaybe oldList _nsq_listType) r
          | otherwise
          -> ne
          -- | Returns 'True' if the input 'NgramsElement' satisfies the search criteria
          -- mandated by 'NgramsSearchQuery'.
          matchingNode :: NgramsElement -> Bool
          matchingNode inputNode =
          let nodeSize = inputNode ^. ne_size
          matchesListType = maybe (const True) (==) _nsq_listType
          respectsMinSize = maybe (const True) ((<=) . getMinSize) _nsq_minSize
          respectsMaxSize = maybe (const True) ((>=) . getMaxSize) _nsq_maxSize
          in respectsMinSize nodeSize
          && respectsMaxSize nodeSize
          && _nsq_searchQuery (inputNode ^. ne_ngrams)
          && matchesListType (inputNode ^. ne_list)
          -- Sorts the input 'NgramsElement' list. -- Sorts the input 'NgramsElement' list.
          -- /IMPORTANT/: As we might be sorting ngrams in all sorts of language, -- /IMPORTANT/: As we might be sorting ngrams in all sorts of language,
          -- some of them might include letters with accents and other unicode symbols, -- some of them might include letters with accents and other unicode symbols,
          ...@@ -477,14 +523,6 @@ searchTableNgrams versionedTableMap NgramsSearchQuery{..} = ...@@ -477,14 +523,6 @@ searchTableNgrams versionedTableMap NgramsSearchQuery{..} =
          ngramTermsAscSorter = on unicodeDUCETSorter (unNgramsTerm . view ne_ngrams) ngramTermsAscSorter = on unicodeDUCETSorter (unNgramsTerm . view ne_ngrams)
          ngramTermsDescSorter = on (\n1 n2 -> unicodeDUCETSorter n2 n1) (unNgramsTerm . view ne_ngrams) ngramTermsDescSorter = on (\n1 n2 -> unicodeDUCETSorter n2 n1) (unNgramsTerm . view ne_ngrams)
          -- | Filters the given `tableMap` with the search criteria. It returns
          -- a set of 'NgramsElement' all matching the input 'NGramsSearchQuery'.
          filterNodes :: Map NgramsTerm NgramsElement -> Set NgramsElement
          filterNodes tblMap = Set.map (rootOf tblMap) selectedNodes
          where
          allNodes = Set.fromList $ Map.elems tblMap
          selectedNodes = Set.filter matchingNode allNodes
          -- | For each input root, extends its occurrence count with -- | For each input root, extends its occurrence count with
          -- the information found in the subitems. -- the information found in the subitems.
          withInners :: Map NgramsTerm NgramsElement -> Set NgramsElement -> Set NgramsElement withInners :: Map NgramsTerm NgramsElement -> Set NgramsElement -> Set NgramsElement
          ......
          src/Gargantext/API/Ngrams/NgramsTree.hs
          View file @ b6f257b3
          ...@@ -10,10 +10,17 @@ Portability : POSIX ...@@ -10,10 +10,17 @@ Portability : POSIX
          -} -}
          {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
          module Gargantext.API.Ngrams.NgramsTree module Gargantext.API.Ngrams.NgramsTree
          where ( -- * Types
          NgramsForest(..)
          , NgramsTree
          , GeneralisedNgramsTree(..)
          -- * Construction
          , toNgramsTree
          , toNgramsForest
          ) where
          import Data.Aeson
          import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
          import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
          import Data.List qualified as List import Data.List qualified as List
          ...@@ -23,41 +30,80 @@ import Data.Tree ( Tree(Node), unfoldForest ) ...@@ -23,41 +30,80 @@ import Data.Tree ( Tree(Node), unfoldForest )
          import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
          import Gargantext.Core.Types.Main ( ListType(..) ) import Gargantext.Core.Types.Main ( ListType(..) )
          import Gargantext.Database.Admin.Types.Node ( NodeId ) import Gargantext.Database.Admin.Types.Node ( NodeId )
          import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger) import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
          import Gargantext.Prelude import Gargantext.Prelude
          import Test.QuickCheck ( Arbitrary(arbitrary) ) import Test.QuickCheck ( Arbitrary(arbitrary) )
          type Children = Text -- | Ngrams forms a forest, i.e. a set of trees, each tree represents a strong grouping
          type Root = Text -- between terms. Each tree has a root and some children, of arbitrary depth. We use
          -- this data structure internally to represent ngrams tables in a principled way, and later
          -- we \"render\" them back into an 'NgramsTable' and/or a set of ngrams elements, where
          -- each 'NgramElement' is a standalone tree.
          --
          -- Properties:
          --
          -- * Aciclic: each tree is a DAG, and therefore there must be no cycles within the tree,
          -- and no cycles between trees in the forest.
          --
          -- /NOTE/: An 'NgramsForest' and a 'GeneralisedNgramsTree' are essentially isomorphic to the \"Tree\"
          -- and \"Forest\" types from the \"containers\" library, but our version allows storing both a label and
          -- a value for each node.
          newtype NgramsForest =
          NgramsForest { getNgramsForest :: [NgramsTree] }
          deriving (Show, Eq, Ord)
          type NgramsTree = GeneralisedNgramsTree Text Int
          data NgramsTree = NgramsTree { mt_label :: Text -- | Models a general ngram tree polymorphic over a label 'l' and a measure 'm'.
          , mt_value :: Double data GeneralisedNgramsTree l m =
          , mt_children :: [NgramsTree] GeneralisedNgramsTree { mt_label :: l
          } , mt_value :: m
          deriving (Generic, Show, Eq) , mt_children :: [GeneralisedNgramsTree l m]
          }
          deriving (Generic, Show, Eq, Ord)
          toNgramsTree :: Tree (NgramsTerm,Double) -> NgramsTree instance (ToJSON l, ToJSON m) => ToJSON (GeneralisedNgramsTree l m) where
          toNgramsTree (Node (NgramsTerm l,v) xs) = NgramsTree l v (map toNgramsTree xs) toJSON (GeneralisedNgramsTree l m children) =
          object [ "label" .= toJSON l
          , "value" .= toJSON m
          , "children" .= toJSON children
          ]
          deriveJSON (unPrefix "mt_") ''NgramsTree instance (FromJSON l, FromJSON m) => FromJSON (GeneralisedNgramsTree l m) where
          parseJSON = withObject "NgramsTree" $ \o -> do
          mt_label <- o .: "label"
          mt_value <- o .: "value"
          mt_children <- o .: "children"
          pure $ GeneralisedNgramsTree{..}
          instance ToSchema NgramsTree where instance ToSchema NgramsTree where
          declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_") declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_")
          instance Arbitrary NgramsTree instance Arbitrary NgramsTree
          where where
          arbitrary = NgramsTree <$> arbitrary <*> arbitrary <*> arbitrary arbitrary = GeneralisedNgramsTree <$> arbitrary <*> arbitrary <*> arbitrary
          --
          -- Constructing trees and forests
          --
          -- | Given a 'Tree' from the \"containers\" library that has an 'NgramsTerm' and a score at the leaves,
          -- converts it into a gargantext 'NgramsTree' tree.
          toNgramsTree :: Tree (NgramsTerm,Int) -> NgramsTree
          toNgramsTree (Node (NgramsTerm l,v) xs) = GeneralisedNgramsTree l v (map toNgramsTree xs)
          toTree :: ListType -- | Given a 'ListType', which informs which category of terms we want to focus on (stop, map, candidate)
          -> HashMap NgramsTerm (Set NodeId) -- and two hashmaps mapping an 'NgramsTerm' to their values, builds an 'NgramsForest'.
          -> HashMap NgramsTerm NgramsRepoElement toNgramsForest :: ListType
          -> [NgramsTree] -> HashMap NgramsTerm (Set NodeId)
          toTree lt vs m = map toNgramsTree $ unfoldForest buildNode roots -> HashMap NgramsTerm NgramsRepoElement
          -> NgramsForest
          toNgramsForest lt vs m = NgramsForest $ map toNgramsTree $ unfoldForest buildNode roots
          where where
          buildNode r = maybe ((r, value r),[]) buildNode r = maybe ((r, value r),[])
          (\x -> ((r, value r), mSetToList $ _nre_children x)) (\x -> ((r, value r), mSetToList $ _nre_children x))
          (HashMap.lookup r m) (HashMap.lookup r m)
          value l = maybe 0 (fromIntegral . Set.size) $ HashMap.lookup l vs value l = maybe 0 Set.size $ HashMap.lookup l vs
          rootsCandidates :: [NgramsTerm] rootsCandidates :: [NgramsTerm]
          rootsCandidates = catMaybes rootsCandidates = catMaybes
          ......
          src/Gargantext/Core/NodeStory.hs
          View file @ b6f257b3
          ...@@ -43,27 +43,31 @@ TODO: ...@@ -43,27 +43,31 @@ TODO:
          {-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
          {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ConstraintKinds #-}
          {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
          {-# LANGUAGE ScopedTypeVariables #-}
          module Gargantext.Core.NodeStory module Gargantext.Core.NodeStory
          ( module Gargantext.Core.NodeStory.Types ( module Gargantext.Core.NodeStory.Types
          , getNodesArchiveHistory , getNodesArchiveHistory
          , Archive(..) , Archive(..)
          , ArchiveStateForest
          , nodeExists , nodeExists
          , getNodesIdWithType , getNodesIdWithType
          , mkNodeStoryEnv , mkNodeStoryEnv
          , upsertNodeStories , upsertNodeStories
          -- , getNodeStory
          , getNodeStory' , getNodeStory'
          , nodeStoriesQuery , nodeStoriesQuery
          , currentVersion , currentVersion
          , archiveStateFromList , archiveStateFromList
          , archiveStateToList , archiveStateToList
          , fixNodeStoryVersions , fixNodeStoryVersions
          , fixChildrenDuplicatedAsParents , getParentsChildren
          , getParentsChildren ) -- * Operations on trees and forests
          where , buildForest
          , pruneForest
          import Control.Lens ((%~), non, _Just, at, over) ) where
          import Control.Lens ((%~), non, _Just, at, over, Lens')
          import Data.ListZipper
          import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
          import Data.Set qualified as Set import Data.Set qualified as Set
          import Database.PostgreSQL.Simple qualified as PGS import Database.PostgreSQL.Simple qualified as PGS
          ...@@ -77,6 +81,73 @@ import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) ) ...@@ -77,6 +81,73 @@ import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) )
          import Gargantext.Database.Admin.Config () import Gargantext.Database.Admin.Config ()
          import Gargantext.Database.Prelude import Gargantext.Database.Prelude
          import Gargantext.Prelude hiding (to) import Gargantext.Prelude hiding (to)
          import Data.Tree
          class HasNgramChildren e where
          ngramsElementChildren :: Lens' e (MSet NgramsTerm)
          instance HasNgramChildren NgramsRepoElement where
          ngramsElementChildren = nre_children
          instance HasNgramChildren NgramsElement where
          ngramsElementChildren = ne_children
          class HasNgramParent e where
          ngramsElementParent :: Lens' e (Maybe NgramsTerm)
          instance HasNgramParent NgramsRepoElement where
          ngramsElementParent = nre_parent
          instance HasNgramParent NgramsElement where
          ngramsElementParent = ne_parent
          -- | A 'Forest' (i.e. a list of trees) that models a hierarchy of ngrams terms, possibly grouped in
          -- a nested fashion, all wrapped in a 'Zipper'. Why using a 'Zipper'? Because when traversing the
          -- forest (for example to fix the children in case of dangling imports) we need sometimes to search
          -- things into the forest, but crucially we do not want to search also inside the tree we are
          -- currently iterating on! A zipper gives exactly that, i.e. a way to \"focus\" only on a particular
          -- piece of a data structure.
          type ArchiveStateForest = ListZipper (Tree (NgramsTerm, NgramsRepoElement))
          buildForestsFromArchiveState :: NgramsState' -> Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
          buildForestsFromArchiveState = Map.map buildForest
          destroyArchiveStateForest :: Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement)) -> NgramsState'
          destroyArchiveStateForest = Map.map destroyForest
          -- | Builds an ngrams forest from the input ngrams table map.
          buildForest :: forall e. HasNgramChildren e => Map NgramsTerm e -> Forest (NgramsTerm, e)
          buildForest mp = unfoldForest mkTreeNode (Map.toList mp)
          where
          mkTreeNode :: (NgramsTerm, e) -> ((NgramsTerm, e), [(NgramsTerm, e)])
          mkTreeNode (k, el) = ((k, el), mapMaybe findChildren $ mSetToList (el ^. ngramsElementChildren))
          findChildren :: NgramsTerm -> Maybe (NgramsTerm, e)
          findChildren t = Map.lookup t mp <&> \el -> (t, el)
          -- | Folds an Ngrams forest back to a table map.
          -- This function doesn't aggregate information, but merely just recostructs the original
          -- map without loss of information. To perform operations on the forest, use the appropriate
          -- functions.
          destroyForest :: Forest (NgramsTerm, NgramsRepoElement) -> Map NgramsTerm NgramsRepoElement
          destroyForest f = Map.fromList . map (foldTree destroyTree) $ f
          where
          destroyTree :: (NgramsTerm, NgramsRepoElement)
          -> [(NgramsTerm, NgramsRepoElement)]
          -> (NgramsTerm, NgramsRepoElement)
          destroyTree (k, rootEl) childrenEl = (k, squashElements rootEl childrenEl)
          squashElements :: e -> [(NgramsTerm, e)] -> e
          squashElements r _ = r
          -- | Prunes the input 'Forest' of 'NgramsElement' by keeping only the roots, i.e. the
          -- nodes which has no children /AND/ they do not appear in any other 'children' relationship.
          -- /NOTE ON IMPLEMENTATION:/ The fast way to do this is to simply filter each tree, ensuring
          -- that we keep only trees which root has no parent or root (i.e. it's a root itself!) and this
          -- will work only under the assumption that the input 'Forest' has been built correctly, i.e.
          -- with the correct relationships specified, or this will break.
          pruneForest :: HasNgramParent e => Forest e -> Forest e
          pruneForest = filter (\(Node r _) -> isNothing (r ^. ngramsElementParent))
          getNodeStory' :: NodeId -> DBQuery err x ArchiveList getNodeStory' :: NodeId -> DBQuery err x ArchiveList
          ...@@ -94,15 +165,6 @@ getNodeStory' nId = do ...@@ -94,15 +165,6 @@ getNodeStory' nId = do
          -- `node_id`, `version` and there is a M2M table -- `node_id`, `version` and there is a M2M table
          -- `node_stories_ngrams` without the `version` colum? Then we would -- `node_stories_ngrams` without the `version` colum? Then we would
          -- have `version` in only one place. -- have `version` in only one place.
          {-
          let versionsS = Set.fromList $ map (\a -> a ^. a_version) dbData
          if Set.size versionsS > 1 then
          panic $ Text.pack $ "[getNodeStory] versions for " <> show nodeId <> " differ! " <> show versionsS
          else
          pure ()
          -}
          pure $ foldl' combine initArchive dbData pure $ foldl' combine initArchive dbData
          where where
          -- NOTE (<>) for Archive doesn't concatenate states, so we have to use `combine` -- NOTE (<>) for Archive doesn't concatenate states, so we have to use `combine`
          ...@@ -174,29 +236,18 @@ updateNodeStory nodeId currentArchive newArchive = do ...@@ -174,29 +236,18 @@ updateNodeStory nodeId currentArchive newArchive = do
          --printDebug "[updateNodeStory] delete applied" () --printDebug "[updateNodeStory] delete applied" ()
          updateArchiveStateList nodeId (newArchive ^. a_version) updates updateArchiveStateList nodeId (newArchive ^. a_version) updates
          --printDebug "[updateNodeStory] update applied" () --printDebug "[updateNodeStory] update applied" ()
          pure () pure ()
          -- where
          -- update = Update { uTable = nodeStoryTable
          -- , uUpdateWith = updateEasy (\(NodeStoryDB { node_id }) ->
          -- NodeStoryDB { archive = sqlValueJSONB $ Archive { _a_history = emptyHistory
          -- , ..}
          -- , .. })
          -- , uWhere = (\row -> node_id row .== sqlInt4 nId)
          -- , uReturning = rCount }
          upsertNodeStories :: NodeId -> ArchiveList -> DBUpdate err () upsertNodeStories :: NodeId -> ArchiveList -> DBUpdate err ()
          upsertNodeStories nodeId newArchive = do upsertNodeStories nodeId newArchive = do
          -- printDebug "[upsertNodeStories] START nId" nId -- printDebug "[upsertNodeStories] START nId" nId
          -- printDebug "[upsertNodeStories] locking nId" nId -- printDebug "[upsertNodeStories] locking nId" nId
          (NodeStory m) <- getNodeStory nodeId (NodeStory m) <- getNodeStory nodeId
          case Map.lookup nodeId m of case Map.lookup nodeId m of
          Nothing -> do Nothing ->
          _ <- insertNodeStory nodeId newArchive void $ insertNodeStory nodeId newArchive
          pure () Just currentArchive ->
          Just currentArchive -> do void $ updateNodeStory nodeId currentArchive newArchive
          _ <- updateNodeStory nodeId currentArchive newArchive
          pure ()
          -- 3. Now we need to set versions of all node state to be the same -- 3. Now we need to set versions of all node state to be the same
          updateNodeStoryVersion nodeId newArchive updateNodeStoryVersion nodeId newArchive
          ...@@ -216,8 +267,9 @@ nodeStoryInc ns@(NodeStory nls) nId = do ...@@ -216,8 +267,9 @@ nodeStoryInc ns@(NodeStory nls) nId = do
          -- `nre_parent` and `nre_children`. We want to make sure that all -- `nre_parent` and `nre_children`. We want to make sure that all
          -- children entries (i.e. ones that have `nre_parent`) have the same -- children entries (i.e. ones that have `nre_parent`) have the same
          -- `list` as their parent entry. -- `list` as their parent entry.
          fixChildrenInNgrams :: NgramsState' -> NgramsState' -- NOTE(adn) Currently unused, see !424 for context.
          fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed _fixChildrenInNgrams :: NgramsState' -> NgramsState'
          _fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed
          where where
          (nsParents, nsChildren) = getParentsChildren ns (nsParents, nsChildren) = getParentsChildren ns
          parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_list)) <$> nsParents parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_list)) <$> nsParents
          ...@@ -233,29 +285,56 @@ fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed ...@@ -233,29 +285,56 @@ fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed
          -- | (#281) Sometimes, when we upload a new list, a child can be left -- | (#281) Sometimes, when we upload a new list, a child can be left
          -- without a parent. Find such ngrams and set their 'root' and -- without a parent. Find such ngrams and set their 'root' and
          -- 'parent' to 'Nothing'. -- 'parent' to 'Nothing'.
          fixChildrenWithNoParent :: NgramsState' -> NgramsState' fixChildrenWithNoParent :: Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
          fixChildrenWithNoParent ns = archiveStateFromList $ nsParents <> nsChildrenFixed -> Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
          fixChildrenWithNoParent = Map.map go
          where where
          (nsParents, nsChildren) = getParentsChildren ns -- If the forest is somehow empty, do nothing. Otherwise, build a zipper and run
          parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents -- the algorithm.
          go :: Forest (NgramsTerm, NgramsRepoElement)
          nsChildrenFixFunc (nt, t, nre) = -> Forest (NgramsTerm, NgramsRepoElement)
          ( nt go fs = case zipper fs of
          , t Nothing -> fs
          , nre { _nre_root = root Just zfs -> maybe mempty toList $ execListZipperOp fixDanglingChildrenInForest zfs
          , _nre_parent = parent }
          ) fixDanglingChildrenInForest :: ListZipperOp (Tree (NgramsTerm, NgramsRepoElement)) ()
          where fixDanglingChildrenInForest = do
          (root, parent) = case parentNtMap ^. at (nre ^. nre_parent . _Just) . _Just . at t of z@(ListZipper l a r) <- get
          Just _ -> (nre ^. nre_root, nre ^. nre_parent) when (isOrphan (l <> r) a) $ void $ modifyFocus detachFromParent
          Nothing -> (Nothing, Nothing) unless (atEnd z) $ do
          moveRight
          nsChildrenFixed = nsChildrenFixFunc <$> nsChildren fixDanglingChildrenInForest
          detachFromParent :: Tree (NgramsTerm, NgramsRepoElement) -> Tree (NgramsTerm, NgramsRepoElement)
          detachFromParent (Node (k,v) el) = Node (k, v & nre_root .~ Nothing & nre_parent .~ Nothing) el
          isOrphan :: Forest (NgramsTerm, NgramsRepoElement)
          -- ^ The rest of the forest, i.e. the list of trees
          -- except the input one.
          -> Tree (NgramsTerm, NgramsRepoElement)
          -- ^ The tree we are currently focusing.
          -> Bool
          -- ^ True if the root of the tree refers to
          -- a node that is not listed as any children of
          -- the subtrees, and yet it has a non-null parent
          -- or root.
          isOrphan restOfTheForest (Node (k,v) _) =
          (isJust (_nre_parent v) || isJust (_nre_root v)) &&
          not (isChildInForest (k,v) restOfTheForest)
          -- | Returns 'True' if the input child can be found in the tree.
          isChildInForest :: Eq e => e -> Forest e -> Bool
          isChildInForest _ [] = False
          isChildInForest e (x:xs) =
          case e == rootLabel x of
          True -> True
          False -> isChildInForest e (subForest x) || isChildInForest e xs
          -- | Sometimes children can also become parents (e.g. #313). Find such -- | Sometimes children can also become parents (e.g. #313). Find such
          -- | children and remove them from the list. -- | children and remove them from the list.
          fixChildrenDuplicatedAsParents :: NgramsState' -> NgramsState' -- NOTE(adn) Currently unused, see !424 for context.
          fixChildrenDuplicatedAsParents ns = archiveStateFromList $ nsChildren <> nsParentsFixed _fixChildrenDuplicatedAsParents :: NgramsState' -> NgramsState'
          _fixChildrenDuplicatedAsParents ns = archiveStateFromList $ nsChildren <> nsParentsFixed
          where where
          (nsParents, nsChildren) = getParentsChildren ns (nsParents, nsChildren) = getParentsChildren ns
          parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents
          ...@@ -280,34 +359,18 @@ getParentsChildren ns = (nsParents, nsChildren) ...@@ -280,34 +359,18 @@ getParentsChildren ns = (nsParents, nsChildren)
          mkNodeStoryEnv :: NodeStoryEnv err mkNodeStoryEnv :: NodeStoryEnv err
          mkNodeStoryEnv = do mkNodeStoryEnv = do
          -- tvar <- nodeStoryVar pool Nothing []
          let saver_immediate nId a = do let saver_immediate nId a = do
          -- ns <- atomically $
          -- readTVar tvar
          -- -- fix children so their 'list' is the same as their parents'
          -- >>= pure . fixChildrenTermTypes
          -- -- fix children that don't have a parent anymore
          -- >>= pure . fixChildrenWithNoParent
          -- >>= writeTVar tvar
          -- >> readTVar tvar
          --printDebug "[mkNodeStorySaver] will call writeNodeStories, ns" ns
          -- writeNodeStories c $ fixChildrenWithNoParent $ fixChildrenTermTypes ns
          -- |NOTE Fixing a_state is kinda a hack. We shouldn't land -- |NOTE Fixing a_state is kinda a hack. We shouldn't land
          -- |with bad state in the first place. -- |with bad state in the first place.
          upsertNodeStories nId $ upsertNodeStories nId $
          a & a_state %~ ( a & a_state %~ (
          fixChildrenDuplicatedAsParents destroyArchiveStateForest
          . fixChildrenInNgrams
          . fixChildrenWithNoParent . fixChildrenWithNoParent
          . buildForestsFromArchiveState
          ) )
          let archive_saver_immediate nId a = do let archive_saver_immediate nId a = do
          insertNodeArchiveHistory nId (a ^. a_version) $ reverse $ a ^. a_history insertNodeArchiveHistory nId (a ^. a_version) $ reverse $ a ^. a_history
          pure $ a & a_history .~ [] pure $ a & a_history .~ []
          -- mapM_ (\(nId, a) -> do
          -- insertNodeArchiveHistory c nId (a ^. a_version) $ reverse $ a ^. a_history
          -- ) $ Map.toList nls
          -- pure $ clearHistory ns
          NodeStoryEnv { _nse_saver = saver_immediate NodeStoryEnv { _nse_saver = saver_immediate
          , _nse_archive_saver = archive_saver_immediate , _nse_archive_saver = archive_saver_immediate
          ...@@ -355,72 +418,3 @@ fixNodeStoryVersions = runDBTx $ do ...@@ -355,72 +418,3 @@ fixNodeStoryVersions = runDBTx $ do
          [PGS.Only (Just maxVersion)] -> do [PGS.Only (Just maxVersion)] -> do
          void $ mkPGUpdate updateVerQuery (maxVersion, nId, ngramsType) void $ mkPGUpdate updateVerQuery (maxVersion, nId, ngramsType)
          _ -> panicTrace "Should get only 1 result!" _ -> panicTrace "Should get only 1 result!"
          -----------------------------------------
          -- DEPRECATED
          -- nodeStoryVar :: Pool PGS.Connection
          -- -> Maybe (TVar NodeListStory)
          -- -> [NodeId]
          -- -> IO (TVar NodeListStory)
          -- nodeStoryVar pool Nothing nIds = do
          -- state' <- withResource pool $ \c -> nodeStoryIncrementalRead c Nothing nIds
          -- atomically $ newTVar state'
          -- nodeStoryVar pool (Just tv) nIds = do
          -- nls <- atomically $ readTVar tv
          -- nls' <- withResource pool
          -- $ \c -> nodeStoryIncrementalRead c (Just nls) nIds
          -- _ <- atomically $ writeTVar tv nls'
          -- pure tv
          -- clearHistory :: NodeListStory -> NodeListStory
          -- clearHistory (NodeStory ns) = NodeStory $ ns & (traverse . a_history) .~ emptyHistory
          -- where
          -- emptyHistory = [] :: [NgramsStatePatch']
          -- fixChildrenWithNoParent :: NodeListStory -> NodeListStory
          -- fixChildrenWithNoParent (NodeStory nls) =
          -- NodeStory $ Map.fromList [ (nId, a & a_state %~ fixChildrenWithNoParentStatePatch)
          -- | (nId, a) <- Map.toList nls ]
          -- fixChildrenTermTypes :: NodeListStory -> NodeListStory
          -- fixChildrenTermTypes (NodeStory nls) =
          -- NodeStory $ Map.fromList [ (nId, a & a_state %~ fixChildrenInNgramsStatePatch)
          -- | (nId, a) <- Map.toList nls ]
          -- nodeStoryIncrementalRead :: PGS.Connection -> Maybe NodeListStory -> [NodeId] -> IO NodeListStory
          -- nodeStoryIncrementalRead _ Nothing [] = pure $ NodeStory Map.empty
          -- nodeStoryIncrementalRead c Nothing (ni:ns) = do
          -- m <- getNodeStory c ni
          -- nodeStoryIncrementalRead c (Just m) ns
          -- nodeStoryIncrementalRead c (Just nls) ns = foldM (\m n -> nodeStoryInc c m n) nls ns
          -- nodeStoryDec :: Pool PGS.Connection -> NodeListStory -> NodeId -> IO NodeListStory
          -- nodeStoryDec pool ns@(NodeStory nls) ni = do
          -- case Map.lookup ni nls of
          -- Nothing -> do
          -- _ <- nodeStoryRemove pool ni
          -- pure ns
          -- Just _ -> do
          -- let ns' = Map.filterWithKey (\k _v -> k /= ni) nls
          -- _ <- nodeStoryRemove pool ni
          -- pure $ NodeStory ns'
          ------------------------------------
          -- writeNodeStories :: PGS.Connection -> NodeListStory -> IO ()
          -- writeNodeStories c (NodeStory nls) = do
          -- mapM_ (\(nId, a) -> upsertNodeStories c nId a) $ Map.toList nls
          -- nodeStoryRemove :: Pool PGS.Connection -> NodeId -> IO Int64
          -- nodeStoryRemove pool (NodeId nId) = withResource pool $ \c -> runDelete c delete
          -- where
          -- delete = Delete { dTable = nodeStoryTable
          -- , dWhere = (\row -> node_id row .== sqlInt4 nId)
          -- , dReturning = rCount }
          src/Gargantext/Core/Viz/Chart.hs
          View file @ b6f257b3
          ...@@ -17,7 +17,7 @@ import Data.List qualified as List ...@@ -17,7 +17,7 @@ import Data.List qualified as List
          import Data.Map.Strict (toList) import Data.Map.Strict (toList)
          import Data.Set qualified as Set import Data.Set qualified as Set
          import Data.Vector qualified as V import Data.Vector qualified as V
          import Gargantext.API.Ngrams.NgramsTree ( toTree, NgramsTree ) import Gargantext.API.Ngrams.NgramsTree ( toNgramsForest, NgramsTree, getNgramsForest )
          import Gargantext.API.Ngrams.Tools ( filterListWithRoot, getListNgrams, getRepo, mapTermListRoot ) import Gargantext.API.Ngrams.Tools ( filterListWithRoot, getListNgrams, getRepo, mapTermListRoot )
          import Gargantext.API.Ngrams.Types ( NgramsTerm(NgramsTerm) ) import Gargantext.API.Ngrams.Types ( NgramsTerm(NgramsTerm) )
          import Gargantext.Core.NodeStory.Types ( NodeStoryEnv ) import Gargantext.Core.NodeStory.Types ( NodeStoryEnv )
          ...@@ -91,4 +91,4 @@ treeData env cId nt lt = do ...@@ -91,4 +91,4 @@ treeData env cId nt lt = do
          cs' <- HashMap.map (Set.map contextId2NodeId) <$> getContextsByNgramsOnlyUser cId (ls' <> ls) nt terms cs' <- HashMap.map (Set.map contextId2NodeId) <$> getContextsByNgramsOnlyUser cId (ls' <> ls) nt terms
          m <- getListNgrams env ls nt m <- getListNgrams env ls nt
          pure $ V.fromList $ toTree lt cs' m pure $ V.fromList $ getNgramsForest $ toNgramsForest lt cs' m
          stack.yaml
          View file @ b6f257b3
          ...@@ -18,6 +18,7 @@ ...@@ -18,6 +18,7 @@
          - "data-default-0.8.0.0" - "data-default-0.8.0.0"
          - "data-default-class-0.2.0.0" - "data-default-class-0.2.0.0"
          - "deferred-folds-0.9.18.7" - "deferred-folds-0.9.18.7"
          - "deriving-compat-0.6.7"
          - "entropy-0.4.1.11" - "entropy-0.4.1.11"
          - "file-embed-lzma-0.1" - "file-embed-lzma-0.1"
          - "foldl-1.4.18" - "foldl-1.4.18"
          ...@@ -38,6 +39,7 @@ ...@@ -38,6 +39,7 @@
          - "jose-0.10.0.1" - "jose-0.10.0.1"
          - "language-c-0.10.0" - "language-c-0.10.0"
          - "linear-1.23" - "linear-1.23"
          - "list-zipper-0.0.12"
          - "massiv-1.0.4.1" - "massiv-1.0.4.1"
          - "megaparsec-9.7.0" - "megaparsec-9.7.0"
          - "microlens-th-0.4.3.16" - "microlens-th-0.4.3.16"
          ...@@ -367,7 +369,7 @@ flags: ...@@ -367,7 +369,7 @@ flags:
          gargantext: gargantext:
          "enable-benchmarks": false "enable-benchmarks": false
          "no-phylo-debug-logs": true "no-phylo-debug-logs": true
          "test-crypto": false "test-crypto": true
          graphviz: graphviz:
          "test-parsing": false "test-parsing": false
          hashable: hashable:
          ...@@ -540,8 +542,6 @@ flags: ...@@ -540,8 +542,6 @@ flags:
          transformers: true transformers: true
          tasty: tasty:
          unix: true unix: true
          "tasty-golden":
          "build-example": false
          "text-format": "text-format":
          developer: false developer: false
          "text-metrics": "text-metrics":
          ......
          test/Test/API/UpdateList.hs
          View file @ b6f257b3
          ...@@ -27,23 +27,23 @@ module Test.API.UpdateList ( ...@@ -27,23 +27,23 @@ module Test.API.UpdateList (
          , mkNewWithForm , mkNewWithForm
          ) where ) where
          import Control.Lens (mapped, over)
          import Control.Monad.Fail (fail) import Control.Monad.Fail (fail)
          import Data.Aeson qualified as JSON import Data.Aeson qualified as JSON
          import Data.Aeson.QQ import Data.Aeson.QQ
          import Data.Map.Strict.Patch qualified as PM import Data.ByteString.Lazy qualified as BL
          import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
          import Data.Set qualified as Set import Data.Map.Strict.Patch qualified as PM
          import Data.Text.IO qualified as TIO import Data.Patch.Class
          import Data.Text qualified as T import Data.Text qualified as T
          import Data.Text.IO qualified as TIO
          import Fmt import Fmt
          import Gargantext.API.Admin.Auth.Types (Token) import Gargantext.API.Admin.Auth.Types (Token)
          import Gargantext.API.Errors import Gargantext.API.Errors
          import Gargantext.API.HashedResponse import Gargantext.API.HashedResponse
          import Gargantext.API.Ngrams qualified as APINgrams
          import Gargantext.API.Ngrams.List ( ngramsListFromTSVData ) import Gargantext.API.Ngrams.List ( ngramsListFromTSVData )
          import Gargantext.API.Ngrams.List.Types (WithJsonFile(..), WithTextFile(..)) import Gargantext.API.Ngrams.List.Types (WithJsonFile(..), WithTextFile(..))
          import Gargantext.API.Ngrams qualified as APINgrams import Gargantext.API.Ngrams.Types as NT
          import Gargantext.API.Ngrams.Types
          import Gargantext.API.Node.Corpus.New.Types qualified as FType import Gargantext.API.Node.Corpus.New.Types qualified as FType
          import Gargantext.API.Node.Types import Gargantext.API.Node.Types
          import Gargantext.API.Routes.Named import Gargantext.API.Routes.Named
          ...@@ -51,8 +51,8 @@ import Gargantext.API.Routes.Named.Corpus (addWithTempFileEp) ...@@ -51,8 +51,8 @@ import Gargantext.API.Routes.Named.Corpus (addWithTempFileEp)
          import Gargantext.API.Routes.Named.Node import Gargantext.API.Routes.Named.Node
          import Gargantext.API.Routes.Named.Private import Gargantext.API.Routes.Named.Private
          import Gargantext.API.Worker (workerAPIPost) import Gargantext.API.Worker (workerAPIPost)
          import Gargantext.Core.Config
          import Gargantext.Core qualified as Lang import Gargantext.Core qualified as Lang
          import Gargantext.Core.Config
          import Gargantext.Core.Text.Corpus.Query (RawQuery(..)) import Gargantext.Core.Text.Corpus.Query (RawQuery(..))
          import Gargantext.Core.Text.List.Social import Gargantext.Core.Text.List.Social
          import Gargantext.Core.Text.Ngrams import Gargantext.Core.Text.Ngrams
          ...@@ -64,7 +64,7 @@ import Gargantext.Database.Query.Facet qualified as Facet ...@@ -64,7 +64,7 @@ import Gargantext.Database.Query.Facet qualified as Facet
          import Gargantext.Prelude hiding (get) import Gargantext.Prelude hiding (get)
          import Network.Wai.Handler.Warp qualified as Wai import Network.Wai.Handler.Warp qualified as Wai
          import Paths_gargantext (getDataFileName) import Paths_gargantext (getDataFileName)
          import qualified Prelude import Prelude qualified
          import Servant.Client.Streaming import Servant.Client.Streaming
          import System.FilePath import System.FilePath
          import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser, alice) import Test.API.Prelude (checkEither, newCorpusForUser, newPrivateFolderForUser, alice)
          ...@@ -108,6 +108,17 @@ uploadJSONList log_cfg port token cId pathToNgrams clientEnv = do ...@@ -108,6 +108,17 @@ uploadJSONList log_cfg port token cId pathToNgrams clientEnv = do
          pure listId pure listId
          -- | Compares the ngrams returned via the input IO action with the ones provided as
          -- the 'ByteString'. Use this function with the 'json' quasi quoter to pass directly
          -- a nicely-formatted JSON.
          checkNgrams :: IO (Either ClientError (VersionedWithCount NgramsTable))
          -> BL.ByteString
          -> WaiSession () ()
          checkNgrams rq expected = liftIO $ do
          eng <- rq
          case eng of
          Left err -> fail (show err)
          Right r -> Just r `shouldBe` JSON.decode expected
          tests :: Spec tests :: Spec
          ...@@ -141,53 +152,180 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do ...@@ -141,53 +152,180 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
          ] ]
          } |] } |]
          it "does allow creating hierarchical grouping at least for level-2" $ \(SpecContext testEnv port app _) -> do
          cId <- newCorpusForUser testEnv "alice"
          withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
          ([listId] :: [NodeId]) <- protectedJSON token "POST" (mkUrl port ("/node/" <> build cId)) [aesonQQ|{"pn_typename":"NodeList","pn_name":"Testing"}|]
          let newMapTerm = NgramsRepoElement {
          _nre_size = 1
          , _nre_list = MapTerm
          , _nre_root = Nothing
          , _nre_parent = Nothing
          , _nre_children = mempty
          }
          let add_guitar_pedals =
          PM.fromList [
          ( "guitar pedals"
          , NgramsReplace { _patch_old = Nothing
          , _patch_new = Just newMapTerm })
          ]
          _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst add_guitar_pedals)) clientEnv
          let add_tube_screamers =
          PM.fromList [
          ( "tube screamers"
          , NgramsReplace { _patch_old = Nothing
          , _patch_new = Just newMapTerm })
          ]
          _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst add_tube_screamers)) clientEnv
          let group_nodes =
          PM.fromList [
          ( "guitar pedals"
          , NgramsPatch { _patch_children = NT.PatchMSet (fst $ PM.fromList [("tube screamers", addPatch)])
          , _patch_list = Keep })
          ]
          _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst group_nodes)) clientEnv
          -- Creates the grouping:
          {- overdrives
          |
          \ guitar pedals
          |
          \ tube screamers
          -}
          let add_overdrives =
          PM.fromList [
          ( "overdrives"
          , NgramsReplace { _patch_old = Nothing
          , _patch_new = Just newMapTerm })
          ]
          _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst add_overdrives)) clientEnv
          let group_nodes_2 =
          PM.fromList [
          ( "overdrives"
          , NgramsPatch { _patch_children = NT.PatchMSet (fst $ PM.fromList [("guitar pedals", addPatch)])
          , _patch_list = Keep })
          ]
          _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst group_nodes_2)) clientEnv
          liftIO $ do
          eRes <- runClientM (get_table_ngrams token cId APINgrams.Terms listId 50 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
          eRes `shouldSatisfy` isRight
          let (Right res) = eRes
          Just res `shouldBe` JSON.decode [json| {"version":5
          ,"count":3
          ,"data":[
          {"ngrams":"guitar pedals"
          ,"size":1
          ,"list":"MapTerm"
          ,"root":"overdrives"
          ,"parent":"overdrives"
          ,"occurrences":[]
          ,"children":["tube screamers"]
          },
          {"ngrams":"overdrives"
          ,"size":1
          ,"list":"MapTerm"
          ,"occurrences":[]
          ,"children":["guitar pedals"]
          },
          {"ngrams":"tube screamers"
          ,"size":1
          ,"list":"MapTerm"
          ,"root":"overdrives"
          ,"parent":"guitar pedals"
          ,"occurrences":[]
          ,"children":[]}
          ]
          } |]
          it "does not create duplicates when uploading JSON (#313)" $ \(SpecContext testEnv port app _) -> do it "does not create duplicates when uploading JSON (#313)" $ \(SpecContext testEnv port app _) -> do
          cId <- newCorpusForUser testEnv "alice" cId <- newCorpusForUser testEnv "alice"
          let log_cfg = (test_config testEnv) ^. gc_logging let log_cfg = (test_config testEnv) ^. gc_logging
          withApplication app $ do withApplication app $ do
          withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do withValidLogin port "alice" (GargPassword "alice") $ \clientEnv token -> do
          -- this term is imported from the .json file -- The test data has a single term called "abelian group". In this test
          let importedTerm = NgramsTerm "abelian group" -- we will try grouping together "abelian group" and "new abelian group".
          -- this is the new term, under which importedTerm will be grouped
          let newTerm = NgramsTerm "new abelian group"
          listId <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv listId <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
          let checkNgrams expected = do
          eng <- liftIO $ runClientM (get_table_ngrams token cId APINgrams.Terms listId 10 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
          case eng of
          Left err -> fail (show err)
          Right r ->
          let real = over mapped (\nt -> ( nt ^. ne_ngrams
          , mSetToList $ nt ^. ne_children ))
          (r ^. vc_data . _NgramsTable) in
          liftIO $ Set.fromList real `shouldBe` Set.fromList expected
          -- The #313 error is about importedTerm being duplicated -- The #313 error is about importedTerm being duplicated
          -- in a specific case -- in a specific case
          let getNgrams = runClientM (get_table_ngrams token cId APINgrams.Terms listId 10 Nothing (Just MapTerm) Nothing Nothing Nothing Nothing) clientEnv
          checkNgrams [ (importedTerm, []) ]
          checkNgrams getNgrams [json| {"version":0
          ,"count":1
          ,"data":[
          {"ngrams":"abelian group"
          ,"size":2
          ,"list":"MapTerm"
          ,"root":null
          ,"parent":null
          ,"occurrences":[]
          ,"children":[]
          }
          ]
          }
          |]
          let nre = NgramsRepoElement 1 MapTerm Nothing Nothing (MSet mempty) let nre = NgramsRepoElement 1 MapTerm Nothing Nothing (MSet mempty)
          let patch = PM.fromList [ let patch = PM.fromList [
          ( newTerm ( "new abelian group"
          , NgramsReplace { _patch_old = Nothing , NgramsReplace { _patch_old = Nothing
          , _patch_new = Just nre } ) , _patch_new = Just nre } )
          ] ]
          _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst patch)) clientEnv _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 1 $ NgramsTablePatch $ fst patch)) clientEnv
          -- check that new term is added (with no parent) -- check that new term is added (with no parent)
          checkNgrams [ (newTerm, []) checkNgrams getNgrams [json| { "version": 1
          , (importedTerm, []) ] ,"count":2
          ,"data":[
          {"ngrams":"abelian group"
          ,"size":2
          ,"list":"MapTerm"
          ,"root":null
          ,"parent":null
          ,"occurrences":[]
          ,"children":[]
          },
          {"ngrams":"new abelian group"
          ,"size":1
          ,"list":"MapTerm"
          ,"root":null
          ,"parent":null
          ,"occurrences":[]
          ,"children":[]
          }
          ]
          }
          |]
          -- now patch it so that we have a group -- now patch it so that we have a group
          let patchChildren = PM.fromList [ let patchChildren = PM.fromList [
          ( newTerm ( "new abelian group"
          , toNgramsPatch [importedTerm] ) , toNgramsPatch ["abelian group"] )
          ] ]
          _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 32 $ NgramsTablePatch $ fst patchChildren)) clientEnv _ <- liftIO $ runClientM (put_table_ngrams token cId APINgrams.Terms listId (Versioned 32 $ NgramsTablePatch $ fst patchChildren)) clientEnv
          -- check that new term is parent of old one -- check that new term is parent of old one
          checkNgrams [ (newTerm, [importedTerm]) ] checkNgrams getNgrams [json| {"version": 2
          ,"count":2
          ,"data":[
          {"ngrams":"abelian group"
          ,"size":2
          ,"list":"MapTerm"
          ,"root": "new abelian group"
          ,"parent": "new abelian group"
          ,"occurrences":[]
          ,"children":[]
          },
          {"ngrams":"new abelian group"
          ,"size":1
          ,"list":"MapTerm"
          ,"root":null
          ,"parent":null
          ,"occurrences":[]
          ,"children":["abelian group"]
          }
          ]
          }
          |]
          -- finally, upload the list again, the group should be as -- finally, upload the list again, the group should be as
          -- it was before (the bug in #313 was that "abelian group" -- it was before (the bug in #313 was that "abelian group"
          ...@@ -195,14 +333,31 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do ...@@ -195,14 +333,31 @@ tests = sequential $ aroundAll withTestDBAndPort $ beforeAllWith dbEnvSetup $ do
          _ <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv _ <- uploadJSONList log_cfg port token cId "test-data/ngrams/simple.json" clientEnv
          -- old (imported) term shouldn't become parentless -- old (imported) term shouldn't become parentless
          -- (#313 error was that we had [newTerm, importedTerm] instead) -- (#313 error was that we had ["new abelian group", "abelian group"] instead)
          -- In essence, this JSON needs to be exactly the same as the previous one,
          -- NOTE: Unfortunately, I'm not able to reproduce this -- i.e. important doesn't change the topology.
          -- error here, though I tried. Something is missing, maybe checkNgrams getNgrams [json| {"version": 2
          -- some nodestory integration with tests? ,"count":2
          checkNgrams [ (newTerm, [importedTerm]) ] ,"data":[
          {"ngrams":"abelian group"
          pure () ,"size":2
          ,"list":"MapTerm"
          ,"root": "new abelian group"
          ,"parent": "new abelian group"
          ,"occurrences":[]
          ,"children":[]
          },
          {"ngrams":"new abelian group"
          ,"size":1
          ,"list":"MapTerm"
          ,"root":null
          ,"parent":null
          ,"occurrences":[]
          ,"children":["abelian group"]
          }
          ]
          }
          |]
          describe "POST /api/v1.0/lists/:id/csv/add/form/async (CSV)" $ do describe "POST /api/v1.0/lists/:id/csv/add/form/async (CSV)" $ do
          ......
          test/Test/Instances.hs
          View file @ b6f257b3
          ...@@ -12,6 +12,7 @@ Portability : POSIX ...@@ -12,6 +12,7 @@ Portability : POSIX
          {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-} {-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}
          {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
          {-# LANGUAGE ScopedTypeVariables #-}
          module Test.Instances module Test.Instances
          where where
          ...@@ -382,15 +383,133 @@ instance Arbitrary DET.WSRequest where ...@@ -382,15 +383,133 @@ instance Arbitrary DET.WSRequest where
          , pure DET.WSDeauthorize ] , pure DET.WSDeauthorize ]
          arbitraryNgramsTerm :: Gen Ngrams.NgramsTerm
          arbitraryNgramsTerm = elements
          [ "time"
          , "year"
          , "people"
          , "way"
          , "day"
          , "man"
          , "thing"
          , "woman"
          , "life"
          , "child"
          , "world"
          , "school"
          , "state"
          , "family"
          , "student"
          , "group"
          , "country"
          , "problem"
          , "hand"
          , "part"
          , "place"
          , "case"
          , "week"
          , "company"
          , "system"
          , "program"
          , "question"
          , "work"
          , "government"
          , "number"
          , "night"
          , "point"
          , "home"
          , "water"
          , "room"
          , "mother"
          , "area"
          , "money"
          , "story"
          , "fact"
          , "month"
          , "lot"
          , "right"
          , "study"
          , "book"
          , "eye"
          , "job"
          , "word"
          , "business"
          , "issue"
          , "side"
          , "kind"
          , "head"
          , "house"
          , "service"
          , "friend"
          , "father"
          , "power"
          , "hour"
          , "game"
          , "line"
          , "end"
          , "member"
          , "law"
          , "car"
          , "city"
          , "community"
          , "name"
          , "president"
          , "team"
          , "minute"
          , "idea"
          , "kid"
          , "body"
          , "information"
          , "back"
          , "parent"
          , "face"
          , "others"
          , "level"
          , "office"
          , "door"
          , "health"
          , "person"
          , "art"
          , "war"
          , "history"
          , "party"
          , "result"
          , "change"
          , "morning"
          , "reason"
          , "research"
          , "girl"
          , "guy"
          , "moment"
          , "air"
          , "teacher"
          , "force"
          , "education"
          ]
          -- Ngrams -- Ngrams
          instance Arbitrary a => Arbitrary (Ngrams.MSet a) instance Arbitrary a => Arbitrary (Ngrams.MSet a)
          -- We cannot pick some completely arbitrary values for the ngrams terms,
          -- see the rationale in the instance for 'NgramsElement'.
          instance Arbitrary Ngrams.NgramsTerm where instance Arbitrary Ngrams.NgramsTerm where
          arbitrary = Ngrams.NgramsTerm <$> arbitrary = arbitraryNgramsTerm
          -- we take into accoutn the fact, that tojsonkey strips the text
          (arbitrary `suchThat` (\t -> t == T.strip t))
          instance Arbitrary Ngrams.TabType where arbitrary = arbitraryBoundedEnum instance Arbitrary Ngrams.TabType where arbitrary = arbitraryBoundedEnum
          instance Arbitrary Ngrams.NgramsElement where instance Arbitrary Ngrams.NgramsElement where
          arbitrary = elements [Ngrams.newNgramsElement Nothing "sport"] -- We cannot pick some completely arbitrary values for the ngrams elements
          -- because we still want to simulate potential hierarchies, i.e. forests of ngrams.
          -- so we sample the ngrams terms from a selection, and we restrict the number of max
          -- children for each 'NgramsElement' to the size parameter to not have very large trees.
          arbitrary = do
          _ne_ngrams <- arbitrary
          _ne_size <- arbitrary
          _ne_list <- arbitrary
          _ne_occurrences <- arbitrary
          _ne_root <- arbitrary `suchThat` (maybe True (\x -> x /= _ne_ngrams)) -- can't be root of itself
          _ne_parent <- arbitrary `suchThat` (maybe True (\x -> x /= _ne_ngrams)) -- can't be parent of itself
          _ne_children <- Ngrams.mSetFromList <$> (sized (\n -> vectorOf n arbitrary `suchThat` (\x -> _ne_ngrams `notElem` x))) -- can't be cyclic
          pure Ngrams.NgramsElement{..}
          instance Arbitrary Ngrams.NgramsTable where instance Arbitrary Ngrams.NgramsTable where
          arbitrary = pure ngramsMockTable arbitrary = pure ngramsMockTable
          instance Arbitrary Ngrams.OrderBy where arbitrary = arbitraryBoundedEnum instance Arbitrary Ngrams.OrderBy where arbitrary = arbitraryBoundedEnum
          ......
          test/Test/Ngrams/Query.hs
          View file @ b6f257b3
          {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
          module Test.Ngrams.Query (tests) where module Test.Ngrams.Query (tests, mkMapTerm) where
          import Control.Monad import Control.Monad
          import Data.Coerce import Data.Coerce
          ......
          test/Test/Offline/Ngrams.hs
          View file @ b6f257b3
          {-# LANGUAGE QuasiQuotes #-}
          {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
          {-# LANGUAGE ViewPatterns #-}
          module Test.Offline.Ngrams (tests) where module Test.Offline.Ngrams (tests) where
          import Prelude import Prelude
          import Control.Lens
          import Data.Map.Strict qualified as Map
          import Data.Text qualified as T import Data.Text qualified as T
          import Gargantext.API.Ngrams (filterNgramsNodes, buildForest, destroyForest, pruneForest)
          import Gargantext.API.Ngrams.Types
          import Gargantext.API.Ngrams.Types qualified as NT import Gargantext.API.Ngrams.Types qualified as NT
          import Gargantext.Core import Gargantext.Core
          import Gargantext.Core.Text.Terms.Mono (isSep)
          import Gargantext.Core.Text.Terms.WithList import Gargantext.Core.Text.Terms.WithList
          import Gargantext.Core.Types import Gargantext.Core.Types
          import Gargantext.Database.Action.Flow.Utils (docNgrams) import Gargantext.Database.Action.Flow.Utils (docNgrams)
          import Gargantext.Database.Schema.Context
          import Gargantext.Database.Admin.Types.Hyperdata import Gargantext.Database.Admin.Types.Hyperdata
          import Gargantext.Database.Schema.Context
          import Test.HUnit
          import Test.Hspec
          import Test.Instances () import Test.Instances ()
          import Test.Ngrams.Query (mkMapTerm)
          import Test.QuickCheck import Test.QuickCheck
          import Test.Hspec import Test.QuickCheck qualified as QC
          import Control.Lens import Data.Tree
          import qualified Test.QuickCheck as QC import Text.RawString.QQ (r)
          import Gargantext.Core.Text.Terms.Mono (isSep) import Data.Char (isSpace)
          import Data.Map.Strict (Map)
          import Test.Hspec.QuickCheck (prop)
          genScientificText :: Gen T.Text genScientificText :: Gen T.Text
          ...@@ -89,6 +101,31 @@ tests = describe "Ngrams" $ do ...@@ -89,6 +101,31 @@ tests = describe "Ngrams" $ do
          it "return results for non-empty input terms" $ property testBuildPatternsNonEmpty it "return results for non-empty input terms" $ property testBuildPatternsNonEmpty
          describe "docNgrams" $ do describe "docNgrams" $ do
          it "always matches if the input text contains any of the terms" $ property testDocNgramsOKMatch it "always matches if the input text contains any of the terms" $ property testDocNgramsOKMatch
          describe "ngram forests" $ do
          it "building a simple tree works" testBuildNgramsTree_01
          it "building a complex tree works" testBuildNgramsTree_02
          it "building a complex deep tree works" testBuildNgramsTree_03
          it "pruning a simple tree works" testPruningNgramsForest_01
          it "pruning a complex tree works" testPruningNgramsForest_02
          prop "destroyForest . buildForest === id" buildDestroyForestRoundtrips
          describe "hierarchical grouping" $ do
          it "filterNgramsNodes with empty query is identity" testFilterNgramsNodesEmptyQuery
          hierarchicalTableMap :: Map NgramsTerm NgramsElement
          hierarchicalTableMap = Map.fromList [
          ("vehicle", mkMapTerm "vehicle" & ne_children .~ mSetFromList ["car"])
          , ("car", mkMapTerm "car" & ne_root .~ Just "vehicle"
          & ne_parent .~ Just "vehicle"
          & ne_children .~ mSetFromList ["ford"])
          , ("ford", mkMapTerm "ford" & ne_root .~ Just "vehicle"
          & ne_parent .~ Just "car")
          ]
          testFilterNgramsNodesEmptyQuery :: Assertion
          testFilterNgramsNodesEmptyQuery = do
          let input = hierarchicalTableMap
          let actual = filterNgramsNodes (Just MapTerm) Nothing Nothing (const True) input
          actual @?= input
          testDocNgramsOKMatch :: Lang -> DocumentWithMatches -> Property testDocNgramsOKMatch :: Lang -> DocumentWithMatches -> Property
          testDocNgramsOKMatch lang (DocumentWithMatches ts doc) = testDocNgramsOKMatch lang (DocumentWithMatches ts doc) =
          ...@@ -103,3 +140,166 @@ testBuildPatternsNonEmpty :: Lang -> NonEmptyList NgramsTermNonEmpty -> Property ...@@ -103,3 +140,166 @@ testBuildPatternsNonEmpty :: Lang -> NonEmptyList NgramsTermNonEmpty -> Property
          testBuildPatternsNonEmpty lang ts = testBuildPatternsNonEmpty lang ts =
          let ts' = map (NT.NgramsTerm . unNgramsTermNonEmpty) $ getNonEmpty ts let ts' = map (NT.NgramsTerm . unNgramsTermNonEmpty) $ getNonEmpty ts
          in counterexample "buildPatterns returned no results" $ length (buildPatternsWith lang ts') > 0 in counterexample "buildPatterns returned no results" $ length (buildPatternsWith lang ts') > 0
          newtype ASCIIForest = ASCIIForest String
          deriving Eq
          instance Show ASCIIForest where
          show (ASCIIForest x) = x
          compareForestVisually :: Forest NgramsElement -> String -> Property
          compareForestVisually f expected =
          let actual = init $ drawForest (map (fmap renderEl) f)
          outermostIndentation = T.length . T.takeWhile isSpace . T.dropWhile (=='\n') . T.pack $ expected
          in ASCIIForest actual === ASCIIForest (sanitiseDrawing outermostIndentation expected)
          where
          renderEl :: NgramsElement -> String
          renderEl = T.unpack . unNgramsTerm . _ne_ngrams
          toTextPaths :: String -> [T.Text]
          toTextPaths = T.splitOn "\n" . T.strip . T.pack
          sanitiseDrawing :: Int -> String -> String
          sanitiseDrawing outermostIndentation =
          let dropLayout t = case T.uncons t of
          Just (' ', _) -> T.drop outermostIndentation t
          _ -> t -- leave it be
          in T.unpack . T.unlines . map dropLayout . toTextPaths
          testBuildNgramsTree_01 :: Property
          testBuildNgramsTree_01 =
          let t1 = Map.fromList [ ( "foo", mkMapTerm "foo" & ne_children .~ mSetFromList ["bar"])
          , ( "bar", mkMapTerm "bar" & ne_parent .~ Just "foo")
          ]
          in (buildForest t1) `compareForestVisually` [r|
          bar
          foo
          |
          `- bar
          |]
          testBuildNgramsTree_02 :: Property
          testBuildNgramsTree_02 =
          buildForest hierarchicalTableMap `compareForestVisually` [r|
          car
          |
          `- ford
          ford
          vehicle
          |
          `- car
          |
          `- ford
          |]
          testBuildNgramsTree_03 :: Property
          testBuildNgramsTree_03 =
          let input = Map.fromList [
          ("animalia", mkMapTerm "animalia" & ne_children .~ mSetFromList ["chordata"])
          , ("chordata", mkMapTerm "chordata" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "animalia"
          & ne_children .~ mSetFromList ["mammalia"])
          , ("mammalia", mkMapTerm "mammalia" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "chordata"
          & ne_children .~ mSetFromList ["carnivora", "primates"]
          )
          , ("carnivora", mkMapTerm "carnivora" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "mammalia"
          & ne_children .~ mSetFromList ["felidae"]
          )
          , ("felidae", mkMapTerm "felidae" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "carnivora"
          & ne_children .~ mSetFromList ["panthera"]
          )
          , ("panthera", mkMapTerm "panthera" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "felidae"
          & ne_children .~ mSetFromList ["panthera leo", "panthera tigris"]
          )
          , ("panthera leo", mkMapTerm "panthera leo" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "pathera"
          )
          , ("panthera tigris", mkMapTerm "panthera tigris" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "panthera"
          )
          , ("panthera tigris", mkMapTerm "panthera tigris" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "panthera"
          )
          , ("primates", mkMapTerm "primates" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "mammalia"
          & ne_children .~ mSetFromList ["hominidae"]
          )
          , ("hominidae", mkMapTerm "hominidae" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "primates"
          & ne_children .~ mSetFromList ["homo"]
          )
          , ("homo", mkMapTerm "homo" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "hominidae"
          & ne_children .~ mSetFromList ["homo sapiens"]
          )
          , ("homo sapies", mkMapTerm "homo sapiens" & ne_root .~ Just "animalia"
          & ne_parent .~ Just "homo"
          )
          ]
          in pruneForest (buildForest input) `compareForestVisually` [r|
          animalia
          |
          `- chordata
          |
          `- mammalia
          |
          +- carnivora
          | |
          | `- felidae
          | |
          | `- panthera
          | |
          | +- panthera leo
          | |
          | `- panthera tigris
          |
          `- primates
          |
          `- hominidae
          |
          `- homo
          |]
          newtype TableMapLockStep = TableMapLockStep { getTableMap :: Map NgramsTerm NgramsElement }
          deriving (Show, Eq)
          instance Arbitrary TableMapLockStep where
          arbitrary = do
          pairs <- map (\(k,v) -> (k, v & ne_ngrams .~ k)) <$> arbitrary
          pure $ TableMapLockStep (Map.fromList pairs)
          -- /PRECONDITION/: The '_ne_ngrams' field always matches the 'NgramsTerm', key of the map.
          buildDestroyForestRoundtrips :: TableMapLockStep -> Property
          buildDestroyForestRoundtrips (TableMapLockStep mp) =
          (destroyForest . buildForest $ mp) === mp
          testPruningNgramsForest_01 :: Property
          testPruningNgramsForest_01 =
          let t1 = Map.fromList [ ( "foo", mkMapTerm "foo" & ne_children .~ mSetFromList ["bar"])
          , ( "bar", mkMapTerm "bar" & ne_parent .~ Just "foo")
          ]
          in (pruneForest $ buildForest t1) `compareForestVisually` [r|
          foo
          |
          `- bar
          |]
          testPruningNgramsForest_02 :: Property
          testPruningNgramsForest_02 =
          (pruneForest $ buildForest hierarchicalTableMap) `compareForestVisually` [r|
          vehicle
          |
          `- car
          |
          `- ford
          |]
          Markdown is supported
          0% or
          You are about to add 0 people to the discussion. Proceed with caution.
          Finish editing this message first!
          Please register or to comment