path: root/source/Syntax/Interface.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Syntax.Interface
    ( MixfixLevel
    , mixfixLevel
    , mixfixLevelValue
    , MixfixLevelError(..)
    , Fixity(..)
    , sourcePragmaFixity
    , CanonicalLexicalEntry(..)
    , canonicalLexicalSurfacePatterns
    , eligibleExpressionPattern
    , CanonicalSyntaxDelta
    , canonicalSyntaxDelta
    , canonicalSyntaxDeltaEntries
    , canonicalSyntaxDeltaSize
    , CanonicalSyntaxCollision
    , canonicalCollisionPattern
    , canonicalCollisionEntries
    , CanonicalSyntaxDeltaId
    , canonicalSyntaxDeltaId
    , canonicalSyntaxDeltaIdDigest
    , BaseSyntaxInterfaceId
    , baseSyntaxInterfaceId
    , baseSyntaxInterfaceIdDigest
    , baseSyntaxManifest
    , fixedBaseSyntaxEntries
    , SyntaxInterfaceId
    , syntaxInterfaceIdDigest
    , ModuleSyntaxInterface
    , moduleSyntaxInterface
    , moduleSyntaxBase
    , moduleSyntaxDirectInputs
    , moduleSyntaxLocalDelta
    , moduleSyntaxAssertedId
    , SyntaxInterfaceError(..)
    , validateModuleSyntaxInterface
    , putCanonicalLexicalEntryCache
    , getCanonicalLexicalEntryCache
    , putPatternCache
    , getPatternCache
    , putTokenCache
    , getTokenCache
    , putCanonicalSyntaxDeltaCache
    , getCanonicalSyntaxDeltaCache
    , putModuleSyntaxInterfaceCache
    , getModuleSyntaxInterfaceCache
    , putBaseSyntaxInterfaceIdCache
    , getBaseSyntaxInterfaceIdCache
    , putSyntaxInterfaceIdCache
    , getSyntaxInterfaceIdCache
    ) where

import Base

import Felix.Cache.Codec
import Syntax.Abstract
import Syntax.Lexicon
import Syntax.Pragma

import Control.DeepSeq (NFData)
import Control.Monad (unless)
import Data.List qualified as List
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Word (Word8)
import Numeric.Natural (Natural)


newtype MixfixLevel = MixfixLevel Word8
    deriving stock (Show, Eq, Ord, Generic)
    deriving newtype (Hashable, NFData)

data MixfixLevelError
    = MixfixLevelOutOfRange !Word8
    deriving stock (Show, Eq)

mixfixLevel :: Word8 -> Either MixfixLevelError MixfixLevel
mixfixLevel supplied
    | supplied <= 9 =
        Right (MixfixLevel supplied)
    | otherwise =
        Left (MixfixLevelOutOfRange supplied)

mixfixLevelValue :: MixfixLevel -> Word8
mixfixLevelValue (MixfixLevel level) =
    level

data Fixity = Fixity
    { fixityAssociativity :: !Associativity
    , fixityLevel :: !MixfixLevel
    } deriving stock (Show, Eq, Ord, Generic)
      deriving anyclass (NFData)

sourcePragmaFixity :: SyntaxPragma -> Fixity
sourcePragmaFixity pragma =
    Fixity
        (syntaxPragmaAssociativity pragma)
        (MixfixLevel
            (sourceMixfixLevelValue
                (syntaxPragmaLevel pragma)))

-- | Complete origin-free lexical semantics produced by scanning.
data CanonicalLexicalEntry
    = CanonicalLeftAdjective !Pattern !Marker
    | CanonicalRightAdjective !Pattern !Marker
    | CanonicalFunctionPhrase !Pattern !Pattern !Marker
    | CanonicalNoun !Pattern !Pattern !Marker
    | CanonicalStructureNoun !Pattern !Pattern !Marker
    | CanonicalVerb !Pattern !Pattern !Marker
    | CanonicalRelation !Token !ParameterArity !Marker
    | CanonicalExpressionFunction !Pattern !Marker !Fixity
    | CanonicalPrefixPredicate !Text !Natural !Marker
    | CanonicalStructureOperation !Text
    deriving stock (Show, Eq, Ord, Generic)
    deriving anyclass (NFData)

