{-# 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)
      ]
    ]