Command.hs

-- SPDX-FileCopyrightText: 2026 Progmasoft <support@progmasoft.com>
-- SPDX-License-Identifier: MPL-2.0 WITH AdditionRef-Progmasoft-Exception-2.0

{- | Private command model shared by the Haskell shared-library boundary and
the small command-line adapter. It returns owned bytes instead of opening an
output artifact: the native driver consumes Core in memory and is the only
component that writes user-requested outputs.
-}
module Progmasoft.Tala.Driver.Command
    ( FrontendOutcome (..)
    , FrontendOutputKind (..)
    , runFrontendArguments
    ) where

import Data.ByteString qualified as ByteString
import Data.Char (isAlpha, isAlphaNum)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Progmasoft.Tala.AST
import Progmasoft.Tala.Compiler
import Progmasoft.Tala.Core (CoreModule)
import Progmasoft.Tala.Core.Wire
import Progmasoft.Tala.Diagnostic
import Progmasoft.Tala.Directives
import Progmasoft.Tala.SourceSet
import Progmasoft.Tala.SourceWarnings

{- | Output tags are part of the private in-process ABI, not public artifact
names. Each output is borrowed only for the synchronous native callback.
-}
data FrontendOutputKind
    = CoreWireOutput
    | ProjectSourceListOutput
    | DiagnosticWireOutput
    | ErrorTextOutput
    deriving (Bounded, Enum, Eq, Ord, Read, Show)

{- | Owned result of one private frontend request, ready for native consumption.

A success carries the warnings of the sources it compiled. A rejection lists
its errors first and the warnings after them, because a warning often
explains the error that follows it in the same statement.
-}
data FrontendOutcome
    = FrontendSuccess FrontendOutputKind ByteString.ByteString [Diagnostic]
    | FrontendDiagnostics [Diagnostic]
    | FrontendFailure String

data FrontendCommand
    = CompileFile DirectiveEnvironment FilePath
    | CompileFiles DirectiveEnvironment QualifiedName [FilePath]
    | CompileTests DirectiveEnvironment [FilePath]
    | CompileProject DirectiveEnvironment FilePath QualifiedName [FilePath] [FilePath]
    | ListProjectSources FilePath [FilePath] [FilePath]

data CommandOptions = CommandOptions
    { optionSourceFiles :: [FilePath]
    , optionProjectRoot :: Maybe FilePath
    , optionEntry :: Maybe String
    , optionSourceRoots :: [FilePath]
    , optionExcludes :: [FilePath]
    , optionListSources :: Bool
    , optionTest :: Bool
    , optionTargetSystem :: Maybe String
    }

emptyOptions :: CommandOptions
emptyOptions = CommandOptions [] Nothing Nothing [] [] False False Nothing

{- | Parse the deliberately narrow private argument vocabulary. Values remain
separate from option names so file names and glob patterns cannot be
reinterpreted by a shell or by option-prefix heuristics.
-}
runFrontendArguments :: [String] -> IO FrontendOutcome
runFrontendArguments arguments = case parseCommand arguments of
    Left problem -> pure (FrontendFailure problem)
    Right command -> executeCommand command

parseCommand :: [String] -> Either String FrontendCommand
parseCommand arguments = parseOptions emptyOptions arguments >>= finishCommand

parseOptions :: CommandOptions -> [String] -> Either String CommandOptions
parseOptions options [] = Right options
parseOptions options (name : remaining) = case name of
    "--source-file" -> repeatedValue name addSourceFile options remaining
    "--project-root" -> uniqueValue name optionProjectRoot setProjectRoot options remaining
    "--entry" -> uniqueValue name optionEntry setEntry options remaining
    "--source-root" -> repeatedValue name addSourceRoot options remaining
    "--exclude" -> repeatedValue name addExclude options remaining
    "--list-sources"
        | optionListSources options -> Left "--list-sources may be specified only once"
        | otherwise -> parseOptions options {optionListSources = True} remaining
    "--test"
        | optionTest options -> Left "--test may be specified only once"
        | otherwise -> parseOptions options {optionTest = True} remaining
    "--target-os" -> uniqueValue name optionTargetSystem setTargetSystem options remaining
    _ -> Left ("unknown private frontend option: " ++ name)

uniqueValue ::
    String ->
    (CommandOptions -> Maybe String) ->
    (String -> CommandOptions -> CommandOptions) ->
    CommandOptions ->
    [String] ->
    Either String CommandOptions