-- | Every surface pattern through which the concrete parser can select an
-- entry. Equal singular and plural surfaces are returned only once.
canonicalLexicalSurfacePatterns
    :: CanonicalLexicalEntry
    -> NonEmpty Pattern
canonicalLexicalSurfacePatterns =
    deduplicatePatterns . \case
    CanonicalLeftAdjective pat _marker ->
        [pat]
    CanonicalRightAdjective pat _marker ->
        [pat]
    CanonicalFunctionPhrase singular _plural _marker ->
        [singular]
    CanonicalNoun singular plural _marker ->
        [singular, plural]
    CanonicalStructureNoun singular _plural _marker ->
        [singular]
    CanonicalVerb singular plural _marker ->
        [singular, plural]
    CanonicalRelation token arity marker ->
        [ relationSymbolPattern
            (RelationSymbol token arity marker)
        ]
    CanonicalExpressionFunction pat _marker _fixity ->
        [pat]
    CanonicalPrefixPredicate command _arity _marker ->
        [ prefixPredicatePattern
            (PrefixPredicate command 0)
        ]
    CanonicalStructureOperation command ->
        [structSymbolPattern (StructSymbol command)]
  where
    deduplicatePatterns patterns =
        case NonEmpty.nonEmpty
                (Set.toList (Set.fromList patterns)) of
            Just nonempty ->
                nonempty
            Nothing ->
                impossible
                    "canonical lexical entry has no parser surface"

eligibleExpressionPattern :: Pattern -> Bool
eligibleExpressionPattern pat =
    case patternToHoley pat of
        Nothing : rest ->
            case reverse rest of
                Nothing : middleReversed ->
                    let middle =
                            reverse middleReversed
                    in
                        countHoles middle == 0
                            && any isJust middle
                _ ->
                    False
        _ ->
            False
  where
    countHoles =
        length . List.filter isNothing

newtype CanonicalSyntaxDelta =
    CanonicalSyntaxDelta
        [CanonicalLexicalEntry]
    deriving stock (Show, Eq, Generic)
    deriving anyclass (NFData)

data CanonicalSyntaxCollision = CanonicalSyntaxCollision
    { canonicalCollisionPattern :: !Pattern
    , canonicalCollisionEntries
        :: !(NonEmpty CanonicalLexicalEntry)
    } deriving stock (Show, Eq)

canonicalSyntaxDelta
    :: [CanonicalLexicalEntry]
    -> Either CanonicalSyntaxCollision CanonicalSyntaxDelta
canonicalSyntaxDelta supplied =
    case orderedCollisions of
        [] ->
            Right (CanonicalSyntaxDelta orderedEntries)
        (_encodedPattern, pat, entries) : _ ->
            Left
                (CanonicalSyntaxCollision
                    pat
                    (case NonEmpty.nonEmpty
                        (canonicalEntryOrder
                            (Set.toList entries)) of
                        Just collisionEntries ->
                            collisionEntries
                        Nothing ->
                            impossible
                                "canonical syntax collision has no entries"))
  where
    orderedEntries =
        canonicalEntryOrder
            (Set.toList (Set.fromList supplied))

    grouped =
        foldl'
            (\entries entry ->
                foldl'
                    (\indexed pat ->
                        Map.insertWith
                            Set.union
                            pat
                            (Set.singleton entry)
                            indexed)
                    entries
                    (canonicalLexicalSurfacePatterns entry))
            mempty
            orderedEntries

    orderedCollisions =
        List.sortOn
            (\(encodedPattern, _pattern, _entries) ->
                encodedPattern)
            [ ( encodeCache (putPatternCache pat)
              , pat
              , entries
              )
            | (pat, entries) <- Map.toList grouped
            , Set.size entries > 1
            ]

