Pipeline.hs

{-# LANGUAGE OverloadedStrings #-}

-- | The compilation pipeline: parsing, renaming, resolving, desugaring,
-- and compiling CHR modules to VM programs.
--
-- Extracted from "YCHR.Run" so that 'compileModules' can be imported by
-- the type-checker TH splice without creating a circular dependency.
module YCHR.Internal.Compile.Pipeline
  ( -- * Compilation
    Error (..),
    GoalRejection (..),
    Warning (..),
    ExhaustivenessWarning,
    CompiledProgram (..),
    ExportResolution (..),
    compileModules,
    compileFiles,
    compileParsedModules,
  )
where

import Control.Exception (Exception)
import Data.Bifunctor (first)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as TIO
import Text.Parsec (ParseError)
import YCHR.Internal.Collect
  ( CollectError,
    addLibraryPrelude,
    resolveLibraryClosure,
    rewriteImports,
  )
import YCHR.Internal.Collected (CollectedModule)
import YCHR.Internal.Compile (CompileError, compile)
import YCHR.Internal.Desugar (DesugarError, desugarProgram, extractSymbolTable, liftAllLambdas)
import YCHR.Internal.Desugared qualified as D
import YCHR.Internal.Diagnostic (Diagnostic)
import YCHR.Internal.Exhaustiveness (ExhaustivenessWarning, checkExhaustiveness)
import YCHR.Internal.PExpr (PExpr)
import YCHR.Internal.Parsed (AnnP (..), Import (..), Module (..), OpDecl, SourceLoc, noAnnP)
import YCHR.Internal.Parser
  ( ModuleHeader (..),
    OpTable,
    ParseValidationError (..),
    buildModuleOpTable,
    builtinOps,
    collectModuleHeader,
    extractOpDecls,
    mergeOps,
    parseModuleWith,
  )
import YCHR.Internal.Rename
  ( RenameError,
    RenameInputs (..),
    RenameWarning,
    buildExportEnv,
    renameProgram,
  )
import YCHR.Internal.Rename.Types (toListExport)
import YCHR.Internal.Resolve
  ( FunVisibility,
    ResolveError,
    buildQueryFunctionVisibility,
    resolveProgram,
  )
import YCHR.Internal.StdLib (stdlib)
import YCHR.Internal.TypeCheck.Error (TypeCheckError)
import YCHR.Internal.Types (SymbolTable)
import YCHR.Internal.Types qualified as Types
import YCHR.Internal.VM (Program, StackFrame)

-- | Anything that can stop a program from compiling or running, tagged by
-- the phase that rejected it.
--
-- 'compileModules' and 'compileFiles' /return/ this as a 'Left';
-- everything downstream (the query entry points, 'YCHR.Convert', the
-- 'YCHR.DSL' runners) throws it, since it is an 'Exception' instance. That
-- is deliberate: a single type to catch regardless of which phase failed.
--
-- Render it with 'YCHR.Run.displayError', not 'show' — the derived 'Show'
-- dumps the internal diagnostic representation, whereas 'displayError'
-- produces the @file:line:col: YCHR-NNNNN@ form the @ychr@ CLI prints.
--
-- The constructors are exported so callers can tell /which/ phase failed,
-- but their payloads are internal diagnostic types (from
-- @YCHR.Internal.*@) with no compatibility guarantee. Treat this as a tag
-- you may match on, plus a value you render — not a structure to
-- destructure.
data Error
  = ParseError FilePath ParseError
  | ParseValidationErrors [AnnP ParseValidationError]
  | CollectErrors [Diagnostic CollectError]
  | RenameErrors [Diagnostic RenameError]
  | DesugarErrors [Diagnostic DesugarError]
  | ResolveErrors [Diagnostic ResolveError]
  | CompileErrors [Diagnostic CompileError]
  | OperatorConflict (AnnP Text)
  | -- | Type errors detected when checking a goal or query before
    -- execution. The compiled program itself was well-typed; the
    -- diagnostics here pertain only to the user-submitted goal.
    TypeErrors [Diagnostic TypeCheckError]
  | -- | A live REPL session received a query that introduces anonymous
    -- lambdas. Live sessions cannot grow the procedure map after the
    -- effect stack has started, so such queries are rejected. Carries
    -- the source location and originating expression of the first
    -- offending lambda so the diagnostic can point at it directly.
    LambdasInLiveQuery SourceLoc PExpr
  | -- | A runtime error raised by 'YCHR.Internal.Runtime.Error.runtimeError'' /
    -- 'YCHR.Internal.Runtime.Error.runtimeErrorS'. Carries the detail message and
    -- the call stack at the throw site (newest frame first), which the
    -- 'Display' instance renders frame-by-frame through
    -- 'YCHR.Internal.Display.displayMsgWithSrcLoc'. Thrown from runtime helpers
    -- so the test harness (and the REPL) can catch and display it
    -- instead of the process exiting unconditionally.
    RuntimeError String [StackFrame]
  | -- | The CLI received a goal via @ychr run -g GOAL@ whose top-level
    -- name does not resolve to a declared constraint. Distinct from
    -- 'ResolveErrors' so the diagnostic can hint that the REPL accepts
    -- broader goal forms (bare expressions, conjunctions, @is@, @=@).
    -- Carries the original 'Types.Constraint' (for name+arity in the
    -- message) and a tag distinguishing the rejection mode.
    GoalNotAConstraint Types.Constraint GoalRejection
  deriving (Show)

-- | Why a goal was rejected as not-a-constraint. Used by the
-- 'GoalNotAConstraint' 'Error' constructor.
data GoalRejection
  = -- | The unqualified goal name has no matching export in any loaded
    -- module (e.g. @ychr run -g 'true'@ when no @true/0@ constraint is
    -- declared).
    NoSuchConstraint
  | -- | The unqualified goal name is exported by more than one module
    -- and is therefore ambiguous. Carries the module names.
    AmbiguousConstraint [Text]
  | -- | The qualified goal name names a module that does not export it.
    -- Carries the resolved name for the message.
    ConstraintNotExported Types.QualifiedName
  | -- | The goal name resolves successfully, but to a function rather
    -- than a constraint (e.g. @ychr run -g '1 + 1'@ resolves to
    -- @prelude:+/2@, which is a function). Carries the resolved name.
    NotAConstraintItem Types.QualifiedName
  deriving (Show)

instance Exception Error

-- | A non-fatal diagnostic. Compilation succeeded; something in the
-- program is nonetheless suspicious — an undeclared data constructor, a
-- function whose equations are not exhaustive.
--
-- Returned alongside the 'CompiledProgram' rather than thrown. The @ychr@
-- CLI's @--Werror@ is simply "treat a non-empty list as failure"; an
-- embedder decides for itself. Render with 'YCHR.Run.displayWarning'.
--
-- As with 'Error', the payloads are internal types; match on the
-- constructor, render the value.
data Warning
  = RenameWarnings [Diagnostic RenameWarning]
  | ExhaustivenessWarnings [Diagnostic ExhaustivenessWarning]
  deriving (Show)

-- | A compiled CHR program together with module visibility information.
data CompiledProgram = CompiledProgram
  { program :: Program,
    exportMap :: Map Types.UnqualifiedIdentifier ExportResolution,
    exportedSet :: Set Types.QualifiedIdentifier,
    symbolTable :: SymbolTable,
    allModules :: [CollectedModule],
    opTable :: OpTable,
    -- | All functions in the desugared program (for call dispatch in queries).
    allFunctions :: [D.Function],
    -- | Counter for the next lambda index (to avoid collisions in queries).
    nextLambdaIndex :: Int,
    -- | Function-visibility table for query-time 'YCHR.Internal.Resolve.termToExpr'
    -- calls. Mirrors the synthetic @\<query\>@ module the renamer
    -- builds: every function declared by any loaded module is in scope
    -- for a query.
    queryFunctionVisibility :: FunVisibility,
    -- | The desugared program (before lambda lifting), for type checking.
    desugaredProgram :: D.Program
  }

-- | What an unqualified name in a goal resolves to, given everything the
-- program exports. 'AmbiguousExport' carries the competing module names so
-- a diagnostic can list them; resolving it requires the caller to qualify.
data ExportResolution
  = UniqueExport Types.QualifiedName
  | AmbiguousExport [Text]
  deriving (Show, Eq)

-- | Compile CHR modules from in-memory source text.
--
-- Every module is compiled together as one program, so they may import
-- each other in any order; the list is a set of inputs, not a sequence.
-- The 'FilePath' of each pair is used only for diagnostics and need not
-- exist on disk — pass a Template Haskell splice or a string literal to
-- build a self-contained binary. Use 'compileFiles' to read from disk
-- instead, or 'compileParsedModules' for programs built with "YCHR.DSL".
--
-- The 'Bool' is @includeStdlib@: pass 'True' to make the bundled
-- libraries (@prelude@, @lists@, @strings@, @meta@) available for
-- @:- use_module(library(…))@, which is what you almost always want —
-- the prelude supplies arithmetic and comparison. 'False' compiles
-- against nothing but the given modules; the CLI uses it so that a
-- program's own diagnostics are not diluted by stdlib warnings.
--
-- Warnings accompany a successful compile; see 'Warning'.
compileModules :: Bool -> [(FilePath, Text)] -> Either Error (CompiledProgram, [Warning])
compileModules includeStdlib inputs = do
  -- Phase 1: lightweight first parse of each user file to collect the
  -- module name, exported operators, header use_module imports, and the
  -- location at which header parsing stopped.
  userHeaders <-
    first (\(fp, e) -> ParseError fp e) $
      traverse (\(fp, src) -> (fp,) <$> first' (fp,) (collectModuleHeader fp src)) inputs
  -- Resolve the transitive closure of library imports starting from the
  -- libraries each user header asks for (plus prelude as an implicit
  -- seed, and every stdlib library if includeStdlib is True).
  let userLibrarySeeds =
        noAnnP "prelude"
          : [ AnnP n loc p
            | (_, h) <- userHeaders,
              AnnP (LibraryImport n _) loc p <- h.headerImports
            ]
  libraryMods <-
    first
      CollectErrors
      ( resolveLibraryClosure
          includeStdlib
          stdlib
          userLibrarySeeds
      )
  -- Build the module-name → exported-operators map used by per-module op
  -- table construction and by the renamer's UnknownOperatorImport check.
  let stdlibOpExports = Map.fromList [(m.name, extractOpDecls m) | m <- libraryMods]
      userOpExports = Map.fromList [(h.modName, h.exportOps) | (_, h) <- userHeaders]
      opExports = stdlibOpExports `Map.union` userOpExports
      preludeOps = Map.findWithDefault [] "prelude" opExports
  -- Build per-module operator tables and full-parse each user file with
  -- its specific table. A first conflict in any table aborts the whole
  -- compilation with OperatorConflict.
  parsedWithErrors <-
    traverse
      ( \((fp, src), (_, hdr)) -> do
          table <- case buildModuleOpTable builtinOps preludeOps opExports hdr of
            Left conflict -> Left (OperatorConflict (AnnP conflict hdr.modLoc hdr.modOrigin))
            Right t -> Right t
          first (ParseError fp) (parseModuleWith table fp src)
      )
      (zip inputs userHeaders)
  let parsed = map fst parsedWithErrors
      validationErrors = concatMap snd parsedWithErrors
  case validationErrors of
    [] -> pure ()
    errs -> Left (ParseValidationErrors errs)
  let trailingLoc =
        Map.fromList [(h.modName, h.trailingLoc) | (_, h) <- userHeaders]
  finalizeCompilation libraryMods opExports trailingLoc parsed
  where
    first' f (Left e) = Left (f e)
    first' _ (Right x) = Right x

-- | Compile already-parsed modules. This is the entry point used by
-- "YCHR.DSL" callers that build 'Module' values in Haskell rather than
-- parsing @.chr@ text.
--
-- The library closure (prelude plus every @use_module(library(_))@ in
-- the input modules' import lists, plus all stdlib libraries when
-- @includeStdlib@ is 'True') is resolved internally; operator
-- declarations come from each module's own export list via
-- 'extractOpDecls'. There is no per-module @trailingLoc@ since the
-- input was not parsed from text — the renamer's
-- "use_module-after-non-import" check is therefore a no-op for these
-- modules, which is the right behaviour for programmatically built
-- input.
compileParsedModules ::
  Bool -> [Module] -> Either Error (CompiledProgram, [Warning])
compileParsedModules includeStdlib parsed = do
  let userLibrarySeeds =
        noAnnP "prelude"
          : [ AnnP n loc p
            | m <- parsed,
              AnnP (LibraryImport n _) loc p <- m.imports
            ]
  libraryMods <-
    first
      CollectErrors
      ( resolveLibraryClosure
          includeStdlib
          stdlib
          userLibrarySeeds
      )
  let stdlibOpExports = Map.fromList [(m.name, extractOpDecls m) | m <- libraryMods]
      userOpExports = Map.fromList [(m.name, extractOpDecls m) | m <- parsed]
      opExports = stdlibOpExports `Map.union` userOpExports
  finalizeCompilation libraryMods opExports Map.empty parsed

-- | Shared post-parse, post-library-resolution pipeline: rename, resolve,
-- desugar, lambda-lift, compile, and assemble the resulting
-- 'CompiledProgram'. Both 'compileModules' (after parsing user files)
-- and 'compileParsedModules' (with no parse step) call this.
finalizeCompilation ::
  -- | Library modules (already-resolved closure).
  [Module] ->
  -- | Per-module operator exports (stdlib + user).
  Map Text [OpDecl] ->
  -- | Trailing-location map for the renamer's
  -- "use_module after non-import" check. Empty for DSL-built input.
  Map Text (Maybe SourceLoc) ->
  -- | User modules (parsed).
  [Module] ->
  Either Error (CompiledProgram, [Warning])
finalizeCompilation libraryMods opExports trailingLocMap parsed = do
  -- Auto-import prelude into every user module and into every library
  -- module (except prelude itself), then rewrite all LibraryImports to
  -- ModuleImports for the renamer.
  let allMods = rewriteImports (addLibraryPrelude libraryMods ++ map addPreludeImport parsed)
      exportEnv = buildExportEnv allMods
      exportMap =
        Map.fromList
          [ (Types.UnqualifiedIdentifier n a, toResolution n ms)
          | ((n, a), ms) <- toListExport exportEnv
          ]
      exportedSet =
        Set.fromList
          [Types.QualifiedIdentifier m n a | ((n, a), ms) <- toListExport exportEnv, m <- ms]
      renameInputs =
        RenameInputs
          { operatorExports = opExports,
            trailingLoc = trailingLocMap
          }
  (renamed, renameWarnings) <- first RenameErrors (renameProgram renameInputs allMods)
  resolved <- first ResolveErrors (resolveProgram renamed)
  desugared <- first DesugarErrors (desugarProgram resolved)
  let (desugared', liftErrs) = liftAllLambdas desugared
  case liftErrs of
    [] -> pure ()
    _ -> Left (DesugarErrors liftErrs)
  let symTab = extractSymbolTable desugared'
      exhaustWarnings = checkExhaustiveness resolved
      warnings =
        [RenameWarnings renameWarnings | not (null renameWarnings)]
          ++ [ExhaustivenessWarnings exhaustWarnings | not (null exhaustWarnings)]
  prog <- first CompileErrors (compile desugared' symTab)
  -- The query parser uses the union of every user module's operator
  -- visibility, so a query at the REPL can use any operator any user
  -- module declares.
  queryTable <- case mergeOps builtinOps (concat (Map.elems opExports)) of
    Left conflict -> Left (OperatorConflict (noAnnP conflict))
    Right t -> Right t
  let lambdaCount =
        length [() | f <- desugared'.functions, isLambdaName (Types.qualifiedToName f.name)]
  pure
    ( CompiledProgram
        prog
        exportMap
        exportedSet
        symTab
        allMods
        queryTable
        desugared'.functions
        lambdaCount
        (buildQueryFunctionVisibility allMods)
        desugared,
      warnings
    )
  where
    toResolution n [m] = UniqueExport (Types.QualifiedName m n)
    toResolution _ ms = AmbiguousExport ms

-- | Prepend a synthetic @use_module(library(prelude))@ to a user module so
-- the renamer treats prelude exports as visible.
addPreludeImport :: Module -> Module
addPreludeImport m = m {imports = noAnnP (LibraryImport "prelude" Nothing) : m.imports}

-- | 'compileModules', reading each module's source from disk.
--
-- The 'Bool' is @includeStdlib@, with the same meaning as in
-- 'compileModules'. All files are compiled together as one program.
compileFiles :: Bool -> [FilePath] -> IO (Either Error (CompiledProgram, [Warning]))
compileFiles includeStdlib paths = do
  contents <- mapM (\fp -> (fp,) <$> TIO.readFile fp) paths
  pure (compileModules includeStdlib contents)

-- | Check if a name is a lambda (generated by lambda lifting).
isLambdaName :: Types.Name -> Bool
isLambdaName (Types.Qualified _ n) = T.isPrefixOf "__lambda_" n
isLambdaName (Types.Unqualified n) = T.isPrefixOf "__lambda_" n