{-# 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