canonicalSyntaxDeltaEntries
    :: CanonicalSyntaxDelta
    -> [CanonicalLexicalEntry]
canonicalSyntaxDeltaEntries
        (CanonicalSyntaxDelta entries) =
    entries

canonicalSyntaxDeltaSize :: CanonicalSyntaxDelta -> Int
canonicalSyntaxDeltaSize
        (CanonicalSyntaxDelta entries) =
    length entries

canonicalEntryOrder
    :: [CanonicalLexicalEntry]
    -> [CanonicalLexicalEntry]
canonicalEntryOrder =
    List.sortOn
        (encodeCache . putCanonicalLexicalEntryCache)

newtype CanonicalSyntaxDeltaId =
    CanonicalSyntaxDeltaId CacheDigest
    deriving stock (Show, Eq, Ord, Generic)
    deriving newtype (Hashable, NFData)

canonicalSyntaxDeltaId
    :: CanonicalSyntaxDelta
    -> CanonicalSyntaxDeltaId
canonicalSyntaxDeltaId delta =
    CanonicalSyntaxDeltaId
        (hashCacheFields
            "felix-syntax-delta-v1"
            [encodeCache
                (putCanonicalSyntaxDeltaCache delta)])

canonicalSyntaxDeltaIdDigest
    :: CanonicalSyntaxDeltaId
    -> CacheDigest
canonicalSyntaxDeltaIdDigest
        (CanonicalSyntaxDeltaId digest) =
    digest

newtype BaseSyntaxInterfaceId =
    BaseSyntaxInterfaceId CacheDigest
    deriving stock (Show, Eq, Ord, Generic)
    deriving newtype (Hashable, NFData)

baseSyntaxInterfaceId :: BaseSyntaxInterfaceId
baseSyntaxInterfaceId =
    BaseSyntaxInterfaceId
        (hashCacheFields
            "felix-base-syntax-interface-v1"
            [encodeCache
                (putCacheList
                    putManifestRow
                    baseSyntaxManifest)])
  where
    putManifestRow =
        putCacheList putCanonicalLexicalEntryCache
            . canonicalEntryOrder

baseSyntaxInterfaceIdDigest
    :: BaseSyntaxInterfaceId
    -> CacheDigest
baseSyntaxInterfaceIdDigest
        (BaseSyntaxInterfaceId digest) =
    digest

baseSyntaxManifest :: [[CanonicalLexicalEntry]]
baseSyntaxManifest =
    case traverse makeRow
            (zip [0 :: Word8 ..] builtinMixfixLevels) of
        Right rows
            | length rows == 10 ->
                rows
        _ ->
            impossible
                "the fixed mixfix manifest does not have ten valid rows"
  where
    makeRow (row, entries) = do
        level <- mixfixLevel row
        pure
            [ CanonicalExpressionFunction
                pat
                marker
                (Fixity associativity level)
            | MixfixItem pat marker associativity <-
                entries
            ]

-- | Every fixed lexical entry consulted by the concrete parser. The base
-- syntax identity above commits to the ten expression rows; the remaining
-- fixed categories are compiler input covered by the cache epoch.
fixedBaseSyntaxEntries :: [CanonicalLexicalEntry]
fixedBaseSyntaxEntries =
    case canonicalSyntaxDelta rawEntries of
        Right delta ->
            canonicalSyntaxDeltaEntries delta
        Left collision ->
            impossible
                ("fixed base syntax contains a collision: "
                    <> show collision)
  where
    rawEntries =
        concat baseSyntaxManifest
            <> (canonicalAdjective CanonicalLeftAdjective
                    <$> lexiconAdjLs builtins)
            <> (canonicalAdjective CanonicalRightAdjective
                    <$> lexiconAdjRs builtins)
            <> (canonicalSgPl CanonicalFunctionPhrase
                    <$> lexiconFuns builtins)
            <> (canonicalSgPl CanonicalNoun
                    <$> lexiconNouns builtins)
            <> (canonicalSgPl CanonicalStructureNoun
                    <$> lexiconStructNouns builtins)
            <> (canonicalSgPl CanonicalVerb
                    <$> lexiconVerbs builtins)
            <> (canonicalRelation
                    <$> lexiconRelationSymbols builtins)
            <> (canonicalPrefix
                    <$> lexiconPrefixPredicates builtins)
            <> (canonicalStructure
                    <$> lexiconStructFun builtins)

    canonicalAdjective constructor item =
        constructor
            (lexicalItemPattern item)
            (lexicalItemMarker item)

    canonicalSgPl constructor item =
        let patterns =
                lexicalItemSgPlPattern item
        in
            constructor
                (sg patterns)
                (pl patterns)
                (lexicalItemSgPlMarker item)

    canonicalRelation relation =
        CanonicalRelation
            (relationSymbolToken relation)
            (relationSymbolParameterArity relation)
            (relationSymbolMarker relation)

    canonicalPrefix
            (PrefixPredicate command arity, marker) =
        CanonicalPrefixPredicate
            command
            (fromIntegral arity)
            marker

    canonicalStructure (StructSymbol command) =
        CanonicalStructureOperation command

