diff options
Diffstat (limited to 'source/Syntax/Interface.hs')
| -rw-r--r-- | source/Syntax/Interface.hs | 887 |
1 files changed, 0 insertions, 887 deletions
diff --git a/source/Syntax/Interface.hs b/source/Syntax/Interface.hs deleted file mode 100644 index 4b84cec..0000000 --- a/source/Syntax/Interface.hs +++ /dev/null @@ -1,887 +0,0 @@ -{-# 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) |