Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
118
Issues
118
List
Board
Labels
Milestones
Merge Requests
7
Merge Requests
7
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
gargantext
haskell-gargantext
Commits
b45714a8
Commit
b45714a8
authored
May 29, 2023
by
Alfredo Di Napoli
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Add more Bool Query Engine tests
parent
05e42831
Changes
4
Show whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
82 additions
and
7 deletions
+82
-7
Query.hs
src-test/Core/Text/Corpus/Query.hs
+73
-4
Jobs.hs
src-test/Utils/Jobs.hs
+0
-1
Query.hs
src/Gargantext/Core/Text/Corpus/Query.hs
+8
-1
Types.hs
src/Gargantext/Core/Types.hs
+1
-1
No files found.
src-test/Core/Text/Corpus/Query.hs
View file @
b45714a8
{-# 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 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
View file @
b45714a8
...
...
@@ -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
View file @
b45714a8
...
...
@@ -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
View file @
b45714a8
...
...
@@ -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
]
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment