1 files changed, 242 insertions, 0 deletions
diff --git a/source/Felix/Workspace.hs b/source/Felix/Workspace.hs
new file mode 100644
index 0000000..b9034c5
--- /dev/null
+++ b/source/Felix/Workspace.hs
@@ -0,0 +1,242 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- | Stable source-mount policy and authority-free workspace preparation.
+module Felix.Workspace
+    ( WorkspaceEnvironment
+    , prepareDefaultWorkspaceEnvironment
+    , workspaceSourceMounts
+    , workspaceHtmlMountPrefixes
+    , workspaceRendererSearchRoots
+    , prepareWorkspaceRoot
+    , prepareSourceGraph
+    , prepareDefaultSourceGraph
+    , AuthorityFreeParseError(..)
+    , renderAuthorityFreeParseError
+    , parseWorkspace
+    , parse
+    , tokenize
+    , scan
+    , simpleStream
+    , TokStream
+    , ParseException(..)
+    , builtins
+    ) where
+
+import Base
+import Felix.Parse (ParseException(..), ParseWorkspaceError(..))
+import Felix.Parse qualified as Parse
+import Felix.Prelude qualified as Prelude
+import Felix.Source
+import Felix.Source.Graph (ResolvedSourceGraph)
+import Felix.Source.Graph qualified as SourceGraph
+import Felix.Report.Location
+import Felix.Syntax.Abstract qualified as Raw
+import Felix.Syntax.Adapt (ScannedLexicalItem, scanChunk)
+import Felix.Syntax.Lexicon (builtins)
+import Felix.Syntax.Token
+
+import Control.Exception qualified as Exception
+import Data.Bifunctor (first)
+import System.Directory (getCurrentDirectory)
+import System.Environment (lookupEnv)
+import System.FilePath.Posix ((</>), isAbsolute)
+import Text.Megaparsec (errorBundlePretty)
+
+data WorkspaceEnvironment = WorkspaceEnvironment
+    !SourceMounts
+    ![(SourceMountId, [Text])]
+    ![FilePath]
+
+workspaceSourceMounts :: WorkspaceEnvironment -> SourceMounts
+workspaceSourceMounts (WorkspaceEnvironment mounts _prefixes _rendererRoots) =
+    mounts
+
+workspaceHtmlMountPrefixes
+    :: WorkspaceEnvironment
+    -> [(SourceMountId, [Text])]
+workspaceHtmlMountPrefixes
+        (WorkspaceEnvironment _mounts prefixes _rendererRoots) =
+    prefixes
+
+workspaceRendererSearchRoots :: WorkspaceEnvironment -> [FilePath]
+workspaceRendererSearchRoots
+        (WorkspaceEnvironment _mounts _prefixes rendererRoots) =
+    rendererRoots
+
+prepareDefaultWorkspaceEnvironment
+    :: IO (Either ParseWorkspaceError WorkspaceEnvironment)
+prepareDefaultWorkspaceEnvironment = do
+    currentDir <- getCurrentDirectory
+    configuredLibrary <- lookupEnv "NAPROCHE_LIB"
+    let libraryDir = fromMaybe (currentDir </> "library") configuredLibrary
+        debugDir = currentDir </> "debug"
+        rendererRoots = [currentDir, libraryDir, debugDir]
+        prefixes =
+            [ (sourceMountId "project", [])
+            , (sourceMountId "library", ["library"])
+            , (sourceMountId "debug", ["debug"])
+            ]
+    fmap (first SourceWorkspaceError)
+        (fmap
+            (\mounts ->
+                WorkspaceEnvironment mounts prefixes rendererRoots)
+            <$> prepareSourceMounts
+                [ (sourceMountId "project", currentDir)
+                , (sourceMountId "library", libraryDir)
+                , (sourceMountId "debug", debugDir)
+                ])
+
+prepareWorkspaceRoot
+    :: WorkspaceEnvironment
+    -> FilePath
+    -> IO (Either ParseWorkspaceError RootRequest)
+prepareWorkspaceRoot _environment file =
+    first SourceWorkspaceError <$> classifyRootRequest file
+
+prepareSourceGraph
+    :: WorkspaceEnvironment
+    -> RootRequest
+    -> IO (Either ParseWorkspaceError ResolvedSourceGraph)
+prepareSourceGraph environment request =
+    first SourceWorkspaceError
+        <$> SourceGraph.buildResolvedSourceGraph
+            (workspaceSourceMounts environment)
+            request
+
+prepareDefaultSourceGraph
+    :: FilePath
+    -> IO (Either ParseWorkspaceError ResolvedSourceGraph)
+prepareDefaultSourceGraph file = do
+    preparedEnvironment <- prepareDefaultWorkspaceEnvironment
+    case preparedEnvironment of
+        Left failure -> pure (Left failure)
+        Right environment -> do
+            preparedRoot <- prepareWorkspaceRoot environment file
+            case preparedRoot of
+                Left failure -> pure (Left failure)
+                Right request -> prepareSourceGraph environment request
+
+classifyRootRequest :: FilePath -> IO (Either SourceError RootRequest)
+classifyRootRequest file
+    | isAbsolute file = existingRoot file
+    | otherwise = pure (searchedRoot file)
+
+data AuthorityFreeParseError
+    = AuthorityFreePreludeLoadFailed !Prelude.PreludeLoadError
+    | AuthorityFreePreludeParseFailed !Prelude.PreludeParseError
+    | AuthorityFreeWorkspaceFailed !ParseWorkspaceError
+    deriving (Show)
+
+instance Exception.Exception AuthorityFreeParseError
+
+renderAuthorityFreeParseError :: AuthorityFreeParseError -> Text
+renderAuthorityFreeParseError = \case
+    AuthorityFreePreludeLoadFailed failure ->
+        "packaged final prelude loading failed: "
+            <> Prelude.renderPreludeLoadError failure
+    AuthorityFreePreludeParseFailed failure ->
+        "packaged final prelude parsing failed: "
+            <> Prelude.renderPreludeParseError failure
+    AuthorityFreeWorkspaceFailed failure ->
+        Parse.renderParseWorkspaceError failure
+
+parseWorkspace
+    :: FilePath
+    -> IO (Either AuthorityFreeParseError [Raw.Block])
+parseWorkspace file =
+    fmap Parse.importedBeforeImporterBlocks
+        <$> parseDefaultWorkspaceWithPrelude file
+
+parse :: FilePath -> IO [Raw.Block]
+parse file = parseWorkspace file >>= either Exception.throwIO pure
+
+parseDefaultWorkspaceWithPrelude
+    :: FilePath
+    -> IO (Either AuthorityFreeParseError Parse.ParsedSourceWorkspace)
+parseDefaultWorkspaceWithPrelude file =
+    Prelude.loadReservedPreludeSourceInput >>= \case
+        Left failure ->
+            pure (Left (AuthorityFreePreludeLoadFailed failure))
+        Right source ->
+            Prelude.parseReservedPreludeSource source >>= \case
+                Left failure ->
+                    pure (Left (AuthorityFreePreludeParseFailed failure))
+                Right prelude -> do
+                    preparedEnvironment <- prepareDefaultWorkspaceEnvironment
+                    case preparedEnvironment of
+                        Left failure ->
+                            pure (Left (AuthorityFreeWorkspaceFailed failure))
+                        Right environment -> do
+                            preparedRoot <- prepareWorkspaceRoot environment file
+                            case preparedRoot of
+                                Left failure ->
+                                    pure
+                                        (Left
+                                            (AuthorityFreeWorkspaceFailed
+                                                failure))
+                                Right request -> do
+                                    let syntax =
+                                            Parse.identifiedParsedModuleSyntaxInterface
+                                                (Prelude.reservedParsedPreludeModule
+                                                    prelude)
+                                    first AuthorityFreeWorkspaceFailed
+                                        <$> Parse.parseSourceWorkspaceWithSyntaxInputsAndGraphValidation
+                                            (workspaceSourceMounts environment)
+                                            request
+                                            (const [syntax])
+                                            (Prelude.rejectOrdinaryPreludeSourceGraph
+                                                source)
+
+lexFile :: FilePath -> IO (Text, [[Located Token]])
+lexFile file = do
+    environment <- prepareDefaultWorkspaceEnvironment
+        >>= either throwWorkspaceError pure
+    request <- prepareWorkspaceRoot environment file
+        >>= either throwWorkspaceError pure
+    loaded <- resolveAndLoadRoot (workspaceSourceMounts environment) request
+        >>= either Exception.throwIO pure
+    let source = loadedSource loaded
+        raw = loadedText loaded
+        locationPath = resolvedSourceLocationPath source
+        canonicalPath =
+            canonicalPathFilePath (resolvedSourceCanonicalPath source)
+    registration <- registerFilePathWithDisplay canonicalPath locationPath
+    fileId <- either
+        (Exception.throwIO . SourceLocationRegistrationFailed source)
+        pure
+        registration
+    case runLexer fileId locationPath raw of
+        Left tokenError ->
+            Exception.throwIO (TokenError (errorBundlePretty tokenError))
+        Right (_imports, chunks) ->
+            pure (raw, chunks)
+
+tokenize :: FilePath -> IO TokStream
+tokenize file = do
+    (raw, chunks) <- lexFile file
+    pure (TokStream raw chunks)
+
+scan :: FilePath -> IO [ScannedLexicalItem]
+scan input = do
+    tokenStream <- tokenize input
+    concatMap (fmap unLocated)
+        <$> traverse
+            (either
+                (Exception.throwIO . LexicalScanFailure)
+                pure
+                . scanChunk)
+            (unTokStream tokenStream)
+
+simpleStream :: TokStream -> [[Token]]
+simpleStream TokStream{unTokStream = chunks} =
+    [unLocated <$> chunk | chunk <- chunks]
+
+throwWorkspaceError :: ParseWorkspaceError -> IO value
+throwWorkspaceError = \case
+    SourceWorkspaceError err -> Exception.throwIO err
+    err@SourceLexiconCollision{} -> Exception.throwIO err
+    err@SourceSyntaxPragmaError{} -> Exception.throwIO err
+    err@SourceSyntaxDeclarationError{} -> Exception.throwIO err
+    err@SourceSyntaxMaterializationError{} -> Exception.throwIO err
+    err@SourceParsedModuleKeyError{} -> Exception.throwIO err
+    SourceParseError _source err -> Exception.throwIO err