newtype SyntaxInterfaceId =
    SyntaxInterfaceId CacheDigest
    deriving stock (Show, Eq, Ord, Generic)
    deriving newtype (Hashable, NFData)

syntaxInterfaceIdDigest :: SyntaxInterfaceId -> CacheDigest
syntaxInterfaceIdDigest (SyntaxInterfaceId digest) =
    digest

data ModuleSyntaxInterface = ModuleSyntaxInterface
    !BaseSyntaxInterfaceId
    ![SyntaxInterfaceId]
    !CanonicalSyntaxDelta
    !SyntaxInterfaceId
    deriving stock (Show, Eq, Generic)
    deriving anyclass (NFData)

moduleSyntaxBase
    :: ModuleSyntaxInterface
    -> BaseSyntaxInterfaceId
moduleSyntaxBase
        (ModuleSyntaxInterface base _direct _delta _asserted) =
    base

moduleSyntaxDirectInputs
    :: ModuleSyntaxInterface
    -> [SyntaxInterfaceId]
moduleSyntaxDirectInputs
        (ModuleSyntaxInterface _base direct _delta _asserted) =
    direct

moduleSyntaxLocalDelta
    :: ModuleSyntaxInterface
    -> CanonicalSyntaxDelta
moduleSyntaxLocalDelta
        (ModuleSyntaxInterface _base _direct delta _asserted) =
    delta

moduleSyntaxAssertedId
    :: ModuleSyntaxInterface
    -> SyntaxInterfaceId
moduleSyntaxAssertedId
        (ModuleSyntaxInterface _base _direct _delta asserted) =
    asserted

data SyntaxInterfaceError
    = DuplicateDirectSyntaxInterface !SyntaxInterfaceId
    | UnexpectedBaseSyntaxInterface
        !BaseSyntaxInterfaceId
        !BaseSyntaxInterfaceId
    | SyntaxInterfaceIdMismatch
        !SyntaxInterfaceId
        !SyntaxInterfaceId
    deriving stock (Show, Eq)

moduleSyntaxInterface
    :: [SyntaxInterfaceId]
    -> CanonicalSyntaxDelta
    -> Either SyntaxInterfaceError ModuleSyntaxInterface
moduleSyntaxInterface direct delta =
    validateModuleSyntaxInterface
        baseSyntaxInterfaceId
        direct
        delta
        (computeSyntaxInterfaceId
            baseSyntaxInterfaceId
            direct
            delta)

validateModuleSyntaxInterface
    :: BaseSyntaxInterfaceId
    -> [SyntaxInterfaceId]
    -> CanonicalSyntaxDelta
    -> SyntaxInterfaceId
    -> Either SyntaxInterfaceError ModuleSyntaxInterface
