Add more Bool Query Engine tests

src-test/Core/Text/Corpus/Query.hs

 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 module Core.Text.Corpus.Query (tests) where
 
 import Data.BoolExpr
 import Gargantext.Core.Text.Corpus.Query
+import Gargantext.Core.Types
 import Prelude
 
 import Test.Tasty
-import Test.Tasty.QuickCheck hiding (Positive)
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck hiding (Positive, Negative)
 
 tests :: TestTree
 tests = testGroup "Boolean Query Engine" [
-  testProperty "Parses 'A OR B'" testParse01
+    testProperty "Parses 'A OR B'" testParse01
+  , testProperty "Parses 'A AND B'" testParse02
+  , testProperty "Parses '-A'" testParse03
+  , testProperty "Parses 'NOT A'" testParse03_01
+  , testProperty "Parses 'A -B'" testParse04
+  , testProperty "Parses 'A NOT -B'" testParse04_01
+  , testProperty "Parses 'A AND B -C'   (left associative)" testParse05
+  , testProperty "Parses 'A AND (B -C)' (right associative)" testParse05_01
+  , testProperty "Parses (A OR B OR NOT C) AND (D OR E OR F) -(G OR H OR I)" testParse06
+  , testCase     "Parses words into a single constant" testWordsIntoConst
+
   ]
 
+-- | Checks that the 'RawQuery' can be translated into the expected 'BoolExpr' form,
+-- by also checking that both renders back to the initial 'RawQuery'.
+translatesInto :: RawQuery -> BoolExpr Term -> Property
+(translatesInto) raw boolExpr =
+  let parsed   = parseQuery raw
+      expected = Right (unsafeMkQuery boolExpr)
+  in counterexample (show parsed <> " != " <> show expected) $
+       (renderQuery <$> parsed) === (renderQuery <$> expected)
+
 testParse01 :: Property
-testParse01 =
-  (renderQuery <$> parseQuery "A OR B") === (renderQuery <$> Right (unsafeMkQuery $ (BConst (Positive "A") `BOr` BConst (Positive "B"))))
+testParse01 = "A OR B" `translatesInto` (BConst (Positive "A") `BOr` BConst (Positive "B"))
+
+testParse02 :: Property
+testParse02 = "A AND B" `translatesInto` (BConst (Positive "A") `BAnd` BConst (Positive "B"))
+
+testParse03 :: Property
+testParse03 = "-A" `translatesInto` (BConst (Negative "A"))
+
+testParse03_01 :: Property
+testParse03_01 = "NOT A" `translatesInto` (BConst (Negative "A"))
+
+testParse04 :: Property
+testParse04 = "A -B" `translatesInto` (BConst (Positive "A") `BAnd` BConst (Negative "B"))
+
+-- Both 'A -B' and 'A AND -B' desugars into the same form.
+testParse04_01 :: Property
+testParse04_01 = "A AND -B" `translatesInto` (BConst (Positive "A") `BAnd` BConst (Negative "B"))
+
+testParse05 :: Property
+testParse05 = "A AND B -C" `translatesInto` ((BConst (Positive "A") `BAnd` BConst (Positive "B")) `BAnd` BConst (Negative "C"))
+
+testParse05_01 :: Property
+testParse05_01 =
+  "A AND (B -C)" `translatesInto` (BConst (Positive "A") `BAnd` (BConst (Positive "B") `BAnd` BConst (Negative "C")))
+
+testParse06 :: Property
+testParse06 =
+  translatesInto "(A OR B OR NOT C) AND (D OR E OR F) -(G OR H OR I)"
+    (
+      (
+        ((BConst (Positive  "A") `BOr` (BConst (Positive  "B"))) `BOr` (BConst  (Negative "C")))
+        `BAnd`
+        ((BConst (Positive "D") `BOr` (BConst (Positive "E"))) `BOr` (BConst (Positive "F")))
+      )
+      `BAnd` BNot (
+        ((BConst (Positive "G") `BOr` (BConst (Positive "H"))) `BOr` (BConst (Positive "I")))
+      )
+    )
+
+testWordsIntoConst :: Assertion
+testWordsIntoConst =
+  let (expected :: BoolExpr Term) =
+        fromCNF (boolTreeToCNF @Term $ (BConst (Positive "The Art of Computer Programming") `BAnd` (BConst (Positive "Conceptual Mathematics"))))
+  in case parseQuery "\"The Art of Computer Programming\" AND \"Conceptual Mathematics\"" of
+    Left err
+      -> assertBool err False
+    Right x
+      -> fromCNF (getQuery x) @?= expected

src-test/Utils/Jobs.hs

@@ -17,7 +17,6 @@ import Data.Either
 import Data.List
 import Data.Sequence (Seq, (|>), fromList)
 import Data.Time
-import GHC.Stack
 import Prelude
 import System.IO.Unsafe
 import Network.HTTP.Client.TLS (newTlsManager)

src/Gargantext/Core/Text/Corpus/Query.hs

@@ -18,6 +18,7 @@ import           Data.String
 import           Gargantext.API.Admin.Orchestrator.Types
 import           Gargantext.Core.Types
 import           Prelude
+import           Text.ParserCombinators.Parsec
 import qualified Data.Aeson                               as Aeson
 import qualified Data.BoolExpr                            as BoolExpr
 import qualified Data.BoolExpr.Parser                     as BoolExpr
@@ -50,10 +51,16 @@ newtype Query = Query { getQuery :: (BoolExpr.CNF Term) }
 unsafeMkQuery :: BoolExpr.BoolExpr Term -> Query
 unsafeMkQuery = Query . BoolExpr.boolTreeToCNF
 
+termToken :: CharParser st Term
+termToken = Term <$> (try (T.pack <$> BoolExpr.identifier) <|> (between dubQuote dubQuote multipleTerms))
+  where
+    dubQuote      = BoolExpr.symbol "\""
+    multipleTerms = T.intercalate " " . map T.pack <$> sepBy BoolExpr.identifier BoolExpr.whiteSpace
+
 -- | Parses an input 'Text' into a 'Query', reporting an error if it fails.
 parseQuery :: RawQuery -> Either String Query
 parseQuery (RawQuery txt) = bimap show (Query . BoolExpr.boolTreeToCNF) $
-  P.runParser (BoolExpr.parseBoolExpr (Term . T.pack <$> BoolExpr.identifier)) () "Corpus.Query" (T.unpack txt)
+  P.runParser (BoolExpr.parseBoolExpr termToken) () "Corpus.Query" (T.unpack txt)
 
 renderQuery :: Query -> RawQuery
 renderQuery (Query cnf) = RawQuery . T.pack $ BoolExpr.boolExprPrinter (showsPrec 0) (BoolExpr.fromCNF cnf) ""

src/Gargantext/Core/Types.hs

@@ -67,7 +67,7 @@ data Ordering = Down | Up
 type Name = Text
 
 newtype Term = Term { getTerm :: Text }
-  deriving newtype (IsString, Show)
+  deriving newtype (Eq, Ord, IsString, Show)
 
 type Stems = Set Text
 type Label = [Text]