Add sorting tests for searchTableNgrams

gargantext.cabal

@@ -1047,6 +1047,7 @@ test-suite garg-test-hspec
     , text ^>= 1.2.4.1
     , time ^>= 1.9.3
     , tmp-postgres >= 1.34.1 && < 1.35
+    , tree-diff
     , unordered-containers ^>= 0.2.16.0
     , validity ^>= 0.11.0.1
     , wai

src/Gargantext/API/Ngrams/Types.hs

@@ -8,12 +8,14 @@ Stability   : experimental
 Portability : POSIX
 -}
 
-{-# LANGUAGE ConstraintKinds   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TypeOperators     #-}
-{-# LANGUAGE TypeFamilies      #-}
-{-# OPTIONS -fno-warn-orphans #-}
+{-# LANGUAGE DerivingStrategies   #-}
+{-# LANGUAGE DeriveAnyClass       #-}
+{-# LANGUAGE ConstraintKinds      #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# OPTIONS -fno-warn-orphans     #-}
 
 module Gargantext.API.Ngrams.Types where
 
@@ -33,6 +35,7 @@ import Data.Set qualified as Set
 import Data.String (IsString(..))
 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.TreeDiff
 import Data.Validity ( Validity(..) )
 import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
 import Database.PostgreSQL.Simple.ToField (ToField, toJSONField, toField)
@@ -92,7 +95,9 @@ instance ToJSONKey TabType where
   toJSONKey = genericToJSONKey defaultJSONKeyOptions
 
 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
   toJSON     (MSet m) = toJSON     (Map.keys m)
@@ -124,7 +129,9 @@ instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
 
 ------------------------------------------------------------------------
 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
   hash (NgramsTerm t) = hash t
 instance Monoid NgramsTerm where
@@ -175,7 +182,8 @@ data NgramsElement =
                    , _ne_parent      :: Maybe NgramsTerm
                    , _ne_children    :: MSet  NgramsTerm
                    }
-      deriving (Ord, Eq, Show, Generic)
+      deriving stock (Ord, Eq, Show, Generic)
+      deriving anyclass (ToExpr)
 
 deriveJSON (unPrefix "_ne_") ''NgramsElement
 makeLenses ''NgramsElement
@@ -197,7 +205,9 @@ instance ToSchema NgramsElement where
 
 ------------------------------------------------------------------------
 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
 
@@ -385,8 +395,8 @@ isRem = (== remPatch)
 type PatchMap = PM.PatchMap
 
 newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
-  deriving (Eq, Show, Generic, Validity, Semigroup, Monoid, Group,
-            Transformable, Composable)
+  deriving stock (Eq, Show, Generic)
+  deriving newtype (Validity, Semigroup, Monoid, Group, Transformable, Composable)
 
 unPatchMSet :: PatchMSet a -> PatchMap a AddRem
 unPatchMSet (PatchMSet a) = a
@@ -538,7 +548,8 @@ instance Action (Replace ListType) NgramsRepoElement where
   act replaceP = over nre_list (act replaceP)
 
 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 = NgramsTablePatch . PM.fromMap
@@ -699,7 +710,8 @@ data VersionedWithCount a = VersionedWithCount
   , _vc_count   :: Count
   , _vc_data    :: a
   }
-  deriving (Generic, Show, Eq)
+  deriving stock (Generic, Show, Eq)
+  deriving anyclass ToExpr
 deriveJSON (unPrefix "_vc_") ''VersionedWithCount
 makeLenses ''VersionedWithCount
 instance (Typeable a, ToSchema a) => ToSchema (VersionedWithCount a) where

src/Gargantext/Core/Types/Main.hs

@@ -12,6 +12,7 @@ Portability : POSIX
 
 
 {-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE DeriveAnyClass      #-}
 
 -----------------------------------------------------------------------
 module Gargantext.Core.Types.Main where
@@ -22,6 +23,7 @@ import Data.Aeson.TH (deriveJSON)
 import Data.Bimap (Bimap)
 import Data.Swagger
 import Data.Text (unpack, pack)
+import Data.TreeDiff
 import Gargantext.Core
 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
 import Gargantext.Database.Admin.Types.Node  -- (NodeType(..), Node, Hyperdata(..))
@@ -49,7 +51,7 @@ type TypeId     = Int
 -- TODO multiple ListType declaration, remove it
 -- 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 FromJSON ListType

src/Gargantext/Database/Admin/Types/Node.hs

@@ -11,11 +11,12 @@ Portability : POSIX
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-{-# LANGUAGE BangPatterns               #-}
-{-# LANGUAGE DerivingStrategies         #-}
-{-# LANGUAGE DerivingVia                #-}
-{-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BangPatterns       #-}
+{-# LANGUAGE DeriveAnyClass     #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia        #-}
+{-# LANGUAGE TemplateHaskell    #-}
+{-# LANGUAGE TypeFamilies       #-}
 
 -- {-# LANGUAGE DuplicateRecordFields #-}
 
@@ -32,6 +33,7 @@ import Data.Morpheus.Types
 import Data.Swagger
 import Data.Text (unpack, pack)
 import Data.Time (UTCTime)
+import Data.TreeDiff
 import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
 import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
 import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
@@ -246,7 +248,9 @@ pgContextId = pgResourceId _ContextId
 -- to a tree, and each node has its unique identifier. Note how nodes might
 -- have also /other/ identifiers, to better qualify them.
 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
   isPositive = (> 0) . _NodeId
@@ -275,6 +279,7 @@ instance ToSchema NodeId
 newtype ContextId = UnsafeMkContextId { _ContextId :: Int }
   deriving stock   (Show, Eq, Ord, Generic)
   deriving newtype (Csv.ToField, ToJSONKey, FromJSONKey, ToJSON, FromJSON, ToField, ToSchema)
+  deriving anyclass ToExpr
   deriving FromField via NodeId
 
 instance ToParamSchema ContextId
@@ -288,7 +293,9 @@ instance ToHttpApiData ContextId where
   toUrlPiece (UnsafeMkContextId n) = toUrlPiece n
 
 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

test/Test/Core/Text/Corpus/Query.hs

@@ -9,7 +9,6 @@ import Data.Conduit
 import Data.String
 import Gargantext.Core (Lang(..))
 import Gargantext.Core.Text.Corpus.Query
-import Gargantext.Core.Types
 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
 import Prelude
 import System.Environment

test/Test/Ngrams/Query.hs

@@ -7,6 +7,7 @@ import Data.Coerce
 import Data.Map.Strict qualified as Map
 import Data.Monoid
 import Data.Patch.Class qualified as Patch
+import Data.String
 import Data.Text qualified as T
 import Data.Validity qualified as Validity
 import Gargantext.API.Ngrams
@@ -17,16 +18,20 @@ import Gargantext.Prelude
 import Test.Ngrams.Query.PaginationCorpus
 import Test.Tasty
 import Test.Tasty.HUnit
+import Test.Utils ((@??=))
 
 
 tests :: TestTree
 tests = testGroup "Ngrams" [unitTests]
 
 curryElem :: NgramsElement
-curryElem = mkNgramsElement "curry" MapTerm Nothing mempty
+curryElem = mkMapTerm "curry"
 
 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 0 $ Map.fromList [
@@ -43,6 +48,7 @@ unitTests = testGroup "Query tests"
   [ -- Sorting
     testCase "Simple query mockFlatCorpus" testFlat01
   , testCase "Simple query (desc sorting)" testFlat02
+  , testCase "[#331] Sort must ignore diacritics" testSortDiacritics
   --  -- Filtering
   , testCase "Simple query (listType = MapTerm)" testFlat03
   , testCase "Simple query (listType = StopTerm)" testFlat04
@@ -96,6 +102,31 @@ testFlat02 = do
                , _nsq_searchQuery = mockQueryFn Nothing
                }
 
+testSortDiacritics :: Assertion
+testSortDiacritics = 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 TermDesc
+               , _nsq_searchQuery = mockQueryFn Nothing
+               }
+
+
 testFlat03 :: Assertion
 testFlat03 = do
   let res = searchTableNgrams mockFlatCorpus searchQuery

test/Test/Utils.hs

@@ -20,6 +20,7 @@ import Data.Text qualified as T
 import Data.Text.Encoding qualified as TE
 import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.Encoding qualified as TLE
+import Data.TreeDiff
 import Fmt (Builder)
 import Gargantext.API.Admin.Auth.Types (AuthRequest(..), Token, authRes_token)
 import Gargantext.Core.Types.Individu (Username, GargPassword)
@@ -37,7 +38,7 @@ import Test.Hspec.Expectations
 import Test.Hspec.Wai (MatchBody(..), WaiExpectation, WaiSession, request)
 import Test.Hspec.Wai.JSON (FromValue(..))
 import Test.Hspec.Wai.Matcher (MatchHeader(..), ResponseMatcher(..), bodyEquals, formatHeader, match)
-import Test.Tasty.HUnit (Assertion)
+import Test.Tasty.HUnit (Assertion, assertBool)
 import Test.Types
 
 
@@ -223,3 +224,7 @@ pollUntilFinished tkn port mkUrlPiece = go 60
      | otherwise
      -> 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)