Establish canonical syntax interfaces

1 files changed, 208 insertions, 4 deletions

diff --git a/source/Test/Unit/Lexicon.hs b/source/Test/Unit/Lexicon.hs
index 445561e..3309e6a 100644
--- a/source/Test/Unit/Lexicon.hs
+++ b/source/Test/Unit/Lexicon.hs
@@ -3,7 +3,9 @@
 module Test.Unit.Lexicon (unitTests) where
 
 import Base
+import Felix.Cache.Codec
 import Syntax.Abstract
+import Syntax.Interface
 import Syntax.Lexicon
 
 import Test.Tasty
@@ -15,18 +17,220 @@ 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 "round-trips complete canonical lexical entries"
+            roundTripsCanonicalEntries
+        , testCase "round-trips asserted module syntax interfaces"
+            roundTripsSyntaxInterfaces
         ]
 
 retainsBaseMixfixGrouping :: Assertion
 retainsBaseMixfixGrouping =
-    assertEqual
-        "least-to-most-tight marker and associativity rows"
-        expectedBaseRows
-        (fmap (fmap entryShape) builtinMixfixLevels)
+    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"
+            "96d03072c3d395185ef9dee2f783f49afecdb177bb68930e302f4611e97397b1"
+            (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])
+
+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
+                (canonicalLexicalPattern entry)
+                "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 =
     [ []