uniqueValue name getter setter options remaining = case remaining of
    [] -> Left (name ++ " requires one value")
    value : rest
        | null value -> Left (name ++ " value is empty")
        | getter options /= Nothing -> Left (name ++ " may be specified only once")
        | otherwise -> parseOptions (setter value options) rest

repeatedValue ::
    String ->
    (String -> CommandOptions -> CommandOptions) ->
    CommandOptions ->
    [String] ->
    Either String CommandOptions
repeatedValue name setter options remaining = case remaining of
    [] -> Left (name ++ " requires one value")
    value : rest
        | null value -> Left (name ++ " value is empty")
        | otherwise -> parseOptions (setter value options) rest

setProjectRoot, setEntry, setTargetSystem :: String -> CommandOptions -> CommandOptions
setProjectRoot value options = options {optionProjectRoot = Just value}
setEntry value options = options {optionEntry = Just value}
setTargetSystem value options = options {optionTargetSystem = Just value}

{- | The environment of the conditional directives: the target's system,
which the native driver names after the target triple, and whether tests are
compiled. Without a system the host's is used.
-}
directiveEnvironment :: CommandOptions -> Either String DirectiveEnvironment
directiveEnvironment options = do
    system <- case optionTargetSystem options of
        Nothing -> Right (directiveSystem hostDirectiveEnvironment)
        Just name -> maybe (Left ("--target-os names no known system: " ++ name)) Right (operatingSystemNamed name)
    Right (DirectiveEnvironment system (optionTest options))

addSourceFile, addSourceRoot, addExclude :: String -> CommandOptions -> CommandOptions
addSourceFile value options = options {optionSourceFiles = optionSourceFiles options ++ [value]}
addSourceRoot value options = options {optionSourceRoots = optionSourceRoots options ++ [value]}
addExclude value options = options {optionExcludes = optionExcludes options ++ [value]}

finishCommand :: CommandOptions -> Either String FrontendCommand
finishCommand options =
    directiveEnvironment options >>= \environment -> case ( optionSourceFiles options
                                                          , optionProjectRoot options
                                                          , optionEntry options
                                                          , optionListSources options
                                                          ) of
        (sources@(_ : _), Nothing, entryText, False)
            | not (null (optionSourceRoots options) && null (optionExcludes options)) ->
                Left "file compilation cannot declare project roots or exclusions"
            | optionTest options -> case entryText of
                Nothing -> Right (CompileTests environment sources)
                Just _ -> Left "a test build has its own entry and takes no --entry"
            | otherwise -> case (entryText, sources) of
                (Just written, _) -> fmap (\entry -> CompileFiles environment entry sources) (parseQualifiedName written)
                (Nothing, [source]) -> Right (CompileFile environment source)
                (Nothing, _) -> Left "several source files require --entry"
        ([], Just root, Just entryText, False)
            | optionTest options -> Left "a test build names its source files"
            | otherwise -> do
                entry <- parseQualifiedName entryText
                if null (optionSourceRoots options)
                    then Left "project compilation requires at least one --source-root"
                    else Right (CompileProject environment root entry (optionSourceRoots options) (optionExcludes options))
        ([], Just root, Nothing, True)
            | not (null (optionSourceRoots options)) ->
                Right (ListProjectSources root (optionSourceRoots options) (optionExcludes options))
            | otherwise -> Left "project source listing requires at least one --source-root"
        _ -> Left "arguments must describe exactly one file compile, project compile, or project source listing"

{- | Load every explicitly named source. A file named twice is one source;
the first failure of any file rejects the whole set, as project loading does.
-}
loadSourceFiles :: [FilePath] -> IO (Either [Diagnostic] [LoadedSource])
loadSourceFiles paths = do
    loaded <- mapM loadSourceFile paths
    let problems = concat [issues | Left issues <- loaded]
        sources = [source | Right source <- loaded]
    pure $ if null problems then Right (uniqueSources sources) else Left problems
    where
        uniqueSources = foldr keepFirst []
        keepFirst source rest =
            source : filter ((/= loadedSourcePath source) . loadedSourcePath) rest

