Commit 30d2b444 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

Reuse AcyclicTableMap generator

parent f036a436
Pipeline #7822 passed with stages
in 43 minutes and 30 seconds
......@@ -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
......
......@@ -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))
{-# 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
......
......@@ -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
......
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