validateModuleSyntaxInterface base direct delta asserted = do
    unless
        (base == baseSyntaxInterfaceId)
        (Left
            (UnexpectedBaseSyntaxInterface
                base
                baseSyntaxInterfaceId))
    case firstDuplicate direct of
        Just duplicate ->
            Left
                (DuplicateDirectSyntaxInterface duplicate)
        Nothing ->
            pure ()
    let computed =
            computeSyntaxInterfaceId base direct delta
    unless
        (asserted == computed)
        (Left
            (SyntaxInterfaceIdMismatch
                asserted
                computed))
    Right
        (ModuleSyntaxInterface
            base
            direct
            delta
            asserted)

computeSyntaxInterfaceId
    :: BaseSyntaxInterfaceId
    -> [SyntaxInterfaceId]
    -> CanonicalSyntaxDelta
    -> SyntaxInterfaceId
computeSyntaxInterfaceId base direct delta =
    SyntaxInterfaceId
        (hashCacheFields
            "felix-syntax-interface-v1"
            [ cacheDigestBytes
                (baseSyntaxInterfaceIdDigest base)
            , encodeCache
                (putCacheList
                    putSyntaxInterfaceIdCache
                    direct)
            , cacheDigestBytes
                (canonicalSyntaxDeltaIdDigest
                    (canonicalSyntaxDeltaId delta))
            ])

firstDuplicate :: Ord value => [value] -> Maybe value
firstDuplicate =
    go mempty
  where
    go _seen [] =
        Nothing
    go seen (value : rest)
        | value `Set.member` seen =
            Just value
        | otherwise =
            go (Set.insert value seen) rest

putCanonicalLexicalEntryCache
    :: CanonicalLexicalEntry
    -> CachePut
putCanonicalLexicalEntryCache = \case
    CanonicalLeftAdjective pat marker -> do
        putCacheTag 0x00
        putPatternCache pat
        putMarkerCache marker
    CanonicalRightAdjective pat marker -> do
        putCacheTag 0x01
        putPatternCache pat
        putMarkerCache marker
    CanonicalFunctionPhrase singular plural marker -> do
        putCacheTag 0x02
        putPatternCache singular
        putPatternCache plural
        putMarkerCache marker
    CanonicalNoun singular plural marker -> do
        putCacheTag 0x03
        putPatternCache singular
        putPatternCache plural
        putMarkerCache marker
    CanonicalStructureNoun singular plural marker -> do
        putCacheTag 0x04
        putPatternCache singular
        putPatternCache plural
        putMarkerCache marker
    CanonicalVerb singular plural marker -> do
        putCacheTag 0x05
        putPatternCache singular
        putPatternCache plural
        putMarkerCache marker
    CanonicalRelation token arity marker -> do
        putCacheTag 0x06
        putTokenCache token
        putCacheNatural (parameterArityValue arity)
        putMarkerCache marker
    CanonicalExpressionFunction pat marker fixity -> do
        putCacheTag 0x07
        putPatternCache pat
        putMarkerCache marker
        putFixityCache fixity
    CanonicalPrefixPredicate command arity marker -> do
        putCacheTag 0x08
        putCacheText command
        putCacheNatural arity
        putMarkerCache marker
    CanonicalStructureOperation command -> do
        putCacheTag 0x09
        putCacheText command

getCanonicalLexicalEntryCache
    :: CacheGet CanonicalLexicalEntry
getCanonicalLexicalEntryCache =
    getCacheTag >>= \case
        0x00 ->
            CanonicalLeftAdjective
                <$> getPatternCache
                <*> getMarkerCache
        0x01 ->
            CanonicalRightAdjective
                <$> getPatternCache
                <*> getMarkerCache
        0x02 ->
            CanonicalFunctionPhrase
                <$> getPatternCache
                <*> getPatternCache
                <*> getMarkerCache
        0x03 ->
            CanonicalNoun
                <$> getPatternCache
                <*> getPatternCache
                <*> getMarkerCache
        0x04 ->
            CanonicalStructureNoun
                <$> getPatternCache
                <*> getPatternCache
                <*> getMarkerCache
        0x05 ->
            CanonicalVerb
                <$> getPatternCache
                <*> getPatternCache
                <*> getMarkerCache
        0x06 ->
            CanonicalRelation
                <$> getTokenCache
                <*> (ParameterArity <$> getCacheNatural)
                <*> getMarkerCache
        0x07 ->
            CanonicalExpressionFunction
                <$> getPatternCache
                <*> getMarkerCache
                <*> getFixityCache
        0x08 ->
            CanonicalPrefixPredicate
                <$> getCacheText
                <*> getCacheNatural
                <*> getMarkerCache
        0x09 ->
            CanonicalStructureOperation
                <$> getCacheText
        tag ->
            fail
                ("unknown canonical lexical entry tag "
                    <> show tag)

