diff options
Diffstat (limited to 'source/Test/Unit/Lexicon.hs')
| -rw-r--r-- | source/Test/Unit/Lexicon.hs | 333 |
1 files changed, 0 insertions, 333 deletions
diff --git a/source/Test/Unit/Lexicon.hs b/source/Test/Unit/Lexicon.hs deleted file mode 100644 index 54b4bd4..0000000 --- a/source/Test/Unit/Lexicon.hs +++ /dev/null @@ -1,333 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Test.Unit.Lexicon (unitTests) where - -import Base -import Felix.Cache.Codec -import Syntax.Abstract -import Syntax.Interface -import 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) - ] - ] |