parseQualifiedName :: String -> Either String QualifiedName
parseQualifiedName text =
    let parts = splitDot text
     in if length parts < 2
            then Left "--entry must name a namespace-qualified class"
            else
                if all validIdentifier parts
                    then Right (QualifiedName (map Identifier parts))
                    else Left ("--entry contains an invalid identifier: " ++ text)

validIdentifier :: String -> Bool
validIdentifier [] = False
validIdentifier (first : remaining) =
    (isAlpha first || first == '_') && all (\value -> isAlphaNum value || value == '_') remaining

splitDot :: String -> [String]
splitDot [] = [""]
splitDot ('.' : remaining) = "" : splitDot remaining
splitDot (value : remaining) = case splitDot remaining of
    [] -> [[value]]
    first : rest -> (value : first) : rest

executeCommand :: FrontendCommand -> IO FrontendOutcome
executeCommand command = case command of
    CompileFile environment source -> do
        loaded <- loadSourceFile source
        case loaded of
            Left diagnostics -> pure (FrontendDiagnostics diagnostics)
            Right document ->
                let warnings = loadedSourceWarnings document
                 in case compileToCorePrepWith environment (CompilerInput (loadedSourceRelativePath document) (loadedSourceText document)) of
                        Left diagnostics -> pure (FrontendDiagnostics (diagnostics ++ warnings))
                        Right artifacts -> encodeCoreOutcome warnings (artifactOptimizedCore artifacts)
    CompileTests environment sources -> do
        loaded <- loadSourceFiles sources
        case loaded of
            Left diagnostics -> pure (FrontendDiagnostics diagnostics)
            Right documents ->
                let warnings = concatMap loadedSourceWarnings documents
                 in case compileTestsToCorePrep environment (map toProjectCompilerInput documents) of
                        Left diagnostics -> pure (FrontendDiagnostics (diagnostics ++ warnings))
                        Right artifacts -> encodeCoreOutcome warnings (projectEntryCore artifacts)
    CompileFiles environment entry sources -> do
        loaded <- loadSourceFiles sources
        case loaded of
            Left diagnostics -> pure (FrontendDiagnostics diagnostics)
            Right documents ->
                let warnings = concatMap loadedSourceWarnings documents
                    inputs = map toProjectCompilerInput documents
                    -- One source keeps the single-file pipeline, whose Core
                    -- carries no source catalog; several are one program.
                    compiled = case inputs of
                        [input] -> fmap artifactOptimizedCore (compileEntryToCorePrepWith environment entry input)
                        _ -> fmap projectEntryCore (compileProjectToCorePrepWith environment entry inputs)
                 in case compiled of
                        Left diagnostics -> pure (FrontendDiagnostics (diagnostics ++ warnings))
                        Right core -> encodeCoreOutcome warnings core
    CompileProject environment root entry roots excludes -> do
        loaded <- loadSourceSet (SourceSetRequest root roots excludes)
        case loaded of
            Left diagnostics -> pure (FrontendDiagnostics diagnostics)
            Right documents ->
                let warnings = concatMap loadedSourceWarnings documents
                 in case compileProjectToCorePrepWith environment entry (map toProjectCompilerInput documents) of
                        Left diagnostics -> pure (FrontendDiagnostics (diagnostics ++ warnings))
                        Right artifacts -> encodeCoreOutcome warnings (projectEntryCore artifacts)
    ListProjectSources root roots excludes -> do
        discovered <- discoverSourceSet (SourceSetRequest root roots excludes)
        pure $ case discovered of
            Left diagnostics -> FrontendDiagnostics diagnostics
            Right paths ->
                FrontendSuccess
                    ProjectSourceListOutput
                    (Text.encodeUtf8 (Text.pack (concatMap (++ "\0") paths)))
                    []

toProjectCompilerInput :: LoadedSource -> CompilerInput
toProjectCompilerInput source = CompilerInput (loadedSourceRelativePath source) (loadedSourceText source)

loadedSourceWarnings :: LoadedSource -> [Diagnostic]
loadedSourceWarnings source = sourceWarnings (loadedSourceRelativePath source) (loadedSourceText source)

encodeCoreOutcome :: [Diagnostic] -> CoreModule -> IO FrontendOutcome
encodeCoreOutcome warnings core = pure $ case encodeCore defaultCoreWireLimits core of
    Left issue -> FrontendFailure ("could not encode verified Core: " ++ show issue)
    Right bytes -> FrontendSuccess CoreWireOutput (ByteString.pack bytes) warnings