diff options
Diffstat (limited to 'source/Felix/Prelude.hs')
| -rw-r--r-- | source/Felix/Prelude.hs | 200 |
1 files changed, 180 insertions, 20 deletions
diff --git a/source/Felix/Prelude.hs b/source/Felix/Prelude.hs index d159b21..28ad961 100644 --- a/source/Felix/Prelude.hs +++ b/source/Felix/Prelude.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NoImplicitPrelude #-} --- | The reserved in-memory prelude source used during migration. +-- | The reserved packaged final-prelude source and its authority-free parser. module Felix.Prelude ( ReservedPreludeSourceInput , reservedPreludeSourceInput @@ -9,11 +9,15 @@ module Felix.Prelude , emptyBootstrapSourceInput , reservedPreludeSourceOwner , reservedPreludeSourceLabel + , reservedPreludeSourceCanonicalPath , reservedPreludeSourceBytes , reservedPreludeSourceText + , rejectOrdinaryPreludeSourceGraph , preludeDiagnosticLabel , PreludeLoadError(..) + , renderPreludeLoadError , PreludeParseError(..) + , renderPreludeParseError , ReservedParsedPrelude , reservedParsedPreludeInput , reservedParsedPreludeModule @@ -24,6 +28,8 @@ import Base import Felix.Module import Felix.Parse import Felix.Parsed.Identity qualified as Parsed +import Felix.Source +import Felix.Source.Graph import Report.Location import Syntax.Adapt (SyntaxMaterializationError) import Syntax.Interface @@ -41,6 +47,7 @@ import Paths_felix qualified as Paths data ReservedPreludeSourceInput = ReservedPreludeSourceInput !ModuleName !FilePath + !(Maybe CanonicalPath) !ByteString !Text @@ -51,38 +58,76 @@ reservedPreludeSourceInput bytes = ReservedPreludeSourceInput preludeModuleName preludeDiagnosticLabel + Nothing bytes <$> Text.decodeUtf8' bytes data PreludeLoadError = PreludeSourceReadFailed !FilePath !Text + | PreludeSourceCanonicalizationFailed !FilePath !SourceError | PreludeSourceUtf8Failed !UnicodeException - deriving stock (Show) + +instance Show PreludeLoadError where + show = Text.unpack . renderPreludeLoadError + +renderPreludeLoadError :: PreludeLoadError -> Text +renderPreludeLoadError = \case + PreludeSourceReadFailed path failure -> + Text.pack path + <> ": unable to read packaged final prelude: " + <> failure + PreludeSourceCanonicalizationFailed path failure -> + Text.pack path + <> ": unable to resolve packaged final prelude: " + <> renderSourceError failure + PreludeSourceUtf8Failed failure -> + preludeErrorPrefix + <> "malformed UTF-8: " + <> Text.pack (displayException failure) loadReservedPreludeSourceInput :: IO (Either PreludeLoadError ReservedPreludeSourceInput) loadReservedPreludeSourceInput = do path <- Paths.getDataFileName "data/felix-prelude.tex" - loaded <- try (ByteString.readFile path) - :: IO (Either IOException ByteString) - pure case loaded of + canonicalized <- canonicalizeExistingSourcePath path + case canonicalized of Left failure -> - Left - (PreludeSourceReadFailed - path - (Text.pack (displayException failure))) - Right bytes -> - case reservedPreludeSourceInput bytes of + pure + (Left + (PreludeSourceCanonicalizationFailed path failure)) + Right canonical -> do + loaded <- try + (ByteString.readFile + (canonicalPathFilePath canonical)) + :: IO (Either IOException ByteString) + pure case loaded of Left failure -> - Left (PreludeSourceUtf8Failed failure) - Right input -> - Right input + Left + (PreludeSourceReadFailed + path + (Text.pack (displayException failure))) + Right bytes -> + case Text.decodeUtf8' bytes of + Left failure -> + Left (PreludeSourceUtf8Failed failure) + Right sourceText -> + Right + (ReservedPreludeSourceInput + preludeModuleName + preludeDiagnosticLabel + (Just canonical) + bytes + sourceText) +-- | Empty final-prelude input used only by focused compiler fixtures. +-- +-- Production verification always calls 'loadReservedPreludeSourceInput'. emptyBootstrapSourceInput :: ReservedPreludeSourceInput emptyBootstrapSourceInput = ReservedPreludeSourceInput preludeModuleName preludeDiagnosticLabel + Nothing ByteString.empty Text.empty @@ -90,28 +135,58 @@ reservedPreludeSourceOwner :: ReservedPreludeSourceInput -> ModuleName reservedPreludeSourceOwner - (ReservedPreludeSourceInput owner _label _bytes _text) = + (ReservedPreludeSourceInput owner _label _canonical _bytes _text) = owner reservedPreludeSourceLabel :: ReservedPreludeSourceInput -> FilePath reservedPreludeSourceLabel - (ReservedPreludeSourceInput _owner label _bytes _text) = + (ReservedPreludeSourceInput _owner label _canonical _bytes _text) = label +reservedPreludeSourceCanonicalPath + :: ReservedPreludeSourceInput + -> Maybe CanonicalPath +reservedPreludeSourceCanonicalPath + (ReservedPreludeSourceInput _owner _label canonical _bytes _text) = + canonical + reservedPreludeSourceBytes :: ReservedPreludeSourceInput -> ByteString reservedPreludeSourceBytes - (ReservedPreludeSourceInput _owner _label bytes _text) = + (ReservedPreludeSourceInput _owner _label _canonical bytes _text) = bytes reservedPreludeSourceText :: ReservedPreludeSourceInput -> Text reservedPreludeSourceText - (ReservedPreludeSourceInput _owner _label _bytes sourceText) = + (ReservedPreludeSourceInput + _owner _label _canonical _bytes sourceText) = sourceText +-- | Reject an ordinary source graph containing the physical packaged +-- prelude. Synthetic reserved inputs deliberately have no physical path. +rejectOrdinaryPreludeSourceGraph + :: ReservedPreludeSourceInput + -> ResolvedSourceGraph + -> Either SourceError () +rejectOrdinaryPreludeSourceGraph sourceInput graph = + case reservedPreludeSourceCanonicalPath sourceInput of + Nothing -> + Right () + Just reservedPath -> + case listToMaybe + [ source + | node <- sourceGraphNodes graph + , let source = sourceNodeResolved node + , resolvedSourceCanonicalPath source == reservedPath + ] of + Nothing -> + Right () + Just source -> + Left (PackagedPreludeSelectedAsOrdinarySource source) + preludeDiagnosticLabel :: FilePath preludeDiagnosticLabel = "<felix-prelude>" @@ -130,7 +205,92 @@ data PreludeParseError | PreludeFreshInputFailed !FreshModuleInputError | PreludeParsedModuleKeyFailed !Parsed.ParsedModuleKeyError | PreludeParseInvariantFailed !Text - deriving stock (Show) + +instance Show PreludeParseError where + show = Text.unpack . renderPreludeParseError + +renderPreludeParseError :: PreludeParseError -> Text +renderPreludeParseError = \case + PreludeLocationRegistrationFailed FileIdSpaceExhausted -> + preludeErrorPrefix + <> "could not register source locations: file identifier space exhausted" + PreludeSyntaxPragmaFailed failure -> + renderSyntaxPragmaError failure + PreludeImportNotSupported imports -> + preludeErrorPrefix + <> "imports are not supported" + <> case imports of + [] -> "" + _ -> + ": " + <> Text.intercalate + ", " + (Text.pack . show <$> imports) + PreludeLexicalScanFailed failure -> + Text.pack (show failure) + PreludeSyntaxDeclarationFailed failure -> + Text.pack (show failure) + PreludeLexiconCollision collision -> + Text.pack (show collision) + PreludeSyntaxDeltaFailed collision -> + preludeErrorPrefix + <> "syntax delta has conflicting entries for pattern " + <> Text.pack (show (canonicalCollisionPattern collision)) + <> ": " + <> Text.pack + (show (toList (canonicalCollisionEntries collision))) + PreludeSyntaxInterfaceFailed failure -> + preludeErrorPrefix <> renderSyntaxInterfaceError failure + PreludeSyntaxMaterializationFailed failure -> + preludeErrorPrefix <> renderSyntaxMaterializationError failure + PreludeParseFailed failure -> + preludeErrorPrefix <> Text.pack (show failure) + PreludeFreshInputFailed failure -> + preludeErrorPrefix <> renderFreshModuleInputError failure + PreludeParsedModuleKeyFailed failure -> + preludeErrorPrefix <> renderParsedModuleKeyError failure + PreludeParseInvariantFailed failure -> + preludeErrorPrefix <> "parse invariant failed: " <> failure + +preludeErrorPrefix :: Text +preludeErrorPrefix = + Text.pack preludeDiagnosticLabel <> ": " + +renderSyntaxInterfaceError :: SyntaxInterfaceError -> Text +renderSyntaxInterfaceError = \case + DuplicateDirectSyntaxInterface duplicate -> + "duplicate direct syntax input " <> Text.pack (show duplicate) + UnexpectedBaseSyntaxInterface actual expected -> + "base syntax interface mismatch: expected " + <> Text.pack (show expected) + <> ", got " + <> Text.pack (show actual) + SyntaxInterfaceIdMismatch asserted computed -> + "syntax interface identity mismatch: asserted " + <> Text.pack (show asserted) + <> ", computed " + <> Text.pack (show computed) + +renderFreshModuleInputError :: FreshModuleInputError -> Text +renderFreshModuleInputError = \case + FreshModuleTextDoesNotMatchBytes -> + "decoded source text does not match its source bytes" + FreshPhysicalOwnerMismatch expected actual -> + "physical source owner mismatch: expected " + <> Text.pack (show expected) + <> ", got " + <> Text.pack (show actual) + FreshPhysicalLocationPathMismatch expected actual -> + "physical source location mismatch: expected " + <> Text.pack (show expected) + <> ", got " + <> Text.pack (show actual) + +renderParsedModuleKeyError :: Parsed.ParsedModuleKeyError -> Text +renderParsedModuleKeyError = \case + Parsed.DuplicateParsedDirectSyntaxInput duplicate -> + "parsed module has duplicate direct syntax input " + <> Text.pack (show duplicate) data ReservedParsedPrelude = ReservedParsedPrelude !FreshModuleInput @@ -148,7 +308,7 @@ reservedParsedPreludeModule reservedParsedPreludeModule (ReservedParsedPrelude _input parsed) = parsed --- | Parse a reserved migration input through the ordinary fresh-source path. +-- | Parse reserved final-prelude input through the ordinary fresh-source path. parseReservedPreludeSource :: ReservedPreludeSourceInput -> IO (Either PreludeParseError ReservedParsedPrelude) |