Migrate to `Felix` namespaceHEADhotg

1 files changed, 114 insertions, 0 deletions

diff --git a/source/Felix/Test/Unit/Abstract.hs b/source/Felix/Test/Unit/Abstract.hs
new file mode 100644
index 0000000..c487c2a
--- /dev/null
+++ b/source/Felix/Test/Unit/Abstract.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Felix.Test.Unit.Abstract (unitTests) where
+
+import Base
+import Felix.Report.Location
+import Felix.Syntax.Abstract
+
+import Hedgehog
+import Hedgehog.Gen qualified as Gen
+import Test.Tasty
+import Test.Tasty.HUnit hiding (assert)
+import Test.Tasty.Hedgehog (testPropertyNamed)
+
+unitTests :: TestTree
+unitTests =
+    testGroup "Abstract syntax"
+        [ testPropertyNamed
+            "noun phrase ordering obeys the Ord laws"
+            "prop_nounPhraseOrd"
+            prop_nounPhraseOrd
+        , testCase
+            "noun phrase fields survive ordered deduplication"
+            nounPhraseFieldsRemainDistinct
+        ]
+
+prop_nounPhraseOrd :: Property
+prop_nounPhraseOrd = withTests 100 . property $ do
+    x <- forAll nounPhrase
+    y <- forAll nounPhrase
+    z <- forAll nounPhrase
+
+    (compare x y == EQ) === (x == y)
+    compare x y === oppositeOrdering (compare y x)
+    assert (not (x <= y && y <= z) || x <= z)
+
+nounPhraseFieldsRemainDistinct :: Assertion
+nounPhraseFieldsRemainDistinct =
+    assertEqual
+        "one value per base and changed field"
+        6
+        (length
+            (nubOrd
+                [ sampleNounPhrase False False False False False
+                , sampleNounPhrase True False False False False
+                , sampleNounPhrase False True False False False
+                , sampleNounPhrase False False True False False
+                , sampleNounPhrase False False False True False
+                , sampleNounPhrase False False False False True
+                ]))
+
+nounPhrase :: Gen (NounPhraseOf Maybe Int)
+nounPhrase =
+    sampleNounPhrase
+        <$> Gen.bool
+        <*> Gen.bool
+        <*> Gen.bool
+        <*> Gen.bool
+        <*> Gen.bool
+
+sampleNounPhrase
+    :: Bool
+    -> Bool
+    -> Bool
+    -> Bool
+    -> Bool
+    -> NounPhraseOf Maybe Int
+sampleNounPhrase hasLeft otherNoun hasName hasRight hasSuchThat =
+    NounPhrase
+        [AdjL Nowhere leftAdjective [1] | hasLeft]
+        (Noun
+            Nowhere
+            (if otherNoun then secondNoun else firstNoun)
+            [2])
+        (NamedVar "x" <$ guardMaybe hasName)
+        [AdjR Nowhere rightAdjective [3] | hasRight]
+        (truthStatement <$ guardMaybe hasSuchThat)
+  where
+    guardMaybe condition =
+        if condition then Just () else Nothing
+
+leftAdjective :: LexicalItem
+leftAdjective =
+    mkLexicalItem [Just (Word "left")] "left"
+
+rightAdjective :: LexicalItem
+rightAdjective =
+    mkLexicalItem [Just (Word "right")] "right"
+
+firstNoun :: LexicalItemSgPl
+firstNoun =
+    mkLexicalItemSgPl
+        (SgPl
+            [Just (Word "first")]
+            [Just (Word "firsts")])
+        "first"
+
+secondNoun :: LexicalItemSgPl
+secondNoun =
+    mkLexicalItemSgPl
+        (SgPl
+            [Just (Word "second")]
+            [Just (Word "seconds")])
+        "second"
+
+truthStatement :: Stmt
+truthStatement =
+    StmtFormula (PropositionalConstant Nowhere IsTop)
+
+oppositeOrdering :: Ordering -> Ordering
+oppositeOrdering = \case
+    LT -> GT
+    EQ -> EQ
+    GT -> LT