{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NoImplicitPrelude #-} module Felix.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 Felix.Syntax.Abstract import Felix.Syntax.Lexicon import Felix.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)