Migrate to `Felix` namespaceHEADhotg

1 files changed, 333 insertions, 0 deletions

diff --git a/source/Felix/Test/Unit/Lexicon.hs b/source/Felix/Test/Unit/Lexicon.hs
new file mode 100644
index 0000000..4b7f9e7
--- /dev/null
+++ b/source/Felix/Test/Unit/Lexicon.hs
@@ -0,0 +1,333 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Felix.Test.Unit.Lexicon (unitTests) where
+
+import Base
+import Felix.Cache.Codec
+import Felix.Syntax.Abstract
+import Felix.Syntax.Interface
+import Felix.Syntax.Lexicon
+
+import Data.Set qualified as Set
+import Test.Tasty
+import Test.Tasty.HUnit
+
+
+unitTests :: TestTree
+unitTests =
+    testGroup "Lexicon"
+        [ testCase "retains the literal ten-row base mixfix grouping"
+            retainsBaseMixfixGrouping
+        , testCase "checks literal mixfix levels"
+            checksMixfixLevels
+        , testCase "coalesces equal canonical syntax entries"
+            coalescesCanonicalEntries
+        , testCase "rejects shared plural parser surfaces"
+            rejectsSharedPluralSurfaces
+        , testCase "round-trips complete canonical lexical entries"
+            roundTripsCanonicalEntries
+        , testCase "round-trips asserted module syntax interfaces"
+            roundTripsSyntaxInterfaces
+        ]
+
+retainsBaseMixfixGrouping :: Assertion
+retainsBaseMixfixGrouping =
+    do
+        assertEqual
+            "least-to-most-tight marker and associativity rows"
+            expectedBaseRows
+            (fmap (fmap entryShape) builtinMixfixLevels)
+        assertEqual
+            "canonical base manifest"
+            expectedBaseRows
+            (fmap (fmap canonicalEntryShape) baseSyntaxManifest)
+        assertEqual
+            "cache-epoch base syntax identity"
+            "97acdc8153821b20dd0f45cf9d44870705723bb60737f7bacbb9ac31a98987a5"
+            (cacheDigestHex
+                (baseSyntaxInterfaceIdDigest
+                    baseSyntaxInterfaceId))
+  where
+    entryShape (MixfixItem _pattern marker associativity) =
+        (marker, associativity)
+
+    canonicalEntryShape = \case
+        CanonicalExpressionFunction
+                _pattern
+                marker
+                (Fixity associativity _level) ->
+            (marker, associativity)
+        entry ->
+            impossible
+                ("non-expression entry in base manifest: "
+                    <> show entry)
+
+checksMixfixLevels :: Assertion
+checksMixfixLevels = do
+    assertEqual
+        "lowest level"
+        (Right 0)
+        (mixfixLevelValue <$> mixfixLevel 0)
+    assertEqual
+        "highest internal level"
+        (Right 9)
+        (mixfixLevelValue <$> mixfixLevel 9)
+    assertEqual
+        "out-of-range level"
+        (Left (MixfixLevelOutOfRange 10))
+        (mixfixLevel 10)
+
+coalescesCanonicalEntries :: Assertion
+coalescesCanonicalEntries = do
+    level <- expectRight (mixfixLevel 3)
+    let pat =
+            patternFromHoley
+                [ Nothing
+                , Just (Command "star")
+                , Nothing
+                ]
+        first =
+            CanonicalExpressionFunction
+                pat
+                "star"
+                (Fixity LeftAssoc level)
+        conflicting =
+            CanonicalExpressionFunction
+                pat
+                "other_star"
+                (Fixity LeftAssoc level)
+    delta <- expectRight
+        (canonicalSyntaxDelta [first, first])
+    assertEqual
+        "equal entries coalesce"
+        1
+        (canonicalSyntaxDeltaSize delta)
+    assertEqual
+        "coalesced entry"
+        [first]
+        (canonicalSyntaxDeltaEntries delta)
+    assertEqual
+        "collision is independent of occurrence order"
+        (canonicalSyntaxDelta [first, conflicting])
+        (canonicalSyntaxDelta [conflicting, first])
+
+rejectsSharedPluralSurfaces :: Assertion
+rejectsSharedPluralSurfaces = do
+    let nounEntry =
+            CanonicalNoun
+                (wordPattern "member")
+                (wordPattern "objects")
+                "member"
+        otherNoun =
+            CanonicalNoun
+                (wordPattern "element")
+                (wordPattern "objects")
+                "element"
+        verbEntry =
+            CanonicalVerb
+                (wordPattern "belongs")
+                (wordPattern "objects")
+                "belongs"
+    assertPluralCollision nounEntry otherNoun
+    assertPluralCollision nounEntry verbEntry
+    case decodeCache
+            getCanonicalSyntaxDeltaCache
+            (encodeCache
+                (putCacheList
+                    putCanonicalLexicalEntryCache
+                    [nounEntry, otherNoun])) of
+        Left _ ->
+            pure ()
+        Right _ ->
+            assertFailure
+                "decoded a delta with a shared plural collision"
+  where
+    wordPattern word =
+        TokenCons (Word word) End
+
+    assertPluralCollision first second =
+        case canonicalSyntaxDelta [first, second] of
+            Left collision -> do
+                assertEqual
+                    "shared plural pattern"
+                    (wordPattern "objects")
+                    (canonicalCollisionPattern collision)
+                assertEqual
+                    "both complete entries"
+                    (Set.fromList [first, second])
+                    (Set.fromList
+                        (toList
+                            (canonicalCollisionEntries collision)))
+            Right _ ->
+                assertFailure
+                    "accepted two entries with one parser-active plural"
+
+roundTripsCanonicalEntries :: Assertion
+roundTripsCanonicalEntries = do
+    level <- expectRight (mixfixLevel 4)
+    let unary =
+            patternFromHoley
+                [ Just (Word "red")
+                , Nothing
+                ]
+        singular =
+            patternFromHoley
+                [ Just (Word "member")
+                , Just (Word "of")
+                , Nothing
+                ]
+        plural =
+            patternFromHoley
+                [ Just (Word "members")
+                , Just (Word "of")
+                , Nothing
+                ]
+        binary =
+            patternFromHoley
+                [ Nothing
+                , Just (Command "star")
+                , Nothing
+                ]
+        entries =
+            [ CanonicalLeftAdjective unary "red"
+            , CanonicalRightAdjective unary "red_right"
+            , CanonicalFunctionPhrase singular plural "member_fun"
+            , CanonicalNoun singular plural "member"
+            , CanonicalStructureNoun singular plural "member_struct"
+            , CanonicalVerb singular plural "member_verb"
+            , CanonicalRelation (Command "rel") (ParameterArity 2) "rel"
+            , CanonicalExpressionFunction
+                binary
+                "star"
+                (Fixity LeftAssoc level)
+            , CanonicalPrefixPredicate "Pred" 3 "pred"
+            , CanonicalStructureOperation "operation"
+            ]
+    traverse_
+        (\entry ->
+            assertEqual
+                ("cache round trip for " <> show entry)
+                (Right entry)
+                (decodeCache
+                    getCanonicalLexicalEntryCache
+                    (encodeCache
+                        (putCanonicalLexicalEntryCache entry))))
+        entries
+
+roundTripsSyntaxInterfaces :: Assertion
+roundTripsSyntaxInterfaces = do
+    level <- expectRight (mixfixLevel 7)
+    changedLevel <- expectRight (mixfixLevel 6)
+    let entry =
+            CanonicalExpressionFunction
+                (patternFromHoley
+                    [ Nothing
+                    , Just (Command "diamond")
+                    , Nothing
+                    ])
+                "diamond"
+                (Fixity NonAssoc level)
+        changedEntry =
+            CanonicalExpressionFunction
+                (patternFromHoley
+                    [ Nothing
+                    , Just (Command "diamond")
+                    , Nothing
+                    ])
+                "diamond"
+                (Fixity RightAssoc changedLevel)
+    delta <- expectRight (canonicalSyntaxDelta [entry])
+    changedDelta <- expectRight
+        (canonicalSyntaxDelta [changedEntry])
+    interface <- expectRight
+        (moduleSyntaxInterface [] delta)
+    changedInterface <- expectRight
+        (moduleSyntaxInterface [] changedDelta)
+    assertEqual
+        "current fixed base"
+        baseSyntaxInterfaceId
+        (moduleSyntaxBase interface)
+    assertEqual
+        "module syntax cache round trip"
+        (Right interface)
+        (decodeCache
+            getModuleSyntaxInterfaceCache
+            (encodeCache
+                (putModuleSyntaxInterfaceCache interface)))
+    assertEqual
+        "asserted ID is deterministic"
+        (Right (moduleSyntaxAssertedId interface))
+        (moduleSyntaxAssertedId
+            <$> moduleSyntaxInterface [] delta)
+    assertBool
+        "normalized fixity changes syntax identity"
+        (moduleSyntaxAssertedId interface
+            /= moduleSyntaxAssertedId changedInterface)
+    case moduleSyntaxInterface
+            [ moduleSyntaxAssertedId interface
+            , moduleSyntaxAssertedId interface
+            ]
+            delta of
+        Left (DuplicateDirectSyntaxInterface duplicate) ->
+            assertEqual
+                "duplicate direct interface"
+                (moduleSyntaxAssertedId interface)
+                duplicate
+        Left err ->
+            assertFailure
+                ("expected duplicate direct syntax input, got "
+                    <> show err)
+        Right _ ->
+            assertFailure
+                "accepted a duplicate direct syntax input"
+
+expectRight :: Show err => Either err value -> IO value
+expectRight = \case
+    Left err ->
+        assertFailure (show err)
+            >> fail "unreachable"
+    Right value ->
+        pure value
+
+expectedBaseRows :: [[(Marker, Associativity)]]
+expectedBaseRows =
+    [ []
+    , [ ("add", LeftAssoc)
+      , ("union", LeftAssoc)
+      , ("minus", LeftAssoc)
+      , ("rminus", LeftAssoc)
+      , ("monus", LeftAssoc)
+      ]
+    , [("relcomp", LeftAssoc)]
+    , [("circ", LeftAssoc)]
+    , [ ("mul", LeftAssoc)
+      , ("inter", LeftAssoc)
+      , ("rmul", LeftAssoc)
+      ]
+    , [("setminus", LeftAssoc)]
+    , [("times", RightAssoc)]
+    , []
+    , [ ("rfrac", NonAssoc)
+      , ("exp", NonAssoc)
+      , ("unions", NonAssoc)
+      , ("cumul", NonAssoc)
+      , ("fst", NonAssoc)
+      , ("snd", NonAssoc)
+      , ("pow", NonAssoc)
+      , ("neg", NonAssoc)
+      , ("inv", NonAssoc)
+      , ("abs", NonAssoc)
+      , ("cons", NonAssoc)
+      , ("pair", NonAssoc)
+      , ("upair", NonAssoc)
+      ]
+    , [ ("emptyset", NonAssoc)
+      , ("naturals", NonAssoc)
+      , ("naturalsPlus", NonAssoc)
+      , ("integers", NonAssoc)
+      , ("rationals", NonAssoc)
+      , ("reals", NonAssoc)
+      , ("unit", NonAssoc)
+      , ("zero", NonAssoc)
+      ]
+    ]