Commit 8de56ef9 authored by Alexandre Delanoë's avatar Alexandre Delanoë

Merge remote-tracking branch 'origin/adinapoli/issue-331' into testing

parents a8b3d08c 37979721
...@@ -629,6 +629,7 @@ library ...@@ -629,6 +629,7 @@ library
, tomland >= 1.3.3.2 , tomland >= 1.3.3.2
, tuple ^>= 0.3.0.2 , tuple ^>= 0.3.0.2
, unordered-containers ^>= 0.2.16.0 , unordered-containers ^>= 0.2.16.0
, unicode-collation >= 0.1.3.6
, uri-encode ^>= 1.5.0.7 , uri-encode ^>= 1.5.0.7
, utf8-string ^>= 1.0.2 , utf8-string ^>= 1.0.2
, uuid ^>= 1.3.15 , uuid ^>= 1.3.15
...@@ -960,6 +961,7 @@ test-suite garg-test-tasty ...@@ -960,6 +961,7 @@ test-suite garg-test-tasty
, tmp-postgres >= 1.34.1 && < 1.35 , tmp-postgres >= 1.34.1 && < 1.35
, tree-diff , tree-diff
, unordered-containers ^>= 0.2.16.0 , unordered-containers ^>= 0.2.16.0
, unicode-collation >= 0.1.3.6
, validity ^>= 0.11.0.1 , validity ^>= 0.11.0.1
, vector ^>= 0.12.3.0 , vector ^>= 0.12.3.0
, wai , wai
...@@ -1048,6 +1050,7 @@ test-suite garg-test-hspec ...@@ -1048,6 +1050,7 @@ test-suite garg-test-hspec
, text ^>= 1.2.4.1 , text ^>= 1.2.4.1
, time ^>= 1.9.3 , time ^>= 1.9.3
, tmp-postgres >= 1.34.1 && < 1.35 , tmp-postgres >= 1.34.1 && < 1.35
, tree-diff
, unordered-containers ^>= 0.2.16.0 , unordered-containers ^>= 0.2.16.0
, validity ^>= 0.11.0.1 , validity ^>= 0.11.0.1
, wai , wai
......
...@@ -121,6 +121,7 @@ import Gargantext.Prelude.Clock (hasTime, getTime) ...@@ -121,6 +121,7 @@ import Gargantext.Prelude.Clock (hasTime, getTime)
import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..)) import Gargantext.Utils.Jobs (serveJobsAPI, MonadJobStatus(..))
import Gargantext.Utils.Jobs.Monad (markFailedNoErr) import Gargantext.Utils.Jobs.Monad (markFailedNoErr)
import Servant hiding (Patch) import Servant hiding (Patch)
import Text.Collate qualified as Unicode
{- {-
-- TODO sequences of modifications (Patchs) -- TODO sequences of modifications (Patchs)
...@@ -557,13 +558,21 @@ searchTableNgrams versionedTableMap NgramsSearchQuery{..} = ...@@ -557,13 +558,21 @@ searchTableNgrams versionedTableMap NgramsSearchQuery{..} =
&& _nsq_searchQuery (inputNode ^. ne_ngrams) && _nsq_searchQuery (inputNode ^. ne_ngrams)
&& matchesListType (inputNode ^. ne_list) && matchesListType (inputNode ^. ne_list)
-- Sorts the input 'NgramsElement' list.
-- /IMPORTANT/: As we might be sorting ngrams in all sorts of language,
-- some of them might include letters with accents and other unicode symbols,
-- but we need to filter those /diacritics/ out so that the sorting would
-- happen in the way users would expect. See ticket #331.
sortOnOrder :: Maybe OrderBy -> ([NgramsElement] -> [NgramsElement]) sortOnOrder :: Maybe OrderBy -> ([NgramsElement] -> [NgramsElement])
sortOnOrder Nothing = sortOnOrder (Just ScoreDesc) sortOnOrder Nothing = sortOnOrder (Just ScoreDesc)
sortOnOrder (Just TermAsc) = List.sortOn $ view ne_ngrams sortOnOrder (Just TermAsc) = List.sortBy ngramTermsAscSorter
sortOnOrder (Just TermDesc) = List.sortOn $ Down . view ne_ngrams sortOnOrder (Just TermDesc) = List.sortBy ngramTermsDescSorter
sortOnOrder (Just ScoreAsc) = List.sortOn $ view (ne_occurrences . to Set.size) sortOnOrder (Just ScoreAsc) = List.sortOn $ view (ne_occurrences . to Set.size)
sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view (ne_occurrences . to Set.size) sortOnOrder (Just ScoreDesc) = List.sortOn $ Down . view (ne_occurrences . to Set.size)
ngramTermsAscSorter = on unicodeDUCETSorter (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 -- | Filters the given `tableMap` with the search criteria. It returns
-- a set of 'NgramsElement' all matching the input 'NGramsSearchQuery'. -- a set of 'NgramsElement' all matching the input 'NGramsSearchQuery'.
filterNodes :: Map NgramsTerm NgramsElement -> Set NgramsElement filterNodes :: Map NgramsTerm NgramsElement -> Set NgramsElement
...@@ -596,6 +605,13 @@ searchTableNgrams versionedTableMap NgramsSearchQuery{..} = ...@@ -596,6 +605,13 @@ searchTableNgrams versionedTableMap NgramsSearchQuery{..} =
. Set.toList . Set.toList
$ xs $ xs
-- | This function allows sorting two texts via their unicode sorting
-- (as opposed as the standard lexicographical sorting) by relying on
-- the DUCET table, a table that specifies the ordering of all unicode
-- characters. This is enough for mimicking the \"natural sort\" effect
-- that users would expect.
unicodeDUCETSorter :: Text -> Text -> Ordering
unicodeDUCETSorter = Unicode.collate Unicode.rootCollator
getTableNgrams :: forall env err m. getTableNgrams :: forall env err m.
( HasNodeStory env err m ( HasNodeStory env err m
......
...@@ -8,12 +8,14 @@ Stability : experimental ...@@ -8,12 +8,14 @@ Stability : experimental
Portability : POSIX Portability : POSIX
-} -}
{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS -fno-warn-orphans #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -fno-warn-orphans #-}
module Gargantext.API.Ngrams.Types where module Gargantext.API.Ngrams.Types where
...@@ -33,6 +35,7 @@ import Data.Set qualified as Set ...@@ -33,6 +35,7 @@ import Data.Set qualified as Set
import Data.String (IsString(..)) import Data.String (IsString(..))
import Data.Swagger ( NamedSchema(NamedSchema), declareSchemaRef, genericDeclareNamedSchema, SwaggerType(SwaggerObject), ToParamSchema, ToSchema(..), HasProperties(properties), HasRequired(required), HasType(type_) ) import Data.Swagger ( NamedSchema(NamedSchema), declareSchemaRef, genericDeclareNamedSchema, SwaggerType(SwaggerObject), ToParamSchema, ToSchema(..), HasProperties(properties), HasRequired(required), HasType(type_) )
import Data.Text qualified as T import Data.Text qualified as T
import Data.TreeDiff
import Data.Validity ( Validity(..) ) import Data.Validity ( Validity(..) )
import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField) import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
import Database.PostgreSQL.Simple.ToField (ToField, toJSONField, toField) import Database.PostgreSQL.Simple.ToField (ToField, toJSONField, toField)
...@@ -92,7 +95,9 @@ instance ToJSONKey TabType where ...@@ -92,7 +95,9 @@ instance ToJSONKey TabType where
toJSONKey = genericToJSONKey defaultJSONKeyOptions toJSONKey = genericToJSONKey defaultJSONKeyOptions
newtype MSet a = MSet (Map a ()) newtype MSet a = MSet (Map a ())
deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid) deriving stock (Eq, Ord, Show, Generic)
deriving newtype (Arbitrary, Semigroup, Monoid)
deriving anyclass (ToExpr)
instance ToJSON a => ToJSON (MSet a) where instance ToJSON a => ToJSON (MSet a) where
toJSON (MSet m) = toJSON (Map.keys m) toJSON (MSet m) = toJSON (Map.keys m)
...@@ -124,7 +129,9 @@ instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where ...@@ -124,7 +129,9 @@ instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
------------------------------------------------------------------------ ------------------------------------------------------------------------
newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text } newtype NgramsTerm = NgramsTerm { unNgramsTerm :: Text }
deriving (Ord, Eq, Show, Generic, ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable, NFData, FromField, ToField) deriving (Ord, Eq, Show, Generic)
deriving newtype (ToJSONKey, ToJSON, FromJSON, Semigroup, Arbitrary, Serialise, ToSchema, Hashable, NFData, FromField, ToField)
deriving anyclass (ToExpr)
instance IsHashable NgramsTerm where instance IsHashable NgramsTerm where
hash (NgramsTerm t) = hash t hash (NgramsTerm t) = hash t
instance Monoid NgramsTerm where instance Monoid NgramsTerm where
...@@ -175,7 +182,8 @@ data NgramsElement = ...@@ -175,7 +182,8 @@ data NgramsElement =
, _ne_parent :: Maybe NgramsTerm , _ne_parent :: Maybe NgramsTerm
, _ne_children :: MSet NgramsTerm , _ne_children :: MSet NgramsTerm
} }
deriving (Ord, Eq, Show, Generic) deriving stock (Ord, Eq, Show, Generic)
deriving anyclass (ToExpr)
deriveJSON (unPrefix "_ne_") ''NgramsElement deriveJSON (unPrefix "_ne_") ''NgramsElement
makeLenses ''NgramsElement makeLenses ''NgramsElement
...@@ -197,7 +205,9 @@ instance ToSchema NgramsElement where ...@@ -197,7 +205,9 @@ instance ToSchema NgramsElement where
------------------------------------------------------------------------ ------------------------------------------------------------------------
newtype NgramsTable = NgramsTable [NgramsElement] newtype NgramsTable = NgramsTable [NgramsElement]
deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show) deriving stock (Ord, Eq, Generic, Show)
deriving newtype (ToJSON, FromJSON)
deriving anyclass (ToExpr)
-- type NgramsList = NgramsTable -- type NgramsList = NgramsTable
...@@ -385,8 +395,8 @@ isRem = (== remPatch) ...@@ -385,8 +395,8 @@ isRem = (== remPatch)
type PatchMap = PM.PatchMap type PatchMap = PM.PatchMap
newtype PatchMSet a = PatchMSet (PatchMap a AddRem) newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
deriving (Eq, Show, Generic, Validity, Semigroup, Monoid, Group, deriving stock (Eq, Show, Generic)
Transformable, Composable) deriving newtype (Validity, Semigroup, Monoid, Group, Transformable, Composable)
unPatchMSet :: PatchMSet a -> PatchMap a AddRem unPatchMSet :: PatchMSet a -> PatchMap a AddRem
unPatchMSet (PatchMSet a) = a unPatchMSet (PatchMSet a) = a
...@@ -538,7 +548,8 @@ instance Action (Replace ListType) NgramsRepoElement where ...@@ -538,7 +548,8 @@ instance Action (Replace ListType) NgramsRepoElement where
act replaceP = over nre_list (act replaceP) act replaceP = over nre_list (act replaceP)
newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch) newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable) deriving stock (Eq, Show, Generic)
deriving newtype (ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
mkNgramsTablePatch :: Map NgramsTerm NgramsPatch -> NgramsTablePatch mkNgramsTablePatch :: Map NgramsTerm NgramsPatch -> NgramsTablePatch
mkNgramsTablePatch = NgramsTablePatch . PM.fromMap mkNgramsTablePatch = NgramsTablePatch . PM.fromMap
...@@ -699,7 +710,8 @@ data VersionedWithCount a = VersionedWithCount ...@@ -699,7 +710,8 @@ data VersionedWithCount a = VersionedWithCount
, _vc_count :: Count , _vc_count :: Count
, _vc_data :: a , _vc_data :: a
} }
deriving (Generic, Show, Eq) deriving stock (Generic, Show, Eq)
deriving anyclass ToExpr
deriveJSON (unPrefix "_vc_") ''VersionedWithCount deriveJSON (unPrefix "_vc_") ''VersionedWithCount
makeLenses ''VersionedWithCount makeLenses ''VersionedWithCount
instance (Typeable a, ToSchema a) => ToSchema (VersionedWithCount a) where instance (Typeable a, ToSchema a) => ToSchema (VersionedWithCount a) where
......
...@@ -12,6 +12,7 @@ Portability : POSIX ...@@ -12,6 +12,7 @@ Portability : POSIX
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveAnyClass #-}
----------------------------------------------------------------------- -----------------------------------------------------------------------
module Gargantext.Core.Types.Main where module Gargantext.Core.Types.Main where
...@@ -22,6 +23,7 @@ import Data.Aeson.TH (deriveJSON) ...@@ -22,6 +23,7 @@ import Data.Aeson.TH (deriveJSON)
import Data.Bimap (Bimap) import Data.Bimap (Bimap)
import Data.Swagger import Data.Swagger
import Data.Text (unpack, pack) import Data.Text (unpack, pack)
import Data.TreeDiff
import Gargantext.Core import Gargantext.Core
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema) import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Database.Admin.Types.Node -- (NodeType(..), Node, Hyperdata(..)) import Gargantext.Database.Admin.Types.Node -- (NodeType(..), Node, Hyperdata(..))
...@@ -49,7 +51,7 @@ type TypeId = Int ...@@ -49,7 +51,7 @@ type TypeId = Int
-- TODO multiple ListType declaration, remove it -- TODO multiple ListType declaration, remove it
-- data ListType = CandidateTerm | StopTerm | MapTerm -- data ListType = CandidateTerm | StopTerm | MapTerm
data ListType = CandidateTerm | StopTerm | MapTerm data ListType = CandidateTerm | StopTerm | MapTerm
deriving (Generic, Eq, Ord, Show, Read, Enum, Bounded) deriving (Generic, Eq, Ord, Show, Read, Enum, Bounded, ToExpr)
instance ToJSON ListType instance ToJSON ListType
instance FromJSON ListType instance FromJSON ListType
......
...@@ -11,11 +11,12 @@ Portability : POSIX ...@@ -11,11 +11,12 @@ Portability : POSIX
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DerivingVia #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- {-# LANGUAGE DuplicateRecordFields #-} -- {-# LANGUAGE DuplicateRecordFields #-}
...@@ -32,6 +33,7 @@ import Data.Morpheus.Types ...@@ -32,6 +33,7 @@ import Data.Morpheus.Types
import Data.Swagger import Data.Swagger
import Data.Text (unpack, pack) import Data.Text (unpack, pack)
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Data.TreeDiff
import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField) import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField) import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
import Database.PostgreSQL.Simple.ToRow (ToRow, toRow) import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
...@@ -246,7 +248,9 @@ pgContextId = pgResourceId _ContextId ...@@ -246,7 +248,9 @@ pgContextId = pgResourceId _ContextId
-- to a tree, and each node has its unique identifier. Note how nodes might -- to a tree, and each node has its unique identifier. Note how nodes might
-- have also /other/ identifiers, to better qualify them. -- have also /other/ identifiers, to better qualify them.
newtype NodeId = UnsafeMkNodeId { _NodeId :: Int } newtype NodeId = UnsafeMkNodeId { _NodeId :: Int }
deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField) deriving stock (Read, Generic, Eq, Ord)
deriving newtype (Num, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
deriving anyclass (ToExpr)
instance ResourceId NodeId where instance ResourceId NodeId where
isPositive = (> 0) . _NodeId isPositive = (> 0) . _NodeId
...@@ -275,6 +279,7 @@ instance ToSchema NodeId ...@@ -275,6 +279,7 @@ instance ToSchema NodeId
newtype ContextId = UnsafeMkContextId { _ContextId :: Int } newtype ContextId = UnsafeMkContextId { _ContextId :: Int }
deriving stock (Show, Eq, Ord, Generic) deriving stock (Show, Eq, Ord, Generic)
deriving newtype (Csv.ToField, ToJSONKey, FromJSONKey, ToJSON, FromJSON, ToField, ToSchema) deriving newtype (Csv.ToField, ToJSONKey, FromJSONKey, ToJSON, FromJSON, ToField, ToSchema)
deriving anyclass ToExpr
deriving FromField via NodeId deriving FromField via NodeId
instance ToParamSchema ContextId instance ToParamSchema ContextId
...@@ -288,7 +293,9 @@ instance ToHttpApiData ContextId where ...@@ -288,7 +293,9 @@ instance ToHttpApiData ContextId where
toUrlPiece (UnsafeMkContextId n) = toUrlPiece n toUrlPiece (UnsafeMkContextId n) = toUrlPiece n
newtype NodeContextId = UnsafeMkNodeContextId { _NodeContextId :: Int } newtype NodeContextId = UnsafeMkNodeContextId { _NodeContextId :: Int }
deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField) deriving stock (Read, Generic, Eq, Ord)
deriving newtype (Num, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
deriving anyclass (ToExpr)
--instance Csv.ToField NodeId where --instance Csv.ToField NodeId where
......
...@@ -9,7 +9,6 @@ import Data.Conduit ...@@ -9,7 +9,6 @@ import Data.Conduit
import Data.String import Data.String
import Gargantext.Core (Lang(..)) import Gargantext.Core (Lang(..))
import Gargantext.Core.Text.Corpus.Query import Gargantext.Core.Text.Corpus.Query
import Gargantext.Core.Types
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..)) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
import Prelude import Prelude
import System.Environment import System.Environment
......
...@@ -7,8 +7,10 @@ import Data.Coerce ...@@ -7,8 +7,10 @@ import Data.Coerce
import Data.Map.Strict qualified as Map import Data.Map.Strict qualified as Map
import Data.Monoid import Data.Monoid
import Data.Patch.Class qualified as Patch import Data.Patch.Class qualified as Patch
import Data.String
import Data.Text qualified as T import Data.Text qualified as T
import Data.Validity qualified as Validity import Data.Validity qualified as Validity
import Text.Collate qualified as Unicode
import Gargantext.API.Ngrams import Gargantext.API.Ngrams
import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types.Main import Gargantext.Core.Types.Main
...@@ -17,16 +19,20 @@ import Gargantext.Prelude ...@@ -17,16 +19,20 @@ import Gargantext.Prelude
import Test.Ngrams.Query.PaginationCorpus import Test.Ngrams.Query.PaginationCorpus
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import Test.Utils ((@??=))
tests :: TestTree tests :: TestTree
tests = testGroup "Ngrams" [unitTests] tests = testGroup "Ngrams" [unitTests]
curryElem :: NgramsElement curryElem :: NgramsElement
curryElem = mkNgramsElement "curry" MapTerm Nothing mempty curryElem = mkMapTerm "curry"
elbaElem :: NgramsElement elbaElem :: NgramsElement
elbaElem = mkNgramsElement "elba" MapTerm Nothing mempty elbaElem = mkMapTerm "elba"
mkMapTerm :: T.Text -> NgramsElement
mkMapTerm e = mkNgramsElement (fromString . T.unpack $ e) MapTerm Nothing mempty
mockFlatCorpus :: Versioned (Map NgramsTerm NgramsElement) mockFlatCorpus :: Versioned (Map NgramsTerm NgramsElement)
mockFlatCorpus = Versioned 0 $ Map.fromList [ mockFlatCorpus = Versioned 0 $ Map.fromList [
...@@ -43,6 +49,9 @@ unitTests = testGroup "Query tests" ...@@ -43,6 +49,9 @@ unitTests = testGroup "Query tests"
[ -- Sorting [ -- Sorting
testCase "Simple query mockFlatCorpus" testFlat01 testCase "Simple query mockFlatCorpus" testFlat01
, testCase "Simple query (desc sorting)" testFlat02 , testCase "Simple query (desc sorting)" testFlat02
, testCase "[#331] sorting via DUCET works" testSortDiacriticsDucet
, testCase "[#331] Natural sort ascending works" testNaturalSortAsceding
, testCase "[#331] Natural sort descending works" testNaturalSortDescending
-- -- Filtering -- -- Filtering
, testCase "Simple query (listType = MapTerm)" testFlat03 , testCase "Simple query (listType = MapTerm)" testFlat03
, testCase "Simple query (listType = StopTerm)" testFlat04 , testCase "Simple query (listType = StopTerm)" testFlat04
...@@ -96,6 +105,61 @@ testFlat02 = do ...@@ -96,6 +105,61 @@ testFlat02 = do
, _nsq_searchQuery = mockQueryFn Nothing , _nsq_searchQuery = mockQueryFn Nothing
} }
testSortDiacriticsDucet :: Assertion
testSortDiacriticsDucet = do
let inputData = [ "étude", "âge", "vue", "période" ]
let expected = [ "âge", "étude", "période", "vue" ]
expected @??= sortBy (Unicode.collate Unicode.rootCollator) inputData
testNaturalSortAsceding :: Assertion
testNaturalSortAsceding = do
let res = searchTableNgrams frenchCorpus searchQuery
res @??= VersionedWithCount 0 4 ( NgramsTable $ map mkMapTerm [ "âge", "étude", "période", "vue" ])
where
frenchCorpus :: Versioned (Map NgramsTerm NgramsElement)
frenchCorpus = Versioned 0 $ Map.fromList [
( "doc_01", mkMapTerm "période")
, ( "doc_02", mkMapTerm "vue")
, ( "doc_03", mkMapTerm "âge")
, ( "doc_04", mkMapTerm "étude")
]
searchQuery = NgramsSearchQuery {
_nsq_limit = Limit 10
, _nsq_offset = Nothing
, _nsq_listType = Nothing
, _nsq_minSize = Nothing
, _nsq_maxSize = Nothing
, _nsq_orderBy = Just TermAsc
, _nsq_searchQuery = mockQueryFn Nothing
}
testNaturalSortDescending :: Assertion
testNaturalSortDescending = do
let res = searchTableNgrams frenchCorpus searchQuery
res @??= VersionedWithCount 0 4 ( NgramsTable $ map mkMapTerm [ "vue", "période", "étude", "âge" ])
where
frenchCorpus :: Versioned (Map NgramsTerm NgramsElement)
frenchCorpus = Versioned 0 $ Map.fromList [
( "doc_01", mkMapTerm "période")
, ( "doc_02", mkMapTerm "vue")
, ( "doc_03", mkMapTerm "âge")
, ( "doc_04", mkMapTerm "étude")
]
searchQuery = NgramsSearchQuery {
_nsq_limit = Limit 10
, _nsq_offset = Nothing
, _nsq_listType = Nothing
, _nsq_minSize = Nothing
, _nsq_maxSize = Nothing
, _nsq_orderBy = Just TermDesc
, _nsq_searchQuery = mockQueryFn Nothing
}
testFlat03 :: Assertion testFlat03 :: Assertion
testFlat03 = do testFlat03 = do
let res = searchTableNgrams mockFlatCorpus searchQuery let res = searchTableNgrams mockFlatCorpus searchQuery
......
...@@ -20,6 +20,7 @@ import Data.Text qualified as T ...@@ -20,6 +20,7 @@ import Data.Text qualified as T
import Data.Text.Encoding qualified as TE import Data.Text.Encoding qualified as TE
import Data.Text.Lazy qualified as TL import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TLE import Data.Text.Lazy.Encoding qualified as TLE
import Data.TreeDiff
import Fmt (Builder) import Fmt (Builder)
import Gargantext.API.Admin.Auth.Types (AuthRequest(..), Token, authRes_token) import Gargantext.API.Admin.Auth.Types (AuthRequest(..), Token, authRes_token)
import Gargantext.Core.Types.Individu (Username, GargPassword) import Gargantext.Core.Types.Individu (Username, GargPassword)
...@@ -37,7 +38,7 @@ import Test.Hspec.Expectations ...@@ -37,7 +38,7 @@ import Test.Hspec.Expectations
import Test.Hspec.Wai (MatchBody(..), WaiExpectation, WaiSession, request) import Test.Hspec.Wai (MatchBody(..), WaiExpectation, WaiSession, request)
import Test.Hspec.Wai.JSON (FromValue(..)) import Test.Hspec.Wai.JSON (FromValue(..))
import Test.Hspec.Wai.Matcher (MatchHeader(..), ResponseMatcher(..), bodyEquals, formatHeader, match) import Test.Hspec.Wai.Matcher (MatchHeader(..), ResponseMatcher(..), bodyEquals, formatHeader, match)
import Test.Tasty.HUnit (Assertion) import Test.Tasty.HUnit (Assertion, assertBool)
import Test.Types import Test.Types
...@@ -223,3 +224,7 @@ pollUntilFinished tkn port mkUrlPiece = go 60 ...@@ -223,3 +224,7 @@ pollUntilFinished tkn port mkUrlPiece = go 60
| otherwise | otherwise
-> pure h -> pure h
-- | Like HUnit's '@?=', but With a nicer error message in case the two entities are not equal.
(@??=) :: (HasCallStack, ToExpr a, Eq a) => a -> a -> Assertion
actual @??= expected =
assertBool (show $ ansiWlEditExprCompact $ ediff expected actual) (expected == actual)
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