putCanonicalSyntaxDeltaCache
    :: CanonicalSyntaxDelta
    -> CachePut
putCanonicalSyntaxDeltaCache
        (CanonicalSyntaxDelta entries) =
    putCacheList putCanonicalLexicalEntryCache entries

getCanonicalSyntaxDeltaCache
    :: CacheGet CanonicalSyntaxDelta
getCanonicalSyntaxDeltaCache = do
    supplied <- getCacheList getCanonicalLexicalEntryCache
    case canonicalSyntaxDelta supplied of
        Left collision ->
            fail
                ("colliding cached canonical syntax entries: "
                    <> show collision)
        Right delta
            | canonicalSyntaxDeltaEntries delta == supplied ->
                pure delta
            | otherwise ->
                fail
                    "cached canonical syntax entries are not in canonical order"

putModuleSyntaxInterfaceCache
    :: ModuleSyntaxInterface
    -> CachePut
putModuleSyntaxInterfaceCache
        (ModuleSyntaxInterface base direct delta asserted) = do
    putBaseSyntaxInterfaceIdCache base
    putCacheList putSyntaxInterfaceIdCache direct
    putCanonicalSyntaxDeltaCache delta
    putSyntaxInterfaceIdCache asserted

getModuleSyntaxInterfaceCache
    :: CacheGet ModuleSyntaxInterface
getModuleSyntaxInterfaceCache = do
    base <- getBaseSyntaxInterfaceIdCache
    direct <- getCacheList getSyntaxInterfaceIdCache
    delta <- getCanonicalSyntaxDeltaCache
    asserted <- getSyntaxInterfaceIdCache
    case
        validateModuleSyntaxInterface
            base
            direct
            delta
            asserted of
        Left err ->
            fail
                ("invalid module syntax interface: "
                    <> show err)
        Right interface ->
            pure interface

putBaseSyntaxInterfaceIdCache
    :: BaseSyntaxInterfaceId
    -> CachePut
putBaseSyntaxInterfaceIdCache
        (BaseSyntaxInterfaceId digest) =
    putCacheDigest digest

getBaseSyntaxInterfaceIdCache
    :: CacheGet BaseSyntaxInterfaceId
getBaseSyntaxInterfaceIdCache =
    BaseSyntaxInterfaceId <$> getCacheDigest

putSyntaxInterfaceIdCache
    :: SyntaxInterfaceId
    -> CachePut
putSyntaxInterfaceIdCache
        (SyntaxInterfaceId digest) =
    putCacheDigest digest

getSyntaxInterfaceIdCache
    :: CacheGet SyntaxInterfaceId
getSyntaxInterfaceIdCache =
    SyntaxInterfaceId <$> getCacheDigest

putFixityCache :: Fixity -> CachePut
putFixityCache (Fixity associativity level) = do
    putAssociativityCache associativity
    putCacheTag (mixfixLevelValue level)

getFixityCache :: CacheGet Fixity
getFixityCache = do
    associativity <- getAssociativityCache
    suppliedLevel <- getCacheTag
    case mixfixLevel suppliedLevel of
        Left err ->
            fail ("invalid cached mixfix level: " <> show err)
        Right level ->
            pure (Fixity associativity level)

putAssociativityCache :: Associativity -> CachePut
putAssociativityCache =
    putCacheTag . \case
        LeftAssoc ->
            0x00
        RightAssoc ->
            0x01
        NonAssoc ->
            0x02

