Reuse AcyclicTableMap generator

src/Gargantext/API/Ngrams.hs

@@ -15,9 +15,6 @@ add get
 
 -}
 
-{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
-{-# OPTIONS_GHC -fno-warn-deprecations #-}
-
 {-# LANGUAGE BangPatterns        #-}
 {-# LANGUAGE ConstraintKinds     #-}
 {-# LANGUAGE IncoherentInstances #-}
@@ -176,10 +173,6 @@ saveNodeStory env nId a = do
   let saver = view hasNodeStoryImmediateSaver env
   saver nId a
 
-listTypeConflictResolution :: ListType -> ListType -> ListType
-listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
-
-
 ngramsStatePatchConflictResolution :: NgramsType
                                    -> NgramsTerm
                                    -> ConflictResolutionNgramsPatch
@@ -193,14 +186,6 @@ ngramsStatePatchConflictResolution _ngramsType _ngramsTerm
 
 
 
--- Current state:
---   Insertions are not considered as patches,
---   they do not extend history,
---   they do not bump version.
-insertNewOnly :: a -> Maybe b -> a
-insertNewOnly m = maybe m (const $ errorTrace "insertNewOnly: impossible")
-  -- TODO error handling
-
 {- unused
 -- TODO refactor with putListNgrams
 copyListNgrams :: RepoCmdM env err m
@@ -671,11 +656,6 @@ setNgramsTableScores nId listId ngramsType table = do
 
 -- TODO: find a better place for the code above, All APIs stay here
 
-needsScores :: Maybe OrderBy -> Bool
-needsScores (Just ScoreAsc)  = True
-needsScores (Just ScoreDesc) = True
-needsScores _ = False
-
 getTableNgramsCorpusHandler :: (IsDBCmd err env m, HasNodeStoryEnv err env)
                             => NodeId
                             -> TabType

test/Test/Instances.hs

@@ -14,18 +14,22 @@ Portability : POSIX
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Test.Instances
-where
+module Test.Instances where
 
+import Control.Lens hiding (elements)
 import Data.List.NonEmpty qualified as NE
+import Data.Map.Strict qualified as Map
 import Data.Map.Strict.Patch qualified as PM
 import Data.Patch.Class (Replace, replace)
+import Data.Set qualified as Set
 import Data.Text qualified as T
 import Data.Validity (Validation(..), ValidationChain (..), prettyValidation)
 import EPO.API.Client.Types qualified as EPO
 import Gargantext.API.Admin.Auth.Types (AuthenticatedUser, ForgotPasswordAsyncParams)
 import Gargantext.API.Admin.Orchestrator.Types qualified as Orch
 import Gargantext.API.Errors.Types qualified as Errors
+import Gargantext.API.Ngrams
+import Gargantext.API.Ngrams.Types
 import Gargantext.API.Ngrams.Types qualified as Ngrams
 import Gargantext.API.Node.Contact.Types (AddContactParams)
 import Gargantext.API.Node.Corpus.Annuaire (AnnuaireWithForm)
@@ -33,14 +37,14 @@ import Gargantext.API.Node.Corpus.New (ApiInfo)
 import Gargantext.API.Node.Corpus.New.Types (FileFormat, FileType)
 import Gargantext.API.Node.Corpus.Types (Datafield)
 import Gargantext.API.Node.Corpus.Types qualified as CT
-import Gargantext.API.Node.DocumentsFromWriteNodes.Types qualified as DFWN
 import Gargantext.API.Node.DocumentUpload.Types (DocumentUpload)
+import Gargantext.API.Node.DocumentsFromWriteNodes.Types qualified as DFWN
 import Gargantext.API.Node.FrameCalcUpload.Types qualified as FCU
 import Gargantext.API.Node.Get (GetNodeParams)
 import Gargantext.API.Node.New.Types (PostNode(..))
 import Gargantext.API.Node.Share.Types (ShareNodeParams(..))
-import Gargantext.API.Node.Update.Types qualified as NU
 import Gargantext.API.Node.Types (NewWithForm, NewWithTempFile(..), RenameNode(..), WithQuery)
+import Gargantext.API.Node.Update.Types qualified as NU
 import Gargantext.API.Public.Types (PublicData(..))
 import Gargantext.API.Routes.Named.Publish (PublishRequest(..))
 import Gargantext.API.Routes.Named.Remote (RemoteExportRequest(..))
@@ -61,12 +65,12 @@ import Gargantext.Database.Admin.Types.Node (NodeId(..), UserId(..), NodeType(..
 import Gargantext.Database.Query.Facet (OrderBy(..))
 import Gargantext.Prelude hiding (replace, Location)
 import Servant.Client.Core.BaseUrl (BaseUrl(..), Scheme(Http))
-import Text.Parsec.Error (ParseError, Message(..), newErrorMessage)
-import Text.Parsec.Pos
 import Test.QuickCheck
 import Test.QuickCheck.Arbitrary.Generic
 import Test.QuickCheck.Instances.Text ()
 import Test.QuickCheck.Instances.Vector ()
+import Text.Parsec.Error (ParseError, Message(..), newErrorMessage)
+import Text.Parsec.Pos
 
 
 instance Arbitrary AuthenticatedUser where arbitrary = genericArbitrary
@@ -738,3 +742,53 @@ instance Arbitrary Job where
       recomputeGraphGen = RecomputeGraph <$> arbitrary
       updateNodeGen = UpdateNode <$> arbitrary <*> arbitrary
       uploadDocumentGen = UploadDocument <$> arbitrary <*> arbitrary
+
+-- | An 'AcyclicTableMap' models a map that associates an 'NgramsTerm' with its 'NgramsElement'.
+-- In particular, there are a few preconditions that govers its QuickCheck generator:
+--
+-- 1. The key matches the '_ne_ngrams' field of each 'NgramsElement';
+-- 2. Acyclic: loops are removed.
+-- The 'AcyclicTableMap' also carries a random element of the map, which can be
+-- used in other tests requiring more specific orchestrations (for example query tests, where
+-- we need to be searching for an element in the collection).
+data AcyclicTableMap =
+  AcyclicTableMap
+    { getTableMap      :: Map NgramsTerm NgramsElement
+    , randomMapElement :: NgramsElement
+    }
+  deriving (Show, Eq)
+
+-- | Generate a hierarchy of ngrams element /WITH NO LOOPS/.
+-- Furthermore, we need to ensure that when we generate elements, we are not
+-- accidentally creating duplicates, because ggtx won't allow us (in the frontend, at least)
+-- to create (say) a MapTerm called \"foo\" if we have already a candidate term with that name.
+genCorpusWithMatchingElement :: Gen AcyclicTableMap
+genCorpusWithMatchingElement = do
+  -- cap the depth of the tree, to not make the tests too slow
+  depth <- choose (1, 5)
+  let mkEntry = do
+        trm <- arbitrary
+        el  <- over ne_children (breakLoop trm) <$> (resize depth arbitrary)
+        pure (trm, el { _ne_ngrams = trm })
+  -- Let's build the map first, so that duplicates will be overwritten.
+  fullMap <- (Map.fromList <$> vectorOf depth mkEntry) `suchThat` (\x -> isRight (buildForest x)) -- exclude loops
+  let (hd NE.:| _) = NE.fromList $ Map.elems fullMap
+  pure $ AcyclicTableMap fullMap hd
+  where
+    breakLoop :: NgramsTerm -> MSet NgramsTerm -> MSet NgramsTerm
+    breakLoop t = mSetFromSet . Set.delete t . mSetToSet
+
+instance Arbitrary AcyclicTableMap where
+  arbitrary = genCorpusWithMatchingElement
+  shrink    = shrinkTree
+
+shrinkTree :: AcyclicTableMap -> [AcyclicTableMap]
+shrinkTree (AcyclicTableMap mp el) =
+  [ AcyclicTableMap (Map.insert k shrunk mp) (if k == _ne_ngrams el then shrunk else el)
+  | (k, ne) <- Map.toList mp
+  , shrunkChildren <- shrinkSet (_ne_children ne)
+  , let shrunk = ne { _ne_children = shrunkChildren }
+  ]
+
+shrinkSet :: Ord a => MSet a -> [MSet a]
+shrinkSet s = map mSetFromList (shrinkList (const []) (mSetToList s))

test/Test/Ngrams/Query.hs

 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-deprecations #-}
-module Test.Ngrams.Query (tests, mkMapTerm) where
+module Test.Ngrams.Query (
+    tests
+  , mkMapTerm
+  , hierarchicalTableMap
+  ) where
 
 import Control.Lens
 import Control.Monad
@@ -8,7 +12,6 @@ import Data.Coerce
 import Data.Map.Strict qualified as Map
 import Data.Monoid
 import Data.Patch.Class qualified as Patch
-import Data.Set qualified as Set
 import Data.String
 import Data.Text qualified as T
 import Data.Validity qualified as Validity
@@ -24,7 +27,17 @@ import Test.Ngrams.Query.PaginationCorpus
 import Test.QuickCheck
 import Test.Utils ((@??=))
 import Text.Collate qualified as Unicode
-import qualified Data.List.NonEmpty as NE
+import Test.Instances
+
+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")
+  ]
 
 
 tests :: Spec
@@ -63,6 +76,7 @@ unitTests = describe "Query tests" $ do
   --  -- Full text search
   it "Simple query (search with match)" testFlat05
   prop "Searching something that is there should always succeed" testForestSearchProp
+  it "Searching for nested terms should succeed" testSearchNestedTerms
   --  -- Pagination
   it "Simple pagination on all terms" test_pagination_allTerms
   it "Simple pagination on MapTerm" test_pagination01
@@ -215,31 +229,11 @@ testFlat05 = do
                , _nsq_searchQuery = mockQueryFn (Just "curry")
                }
 
--- | Generate a hierarchy of ngrams element /WITH NO LOOPS/.
--- Furthermore, we need to ensure that when we generate elements, we are not
--- accidentally creating duplicates, because ggtx won't allow us (in the frontend, at least)
--- to create (say) a MapTerm called \"foo\" if we have already a candidate term with that name.
-genCopusWithMatchingElement :: Gen (Map NgramsTerm NgramsElement, NgramsElement)
-genCopusWithMatchingElement = do
-  -- cap the depth of the tree, to not make the tests too slow
-  depth <- choose (1, 5)
-  let mkEntry = do
-        trm <- arbitrary
-        el  <- over ne_children (breakLoop trm) <$> (resize depth arbitrary)
-        pure (trm, el { _ne_ngrams = trm })
-  -- Let's build the map first, so that duplicates will be overwritten.
-  fullMap <- (Map.fromList <$> vectorOf depth mkEntry) `suchThat` (\x -> isRight (buildForest x)) -- exclude loops
-  let (hd NE.:| _) = NE.fromList $ Map.elems fullMap
-  pure (fullMap, hd)
-  where
-    breakLoop :: NgramsTerm -> MSet NgramsTerm -> MSet NgramsTerm
-    breakLoop t = mSetFromSet . Set.delete t . mSetToSet
-
 -- | Property that tests that if we make a search for a given term that we know it's
 -- present in the list, we need to get it back, either directly (i.e. a single match) or
 -- indirectly (i.e. present in the list of results, because it's included in a hierarchy of nodes).
 testForestSearchProp :: Property
-testForestSearchProp = forAllShrink genCopusWithMatchingElement shrinkTree $ \(ngramsTable, el) -> do
+testForestSearchProp = forAll arbitrary $ \(AcyclicTableMap ngramsTable el) -> do
   case searchTableNgrams (Versioned 0 ngramsTable) (searchQuery el) of
     Left (BFE_loop_detected err) -> fail (T.unpack $ renderLoop err)
     Right res -> res ^. vc_data `shouldSatisfy` (elem (_ne_ngrams el) . map _ne_ngrams . getNgramsTable)
@@ -254,17 +248,24 @@ testForestSearchProp = forAllShrink genCopusWithMatchingElement shrinkTree $ \(n
                , _nsq_searchQuery = mockQueryFn (Just $ unNgramsTerm $ _ne_ngrams term)
                }
 
-shrinkTree :: (Map.Map NgramsTerm NgramsElement, NgramsElement)
-           -> [(Map.Map NgramsTerm NgramsElement, NgramsElement)]
-shrinkTree (mp, el) =
-  [ (Map.insert k shrunk mp, if k == _ne_ngrams el then shrunk else el)
-  | (k, ne) <- Map.toList mp
-  , shrunkChildren <- shrinkSet (_ne_children ne)
-  , let shrunk = ne { _ne_children = shrunkChildren }
-  ]
-
-shrinkSet :: Ord a => MSet a -> [MSet a]
-shrinkSet s = map mSetFromList (shrinkList (const []) (mSetToList s))
+-- | In this test we check that if we have nested terms, they will still show up in search.
+-- In this test we have a nested hierarchy of a level-2 tree, and we search for the children,
+-- and it still shows up.
+testSearchNestedTerms :: Assertion
+testSearchNestedTerms = do
+  case searchTableNgrams (Versioned 0 hierarchicalTableMap) searchQuery of
+    Left (BFE_loop_detected err) -> fail (T.unpack $ renderLoop err)
+    Right res -> res ^. vc_data `shouldSatisfy` (elem "ford" . map _ne_ngrams . getNgramsTable)
+  where
+   searchQuery = NgramsSearchQuery {
+                 _nsq_limit       = Limit 5
+               , _nsq_offset      = Nothing
+               , _nsq_listType    = Nothing
+               , _nsq_minSize     = Nothing
+               , _nsq_maxSize     = Nothing
+               , _nsq_orderBy     = Just TermDesc
+               , _nsq_searchQuery = mockQueryFn (Just "ford")
+               }
 
 -- Pagination tests
 

test/Test/Offline/Ngrams.hs

@@ -13,7 +13,7 @@ import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Text qualified as T
 import Data.Tree
-import Gargantext.API.Ngrams (filterNgramsNodes, buildForest, destroyForest, pruneForest)
+import Gargantext.API.Ngrams
 import Gargantext.API.Ngrams.Types
 import Gargantext.API.Ngrams.Types qualified as NT
 import Gargantext.Core
@@ -26,8 +26,8 @@ import Gargantext.Database.Schema.Context
 import Test.HUnit
 import Test.Hspec
 import Test.Hspec.QuickCheck (prop)
-import Test.Instances ()
-import Test.Ngrams.Query (mkMapTerm)
+import Test.Instances (AcyclicTableMap(..))
+import Test.Ngrams.Query (mkMapTerm, hierarchicalTableMap)
 import Test.QuickCheck
 import Test.QuickCheck qualified as QC
 import Text.RawString.QQ (r)
@@ -113,16 +113,6 @@ tests = describe "Ngrams" $ do
   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 = buildForestOrFail hierarchicalTableMap
@@ -151,7 +141,7 @@ instance Show ASCIIForest where
 
 buildForestOrFail :: Map NgramsTerm NgramsElement -> Forest NgramsElement
 buildForestOrFail mp = case buildForest mp of
-  Left err -> error (show err)
+  Left (BFE_loop_detected treeLoop) -> error (T.unpack $ renderLoop treeLoop)
   Right x  -> x
 
 compareForestVisually :: Forest NgramsElement -> String -> Property
@@ -276,17 +266,9 @@ testBuildNgramsTree_03 =
 |]
 
 
-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) =
+buildDestroyForestRoundtrips :: AcyclicTableMap -> Property
+buildDestroyForestRoundtrips (AcyclicTableMap mp _) =
   (destroyForest . buildForestOrFail $ mp) === mp
 
 testPruningNgramsForest_01 :: Property