getAssociativityCache :: CacheGet Associativity
getAssociativityCache =
    getCacheTag >>= \case
        0x00 ->
            pure LeftAssoc
        0x01 ->
            pure RightAssoc
        0x02 ->
            pure NonAssoc
        tag ->
            fail
                ("unknown associativity tag " <> show tag)

putMarkerCache :: Marker -> CachePut
putMarkerCache (Marker marker) =
    putCacheText marker

getMarkerCache :: CacheGet Marker
getMarkerCache =
    Marker <$> getCacheText

putPatternCache :: Pattern -> CachePut
putPatternCache = \case
    End ->
        putCacheTag 0x00
    HoleCons rest -> do
        putCacheTag 0x01
        putPatternCache rest
    TokenCons token rest -> do
        putCacheTag 0x02
        putTokenCache token
        putPatternCache rest

getPatternCache :: CacheGet Pattern
getPatternCache =
    getCacheTag >>= \case
        0x00 ->
            pure End
        0x01 ->
            HoleCons <$> getPatternCache
        0x02 ->
            TokenCons
                <$> getTokenCache
                <*> getPatternCache
        tag ->
            fail
                ("unknown lexical pattern tag " <> show tag)

putTokenCache :: Token -> CachePut
putTokenCache = \case
    Word text -> do
        putCacheTag 0x00
        putCacheText text
    Variable text -> do
        putCacheTag 0x01
        putCacheText text
    Symbol text -> do
        putCacheTag 0x02
        putCacheText text
    Integer integer -> do
        putCacheTag 0x03
        putCacheInteger (toInteger integer)
    Command text -> do
        putCacheTag 0x04
        putCacheText text
    Label text -> do
        putCacheTag 0x05
        putCacheText text
    Ref references -> do
        putCacheTag 0x06
        putCacheList putCacheText (toList references)
    BeginEnv text -> do
        putCacheTag 0x07
        putCacheText text
    EndEnv text -> do
        putCacheTag 0x08
        putCacheText text
    ParenL ->
        putCacheTag 0x09
    ParenR ->
        putCacheTag 0x0a
    BracketL ->
        putCacheTag 0x0b
    BracketR ->
        putCacheTag 0x0c
    VisibleBraceL ->
        putCacheTag 0x0d
    VisibleBraceR ->
        putCacheTag 0x0e
    InvisibleBraceL ->
        putCacheTag 0x0f
    InvisibleBraceR ->
        putCacheTag 0x10

getTokenCache :: CacheGet Token
getTokenCache =
    getCacheTag >>= \case
        0x00 ->
            Word <$> getCacheText
        0x01 ->
            Variable <$> getCacheText
        0x02 ->
            Symbol <$> getCacheText
        0x03 ->
            Integer <$> getCacheInt
        0x04 ->
            Command <$> getCacheText
        0x05 ->
            Label <$> getCacheText
        0x06 -> do
            references <- getCacheList getCacheText
            case NonEmpty.nonEmpty references of
                Nothing ->
                    fail "cached reference token has no marker"
                Just nonempty ->
                    pure (Ref nonempty)
        0x07 ->
            BeginEnv <$> getCacheText
        0x08 ->
            EndEnv <$> getCacheText
        0x09 ->
            pure ParenL
        0x0a ->
            pure ParenR
        0x0b ->
            pure BracketL
        0x0c ->
            pure BracketR
        0x0d ->
            pure VisibleBraceL
        0x0e ->
            pure VisibleBraceR
        0x0f ->
            pure InvisibleBraceL
        0x10 ->
            pure InvisibleBraceR
        tag ->
            fail ("unknown lexical token tag " <> show tag)

getCacheInt :: CacheGet Int
getCacheInt = do
    integer <- getCacheInteger
    if integer < toInteger (minBound :: Int)
        || integer > toInteger (maxBound :: Int)
        then
            fail "cached integer token exceeds Int"
        else
            pure (fromInteger integer)