packages feed

ychr (empty) → 0.1.0.0

raw patch · 1287 files changed

+38757/−0 lines, 1287 filesdep +ansi-terminaldep +basedep +containers

Dependencies added: ansi-terminal, base, containers, criterion, directory, filepath, haskeline, hedgehog, optparse-applicative, parsec, tasty, tasty-hedgehog, tasty-hunit, template-haskell, text, transformers, ychr

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

+ CHANGELOG.md view
@@ -0,0 +1,8 @@+# Revision history for ychr++## 0.1.0.0 -- 2026-08-02++First release. See the+[README](https://github.com/lortabac/ychr#readme) for an overview and+[`docs/`](https://github.com/lortabac/ychr/tree/master/docs) for the+documentation.
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2026, Lorenzo Tabacchini+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of the copyright holder nor the names of its+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,155 @@+# YCHR++A Constraint Handling Rules (CHR) compiler with multiple backends. The+surface language is standard CHR with Prolog-compatible syntax,+extended with Erlang-style user-defined functions. The compiler is+written in Haskell and lowers programs to a small abstract VM, which+can be interpreted directly or translated to Scheme.++The compilation algorithm follows Van Weert, Wuille, Schrijvers, and+Demoen (2008), *CHR for Imperative Host Languages*.++## Example++```prolog+:- module(order, [leq/2]).+:- chr_constraint leq/2.++reflexivity   @ leq(X, X) <=> true.+antisymmetry  @ leq(X, Y), leq(Y, X) <=> X = Y.+idempotence   @ leq(X, Y) \ leq(X, Y) <=> true.+transitivity  @ leq(X, Y), leq(Y, Z) ==> leq(X, Z).+```++```sh+$ ychr repl examples/leq.chr+ychr> leq(X, Y), leq(Y, X).+X = Y,+Y = X.+ychr>+```++## Status++Work in progress. The Haskell interpreter and Scheme backend are+working; the JavaScript backend and most of the optimization catalogue+from the paper are not yet implemented. See the+[roadmap](https://github.com/lortabac/ychr/blob/master/docs/roadmap.md)+for the full status.++## Install++Requires GHC 9.6+ and Cabal 3.4+.++```sh+cabal install ychr+```++To build from a checkout instead:++```sh+make build+make install+```++## Quick start++```sh+ychr repl file.chr                   # interactive REPL (Prolog-style queries)+ychr run -g 'constraint(args)' file  # run a single constraint as the goal+ychr check file.chr                  # type-check only+ychr compile -t scheme -d out file.chr+```++`make test` runs the full test suite: the Haskell interpreter, the+Scheme backend and runtime, the REPL, the type checker, the embedding+example, and lint checks over the documentation. Besides GHC it needs+`python3` with `pytest`, and Guile 3.++Compiling to Scheme emits code that imports the YCHR Scheme runtime+(`(ychr runtime)` and friends). That runtime lives in+[`scheme/`](https://github.com/lortabac/ychr/tree/master/scheme)+in this repository and is **not** shipped with the Hackage package, so+`-t scheme` currently requires a source checkout — see the+[Scheme REPL guide](https://github.com/lortabac/ychr/blob/master/docs/how-to/scheme-repl.md).++## Using YCHR as a Haskell library++YCHR is also an ordinary Haskell library: compile a `.chr` module from+your own program, feed it Haskell values, and decode the answers back.++```+build-depends: ychr+```++```haskell+{-# LANGUAGE OverloadedStrings #-}+import System.IO (hPutStr, stderr)+import YCHR++main :: IO ()+main = do+  result <- compileFiles True ["Order.chr"]+  case result of+    Left err -> hPutStr stderr (displayError err)+    Right (cp, _warnings) -> do+      r <- runQueryCompiled cp goal "R"+      print (r :: Either ConvertError Int)+  where+    goal = CompoundTerm (Unqualified "compute") [VarTerm "R"]+```++A single `import YCHR` covers compiling, querying, and marshalling.+Values cross the boundary through the `ToTerm` / `FromTerm` classes, and+Haskell functions can be exposed to CHR programs as host calls.++- [Embedding a CHR module](https://github.com/lortabac/ychr/blob/master/docs/how-to/embed-a-chr-module.md) —+  worked example: a lambda-calculus type inferencer written in CHR,+  driven from Haskell.+- [Value conversion](https://github.com/lortabac/ychr/blob/master/docs/reference/convert.md) —+  `ToTerm` / `FromTerm`, decoding, and compile-once/query-many.+- [Host functions](https://github.com/lortabac/ychr/blob/master/docs/reference/host-functions.md) —+  calling Haskell from CHR.+- [Haskell DSL](https://github.com/lortabac/ychr/blob/master/docs/reference/dsl.md) —+  build programs as Haskell values instead of parsing `.chr` source.++Modules under `YCHR.Internal` are implementation details and are not+covered by the package version policy.++## Documentation++User-facing documentation lives in+[`docs/`](https://github.com/lortabac/ychr/tree/master/docs) and follows+the [Diátaxis](https://diataxis.fr/) structure:++- [Tutorials](https://github.com/lortabac/ychr/tree/master/docs/tutorials) —+  getting started, CHR primer, your first program.+- [How-to guides](https://github.com/lortabac/ychr/tree/master/docs/how-to) —+  REPL, types, host calls, modules.+- [Reference](https://github.com/lortabac/ychr/tree/master/docs/reference) —+  language, syntax, type system, prelude, CLI, REPL, errors, abstract VM.+- [Explanation](https://github.com/lortabac/ychr/tree/master/docs/explanation) —+  what CHR is, operational semantics, design rationale.++The tutorials and reference are complete; a few how-to guides and+explanation pages are still outlines.++See [`docs/README.md`](https://github.com/lortabac/ychr/blob/master/docs/README.md)+for a full index with reading paths for newcomers and existing+CHR/Prolog users, and+[`docs/roadmap.md`](https://github.com/lortabac/ychr/blob/master/docs/roadmap.md)+for implementation status.++Contributor and design documentation lives in+[`dev-docs/`](https://github.com/lortabac/ychr/tree/master/dev-docs),+including+[PROJECT.md](https://github.com/lortabac/ychr/blob/master/dev-docs/PROJECT.md)+(architecture and compilation scheme) and the reference paper.++## AI disclosure++This project has been developed with the help of large language models.++## License++BSD-3-Clause
+ app/Main.hs view
@@ -0,0 +1,348 @@+module Main where++import Control.Exception (SomeException, displayException, fromException, try)+import Control.Monad (unless, when)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Options.Applicative+import System.Directory (createDirectoryIfMissing)+import System.Exit (exitFailure)+import System.FilePath (takeDirectory, (</>))+import System.IO (hPutStr, stderr)+import YCHR.Internal.Backend.Scheme (generateScheme, isValidSchemeIdentifier)+import YCHR.Internal.Backend.SchemeDriver (generateDriver)+import YCHR.Internal.Compile.Pipeline (CompiledProgram (..))+import YCHR.Internal.Display (displayMsg)+import YCHR.Internal.Meta (metaHostCallRegistry)+import YCHR.Internal.Parser (parseConstraintWith)+import YCHR.Internal.Pretty (prettyBindings)+import YCHR.Internal.Rename (renameQueryArgs)+import YCHR.Internal.Repl qualified as Repl+import YCHR.Internal.Runtime.Interpreter (HostCallRegistry, baseHostCallRegistry)+import YCHR.Internal.TypeCheck (typeCheckProgram)+import YCHR.Internal.VM.SExpr (VMProgram (..), serialize)+import YCHR.Run+  ( Error (..),+    Warning (..),+    compileFiles,+    goalShapeConstraint,+    prepareGoal,+    resolveQueryTellOrThrow,+    runPreparedGoal,+  )+import YCHR.Types (Constraint (..))++-- ---------------------------------------------------------------------------+-- Command-line options+-- ---------------------------------------------------------------------------++data RunOpts = RunOpts+  { goal :: T.Text,+    showBindings :: Bool,+    werror :: Bool+  }++data Target = TargetVM | TargetScheme++data CompileOpts = CompileOpts+  { outputDir :: FilePath,+    baseName :: Maybe String,+    target :: Target,+    werror :: Bool+  }++data GenDriverOpts = GenDriverOpts+  { gdGoal :: T.Text,+    werror :: Bool+  }++data ReplOpts = ReplOpts+  { quiet :: Bool,+    werror :: Bool+  }++data CheckOpts = CheckOpts+  { werror :: Bool+  }++data Command+  = Repl ReplOpts [FilePath]+  | Run RunOpts [FilePath]+  | Compile CompileOpts [FilePath]+  | GenDriver GenDriverOpts [FilePath]+  | Check CheckOpts [FilePath]++filesArg :: Parser [FilePath]+filesArg = many (argument str (metavar "FILES..."))++werrorFlag :: Parser Bool+werrorFlag = switch (long "Werror" <> help "Treat warnings as errors")++replParser :: Parser Command+replParser =+  Repl+    <$> ( ReplOpts+            <$> switch (long "quiet" <> help "Suppress prompt and warnings")+            <*> werrorFlag+        )+    <*> filesArg++runParser :: Parser Command+runParser =+  Run+    <$> ( RunOpts+            <$> fmap T.pack (strOption (short 'g' <> metavar "GOAL" <> help "Goal to execute"))+            <*> switch (long "show-bindings" <> help "Print variable bindings")+            <*> werrorFlag+        )+    <*> filesArg++targetReader :: ReadM Target+targetReader = eitherReader $ \t -> case t of+  "vm" -> Right TargetVM+  "scheme" -> Right TargetScheme+  _ -> Left ("Unknown target: " ++ t ++ " (valid targets: vm, scheme)")++compileParser :: Parser Command+compileParser =+  Compile+    <$> ( CompileOpts+            <$> strOption+              ( long "output-dir"+                  <> short 'd'+                  <> metavar "DIR"+                  <> help "Output directory"+                  <> value "."+              )+            <*> optional+              ( strOption+                  ( short 'n'+                      <> long "base-name"+                      <> metavar "NAME"+                      <> help "Base name for generated files (default: program)"+                  )+              )+            <*> option+              targetReader+              ( short 't'+                  <> metavar "TARGET"+                  <> help "Target (vm, scheme)"+                  <> value TargetVM+              )+            <*> werrorFlag+        )+    <*> filesArg++genDriverParser :: Parser Command+genDriverParser =+  GenDriver+    <$> ( GenDriverOpts+            <$> fmap T.pack (strOption (short 'g' <> metavar "GOAL" <> help "Goal to execute"))+            <*> werrorFlag+        )+    <*> filesArg++checkParser :: Parser Command+checkParser = Check <$> (CheckOpts <$> werrorFlag) <*> filesArg++commandParser :: Parser Command+commandParser =+  subparser+    ( command+        "repl"+        ( info+            (replParser <**> helper)+            ( progDesc+                "Start the interactive REPL (default)"+            )+        )+        <> command "run" (info (runParser <**> helper) (progDesc "Compile and run a goal"))+        <> command+          "compile"+          ( info+              (compileParser <**> helper)+              ( progDesc+                  "Compile to a target format"+              )+          )+        <> command+          "gen-driver"+          ( info+              (genDriverParser <**> helper)+              ( progDesc+                  "Generate a Scheme driver script for a goal"+              )+          )+        <> command "check" (info (checkParser <**> helper) (progDesc "Type-check the program"))+    )+    <|> replParser++main :: IO ()+main = do+  cmd <- execParser (info (commandParser <**> helper) (fullDesc <> progDesc "CHR compiler"))+  case cmd of+    Repl opts files -> Repl.runRepl hostCalls opts.quiet opts.werror files+    Run opts files -> runGoal opts files+    Compile opts files -> runCompile opts files+    GenDriver opts files -> runGenDriver opts files+    Check opts files -> runCheck opts files++-- ---------------------------------------------------------------------------+-- Subcommands+-- ---------------------------------------------------------------------------++runGoal :: RunOpts -> [FilePath] -> IO ()+runGoal opts files = withCompiled False files $ \prog warnings -> do+  printWarnings warnings+  typeCheckOrExit prog+  prepResult <- try @SomeException (prepareGoal prog opts.goal)+  case prepResult of+    Left exc -> reportErrorAndExit exc+    Right (constraint, goalWarnings) -> do+      printWarnings goalWarnings+      exitOnWerror opts.werror (warnings ++ goalWarnings)+      outcome <- try @SomeException (runPreparedGoal prog hostCalls constraint)+      case outcome of+        Left exc -> reportErrorAndExit exc+        Right bindings ->+          when opts.showBindings (putStr (prettyBindings bindings))+  where+    reportErrorAndExit exc = do+      case fromException exc of+        Just err -> hPutStr stderr (displayMsg (err :: Error))+        Nothing -> hPutStr stderr ("Error: " ++ displayException exc ++ "\n")+      exitFailure++runCompile :: CompileOpts -> [FilePath] -> IO ()+runCompile opts files = withCompiled False files $ \prog warnings -> do+  printWarnings warnings+  typeCheckOrExit prog+  exitOnWerror opts.werror warnings+  let vmp =+        VMProgram+          { program = prog.program,+            exportedSet = prog.exportedSet,+            symbolTable = prog.symbolTable+          }+      name = maybe (T.pack "program") T.pack opts.baseName+  case opts.target of+    TargetVM -> do+      let outPath = opts.outputDir </> T.unpack name ++ ".vm"+      TIO.writeFile outPath (serialize vmp)+      putStrLn outPath+    TargetScheme -> do+      unless (isValidSchemeIdentifier name) $ do+        hPutStr+          stderr+          ( "Error: --base-name "+              ++ show (T.unpack name)+              ++ " is not a valid Scheme identifier; the Scheme target uses\n"+              ++ "       it as the library's final segment and as the exported\n"+              ++ "       program-info binding name.\n"+          )+        exitFailure+      let libName = [T.pack "ychr", T.pack "generated", name]+          outPath = opts.outputDir </> "ychr" </> "generated" </> T.unpack name ++ ".sls"+      createDirectoryIfMissing True (takeDirectory outPath)+      TIO.writeFile outPath (generateScheme libName vmp)+      putStrLn outPath+      schemeRuntimeNote++runGenDriver :: GenDriverOpts -> [FilePath] -> IO ()+runGenDriver opts files = withCompiled False files $ \prog warnings -> do+  printWarnings warnings+  typeCheckOrExit prog+  Constraint cname cargs <- case parseConstraintWith prog.opTable "<query>" opts.gdGoal of+    Left err -> do+      putStr (displayMsg (ParseError "<query>" err))+      exitFailure+    Right parsed -> case either goalShapeConstraint Right parsed of+      Left validErr -> do+        putStr (displayMsg (ParseValidationErrors [validErr]))+        exitFailure+      Right c -> pure c+  -- Canonicalize bare data-constructor references in the goal's+  -- arguments so they reach the runtime in the same flat-functor+  -- form the compiled head patterns expect.+  (renamedArgs, goalWarnings) <- case renameQueryArgs prog.allModules cargs of+    Left errs -> do+      putStr (displayMsg (RenameErrors errs))+      exitFailure+    Right (rs, ws) -> do+      let gws = [RenameWarnings ws | not (null ws)]+      printWarnings gws+      pure (rs, gws)+  outcome <-+    try @SomeException+      (resolveQueryTellOrThrow prog (Constraint cname renamedArgs))+  (qn, exprs) <- case outcome of+    Left e -> case fromException e of+      Just (err :: Error) -> do+        putStr (displayMsg err)+        exitFailure+      Nothing -> do+        hPutStr stderr ("Error: " ++ displayException e ++ "\n")+        exitFailure+    Right pair -> pure pair+  -- Combine file-level and goal-level warnings into a single Werror+  -- decision so a single run reports every warning before exiting.+  exitOnWerror opts.werror (warnings ++ goalWarnings)+  TIO.putStr (generateDriver (T.pack "program") qn exprs)+  schemeRuntimeNote++runCheck :: CheckOpts -> [FilePath] -> IO ()+runCheck opts files = withCompiled False files $ \prog warnings -> do+  printWarnings warnings+  typeCheckOrExit prog+  exitOnWerror opts.werror warnings++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++-- | Point at the Scheme runtime after emitting Scheme.+--+-- Generated code imports @(ychr runtime)@ and friends, which live in+-- @scheme\/@ in the YCHR source tree rather than in the installed+-- package — so an installed @ychr@ can emit Scheme it cannot itself run.+-- Written to stderr to keep stdout a clean list of generated paths (or,+-- for @gen-driver@, the driver source).+schemeRuntimeNote :: IO ()+schemeRuntimeNote =+  hPutStr stderr $+    "Note: the generated code imports the YCHR Scheme runtime\n"+      ++ "      ((ychr runtime) and friends). That runtime is not installed\n"+      ++ "      with this program; it lives in scheme/ in the YCHR source\n"+      ++ "      tree. Add that directory to your Scheme library path to run\n"+      ++ "      the output. See docs/how-to/scheme-repl.md.\n"++-- | Compile @files@ (or an empty program if @files@ is empty) and+-- pass the resulting 'CompiledProgram' and warnings to the+-- continuation. On compilation failure, print the diagnostic to+-- stdout and exit non-zero — the continuation does not run.+withCompiled :: Bool -> [FilePath] -> (CompiledProgram -> [Warning] -> IO ()) -> IO ()+withCompiled stdlib files k = do+  result <- compileFiles stdlib files+  case result of+    Left err -> do+      putStr (displayMsg err)+      exitFailure+    Right (prog, warnings) -> k prog warnings++-- | Type-check the compiled program. If errors are found, print them+-- to stderr and exit non-zero; otherwise return cleanly.+typeCheckOrExit :: CompiledProgram -> IO ()+typeCheckOrExit prog = do+  errs <- typeCheckProgram prog.desugaredProgram+  unless (null errs) $ do+    mapM_ (hPutStr stderr . displayMsg) errs+    exitFailure++printWarnings :: [Warning] -> IO ()+printWarnings = mapM_ (hPutStr stderr . displayMsg)++exitOnWerror :: Bool -> [Warning] -> IO ()+exitOnWerror enabled ws = when (enabled && not (null ws)) exitFailure++hostCalls :: HostCallRegistry+hostCalls = baseHostCallRegistry <> metaHostCallRegistry
+ bench/Main.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Criterion benchmarks for the YCHR Haskell interpreter.+--+-- Each benchmark loads a CHR program and its matching goal from+-- @test/golden/<name>/@ once at startup, then measures only the call to+-- 'runProgramWithGoalDSL' — i.e. the actual VM execution with runtime+-- initialization, excluding parsing, renaming, desugaring, and CHR-to-VM+-- compilation.+module Main (main) where++import Criterion.Main+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import System.FilePath ((<.>), (</>))+import YCHR.Internal.Compile.Pipeline (CompiledProgram (..))+import YCHR.Internal.Meta (metaHostCallRegistry)+import YCHR.Internal.Parser (parseConstraint)+import YCHR.Internal.Rename (renameQueryArgs)+import YCHR.Internal.Runtime.Interpreter (baseHostCallRegistry)+import YCHR.Internal.Runtime.Registry (HostCallRegistry)+import YCHR.Run+  ( compileFiles,+    runProgramWithGoalDSL,+  )+import YCHR.Types (Constraint (..))++-- | A benchmark case after all setup work is complete.+data BenchCase = BenchCase+  { name :: String,+    program :: CompiledProgram,+    goal :: Constraint+  }++-- | Programs to benchmark. Each entry is a golden-test directory name+-- under @test/golden@; the harness loads @<name>/<name>.chr@ and+-- @<name>/<name>.goal@ from there.+benchmarkPrograms :: [String]+benchmarkPrograms =+  [ "guard",+    "leq",+    -- Transitive-closure leq: a store-heavy workload whose activations run+    -- the partner searches in occurrences 2-7 rather than early-dropping on+    -- reflexivity, so it exercises the passive-occurrences optimization+    -- (unlike the "leq" case, whose leq(X, X) goal fires reflexivity first).+    "leq_closure",+    "fib",+    "sum_list_test",+    "graph_test",+    "lambda_test"+  ]++goldenDir :: FilePath+goldenDir = "test/golden"++-- | Load a program and parse its goal. All work here is done once, at+-- startup, and is NOT measured by criterion.+loadCase :: String -> IO BenchCase+loadCase name = do+  let chrPath = goldenDir </> name </> name <.> "chr"+      goalPath = goldenDir </> name </> name <.> "goal"+  result <- compileFiles False [chrPath]+  prog <- case result of+    Left err -> fail ("compile failed for " ++ name ++ ": " ++ show err)+    Right (p, _warnings) -> pure p+  goalText <- TIO.readFile goalPath+  Constraint cname cargs <- case parseConstraint "<bench>" (T.strip goalText) of+    Left err -> fail ("goal parse failed for " ++ name ++ ": " ++ show err)+    Right (Left validErr) -> fail ("goal parse failed for " ++ name ++ ": " ++ show validErr)+    Right (Right c) -> pure c+  -- Mirror the query-side canonicalization that runProgramWithGoal does+  -- (rename bare data-constructor references) so the goal's term shapes+  -- match the compiled head patterns. Name resolution to a qualified+  -- form is handled inside 'runProgramWithGoalDSL'.+  renamedArgs <- case renameQueryArgs prog.allModules cargs of+    Left errs -> fail ("goal rename failed for " ++ name ++ ": " ++ show errs)+    Right (args, _warnings) -> pure args+  pure (BenchCase name prog (Constraint cname renamedArgs))++-- | The host call registry used by all benchmarks. Same combination as the+-- golden test harness in @test/YCHR/GoldenTest.hs@.+benchHostCalls :: HostCallRegistry+benchHostCalls = baseHostCallRegistry <> metaHostCallRegistry++-- | Build one criterion benchmark for a loaded case.+makeBench :: BenchCase -> Benchmark+makeBench bc =+  bench bc.name $+    whnfIO (runProgramWithGoalDSL bc.program benchHostCalls bc.goal)++main :: IO ()+main = do+  cases <- traverse loadCase benchmarkPrograms+  defaultMain (map makeBench cases)
+ examples/bakery.chr view
@@ -0,0 +1,20 @@+% A toy CHR program: a cake recipe.+%+% The rule head requires three eggs and one each of milk, flour, and+% sugar in the constraint store, plus a `bake` trigger. When all are+% present, the rule fires and replaces them with a single `cake`.+%+% Used by docs/tutorials/01-getting-started.md and+% docs/tutorials/03-your-first-program.md.++:- module(bakery).++:- chr_constraint+    egg/0, glass_of_milk/0, glass_of_flour/0, glass_of_sugar/0,+    bake/0, cake/0.++cake_recipe @+    egg, egg, egg,+    glass_of_milk, glass_of_flour, glass_of_sugar,+    bake+  <=> cake.
+ examples/clamp.chr view
@@ -0,0 +1,12 @@+% A two-rule example demonstrating guards.+%+% Both rules have the same head shape; their guards decide which one+% fires. clamp(X, Lo, R) binds R to Lo if X < Lo, otherwise to X.+%+% Used by docs/tutorials/02-chr-primer.md §4.++:- module(clamp, [clamp/3]).+:- chr_constraint clamp/3.++low  @ clamp(X, Lo, R) <=> X < Lo  | R = Lo.+high @ clamp(X, Lo, R) <=> X >= Lo | R = X.
+ examples/closures.chr view
@@ -0,0 +1,28 @@+% Anonymous lambdas, function references, and closures.+%+% `double/1` is an ordinary function. `make_adder/1` returns a+% *closure*: a lambda that captures the argument N from its enclosing+% scope. Both are invoked via the prelude's `call/2`, which applies+% any callable value to its argument.+%+% Three constraints each demonstrate one form of callable:+%   - by_ref(R):  pass an existing function by reference.+%   - lambda(R):  pass an anonymous lambda.+%   - closure(R): build a closure with make_adder, then call it.+%+% Used by docs/tutorials/04-functions-and-types.md §3.++:- module(callables,+          [by_ref/1, lambda/1, closure/1,+           fun double/1, fun make_adder/1]).+:- chr_constraint by_ref/1, lambda/1, closure/1.+:- function double/1.+:- function make_adder/1.++double(X) -> X + X.++make_adder(N) -> fun(X) -> X + N end.++by_ref(R)  <=> R is call(fun double/1, 21).+lambda(R)  <=> R is call(fun(X) -> X * X end, 7).+closure(R) <=> Add10 is make_adder(10), R is call(Add10, 5).
+ examples/factorial.chr view
@@ -0,0 +1,16 @@+% A user-defined function: factorial.+%+% Two equations, tried top-to-bottom. The first matches only when the+% argument is the integer 0. The second matches any N and uses a guard+% N > 0 to exclude negatives.+%+% Used by docs/tutorials/04-functions-and-types.md §1 and §2.++:- module(factorial, [compute/2, fun factorial/1]).+:- chr_constraint compute(int, int).+:- function factorial(int) -> int.++factorial(0)         -> 1.+factorial(N) | N > 0 -> N * factorial(N - 1).++compute(N, R) <=> R is factorial(N).
+ examples/fib.chr view
@@ -0,0 +1,17 @@+% Fibonacci as a function, called from a constraint's rule body.+%+% Three equations: two base cases and one recursive case guarded by+% N > 1. The constraint `compute(N, R)` binds R to fib(N) using the+% `is` operator, which evaluates its right-hand side as an expression.+%+% Used by docs/tutorials/04-functions-and-types.md §1.++:- module(fib, [compute/2, fun fib/1]).+:- chr_constraint compute(int, int).+:- function fib(int) -> int.++fib(0) -> 0.+fib(1) -> 1.+fib(N) | N > 1 -> fib(N - 1) + fib(N - 2).++compute(N, R) <=> R is fib(N).
+ examples/gcd.chr view
@@ -0,0 +1,13 @@+% Euclid's algorithm as two CHR rules.+%+% Tell gcd(N) for each input number; the rules repeatedly replace the+% larger of two numbers with their difference and drop zeros, until a+% single gcd(G) remains in the store.+%+% Used by docs/explanation/what-is-chr.md.++:- module(gcd, [gcd/1]).+:- chr_constraint gcd/1.++zero     @ gcd(0) <=> true.+subtract @ gcd(N) \ gcd(M) <=> M >= N, N > 0 | gcd(M - N).
+ examples/leq.chr view
@@ -0,0 +1,19 @@+% The canonical CHR example: a less-or-equal solver.+%+% Four rules cover the structural properties of a partial order:+%   - reflexivity:   leq(X, X) is trivially true.+%   - antisymmetry:  leq(X, Y) and leq(Y, X) force X = Y.+%   - idempotence:   two copies of leq(X, Y) collapse to one+%                    (simpagation: keep the left, remove the right).+%   - transitivity:  leq(X, Y) and leq(Y, Z) propagate leq(X, Z).+%+% Used by docs/tutorials/02-chr-primer.md as the worked example for+% all three rule kinds (simplification, simpagation, propagation).++:- module(order, [leq/2]).+:- chr_constraint leq/2.++reflexivity   @ leq(X, X) <=> true.+antisymmetry  @ leq(X, Y), leq(Y, X) <=> X = Y.+idempotence   @ leq(X, Y) \ leq(X, Y) <=> true.+transitivity  @ leq(X, Y), leq(Y, Z) ==> leq(X, Z).
+ examples/stlc/Embed.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Compile-time embedding of the inferencer source, so the example+-- binary is self-contained (no cwd-relative @.chr@ path at run time).+-- Mirrors the pattern used by the built-in type checker in+-- "YCHR.Internal.TypeCheck.TH".+module Embed+  ( stlcPath,+    stlcSource,+  )+where++import Data.Text (Text)+import Data.Text.IO qualified as TIO+import Language.Haskell.TH (Exp, Q)+import Language.Haskell.TH.Syntax (addDependentFile, lift, runIO)++-- | Path of the inferencer source, relative to the package root (GHC runs+-- splices with the cabal package directory as cwd). Also surfaced in+-- compile diagnostics.+stlcPath :: FilePath+stlcPath = "examples/stlc/stlc.chr"++-- | Splice yielding the inferencer source as 'Text'. 'addDependentFile'+-- makes GHC recompile the example when the @.chr@ changes.+stlcSource :: Q Exp+stlcSource = do+  addDependentFile stlcPath+  contents <- runIO (TIO.readFile stlcPath)+  lift (contents :: Text)
+ examples/stlc/Main.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | An end-to-end example of embedding a CHR module in a Haskell program.+--+-- @examples/stlc/stlc.chr@ is a Curry-style simply-typed lambda-calculus+-- type inferencer written in CHR. This driver parses a small surface+-- syntax (see "Parser"), encodes the resulting term into CHR data with the+-- @ToTerm@ instance in "Syntax", runs the @typecheck/2@ goal with+-- 'runQueryCompiled', and+-- decodes the inferred type back into a Haskell 'Type' (or a type error)+-- with 'FromTerm' — the whole round trip goes through "YCHR.Convert".+--+-- With no arguments it is a small type-inference REPL; @--demo@ prints a+-- fixed table:+--+-- > cabal run stlc-typechecker            # REPL+-- > cabal run stlc-typechecker -- --demo  # demo table+module Main (main) where++import Control.Monad (forM_, when)+import Data.Char (isSpace)+import Data.List (intercalate)+import Data.Text (Text)+import Data.Text qualified as T+import Embed (stlcPath, stlcSource)+import Parser (parseExpr)+import Syntax (Expr)+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO+  ( BufferMode (NoBuffering),+    hFlush,+    hIsTerminalDevice,+    hPutStrLn,+    hSetBuffering,+    isEOF,+    stderr,+    stdin,+    stdout,+  )+import YCHR+  ( CompiledProgram,+    FromTerm (..),+    Name (..),+    Term (..),+    argAt,+    compileModules,+    compound,+    decodeSum,+    displayError,+    quote,+    runQueryCompiled,+  )++-- ---------------------------------------------------------------------------+-- Decoding the result+-- ---------------------------------------------------------------------------++data Type+  = TInt+  | TArrow Type Type+  | TVar Int++-- | Decode a @ty@ term. The functor is matched on its local name, so the+-- module-qualified @stlc:arrow@ that comes back still decodes.+instance FromTerm Type where+  fromTerm =+    decodeSum+      [ ("tint", 0, \_ -> Right TInt),+        ("arrow", 2, \as -> TArrow <$> argAt 0 as <*> argAt 1 as),+        ("tvar", 1, \as -> TVar <$> argAt 0 as)+      ]++-- | The inferencer answers with @ok(Type)@ or @type_error(Errors)@. The+-- error list is kept as raw 'Term's (they mention pre-generalization type+-- variables that would not decode as a ground 'Type') and rendered below.+data TCResult+  = Ok Type+  | Ill [Term]++instance FromTerm TCResult where+  fromTerm =+    decodeSum+      [ ("ok", 1, \as -> Ok <$> argAt 0 as),+        ("type_error", 1, \as -> Ill <$> argAt 0 as)+      ]++-- ---------------------------------------------------------------------------+-- Driver+-- ---------------------------------------------------------------------------++main :: IO ()+main = do+  args <- getArgs+  cp <- loadInferencer+  case args of+    ["--demo"] -> runDemo cp+    [] -> runRepl cp+    _ -> hPutStrLn stderr "usage: stlc-typechecker [--demo]" >> exitFailure++-- | Compile the embedded inferencer once; reuse it across every query.+loadInferencer :: IO CompiledProgram+loadInferencer =+  case compileModules True [(stlcPath, $(stlcSource))] of+    Left err -> fail ("could not compile " ++ stlcPath ++ ":\n" ++ displayError err)+    Right (cp, _warnings) -> pure cp++-- | Parse, type-check, and render one line of surface syntax.+inferLine :: CompiledProgram -> String -> IO String+inferLine cp line = case parseExpr line of+  Left err -> pure ("parse error: " ++ firstLine err)+  Right e -> do+    result <- runQueryCompiled cp (typecheckGoal e) "Result"+    pure (either show renderResult result)++-- | Build the goal @typecheck(quote(<expr>), Result)@. The @quote/1@+-- form ('quote') keeps the expression symbolic: without it the argument would+-- be evaluated, and @var(\"x\")@ in particular would call the prelude's+-- @var/1@ predicate instead of naming a variable node.+typecheckGoal :: Expr -> Term+typecheckGoal e = compound "typecheck" [quote e, VarTerm "Result"]++-- ---------------------------------------------------------------------------+-- REPL+-- ---------------------------------------------------------------------------++runRepl :: CompiledProgram -> IO ()+runRepl cp = do+  hSetBuffering stdout NoBuffering+  interactive <- hIsTerminalDevice stdin+  when interactive $+    putStrLn "STLC type-inference REPL. Enter a lambda term (e.g. \\x. x + 1); :q to quit."+  loop interactive+  where+    loop interactive = do+      when interactive (putStr "stlc> ")+      hFlush stdout+      atEof <- isEOF+      if atEof+        then when interactive (putStrLn "")+        else do+          line <- getLine+          keepGoing <- step interactive line+          when keepGoing (loop interactive)++    step interactive line+      | command `elem` [":q", ":quit"] = pure False+      | null command = pure True+      | otherwise = do+          when (not interactive) (putStrLn ("stlc> " ++ line))+          inferLine cp line >>= putStrLn+          pure True+      where+        command = strip line++-- ---------------------------------------------------------------------------+-- Demo table+-- ---------------------------------------------------------------------------++runDemo :: CompiledProgram -> IO ()+runDemo cp = do+  putStrLn "Curry-style STLC type inference (via a CHR module):\n"+  forM_ demoInputs $ \s -> do+    rendered <- inferLine cp s+    putStrLn (pad 26 s ++ " :  " ++ rendered)++demoInputs :: [String]+demoInputs =+  [ "\\x. x + 1",+    "\\x. x",+    "(\\x. x + 1) 5",+    "\\x. \\y. x",+    "\\f. \\x. f (f x)",+    "let f = \\x. x + 1 in f 5",+    "\\x. x x",+    "1 2",+    "y"+  ]++-- ---------------------------------------------------------------------------+-- Rendering+-- ---------------------------------------------------------------------------++renderResult :: TCResult -> String+renderResult (Ok t) = renderType False t+renderResult (Ill errs) = "TYPE ERROR: " ++ intercalate "; " (map describeError errs)++renderType :: Bool -> Type -> String+renderType _ TInt = "int"+renderType _ (TVar n) = tyVarName n+renderType paren (TArrow a b) =+  parenthesize paren (renderType True a ++ " -> " ++ renderType False b)++-- | Render a type that is still a raw 'Term' (as it appears inside an+-- error), tolerating the unbound variables an in-progress inference leaves+-- behind.+renderTypeTerm :: Term -> String+renderTypeTerm t = case t of+  CompoundTerm n [] | localName n == "tint" -> "int"+  CompoundTerm n [IntTerm k] | localName n == "tvar" -> tyVarName (fromInteger k)+  CompoundTerm n [a, b]+    | localName n == "arrow" ->+        "(" ++ renderTypeTerm a ++ " -> " ++ renderTypeTerm b ++ ")"+  TextTerm s -> T.unpack s+  -- A type variable still unbound at the point the error was raised.+  VarTerm _ -> "_"+  Wildcard -> "_"+  _ -> "?"++describeError :: Term -> String+describeError t = case t of+  CompoundTerm n [a, b]+    | localName n == "mismatch" ->+        "cannot unify " ++ renderTypeTerm a ++ " with " ++ renderTypeTerm b+  CompoundTerm n [_, ty]+    | localName n == "infinite_type" ->+        "cannot construct the infinite type " ++ renderTypeTerm ty+  CompoundTerm n [x]+    | localName n == "unbound_variable" ->+        "unbound variable " ++ renderTypeTerm x+  _ -> "?"++-- ---------------------------------------------------------------------------+-- Small helpers+-- ---------------------------------------------------------------------------++localName :: Name -> Text+localName (Unqualified n) = n+localName (Qualified _ n) = n++tyVarName :: Int -> String+tyVarName n+  | n < 26 = [toEnum (fromEnum 'a' + n)]+  | otherwise = 't' : show n++parenthesize :: Bool -> String -> String+parenthesize True s = "(" ++ s ++ ")"+parenthesize False s = s++pad :: Int -> String -> String+pad w s = s ++ replicate (max 1 (w - length s)) ' '++strip :: String -> String+strip = f . f where f = reverse . dropWhile isSpace++-- | Collapse a multi-line parse-error message to its first non-empty line+-- so the REPL prints one tidy line.+firstLine :: String -> String+firstLine = unwords . filter (not . null) . map strip . lines
+ examples/stlc/Parser.hs view
@@ -0,0 +1,98 @@+-- | A tiny surface syntax for the lambda calculus, parsed with @parsec@.+--+-- Grammar (loosest to tightest binding):+--+-- > expr   ::= '\' ident+ '.' expr          -- lambda (body extends right)+-- >          | 'let' ident '=' expr 'in' expr+-- >          | add+-- > add    ::= app ('+' app)*               -- left-associative+-- > app    ::= atom atom*                   -- application by juxtaposition+-- > atom   ::= ident | int | '(' expr ')'+--+-- Application binds tighter than @+@, so @f x + 1@ is @(f x) + 1@; a lambda+-- body runs as far right as possible, so @\\x. x + 1@ is @\\x. (x + 1)@.+module Parser+  ( parseExpr,+  )+where++import Data.Text qualified as T+import Syntax (Expr (..))+import Text.Parsec+import Text.Parsec.Language (emptyDef)+import Text.Parsec.String (Parser)+import Text.Parsec.Token qualified as Tok++-- | Parse a single expression, or return a human-readable error.+parseExpr :: String -> Either String Expr+parseExpr input = case parse (Tok.whiteSpace lexer *> expr <* eof) "" input of+  Left err -> Left (show err)+  Right e -> Right e++-- ---------------------------------------------------------------------------+-- Lexer+-- ---------------------------------------------------------------------------++lexer :: Tok.TokenParser ()+lexer =+  Tok.makeTokenParser+    emptyDef+      { Tok.identStart = letter <|> char '_',+        Tok.identLetter = alphaNum <|> char '_',+        Tok.reservedNames = ["let", "in"],+        Tok.reservedOpNames = ["\\", ".", "+", "="]+      }++identifier :: Parser T.Text+identifier = T.pack <$> Tok.identifier lexer++reserved :: String -> Parser ()+reserved = Tok.reserved lexer++reservedOp :: String -> Parser ()+reservedOp = Tok.reservedOp lexer++parens :: Parser a -> Parser a+parens = Tok.parens lexer++natural :: Parser Integer+natural = Tok.natural lexer++-- ---------------------------------------------------------------------------+-- Grammar+-- ---------------------------------------------------------------------------++expr :: Parser Expr+expr = lambda <|> letExpr <|> addExpr++-- @\x y. e@ is sugar for @\x. \y. e@.+lambda :: Parser Expr+lambda = do+  reservedOp "\\"+  vars <- many1 identifier+  reservedOp "."+  body <- expr+  pure (foldr Lam body vars)++-- @let x = rhs in body@ desugars to @(\x. body) rhs@.+letExpr :: Parser Expr+letExpr = do+  reserved "let"+  v <- identifier+  reservedOp "="+  rhs <- expr+  reserved "in"+  body <- expr+  pure (App (Lam v body) rhs)++addExpr :: Parser Expr+addExpr = chainl1 appExpr (reservedOp "+" >> pure Add)++appExpr :: Parser Expr+appExpr = foldl1 App <$> many1 atom++atom :: Parser Expr+atom =+  parens expr+    <|> (Var <$> identifier)+    <|> (IntLit <$> natural)
+ examples/stlc/Syntax.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}++-- | The object language shared by the parser and the driver. Kept in its+-- own module so "Parser" and "Main" can both import it without a cycle;+-- the 'ToTerm' instance lives here too (with the type it encodes) so it is+-- not an orphan.+module Syntax+  ( Expr (..),+  )+where++import Data.Text (Text)+import YCHR (ToTerm (..), compound)++-- | Unannotated lambda terms. @let x = e1 in e2@ is desugared by the+-- parser to @(\\x. e2) e1@, so it needs no constructor of its own.+data Expr+  = Var Text+  | Lam Text Expr+  | App Expr Expr+  | IntLit Integer+  | Add Expr Expr+  deriving (Eq, Show)++-- | Encode a term as the CHR data the inferencer matches on. These are+-- plain compounds (@var@, @lam@, …), which the driver passes in quoted+-- with @quote/1@ so they are treated as data rather than evaluated.+instance ToTerm Expr where+  toTerm (Var x) = compound "var" [toTerm x]+  toTerm (Lam x body) = compound "lam" [toTerm x, toTerm body]+  toTerm (App f a) = compound "app" [toTerm f, toTerm a]+  toTerm (IntLit n) = compound "lit_int" [toTerm n]+  toTerm (Add a b) = compound "add" [toTerm a, toTerm b]
+ examples/stlc/stlc.chr view
@@ -0,0 +1,195 @@+% A Curry-style simply-typed lambda-calculus type inferencer, written+% entirely in CHR.+%+% This is the CHR half of an end-to-end embedding example: the Haskell+% driver in examples/stlc/Main.hs encodes lambda terms as CHR terms,+% tells `typecheck/2`, and decodes the inferred type (or the type errors)+% back into Haskell values through YCHR.Convert.+%+% Type inference *is* constraint solving, so it maps directly onto CHR:+%   - a fresh type variable is just an unbound logical variable, created+%     for free whenever a rule body mentions a new variable;+%   - unification of type structures is a handful of simplification rules;+%   - the typing context and the accumulated errors live in the store.+%+% The object language (built by the Haskell side):+%   var(Name)        a variable reference        (Name is a string)+%   lam(Name, Body)  an *unannotated* lambda      (argument type inferred)+%   app(F, X)        application+%   lit_int(N)       an integer literal+%   add(A, B)        integer addition             (forces both sides to int)+%+% The type language (`ty`, below):+%   tint             the base type of integers+%   arrow(S, T)      a function type+%   tvar(N)          a numbered type variable, produced only at the very+%                    end by `number_vars` so that a polymorphic result+%                    such as `arrow(tvar(0), tvar(0))` can be printed and+%                    decoded with its sharing intact.++:- module(stlc, [typecheck/2]).+:- use_module(library(prelude)).++% The object language is *host-supplied data*: the Haskell driver builds+% these compounds and passes them in (wrapped in `quote/1`, so they are+% never evaluated as calls — `var/1`, in particular, is also a prelude+% predicate). They are matched structurally in rule heads and so are left+% as ordinary (undeclared) functors rather than `:- chr_type` constructors:+%   var(Name)  lam(Name, Body)  app(F, X)  lit_int(N)  add(A, B)+% Because they are undeclared, `ychr check` reports each one as an+% "undeclared data constructor" (YCHR-20101); that is expected here — these+% are an opaque interchange format for the host, not types this module owns.+%+% The type language, by contrast, is built and matched entirely inside+% this module, so it is a proper declared type. `tvar` is produced only by+% `number_vars`, at the very end.+:- chr_type ty ---> tint ; arrow(ty, ty) ; tvar(int).++% The two possible results of inference (decoded on the Haskell side).+:- chr_type tc_result ---> ok(ty) ; type_error(list(any)).++% Entry point. `Result` is unified with `ok(Type)` when inference+% succeeds, or `type_error(Errors)` when it does not.+:- chr_constraint+    typecheck(any, tc_result),+    typeof(any, any, ty),+    lookup_ty(any, any, ty),+    unify_ty(ty, ty),+    bind_ty(ty, ty),+    number_vars(ty),+    assign_tvars(any, int),+    finish(any, ty, tc_result),+    report_error(any),+    errors(any),+    collect(any).++% ==========================================================================+% Driver+% ==========================================================================+%+% Seed an empty error accumulator, infer the type of the expression in the+% empty context, then read the accumulated errors back out and build the+% result. Body goals run to completion left-to-right, so by the time+% `collect` fires every error `typeof` could raise has already landed in+% `errors`.++typecheck(Expr, Result) <=>+    errors([]),+    typeof([], Expr, T),+    collect(Es),+    finish(Es, T, Result).++% No errors: ground the residual type variables and report the type.+finish_ok @  finish([], T, Result) <=> number_vars(T), Result = ok(T).+% At least one error: report them, leaving the (partial) type untouched.+finish_err @ finish([E | Es], _, Result) <=> Result = type_error([E | Es]).++% ==========================================================================+% Typing rules: typeof(Env, Expr, T)+% ==========================================================================+%+% Env is an association list of `bind(Name, Type)` cells. Each rule is a+% simplification: the `typeof` goal is consumed and replaced by the+% subgoals that decompose it. Variables first mentioned in a body (A, B,+% TF, TA below) are fresh type variables.++typeof_int @ typeof(_, lit_int(_), T) <=> unify_ty(T, tint).++typeof_add @ typeof(Env, add(A, B), T) <=>+    typeof(Env, A, TA),+    typeof(Env, B, TB),+    unify_ty(TA, tint),+    unify_ty(TB, tint),+    unify_ty(T, tint).++typeof_var @ typeof(Env, var(X), T) <=> lookup_ty(Env, X, T).++% `Env2 = [...]` introduces the fresh argument-type variable A: a bare+% unbound variable may not first appear nested inside a constraint tell+% (whose arguments are evaluated), but `=` is pure unification and binds+% the new variables in its operands.+typeof_lam @ typeof(Env, lam(X, Body), T) <=>+    Env2 = [bind(X, A) | Env],+    typeof(Env2, Body, B),+    unify_ty(T, arrow(A, B)).++typeof_app @ typeof(Env, app(F, Arg), T) <=>+    typeof(Env, F, TF),+    typeof(Env, Arg, TA),+    unify_ty(TF, arrow(TA, T)).++% ==========================================================================+% Context lookup: lookup_ty(Env, Name, T)+% ==========================================================================+%+% The three rules are tried top-to-bottom. In the first head the repeated+% `X` becomes an implicit equality guard, so it fires only when the head+% binding's name matches; otherwise the general second rule skips a cell.+% Reaching the empty list means the variable was never bound.++lookup_hit  @ lookup_ty([bind(X, Ty) | _], X, T) <=> unify_ty(T, Ty).+lookup_skip @ lookup_ty([bind(_, _) | Rest], X, T) <=> lookup_ty(Rest, X, T).+lookup_miss @ lookup_ty([], X, _) <=> report_error(quote(unbound_variable(X))).++% ==========================================================================+% Type unification: unify_ty(T1, T2)+% ==========================================================================+%+% A structural unifier that binds unbound type variables but *never* lets a+% raw `=` fail: an incompatible pair of concrete types is reported as an+% error instead of aborting the whole run. Variable cases bind directly+% (one side is always an unbound variable, so `=` cannot fail there).++unify_int   @ unify_ty(tint, tint) <=> true.+unify_arrow @ unify_ty(arrow(A1, R1), arrow(A2, R2)) <=>+    unify_ty(A1, A2),+    unify_ty(R1, R2).++unify_vv @ unify_ty(T1, T2) <=> var(T1), var(T2) | T1 = T2.+unify_vt @ unify_ty(T1, T2) <=> var(T1), nonvar(T2) | bind_ty(T1, T2).+unify_tv @ unify_ty(T1, T2) <=> nonvar(T1), var(T2) | bind_ty(T2, T1).+unify_bad @ unify_ty(T1, T2) <=> nonvar(T1), nonvar(T2) |+    report_error(quote(mismatch(T1, T2))).++% Bind a variable to a type, guarding against the infinite types that+% self-application (`lam(x, app(var(x), var(x)))`) would otherwise create.+bind_occurs @ bind_ty(V, Ty) <=> occurs(V, Ty) |+    report_error(quote(infinite_type(V, Ty))).+bind_ok     @ bind_ty(V, Ty) <=> V = Ty.++% ==========================================================================+% Error accumulation+% ==========================================================================+%+% Errors are prepended, so a program with several of them collects them in+% reverse (most-recent-first) order. That is invisible here — every demo+% raises at most one — but worth knowing before extending this.++accumulate @ report_error(E), errors(Es) <=> errors([E | Es]).+collect_es @ collect(Out), errors(Es) <=> Out = Es.++% ==========================================================================+% Helpers+% ==========================================================================++% occurs(V, Ty): does the unbound variable V appear anywhere in Ty? Only+% ever called on pre-`number_vars` types, whose leaves are `tint` or+% unbound variables, so the `arrow` recursion covers every compound case.+:- function occurs/2.+occurs(V, T) | V == T -> true.+occurs(_, T) | var(T) -> false.+occurs(V, arrow(A, B)) | occurs(V, A) -> true.+occurs(V, arrow(A, B)) -> occurs(V, B).+occurs(_, _) -> false.++% number_vars(T): replace every residual (still unbound) type variable in T+% with a distinct `tvar(N)`, numbered from 0 in first-occurrence order.+% `term_variables` yields each variable once, and its elements are the very+% variables inside T, so unifying them preserves sharing.+number_vars(T) <=> Vs is term_variables(T), assign_tvars(Vs, 0).++assign_nil  @ assign_tvars([], _) <=> true.+assign_cons @ assign_tvars([V | Vs], N) <=>+    V = tvar(N),+    N1 is N + 1,+    assign_tvars(Vs, N1).
+ examples/traffic.chr view
@@ -0,0 +1,18 @@+% An algebraic type with three constructors, plus a typed function+% that pattern-matches on them.+%+% The `intensity_of/2` constraint computes the intensity associated+% with each color and binds it to its second argument.+%+% Used by docs/tutorials/04-functions-and-types.md §2.++:- module(traffic, [intensity_of/2, type(color/0, [red, green, yellow])]).+:- chr_type color ---> red ; green ; yellow.+:- chr_constraint intensity_of(color, int).+:- function intensity(color) -> int.++intensity(red)    -> 100.+intensity(yellow) -> 60.+intensity(green)  -> 20.++intensity_of(C, R) <=> R is intensity(C).
+ libraries/lists.chr view
@@ -0,0 +1,71 @@+:- module(lists, [+    fun cons/2,+    fun head/1,+    fun tail/1,+    fun length/1,+    fun member/2,+    fun append/2,+    fun maplist/2,+    fun foldl/3,+    fun sum_list/1,+    fun product_list/1,+    fun nth/2+]).++:- function+    (cons(T, list(T)) -> list(T)),+    (length(list(T)) -> int),+    (member(T, list(T)) -> bool),+    (append(list(T), list(T)) -> list(T)),+    (maplist(fun(A) -> B end, list(A)) -> list(B)),+    (foldl(fun(B, A) -> B end, B, list(A)) -> B),+    (foldl_(fun(B, A) -> B end, list(A), B) -> B),+    (sum_list(list(int)) -> int),+    (product_list(list(int)) -> int).++% head/1, tail/1 and nth/2 are deliberately left untyped.+%+% They are partial -- there is no sensible `head([])` -- and the+% language currently offers no way to write the failing equation, since+% raising a runtime error from source is not expressible. A `list(T)`+% signature is what enables the exhaustiveness checker, so typing them+% would make every module that merely imports this library emit+% YCHR-20103, which is fatal under `--Werror`.+%+% Calling any of them on an empty list is a runtime error ("no matching+% equation") either way; only the static check differs.+:- function+    head/1,+    tail/1,+    nth/2.++cons(X, Xs) -> [X|Xs].++head([X|_]) -> X.++tail([_|Xs]) -> Xs.++length([]) -> 0.+length([_|Xs]) -> length(Xs) + 1.++member(_, []) -> false.+member(X, [X|_]) -> true.+member(X, [_|Xs]) -> member(X, Xs).++append([], Ys) -> Ys.+append([X|Xs], Ys) -> cons(X, append(Xs, Ys)).++maplist(_, []) -> [].+maplist(F, [X|Xs]) -> cons('$call'(F, X), maplist(F, Xs)).++foldl(F, Init, Xs) -> foldl_(F, Xs, Init).++foldl_(F, [], Acc) -> Acc.+foldl_(F, [X|Xs], Acc) -> foldl_(F, Xs, '$call'(F, Acc, X)).++sum_list(Xs) -> foldl(fun '+'/2, 0, Xs).++product_list(Xs) -> foldl(fun '*'/2, 1, Xs).++nth(0, [X|_]) -> X.+nth(N, [_|Xs]) | N > 0 -> nth(N - 1, Xs).
+ libraries/meta.chr view
@@ -0,0 +1,24 @@+:- module(meta, [+    fun print/1,+    fun read_term_from_string/1,+    fun write_term_to_string/1,+    fun write_store_to_list/0,+    fun print_store/0+]).++:- function+    (print(any) -> any),+    (print_store() -> any),+    (read_term_from_string(string) -> any),+    (write_term_to_string(any) -> string),+    (write_store_to_list() -> list(any)).++print(X) -> host:print(X).++write_term_to_string(T) -> host:write_term_to_string(T).++read_term_from_string(S) -> host:read_term_from_string(S).++write_store_to_list -> host:write_store_to_list.++print_store -> host:print_store.
+ libraries/prelude.chr view
@@ -0,0 +1,182 @@+:- module(prelude, [+    type(bool/0),+    type(list/1),+    fun '+'/2,+    fun '-'/2,+    fun '*'/2,+    fun '/'/2,+    fun 'div'/2,+    fun 'mod'/2,+    fun 'rem'/2,+    fun '<'/2,+    fun '>'/2,+    fun '>='/2,+    fun '=<'/2,+    fun '=='/2,+    fun not/1,+    fun max/2,+    fun min/2,+    fun var/1,+    fun nonvar/1,+    fun integer/1,+    fun float/1,+    fun atom/1,+    fun boolean/1,+    fun string/1,+    fun ground/1,+    fun int_to_float/1,+    fun float_to_int/1,+    fun unifiable/2,+    fun term_variables/1,+    fun compound_to_list/1,+    fun list_to_compound/1,+    fun copy_term/1,+    fun write/1,+    fun nl/0,+    fun writeln/1,+    fun call/2,+    fun call/3,+    op(500, yfx, '+'),+    op(500, yfx, '-'),+    op(400, yfx, '*'),+    op(400, yfx, '/'),+    op(400, yfx, div),+    op(400, yfx, mod),+    op(400, yfx, rem),+    op(700, xfx, '<'),+    op(700, xfx, '>'),+    op(700, xfx, '>='),+    op(700, xfx, '=<'),+    op(700, xfx, '==')+]).++:- chr_type bool ---> true ; false.++:- chr_type list(T) ---> [] ; [T|list(T)].++:- class+    ('+'(int, int) -> int),+    ('+'(float, float) -> float).+:- class+    ('-'(int, int) -> int),+    ('-'(float, float) -> float).+:- class+    ('*'(int, int) -> int),+    ('*'(float, float) -> float).+:- class+    ('<'(int, int) -> bool),+    ('<'(float, float) -> bool).+:- class+    ('>'(int, int) -> bool),+    ('>'(float, float) -> bool).+:- class+    ('>='(int, int) -> bool),+    ('>='(float, float) -> bool).+:- class+    ('=<'(int, int) -> bool),+    ('=<'(float, float) -> bool).++:- function+    ('/'(float, float) -> float),+    ('div'(int, int) -> int),+    ('mod'(int, int) -> int),+    ('rem'(int, int) -> int),+    ('=='(A, A) -> bool),+    (not(bool) -> bool),+    (var(any) -> bool),+    (nonvar(any) -> bool),+    (integer(any) -> bool),+    (float(any) -> bool),+    (atom(any) -> bool),+    (boolean(any) -> bool),+    (string(any) -> bool),+    (ground(any) -> bool),+    (int_to_float(int) -> float),+    (float_to_int(float) -> int),+    (copy_term(A) -> A),+    (unifiable(any, any) -> bool),+    term_variables/1,+    (compound_to_list(any) -> list(any)),+    (list_to_compound(list(any)) -> any),+    (call(fun(A) -> B end, A) -> B),+    (call(fun(A, B) -> C end, A, B) -> C),+    (write(string) -> any),+    (nl() -> any),+    (writeln(string) -> any).++:- function max(T, T) -> T requiring '>='(T, T) -> bool.+:- function min(T, T) -> T requiring '=<'(T, T) -> bool.++X + Y -> host:'+'(X, Y).++X - Y -> host:'-'(X, Y).++X * Y -> host:'*'(X, Y).++X / Y -> host:'/'(X, Y).++X div Y -> host:'div'(X, Y).++X mod Y -> host:'mod'(X, Y).++X rem Y -> host:'rem'(X, Y).++X < Y -> host:'<'(X, Y).++X > Y -> host:'>'(X, Y).++X >= Y -> host:'>='(X, Y).++X =< Y -> host:'=<'(X, Y).++X == Y -> host:'=='(X, Y).++% Boolean negation. There is no `\=` / `\==` operator; write the+% negation explicitly, e.g. `not(X == Y)` or `not(unifiable(X, Y))`.+not(X) -> host:not(X).++max(X, Y) | X >= Y -> X.+max(_, Y) -> Y.++min(X, Y) | X =< Y -> X.+min(_, Y) -> Y.++var(X) -> host:var(X).++nonvar(X) -> host:nonvar(X).++integer(X) -> host:integer(X).++float(X) -> host:float(X).++int_to_float(X) -> host:int_to_float(X).++float_to_int(X) -> host:float_to_int(X).++atom(X) -> host:atom(X).++boolean(X) -> host:boolean(X).++string(X) -> host:string(X).++ground(X) -> host:ground(X).++unifiable(X, Y) -> host:unifiable(X, Y).++term_variables(T) -> host:term_variables(T).++compound_to_list(C) -> host:compound_to_list(C).++list_to_compound(Xs) -> host:list_to_compound(Xs).++write(S) -> host:write(S).++nl -> host:write("\n").++writeln(S) -> host:writeln(S).++copy_term(T) -> host:copy_term(T).++call(F, X) -> '$call'(F, X).++call(F, X, Y) -> '$call'(F, X, Y).
+ libraries/strings.chr view
@@ -0,0 +1,20 @@+:- module(strings, [+    fun string_concat/2,+    fun string_length/1,+    fun string_upper/1,+    fun string_lower/1+]).++:- function+    (string_concat(string, string) -> string),+    (string_length(string) -> int),+    (string_upper(string) -> string),+    (string_lower(string) -> string).++string_concat(X, Y) -> host:string_concat(X, Y).++string_length(S) -> host:string_length(S).++string_upper(S) -> host:string_upper(S).++string_lower(S) -> host:string_lower(S).
+ src/YCHR.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE OverloadedStrings #-}++-- | The entry point for embedding YCHR as a Haskell library.+--+-- This umbrella module gathers the common /compile-and-query/ surface into+-- a single import: compile a CHR program (from @.chr@ files or in-memory+-- sources), run goals against it, and marshal ordinary Haskell values in+-- and out with 'ToTerm' / 'FromTerm'. For most embedders,+--+-- > import YCHR+--+-- is all that is needed.+--+-- = Worked example: compile once, query many+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import System.IO (hPutStr, stderr)+-- > import YCHR+-- >+-- > main :: IO ()+-- > main =+-- >   case compileModules True [("Order.chr", source)] of+-- >     Left err -> hPutStr stderr (displayError err)+-- >     Right (cp, _warnings) -> do+-- >       -- goal is a 'Term'; decode the "R" binding as a Haskell Int+-- >       r <- runQueryCompiled cp goal "R"+-- >       print (r :: Either ConvertError Int)+-- >   where+-- >     source = "..."               -- CHR source text+-- >     goal   = CompoundTerm (Unqualified "compute") [VarTerm "R"]+--+-- = Opt-in companions+--+-- Two capabilities live in their own modules and are intentionally /not/+-- re-exported here:+--+--   * "YCHR.DSL" — build CHR programs in Haskell (rules, functions, type+--     declarations) without @.chr@ source, using a combinator vocabulary+--     with operators. Import it directly when you construct programs+--     rather than load them. Its @Module@ values are queried with+--     'YCHR.Convert.runQuery' \/ 'YCHR.Convert.runQueryWith' \/+--     'YCHR.Convert.runQueryWithHostCallRegistry', which live in+--     "YCHR.Convert" alongside the DSL rather than here — this umbrella+--     covers the @.chr@-source path only.+--+--   * "YCHR.Convert.Generic" (GHC only) — @genericToTerm@ /+--     @genericFromTerm@ for @deriving 'GHC.Generics.Generic'@ types. It is+--     GHC-only; this umbrella and the core "YCHR.Convert" stay+--     @Generic@-free so they remain usable on every backend.+--+-- = Registering host functions+--+-- A @host:f(args)@ call in a CHR program is resolved against a+-- 'HostCallRegistry'. Beyond the built-ins, you can register your own by+-- lifting ordinary Haskell functions with 'hostFn1' \/ 'hostFn2' \/ … (or+-- their effectful @…M@ variants), assembling a registry with+-- 'withDefaultHostFunctions', and running with the+-- @…WithHostCallRegistry@ query variants:+--+-- > registry :: HostCallRegistry+-- > registry = withDefaultHostFunctions+-- >   [ ("my_add", hostFn2 ((+) :: Int -> Int -> Int)) ]  -- called as host:my_add(X, Y)+-- >+-- > main = do+-- >   r <- runQueryCompiledWithHostCallRegistry registry cp goal (decodeVar "R")+-- >   print (r :: Either ConvertError Int)+--+-- User entries override built-ins of the same name. Arguments and results+-- marshal through 'ToTerm' \/ 'FromTerm'; for I\/O or logic-variable access+-- use the @…M@ adapters (the body runs in 'Chr') or the raw 'hostFnValues'+-- escape hatch.+--+-- Other lower-level entry points — the raw CHR session API, the multi-goal+-- query API, the compiler pipeline internals — remain available by+-- importing "YCHR.Run", "YCHR.Convert", and the internal @YCHR.*@ modules+-- directly.+module YCHR+  ( -- * Compiling a program+    compileFiles,+    compileModules,+    CompiledProgram,+    Error (..),+    Warning (..),+    displayError,+    displayWarning,++    -- * Typed queries+    runQueryCompiled,+    runQueryCompiledWith,+    runQueryCompiledWithHostCallRegistry,++    -- * Raw-goal queries+    runProgramWithGoal,++    -- * Value marshalling+    ToTerm (..),+    FromTerm (..),+    ConvertError (..),++    -- ** Combinators for hand-written instances+    compound,+    atomTerm,+    matchCompound,+    decodeSum,+    argAt,+    ground,++    -- ** The quote/1 quoting form+    quote,++    -- ** Result decoding+    decodeVar,+    decodeVarMaybe,+    lookupBinding,++    -- * Host functions+    HostCallRegistry,+    baseHostCallRegistry,+    HostCallFn (..),+    hostFunctions,+    withDefaultHostFunctions,+    hostFn0M,+    hostFn1,+    hostFn1M,+    hostFn2,+    hostFn2M,+    hostFn3,+    hostFn3M,+    hostFnN,+    hostFnValues,+    Chr,+    Value (..),++    -- ** Inspecting runtime values+    -- $runtimeValues+    deref,+    equal,+    newVar,++    -- * Core term types+    Term (..),+    Name (..),+  )+where++import YCHR.Convert+  ( Chr,+    ConvertError (..),+    FromTerm (..),+    HostCallFn (..),+    HostCallRegistry,+    ToTerm (..),+    Value (..),+    argAt,+    atomTerm,+    baseHostCallRegistry,+    compound,+    decodeSum,+    decodeVar,+    decodeVarMaybe,+    ground,+    hostFn0M,+    hostFn1,+    hostFn1M,+    hostFn2,+    hostFn2M,+    hostFn3,+    hostFn3M,+    hostFnN,+    hostFnValues,+    hostFunctions,+    lookupBinding,+    matchCompound,+    quote,+    runQueryCompiled,+    runQueryCompiledWith,+    runQueryCompiledWithHostCallRegistry,+    withDefaultHostFunctions,+  )+import YCHR.Run+  ( CompiledProgram,+    Error (..),+    Warning (..),+    compileFiles,+    compileModules,+    deref,+    displayError,+    displayWarning,+    equal,+    newVar,+    runProgramWithGoal,+  )+import YCHR.Types (Name (..), Term (..))++-- $runtimeValues+-- A 'hostFnValues' handler receives raw 'Value's, which may be logical+-- variables that are bound to something else. Inspect them with these,+-- all of which run in 'Chr':+--+--   * 'deref' — follow a variable chain to the value it is bound to (or to+--     the unbound variable at the end). Call this before pattern-matching+--     on a 'Value' constructor, or a bound variable will look like a+--     'VVar' rather than its binding.+--+--   * 'equal' — CHR's @==@ (\"ask\") semantics: structural equality that+--     never binds, and where two distinct unbound variables compare+--     unequal. This is the correct comparison for 'Value'; there is+--     deliberately no 'Eq' instance, since a derived one would compare+--     variables by reference and silently disagree with the language.+--+--   * 'newVar' — allocate a fresh unbound logical variable.+--+-- The @hostFn1@ \/ @hostFn2@ \/ … adapters dereference for you, so reach+-- for these only with the raw 'hostFnValues' escape hatch.+--+-- Binding is deliberately not offered here. @unify@ (in "YCHR.Run")+-- returns the constraints that observe the variables it bound, and the+-- caller must hand them to the reactivation queue or those constraints+-- silently never wake up. Returning a value from your handler and letting+-- the generated code do the unification is the safe path; reach for+-- "YCHR.Run" only if you are driving a session yourself.
+ src/YCHR/Convert.hs view
@@ -0,0 +1,651 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | An ergonomic bridge between ordinary Haskell data types and CHR+-- terms. Use it when @ychr@ is embedded as a library and you would rather+-- pass and receive Haskell values than hand-build and pattern-match+-- 'Term's.+--+-- This module is a companion to "YCHR.DSL": the DSL builds CHR /programs/,+-- while this module converts /values/ at the program boundary. The library+-- boundary is entirely the pure 'Term' type — a goal is a 'Term', and a+-- result is a @'Map' 'Text' 'Term'@ keyed by goal-variable name — so both+-- classes target 'Term' and never touch the runtime value representation.+--+-- = Worked example+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import YCHR.Convert+-- > import YCHR.DSL (module', declaring, defining, term, var, int, (@:), (<=>), (|-))+-- >+-- > -- run a program and decode the "R" binding as a Haskell Int+-- > main = do+-- >   r <- runQuery [myModule] (term "compute" [var "R"]) "R"+-- >   print (r :: Either ConvertError Int)+--+-- = Generic derivation+--+-- Hand-writing instances is optional. Under GHC, "YCHR.Convert.Generic"+-- provides @genericToTerm@ / @genericFromTerm@ so a @deriving 'GHC.Generics.Generic'@+-- type gets instances for free. That module is GHC-only; this one carries+-- no @Generic@ dependency and provides the hand-written path.+module YCHR.Convert+  ( -- * Classes+    ToTerm (..),+    FromTerm (..),++    -- * Errors+    ConvertError (..),++    -- * Combinators for hand-written instances+    compound,+    atomTerm,+    matchCompound,+    decodeSum,+    argAt,+    ground,++    -- * The quote/1 quoting form+    quote,++    -- * Result decoding+    decodeVar,+    decodeVarMaybe,+    lookupBinding,++    -- * Host functions+    -- $hostFunctions+    HostCallFn (..),+    Chr,+    Value (..),+    hostFn0M,+    hostFn1,+    hostFn1M,+    hostFn2,+    hostFn2M,+    hostFn3,+    hostFn3M,+    hostFnN,+    hostFnValues,++    -- * Host-function registries+    HostCallRegistry,+    baseHostCallRegistry,+    hostFunctions,+    withDefaultHostFunctions,++    -- * Typed query wrapper+    runQuery,+    runQueryWith,+    runQueryWithHostCallRegistry,++    -- * Typed query wrapper over a compiled program+    CompiledProgram,+    runQueryCompiled,+    runQueryCompiledWith,+    runQueryCompiledWithHostCallRegistry,+  )+where++import Control.Exception (throwIO)+import Control.Monad.Trans.State.Strict (evalStateT)+import Data.Bits (toIntegralSized)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import YCHR.Internal.Meta (metaHostCallRegistry, termToValue, valueToTerm)+import YCHR.Internal.Parsed (Module)+import YCHR.Internal.Runtime.Error (runtimeErrorS)+import YCHR.Internal.Runtime.Monad (Chr)+import YCHR.Internal.Runtime.Registry (HostCallFn (..), HostCallRegistry, baseHostCallRegistry)+import YCHR.Internal.Runtime.Types (Value (..))+import YCHR.Internal.VM qualified as VM+import YCHR.Run+  ( CompiledProgram,+    Error,+    compileParsedModules,+    runProgramWithGoalDSL,+  )+import YCHR.Types (Constraint (..), Name (..), Term (..))++-- ---------------------------------------------------------------------------+-- Classes+-- ---------------------------------------------------------------------------++-- | Encode a Haskell value as a CHR 'Term'. Total: encoding never fails.+class ToTerm a where+  toTerm :: a -> Term++-- | Decode a CHR 'Term' into a Haskell value. Fallible: the term may have+-- the wrong shape, or be an unbound variable where a ground value was+-- required. Failures are returned as data (a 'ConvertError'), never thrown.+class FromTerm a where+  fromTerm :: Term -> Either ConvertError a++-- ---------------------------------------------------------------------------+-- Errors+-- ---------------------------------------------------------------------------++-- | Why a 'Term' could not be decoded into a Haskell value.+--+-- The constructors are positional rather than record-shaped because the+-- \"what was found\" payload differs across cases ('Term' vs 'Name'), which a+-- single record could not share.+data ConvertError+  = -- | Wrong shape: a description of what was expected, and the term found.+    TypeMismatch Text Term+  | -- | Right functor, wrong argument count: functor, expected arity, found arity.+    ArityMismatch Name Int Int+  | -- | A compound whose functor matched none of a sum type's constructors:+    -- the accepted functor names, and the functor actually found.+    UnknownFunctor [Text] Name+  | -- | A ground value was required but the term was a variable or wildcard.+    UnboundValue Term+  | -- | Result-map decoding: the requested goal variable is absent.+    MissingBinding Text+  | -- | A typed query was given a goal that is not a compound term (a+    -- constraint occurrence). Carries the offending goal term.+    MalformedGoal Term+  deriving (Show, Eq)++-- ---------------------------------------------------------------------------+-- Combinators for hand-written instances+-- ---------------------------------------------------------------------------++-- | Build an unqualified compound term (the same shape as "YCHR.DSL"'s+-- @term@). Handy in 'ToTerm' instances.+compound :: Text -> [Term] -> Term+compound n = CompoundTerm (Unqualified n)++-- | Build a nullary atom (an unqualified 0-arity compound).+atomTerm :: Text -> Term+atomTerm n = CompoundTerm (Unqualified n) []++-- | Wrap a decoder so that an unbound variable or wildcard is reported as+-- 'UnboundValue' before the decoder runs. Every scalar 'FromTerm' instance+-- uses this so \"decode a value from an unbound variable\" fails uniformly.+ground :: (Term -> Either ConvertError a) -> Term -> Either ConvertError a+ground _ t@(VarTerm _) = Left (UnboundValue t)+ground _ t@Wildcard = Left (UnboundValue t)+ground f t = f t++-- | Decode a compound with the given (local) functor name and exact arity,+-- returning its argument terms. Rejects variables/wildcards+-- ('UnboundValue'), a different functor ('UnknownFunctor'), a wrong arity+-- ('ArityMismatch'), and non-compound terms ('TypeMismatch'). The functor is+-- matched on its local part, so a result that comes back module-qualified+-- still decodes.+matchCompound :: Text -> Int -> Term -> Either ConvertError [Term]+matchCompound n arity = ground $ \t -> case t of+  CompoundTerm name args+    | nameLocal name == n ->+        if length args == arity+          then Right args+          else Left (ArityMismatch name arity (length args))+    | otherwise -> Left (UnknownFunctor [n] name)+  _ -> Left (TypeMismatch n t)++-- | Decode a sum type: dispatch on a compound's functor and arity against a+-- table of @(functor, arity, handler)@ rows. Produces 'UnknownFunctor' when+-- no row's functor matches and 'ArityMismatch' when the functor matches but+-- the arity does not.+decodeSum ::+  [(Text, Int, [Term] -> Either ConvertError a)] ->+  Term ->+  Either ConvertError a+decodeSum rows = ground $ \t -> case t of+  CompoundTerm name args ->+    case lookupRow (nameLocal name) of+      Just (ar, h)+        | ar == length args -> h args+        | otherwise -> Left (ArityMismatch name ar (length args))+      Nothing -> Left (UnknownFunctor rowNames name)+  _ -> Left (TypeMismatch (Text.intercalate " | " rowNames) t)+  where+    rowNames = map (\(fn, _, _) -> fn) rows+    lookupRow k =+      foldr (\(fn, ar, h) acc -> if fn == k then Just (ar, h) else acc) Nothing rows++-- | Decode the argument at a 0-based position with 'fromTerm'. Intended for+-- use on the argument list returned by 'matchCompound' \/ 'decodeSum', where+-- the arity has already been checked.+argAt :: (FromTerm a) => Int -> [Term] -> Either ConvertError a+argAt i args = case drop i args of+  (t : _) -> fromTerm t+  [] -> Left (TypeMismatch ("positional argument #" <> Text.pack (show i)) Wildcard)++-- ---------------------------------------------------------------------------+-- The quote/1 quoting form+-- ---------------------------------------------------------------------------++-- | Wrap a value in the @quote\/1@ quoting form, keeping it symbolic.+--+-- Goal and rule-body arguments are /evaluated/, so a compound whose functor+-- is also a declared function is called rather than kept as data. Quoting+-- opts out. Use it where you build the goal, not inside a 'ToTerm' instance:+--+-- > compound "typecheck" [quote expr, VarTerm "Result"]  -- here, or+-- > term     "typecheck" [quote expr, var "Result"]      -- with "YCHR.DSL"+--+-- The argument is any 'ToTerm' value, so the 'toTerm' call is implicit;+-- a plain 'Term' passes through unchanged.+quote :: (ToTerm a) => a -> Term+quote x = CompoundTerm (Unqualified "quote") [toTerm x]++-- | The local (unqualified) part of a name.+nameLocal :: Name -> Text+nameLocal (Unqualified n) = n+nameLocal (Qualified _ n) = n++-- ---------------------------------------------------------------------------+-- Base and stdlib instances+-- ---------------------------------------------------------------------------++instance ToTerm Term where+  toTerm = id++instance FromTerm Term where+  fromTerm = Right++instance ToTerm Integer where+  toTerm = IntTerm++instance FromTerm Integer where+  fromTerm = ground $ \t -> case t of+    IntTerm n -> Right n+    _ -> Left (TypeMismatch "Integer" t)++instance ToTerm Int where+  toTerm = IntTerm . toInteger++instance FromTerm Int where+  fromTerm = ground $ \t -> case t of+    IntTerm n -> maybe (Left (TypeMismatch "Int" t)) Right (toIntegralSized n)+    _ -> Left (TypeMismatch "Int" t)++-- | Strict: an 'IntTerm' is /not/ coerced to a 'Double'. Use 'Integer' \/+-- 'Int' for integral results.+instance ToTerm Double where+  toTerm = FloatTerm++instance FromTerm Double where+  fromTerm = ground $ \t -> case t of+    FloatTerm d -> Right d+    _ -> Left (TypeMismatch "Double" t)++-- | Encodes to the canonical @true@ \/ @false@ atom. Decoding also accepts+-- the @prelude@-qualified forms that appear in results.+instance ToTerm Bool where+  toTerm True = atomTerm "true"+  toTerm False = atomTerm "false"++instance FromTerm Bool where+  fromTerm = ground $ \t -> case t of+    CompoundTerm (Unqualified "true") [] -> Right True+    CompoundTerm (Unqualified "false") [] -> Right False+    CompoundTerm (Qualified "prelude" "true") [] -> Right True+    CompoundTerm (Qualified "prelude" "false") [] -> Right False+    _ -> Left (TypeMismatch "Bool" t)++-- | The idiomatic CHR string type: encodes to 'TextTerm'.+instance ToTerm Text where+  toTerm = TextTerm++instance FromTerm Text where+  fromTerm = ground $ \t -> case t of+    TextTerm s -> Right s+    _ -> Left (TypeMismatch "Text" t)++-- | A single-character 'TextTerm'. Note that @String = [Char]@ therefore+-- round-trips as a /list/ of one-character 'TextTerm's; prefer 'Text' when+-- you want a single 'TextTerm'.+instance ToTerm Char where+  toTerm c = TextTerm (Text.singleton c)++instance FromTerm Char where+  fromTerm = ground $ \t -> case t of+    TextTerm s | Text.length s == 1 -> Right (Text.head s)+    _ -> Left (TypeMismatch "Char" t)++-- | Encodes to the @()@ atom (matching the runtime's unit value).+instance ToTerm () where+  toTerm () = atomTerm "()"++instance FromTerm () where+  fromTerm = ground $ \t -> case t of+    CompoundTerm (Unqualified "()") [] -> Right ()+    _ -> Left (TypeMismatch "()" t)++instance (ToTerm a) => ToTerm (Maybe a) where+  toTerm Nothing = atomTerm "nothing"+  toTerm (Just x) = compound "just" [toTerm x]++instance (FromTerm a) => FromTerm (Maybe a) where+  fromTerm =+    decodeSum+      [ ("nothing", 0, \_ -> Right Nothing),+        ("just", 1, \as -> Just <$> argAt 0 as)+      ]++instance (ToTerm a, ToTerm b) => ToTerm (Either a b) where+  toTerm (Left x) = compound "left" [toTerm x]+  toTerm (Right y) = compound "right" [toTerm y]++instance (FromTerm a, FromTerm b) => FromTerm (Either a b) where+  fromTerm =+    decodeSum+      [ ("left", 1, \as -> Left <$> argAt 0 as),+        ("right", 1, \as -> Right <$> argAt 0 as)+      ]++-- Tuples encode to a @tuple@ compound, distinguished by arity.++instance (ToTerm a, ToTerm b) => ToTerm (a, b) where+  toTerm (a, b) = compound "tuple" [toTerm a, toTerm b]++instance (FromTerm a, FromTerm b) => FromTerm (a, b) where+  fromTerm t = do+    as <- matchCompound "tuple" 2 t+    (,) <$> argAt 0 as <*> argAt 1 as++instance (ToTerm a, ToTerm b, ToTerm c) => ToTerm (a, b, c) where+  toTerm (a, b, c) = compound "tuple" [toTerm a, toTerm b, toTerm c]++instance (FromTerm a, FromTerm b, FromTerm c) => FromTerm (a, b, c) where+  fromTerm t = do+    as <- matchCompound "tuple" 3 t+    (,,) <$> argAt 0 as <*> argAt 1 as <*> argAt 2 as++instance (ToTerm a, ToTerm b, ToTerm c, ToTerm d) => ToTerm (a, b, c, d) where+  toTerm (a, b, c, d) = compound "tuple" [toTerm a, toTerm b, toTerm c, toTerm d]++instance (FromTerm a, FromTerm b, FromTerm c, FromTerm d) => FromTerm (a, b, c, d) where+  fromTerm t = do+    as <- matchCompound "tuple" 4 t+    (,,,) <$> argAt 0 as <*> argAt 1 as <*> argAt 2 as <*> argAt 3 as++-- | Prolog list encoding: cons is @.\/2@, nil is @[]@. Interoperates with+-- the @lists@ library. Decoding also accepts the @prelude@-qualified and+-- mangled cons\/nil forms that can appear in results.+instance (ToTerm a) => ToTerm [a] where+  toTerm = foldr (\x acc -> compound "." [toTerm x, acc]) (atomTerm "[]")++instance (FromTerm a) => FromTerm [a] where+  fromTerm = ground go+    where+      go t = case t of+        CompoundTerm name []+          | isNil name -> Right []+        CompoundTerm name [h, tl]+          | isCons name -> (:) <$> fromTerm h <*> fromTerm tl+        _ -> Left (TypeMismatch "list" t)+      isNil name =+        name+          `elem` [ Unqualified "[]",+                   Qualified "prelude" "[]",+                   Unqualified "prelude__[]"+                 ]+      isCons name =+        name+          `elem` [ Unqualified ".",+                   Qualified "prelude" ".",+                   Unqualified "prelude__."+                 ]++-- ---------------------------------------------------------------------------+-- Result decoding+-- ---------------------------------------------------------------------------++-- | Decode a single goal variable's binding by name. 'MissingBinding' when+-- the variable is absent from the result map; otherwise delegates to+-- 'fromTerm'.+decodeVar :: (FromTerm a) => Text -> Map Text Term -> Either ConvertError a+decodeVar k m = case Map.lookup k m of+  Nothing -> Left (MissingBinding k)+  Just t -> fromTerm t++-- | Like 'decodeVar' but yields 'Nothing' for an absent variable instead of+-- failing. A present-but-undecodable binding still fails.+decodeVarMaybe :: (FromTerm a) => Text -> Map Text Term -> Either ConvertError (Maybe a)+decodeVarMaybe k m = case Map.lookup k m of+  Nothing -> Right Nothing+  Just t -> Just <$> fromTerm t++-- | Raw lookup escape hatch: the bound 'Term' for a goal variable, if any.+lookupBinding :: Text -> Map Text Term -> Maybe Term+lookupBinding = Map.lookup++-- ---------------------------------------------------------------------------+-- Typed query wrapper+-- ---------------------------------------------------------------------------++-- | Compile the modules, run the goal 'Term', and decode a single goal+-- variable's binding as a Haskell value. The goal is built exactly like a+-- rule head or "YCHR.DSL" body goal (e.g. @term \"leq\" [int 1, var \"R\"]@);+-- its 'ToTerm'-encoded arguments run at tell time.+--+-- Compilation failures are thrown as 'Error' (as 'YCHR.DSL.runDSL' does);+-- decoding failures are returned as 'Left'. Uses the base + meta host-call+-- registries and includes the standard library.+runQuery :: (FromTerm a) => [Module] -> Term -> Text -> IO (Either ConvertError a)+runQuery modules goal v = runQueryWith modules goal (decodeVar v)++-- | Like 'runQuery' but takes an explicit decoder over the whole binding+-- map, so a record can be assembled from several 'decodeVar' calls.+runQueryWith ::+  [Module] ->+  Term ->+  (Map Text Term -> Either ConvertError a) ->+  IO (Either ConvertError a)+runQueryWith = runQueryWithHostCallRegistry (baseHostCallRegistry <> metaHostCallRegistry)++-- | Like 'runQueryWith' but takes an explicit host-call registry. Use this+-- when the program calls custom @host:_@ functions registered by the+-- embedder.+runQueryWithHostCallRegistry ::+  HostCallRegistry ->+  [Module] ->+  Term ->+  (Map Text Term -> Either ConvertError a) ->+  IO (Either ConvertError a)+runQueryWithHostCallRegistry hostCalls modules goal decode =+  -- Check the goal shape before compiling, so a malformed goal is reported+  -- as data without doing (or throwing on) the compile.+  case goalConstraint goal of+    Left err -> pure (Left err)+    Right _ -> do+      cp <- compileOrThrow modules+      runQueryCompiledWithHostCallRegistry hostCalls cp goal decode++compileOrThrow :: [Module] -> IO CompiledProgram+compileOrThrow modules = case compileParsedModules True modules of+  Left err -> throwIO (err :: Error)+  Right (cp, _warnings) -> pure cp++-- ---------------------------------------------------------------------------+-- Typed query wrapper over a compiled program+-- ---------------------------------------------------------------------------++-- | Like 'runQuery' but over an already-'CompiledProgram' instead of a+-- list of source modules. Compile once (with 'YCHR.Run.compileFiles' for+-- @.chr@ files, or 'YCHR.Run.compileParsedModules' for "YCHR.DSL"+-- modules), then run as many typed queries as you like against the same+-- program — each call is an independent run with a fresh store. This is+-- the entry point for embedding a real @.chr@ module and driving it with+-- 'ToTerm' \/ 'FromTerm'.+runQueryCompiled ::+  (FromTerm a) => CompiledProgram -> Term -> Text -> IO (Either ConvertError a)+runQueryCompiled cp goal v = runQueryCompiledWith cp goal (decodeVar v)++-- | Like 'runQueryWith' but over an already-'CompiledProgram'. Decodes the+-- whole binding map, so a record can be assembled from several 'decodeVar'+-- calls.+runQueryCompiledWith ::+  CompiledProgram ->+  Term ->+  (Map Text Term -> Either ConvertError a) ->+  IO (Either ConvertError a)+runQueryCompiledWith =+  runQueryCompiledWithHostCallRegistry (baseHostCallRegistry <> metaHostCallRegistry)++-- | Like 'runQueryWithHostCallRegistry' but over an+-- already-'CompiledProgram'. Use this when the program calls custom+-- @host:_@ functions registered by the embedder.+runQueryCompiledWithHostCallRegistry ::+  HostCallRegistry ->+  CompiledProgram ->+  Term ->+  (Map Text Term -> Either ConvertError a) ->+  IO (Either ConvertError a)+runQueryCompiledWithHostCallRegistry hostCalls cp goal decode =+  case goalConstraint goal of+    Left err -> pure (Left err)+    Right constraint -> do+      bindings <- runProgramWithGoalDSL cp hostCalls constraint+      pure (decode bindings)++-- | A goal must be a compound term (a constraint occurrence). Unlike+-- "YCHR.DSL"'s @termToConstraint@, which crashes, this reports a malformed+-- goal as a 'ConvertError' so it flows through the errors-as-data query API.+goalConstraint :: Term -> Either ConvertError Constraint+goalConstraint (CompoundTerm n args) = Right (Constraint n args)+goalConstraint t = Left (MalformedGoal t)++-- ---------------------------------------------------------------------------+-- Host functions+-- ---------------------------------------------------------------------------++-- $hostFunctions+--+-- A @host:f(args)@ call in a CHR program is dispatched through a+-- 'HostCallRegistry'. The adapters below lift ordinary Haskell functions+-- into 'HostCallFn' entries using the same 'ToTerm' \/ 'FromTerm' classes+-- used for goals and results, so the common case needs no knowledge of the+-- runtime value representation. Assemble a registry with 'hostFunctions'+-- (or 'withDefaultHostFunctions') and pass it to+-- 'runQueryWithHostCallRegistry' \/ 'runQueryCompiledWithHostCallRegistry'.++-- | Marshal one dereferenced host-call argument 'Value' into a decoded+-- Haskell value. 'valueToTerm' recursively dereferences, so a logical+-- variable bound inside a compound argument is resolved; a genuinely+-- unbound argument becomes 'Wildcard' and 'fromTerm' rejects it as an+-- 'UnboundValue'.+argFromValue :: (FromTerm a) => Value -> Chr (Either ConvertError a)+argFromValue v = fromTerm <$> valueToTerm Map.empty v++-- | Marshal a host-function result Haskell value back into a runtime+-- 'Value'. Results are expected ground.+resultToValue :: (ToTerm r) => r -> Chr Value+resultToValue r = evalStateT (termToValue (toTerm r)) Map.empty++hostArityError :: Int -> [a] -> Chr b+hostArityError n vs =+  runtimeErrorS+    ("host call: expected " ++ show n ++ " argument(s), got " ++ show (length vs))++hostDecodeError :: ConvertError -> Chr a+hostDecodeError err = runtimeErrorS ("host call: " ++ show err)++-- | Adapt a nullary effectful action into a host function. There is no+-- pure @hostFn0@ because a nullary pure host function is just a constant;+-- use this for host calls that read external state (a clock, a fresh+-- identifier) or perform I\/O. The body runs in 'Chr' (use 'liftIO' for+-- 'IO').+hostFn0M :: (ToTerm r) => Chr r -> HostCallFn+hostFn0M act = HostCallFn $ \case+  [] -> act >>= resultToValue+  vs -> hostArityError 0 vs++-- | Adapt a pure unary Haskell function into a host function.+--+-- > hostFunctions [("shout", hostFn1 Data.Text.toUpper)]   -- host:shout(X)+hostFn1 :: (FromTerm a, ToTerm r) => (a -> r) -> HostCallFn+hostFn1 f = hostFn1M (pure . f)++-- | Effectful unary adapter: the body runs in 'Chr', so it may perform+-- I\/O (via 'liftIO'), dereference logical variables, or inspect the+-- constraint store. Arguments and result still marshal via+-- 'FromTerm' \/ 'ToTerm'.+hostFn1M :: (FromTerm a, ToTerm r) => (a -> Chr r) -> HostCallFn+hostFn1M f = HostCallFn $ \case+  [va] -> do+    ea <- argFromValue va+    case ea of+      Right a -> f a >>= resultToValue+      Left err -> hostDecodeError err+  vs -> hostArityError 1 vs++-- | Adapt a pure binary Haskell function into a host function.+--+-- > hostFunctions [("my_add", hostFn2 ((+) :: Int -> Int -> Int))]  -- host:my_add(X, Y)+hostFn2 :: (FromTerm a, FromTerm b, ToTerm r) => (a -> b -> r) -> HostCallFn+hostFn2 f = hostFn2M (\a b -> pure (f a b))++-- | Effectful binary adapter. See 'hostFn1M'.+hostFn2M :: (FromTerm a, FromTerm b, ToTerm r) => (a -> b -> Chr r) -> HostCallFn+hostFn2M f = HostCallFn $ \case+  [va, vb] -> do+    ea <- argFromValue va+    eb <- argFromValue vb+    case (,) <$> ea <*> eb of+      Right (a, b) -> f a b >>= resultToValue+      Left err -> hostDecodeError err+  vs -> hostArityError 2 vs++-- | Adapt a pure ternary Haskell function into a host function.+hostFn3 ::+  (FromTerm a, FromTerm b, FromTerm c, ToTerm r) =>+  (a -> b -> c -> r) ->+  HostCallFn+hostFn3 f = hostFn3M (\a b c -> pure (f a b c))++-- | Effectful ternary adapter. See 'hostFn1M'.+hostFn3M ::+  (FromTerm a, FromTerm b, FromTerm c, ToTerm r) =>+  (a -> b -> c -> Chr r) ->+  HostCallFn+hostFn3M f = HostCallFn $ \case+  [va, vb, vc] -> do+    ea <- argFromValue va+    eb <- argFromValue vb+    ec <- argFromValue vc+    case (,,) <$> ea <*> eb <*> ec of+      Right (a, b, c) -> f a b c >>= resultToValue+      Left err -> hostDecodeError err+  vs -> hostArityError 3 vs++-- | Variable-arity escape hatch that still marshals through 'Term'. The+-- supplied function receives every argument already decoded to a 'Term'+-- (recursively dereferenced) and returns the result 'Term' or a+-- 'ConvertError'. Use it for host functions whose arity is not fixed+-- (e.g. an n-ary sum).+hostFnN :: ([Term] -> Either ConvertError Term) -> HostCallFn+hostFnN g = HostCallFn $ \vs -> do+  ts <- traverse (valueToTerm Map.empty) vs+  case g ts of+    Right t -> resultToValue t+    Left err -> hostDecodeError err++-- | The raw host-function escape hatch: build a 'HostCallFn' directly from+-- @'Value' -> 'Chr' 'Value'@, with no 'Term' marshalling. Arguments arrive+-- top-level dereferenced only (logical variables nested inside a compound+-- argument are /not/ chased — use 'YCHR.Run.deref' as needed). This is the+-- 'HostCallFn' constructor under a descriptive name, exposed so the raw+-- path needs no import of the internal runtime modules.+hostFnValues :: ([Value] -> Chr Value) -> HostCallFn+hostFnValues = HostCallFn++-- | Assemble a host-call registry from named host functions. The names are+-- the bare functors used at the call site: an entry @("my_add", …)@ is+-- invoked as @host:my_add(...)@ from CHR source. Composes with '<>'.+hostFunctions :: [(Text, HostCallFn)] -> HostCallRegistry+hostFunctions = Map.fromList . map (\(n, fn) -> (VM.Name n, fn))++-- | Like 'hostFunctions', but the given functions are unioned over the full+-- default registry (the base arithmetic \/ comparison \/ string builtins+-- plus the meta operations), so a program can call both the built-ins and+-- the custom functions. On a name clash the custom entry wins.+withDefaultHostFunctions :: [(Text, HostCallFn)] -> HostCallRegistry+withDefaultHostFunctions fns =+  hostFunctions fns <> baseHostCallRegistry <> metaHostCallRegistry
+ src/YCHR/DSL.hs view
@@ -0,0 +1,696 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | A Haskell-embedded DSL for building CHR programs without going through+-- @.chr@ source files. Use it when @ychr@ is embedded as a library: build+-- one or more 'Module' values, then compile and run them with 'runDSL'.+--+-- = Worked example: less-than-or-equal+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import YCHR.DSL+-- >+-- > orderModule :: Module+-- > orderModule =+-- >   module' "Order"+-- >     `declaring` ["leq" // 2]+-- >     `defining`+-- >       [ "refl" @: [term "leq" [var "X", var "X"]] <=> [bool True]+-- >       , "antisymm"+-- >           @: [term "leq" [var "X", var "Y"]] \\\\ [term "leq" [var "Y", var "X"]]+-- >             <=> [var "X" .=. var "Y"]+-- >       , "trans"+-- >           @: [term "leq" [var "X", var "Y"], term "leq" [var "Y", var "Z"]]+-- >             ==> [term "leq" [var "X", var "Z"]]+-- >       ]+-- >+-- > main :: IO ()+-- > main = do+-- >   bindings <- runDSL [orderModule] (term "leq" [var "A", var "B"])+-- >   print bindings+--+-- The DSL is a thin layer over 'YCHR.Internal.Parsed.Module': every combinator is a+-- pure function that builds AST nodes the parser would otherwise produce+-- from @.chr@ text. It does not validate the program — undeclared+-- constraints, ill-typed bodies, etc. are caught downstream by the+-- compilation pipeline ('compileParsedModules') exactly as for parsed+-- input.+--+-- = Two things to know before you start+--+-- __Constraint positions are partial.__ '<=>', '==>', @\\\\@ and 'runDSL'+-- expect each rule-head and goal 'Term' to be a compound or an atom — the+-- shapes 'term', 'qterm' and 'atom' build. Handing them a bare 'var' or+-- 'int' throws an 'error' rather than returning a diagnostic, because+-- there is no failure channel in a pure combinator. (The equivalent+-- mistake through "YCHR.Convert" is reported as a @MalformedGoal@+-- 'YCHR.Convert.ConvertError' instead.) Malformed /programs/ are still+-- reported properly by the pipeline; it is only malformed /Haskell/ that+-- fails this way.+--+-- __This module defines an orphan @instance Num Term@__ so that numeric+-- literals and '+' \/ '-' \/ '*' work in term position. It changes what+-- arithmetic on 'Term' means anywhere both this module and 'Term' are in+-- scope: @1 + 2 :: Term@ builds the /symbolic/ compound @+(1, 2)@, it does+-- not evaluate to @3@. That is the intent — a DSL body is CHR source, not+-- Haskell arithmetic — but it is worth knowing before importing this+-- module alongside "YCHR".+--+-- Negative literals work: @-1 :: Term@ is @'IntTerm' (-1)@, because GHC+-- routes them through 'negate', which folds them into the literal. But+-- 'negate' on a /non-literal/, 'abs', and 'signum' build @-(x)@,+-- @abs(x)@, and @sign(x)@ compounds, and the prelude declares none of+-- those — so they only work if your own module declares @-\/1@,+-- @abs\/1@, or @sign\/1@. Prefer '.-' and friends. There is also no+-- 'Fractional' instance, so a fractional literal needs the explicit+-- 'float' constructor.+module YCHR.DSL+  ( -- * Modules+    Module,+    module',+    importing,+    library,+    declaring,+    defining,+    withEquations,+    withExtensions,+    withClassExtensions,+    chrType,+    exporting,++    -- * Declarations+    Declaration,+    (//),+    function,+    openFunction,+    class_,+    openClass,+    extendClassType,+    typeExport,+    typeExportWith,+    op,+    OpType (..),++    -- * Type definitions+    TypeDefinition,+    TypeKind (..),+    DataConstructor,+    TypeExpr (..),+    tyDef,+    tyOpaque,+    dataCtor,++    -- * Rules+    Rule,+    Simpa,+    IsRuleHead,+    (@:),+    (<=>),+    (==>),+    (\\),+    (|-),++    -- * Terms+    Term,+    term,+    qterm,+    quote,+    var,+    atom,+    int,+    float,+    bool,+    text,+    wildcard,++    -- * Goal sugar+    (.=.),+    is,+    hostCall,++    -- * Function equations and lambdas+    FunctionEquation,+    equation,+    equationSeq,+    lambda,+    funRef,+    call_,++    -- * Numeric and comparison sugar++    --+    -- $numericSugar+    (.+),+    (.-),+    (.*),+    (./),+    (.<),+    (.<=),+    (.>),+    (.>=),+    (.==),++    -- * Compiling and running+    runDSL,+    runDSLWithHostCallRegistry,+    HostCallRegistry,+  )+where++import Control.Exception (throwIO)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Text (Text)+import YCHR.Convert (quote)+import YCHR.Internal.Meta (metaHostCallRegistry)+import YCHR.Internal.Parsed+import YCHR.Internal.Runtime.Registry (HostCallRegistry, baseHostCallRegistry)+import YCHR.Run+  ( CompiledProgram,+    Warning,+    compileParsedModules,+    runProgramWithGoalDSL,+  )++-- ---------------------------------------------------------------------------+-- Modules+-- ---------------------------------------------------------------------------++-- | An empty module with the given name.+module' :: Text -> Module+module' name =+  Module+    { name = name,+      nameLoc = dummyLoc,+      imports = [],+      decls = [],+      extensionTypes = [],+      typeDecls = [],+      rules = [],+      equations = [],+      extensions = [],+      classExtensions = [],+      exports = Nothing+    }++-- | Append plain @use_module(M)@ imports to a module.+--+-- > module' "Logic" `importing` ["Order", "Util"]+--+-- Note: this combinator appends to any imports already present.+importing :: Module -> [Text] -> Module+importing m imps =+  m {imports = m.imports ++ map (noAnnP . (`ModuleImport` Nothing)) imps}++-- | Append a single @use_module(library(L))@ import (a stdlib library or+-- bundled library, as opposed to a user-written sibling module).+--+-- > module' "MyApp" `library` "lists" `library` "math"+library :: Module -> Text -> Module+library m libName =+  m {imports = m.imports ++ [noAnnP (LibraryImport libName Nothing)]}++-- | Append constraint, function, operator, or type-export declarations.+--+-- > module' "M" `declaring` ["leq" // 2, function "factorial" 1]+declaring :: Module -> [Declaration] -> Module+declaring m ds = m {decls = m.decls ++ map noAnn ds}++-- | Append rules to a module.+defining :: Module -> [Rule] -> Module+defining m rls = m {rules = m.rules ++ rls}++-- | Append function-definition equations to a module.+--+-- > module' "M"+-- >   `declaring` [function "factorial" 1]+-- >   `withEquations`+-- >     [ equation "factorial" [int 0]    [] (int 1)+-- >     , equation "factorial" [var "N"]  [var "N" .> int 0]+-- >         (var "N" .* call_ (funRef "factorial" 1) [var "N" .- int 1])+-- >     ]+withEquations :: Module -> [FunctionEquation] -> Module+withEquations m eqs = m {equations = m.equations ++ map noAnnP eqs}++-- | Append function-equation /extensions/ to a module. Mirrors+-- @:- extend_function name(args) -> body@ directives in source+-- form: the equations contribute to an open function declared in+-- another module (resolved through this module's imports).+withExtensions :: Module -> [FunctionEquation] -> Module+withExtensions m eqs = m {extensions = m.extensions ++ map noAnnP eqs}++-- | Append class-equation /extensions/ to a module. Mirrors+-- @:- extend_class name(args) -> body@ directives in source form:+-- the equations contribute to an open class declared in another+-- module (resolved through this module's imports).+withClassExtensions :: Module -> [FunctionEquation] -> Module+withClassExtensions m eqs =+  m {classExtensions = m.classExtensions ++ map noAnnP eqs}++-- | Append a CHR-type definition (@:- chr_type ...@).+chrType :: Module -> TypeDefinition -> Module+chrType m ty = m {typeDecls = m.typeDecls ++ [noAnn ty]}++-- | Replace the export list of a module.+--+-- An absent export list (the default after 'module'') means the+-- module exports everything by name. Calling 'exporting' switches the+-- module to an explicit export list. Subsequent calls /append/ to that+-- list rather than replacing it.+exporting :: Module -> [Declaration] -> Module+exporting m ds = case m.exports of+  Nothing -> m {exports = Just (noAnnP ds)}+  Just (AnnP existing loc origin) ->+    m {exports = Just (AnnP (existing ++ ds) loc origin)}++-- ---------------------------------------------------------------------------+-- Declarations+-- ---------------------------------------------------------------------------++-- | Constraint declaration. Mirrors @:- chr_constraint name/arity@.+--+-- > "leq" // 2+(//) :: Text -> Int -> Declaration+(//) name arity = ConstraintDecl name arity Nothing Nothing++-- | Function declaration: @:- function name/arity@.+function :: Text -> Int -> Declaration+function name arity =+  FunctionDecl+    { name = name,+      arity = arity,+      argTypes = Nothing,+      returnType = Nothing,+      isOpen = False,+      kind = DKFunction,+      requiring = Nothing+    }++-- | Open-function declaration: @:- open_function name/arity@. Open functions+-- can be extended with new equations from other modules.+openFunction :: Text -> Int -> Declaration+openFunction name arity =+  FunctionDecl+    { name = name,+      arity = arity,+      argTypes = Nothing,+      returnType = Nothing,+      isOpen = True,+      kind = DKFunction,+      requiring = Nothing+    }++-- | Class declaration: @:- class name/arity@. A class enables+-- multi-signature overloading.+class_ :: Text -> Int -> Declaration+class_ name arity =+  FunctionDecl+    { name = name,+      arity = arity,+      argTypes = Nothing,+      returnType = Nothing,+      isOpen = False,+      kind = DKClass,+      requiring = Nothing+    }++-- | Open-class declaration: @:- open_class name/arity@. Open classes+-- can be extended with new signatures and equations from other modules.+openClass :: Text -> Int -> Declaration+openClass name arity =+  FunctionDecl+    { name = name,+      arity = arity,+      argTypes = Nothing,+      returnType = Nothing,+      isOpen = True,+      kind = DKClass,+      requiring = Nothing+    }++-- | Extension type declaration: @:- extend_class_type (name(args) -> ret)@.+-- Adds an overloaded signature to an open class declared in another+-- module. The renamer resolves the class name through the importing+-- module's imports.+extendClassType :: Text -> [TypeExpr] -> TypeExpr -> Declaration+extendClassType name argTypes returnType =+  ExtendClassTypeDecl+    { name = name,+      arity = length argTypes,+      argTypes = Just argTypes,+      returnType = Just returnType,+      target = Nothing+    }++-- | Type-export declaration: @:- module(m, [type(name/arity)])@. Exports+-- the type and all of its data constructors.+typeExport :: Text -> Int -> Declaration+typeExport n a = TypeExportDecl n a Nothing++-- | Type-export declaration with a constructor allowlist:+-- @:- module(m, [type(name/arity, [c1, c2])])@. Exports the type and only+-- the listed constructors. Pass @[]@ to export the type without any+-- constructors.+typeExportWith :: Text -> Int -> [Text] -> Declaration+typeExportWith n a cs = TypeExportDecl n a (Just cs)++-- | Operator declaration. Mirrors @:- op(Fixity, OpType, Name)@.+--+-- > op 700 Xfx "is"+op :: Int -> OpType -> Text -> Declaration+op fixity opType opName = OperatorDecl OpDecl {fixity, opType, opName}++-- ---------------------------------------------------------------------------+-- Type definitions+-- ---------------------------------------------------------------------------++-- | Build a type definition: name, type variables, constructors.+--+-- > tyDef "color" [] [dataCtor "red" [], dataCtor "green" [], dataCtor "blue" []]+tyDef :: Text -> [Text] -> [DataConstructor] -> TypeDefinition+tyDef n vs cs =+  TypeDefinition+    { name = Unqualified n,+      typeVars = vs,+      kind = Algebraic cs,+      loc = dummyLoc+    }++-- | Build an opaque type definition: a nominal type name with zero or+-- more type parameters and no data constructors.+--+-- > tyOpaque "set" ["X"]+tyOpaque :: Text -> [Text] -> TypeDefinition+tyOpaque n vs =+  TypeDefinition+    { name = Unqualified n,+      typeVars = vs,+      kind = Opaque,+      loc = dummyLoc+    }++-- | Build a data constructor: name and argument types.+--+-- > dataCtor "cons" [TypeVar "a", TypeCon (Unqualified "list") [TypeVar "a"]]+dataCtor :: Text -> [TypeExpr] -> DataConstructor+dataCtor n args = DataConstructor {conName = Unqualified n, conArgs = args}++-- ---------------------------------------------------------------------------+-- Rules+-- ---------------------------------------------------------------------------++-- | A simpagation kept/removed pair, awaiting a body via '<=>'.+--+-- Produced by '\\'; consumed by '<=>' through 'IsRuleHead'.+data Simpa = Simpa+  { kept :: [Term],+    removed :: [Term]+  }++-- | The left-hand side of a '<=>': either a list of terms (simplification)+-- or a 'Simpa' (simpagation).+class IsRuleHead h where+  toRuleHead :: h -> Head++instance IsRuleHead [Term] where+  toRuleHead = Simplification . map termToConstraint++instance IsRuleHead Simpa where+  toRuleHead s =+    Simpagation (map termToConstraint s.kept) (map termToConstraint s.removed)++-- | Convert a 'Term' built by 'term' / 'qterm' / 'atom' into a head+-- 'Constraint' occurrence. Compound and atom terms map to a constraint;+-- anything else (a bare variable, integer, etc.) is rejected with the+-- same shape of error the parser raises for a 'MalformedConstraint'.+termToConstraint :: Term -> Constraint+termToConstraint (CompoundTerm n args) = Constraint n args+termToConstraint t =+  errorWithoutStackTrace $+    "YCHR.DSL: term is not a valid constraint occurrence: " <> show t++-- | Attach a name to a rule.+--+-- > "trans" @: [term "leq" [var "X", var "Y"], ...] ==> [...]+(@:) :: Text -> Rule -> Rule+n @: (Rule _ h g b) = Rule (Just (noAnn n)) h g b++-- | Simplification rule (@head \<=\> body@) or simpagation rule+-- (@kept \\ removed \<=\> body@), depending on the LHS.+--+-- > [term "p" []]                <=> [bool True]   -- simplification+-- > [term "k" []] \\ [term "r" []] <=> [bool True] -- simpagation+(<=>) :: (IsRuleHead h) => h -> [Term] -> Rule+h <=> body =+  Rule Nothing (noAnnP (toRuleHead h)) (noAnnP []) (noAnnP body)++-- | Propagation rule (@head ==\> body@).+--+-- > [term "leq" [var "X", var "Y"], term "leq" [var "Y", var "Z"]]+-- >   ==> [term "leq" [var "X", var "Z"]]+(==>) :: [Term] -> [Term] -> Rule+lhs ==> rhs =+  Rule+    Nothing+    (noAnnP (Propagation (map termToConstraint lhs)))+    (noAnnP [])+    (noAnnP rhs)++-- | Simpagation split: @kept \\ removed@. Followed by '<=>' body.+(\\) :: [Term] -> [Term] -> Simpa+k \\ r = Simpa {kept = k, removed = r}++-- | Attach a guard to a rule.+--+-- > [term "p" [var "X"]] <=> [bool True] |- [var "X" .> int 0]+(|-) :: Rule -> [Term] -> Rule+r |- g = let Rule n h _ b = r in Rule n h (noAnnP g) b++infix 4 .=.++infix 4 .==, .<, .<=, .>, .>=++infixl 6 .+, .-++infixl 7 .*, ./++infixr 3 \\++infixr 3 `is`++infix 2 <=>, ==>++infixl 1 |-++infixr 0 @:++-- ---------------------------------------------------------------------------+-- Terms+-- ---------------------------------------------------------------------------++-- | Compound term with an unqualified functor.+--+-- The same constructor serves for constraint occurrences (in rule heads+-- or as body goals), function calls, and data-constructor terms — the+-- surface language draws no distinction between them, so the DSL doesn't+-- either. Classification happens later, in the renamer and desugarer.+--+-- > term "leq" [var "X", var "Y"]+term :: Text -> [Term] -> Term+term n args = CompoundTerm (Unqualified n) args++-- | Compound term with a fully-qualified functor.+--+-- > qterm "Order" "leq" [var "X", var "Y"]+qterm :: Text -> Text -> [Term] -> Term+qterm m n args = CompoundTerm (Qualified m n) args++-- | Variable term: 'var' \"X\" produces the same AST as the surface @X@.+var :: Text -> Term+var = VarTerm++-- | Atom term. Surface atoms are represented as 0-arity unqualified+-- compounds in the AST; the runtime collapses them to 'VAtom'.+atom :: Text -> Term+atom s = CompoundTerm (Unqualified s) []++-- | Integer literal term (arbitrary precision).+int :: Integer -> Term+int = IntTerm++-- | Floating-point literal term.+float :: Double -> Term+float = FloatTerm++-- | Boolean literal — produces the canonical @true@ / @false@ atom term+-- the renamer expects. Equivalent to @atom \"true\"@ / @atom \"false\"@.+bool :: Bool -> Term+bool True = CompoundTerm (Unqualified "true") []+bool False = CompoundTerm (Unqualified "false") []++-- | Text/string literal term.+text :: Text -> Term+text = TextTerm++-- | Wildcard pattern: matches anything without binding.+wildcard :: Term+wildcard = Wildcard++-- ---------------------------------------------------------------------------+-- Goal sugar+-- ---------------------------------------------------------------------------++-- | Structural unification goal, written @=@ in the surface language.+(.=.) :: Term -> Term -> Term+l .=. r = CompoundTerm (Unqualified "=") [l, r]++-- | Arithmetic-evaluation goal: @V is Expr@.+--+-- > var "X" `is` (int 1 .+ var "Y")+is :: Term -> Term -> Term+is v e = CompoundTerm (Unqualified "is") [v, e]++-- | Host-language call, written @host:f(args)@ in the surface language.+--+-- > hostCall "print" [var "X"]+hostCall :: Text -> [Term] -> Term+hostCall f args = CompoundTerm (Qualified "host" f) args++-- ---------------------------------------------------------------------------+-- Function equations and lambdas+-- ---------------------------------------------------------------------------++-- | A single function-defining equation with a single-expression body.+-- Use 'equationSeq' for a sequenced body (@A1, A2, ..., Return@).+--+-- > equation "factorial" [int 0]   [] (int 1)+-- > equation "factorial" [var "N"] [var "N" .> int 0]+-- >   (var "N" .* call_ (funRef "factorial" 1) [var "N" .- int 1])+equation :: Text -> [Term] -> [Term] -> Term -> FunctionEquation+equation n args guard rhs = equationSeq n args guard (NE.singleton rhs)++-- | A function-defining equation whose body is a non-empty sequence of+-- terms. The last term is the return expression; earlier terms must be+-- either an @is@ binding or an IO action (host call / discardable function+-- call). Validated in the desugarer.+equationSeq ::+  Text -> [Term] -> [Term] -> NE.NonEmpty Term -> FunctionEquation+equationSeq n args guard rhs =+  FunctionEquation+    { funName = Unqualified n,+      args = args,+      guard = noAnnP guard,+      rhs = noAnnP rhs+    }++-- | An anonymous function (lambda) term. Mirrors @fun(args) -> body end@.+-- Internally a lambda is the compound @'->'(fun(args), body)@; lambda lifting+-- happens during desugaring.+--+-- > lambda [var "X"] (var "X" .+ int 1)+lambda :: [Term] -> Term -> Term+lambda args body =+  CompoundTerm+    (Unqualified "->")+    [CompoundTerm (Unqualified "fun") args, body]++-- | Reference a named function as a first-class value: @fun name/arity@.+--+-- The surface syntax @fun foo/2@ produces the AST below, callable via 'call_'.+funRef :: Text -> Int -> Term+funRef n arity =+  CompoundTerm+    (Unqualified "fun")+    [ CompoundTerm+        (Unqualified "/")+        [CompoundTerm (Unqualified n) [], IntTerm (fromIntegral arity)]+    ]++-- | Call a first-class function value (a 'lambda' or 'funRef') with the+-- given arguments. Mirrors the surface @'$call'(F, A1, A2, ...)@.+call_ :: Term -> [Term] -> Term+call_ f args = CompoundTerm (Unqualified "$call") (f : args)++-- ---------------------------------------------------------------------------+-- Numeric and comparison sugar+-- ---------------------------------------------------------------------------++-- $numericSugar+--+-- The 'Term' type is an instance of 'Num' so integer literals can be+-- written without 'int' and the standard arithmetic operators+-- (@+@, @-@, @*@, 'negate') compile to the corresponding compound terms+-- the surface language recognises.+--+-- > var "X" `is` (1 + 2 * var "Y")+--+-- For users who prefer to keep the AST literal-explicit, the prefixed+-- operators ('.+', '.-', '.*', './') do the same job without the+-- 'Num' machinery, and the comparison operators ('.<', '.<=', '.>',+-- '.>=', '.==') build comparison goals usable in guards.++instance Num Term where+  fromInteger n = IntTerm n+  l + r = CompoundTerm (Unqualified "+") [l, r]+  l - r = CompoundTerm (Unqualified "-") [l, r]+  l * r = CompoundTerm (Unqualified "*") [l, r]++  -- GHC desugars a negative literal through 'negate', so @-1 :: Term@+  -- arrives here as @negate (IntTerm 1)@. Fold it into the literal: the+  -- prelude has no unary minus, so the @-(1)@ compound these used to+  -- build reached the runtime as a one-argument call to @-@ and died with+  -- an arity error at tell time.+  negate (IntTerm n) = IntTerm (negate n)+  negate (FloatTerm x) = FloatTerm (negate x)+  -- Non-literals keep the compound form. The functor is /unqualified/, so+  -- it resolves against the program's own functions — a module that+  -- declares @-\/1@, @abs\/1@, or @sign\/1@ gets a working call. Nothing+  -- in the prelude provides them, so without such a declaration these+  -- fail at tell time; prefer '.-' and friends, which are explicit.+  negate x = CompoundTerm (Unqualified "-") [x]+  abs x = CompoundTerm (Unqualified "abs") [x]+  signum x = CompoundTerm (Unqualified "sign") [x]++(.+), (.-), (.*), (./) :: Term -> Term -> Term+l .+ r = CompoundTerm (Unqualified "+") [l, r]+l .- r = CompoundTerm (Unqualified "-") [l, r]+l .* r = CompoundTerm (Unqualified "*") [l, r]+l ./ r = CompoundTerm (Unqualified "/") [l, r]++(.<), (.<=), (.>), (.>=), (.==) :: Term -> Term -> Term+l .< r = CompoundTerm (Unqualified "<") [l, r]+l .<= r = CompoundTerm (Unqualified "=<") [l, r]+l .> r = CompoundTerm (Unqualified ">") [l, r]+l .>= r = CompoundTerm (Unqualified ">=") [l, r]+l .== r = CompoundTerm (Unqualified "==") [l, r]++-- ---------------------------------------------------------------------------+-- Compiling and running+-- ---------------------------------------------------------------------------++-- | Compile DSL-built modules and run a single goal against them, using+-- the same default host-call registry as the @ychr@ CLI+-- (@baseHostCallRegistry <> metaHostCallRegistry@). Includes the stdlib.+--+-- The goal is built with 'term' / 'qterm' just like rule heads. Returns+-- the final unification map for the variables mentioned in the goal.+-- Compilation or runtime errors are raised as exceptions.+--+-- > main = do+-- >   bindings <- runDSL [orderModule] (term "leq" [var "A", var "B"])+-- >   print bindings+runDSL :: [Module] -> Term -> IO (Map Text Term)+runDSL = runDSLWithHostCallRegistry (baseHostCallRegistry <> metaHostCallRegistry)++-- | Like 'runDSL', but takes an explicit host-call registry. Use this when+-- the program calls custom @host:_@ functions registered by the embedder.+runDSLWithHostCallRegistry ::+  HostCallRegistry -> [Module] -> Term -> IO (Map Text Term)+runDSLWithHostCallRegistry hostCalls modules goal = do+  cp <- compileOrThrow modules+  runProgramWithGoalDSL cp hostCalls (termToConstraint goal)++compileOrThrow :: [Module] -> IO CompiledProgram+compileOrThrow modules = case compileParsedModules True modules of+  Left err -> throwIO err+  Right (cp, _warnings :: [Warning]) -> pure cp
+ src/YCHR/Internal/Backend/Scheme.hs view
@@ -0,0 +1,718 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Scheme code generation backend for CHR VM programs.+--+-- Translates a 'VMProgram' into R7RS Scheme source code that uses the+-- YCHR Scheme runtime libraries (@(ychr var)@, @(ychr store)@,+-- @(ychr history)@, @(ychr reactivation)@).+--+-- Control flow ('Return', 'Break', 'Continue') is implemented via+-- @call\/cc@ escape continuations.  Internal names use a @%@ prefix+-- to avoid collisions with user-defined identifiers.+module YCHR.Internal.Backend.Scheme+  ( generateScheme,+    compileSymbol,+    isValidSchemeIdentifier,+    qualifiedAliasIdentifier,+  )+where++import Data.Char (isAlpha, isAlphaNum, ord)+import Data.Map.Strict qualified as Map+import Data.Maybe (maybeToList)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Numeric (showHex)+import YCHR.Internal.Compile (tellProcName)+import YCHR.Internal.Compile.Names (encodeIdentifier, isIdInitialSafe)+import YCHR.Internal.SExpr (SExpr (..), printSExpr)+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM.SExpr (VMProgram (..))+import YCHR.Internal.VM.Types++-- ---------------------------------------------------------------------------+-- Public API+-- ---------------------------------------------------------------------------++-- | Generate Scheme source code from a VM program, wrapped in an R6RS+-- @(library ...)@ form.+--+-- The library name components are given as a list of 'Text' values,+-- e.g. @["ychr", "generated", "order"]@ produces @(ychr generated order)@.+-- A program-info binding named after the last segment is exported+-- (see 'programInfoBindingName'); it is a zero-argument thunk that+-- creates and returns a fresh session.+--+-- For every exported constraint with a generated @tell_*@, two+-- user-facing identifiers may be exported:+--+-- * Qualified: @MOD:NAME\/ARITY@ — always emitted when the resulting+--   string is a valid Scheme identifier.+-- * Short: @NAME\/ARITY@ — emitted only when the short form is unique+--   across all exported constraints in this library, and valid as an+--   identifier.+--+-- The mangled @tell_MOD__NAME_ARITY@ procedures remain defined inside+-- the library (the aliases are bound to them) but are not exported.+generateScheme :: [Text] -> VMProgram -> Text+generateScheme libName vmp =+  let procs = vmp.program.procedures+      infoName = programInfoBindingName libName+      aliases = collectAliases vmp+   in T.unlines $+        [ ";; Generated by YCHR",+          "(library " <> renderSExpr (SList (map SAtom libName)),+          "  " <> renderSExpr (exportClause infoName vmp aliases),+          "  " <> renderSExpr importClause,+          ""+        ]+          ++ map renderSExpr (concatMap compileProcedure procs)+          ++ map renderSExpr (aliasDefines aliases)+          ++ [renderSExpr (programInfoSExpr infoName vmp)]+          ++ [") ;; end library"]++-- ---------------------------------------------------------------------------+-- Library wrapper+-- ---------------------------------------------------------------------------++-- | Build the @(export ...)@ clause. Exports the friendly tell-procedure+-- aliases, all @func_*@ procedures (so drivers can evaluate function+-- calls in goal-argument position — see 'YCHR.Internal.Desugared.BodyTell'),+-- and the program-info binding.+exportClause :: Text -> VMProgram -> [AliasEntry] -> SExpr+exportClause infoName vmp aliases =+  let procNames = Set.fromList [n.unName | p <- vmp.program.procedures, let n = p.name]+      aliasNames = concatMap aliasEntryExports aliases+      funcNames =+        [ n | n <- Set.toList procNames, "func_" `T.isPrefixOf` n+        ]+   in SList+        ( SAtom "export"+            : SAtom infoName+            : map SAtom (aliasNames ++ funcNames)+        )++-- | Import clause for the runtime.+importClause :: SExpr+importClause =+  SList+    [ SAtom "import",+      SList [SAtom "rnrs"],+      SList [SAtom "ychr", SAtom "runtime"]+    ]++-- ---------------------------------------------------------------------------+-- Tell-procedure aliases+-- ---------------------------------------------------------------------------++-- | One row per exported constraint with a generated @tell_*@. Records+-- the friendly identifiers that should bind to the underlying mangled+-- procedure. The qualified alias is always emitted; the short alias is+-- 'Nothing' when another exported constraint shares the same encoded+-- short name (intra-library collision).+data AliasEntry = AliasEntry+  { aliasQualified :: Text,+    aliasShort :: Maybe Text,+    aliasTarget :: Text+  }++aliasEntryExports :: AliasEntry -> [Text]+aliasEntryExports (AliasEntry q s _) = q : maybeToList s++-- | Render the qualified alias identifier (@mod:name/arity@) for a+-- constraint. The function is total: any input is encoded into a+-- well-formed identifier via 'encodeIdentifier' (plus an+-- initial-character guard via 'encodeAliasComponent' for the leading+-- module segment).+--+-- Shared with 'YCHR.Internal.Backend.SchemeDriver' so the driver script always+-- targets the same identifier the generated library exports.+qualifiedAliasIdentifier :: Types.Name -> Int -> Text+qualifiedAliasIdentifier name arity = case name of+  Types.Qualified m n ->+    encodeAliasComponent m+      <> ":"+      <> encodeIdentifier n+      <> "/"+      <> T.pack (show arity)+  Types.Unqualified n -> shortAliasName n arity++-- | Render the short alias identifier (@name/arity@).+-- 'encodeAliasComponent' ensures the first character is a valid+-- identifier @<initial>@; the rest of the name uses+-- 'encodeIdentifier'.+shortAliasName :: Text -> Int -> Text+shortAliasName n a = encodeAliasComponent n <> "/" <> T.pack (show a)++-- | Like 'encodeIdentifier', but additionally escapes the first+-- character when it isn't a valid identifier @<initial>@ — digits+-- pass 'encodeIdentifier' (they're valid /subsequent/ chars) but are+-- illegal as the first character of an identifier. Used by the alias+-- builders, where the encoded component sits at the start of the+-- identifier; not needed by 'procNameFor', whose @tell_@ prefix+-- already supplies a safe initial.+encodeAliasComponent :: Text -> Text+encodeAliasComponent t = case T.uncons t of+  Nothing -> T.empty+  Just (c, rest)+    | isIdInitialSafe c -> T.singleton c <> encodeIdentifier rest+    | otherwise ->+        "__u" <> T.pack (showHex (ord c) "") <> "__" <> encodeIdentifier rest++-- | Walk the program's exported tell procedures and compute the alias+-- table. Short-name uniqueness is determined within this library only;+-- cross-library collisions are left for the importing R6RS runtime to+-- surface via @(rename ...)@ / @(only ...)@ import sub-forms.+collectAliases :: VMProgram -> [AliasEntry]+collectAliases vmp =+  let procNames = Set.fromList [n.unName | p <- vmp.program.procedures, let n = p.name]+      tells =+        [ (m, n, a, mangleName tn)+        | Types.QualifiedIdentifier m n a <- Set.toList vmp.exportedSet,+          let tn = tellProcName (Types.Qualified m n) a,+          Set.member tn.unName procNames+        ]+      shortCounts =+        Map.fromListWith (+) [(shortAliasName n a, 1 :: Int) | (_, n, a, _) <- tells]+   in [ AliasEntry+          { aliasQualified = qualifiedAliasIdentifier (Types.Qualified m n) a,+            aliasShort =+              let s = shortAliasName n a+               in if Map.findWithDefault 0 s shortCounts == 1+                    then Just s+                    else Nothing,+            aliasTarget = target+          }+      | (m, n, a, target) <- tells+      ]++-- | Emit the @(define ALIAS tell_*)@ forms paired with each alias.+aliasDefines :: [AliasEntry] -> [SExpr]+aliasDefines entries =+  [ SList [SAtom "define", SAtom name, SAtom entry.aliasTarget]+  | entry <- entries,+    name <- aliasEntryExports entry+  ]++-- ---------------------------------------------------------------------------+-- Program-info binding+-- ---------------------------------------------------------------------------++-- | Identifier under which the per-program info is exported. Equals the+-- library's final segment, so a library compiled with @-n fib@ (giving+-- @(ychr generated fib)@) exports a binding named @fib@. Users then+-- call @(open-session fib)@ after importing @(ychr generated fib)@.+--+-- Callers must pass a non-empty 'libName'; the CLI always synthesizes+-- @["ychr","generated",NAME]@. The @NAME@ component is validated as a+-- Scheme identifier upstream (see 'isValidSchemeIdentifier' in+-- 'YCHR.Internal.Backend.Scheme', applied by @app/Main.hs@'s @runCompile@).+programInfoBindingName :: [Text] -> Text+programInfoBindingName libName = case reverse libName of+  (x : _) -> x+  [] -> error "programInfoBindingName: empty library name"++-- | Build the program-info binding: a zero-argument thunk that+-- allocates a fresh runtime session. The session's deep-eval+-- dispatch table is populated immediately so @is@ can reach every+-- user-defined function in the library.+--+-- > (define (NAME)+-- >   (let ((%s (%make-session N)))+-- >     (register-evaluable! %s 'functor1 arity1 proc1)+-- >     ...+-- >     %s))+--+-- @(open-session NAME)@ in the REPL library simply invokes this thunk;+-- the dispatcher-style @(NAME 'init)@ / @(NAME 'tells)@ protocol is+-- gone since tell procedures are now reached statically through the+-- exported alias identifiers.+programInfoSExpr :: Text -> VMProgram -> SExpr+programInfoSExpr infoName vmp =+  let bindings =+        [ SList+            [ SAtom "%s",+              SList [SAtom "%make-session", SInt (fromIntegral vmp.program.numTypes)]+            ]+        ]+      registrations = map evaluableRegistration vmp.program.evaluables+      -- The let body is the session itself, returned to the caller.+      letBody = SAtom "%s"+   in SList+        [ SAtom "define",+          SList [SAtom infoName],+          SList ([SAtom "let", SList bindings] ++ registrations ++ [letBody])+        ]++-- | Emit @(register-evaluable! %s 'functor arity procedure)@ for a+-- single entry of the program's evaluables table. The procedure+-- identifier is the same mangled name bound by 'compileProcedure', so+-- direct identifier reference resolves it in the library's scope.+evaluableRegistration :: (EvaluableKey, Name) -> SExpr+evaluableRegistration (key, procName) =+  SList+    [ SAtom "register-evaluable!",+      SAtom "%s",+      compileSymbol key.functor.unName,+      SInt (fromIntegral key.arity),+      SAtom procName.unName+    ]++-- ---------------------------------------------------------------------------+-- Rendering+-- ---------------------------------------------------------------------------++renderSExpr :: SExpr -> Text+renderSExpr = printSExpr++-- ---------------------------------------------------------------------------+-- Procedure compilation+-- ---------------------------------------------------------------------------++compileProcedure :: Procedure -> [SExpr]+compileProcedure proc =+  [ SList+      ( SAtom "define"+          : SList+            ( SAtom (mangleName proc.name)+                : SAtom "%s"+                : map+                  (SAtom . mangleName)+                  proc.params+            )+          : [wrapReturn (compileStmts proc.body)]+      )+  ]++-- | Wrap a procedure body in a call/cc for %return.+wrapReturn :: SExpr -> SExpr+wrapReturn body =+  SList+    [ SAtom "call/cc",+      SList [SAtom "lambda", SList [SAtom "%return"], body, SAtom "#f"]+    ]++-- ---------------------------------------------------------------------------+-- Statement compilation+-- ---------------------------------------------------------------------------++-- | Compile a list of statements into a single SExpr.+-- Let statements thread as nested let bindings wrapping the rest.+compileStmts :: [Stmt] -> SExpr+compileStmts [] = SAtom "#f"+compileStmts [s] = compileStmtTail s []+compileStmts (s : rest) = compileStmtTail s rest++-- | Compile a statement with its continuation (remaining statements).+-- Let creates a nested let wrapping the rest; other statements emit+-- themselves followed by the rest in a begin.+compileStmtTail :: Stmt -> [Stmt] -> SExpr+compileStmtTail (LetVal n e) rest =+  SList+    [ SAtom "let",+      SList [SList [SAtom (mangleName n), compileValExpr e]],+      compileStmts rest+    ]+compileStmtTail (LetId n e) rest =+  SList+    [ SAtom "let",+      SList [SList [SAtom (mangleName n), compileIdExpr e]],+      compileStmts rest+    ]+compileStmtTail s [] = compileStmt s+compileStmtTail s rest =+  SList (SAtom "begin" : compileStmt s : [compileStmts rest])++-- | Compile a single statement (no continuation context).+compileStmt :: Stmt -> SExpr+compileStmt (LetVal n e) =+  SList [SAtom "let", SList [SList [SAtom (mangleName n), compileValExpr e]], SAtom "#f"]+compileStmt (LetId n e) =+  SList [SAtom "let", SList [SList [SAtom (mangleName n), compileIdExpr e]], SAtom "#f"]+compileStmt (AssignVal n e) =+  SList [SAtom "set!", SAtom (mangleName n), compileValExpr e]+compileStmt (AssignId n e) =+  SList [SAtom "set!", SAtom (mangleName n), compileIdExpr e]+compileStmt (If cond thenBranch elseBranch) =+  SList+    [ SAtom "if",+      compileBoolExpr cond,+      compileBody thenBranch,+      compileBody elseBranch+    ]+compileStmt (Foreach lbl (ConstraintType ct) sv conds body) =+  compileForeach lbl ct sv conds body+compileStmt (Continue (Label lbl)) =+  SList [SAtom (continueName lbl), SAtom "#f"]+compileStmt (Break (Label lbl)) =+  SList [SAtom (breakName lbl), SAtom "#f"]+compileStmt (Return e) =+  SList [SAtom "%return", compileValExpr e]+compileStmt (ExprStmt e) =+  compileValExpr e+compileStmt (BoolExprStmt e) =+  compileBoolExpr e+compileStmt (Store e) =+  SList [SAtom "store-constraint", SAtom "%s", compileIdExpr e]+compileStmt (Kill e) =+  SList [SAtom "kill-constraint", compileIdExpr e]+compileStmt (AddHistory (RuleId rid) es) =+  SList+    [ SAtom "add-history!",+      SAtom "%s",+      SInt (fromIntegral rid),+      SList+        ( SAtom "list"+            : map (\e -> SList [SAtom "constraint-id", compileIdExpr e]) es+        )+    ]+compileStmt (PushFrame _) =+  SList [SAtom "values"]+compileStmt (DrainReactivationQueue (Name sv) body) =+  SList+    [ SAtom "drain-queue!",+      SAtom "%s",+      SList+        [ SAtom "lambda",+          SList [SAtom sv],+          SList+            [ SAtom "when",+              SList [SAtom "alive-constraint?", SAtom sv],+              compileBody body+            ]+        ]+    ]++-- | Compile a statement list as a body (begin-wrapped if multiple).+compileBody :: [Stmt] -> SExpr+compileBody [] = SAtom "#f"+compileBody [s] = compileStmt s+compileBody stmts = compileStmts stmts++-- ---------------------------------------------------------------------------+-- Foreach compilation+-- ---------------------------------------------------------------------------++compileForeach :: Label -> Int -> Name -> [(ArgIndex, ValExpr)] -> [Stmt] -> SExpr+compileForeach (Label lbl) ct (Name sv) conds body =+  SList+    [ SAtom "call/cc",+      SList+        [ SAtom "lambda",+          SList [SAtom (breakName lbl)],+          SList+            [ SAtom "let-values",+              SList+                [ SList+                    [ SList [SAtom "%vec", SAtom "%count"],+                      SList [SAtom "store-snapshot", SAtom "%s", SInt (fromIntegral ct)]+                    ]+                ],+              SList+                [ SAtom "let",+                  SAtom (foreachName lbl),+                  SList [SList [SAtom "%i", SInt 0]],+                  SList+                    [ SAtom "when",+                      SList [SAtom "<", SAtom "%i", SAtom "%count"],+                      SList+                        [ SAtom "let",+                          SList+                            [ SList+                                [ SAtom sv,+                                  SList+                                    [ SAtom "vector-ref",+                                      SAtom "%vec",+                                      SAtom "%i"+                                    ]+                                ]+                            ],+                          foreachInner lbl sv conds body+                        ],+                      SList [SAtom (foreachName lbl), SList [SAtom "+", SAtom "%i", SInt 1]]+                    ]+                ]+            ]+        ]+    ]++foreachInner :: Text -> Text -> [(ArgIndex, ValExpr)] -> [Stmt] -> SExpr+foreachInner lbl sv conds body =+  let aliveCheck = SList [SAtom "suspension-alive?", SAtom sv]+      condChecks = map compileCondition conds+      allChecks = aliveCheck : condChecks+      guard = case allChecks of+        [c] -> c+        cs -> SList (SAtom "and" : cs)+      innerBody =+        SList+          [ SAtom "call/cc",+            SList+              [ SAtom "lambda",+                SList [SAtom (continueName lbl)],+                compileBody body+              ]+          ]+   in SList [SAtom "when", guard, innerBody]+  where+    compileCondition (ArgIndex i, e) =+      SList+        [ SAtom "equal?/chr",+          SList [SAtom "constraint-arg", SAtom sv, SInt (fromIntegral i)],+          compileValExpr e+        ]++-- ---------------------------------------------------------------------------+-- Expression compilation+-- ---------------------------------------------------------------------------++compileValExpr :: ValExpr -> SExpr+compileValExpr (Var n) = SAtom (mangleName n)+compileValExpr (Lit l) = compileLiteral l+compileValExpr (CallExpr n args) =+  SList (SAtom (mangleName n) : SAtom "%s" : map compileCallArg args)+compileValExpr (HostCall n args) =+  compileHostCall n args+compileValExpr (EvalDeep e) =+  compileEvalDeep e+compileValExpr (EvalIs e) =+  -- @is@-with-variable-RHS marker. The inner expression is always a+  -- 'Var' (the compiler only emits this form for that case): we+  -- evaluate it with deep-deref and then walk the dereferenced value+  -- through 'deep-eval-value' so a bound compound whose functor is a+  -- declared evaluable gets actually evaluated. Mirrors+  -- 'evalValExpr (EvalIs _)' in the Haskell interpreter.+  SList+    [ SAtom "deep-eval-value",+      SAtom "%s",+      compileEvalDeep e+    ]+compileValExpr NewVar =+  SList [SAtom "make-var", SAtom "%s"]+compileValExpr (MakeTerm (Name f) args) =+  SList+    [ SAtom "make-term",+      compileSymbol f,+      SList (SAtom "vector" : map compileValExpr args)+    ]+compileValExpr (GetArg e i) =+  SList [SAtom "get-arg", compileValExpr e, SInt (fromIntegral i)]+compileValExpr (FieldArg e (ArgIndex i)) =+  SList [SAtom "constraint-arg", compileIdExpr e, SInt (fromIntegral i)]+compileValExpr (FieldType e) =+  SList [SAtom "constraint-type", compileIdExpr e]++-- | Compile a 'BoolExpr' to a Scheme boolean expression. Scheme is+-- dynamically typed, so 'BFromVal' is identical to compiling the+-- wrapped 'ValExpr' — the runtime accepts whatever truthy value the+-- underlying value produces.+compileBoolExpr :: BoolExpr -> SExpr+compileBoolExpr (BLit True) = SAtom "#t"+compileBoolExpr (BLit False) = SAtom "#f"+compileBoolExpr (BNot e) = SList [SAtom "not", compileBoolExpr e]+compileBoolExpr (BAnd a b) = SList [SAtom "and", compileBoolExpr a, compileBoolExpr b]+compileBoolExpr (BOr a b) = SList [SAtom "or", compileBoolExpr a, compileBoolExpr b]+compileBoolExpr (BMatchTerm e (Name f) arity) =+  SList [SAtom "match-term", compileValExpr e, compileSymbol f, SInt (fromIntegral arity)]+compileBoolExpr (BEqual a b) =+  SList [SAtom "equal?/chr", compileValExpr a, compileValExpr b]+compileBoolExpr (BIdEqual a b) =+  SList [SAtom "id-equal?", compileIdExpr a, compileIdExpr b]+compileBoolExpr (BAlive e) =+  SList [SAtom "alive-constraint?", compileIdExpr e]+compileBoolExpr (BIsConstraintType e (ConstraintType ct)) =+  SList [SAtom "is-constraint-type?", compileIdExpr e, SInt (fromIntegral ct)]+compileBoolExpr (BNotInHistory (RuleId rid) es) =+  SList+    [ SAtom "not-in-history?",+      SAtom "%s",+      SInt (fromIntegral rid),+      SList+        ( SAtom "list"+            : map (\e -> SList [SAtom "constraint-id", compileIdExpr e]) es+        )+    ]+compileBoolExpr (BUnify a b) =+  SList [SAtom "%unify", SAtom "%s", compileValExpr a, compileValExpr b]+compileBoolExpr (BFromVal e) = compileValExpr e+compileBoolExpr (BEvalDeep e) = compileBoolEvalDeep e++compileIdExpr :: IdExpr -> SExpr+compileIdExpr (IdVar n) = SAtom (mangleName n)+compileIdExpr (CreateConstraint (ConstraintType ct) args) =+  SList+    [ SAtom "create-constraint",+      SAtom "%s",+      SInt (fromIntegral ct),+      SList (SAtom "vector" : map compileValExpr args)+    ]++compileCallArg :: CallArg -> SExpr+compileCallArg (AVal e) = compileValExpr e+compileCallArg (AId e) = compileIdExpr e++-- ---------------------------------------------------------------------------+-- Literal compilation+-- ---------------------------------------------------------------------------++compileLiteral :: Literal -> SExpr+compileLiteral (IntLit n) = SInt n+compileLiteral (FloatLit n) = SFloat n+compileLiteral (AtomLit s) = compileSymbol s+compileLiteral (TextLit s) = SString s+compileLiteral (BoolLit True) = SAtom "#t"+compileLiteral (BoolLit False) = SAtom "#f"+compileLiteral WildcardLit = SAtom "*wildcard*"++-- | Compile a text to a Scheme symbol expression.+-- Uses @(quote sym)@ for valid identifiers, @(string->symbol "...")@ otherwise.+compileSymbol :: Text -> SExpr+compileSymbol s+  | isValidSchemeIdentifier s = SList [SAtom "quote", SAtom s]+  | otherwise = SList [SAtom "string->symbol", SString s]++-- ---------------------------------------------------------------------------+-- Host calls+-- ---------------------------------------------------------------------------++-- | Known host call name mapping.+hostCallMap :: Map.Map Text Text+hostCallMap =+  Map.fromList+    [ ("div", "%idiv"),+      ("mod", "%imod"),+      ("rem", "%irem"),+      ("=<", "<="),+      ("==", "equal?/chr"),+      -- Must map: bare 'not' would bind to R6RS 'not', which treats every+      -- non-#f value as true and so disagrees with the Haskell runtime on+      -- untyped arguments. '%not' rejects non-booleans.+      ("not", "%not"),+      ("float", "flonum?"),+      ("int_to_float", "%int-to-float"),+      ("float_to_int", "%float-to-int"),+      ("write", "display"),+      ("writeln", "%writeln"),+      ("print", "%print"),+      ("string_concat", "string-append"),+      ("string_length", "string-length"),+      ("string_upper", "string-upcase"),+      ("string_lower", "string-downcase"),+      ("__chr_error", "%chr-error"),+      ("integer", "integer?"),+      ("atom", "symbol?"),+      ("boolean", "boolean?"),+      ("string", "string?"),+      ("var", "var?"),+      ("nonvar", "%nonvar?"),+      ("unifiable", "%unifiable?"),+      ("ground", "%ground?"),+      ("term_variables", "%term-variables"),+      ("compound_to_list", "%compound-to-list"),+      ("list_to_compound", "%list-to-compound"),+      ("read_term_from_string", "%read-term-from-string"),+      ("copy_term", "%copy-term")+    ]++-- | Host calls that need the session threaded as their first argument.+sessionHostCalls :: Set.Set Text+sessionHostCalls = Set.fromList ["copy_term"]++-- | Compile a host call. Arguments are dereferenced before calling.+-- Calls listed in 'sessionHostCalls' get the session @%s@ threaded as+-- their first argument (before the user-visible arguments).+compileHostCall :: Name -> [ValExpr] -> SExpr+compileHostCall = compileHostCallWith compileValExpr++-- | Worker for 'compileHostCall' parameterized by how arguments are+-- compiled. 'compileEvalDeep' reuses this with itself as the inner+-- compiler so deep-deref propagates into host-call arguments.+--+-- Names in 'hostCallMap' are rewritten to the corresponding runtime+-- procedure (e.g. @rem@ → @%irem@). Names not in the map are emitted+-- verbatim and resolve to whatever procedure is in scope in the+-- generated library's import environment — the YCHR runtime, R6RS+-- builtins, or anything the user has wired in. Guile R6RS resolves+-- top-level identifiers lazily at call time, so an unknown host name+-- only errors if it is actually invoked at runtime.+compileHostCallWith :: (ValExpr -> SExpr) -> Name -> [ValExpr] -> SExpr+compileHostCallWith compile (Name n) args =+  let fn = Map.findWithDefault n n hostCallMap+      derefedArgs = map (\a -> SList [SAtom "deref", compile a]) args+      allArgs+        | Set.member n sessionHostCalls = SAtom "%s" : derefedArgs+        | otherwise = derefedArgs+   in SList (SAtom fn : allArgs)++-- | Compile an EvalDeep expression. Like the standard expression+-- compiler, but Var references are dereferenced (following binding+-- chains) and the transformation propagates recursively into+-- sub-expressions ('call-expr' arguments, 'make-term' arguments,+-- 'host-call' arguments).+compileEvalDeep :: ValExpr -> SExpr+compileEvalDeep (Lit l) = compileLiteral l+compileEvalDeep (Var n) = SList [SAtom "deref", SAtom (mangleName n)]+compileEvalDeep (HostCall n args) = compileHostCallWith compileEvalDeep n args+compileEvalDeep (CallExpr n args) =+  SList (SAtom (mangleName n) : SAtom "%s" : map compileCallArgDeep args)+compileEvalDeep (MakeTerm (Name f) args) =+  SList+    [ SAtom "make-term",+      compileSymbol f,+      SList (SAtom "vector" : map compileEvalDeep args)+    ]+compileEvalDeep e = compileValExpr e -- GetArg, FieldArg, FieldType, NewVar++compileCallArgDeep :: CallArg -> SExpr+compileCallArgDeep (AVal e) = compileEvalDeep e+compileCallArgDeep (AId e) = compileIdExpr e++-- | Like 'compileBoolExpr', but propagates deep-deref into 'ValExpr'+-- and 'IdExpr' payloads. Mirrors 'compileEvalDeep' for booleans.+compileBoolEvalDeep :: BoolExpr -> SExpr+compileBoolEvalDeep (BNot e) = SList [SAtom "not", compileBoolEvalDeep e]+compileBoolEvalDeep (BAnd a b) =+  SList [SAtom "and", compileBoolEvalDeep a, compileBoolEvalDeep b]+compileBoolEvalDeep (BOr a b) =+  SList [SAtom "or", compileBoolEvalDeep a, compileBoolEvalDeep b]+compileBoolEvalDeep (BMatchTerm e (Name f) arity) =+  SList [SAtom "match-term", compileEvalDeep e, compileSymbol f, SInt (fromIntegral arity)]+compileBoolEvalDeep (BEqual a b) =+  SList [SAtom "equal?/chr", compileEvalDeep a, compileEvalDeep b]+compileBoolEvalDeep (BUnify a b) =+  SList [SAtom "%unify", SAtom "%s", compileEvalDeep a, compileEvalDeep b]+compileBoolEvalDeep (BFromVal e) = compileEvalDeep e+compileBoolEvalDeep (BEvalDeep e) = compileBoolEvalDeep e+compileBoolEvalDeep e = compileBoolExpr e++-- ---------------------------------------------------------------------------+-- Name mangling+-- ---------------------------------------------------------------------------++mangleName :: Name -> Text+mangleName (Name n) = n++-- | Continuation name for a foreach break.+breakName :: Text -> Text+breakName lbl = "%break-" <> lbl++-- | Continuation name for a foreach continue.+continueName :: Text -> Text+continueName lbl = "%continue-" <> lbl++-- | Named let for foreach loop.+foreachName :: Text -> Text+foreachName lbl = "%foreach-" <> lbl++-- | Check whether a text is a valid R7RS Scheme identifier.+-- Conservative: allows alphanumeric, underscore, hyphen, and common+-- Scheme "extended" identifier characters.+isValidSchemeIdentifier :: Text -> Bool+isValidSchemeIdentifier t = case T.uncons t of+  Nothing -> False+  Just (c, rest) ->+    isSchemeInitial c && T.all isSchemeSubsequent rest+  where+    isSchemeInitial c = isAlpha c || c `elem` ("!$%&*/:<=>?^_~" :: [Char])+    isSchemeSubsequent c = isSchemeInitial c || isAlphaNum c || c `elem` ("+-.@" :: [Char])
+ src/YCHR/Internal/Backend/SchemeDriver.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Generate a Scheme driver script that executes a single CHR query+-- against a compiled Scheme library.+--+-- The generated script imports the compiled library, creates logical+-- variables for query variables, calls the appropriate @tell_*@+-- procedure, and prints the variable bindings in the same format as+-- 'YCHR.Internal.Pretty.prettyBindings'.+module YCHR.Internal.Backend.SchemeDriver+  ( generateDriver,+  )+where++import Data.List (nub, sort)+import Data.List.NonEmpty qualified as NE+import Data.Text (Text)+import Data.Text qualified as T+import YCHR.Internal.Backend.Scheme (compileSymbol, qualifiedAliasIdentifier)+import YCHR.Internal.Compile (funcProcName)+import YCHR.Internal.Compile.Names (vmName)+import YCHR.Internal.Resolved qualified as R+import YCHR.Internal.SExpr (SExpr (..), printSExpr)+import YCHR.Internal.Types (HeadArg (..), QualifiedName, Term (..))+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM.Types (Name (..))++-- | Generate a complete Scheme driver script.+--+-- The script imports the generated library, creates fresh logical+-- variables for each variable mentioned in the goal arguments, calls+-- the tell procedure, and prints each variable binding sorted+-- alphabetically. Argument expressions are evaluated like any other+-- tell-side expression: 'CallExpr' triggers a function call,+-- 'HostExpr' a host call, 'CtorExpr' builds a compound term, and so+-- on.+generateDriver :: Text -> QualifiedName -> [R.Expr] -> Text+generateDriver moduleName qn args =+  let arity = length args+      -- Use the exported friendly alias (e.g. @mod:name/2@) emitted by+      -- the Scheme backend, not the internal mangled @tell_*@ — the+      -- mangled procedures are no longer exported by generated+      -- libraries. 'qualifiedAliasIdentifier' is total: it encodes any+      -- constraint name into a well-formed Scheme identifier.+      tellAlias = qualifiedAliasIdentifier (Types.qualifiedToName qn) arity+      varNames = nub (concatMap exprVars args)+      sortedVars = sort varNames+      argExprs = map exprToScheme args+      tellCall = "(" <> tellAlias <> " %s " <> T.intercalate " " argExprs <> ")"+      bindingsCall = case sortedVars of+        [] -> []+        vs ->+          [ "(pretty-bindings (list "+              <> T.intercalate+                " "+                ["(cons (quote " <> v <> ") " <> v <> ")" | v <- vs]+              <> "))"+          ]+      body = map ("    " <>) (tellCall : bindingsCall)+      -- The generated library's program-info binding is a thunk named+      -- after the library's final segment; calling it creates a fresh+      -- session.+      openSession = "(let ((%s (" <> moduleName <> ")))"+   in T.unlines $+        [ "(import (rnrs) (ychr runtime) (ychr pretty)",+          "        (ychr generated " <> moduleName <> "))",+          ""+        ]+          ++ case varNames of+            [] ->+              [openSession]+                ++ body+                ++ [")"]+            _ ->+              [ openSession,+                "  (let* ("+                  <> T.intercalate+                    "\n         "+                    [ "("+                        <> v+                        <> " (make-var %s))"+                    | v <- varNames+                    ]+                  <> ")"+              ]+                ++ body+                ++ ["))"]++-- | Convert an 'R.Expr' to a Scheme expression. Mirrors the dispatch+-- in 'YCHR.Internal.Compile.compileExpr' / 'YCHR.Internal.Backend.Scheme.compileValExpr':+-- 'CallExpr' becomes a function call, 'HostExpr' a host bridge,+-- 'CtorExpr' a 'make-term', and so on. Variables are referenced by+-- their declared name in the surrounding @let*@ block.+exprToScheme :: R.Expr -> Text+exprToScheme (R.VarExpr v) = v+exprToScheme (R.IntExpr n) = T.pack (show n)+exprToScheme (R.FloatExpr n) = printSExpr (SFloat n)+exprToScheme (R.TextExpr s) = printSExpr (SString s)+exprToScheme R.WildcardExpr = "*wildcard*"+-- @quote(arg)@: the surface quoting form opts out of evaluation. The+-- inner term stays as a data tree; mirror 'compileTerm' here.+exprToScheme (R.CtorExpr (Types.Unqualified "quote") [arg]) =+  termToScheme (R.exprToTerm arg)+-- Native-bool fast path. The renamer canonicalizes source @true@ /+-- @false@ to @prelude:true@ / @prelude:false@, and+-- 'YCHR.Internal.Compile.compileExpr' turns those into @BoolLit@ so the+-- runtime sees a real boolean. Without the same case here a goal-side+-- @true@ reaches the runtime as the /atom/ @prelude__true@, which+-- silently fails every boolean test (@boolean(X)@ answers @false@, and+-- @not(X)@ raises).+exprToScheme (R.CtorExpr (Types.Qualified "prelude" "true") []) = "#t"+exprToScheme (R.CtorExpr (Types.Qualified "prelude" "false") []) = "#f"+-- 0-arity ctors collapse to bare symbols at the runtime layer.+-- Qualified uses the @vmName@-mangled @m__n@ form; unqualified keeps+-- the raw name so unicode is preserved as data — mirrors the split in+-- 'YCHR.Internal.Compile.compileExpr' so a goal-side unqualified atom matches+-- the head-side symbol byte-for-byte.+exprToScheme (R.CtorExpr (Types.Unqualified n) []) =+  printSExpr (compileSymbol n)+exprToScheme (R.CtorExpr name@(Types.Qualified _ _) []) =+  printSExpr (compileSymbol (vmName name).unName)+exprToScheme (R.CtorExpr name args) =+  let flat = (vmName name).unName+      argExprs = map exprToScheme args+   in "(make-term "+        <> printSExpr (compileSymbol flat)+        <> " (vector "+        <> T.intercalate " " argExprs+        <> "))"+exprToScheme (R.CallExpr qn args) =+  let funcName = funcProcName (Types.qualifiedToName qn) (length args)+      argExprs = map exprToScheme args+   in "(" <> funcName.unName <> " %s " <> T.intercalate " " argExprs <> ")"+exprToScheme (R.HostExpr f args) =+  let argExprs = map exprToScheme args+   in "(" <> hostBridgeName f <> " " <> T.intercalate " " argExprs <> ")"+exprToScheme (R.ApplyExpr f args) =+  let n = length args+      dispatch = "call_" <> T.pack (show n)+      fAndArgs = map exprToScheme (f : args)+   in "(" <> dispatch <> " %s " <> T.intercalate " " fAndArgs <> ")"+exprToScheme (R.FunRefExpr qn arity) =+  -- Mirrors 'compileExpr's encoding for first-class function refs.+  let flat = (vmName (Types.qualifiedToName qn)).unName+   in "(make-term "+        <> printSExpr (compileSymbol "/")+        <> " (vector "+        <> printSExpr (compileSymbol flat)+        <> " "+        <> T.pack (show arity)+        <> "))"+exprToScheme (R.LambdaExpr _ _) =+  error+    "SchemeDriver.exprToScheme: lambdas in goal arguments \+    \are not supported in the Scheme driver"++-- | Host-call bridge name. Mirrors the encoding used by+-- 'YCHR.Internal.Backend.Scheme.compileHostCall'.+hostBridgeName :: Text -> Text+hostBridgeName f = "host__" <> f++-- | Convert a 'Term' to a Scheme expression. Used for the+-- @quote(...)@ quoting form, which keeps the inner tree opaque.+termToScheme :: Term -> Text+termToScheme (IntTerm n) = T.pack (show n)+termToScheme (FloatTerm n) = printSExpr (SFloat n)+-- Mirrors the native-bool fast path in+-- 'YCHR.Internal.Compile.compileTerm', which maps the canonicalized+-- @prelude:true@ \/ @prelude:false@ to a boolean literal even inside+-- the @quote\/1@ quoting form.+termToScheme (CompoundTerm (Types.Qualified "prelude" "true") []) = "#t"+termToScheme (CompoundTerm (Types.Qualified "prelude" "false") []) = "#f"+termToScheme (CompoundTerm (Types.Unqualified s) []) = printSExpr (compileSymbol s)+termToScheme (CompoundTerm name@(Types.Qualified _ _) []) =+  printSExpr (compileSymbol (vmName name).unName)+termToScheme (TextTerm s) = printSExpr (SString s)+termToScheme (VarTerm n) = n+termToScheme Wildcard = "*wildcard*"+termToScheme (CompoundTerm (Types.Unqualified ".") [h, t]) =+  "(%cons " <> termToScheme h <> " " <> termToScheme t <> ")"+termToScheme (CompoundTerm name@(Types.Qualified _ _) ts) =+  let flat = (vmName name).unName+      argExprs = map termToScheme ts+   in "(make-term "+        <> printSExpr (compileSymbol flat)+        <> " (vector "+        <> T.intercalate " " argExprs+        <> "))"+termToScheme (CompoundTerm (Types.Unqualified n) ts) =+  let symExpr = compileSymbol n+      argExprs = map termToScheme ts+   in "(make-term " <> printSExpr symExpr <> " (vector " <> T.intercalate " " argExprs <> "))"++-- | Collect every variable name mentioned anywhere in an expression+-- tree, so each can be declared as a logical variable in the+-- surrounding @let*@ block. Lambda parameter names are excluded+-- (they are bound locally), though lambdas are not actually supported+-- in this path — see 'exprToScheme'.+exprVars :: R.Expr -> [Text]+exprVars (R.VarExpr v) = [v]+exprVars (R.CtorExpr _ args) = concatMap exprVars args+exprVars (R.CallExpr _ args) = concatMap exprVars args+exprVars (R.ApplyExpr f args) = exprVars f ++ concatMap exprVars args+exprVars (R.HostExpr _ args) = concatMap exprVars args+exprVars (R.LambdaExpr params body) =+  filter+    (`notElem` [v | HeadVar v <- NE.toList params])+    (concatMap exprVars (NE.toList body))+exprVars _ = []
+ src/YCHR/Internal/Collect.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Library import collector.+--+-- Resolves @use_module(library(name))@ imports against the standard+-- library map. The two responsibilities are now exposed as separate+-- functions so the pipeline can build per-module operator tables before+-- the full parse:+--+--   * 'resolveLibraryClosure' walks the dependency graph from a set of+--     seed library names, returns the reachable libraries in topological+--     order, and reports unknown or circularly-imported libraries.+--+--   * 'rewriteImports' converts each parsed 'Module' to a+--     'CollectedModule', collapsing 'LibraryImport' and 'ModuleImport'+--     into the single 'CollectedImport' so everything downstream sees+--     only one kind of import.+--+--   * 'addLibraryPrelude' prepends a @prelude@ import to each library+--     module (except the prelude itself).+module YCHR.Internal.Collect+  ( CollectError (..),+    resolveLibraryClosure,+    rewriteImports,+    addLibraryPrelude,+  )+where++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 YCHR.Internal.Collected (CollectedModule, collectedFromParsed)+import YCHR.Internal.Diagnostic (Diagnostic, noDiag)+import YCHR.Internal.Parsed++data CollectError+  = UnknownLibrary Text+  | CircularLibraryImport [Text]+  deriving (Show, Eq)++-- | Walk the transitive closure of library imports.+--+-- Seeds are the user-supplied library import names (typically extracted+-- from each user module's header). When @includeStdlib@ is 'True', every+-- library in the standard library map is also seeded so the full standard+-- library is available regardless of which libraries the user imports+-- explicitly.+--+-- Returns the reachable libraries in topological order (dependencies+-- first), or a list of 'CollectError' diagnostics if any seed names an+-- unknown library or a cycle is detected.+resolveLibraryClosure ::+  Bool ->+  Map Text Module ->+  [AnnP Text] ->+  Either [Diagnostic CollectError] [Module]+resolveLibraryClosure includeStdlib stdlibMap userSeeds =+  let seeds =+        (if includeStdlib then map noAnnP (Map.keys stdlibMap) else [])+          ++ userSeeds+   in case resolveAll stdlibMap Set.empty Set.empty seeds of+        (_, libs, []) -> Right libs+        (_, _, errs) -> Left errs++-- | DFS resolution of library dependencies.+--+-- Processes a worklist of library names. For each name:+--   - If already visited (fully processed), skip.+--   - If on the current path (gray), report a cycle.+--   - Look up in the stdlib map.+--   - Recursively resolve its own library imports.+--   - Append to the result list (post-order ensures dependencies come first).+--+-- The visited set is threaded through so that a library resolved by one+-- sibling is not re-resolved by the next.+resolveAll ::+  Map Text Module ->+  Set Text ->+  Set Text ->+  [AnnP Text] ->+  (Set Text, [Module], [Diagnostic CollectError])+resolveAll _ visited _ [] = (visited, [], [])+resolveAll stdlibMap visited path (ann : rest)+  | Set.member name visited = resolveAll stdlibMap visited path rest+  | Set.member name path =+      let (visited', restMods, restErrs) = resolveAll stdlibMap visited path rest+       in ( visited',+            restMods,+            noDiag+              ( AnnP+                  ( CircularLibraryImport+                      ( Set.toList path+                          ++ [name]+                      )+                  )+                  ann.sourceLoc+                  ann.parsed+              )+              : restErrs+          )+  | otherwise =+      case Map.lookup name stdlibMap of+        Nothing ->+          let (visited', restMods, restErrs) = resolveAll stdlibMap visited path rest+           in ( visited',+                restMods,+                noDiag (AnnP (UnknownLibrary name) ann.sourceLoc ann.parsed) : restErrs+              )+        Just m ->+          let deps = libraryImports m+              path' = Set.insert name path+              (visited1, depMods, depErrs) = resolveAll stdlibMap visited path' deps+              visited2 = Set.insert name visited1+              (visited3, restMods, restErrs) = resolveAll stdlibMap visited2 path rest+           in (visited3, depMods ++ [m] ++ restMods, depErrs ++ restErrs)+  where+    name = ann.node++-- | Extract library import names from a module.+libraryImports :: Module -> [AnnP Text]+libraryImports m = [AnnP n loc p | AnnP (LibraryImport n _) loc p <- m.imports]++-- | Add a prelude import to every library module that does not already+-- declare itself to be the prelude.+addLibraryPrelude :: [Module] -> [Module]+addLibraryPrelude = map go+  where+    go :: Module -> Module+    go m+      | m.name == "prelude" = m+      | otherwise = m {imports = noAnnP (LibraryImport "prelude" Nothing) : m.imports}++-- | Convert each parsed 'Module' to a 'CollectedModule', collapsing both+-- import kinds into 'CollectedImport'. After this point the+-- library-vs-module distinction no longer exists in the types. The+-- per-module conversion lives in "YCHR.Internal.Collected" ('collectedFromParsed').+rewriteImports :: [Module] -> [CollectedModule]+rewriteImports = map collectedFromParsed
+ src/YCHR/Internal/Collected.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DuplicateRecordFields #-}++-- | Collected AST: the module representation produced by the collect+-- phase ('YCHR.Internal.Collect.rewriteImports') and consumed by 'YCHR.Internal.Rename'+-- and 'YCHR.Internal.Resolve'.+--+-- It is structurally identical to 'YCHR.Internal.Parsed.Module' except for one+-- field: imports. The parser's 'YCHR.Internal.Parsed.Import' distinguishes a+-- @use_module(M)@ ('ModuleImport') from a @use_module(library(L))@+-- ('LibraryImport'). That distinction matters only inside the collect+-- phase, which resolves the library closure and then rewrites every+-- library import to a plain module import. Once collection is done the+-- two are indistinguishable, so 'CollectedModule' carries a single+-- 'CollectedImport' with no library/module tag — making a stray+-- 'LibraryImport' unrepresentable in everything downstream of+-- 'rewriteImports' rather than relying on convention.+--+-- The shared field names (matched against 'YCHR.Internal.Parsed.Module') let the+-- rename and resolve passes access fields with 'OverloadedRecordDot'+-- without caring which record they hold.+module YCHR.Internal.Collected+  ( CollectedModule (..),+    CollectedImport (..),+    collectedFromParsed,+  )+where++import Data.Text (Text)+import YCHR.Internal.Parsed+  ( Ann,+    AnnP (..),+    Declaration,+    FunctionEquation,+    Import (..),+    Module (..),+    Rule,+    SourceLoc,+    TypeDefinition,+  )++-- | An import after collection: just the source module name and an+-- optional import list. The library-vs-module distinction is gone.+data CollectedImport = CollectedImport+  { importModule :: Text,+    importItems :: Maybe [Declaration]+  }+  deriving (Show, Eq)++-- | A module after the collect phase. Mirrors 'YCHR.Internal.Parsed.Module'+-- field-for-field, differing only in the element type of 'imports'.+data CollectedModule = CollectedModule+  { name :: Text,+    nameLoc :: SourceLoc,+    imports :: [AnnP CollectedImport],+    decls :: [Ann Declaration],+    extensionTypes :: [Ann Declaration],+    typeDecls :: [Ann TypeDefinition],+    rules :: [Rule],+    equations :: [AnnP FunctionEquation],+    extensions :: [AnnP FunctionEquation],+    classExtensions :: [AnnP FunctionEquation],+    exports :: Maybe (AnnP [Declaration])+  }+  deriving (Show, Eq)++-- | Convert a parsed 'Module' to a 'CollectedModule', collapsing both+-- import kinds into 'CollectedImport'. This is the single boundary at+-- which the library-vs-module distinction is erased; everything+-- downstream sees only 'CollectedImport'. Defined here (rather than in+-- 'YCHR.Internal.Collect') so that callers need not bring 'CollectedModule''s+-- field names into scope: doing so would make their own parsed-'Module'+-- record updates ambiguous (the two records share field names).+collectedFromParsed :: Module -> CollectedModule+collectedFromParsed m =+  CollectedModule+    { name = m.name,+      nameLoc = m.nameLoc,+      imports = map (fmap collectedImport) m.imports,+      decls = m.decls,+      extensionTypes = m.extensionTypes,+      typeDecls = m.typeDecls,+      rules = m.rules,+      equations = m.equations,+      extensions = m.extensions,+      classExtensions = m.classExtensions,+      exports = m.exports+    }+  where+    collectedImport (ModuleImport n il) = CollectedImport n il+    collectedImport (LibraryImport n il) = CollectedImport n il
+ src/YCHR/Internal/Compile.hs view
@@ -0,0 +1,1270 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : YCHR.Internal.Compile+-- Description : Transforms a desugared CHR program into a VM program.+--+-- The Compiler is the transformation pass between the desugared+-- 'YCHR.Internal.Desugared.Program' and the abstract 'YCHR.Internal.VM.Program' consumed by+-- the backends and the interpreter. It performs, in order:+--+-- 1. /Occurrence collection/: 'collectOccurrences' walks every rule head+--    and produces, for each constraint type, a top-down list of+--    'Occurrence' records numbered as required by the refined operational+--    semantics (paper §2.2, Fig. 2).+--+-- 2. /Per-constraint procedure generation/: for each entry in the symbol+--    table 'genConstraintProcs' emits a @tell_c@, an @activate_c@, and one+--    @occurrence_c_j@ procedure per occurrence (paper §5.2, Listings 1+--    and 2).+--+-- 3. /Function compilation/: 'compileFunctionDef' emits one VM procedure+--    per user-defined function, with equations tried in source order.+--+-- 4. /Reactivation dispatch/: 'genReactivateDispatch' emits a single+--    @reactivate_dispatch@ procedure that selects the right @activate_c@+--    based on a suspension's constraint type (paper §5.3, "Selective+--    Constraint Reactivation").+--+-- 5. /@$call@ dispatch/: 'genCallFunDispatches' emits one+--    @call_N@ procedure per supported call arity to dispatch first-class+--    function values (function references and lifted lambda closures).+--+-- The basic compilation scheme is from paper §5.2; the Early Drop and+-- Backjumping optimizations are from §5.3 (Listing 8). Selective+-- Constraint Reactivation is implemented at the runtime level (the+-- observer pattern in 'YCHR.Internal.Runtime.Reactivation') — this pass only emits+-- 'DrainReactivationQueue' calls after each tell-side @Unify@.+--+-- Non-obvious design choices are documented in the \"Notes\" block at the+-- bottom of this file.+module YCHR.Internal.Compile+  ( -- * Errors+    CompileError (..),++    -- * Compilation+    compile,++    -- * Function compilation+    compileFunctionDef,++    -- * Call dispatch+    genCallFunDispatches,++    -- * Re-exported name builders (see "YCHR.Internal.Compile.Names")+    funcProcName,+    vmName,+    procNameFor,+    tellProcName,+    activateProcName,+    occProcName,+  )+where++import Control.Monad (foldM)+import Control.Monad.Trans.Writer.CPS (Writer, runWriter, tell)+import Data.List (nub, partition, sortOn)+import Data.List qualified as List+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 YCHR.Internal.Compile.Names+import YCHR.Internal.Compile.Occurrences (collectOccurrences)+import YCHR.Internal.Compile.Types+import YCHR.Internal.Desugared qualified as D+import YCHR.Internal.Diagnostic (Diagnostic (..))+import YCHR.Internal.Loc (SourceLoc)+import YCHR.Internal.PExpr (PExpr)+import YCHR.Internal.Parsed (AnnP (..))+import YCHR.Internal.Parsed qualified as P+import YCHR.Internal.Pretty (prettyPExprSrc)+import YCHR.Internal.Resolved qualified as R+import YCHR.Internal.Types+  ( HeadArg (..),+    Identifier (..),+    SymbolTable,+    Term (..),+    flattenName,+    symbolTableSize,+    symbolTableToList,+  )+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM++-- | Source location, original parsed expression, and optional context+-- label, extracted from an 'AnnP' wrapper.+data SrcInfo = SrcInfo+  { -- | Source location attached to the originating 'AnnP'.+    srcLoc :: P.SourceLoc,+    -- | Pretty-printable parsed form, used to render diagnostics.+    srcParsed :: PExpr,+    -- | Optional context label (e.g. @"rule foo"@ or+    -- @"function bar/2"@) prefixed onto diagnostic messages.+    srcLabel :: Maybe Text+  }++-- ---------------------------------------------------------------------------+-- Public API+-- ---------------------------------------------------------------------------++-- | Compile a desugared program against the given constraint-type symbol+-- table. Returns 'Right' a 'YCHR.Internal.VM.Program' on success, or 'Left' the+-- accumulated errors. Errors from every sub-pass are collected before+-- the function decides to fail, so callers see as much detail as+-- possible in one go.+compile :: D.Program -> SymbolTable -> Either [Diagnostic CompileError] Program+compile prog symTab =+  let ( (occMap, ruleDisplayNames),+        occErrs+        ) = runWriter (collectOccurrences symTab prog)+      (procs, procErrs) = runWriter $ do+        fmap concat $+          traverse (genConstraintProcs symTab occMap) (symbolTableToList symTab)+      (funProcs, funErrs) = runWriter $ do+        traverse compileFunctionDef prog.functions+      dispatch = genReactivateDispatch symTab+      callFunDispatches = genCallFunDispatches prog.functions+      allErrs = occErrs ++ procErrs ++ funErrs+   in if null allErrs+        then+          Right+            Program+              { numTypes = symbolTableSize symTab,+                typeNames = buildTypeNames symTab,+                numRules = length ruleDisplayNames,+                ruleNames = ruleDisplayNames,+                procedures = procs ++ funProcs ++ [dispatch] ++ callFunDispatches,+                evaluables = buildEvaluables prog.functions+              }+        else Left allErrs++-- | Build the dispatch table consumed by the runtime @is@+-- deep-evaluator. Each user-defined function contributes one entry+-- mapping its 'EvaluableKey' (VM-encoded functor + arity, matching+-- the form stored on a @VTerm@) to the mangled 'funcProcName' that+-- resolves the compiled procedure.+--+-- The list may carry one entry per source function, which means the+-- @(functor, arity)@ key is unique by construction: the language+-- already forbids two functions of the same name and arity (an+-- @open_function@ across modules still has a single equation set+-- under the same qualified name, so it surfaces here as one entry).+-- The runtime's @Map.fromList@ would otherwise pick the last entry+-- silently.+buildEvaluables :: [D.Function] -> [(EvaluableKey, Name)]+buildEvaluables functions =+  [ ( EvaluableKey {functor = vmName funcName, arity = func.arity},+      funcProcName funcName func.arity+    )+  | func <- functions,+    let funcName = Types.qualifiedToName func.name+  ]++-- | Build the list of constraint type source names, indexed by+-- 'Types.ConstraintType'. The list is ordered by the constraint type's+-- integer index, so @typeNames !! i@ is the name of the type with index @i@.+buildTypeNames :: SymbolTable -> [Types.Name]+buildTypeNames symTab =+  [ ident.name+  | (ident, _) <- sortOn (ctIndex . snd) (symbolTableToList symTab)+  ]+  where+    ctIndex (Types.ConstraintType i) = i++-- ---------------------------------------------------------------------------+-- Procedure generation for each constraint type+-- ---------------------------------------------------------------------------++genConstraintProcs ::+  SymbolTable ->+  OccurrenceMap ->+  ( Identifier,+    ConstraintType+  ) ->+  Writer [Diagnostic CompileError] [Procedure]+genConstraintProcs symTab occMap (ident, cType) = do+  -- Passive occurrences (paper §5.3, marked by 'YCHR.Internal.Compile.Passive')+  -- can never fire when this constraint is active, so we emit neither+  -- their occurrence procedure nor the call to it from activate. They+  -- keep their ωr numbers, so the surviving procedures' names are stable.+  let occs = filter (not . (.passive)) (lookupOccurrences ident occMap)+      tellProc = genTell ident.name cType ident.arity+      activate = genActivate ident.name cType ident.arity occs+  occProcs <- traverse (genOccurrence symTab ident.name cType ident.arity) occs+  pure (tellProc : activate : occProcs)++-- ---------------------------------------------------------------------------+-- tell_c+-- ---------------------------------------------------------------------------++genTell :: Types.Name -> ConstraintType -> Int -> Procedure+genTell name cType arity =+  let params = argNames arity+      tellName = tellProcName name arity+      activateName = activateProcName name arity+   in Procedure+        { name = tellName,+          params = params,+          body =+            [ LetId activeName (CreateConstraint cType (map Var params)),+              Store (IdVar activeName),+              ExprStmt (CallExpr activateName [AId (IdVar activeName)])+            ],+          procKind = PKTell cType+        }++-- ---------------------------------------------------------------------------+-- activate_c+-- ---------------------------------------------------------------------------++-- | Generate the @activate_c@ procedure. Takes the active constraint as+-- its single parameter, extracts the constraint arguments into local+-- variables, and tries each occurrence procedure in order (paper §5.2,+-- Listing 2 with Early Drop from Listing 8).+genActivate :: Types.Name -> ConstraintType -> Int -> [Occurrence] -> Procedure+genActivate name cType arity occs =+  let activateName = activateProcName name arity+      argExtracts =+        [ LetVal (argName i) (FieldArg (IdVar activeName) (ArgIndex i))+        | i <- [0 .. arity - 1]+        ]+      body =+        argExtracts+          ++ concatMap genActivateCall occs+          ++ [Return (Lit (BoolLit False))]+   in Procedure+        { name = activateName,+          params = [activeName],+          body = body,+          procKind = PKActivate cType+        }+  where+    occCallArgs =+      AId (IdVar activeName) : map (AVal . Var) (argNames arity)+    genActivateCall occ =+      let occName = occProcName name arity occ.number+       in [ LetVal dropResultName (CallExpr occName occCallArgs),+            If (BFromVal (Var dropResultName)) [Return (Lit (BoolLit True))] []+          ]++-- ---------------------------------------------------------------------------+-- occurrence_c_j+-- ---------------------------------------------------------------------------++genOccurrence ::+  SymbolTable ->+  Types.Name ->+  ConstraintType ->+  Int ->+  Occurrence ->+  Writer [Diagnostic CompileError] Procedure+genOccurrence symTab name cType arity occ = do+  let params = activeName : argNames arity+      procName' = occProcName name arity occ.number+      varMap = buildVarMap occ+  body <- genOccurrenceBody symTab varMap occ+  pure+    Procedure+      { name = procName',+        params = params,+        body = body,+        procKind = PKOccurrence cType occ.number.unOccurrenceNumber occ.ruleId occ.ruleDisplay+      }++-- | Map every user-written head variable in an 'Occurrence' to the+-- generated VM variable that holds its value (an @X_i@ for the active+-- constraint, a @pArg_k_j@ for partner @k@). 'HeadWildcard' arguments+-- contribute no binding: wildcards are never referenced from guards+-- or bodies. See the \"Notes\" block at the bottom of this file.+buildVarMap :: Occurrence -> VarMap+buildVarMap occ =+  let activeBindings =+        [ (v, Var (argName i))+        | (i, HeadVar v) <- zip [0 ..] occ.activeArgs+        ]+      partnerBindings =+        [ (v, Var (partArgName k j))+        | (k, partner) <- zip [PartnerIndex 0 ..] occ.partners,+          (j, HeadVar v) <- zip [0 ..] partner.constraint.args+        ]+   in varMapFromList (activeBindings ++ partnerBindings)++-- | Compile the body of an occurrence procedure: build the innermost+-- "guards-then-fire" block, wrap it in one nested 'Foreach' per partner,+-- then append the trailing @Return false@ that signals "no early drop".+genOccurrenceBody ::+  SymbolTable ->+  VarMap ->+  Occurrence ->+  Writer [Diagnostic CompileError] [Stmt]+genOccurrenceBody symTab varMap occ = do+  (inner, condMap) <- genGuardedFire symTab varMap occ+  let body = wrapInPartnerLoops occ condMap inner+  -- Push the rule frame at procedure entry, so it is live during guard+  -- evaluation (and the history check) as well as body execution. A guard+  -- that errors (e.g. evaluates to a non-boolean) then reports the rule's+  -- source location and label, just like a body error. The frame is scoped+  -- to this call via 'withSavedCallStack', so it does not accumulate.+  pure (PushFrame (mkRuleFrame occ) : body ++ [Return (Lit (BoolLit False))])++-- | Compile the guards followed by the rule-firing block. Returns the+-- statements that go at the innermost partner-loop position — any HNF+-- match-guard wrappers (lets and structural @if@s introduced by+-- 'D.GuardMatch' / 'D.GuardGetArg') wrapped around the conditional+-- 'genFireStmts' result — together with the per-partner index+-- conditions lifted out of equality check guards by 'compileCheckGuards'.+genGuardedFire ::+  SymbolTable ->+  VarMap ->+  Occurrence ->+  Writer [Diagnostic CompileError] ([Stmt], PartnerCondMap)+genGuardedFire symTab varMap occ = do+  let AnnP {node = guards, sourceLoc = guardLoc, parsed = guardP} = occ.rule.guard+      ruleLabel = Just ("rule " <> occ.ruleDisplay)+      guardSi = SrcInfo guardLoc guardP ruleLabel+  compiled <- compileGuards (Just occ) varMap guardSi guards+  fireStmts <- genFireStmts symTab compiled.extendedVarMap occ+  let guarded = case compiled.residualCheck of+        Nothing -> fireStmts+        Just gExpr -> [If gExpr fireStmts []]+  pure (compiled.matchWrapper guarded, compiled.indexConditions)++-- | Wrap a pre-built inner block in one nested 'Foreach' per partner+-- (paper §5.2, Listing 1). For each partner @k@ this produces:+--+-- @+-- Foreach Lk cType susp_k condsK [+--   let pId_k  = susp_k.id+--   let pArg_… = susp_k.arg(…)+--   if pId_k ≠ id ∧ pId_k ≠ pId_0 ∧ … then+--     ‹inner — possibly another Foreach for partner k+1›+-- ]+-- @+--+-- @condsK@ is the index-condition list lifted out of equality check+-- guards by 'compileCheckGuards' (paper §5.3, "Indexing"): the iterator+-- skips candidates whose argument values do not match without ever+-- entering the loop body.+--+-- When @occ@ has no partners the inner block is returned unchanged.+wrapInPartnerLoops :: Occurrence -> PartnerCondMap -> [Stmt] -> [Stmt]+wrapInPartnerLoops occ condMap inner =+  -- Loops are built innermost-first by folding from the right, so the+  -- partner with the highest index ends up as the innermost loop and+  -- partner 0 as the outermost — matching the source order of the head.+  foldr wrapOne inner (zip [PartnerIndex 0 ..] occ.partners)+  where+    wrapOne :: (PartnerIndex, Partner) -> [Stmt] -> [Stmt]+    wrapOne (k, partner) inside =+      let label = partLabel k+          suspVar = partSuspName k+          partArity = length partner.constraint.args+          conds = [(c.argIndex, c.expectedValue) | c <- Map.findWithDefault [] k condMap]+          -- Bind the partner's id and arguments as ordinary locals so+          -- the rest of the body can reference them by name. The id is+          -- the suspension itself: 'IdVar suspVar' is renamed to+          -- 'IdVar (partIdName k)' for symmetry with subsequent uses.+          fieldExtracts =+            LetId (partIdName k) (IdVar suspVar)+              : [ LetVal (partArgName k j) (FieldArg (IdVar suspVar) (ArgIndex j))+                | j <- [0 .. partArity - 1]+                ]+          -- The partner must be distinct from the active constraint and+          -- from every earlier partner: at most one suspension can play+          -- a given role in a rule firing. No alive checks here — the+          -- Foreach iterator guarantees yielded partners are alive, and+          -- the active constraint's liveness is verified after body+          -- execution (early drop / backjumping in 'genFireStmts').+          distinctActive = BNot (BIdEqual (IdVar (partIdName k)) (IdVar activeName))+          distinctEarlier =+            [ BNot (BIdEqual (IdVar (partIdName k)) (IdVar (partIdName j)))+            | j <- [PartnerIndex 0 .. k - 1]+            ]+          distinctAll = List.foldl' BAnd distinctActive distinctEarlier+          guarded = [If distinctAll inside []]+       in [Foreach label partner.cType suspVar conds (fieldExtracts ++ guarded)]++-- ---------------------------------------------------------------------------+-- Fire: history check + kill + body + early drop + backjumping+-- ---------------------------------------------------------------------------++genFireStmts ::+  SymbolTable ->+  VarMap ->+  Occurrence ->+  Writer [Diagnostic CompileError] [Stmt]+genFireStmts symTab varMap occ = do+  let rule = occ.rule+      AnnP {node = ruleHead} = rule.head+      isPropagation = null ruleHead.removed+      activeIsRemoved = not occ.isKept+      ruleId' = occ.ruleId+      historyIds = buildHistoryIds occ+      killStmts = genKillStmts occ+  let AnnP {node = ruleBody, sourceLoc = bodyLoc, parsed = bodyP} = rule.body+      ruleLabel = Just ("rule " <> occ.ruleDisplay)+      bodySi = SrcInfo bodyLoc bodyP ruleLabel+  bodyStmts <- compileBodyGoals symTab varMap bodySi ruleBody+  let earlyDropStmts+        | activeIsRemoved = [Return (Lit (BoolLit True))]+        | otherwise = [If (BNot (BAlive (IdVar activeName))) [Return (Lit (BoolLit True))] []]+      -- Backjumping (paper §5.3): after body execution, check each+      -- partner's liveness outermost-first.  If a partner died (e.g.+      -- killed by a rule fired during body execution), Continue to its+      -- Foreach loop to skip useless inner iterations.+      --+      -- Removed partners are omitted: they were explicitly killed by+      -- killStmts above, so they are guaranteed dead and the check+      -- would always succeed.  The outermost removed partner's Continue+      -- would be unconditional, making all subsequent checks unreachable+      -- (paper §5.3, "all following alive tests thus becomes redundant").+      --+      -- When activeIsRemoved the early drop is an unconditional Return,+      -- so backjumps are unreachable.+      backjumpStmts+        | activeIsRemoved = []+        | otherwise =+            [ If+                (BNot (BAlive (IdVar (partIdName k))))+                [Continue (partLabel k)]+                []+            | (k, p) <- zip [PartnerIndex 0 ..] occ.partners,+              p.isKept+            ]+      -- The rule frame is pushed at occurrence-procedure entry (see+      -- 'genOccurrenceBody'), so it is already on the call stack here.+      coreFireStmts =+        killStmts+          ++ bodyStmts+          ++ earlyDropStmts+          ++ backjumpStmts+  pure $+    if isPropagation+      then+        [ If+            (BNotInHistory ruleId' historyIds)+            (AddHistory ruleId' historyIds : coreFireStmts)+            []+        ]+      else coreFireStmts++-- | Collect constraint identifiers for the propagation history tuple.+-- IDs are sorted by head position so that the same rule with the same+-- partner combination always produces an identical tuple regardless of+-- which occurrence is active (paper §5.2, Listing 1, line 14).+buildHistoryIds :: Occurrence -> [IdExpr]+buildHistoryIds occ =+  let positions =+        (occ.activeIdx, IdVar activeName)+          : [ (p.idx, IdVar (partIdName k))+            | (k, p) <- zip [PartnerIndex 0 ..] occ.partners+            ]+   in map snd (sortOn fst positions)++-- | Build a 'StackFrame' for a rule firing.+mkRuleFrame :: Occurrence -> StackFrame+mkRuleFrame occ =+  let label = "rule " <> occ.ruleDisplay+   in mkFrame label occ.rule.head.sourceLoc occ.rule.head.parsed++-- | Build a 'StackFrame' from a label, source location, and parsed expression.+mkFrame :: Text -> SourceLoc -> PExpr -> StackFrame+mkFrame label loc pexpr =+  StackFrame+    { frameLabel = label,+      frameSourceLoc = loc,+      frameSourceCode = T.pack (prettyPExprSrc pexpr)+    }++genKillStmts :: Occurrence -> [Stmt]+genKillStmts occ =+  let -- Kill removed partners+      partnerKills =+        [ Kill (IdVar (partIdName k))+        | (k, p) <- zip [PartnerIndex 0 ..] occ.partners,+          not p.isKept+        ]+      -- Kill active if removed+      activeKill = [Kill (IdVar activeName) | not occ.isKept]+   in partnerKills ++ activeKill++-- ---------------------------------------------------------------------------+-- Compile terms+-- ---------------------------------------------------------------------------++compileTerm :: VarMap -> SrcInfo -> Term -> Writer [Diagnostic CompileError] ValExpr+compileTerm varMap si (VarTerm v) = case lookupVar v varMap of+  Just expr -> pure expr+  Nothing -> do+    tell [Diagnostic si.srcLabel (AnnP (UnboundVariable v) si.srcLoc si.srcParsed)]+    pure (Lit WildcardLit)+compileTerm _ _ (IntTerm n) = pure (Lit (IntLit n))+compileTerm _ _ (FloatTerm n) = pure (Lit (FloatLit n))+compileTerm _ _ (TextTerm s) = pure (Lit (TextLit s))+-- Native-bool fast path: source @true@/@false@ reach @compileTerm@ only+-- as the renamer-canonicalized @prelude:true@ / @prelude:false@ form+-- (see 'YCHR.Internal.Rename.canonicalizeDataCon'). Match the canonical compound+-- shape so the @If@ instruction can dispatch on @VBool@ without boxing.+compileTerm _ _ (CompoundTerm (Types.Qualified "prelude" "true") []) =+  pure (Lit (BoolLit True))+compileTerm _ _ (CompoundTerm (Types.Qualified "prelude" "false") []) =+  pure (Lit (BoolLit False))+-- 0-arity compounds normalize to atom literals: at the runtime layer+-- the canonical form is 'VAtom' (no empty-args vector), and 'AtomLit'+-- is the cheap VM constructor for that value. 'BMatchTerm' accepts+-- 'VAtom' for arity-0 tests so the dispatch invariant is preserved at+-- the matcher layer rather than via a parallel runtime representation.+--+-- Qualified 0-arity uses 'vmName' for the @m__n@ mangled functor;+-- unqualified 0-arity (user-quoted atoms, undeclared bare names)+-- keeps the raw name so unicode is preserved as data — 'vmName' would+-- escape non-ASCII to @%%u\<hex\>@, which is appropriate for+-- qualified-name mangling but not for atom values.+compileTerm _ _ (CompoundTerm name@(Types.Qualified _ _) []) =+  pure (Lit (AtomLit (vmName name).unName))+compileTerm _ _ (CompoundTerm (Types.Unqualified n) []) =+  pure (Lit (AtomLit n))+compileTerm varMap si (CompoundTerm name args) = do+  args' <- traverse (compileTerm varMap si) args+  pure (MakeTerm (vmName name) args')+compileTerm _ _ Wildcard = pure (Lit WildcardLit)++-- | Lower a typed 'D.Expr' to a VM 'ValExpr'. Each constructor maps to+-- exactly one runtime behavior:+--+--   * 'D.CallExpr' / 'D.ApplyExpr' / 'D.HostExpr' produce 'CallExpr' /+--     'HostCall' instructions.+--   * 'D.CtorExpr' produces a 'MakeTerm', with its arguments recursively+--     lowered. The native-bool fast path and the @quote\/1@ quoting form+--     are the only structural special cases.+--   * 'D.FunRefExpr' produces the canonical @'/'(<flatname>, <arity>)@+--     compound that 'genCallFunDispatches' pattern-matches at runtime.+--   * 'D.LambdaExpr' is removed by lambda lifting before compilation+--     and is therefore unreachable here.+compileExpr ::+  VarMap ->+  SrcInfo ->+  D.Expr ->+  Writer [Diagnostic CompileError] ValExpr+compileExpr varMap si e = case e of+  R.VarExpr v -> case lookupVar v varMap of+    Just expr -> pure expr+    Nothing -> do+      tell [Diagnostic si.srcLabel (AnnP (UnboundVariable v) si.srcLoc si.srcParsed)]+      pure (Lit WildcardLit)+  R.IntExpr n -> pure (Lit (IntLit n))+  R.FloatExpr n -> pure (Lit (FloatLit n))+  R.TextExpr s -> pure (Lit (TextLit s))+  R.WildcardExpr -> pure (Lit WildcardLit)+  -- Native-bool fast path: the renamer canonicalizes source @true@ /+  -- @false@ to @prelude:true@ / @prelude:false@ (see+  -- 'YCHR.Internal.Rename.canonicalizeDataCon'). Matching them structurally+  -- lets 'If' dispatch on 'VBool' without boxing.+  R.CtorExpr (Types.Qualified "prelude" "true") [] ->+    pure (Lit (BoolLit True))+  R.CtorExpr (Types.Qualified "prelude" "false") [] ->+    pure (Lit (BoolLit False))+  -- @quote\/1@ short-circuit: the subtree stays opaque (no calls are+  -- evaluated). Delegate to 'compileTerm' on the surface 'Term' shape+  -- of the argument; the user opts into this with @quote(foo(X))@ when+  -- they want @foo@ kept structural even if it is also a declared+  -- function.+  R.CtorExpr (Types.Unqualified "quote") [arg] ->+    compileTerm varMap si (R.exprToTerm arg)+  -- 0-arity ctors collapse to atom literals at runtime (see comment+  -- in 'compileTerm'). Compiler never emits @MakeTerm name []@.+  R.CtorExpr name@(Types.Qualified _ _) [] ->+    pure (Lit (AtomLit (vmName name).unName))+  R.CtorExpr (Types.Unqualified n) [] ->+    pure (Lit (AtomLit n))+  -- Other constructor compounds: arguments stay in expression context+  -- so nested calls (e.g. @foo(X)@ inside @pair(foo(X), bar)@) are+  -- evaluated.+  R.CtorExpr name args -> do+    args' <- traverse (compileExpr varMap si) args+    pure (MakeTerm (vmName name) args')+  R.CallExpr qn args -> do+    args' <- traverse (compileExpr varMap si) args+    let funcName = Types.qualifiedToName qn+    pure (CallExpr (funcProcName funcName (length args')) (map AVal args'))+  R.ApplyExpr f args -> do+    fAndArgs <- traverse (compileExpr varMap si) (f : args)+    pure (CallExpr (callFunProcName (length args)) (map AVal fAndArgs))+  R.HostExpr f args -> do+    args' <- traverse (compileExpr varMap si) args+    pure (HostCall (Name f) args')+  R.FunRefExpr qn arity ->+    pure+      ( MakeTerm+          (Name "/")+          [ Lit (AtomLit (flattenName (Types.qualifiedToName qn))),+            Lit (IntLit (fromIntegral arity))+          ]+      )+  R.LambdaExpr {} ->+    error "Compile.compileExpr: LambdaExpr survived lambda lifting"++-- ---------------------------------------------------------------------------+-- Compile guards+-- ---------------------------------------------------------------------------++-- | Free 'Var' / 'IdVar' names occurring in a 'ValExpr'. Used by the+-- index-condition pushdown classifier to decide whether the+-- non-partner-arg side of an equality is referenceable at a partner+-- loop's evaluation point. Walks through 'IdExpr' children too: even+-- though their bindings live in a separate environment slot at+-- runtime, scope-wise they share a single source-level namespace.+freeVars :: ValExpr -> Set Name+freeVars = goV+  where+    goV (Var n) = Set.singleton n+    goV (Lit _) = Set.empty+    goV NewVar = Set.empty+    goV (CallExpr _ args) = Set.unions (map goA args)+    goV (HostCall _ es) = Set.unions (map goV es)+    goV (EvalDeep e) = goV e+    goV (EvalIs e) = goV e+    goV (MakeTerm _ es) = Set.unions (map goV es)+    goV (GetArg e _) = goV e+    goV (FieldArg e _) = goI e+    goV (FieldType e) = goI e++    goI (IdVar n) = Set.singleton n+    goI (CreateConstraint _ es) = Set.unions (map goV es)++    goA (AVal e) = goV e+    goA (AId e) = goI e++-- | Set of variable names visible at the moment partner @k@'s+-- 'YCHR.Internal.VM.Foreach' evaluates its index-condition expressions: the+-- active constraint's argument names, plus every earlier partner's+-- argument names. Match-guard 'LetVal' bindings are deliberately /not/+-- included — they live inside the innermost guard wrapper and are not+-- in scope at any 'Foreach' evaluation point.+inScopeBeforeLoop :: Occurrence -> PartnerIndex -> Set Name+inScopeBeforeLoop occ k =+  let activeNames = Set.fromList (argNames occ.conArity)+      earlierPartnerNames =+        Set.fromList+          [ partArgName k' j+          | (k', p) <- zip [PartnerIndex 0 ..] occ.partners,+            k' < k,+            j <- [0 .. length p.constraint.args - 1]+          ]+   in activeNames `Set.union` earlierPartnerNames++-- | Recognise a 'ValExpr' that is a reference to a partner argument+-- variable. The inverse of 'partArgName' for the partner indices and+-- arities present in @occ@.+asPartnerArg :: Occurrence -> ValExpr -> Maybe (PartnerIndex, ArgIndex)+asPartnerArg occ (Var n) = Map.lookup n partArgs+  where+    partArgs =+      Map.fromList+        [ (partArgName k j, (k, ArgIndex j))+        | (k, p) <- zip [PartnerIndex 0 ..] occ.partners,+          j <- [0 .. length p.constraint.args - 1]+        ]+asPartnerArg _ _ = Nothing++-- | Try to lift an @Equal a b@ check to an index condition on a partner+-- 'YCHR.Internal.VM.Foreach'. Returns @Just (k, j, other)@ when exactly one side+-- is partner @k@'s @j@-th argument and the other side's free variables+-- are all in scope at loop @k@'s evaluation point. Returns @Nothing@ if+-- neither side qualifies — in which case the equality stays in the+-- residual check expression.+classifyEqual ::+  Occurrence ->+  ValExpr ->+  ValExpr ->+  Maybe (PartnerIndex, ArgIndex, ValExpr)+classifyEqual occ a b+  | Just (k, j) <- asPartnerArg occ a,+    freeVars b `Set.isSubsetOf` inScopeBeforeLoop occ k =+      Just (k, j, b)+  | Just (k, j) <- asPartnerArg occ b,+    freeVars a `Set.isSubsetOf` inScopeBeforeLoop occ k =+      Just (k, j, a)+  | otherwise = Nothing++-- | Compile a guard conjunction. Guards are split into two groups:+--+--   * __Match guards__ ('D.GuardMatch', 'D.GuardGetArg') introduce new+--     variable bindings and structural checks. They are compiled into+--     a wrapper @[Stmt] -> [Stmt]@ that nests the inner code inside+--     conditionals and let-bindings. Match guards must be processed+--     first so that the variables they bind are in scope for check+--     guards.+--+--   * __Check guards__ ('D.GuardEqual', 'D.GuardExpr') are pure boolean+--     tests. Equalities whose shape matches 'classifyEqual' are lifted+--     into per-partner index conditions ('PartnerCondMap'); the rest+--     are compiled into a single 'And'-chained residual expression.+--+-- The 'Maybe' 'Occurrence' parameter enables the index-condition+-- pushdown classifier when an occurrence context is available; pass+-- 'Nothing' (e.g. when compiling user-defined function equations) to+-- bypass classification — no partners exist so nothing is liftable.+compileGuards ::+  Maybe Occurrence ->+  VarMap ->+  SrcInfo ->+  [D.Guard] ->+  Writer [Diagnostic CompileError] CompiledGuards+compileGuards mOcc varMap si guards = do+  let (matchGuards, checkGuards) = partition isMatchGuard guards+  (wrapper, varMap') <- foldM (compileMatchGuard si) (id, varMap) matchGuards+  (condMap, checkExpr) <- compileCheckGuards mOcc varMap' si checkGuards+  pure+    CompiledGuards+      { matchWrapper = wrapper,+        indexConditions = condMap,+        residualCheck = checkExpr,+        extendedVarMap = varMap'+      }+  where+    isMatchGuard (D.GuardMatch {}) = True+    isMatchGuard (D.GuardGetArg {}) = True+    isMatchGuard _ = False++compileMatchGuard ::+  SrcInfo ->+  ([Stmt] -> [Stmt], VarMap) ->+  D.Guard ->+  Writer [Diagnostic CompileError] ([Stmt] -> [Stmt], VarMap)+compileMatchGuard si (matchWrapper, varMap) (D.GuardMatch operand name arity) = do+  -- HNF only emits 'GuardMatch' with a 'VarExpr' operand, but+  -- 'compileExpr' handles every 'Expr' constructor structurally, so+  -- delegating is safe and keeps the invariant unenforced-but-honoured.+  operandExpr <- compileExpr varMap si operand+  let check body = [If (BMatchTerm operandExpr (vmName name) arity) body []]+  pure (matchWrapper . check, varMap)+compileMatchGuard si (matchWrapper, varMap) (D.GuardGetArg vname operand idx) = do+  operandExpr <- compileExpr varMap si operand+  let binding body = LetVal (Name vname) (GetArg operandExpr idx) : body+      varMap' = insertVar vname (Var (Name vname)) varMap+  pure (matchWrapper . binding, varMap')+compileMatchGuard _ acc _ = pure acc++-- | Compile the check guards of an occurrence, classifying each one as+-- either a liftable index condition for a partner 'YCHR.Internal.VM.Foreach' or+-- a residual boolean check that stays at the innermost guard position.+--+-- The classification (paper §5.3, "Indexing" / Loop-Invariant Code+-- Motion in spirit) inspects each compiled equality with+-- 'classifyEqual'. Liftable equalities are routed to a per-partner map;+-- the rest are 'And'-folded in source order into the residual check.+compileCheckGuards ::+  Maybe Occurrence ->+  VarMap ->+  SrcInfo ->+  [D.Guard] ->+  Writer [Diagnostic CompileError] (PartnerCondMap, Maybe BoolExpr)+compileCheckGuards mOcc varMap si guards = do+  (condMap, residuals) <- foldM step (Map.empty, []) guards+  let residual = case residuals of+        [] -> Nothing+        r : rest -> Just (foldl BAnd r rest)+  pure (condMap, residual)+  where+    classify e1 e2 = case mOcc of+      Just occ -> classifyEqual occ e1 e2+      Nothing -> Nothing+    step (cm, rs) (D.GuardEqual t1 t2) = do+      e1 <- compileExpr varMap si t1+      e2 <- compileExpr varMap si t2+      case classify e1 e2 of+        Just (k, j, other) ->+          let cond = IndexCondition {argIndex = j, expectedValue = other}+           in pure (Map.insertWith (flip (++)) k [cond] cm, rs)+        Nothing ->+          pure (cm, rs ++ [BEqual e1 e2])+    step (cm, rs) (D.GuardExpr expr) = do+      e <- BFromVal . EvalDeep <$> compileExpr varMap si expr+      pure (cm, rs ++ [e])+    step acc _ = pure acc++-- ---------------------------------------------------------------------------+-- Compile body goals+-- ---------------------------------------------------------------------------++compileBodyGoals ::+  SymbolTable ->+  VarMap ->+  SrcInfo ->+  [D.BodyGoal] ->+  Writer [Diagnostic CompileError] [Stmt]+compileBodyGoals symTab varMap si goals = do+  (stmts, _) <- foldM step ([], varMap) goals+  pure stmts+  where+    step (acc, vm) goal = do+      (stmts, vm') <- compileBodyGoal symTab vm si goal+      pure (acc ++ stmts, vm')++-- | Tell-unify two terms and immediately drain the resulting+-- reactivation queue. Used by 'D.BodyUnify' and the re-binding case of+-- 'D.BodyIs'. Wrapped in a helper because the dispatch shape is not+-- something a casual reader should have to re-derive every time.+unifyAndReactivate :: ValExpr -> ValExpr -> [Stmt]+unifyAndReactivate l r =+  [ BoolExprStmt (BUnify l r),+    DrainReactivationQueue+      pendingName+      [ExprStmt (CallExpr reactivateDispatchName [AId (IdVar pendingName)])]+  ]++-- | Free variables that appear in /term position/ within an+-- expression — i.e. positions where 'compileTerm' will consume the+-- value structurally rather than evaluating it. Under non-evaluating+-- '=' every sub-expression of an '=' operand is a term position, so+-- this recurses through every compound shape ('CtorExpr',+-- 'CallExpr', 'HostExpr', 'ApplyExpr'). Used by+-- 'compileBodyGoal' for 'D.BodyUnify' to decide which fresh+-- 'NewVar's the unification itself must allocate before+-- 'compileTerm' sees an unbound name and raises @YCHR-40002@.+termPositionVars :: R.Expr -> [Text]+termPositionVars (R.VarExpr v) = [v]+termPositionVars (R.CtorExpr _ args) = concatMap termPositionVars args+termPositionVars (R.CallExpr _ args) = concatMap termPositionVars args+termPositionVars (R.HostExpr _ args) = concatMap termPositionVars args+termPositionVars (R.ApplyExpr f args) =+  termPositionVars f ++ concatMap termPositionVars args+termPositionVars _ = []++-- | Compile a single body goal, returning the generated statements and+-- an updated 'VarMap'. The VarMap may grow when a goal introduces new+-- variables (e.g. @is@ binding a fresh variable, or a constraint whose+-- arguments reference not-yet-seen variables that need 'NewVar').+compileBodyGoal ::+  SymbolTable ->+  VarMap ->+  SrcInfo ->+  D.BodyGoal ->+  Writer [Diagnostic CompileError] ([Stmt], VarMap)+compileBodyGoal _ varMap _ D.BodyTrue = pure ([], varMap)+compileBodyGoal _ varMap si (D.BodyTell qn args) = do+  -- A top-level bare 'VarExpr' in a tell argument refers to a logical+  -- variable that may not yet exist (e.g. 'foo(X)' on its first+  -- appearance); introduce a fresh 'NewVar' before evaluating the+  -- argument list. Variables nested inside a 'CallExpr' / 'CtorExpr'+  -- argument are evaluated by 'compileExpr', which runtime-errors if+  -- they are unbound. Tell arguments are evaluated, so the+  -- introduction is top-level only; contrast 'BodyUnify' below,+  -- whose operands are unification terms and may introduce variables+  -- under a 'CtorExpr' as well.+  -- 'nub' guards against repeated top-level 'VarExpr's like+  -- 'foo(X, X)' that would otherwise emit two consecutive 'LetVal+  -- X NewVar' (shadowing the first and leaking its allocation).+  let freshVars = nub [v | R.VarExpr v <- args, notMemberVar v varMap]+      newStmts = [LetVal (Name v) NewVar | v <- freshVars]+      varMap' = List.foldl' (\m v -> insertVar v (Var (Name v)) m) varMap freshVars+  callArgs <- traverse (compileExpr varMap' si) args+  let tellName = tellProcName (Types.qualifiedToName qn) (length callArgs)+  pure (newStmts ++ [ExprStmt (CallExpr tellName (map AVal callArgs))], varMap')+compileBodyGoal _ varMap si (D.BodyUnify t1 t2) = do+  -- '=' is pure structural unification: both operands are compiled as+  -- terms, not expressions. Function-call shapes ('CallExpr',+  -- 'HostExpr', 'ApplyExpr') do not evaluate — they become symbolic+  -- compounds via 'R.exprToTerm' + 'compileTerm'. The 'quote/1' quoting+  -- form is preserved as ordinary compound data here (no strip),+  -- matching head/equation patterns and the REPL's 'termToValue'.+  -- Mirrors the query-side 'Run.exprToValue' so '=' has the same+  -- semantics in rule bodies and queries. Use 'is' for arithmetic+  -- evaluation.+  --+  -- Any variable appearing anywhere inside an operand that is not yet+  -- in scope is introduced by the unification itself: it becomes a+  -- fresh logical variable slot that 'BUnify' then binds. 'nub' guards+  -- against repeated occurrences like 'X = X' that would otherwise+  -- allocate two 'NewVar's for the same name.+  let freshVars =+        nub [v | v <- termPositionVars t1 ++ termPositionVars t2, notMemberVar v varMap]+      newStmts = [LetVal (Name v) NewVar | v <- freshVars]+      varMap' = List.foldl' (\m v -> insertVar v (Var (Name v)) m) varMap freshVars+  t1' <- compileTerm varMap' si (R.exprToTerm t1)+  t2' <- compileTerm varMap' si (R.exprToTerm t2)+  pure (newStmts ++ unifyAndReactivate t1' t2', varMap')+compileBodyGoal _ varMap si (D.BodyHostStmt f args) = do+  args' <- traverse (compileExpr varMap si) args+  pure ([ExprStmt (HostCall (Name f) args')], varMap)+compileBodyGoal _ varMap si (D.BodyIs v expr) = do+  expr' <- compileExpr varMap si expr+  -- A bare-variable RHS (@R is X@) needs the dereferenced compound to+  -- be walked at runtime: emit 'EvalIs' to trigger 'deepEvalValue'.+  -- Any other RHS shape (host call, user function call, term ctor)+  -- already returns an evaluated value from its outer operation;+  -- 'EvalDeep' (deep-deref only) is sufficient. Mirrors the+  -- syntactic gate in 'checkBodyGoal' for the type checker — same+  -- pattern, same widening rule.+  let rhs = case expr of+        R.VarExpr _ -> EvalIs expr'+        _ -> EvalDeep expr'+  case lookupVar v varMap of+    -- Re-binding a variable already bound by the head: tell-unify so any+    -- existing constraints observing it are reactivated.+    Just existing -> pure (unifyAndReactivate existing rhs, varMap)+    -- First binding of this variable: an ordinary 'LetVal' is enough; no+    -- observers can exist yet.+    Nothing ->+      let varMap' = insertVar v (Var (Name v)) varMap+       in pure ([LetVal (Name v) rhs], varMap')+compileBodyGoal _ varMap si (D.BodyCall qn args) = do+  args' <- traverse (compileExpr varMap si) args+  let funcName = Types.qualifiedToName qn+  pure ([ExprStmt (CallExpr (funcProcName funcName (length args')) (map AVal args'))], varMap)+compileBodyGoal _ varMap si (D.BodyApply f args) = do+  fAndArgs <- traverse (compileExpr varMap si) (f : args)+  pure ([ExprStmt (CallExpr (callFunProcName (length args)) (map AVal fAndArgs))], varMap)++-- ---------------------------------------------------------------------------+-- Compile function definitions+-- ---------------------------------------------------------------------------++compileFunctionDef ::+  D.Function ->+  Writer [Diagnostic CompileError] Procedure+compileFunctionDef func = do+  let funcName = Types.qualifiedToName func.name+      procName' = funcProcName funcName func.arity+      params = [Name ("arg_" <> T.pack (show i)) | i <- [0 .. func.arity - 1]]+      funcLabel =+        Just+          ( "function "+              <> flattenName funcName+              <> "/"+              <> T.pack (show func.arity)+          )+      funcSi = SrcInfo func.equations.sourceLoc func.equations.parsed funcLabel+      frame =+        mkFrame+          ("function " <> flattenName funcName <> "/" <> T.pack (show func.arity))+          func.equations.sourceLoc+          func.equations.parsed+  eqStmts <- traverse (compileEquation params funcSi) func.equations.node+  let errorStmt = ExprStmt (HostCall chrErrorName [Lit (AtomLit "no_matching_equation")])+  pure+    Procedure+      { name = procName',+        params = params,+        body = PushFrame frame : concat eqStmts ++ [errorStmt],+        procKind = PKFunction func.name func.arity+      }++-- | Build a VarMap for a function equation: maps each normalized parameter+-- variable to the corresponding procedure parameter name.+buildEquationVarMap :: [Name] -> [HeadArg] -> VarMap+buildEquationVarMap procParams normalizedArgs =+  varMapFromList+    [ (v, Var p)+    | (p, HeadVar v) <- zip procParams normalizedArgs+    ]++compileEquation ::+  [Name] ->+  SrcInfo ->+  D.Equation ->+  Writer [Diagnostic CompileError] [Stmt]+compileEquation params si eq = do+  let varMap = buildEquationVarMap params eq.params+  -- Equations have no partners, so the index-condition pushdown+  -- classifier never fires; pass 'Nothing' to short-circuit it.+  compiled <- compileGuards Nothing varMap si eq.guards+  (preludeStmts, varMap1) <-+    compilePrelude compiled.extendedVarMap si eq.prelude+  rhsExpr <- compileExpr varMap1 si eq.rhs+  let returnStmts = preludeStmts ++ [Return rhsExpr]+      inner = case compiled.residualCheck of+        Nothing -> returnStmts+        Just gExpr -> [If gExpr returnStmts []]+  pure (compiled.matchWrapper inner)++-- | Compile a function-body prelude: lower each 'D.FunStmt' to its VM+-- statements, threading the 'VarMap' so that an @X is E@ binding becomes+-- visible to later statements and to the trailing return expression.+-- Mirrors a subset of 'compileBodyGoal' but skips the rule-body-only+-- reactivation-on-rebind path: a function has no constraint store to+-- reactivate against. An @is@ that shadows a same-named parameter is+-- intentional and works via the host language's lexical scoping —+-- 'LetVal' lowers to a let binding that shadows the outer name for+-- the rest of the procedure body.+compilePrelude ::+  VarMap ->+  SrcInfo ->+  [D.FunStmt] ->+  Writer [Diagnostic CompileError] ([Stmt], VarMap)+compilePrelude varMap si = foldM step ([], varMap)+  where+    step (acc, vm) stmt = do+      (stmts, vm') <- compileFunStmt vm si stmt+      pure (acc ++ stmts, vm')++compileFunStmt ::+  VarMap ->+  SrcInfo ->+  D.FunStmt ->+  Writer [Diagnostic CompileError] ([Stmt], VarMap)+compileFunStmt varMap si (D.FunHostStmt f args) = do+  args' <- traverse (compileExpr varMap si) args+  pure ([ExprStmt (HostCall (Name f) args')], varMap)+compileFunStmt varMap si (D.FunIs v expr) = do+  expr' <- compileExpr varMap si expr+  let rhs = case expr of+        R.VarExpr _ -> EvalIs expr'+        _ -> EvalDeep expr'+      varMap' = insertVar v (Var (Name v)) varMap+  pure ([LetVal (Name v) rhs], varMap')+compileFunStmt varMap si (D.FunCall qn args) = do+  args' <- traverse (compileExpr varMap si) args+  let funcName = Types.qualifiedToName qn+  pure+    ( [ExprStmt (CallExpr (funcProcName funcName (length args')) (map AVal args'))],+      varMap+    )+compileFunStmt varMap si (D.FunApply f args) = do+  fAndArgs <- traverse (compileExpr varMap si) (f : args)+  pure+    ( [ExprStmt (CallExpr (callFunProcName (length args)) (map AVal fAndArgs))],+      varMap+    )++-- ---------------------------------------------------------------------------+-- reactivate_dispatch+-- ---------------------------------------------------------------------------++-- | Dispatch reactivation by constraint type.  Generates a linear+-- if-chain over all constraint types.  Each branch simply calls the+-- appropriate @activate_c@ with the suspension; argument extraction+-- is handled inside @activate_c@ itself.+--+-- The if-chain is inherent to the VM's instruction set (no+-- switch\/dispatch instruction); backends may optimize this to a+-- table dispatch or similar.+genReactivateDispatch :: SymbolTable -> Procedure+genReactivateDispatch symTab =+  let body = map genDispatchBranch (symbolTableToList symTab)+   in Procedure+        { name = reactivateDispatchName,+          params = [suspParamName],+          body = body,+          procKind = PKReactivateDispatch+        }+  where+    genDispatchBranch (ident, cType) =+      If+        (BIsConstraintType (IdVar suspParamName) cType)+        [ ExprStmt+            ( CallExpr+                (activateProcName ident.name ident.arity)+                [AId (IdVar suspParamName)]+            )+        ]+        []++-- ---------------------------------------------------------------------------+-- call dispatch+-- ---------------------------------------------------------------------------++-- | Generate @call_1@ and @call_2@ dispatch procedures.+-- Each procedure pattern-matches on the closure/function-reference term+-- and dispatches to the appropriate compiled function.+genCallFunDispatches :: [D.Function] -> [Procedure]+genCallFunDispatches functions =+  [genCallFunDispatch functions callArity | callArity <- [1, 2]]++genCallFunDispatch :: [D.Function] -> Int -> Procedure+genCallFunDispatch functions callArity =+  let closureParam = Name "closure"+      argParams = [Name ("arg_" <> T.pack (show i)) | i <- [0 .. callArity - 1]]+      funRefBranches = concatMap (genFunRefBranch callArity argParams) functions+      lambdaBranches = concatMap (genLambdaBranch callArity argParams) functions+      errorStmt = ExprStmt (HostCall chrErrorName [Lit (AtomLit "call: no matching closure")])+   in Procedure+        { name = callFunProcName callArity,+          params = closureParam : argParams,+          body = funRefBranches ++ lambdaBranches ++ [errorStmt],+          procKind = PKCallDispatch callArity+        }++-- | Generate a dispatch branch for a function reference (@name/arity@).+-- Only emits a branch when the function's arity matches @callArity@.+genFunRefBranch :: Int -> [Name] -> D.Function -> [Stmt]+genFunRefBranch callArity argParams func+  | func.arity /= callArity = []+  | otherwise =+      let funcName = Types.qualifiedToName func.name+          flatName = flattenName funcName+          pName = funcProcName funcName func.arity+          condition =+            BAnd+              (BMatchTerm (Var (Name "closure")) (Name "/") 2)+              ( BAnd+                  (BEqual (GetArg (Var (Name "closure")) 0) (Lit (AtomLit flatName)))+                  ( BEqual+                      (GetArg (Var (Name "closure")) 1)+                      (Lit (IntLit (fromIntegral func.arity)))+                  )+              )+       in [ If+              condition+              [Return (CallExpr pName (map (AVal . Var) argParams))]+              []+          ]++-- | Generate a dispatch branch for a lifted lambda closure.+-- Only emits a branch for functions whose name starts with @__lambda_@.+--+-- Closures are self-describing terms of the form+-- @__closure(LambdaId, SourceForm, Cap1, …, CapN)@.+-- The first two arguments are the lambda identifier and the quoted+-- source form (for pretty-printing); captured variables start at+-- index 2, hence the @+ 2@ offset in 'captureBinds' below.+genLambdaBranch :: Int -> [Name] -> D.Function -> [Stmt]+genLambdaBranch callArity argParams func+  | not (isLambdaFunc func) = []+  | numCaptures < 0 = []+  | otherwise =+      let funcName = Types.qualifiedToName func.name+          Name lambdaVmText = vmName funcName+          pName = funcProcName funcName func.arity+          -- The closure has 2 header fields (lambdaId, sourceForm) followed+          -- by the captured free variables, so its total arity is+          -- numCaptures + 2.+          condition =+            BAnd+              (BMatchTerm (Var (Name "closure")) (Name "__closure") (numCaptures + 2))+              (BEqual (GetArg (Var (Name "closure")) 0) (Lit (AtomLit lambdaVmText)))+          -- Captures are stored after the 2 header fields (lambdaId at+          -- index 0, sourceForm at index 1), so capture i lives at+          -- index i + 2.+          captureBinds =+            [ LetVal+                (Name ("cap_" <> T.pack (show i)))+                (GetArg (Var (Name "closure")) (i + 2))+            | i <- [0 .. numCaptures - 1]+            ]+          captureVars =+            [Var (Name ("cap_" <> T.pack (show i))) | i <- [0 .. numCaptures - 1]]+          allArgs = captureVars ++ map Var argParams+       in [ If+              condition+              ( captureBinds+                  ++ [Return (CallExpr pName (map AVal allArgs))]+              )+              []+          ]+  where+    numCaptures = func.arity - callArity++-- | Check if a function was generated by lambda lifting.+isLambdaFunc :: D.Function -> Bool+isLambdaFunc func = T.isPrefixOf "__lambda_" func.name.baseName++{- ---------------------------------------------------------------------------+Notes+-----------------------------------------------------------------------------++Why occurrences are reversed before numbering: 'collectOccurrences' folds+each rule's occurrences into the 'OccurrenceMap' with 'occMapAppend',+which is implemented on top of @Map.insertWith (++)@ and therefore+prepends. Reversing the resulting list before 'assignNumbers' restores+top-down rule order so that occurrence number 1 is the textually first+occurrence of the constraint, matching the convention in the paper's+Listings.++Why partner ordering is "removed first, right-to-left" inside+'ruleOccurrences': this is the ωr refined operational semantics from+Duck et al. (2004) and the paper §2.2, Fig. 2. Removed occurrences are+tried before kept ones so that simplifications fire eagerly, and within+each group the rightmost head constraint gets the lowest occurrence+number so that join order matches a left-to-right scan of the body when+the rule is read as a Horn clause.++Why 'buildVarMap' only inspects 'HeadVar' arguments: occurrence head+arguments are 'HeadArg', so the only two cases are 'HeadVar' (binds a+name) and 'HeadWildcard' (contributes nothing). Non-variable patterns+have been lifted into 'D.GuardMatch' and 'D.GuardGetArg' guards by the+desugarer ('YCHR.Internal.Desugar.normalizeHead') and replaced with fresh+'HeadVar's in the head — the type-level narrowing makes that+invariant explicit instead of trusted by discipline.++Why the active constraint is called @active@ everywhere: at runtime+"constraint identifier" and "constraint suspension" are the same value+(a pointer to a heap-allocated 'YCHR.Internal.Runtime.Types.Suspension'). The+compiler picks the paper's terminology — "active constraint" — and uses+'activeName' as the single local-variable name in @tell_c@, @activate_c@,+and inside every @occurrence_c_j@ procedure. The only places that still+talk about a "suspension" are @reactivate_dispatch@ ('suspParamName')+and 'DrainReactivationQueue' ('pendingName'), where the value really is+"a suspension we received from somewhere else".++How 'compileExpr' handles compound forms: each 'D.Expr' constructor+maps to one runtime behavior. 'D.CallExpr' / 'D.ApplyExpr' /+'D.HostExpr' lower to 'CallExpr' / 'HostCall' (and their arguments+stay in expression context); 'D.CtorExpr' lowers to 'MakeTerm', with+its arguments recursively re-entered through 'compileExpr' so a+nested call inside @pair(foo(X), bar(Y))@ is still evaluated when+@foo@ is a declared function. The user opts out of this with+@quote\/1@: @quote(foo(X))@ delegates to 'compileTerm' on the surface+'Term' shape and keeps the subterm opaque regardless of whether+@foo@ happens to be a declared function. The call-vs-constructor+distinction was once made by a 'funSet' membership check at every+compound; it is now structural at the 'D.Expr' level+('YCHR.Internal.Resolve' commits to it once, in 'YCHR.Internal.Resolve.termToExpr').++Why 'genFireStmts' skips the alive check for removed partners during+backjumping: 'genKillStmts' has just emitted an unconditional 'Kill' for+every removed partner, so they are guaranteed dead by the time the body+runs. Emitting an alive check for them would always fail and the+resulting unconditional 'Continue' would make every later check+unreachable (paper §5.3, "all following alive tests thus becomes+redundant"). Backjumping is only useful for kept partners.++Why anonymous rules get a synthetic @__rule_N@ name in 'ruleOccurrences':+the propagation history is keyed on (rule name, constraint id tuple).+If two anonymous propagation rules shared a single placeholder name,+they would collide in the history and prevent each other from firing.+The synthetic name uses the rule's program-wide source position, which+is stable as long as the source order is.++Semantics of @quote(X)@ — the quoting operator:++@quote@ is a reserved keyword that prevents evaluation of its argument in+expression contexts (@is@ RHS, guard expressions, function arguments).+Normally, 'compileExpr' recursively evaluates recognised function calls+and host calls inside an expression; @quote(E)@ instead compiles @E@ via+'compileTerm', producing an opaque data term ('MakeTerm' \/ 'Lit' \/+'Var') regardless of whether @E@ contains function or operator names.++The effect is visible in three places:++  1. /Renamer/ ('YCHR.Internal.Rename.renameTerm'): inside @quote(...)@, the+     argument is renamed in 'NoResolve' mode, so functor names stay+     unqualified.  This means @quote(1 + 1)@ preserves the surface-level+     @+(1, 1)@ rather than producing the internal @prelude:+(1, 1)@+     representation.  Variables are still tracked (they need runtime+     bindings) but are not resolved against the module's declarations.++  2. /Compiler/ ('compileExpr'): the @quote\/1@ clause delegates to+     'compileTerm', which never emits 'CallExpr' or 'HostCall'.++  3. /REPL evaluator/ ('YCHR.Run.evalNestedExpr'): a parallel clause+     delegates to 'termToValue' instead of recursively evaluating.++@quote@ is forbidden as a user-defined constraint or function name+('YCHR.Internal.Resolve.checkReservedNames', error code YCHR-16003).++Example: @R is compound_to_list(quote(1 + 1))@ yields @R = [\'+\', 1, 1]@+because @1 + 1@ is compiled as the compound term @+(1, 1)@ instead of+being evaluated to @2@.++Why 'extractSymbolTable' lives in 'YCHR.Internal.Desugar' rather than here: the+constraint-type indices it produces are needed both by this module and+by 'YCHR.Internal.Compile.compile', but they are derivable from the desugared+program's rule heads together with its 'constraintTypes' map.+Computing them in the desugarer keeps the compilation pipeline+single-pass over the desugared AST.+--------------------------------------------------------------------------- -}
+ src/YCHR/Internal/Compile/Names.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : YCHR.Internal.Compile.Names+-- Description : Naming conventions for compiler-generated VM identifiers.+--+-- Centralizes every name the CHR-to-VM compiler bakes into the generated+-- 'YCHR.Internal.VM.Program'. Two flavours of name live here:+--+-- * /Procedure-name builders/ ('tellProcName', 'activateProcName',+--   'occProcName', 'funcProcName', 'callFunProcName'): pure functions+--   from a source name + arity (or other identifying data) to a 'Name'.+--   Backends and tests that need to predict the name of a generated+--   procedure should import this module rather than re-deriving the+--   convention.+--+-- * /Local-variable names and dispatch constants/ ('activeName',+--   'pendingName', 'suspParamName', 'dropResultName',+--   'reactivateDispatchName', 'chrErrorName', plus the partner-loop+--   helpers 'partSuspName' \/ 'partIdName' \/ 'partArgName' \/+--   'partLabel'): the vocabulary used by the bodies of generated+--   procedures.+module YCHR.Internal.Compile.Names+  ( -- * Procedure name builders+    procNameFor,+    tellProcName,+    activateProcName,+    occProcName,+    funcProcName,+    callFunProcName,++    -- * Source-name encoding+    encodeText,+    encodeIdentifier,+    isIdInitialSafe,+    vmName,++    -- * Active-constraint argument variables+    argName,+    argNames,++    -- * Partner-loop variables+    partSuspName,+    partIdName,+    partArgName,+    partLabel,++    -- * Generated-code local-variable names+    activeName,+    pendingName,+    suspParamName,+    dropResultName,++    -- * Runtime entry-point names+    reactivateDispatchName,+    chrErrorName,+  )+where++import Data.Char (isAlpha, isAscii, isDigit, ord)+import Data.Text (Text)+import Data.Text qualified as T+import Numeric (showHex)+import YCHR.Internal.Compile.Types (OccurrenceNumber (..), PartnerIndex (..))+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM (Label (..), Name (..))++-- ---------------------------------------------------------------------------+-- Source-name encoding+-- ---------------------------------------------------------------------------++-- | Encode a text component for use in generated /symbolic/ VM names —+-- compound-term functors and lambda-closure identifiers. ASCII+-- characters pass through unchanged; non-ASCII characters are+-- rewritten to @%%u\<hex\>@ where @\<hex\>@ is the Unicode codepoint+-- padded to exactly 6 lowercase digits.+--+-- The escape marker @%%u@ is reserved by the lexer (see+-- 'YCHR.Internal.PExpr.quotedAtomP') so it can never appear in a source atom.+-- Together with the lexer's existing rejection of @__@, this makes+-- the encoding @encodeText m <> "__" <> encodeText n@ used by+-- 'vmName' /injective/: encoded text contains no @__@ at all (escapes+-- use @%%u@ instead, and source contributes none), so the only @__@+-- in the mangled form is the module/base separator. Every @%%u@ is+-- followed by exactly 6 hex digits — fixed-width with no closing+-- delimiter, so escape boundaries cannot overlap with the separator+-- or with each other. Six digits covers the whole Unicode range+-- (@U+10FFFF@). The decoder ('YCHR.Internal.Meta.decodeMangled') therefore+-- splits on the first @__@ and then expands @%%u\<6 hex digits\>@ in+-- each half.+--+-- The resulting string is treated as a symbol by the runtime (the+-- Scheme backend falls back to @(string->symbol "...")@ via+-- 'YCHR.Internal.Backend.Scheme.compileSymbol' when the encoded form isn't a+-- valid Scheme identifier), so the encoding need not produce a+-- strictly identifier-safe result.+--+-- For generated /procedure/ names — @tell_*@, @activate_*@, @func_*@+-- — use 'encodeIdentifier' instead. Those names are emitted as bare+-- identifiers in target code and must be valid in both Scheme and+-- JavaScript, neither of which accept @%@; the older+-- @__u\<hex\>__@ escape is retained there since procedure names are+-- never decoded.+encodeText :: Text -> Text+encodeText = T.concatMap encodeChar+  where+    encodeChar c+      | isAscii c = T.singleton c+      | otherwise = "%%u" <> T.pack (padHex6 (showHex (ord c) ""))+    padHex6 h = replicate (6 - length h) '0' ++ h++-- | Encode a text component into an identifier that is valid in every+-- backend's target language. ASCII letters, digits, @_@, and @$@ pass+-- through; every other character is rewritten to @__u{hex codepoint}__@.+--+-- The allowed character set is the intersection of what JavaScript+-- and R6RS Scheme accept in identifiers: function names like+-- @func_prelude__+2@ would be a valid Scheme identifier but not a+-- valid JavaScript one, so @+@ is escaped.+--+-- Used by 'procNameFor' (so generated procedures like @tell_*@ are+-- always valid identifiers in the target language) and by the alias+-- builder in 'YCHR.Internal.Backend.Scheme'.+--+-- The encoding is one-way: total, deterministic, and unambiguous.+-- Injectivity follows from the parser: 'YCHR.Internal.PExpr' rejects atoms+-- containing @__@, so no source-language name can look like an+-- escape sequence and collide with one.+encodeIdentifier :: Text -> Text+encodeIdentifier = T.concatMap encodeChar+  where+    encodeChar c+      | isAscii c && (isAlpha c || isDigit c || c == '_' || c == '$') =+          T.singleton c+      | otherwise = "__u" <> T.pack (showHex (ord c) "") <> "__"++-- | Predicate that classifies a character as safe as the /first/+-- character of an identifier. Letters, @_@, and @$@ qualify; digits+-- do not. Used by alias builders, where the encoded component lands+-- at the start of an identifier and a leading digit would be+-- syntactically illegal.+isIdInitialSafe :: Char -> Bool+isIdInitialSafe c = isAscii c && (isAlpha c || c == '_' || c == '$')++-- | Build a VM 'Name' for a source-language identifier of the given+-- arity, prefixed by a procedure-kind tag (@tell@, @activate@, @func@,+-- …). Qualified names embed both the module and the local part,+-- separated by @__@.+--+-- The module and constraint-name components are passed through+-- 'encodeIdentifier' (not 'encodeText') so the resulting procedure+-- name is always a valid identifier in every backend's target+-- language — including JavaScript, where operator characters like+-- @+@, @-@, @*@, @/@ are illegal in function names.+procNameFor :: Text -> Types.Name -> Int -> Name+procNameFor prefix (Types.Qualified m n) arity =+  Name+    ( prefix+        <> "_"+        <> encodeIdentifier m+        <> "__"+        <> encodeIdentifier n+        <> T.pack (show arity)+    )+procNameFor prefix (Types.Unqualified n) arity =+  Name (prefix <> "_" <> encodeIdentifier n <> T.pack (show arity))++-- | Encode a source-language 'Types.Name' as a VM 'Name' /without/ a+-- procedure-kind prefix. Used for compound-term functors and lambda+-- closures.+vmName :: Types.Name -> Name+vmName (Types.Unqualified n) = Name (encodeText n)+vmName (Types.Qualified m n) = Name (encodeText m <> "__" <> encodeText n)++-- ---------------------------------------------------------------------------+-- Procedure-name builders+-- ---------------------------------------------------------------------------++-- | Name of the @tell_c@ procedure for a constraint of the given source+-- name and arity.+tellProcName :: Types.Name -> Int -> Name+tellProcName = procNameFor "tell"++-- | Name of the @activate_c@ procedure for a constraint of the given+-- source name and arity.+activateProcName :: Types.Name -> Int -> Name+activateProcName = procNameFor "activate"++-- | Name of the @occurrence_c_j@ procedure for the @j@-th occurrence of+-- a constraint of the given source name and arity.+occProcName :: Types.Name -> Int -> OccurrenceNumber -> Name+occProcName name arity num =+  let Name base = procNameFor "occurrence" name arity+   in Name (base <> "_" <> T.pack (show num.unOccurrenceNumber))++-- | Name of the procedure that implements a user-defined function of+-- the given source name and arity.+funcProcName :: Types.Name -> Int -> Name+funcProcName = procNameFor "func"++-- | Name of the @call_N@ dispatch procedure for a call with @N@+-- arguments (i.e. an @N+1@-ary @call(F, arg_1, …, arg_N)@). Each+-- supported call arity gets its own dispatch procedure.+callFunProcName :: Int -> Name+callFunProcName n = Name ("call_" <> T.pack (show n))++-- ---------------------------------------------------------------------------+-- Active-constraint argument variables+-- ---------------------------------------------------------------------------++-- | List of local-variable names for the arguments of the active+-- constraint inside an @activate_c@ \/ @occurrence_c_j@ procedure.+argNames :: Int -> [Name]+argNames arity = [argName i | i <- [0 .. arity - 1]]++-- | Local-variable name for the @i@-th argument of the active+-- constraint: @X_i@.+argName :: Int -> Name+argName i = Name ("X_" <> T.pack (show i))++-- ---------------------------------------------------------------------------+-- Partner-loop variables+-- ---------------------------------------------------------------------------++-- | VM variable name for the suspension currently bound by partner+-- @k@'s 'YCHR.Internal.VM.Foreach' loop: @susp_k@.+partSuspName :: PartnerIndex -> Name+partSuspName k = Name ("susp_" <> T.pack (show k.unPartnerIndex))++-- | VM variable name for the constraint identifier of partner @k@,+-- extracted from its suspension before the body runs: @pId_k@.+partIdName :: PartnerIndex -> Name+partIdName k = Name ("pId_" <> T.pack (show k.unPartnerIndex))++-- | VM variable name for the @j@-th argument of partner @k@: @pArg_k_j@.+partArgName :: PartnerIndex -> Int -> Name+partArgName k j = Name ("pArg_" <> T.pack (show k.unPartnerIndex) <> "_" <> T.pack (show j))++-- | VM 'Label' attached to partner @k@'s 'YCHR.Internal.VM.Foreach' loop. Used+-- by 'YCHR.Internal.VM.Continue' for backjumping. Numbered from 1 so the+-- outermost loop is @L1@.+partLabel :: PartnerIndex -> Label+partLabel k = Label ("L" <> T.pack (show (k.unPartnerIndex + 1)))++-- ---------------------------------------------------------------------------+-- Generated-code local-variable names+-- ---------------------------------------------------------------------------++-- | The active constraint of an occurrence procedure (paper+-- terminology). At runtime "constraint identifier" and "constraint+-- suspension" are the same value, so this single name covers both+-- roles. See the \"Notes\" block in 'YCHR.Internal.Compile'.+activeName :: Name+activeName = "active"++-- | Suspension binder for 'YCHR.Internal.VM.DrainReactivationQueue': each+-- pending reactivation is bound to this variable in turn.+pendingName :: Name+pendingName = "pending"++-- | Suspension binder for the @reactivate_dispatch@ procedure. Distinct+-- from 'pendingName' because dispatch handles a single suspension at a+-- time without iterating.+suspParamName :: Name+suspParamName = "susp"++-- | Boolean result returned by an @occurrence_c_j@ call: @True@ when the+-- occurrence dropped the active constraint, telling the caller to+-- short-circuit (Early Drop, paper §5.3).+dropResultName :: Name+dropResultName = "dropped"++-- ---------------------------------------------------------------------------+-- Runtime entry-point names+-- ---------------------------------------------------------------------------++-- | Procedure name of @reactivate_dispatch@ — the only+-- compiler-generated procedure called by name from inside another+-- procedure's body, since the others are looked up via 'tellProcName'+-- \/ 'activateProcName' \/ 'occProcName'.+reactivateDispatchName :: Name+reactivateDispatchName = "reactivate_dispatch"++-- | Host-language error reporter, called from generated dispatch+-- procedures when no equation matches. Defined by the runtime.+chrErrorName :: Name+chrErrorName = "__chr_error"
+ src/YCHR/Internal/Compile/Occurrences.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : YCHR.Internal.Compile.Occurrences+-- Description : Pre-pass that collects and numbers head occurrences.+--+-- This module owns the first phase of the CHR-to-VM compiler: walking+-- every rule head and producing, for each constraint type, a top-down+-- list of 'Occurrence' records numbered as required by the refined+-- operational semantics ωr (paper §2.2, Fig. 2). The result is a single+-- 'OccurrenceMap' that the rest of 'YCHR.Internal.Compile' consumes.+--+-- See the \"Notes\" block in 'YCHR.Internal.Compile' for the rationale behind the+-- ordering and numbering choices.+module YCHR.Internal.Compile.Occurrences+  ( collectOccurrences,+  )+where++import Control.Monad.Trans.Writer.CPS (Writer, tell)+-- 'foldl'' is imported qualified because the Prelude only re-exports it from+-- base 4.20 (GHC 9.10) and this package supports GHC 9.6+. An unqualified+-- 'import Data.List (foldl'')' would be flagged redundant on newer compilers,+-- since this module needs nothing else from "Data.List".+import Data.List qualified as List+import Data.Text (Text)+import Data.Text qualified as T+import Data.Traversable (for)+import YCHR.Internal.Compile.Passive (markPassive)+import YCHR.Internal.Compile.Types+import YCHR.Internal.Desugared qualified as D+import YCHR.Internal.Diagnostic (Diagnostic (..))+import YCHR.Internal.PExpr (PExpr)+import YCHR.Internal.Parsed (AnnP (..))+import YCHR.Internal.Parsed qualified as P+import YCHR.Internal.Types+  ( HeadConstraint,+    Identifier (..),+    RuleId (..),+    SymbolTable,+    lookupSymbol,+    qualifiedToName,+  )+import YCHR.Internal.VM (ConstraintType (..))++-- | Walk every rule in the program and assemble the per-constraint+-- 'OccurrenceMap'. Occurrences are numbered top-down within each+-- constraint type so that occurrence number 1 is the textually first+-- occurrence (paper §5.2, Listings 1 and 2).+--+-- Also returns the list of per-rule display names, indexed by the+-- rule's 'RuleId' (which mirrors its program-wide source index).+collectOccurrences ::+  SymbolTable ->+  D.Program ->+  Writer [Diagnostic CompileError] (OccurrenceMap, [Text])+collectOccurrences symTab prog = do+  let indexed = zip [0 ..] prog.rules+      displayNames = map (uncurry ruleDisplayName) indexed+  allOccs <- fmap concat (traverse (ruleOccurrences symTab) indexed)+  let grouped =+        List.foldl'+          ( \m occ ->+              occMapAppend (Identifier occ.conName occ.conArity) occ m+          )+          occMapEmpty+          allOccs+  -- Number occurrences first (so ωr numbers are stable), then mark the+  -- provably-passive ones. Passivity only flips a flag; it never renumbers.+  let numbered = occMapMap (assignNumbers . reverse) grouped+  pure (markPassive numbered, displayNames)+  where+    -- Reverse before numbering to undo the prepend-on-insert in+    -- 'occMapAppend' and restore top-down rule order.+    assignNumbers = zipWith (\n o -> o {number = n}) [OccurrenceNumber 1 ..]++-- | Compute the display name of a rule. Anonymous rules get a+-- synthetic @__rule_N@ name whose index matches the rule's+-- program-wide source position. The double-underscore prefix avoids+-- clashes with user-defined names.+ruleDisplayName :: Int -> D.Rule -> Text+ruleDisplayName ruleIdx rule = case rule.name of+  Just n -> n+  Nothing -> "__rule_" <> T.pack (show ruleIdx)++-- | Produce one 'Occurrence' record for every head constraint of a+-- single rule. The active head varies; the other heads become the+-- partner list of that occurrence.+ruleOccurrences ::+  SymbolTable ->+  ( Int,+    D.Rule+  ) ->+  Writer [Diagnostic CompileError] [Occurrence]+ruleOccurrences symTab (ruleIdx, rule) = do+  let AnnP {node = ruleHead} = rule.head+      kept = ruleHead.kept+      removed = ruleHead.removed+      -- Occurrences are ordered removed-first, right-to-left within+      -- each group, following the ωr refined operational semantics+      -- (paper §2.2, Fig. 2). Removed occurrences are tried before+      -- kept ones, and within each group the rightmost head constraint+      -- gets the lowest (earliest) occurrence number.+      orderedOccurrences =+        [(i, c, False) | (i, c) <- zip [HeadPosition 0 ..] (reverse removed)]+          ++ [(i, c, True) | (i, c) <- zip [HeadPosition (length removed) ..] (reverse kept)]+      ruleId' = RuleId ruleIdx+      display = ruleDisplayName ruleIdx rule+  for orderedOccurrences $ \(idx, con, isKept) ->+    mkOccurrence symTab rule ruleId' display orderedOccurrences idx con isKept++-- | Build a single 'Occurrence' record for the active head constraint+-- at @activeIdx@. The other entries in @combined@ become the partner+-- list.+mkOccurrence ::+  SymbolTable ->+  D.Rule ->+  RuleId ->+  Text ->+  [(HeadPosition, HeadConstraint, Bool)] ->+  HeadPosition ->+  HeadConstraint ->+  Bool ->+  Writer [Diagnostic CompileError] Occurrence+mkOccurrence symTab rule ruleId' display combined activeIdx activeCon activeIsKept = do+  let partners' = [(idx, con, isKept) | (idx, con, isKept) <- combined, idx /= activeIdx]+      headLoc = rule.head.sourceLoc+      headPretty = rule.head.parsed+  let ruleLabel = Just ("rule " <> display)+  partners <- for partners' $ \(idx, con, isKept) -> do+    ct <-+      lookupCType+        symTab+        headLoc+        headPretty+        ruleLabel+        ( Identifier+            (qualifiedToName con.name)+            ( length+                con.args+            )+        )+    pure+      Partner+        { idx = idx,+          constraint = con,+          isKept = isKept,+          cType = ct+        }+  pure+    Occurrence+      { conName = qualifiedToName activeCon.name,+        conArity = length activeCon.args,+        number = OccurrenceNumber 0,+        rule = rule,+        ruleId = ruleId',+        ruleDisplay = display,+        activeIdx = activeIdx,+        isKept = activeIsKept,+        activeArgs = activeCon.args,+        partners = partners,+        passive = False+      }++-- | Look up a constraint type in the symbol table or report an error.+-- Returns a placeholder 'ConstraintType' on failure so that the rest+-- of the pass can keep going and collect more diagnostics.+lookupCType ::+  SymbolTable ->+  P.SourceLoc ->+  PExpr ->+  Maybe Text ->+  Identifier ->+  Writer [Diagnostic CompileError] ConstraintType+lookupCType symTab loc p label ident = case lookupSymbol ident symTab of+  Just ct -> pure ct+  Nothing -> do+    tell [Diagnostic label (AnnP (UnknownConstraintType ident.name) loc p)]+    pure (ConstraintType (-1))
+ src/YCHR/Internal/Compile/Passive.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : YCHR.Internal.Compile.Passive+-- Description : Marks occurrences that can never fire as passive.+--+-- The /passive occurrences/ optimization (paper §5.3). An occurrence is+-- *passive* if it can be derived statically that the rule can never fire+-- with the active constraint matching that occurrence. A passive+-- occurrence contributes no @occurrence_c_j@ procedure and no call from+-- @activate_c@, so its (always-empty) partner search is never emitted.+--+-- This module is a pure post-pass over the fully-numbered 'OccurrenceMap'+-- (see 'YCHR.Internal.Compile.Occurrences'): it only flips the 'passive' flag,+-- never reorders or renumbers, so the ωr occurrence numbers of the+-- surviving occurrences are unchanged.+--+-- v1 detects the /subsumption \/ symmetry/ source: the kept occurrence of+-- an idempotence simpagation @c(..) \\ c(..) \<=\> ..@, and the ωr-later+-- occurrence of a symmetric two-head simplification @c(X,Y), c(Y,X) \<=\>+-- ..@. The paper's /never-stored/ source is deferred: without Late+-- Storage its only sound criterion (a constraint all of whose head+-- occurrences are single-headed guardless simplifications) is vacuous for+-- partner elimination — such a constraint can never be a partner, because+-- being a partner requires appearing in a multi-headed rule. See+-- @dev-docs/passive-occurrences.md@ for the full specification and+-- soundness argument.+--+-- The analysis is conservative: it marks an occurrence passive only when+-- soundness is guaranteed. Every predicate below is a /sufficient/, not+-- necessary, condition — correctness over completeness.+module YCHR.Internal.Compile.Passive+  ( markPassive,+  )+where++import Data.List (nub)+import Data.List qualified as List+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 YCHR.Internal.Compile.Types+import YCHR.Internal.Desugared qualified as D+import YCHR.Internal.Parsed (AnnP (..))+import YCHR.Internal.Types (HeadArg (..), HeadConstraint)++-- | Flip the 'passive' flag on every occurrence the analysis can prove+-- can never fire. Runs after occurrence numbering, so numbers are+-- preserved and only the 'passive' field changes.+markPassive :: OccurrenceMap -> OccurrenceMap+markPassive = occMapMap (map mark)+  where+    mark occ = occ {passive = occ.passive || isPassive occ}++-- | Is this occurrence passive under any v1 source?+isPassive :: Occurrence -> Bool+isPassive occ = idempotencePassive occ || symmetryPassive occ++-- ---------------------------------------------------------------------------+-- Subsumption / symmetry analysis+-- ---------------------------------------------------------------------------++-- | The kept occurrence of an idempotence simpagation is subsumed by the+-- removed one and made passive. The rule must have exactly one kept and+-- one removed head of the same constraint type, structurally identical+-- after HNF canonicalization, with no residual guards. The occurrence is+-- passive only when it is the /kept/ one (the removed one stays active+-- and, being tried first by ωr, always fires before the kept one could).+idempotencePassive :: Occurrence -> Bool+idempotencePassive occ =+  case (hd.kept, hd.removed) of+    ([k], [r]) ->+      occ.isKept+        && sameType k r+        && allGuardsHeadEq headVars guards+        && canonArgs classes "k" k.args == canonArgs classes "r" r.args+      where+        headVars = headVarsOf (hd.kept ++ hd.removed)+        classes = buildClasses headVars guards+    _ -> False+  where+    hd = ruleHead occ.rule+    guards = ruleGuards occ.rule++-- | One occurrence of a symmetric two-head simplification is redundant.+-- The rule must have no kept heads and exactly two removed heads of the+-- same constraint type, related by swapping their argument positions,+-- with no residual guards. The ωr-later occurrence (the one not tried+-- first) is made passive.+symmetryPassive :: Occurrence -> Bool+symmetryPassive occ =+  case (hd.kept, hd.removed) of+    ([], [h0, h1]) ->+      isLaterOccurrence occ+        && sameType h0 h1+        && allGuardsHeadEq headVars guards+        && isSymmetric classes h0 h1+      where+        headVars = headVarsOf hd.removed+        classes = buildClasses headVars guards+    _ -> False+  where+    hd = ruleHead occ.rule+    guards = ruleGuards occ.rule++-- | Among the two occurrences of a symmetric two-head rule, the passive+-- one is the ωr-later of the two. Occurrence positions in the combined+-- (removed-first, right-to-left) head list run @0@ (tried first) and @1@+-- (tried later); the later one is passive.+isLaterOccurrence :: Occurrence -> Bool+isLaterOccurrence occ = occ.activeIdx == HeadPosition 1++-- | Whether the two heads describe the same unordered match: there is a+-- bijection on argument class-tokens mapping @h0@ to @h1@ and @h1@ to+-- @h0@. Built from the pairing @zip (a0 ++ a1) (a1 ++ a0)@; the mapping+-- must be a consistent function whose image has no duplicates (injective,+-- hence a bijection / involution).+isSymmetric :: ClassMap -> HeadConstraint -> HeadConstraint -> Bool+isSymmetric classes h0 h1 =+  case build Map.empty (zip (a0 ++ a1) (a1 ++ a0)) of+    Just m -> let vals = Map.elems m in length vals == length (nub vals)+    Nothing -> False+  where+    a0 = canonArgs classes "0" h0.args+    a1 = canonArgs classes "1" h1.args+    build m [] = Just m+    build m ((x, y) : rest) = case Map.lookup x m of+      Just y' | y' /= y -> Nothing+      _ -> build (Map.insert x y m) rest++-- ---------------------------------------------------------------------------+-- Head canonicalization (seeing through HNF)+-- ---------------------------------------------------------------------------++-- | A flat union-find over head variables: every key maps directly to+-- its class representative.+type ClassMap = Map Text Text++-- | The set of head-variable names in a list of head constraints.+-- Wildcards contribute no name.+headVarsOf :: [HeadConstraint] -> Set Text+headVarsOf hcs = Set.fromList [v | hc <- hcs, HeadVar v <- hc.args]++-- | Build head-variable equivalence classes from the head-variable+-- equality guards induced by HNF (e.g. @X = _hnf_0@). Only guards+-- equating two head variables union classes; all others are ignored here+-- (they are rejected separately by 'allGuardsHeadEq').+buildClasses :: Set Text -> [D.Guard] -> ClassMap+buildClasses headVars guards = List.foldl' union (Map.fromSet id headVars) headEqns+  where+    headEqns =+      [ (a, b)+      | D.GuardEqual (D.VarExpr a) (D.VarExpr b) <- guards,+        a `Set.member` headVars,+        b `Set.member` headVars+      ]+    union m (a, b) =+      case (Map.lookup a m, Map.lookup b m) of+        (Just ra, Just rb)+          | ra == rb -> m+          | otherwise -> Map.map (\r -> if r == rb then ra else r) m+        _ -> m++-- | The class-token list of a head's arguments: each variable maps to+-- its class representative, each wildcard to a fresh token unique to this+-- head (the @prefix@ plus its position), so wildcards never unify with+-- anything — conservatively defeating passivity when they appear.+canonArgs :: ClassMap -> Text -> [HeadArg] -> [Text]+canonArgs classes prefix args =+  [ case a of+      HeadVar v -> Map.findWithDefault v v classes+      HeadWildcard -> "_wc:" <> prefix <> ":" <> T.pack (show i)+  | (i, a) <- zip [0 :: Int ..] args+  ]++-- | Every guard is a head-variable equality (so there are no residual+-- guards). This is the v1 conservative form of "residual guards are+-- symmetric": it rejects rules like @c(X,Y), c(Y,X) \<=\> X \< Y | ..@+-- whose @X \< Y@ guard is not a head-variable equality.+allGuardsHeadEq :: Set Text -> [D.Guard] -> Bool+allGuardsHeadEq headVars = all isHeadEq+  where+    isHeadEq (D.GuardEqual (D.VarExpr a) (D.VarExpr b)) =+      a `Set.member` headVars && b `Set.member` headVars+    isHeadEq _ = False++-- ---------------------------------------------------------------------------+-- Rule accessors and helpers+-- ---------------------------------------------------------------------------++-- | A rule's post-HNF head. Pattern-matched out of the 'AnnP' wrapper+-- (the codebase reads 'AnnP' fields this way rather than via record dot).+ruleHead :: D.Rule -> D.Head+ruleHead rule = let AnnP {node = hd} = rule.head in hd++-- | A rule's post-HNF guard list.+ruleGuards :: D.Rule -> [D.Guard]+ruleGuards rule = let AnnP {node = gs} = rule.guard in gs++-- | Whether two head constraints have the same constraint type (functor+-- and arity).+sameType :: HeadConstraint -> HeadConstraint -> Bool+sameType a b = a.name == b.name && length a.args == length b.args
+ src/YCHR/Internal/Compile/Pipeline.hs view
@@ -0,0 +1,392 @@+{-# 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
+ src/YCHR/Internal/Compile/Types.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE DuplicateRecordFields #-}++-- | Internal types for the CHR-to-VM compiler.+module YCHR.Internal.Compile.Types+  ( -- * Errors+    CompileError (..),++    -- * Semantic newtypes+    OccurrenceNumber (..),+    HeadPosition (..),+    PartnerIndex (..),++    -- * Data types+    Occurrence (..),+    Partner (..),+    IndexCondition (..),+    CompiledGuards (..),++    -- * Partner index conditions+    PartnerCondMap,++    -- * Occurrence map+    OccurrenceMap,+    occMapEmpty,+    occMapAppend,+    occMapMap,+    lookupOccurrences,++    -- * Variable map+    VarMap,+    varMapFromList,+    lookupVar,+    insertVar,+    notMemberVar,+  )+where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import YCHR.Internal.Desugared qualified as D+import YCHR.Internal.Types (HeadArg, HeadConstraint, Identifier, Name, RuleId)+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM (ArgIndex, BoolExpr, ConstraintType, Stmt, ValExpr)++-- | Errors raised by any pass in the CHR-to-VM compiler. Wrapped in+-- 'YCHR.Internal.Parsed.AnnP' at the use site to carry the source location and+-- original parsed expression for diagnostics.+data CompileError+  = -- | A head constraint references a constraint type that is not in+    -- the symbol table. Raised by 'YCHR.Internal.Compile.Occurrences'.+    UnknownConstraintType Types.Name+  | -- | A guard or body term references a variable that is not bound+    -- by the rule head. Raised by 'YCHR.Internal.Compile' while compiling+    -- terms.+    UnboundVariable Text+  deriving (Show)++-- | 1-based occurrence number within a constraint type's occurrence list.+newtype OccurrenceNumber = OccurrenceNumber {unOccurrenceNumber :: Int}+  deriving (Show, Eq, Ord, Num, Enum)++-- | 0-based position in the combined (removed ++ kept) head list.+newtype HeadPosition = HeadPosition {unHeadPosition :: Int}+  deriving (Show, Eq, Ord, Num, Enum)++-- | 0-based index into the partners list of an occurrence.+newtype PartnerIndex = PartnerIndex {unPartnerIndex :: Int}+  deriving (Show, Eq, Ord, Num, Enum)++-- | One occurrence of a single head constraint within a rule. The+-- compiler emits one @occurrence_c_j@ procedure per 'Occurrence'.+data Occurrence = Occurrence+  { -- | Source name of the constraint this occurrence belongs to.+    conName :: Name,+    -- | Arity of the constraint (used for procedure-name encoding).+    conArity :: Int,+    -- | 1-based position within the constraint's occurrence list.+    -- Assigned top-down in 'YCHR.Internal.Compile.collectOccurrences'.+    number :: OccurrenceNumber,+    -- | The full rule this occurrence belongs to. Carried so that+    -- 'genFireStmts' can read its guard, body, and head shape.+    rule :: D.Rule,+    -- | Numeric identifier of the rule, used as the propagation+    -- history key. Assigned by 'YCHR.Internal.Compile.collectOccurrences'+    -- from the rule's program-wide source position.+    ruleId :: RuleId,+    -- | Display name of the rule, used for diagnostics and+    -- 'YCHR.Internal.VM.StackFrame' labels. Equals @rule.name@ when+    -- the rule was explicitly named, otherwise a synthetic+    -- @__rule_N@ fallback.+    ruleDisplay :: Text,+    -- | Position of the active head constraint inside the rule's+    -- combined (removed ++ kept) head list.+    activeIdx :: HeadPosition,+    -- | Whether the active constraint is kept (@True@) or removed+    -- (@False@) when the rule fires.+    isKept :: Bool,+    -- | Arguments of the active head constraint, in source order.+    -- Narrowed to 'HeadArg' so the HNF invariant ("head args are+    -- variables or wildcards") is enforced by the type.+    activeArgs :: [HeadArg],+    -- | The other head constraints, in the order they will be iterated+    -- by nested 'YCHR.Internal.VM.Foreach' loops.+    partners :: [Partner],+    -- | Whether ωr guarantees this occurrence can never fire with the+    -- active constraint in this role. Every occurrence is born active+    -- ('False') in 'YCHR.Internal.Compile.Occurrences.mkOccurrence'; the passivity+    -- pass 'YCHR.Internal.Compile.Passive.markPassive' flips it. A passive+    -- occurrence keeps its ωr 'number' (numbering runs first) but+    -- contributes no @occurrence_c_j@ procedure and no call from+    -- @activate_c@. See "YCHR.Internal.Compile.Passive" and+    -- @dev-docs/passive-occurrences.md@.+    passive :: Bool+  }++-- | One partner constraint of an 'Occurrence' — i.e. a head constraint+-- of the same rule that is /not/ the active one.+data Partner = Partner+  { -- | Position in the rule's combined (removed ++ kept) head list.+    idx :: HeadPosition,+    -- | The original constraint as it appears in the head, narrowed+    -- to 'HeadConstraint' (post-HNF).+    constraint :: HeadConstraint,+    -- | Whether the partner is kept (@True@) or removed (@False@) when+    -- the rule fires. Removed partners are killed before the body runs+    -- and skipped during backjumping (they are guaranteed dead).+    isKept :: Bool,+    -- | Constraint-type index used by 'YCHR.Internal.VM.Foreach' to look the+    -- partner up in the constraint store.+    cType :: ConstraintType+  }++-- | A single index condition lifted out of an equality check guard onto+-- a partner 'YCHR.Internal.VM.Foreach' loop: argument @argIndex@ of the partner+-- must be 'YCHR.Internal.VM.Equal' to @expectedValue@. Produced by+-- 'YCHR.Internal.Compile.classifyEqual' and consumed by+-- 'YCHR.Internal.Compile.wrapInPartnerLoops', which projects it back to the+-- @(ArgIndex, ValExpr)@ pair the VM 'YCHR.Internal.VM.Foreach' instruction expects.+data IndexCondition = IndexCondition+  { argIndex :: ArgIndex,+    expectedValue :: ValExpr+  }++-- | Per-partner index conditions lifted out of check guards by the+-- 'YCHR.Internal.VM.Foreach' index-condition pushdown optimization. Each entry+-- maps a partner index @k@ to the list of conditions that becomes+-- 'YCHR.Internal.VM.Foreach' @k@'s index-conditions argument.+type PartnerCondMap = Map PartnerIndex [IndexCondition]++-- | Result of compiling a guard conjunction. Threaded out of+-- 'YCHR.Internal.Compile.compileGuards' to its two callers (occurrence bodies+-- and function equations).+data CompiledGuards = CompiledGuards+  { -- | Wrapper that nests an inner statement block inside the+    -- structural @if@s and let-bindings introduced by match guards+    -- ('YCHR.Internal.Desugared.GuardMatch', 'YCHR.Internal.Desugared.GuardGetArg').+    matchWrapper :: [Stmt] -> [Stmt],+    -- | Index conditions lifted onto the surrounding partner+    -- 'YCHR.Internal.VM.Foreach' loops by 'YCHR.Internal.Compile.classifyEqual'. Empty+    -- when no occurrence context is available (function equations).+    indexConditions :: PartnerCondMap,+    -- | Residual boolean check that did not lift into the index map.+    -- 'Nothing' when every check guard lifted or when there were no+    -- check guards.+    residualCheck :: Maybe BoolExpr,+    -- | 'VarMap' extended with the bindings introduced by match+    -- guards.+    extendedVarMap :: VarMap+  }++newtype OccurrenceMap = OccurrenceMap (Map.Map Identifier [Occurrence])++occMapEmpty :: OccurrenceMap+occMapEmpty = OccurrenceMap Map.empty++occMapAppend :: Identifier -> Occurrence -> OccurrenceMap -> OccurrenceMap+occMapAppend k occ (OccurrenceMap m) = OccurrenceMap (Map.insertWith (++) k [occ] m)++occMapMap :: ([Occurrence] -> [Occurrence]) -> OccurrenceMap -> OccurrenceMap+occMapMap f (OccurrenceMap m) = OccurrenceMap (Map.map f m)++lookupOccurrences :: Identifier -> OccurrenceMap -> [Occurrence]+lookupOccurrences k (OccurrenceMap m) = Map.findWithDefault [] k m++-- | Map from source-level variable names to the 'ValExpr' that holds+-- their value. The compiler stores only value bindings here; constraint+-- identifiers (partner ids, the active id) are referenced by their+-- generated names directly via 'YCHR.Internal.VM.IdVar' and never enter the map.+newtype VarMap = VarMap (Map.Map Text ValExpr)++varMapFromList :: [(Text, ValExpr)] -> VarMap+varMapFromList = VarMap . Map.fromList++lookupVar :: Text -> VarMap -> Maybe ValExpr+lookupVar k (VarMap m) = Map.lookup k m++insertVar :: Text -> ValExpr -> VarMap -> VarMap+insertVar k v (VarMap m) = VarMap (Map.insert k v m)++notMemberVar :: Text -> VarMap -> Bool+notMemberVar k (VarMap m) = Map.notMember k m
+ src/YCHR/Internal/Constructors.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Shared data-constructor resolution.+--+-- Maps from a program's @:- chr_type@ declarations that let any phase+-- (the type checker, the exhaustiveness checker) answer two questions+-- about a use-site constructor name: which declared type and+-- constructor does it refer to ('lookupCon'), and what is its canonical+-- qualified form ('canonicalizeCon').+--+-- The subtle part is 'buildConAlias': an unqualified name is resolved+-- to its declaration only when exactly one declared constructor uses+-- it. Ambiguous names (declared in more than one module) are dropped so+-- callers fall through and treat the use site as unknown rather than+-- guessing. Keeping this logic in one place stops the type checker and+-- the exhaustiveness checker from diverging on that rule.+module YCHR.Internal.Constructors+  ( ConEnv (..),+    buildConEnv,+    buildConMap,+    buildConAlias,+    canonicalizeCon,+    lookupCon,+  )+where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import YCHR.Internal.Types+  ( DataConstructor (..),+    Name (..),+    TypeDefinition (..),+    typeConstructors,+  )++-- | Constructor-resolution maps derived from a program's type+-- definitions.+data ConEnv = ConEnv+  { -- | Map from constructor name to its parent type definition and+    -- constructor info.+    conMap :: Map Name (TypeDefinition, DataConstructor),+    -- | Resolves a use-site unqualified name to its declaration's+    -- qualified name when exactly one constructor matches. See+    -- 'buildConAlias'.+    conAlias :: Map Text Name+  }++-- | Build a 'ConEnv' from a program's type definitions.+buildConEnv :: [TypeDefinition] -> ConEnv+buildConEnv tds =+  ConEnv+    { conMap = buildConMap tds,+      conAlias = buildConAlias tds+    }++buildConMap :: [TypeDefinition] -> Map Name (TypeDefinition, DataConstructor)+buildConMap tds =+  Map.fromList+    [ (dc.conName, (td, dc))+    | td <- tds,+      dc <- typeConstructors td+    ]++-- | Build the use-site → declaration alias map, keyed by unqualified name.+-- A name is included only when exactly one declared constructor uses it;+-- ambiguous names (same unqualified name declared in more than one module)+-- are dropped so 'canonicalizeCon' falls through and the caller treats the+-- use site as unknown rather than guessing.+buildConAlias :: [TypeDefinition] -> Map Text Name+buildConAlias tds =+  Map.mapMaybe single $+    Map.fromListWith+      (++)+      [ (unqualifiedText dc.conName, [dc.conName])+      | td <- tds,+        dc <- typeConstructors td+      ]+  where+    single [n] = Just n+    single _ = Nothing+    unqualifiedText (Unqualified t) = t+    unqualifiedText (Qualified _ t) = t++-- | Map a use-site constructor name to its declared, qualified form when a+-- unique match exists. 'Qualified' names pass through unchanged;+-- 'Unqualified' names are resolved through 'conAlias'. When no unique+-- match exists the name is returned as-is.+canonicalizeCon :: ConEnv -> Name -> Name+canonicalizeCon _ name@(Qualified _ _) = name+canonicalizeCon env (Unqualified n) =+  Map.findWithDefault (Unqualified n) n env.conAlias++-- | Look up a (possibly already canonical) constructor name in the+-- 'conMap'. Returns the parent type definition and the constructor.+lookupCon :: ConEnv -> Name -> Maybe (TypeDefinition, DataConstructor)+lookupCon env name = Map.lookup name env.conMap
+ src/YCHR/Internal/Desugar.hs view
@@ -0,0 +1,1050 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : YCHR.Internal.Desugar+-- Description : Transforms the resolved AST into the compiler's internal AST.+--+-- The Desugarer is the transformation pass between the resolved+-- 'YCHR.Internal.Resolved.Program' and the internal 'YCHR.Internal.Desugared.Program'+-- consumed by the compiler. It performs, in order:+--+-- 1. /Head-kind flattening/: map the three surface head kinds+--    ('P.Simplification', 'P.Propagation', 'P.Simpagation') to the+--    uniform @Kept\/Removed@ shape of 'D.Head'.+--+-- 2. /Head Normal Form (HNF)/: in every head constraint, replace+--    non-variable and duplicated-variable arguments with fresh variables,+--    emitting explicit 'D.GuardEqual' / 'D.GuardMatch' / 'D.GuardGetArg'+--    guards.+--+-- 3. /Goal classification/: partition each body into structured 'D.BodyGoal'+--    values ('D.BodyUnify', 'D.BodyIs', 'D.BodyHostStmt',+--    'D.BodyCall', 'D.BodyTell', or 'D.BodyTrue').+--+-- 4. /Guard classification/: map each surface guard term to a 'D.Guard'.+--+-- 5. /Function-equation desugaring/: HNF-normalize function-equation+--    patterns and produce 'D.Function' values.+--+-- 6. /Lambda lifting/: replace @fun(...) -> ...@ closures with top-level+--    @__lambda_N@ functions plus closure compound terms carrying the+--    captured free variables.+--+-- Module erasure and equation grouping are handled upstream by the+-- resolve phase ('YCHR.Internal.Resolve').+--+-- 'extractSymbolTable' is a separate utility that assigns sequential IDs+-- to every 'Qualified' rule-head constraint in the desugared program; it+-- is not part of the main pipeline.+--+-- Non-obvious design choices are documented in the \"Notes\" block at the+-- bottom of this file.+module YCHR.Internal.Desugar+  ( -- * Pipeline+    desugarProgram,+    desugarQueryGoals,++    -- * Lambda lifting+    liftAllLambdas,+    liftQueryLambdas,++    -- * Symbol table+    SymbolTable,+    extractSymbolTable,++    -- * Errors+    DesugarError (..),+  )+where++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, modify)+import Control.Monad.Trans.Writer.CPS (Writer, runWriter, tell)+import Data.List (mapAccumL)+import Data.List qualified as List+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import YCHR.Internal.Desugared qualified as D+import YCHR.Internal.Diagnostic (Diagnostic (..))+import YCHR.Internal.PExpr (PExpr (Atom))+import YCHR.Internal.Parsed (AnnP (..), noAnnP)+import YCHR.Internal.Parsed qualified as P+import YCHR.Internal.Resolved qualified as R+import YCHR.Internal.Types++-- | Errors produced by the desugaring pass.+data DesugarError+  = -- | A rule-body expression did not match any of the recognized+    -- body-goal forms (unification, @is@, host call, user-function+    -- call, dynamic dispatch, constraint tell, @true@). See+    -- 'desugarBodyGoal' for the accepted shapes.+    UnexpectedBodyExpr R.Expr+  | -- | A guard expression that structurally cannot evaluate to a+    -- boolean (e.g. a numeric literal, a non-@true@/@false@ atom, a+    -- data constructor application, a lambda). See 'guardExprIsAllowed'+    -- for the rejection predicate.+    NonBooleanGuard R.Expr+  | -- | A non-final item in a function body sequence was not one of the+    -- allowed shapes (@X is E@, @host:f(args)@, function call, or+    -- @'$call'@).+    NonPreludeFunctionBodyItem R.Expr+  | -- | A non-final @is@ binding had a non-variable LHS, which is not+    -- supported in a function body (function bodies have no unification+    -- machinery).+    NonVariableIsInFunctionBody R.Expr+  deriving (Eq, Show)++-- | Prefix for fresh variables introduced by the Head Normal Form+-- transformation (see 'normalizeHead').+hnfPrefix :: Text+hnfPrefix = "_hnf_"++-- | Prefix for fresh variables introduced when rewriting a non-variable+-- @T is E@ form into @R is E, R = T@ (see 'desugarBodyGoal').+isPrefix :: Text+isPrefix = "__is_"++-- | Prefix for top-level function names produced by the lambda-lifter+-- (see 'liftAllLambdas' and 'liftQueryLambdas').+lambdaPrefix :: Text+lambdaPrefix = "__lambda_"++-- | Functor name for self-describing closure terms.+closureFunctor :: Text+closureFunctor = "__closure"++-- | Quote an expression so it becomes ground: variable references+-- become 0-arity ctor literals; wildcards become @CtorExpr "_" []@.+-- Used to embed the original lambda source form in the closure+-- expression without introducing dangling variable references. The+-- pretty-printer reads the quoted form back out at display time; the+-- form is never evaluated. See the comment at 'sourceForm' in+-- 'liftExpr' for the reason 'LambdaExpr' is flattened here rather+-- than preserved.+quoteExpr :: R.Expr -> R.Expr+quoteExpr (R.VarExpr v) = R.CtorExpr (Unqualified v) []+quoteExpr R.WildcardExpr = R.CtorExpr (Unqualified "_") []+quoteExpr (R.CtorExpr n args) = R.CtorExpr n (map quoteExpr args)+quoteExpr (R.CallExpr qn args) = R.CallExpr qn (map quoteExpr args)+quoteExpr (R.ApplyExpr f args) =+  R.ApplyExpr (quoteExpr f) (map quoteExpr args)+quoteExpr (R.HostExpr f args) = R.HostExpr f (map quoteExpr args)+quoteExpr (R.LambdaExpr params body) =+  R.CtorExpr+    (Unqualified "->")+    [ R.CtorExpr (Unqualified "fun") (map paramAtom (NE.toList params)),+      quoteSequence body+    ]+  where+    paramAtom (HeadVar v) = R.CtorExpr (Unqualified v) []+    paramAtom HeadWildcard = R.CtorExpr (Unqualified "_") []+    quoteSequence = go . NE.toList+      where+        go [e] = quoteExpr e+        go (e : es) =+          R.CtorExpr+            (Unqualified ",")+            [quoteExpr e, go es]+        go [] = R.CtorExpr (Unqualified "true") [] -- unreachable: NonEmpty+quoteExpr e@(R.IntExpr _) = e+quoteExpr e@(R.FloatExpr _) = e+quoteExpr e@(R.TextExpr _) = e+quoteExpr e@(R.FunRefExpr _ _) = e++-- | Convert a head-position 'Term' (always a pattern: variable, wildcard,+-- literal, or constructor compound) to its 'R.Expr' equivalent. HNF+-- emits guards whose operands are these patterns, so the conversion is+-- exhaustive over the pattern grammar.+headTermToExpr :: Term -> R.Expr+headTermToExpr (VarTerm v) = R.VarExpr v+headTermToExpr Wildcard = R.WildcardExpr+headTermToExpr (IntTerm n) = R.IntExpr n+headTermToExpr (FloatTerm n) = R.FloatExpr n+headTermToExpr (TextTerm s) = R.TextExpr s+headTermToExpr (CompoundTerm n args) =+  R.CtorExpr n (map headTermToExpr args)++-- | The primary entry point: converts a resolved program to a desugared program.+desugarProgram :: R.Program -> Either [Diagnostic DesugarError] D.Program+desugarProgram rprog =+  let (result, errs) = runWriter $ do+        rules <- traverse desugarRule rprog.rules+        functions <- traverse desugarFunctionDef rprog.functions+        pure+          D.Program+            { rules = rules,+              functions = functions,+              constraintTypes = rprog.constraintTypes,+              constraintBounds = rprog.constraintBounds,+              typeDefinitions = rprog.typeDefinitions+            }+   in if null errs then Right result else Left errs++-- | Scans a desugared program and builds the optimization map.+-- It ensures that all qualified names get a sequential ID starting from 0.+--+-- Constraint names come from two sources:+--+--   1. Every head constraint and body-tell in every rule (rules are the+--      primary source — they tell us which constraints participate in+--      the ωr activation-dispatch loop).+--   2. Every constraint declared via @:- chr_constraint@ that does not+--      appear in any rule (unreferenced constraints still need a+--      @tell_c@ procedure so the user can tell them at goal time without+--      a raw \"Constraint not found\" error).+extractSymbolTable :: D.Program -> SymbolTable+extractSymbolTable prog =+  let rules = prog.rules+      ruleIds =+        Set.fromList+          [ qualifiedNameToIdentifier name arity+          | r <- rules,+            (name, arity) <- getRuleConstraints r+          ]+      -- Constraints declared via :- chr_constraint that never appear in+      -- any rule still need a tell_c and activate_c procedure. Without+      -- a symbol-table entry the compiler skips them entirely and the+      -- user hits a raw "user error (Constraint not found)" at goal time.+      declaredIds =+        Set.fromList+          [ qualifiedNameToIdentifier qn (length types)+          | (qn, types) <- Map.toList prog.constraintTypes+          ]+      allIds = ruleIds `Set.union` declaredIds+   in mkSymbolTable (zip (Set.toList allIds) (map ConstraintType [0 ..]))++-- | Helper to find every constraint instance in a desugared rule,+-- returning its qualified name and arity. Head and body tells are both+-- included, since both contribute to the constraint-symbol table.+getRuleConstraints :: D.Rule -> [(QualifiedName, Int)]+getRuleConstraints r =+  let AnnP {node = rHead} = r.head+      AnnP {node = rBody} = r.body+      headPair hc = (hc.name, length hc.args)+   in map headPair rHead.kept+        ++ map headPair rHead.removed+        ++ [(qn, length args) | D.BodyTell qn args <- rBody]++-- | Desugar one resolved rule: classify its body goals, desugar its user+-- guards, flatten the head kind, and run HNF on the head. HNF-emitted+-- guards are prepended to the user guards so they run first.+desugarRule :: R.Rule -> Writer [Diagnostic DesugarError] D.Rule+desugarRule r = do+  let ruleLabel = fmap (\ann -> "rule " <> ann.node) r.name+  ruleBody <- desugarBodyGoals ruleLabel r.body.sourceLoc r.body.parsed r.body.node+  userGuards <- traverse (desugarGuard r.guard.sourceLoc r.guard.parsed) r.guard.node+  let (rawKept, rawRemoved) = flattenHeadKind r.head.node+      (guards, normalizedHead) = normalizeHead rawKept rawRemoved+  pure+    D.Rule+      { name = fmap (.node) r.name,+        head = AnnP normalizedHead r.head.sourceLoc r.head.parsed,+        guard = AnnP (guards ++ userGuards) r.guard.sourceLoc r.guard.parsed,+        body = AnnP ruleBody r.body.sourceLoc r.body.parsed+      }++-- | Map the three resolved head kinds to a uniform @(kept, removed)@+-- pair of raw 'QualifiedConstraint' lists. Propagation rules keep every+-- constraint; simplification rules remove every constraint; simpagation+-- rules carry both lists explicitly. The result is fed to+-- 'normalizeHead', which produces the 'D.Head' with HNF-narrowed+-- 'HeadConstraint' arguments.+flattenHeadKind :: R.Head -> ([QualifiedConstraint], [QualifiedConstraint])+flattenHeadKind h = case h of+  R.Simplification rs -> ([], rs)+  R.Propagation ks -> (ks, [])+  R.Simpagation ks rs -> (ks, rs)++-- ---------------------------------------------------------------------------+-- Head Normal Form (HNF)+-- ---------------------------------------------------------------------------++-- | In every head constraint, replace non-variable and duplicated-variable+-- arguments with fresh variables and emit explicit 'D.GuardEqual',+-- 'D.GuardMatch', and 'D.GuardGetArg' guards that recover the original+-- semantics.++-- | Threaded state for HNF: a fresh-variable counter, the set of+-- variable names already seen in the head so far (so that duplicates+-- can be detected), and the list of guards accumulated in reverse order.+data HnfState = HnfState+  { counter :: !Int,+    seen :: Set.Set Text,+    guards :: [D.Guard] -- accumulated in reverse+  }++-- | Normalize the kept and removed constraints of a head. Kept is+-- processed before removed so that variables first appearing in kept+-- constraints become the canonical binding (see the note at the bottom+-- of this module).+normalizeHead :: [QualifiedConstraint] -> [QualifiedConstraint] -> ([D.Guard], D.Head)+normalizeHead kept removed =+  let initState = HnfState 0 Set.empty []+      (st1, kept') = mapAccumL normalizeConstraint initState kept+      (st2, removed') = mapAccumL normalizeConstraint st1 removed+   in (reverse st2.guards, D.Head kept' removed')++-- | Normalize the arguments of one head constraint, narrowing them+-- from raw 'Term's to 'HeadArg's.+normalizeConstraint :: HnfState -> QualifiedConstraint -> (HnfState, HeadConstraint)+normalizeConstraint st (QualifiedConstraint cname cargs) =+  let (st', args') = mapAccumL normalizeArg st cargs+   in (st', HeadConstraint cname args')++-- | Normalize one argument of a head constraint. Fresh variables are+-- only introduced for duplicates and non-variables; first-use variables+-- and wildcards pass through.+normalizeArg :: HnfState -> Term -> (HnfState, HeadArg)+normalizeArg HnfState {counter, seen, guards} (VarTerm v)+  | Set.member v seen =+      let fresh = hnfPrefix <> T.pack (show counter)+       in ( HnfState+              { counter = counter + 1,+                seen,+                guards = D.GuardEqual (R.VarExpr v) (R.VarExpr fresh) : guards+              },+            HeadVar fresh+          )+  | otherwise =+      ( HnfState {counter, seen = Set.insert v seen, guards},+        HeadVar v+      )+-- Wildcards pass through unchanged: they match anything, are never referenced,+-- and cannot duplicate, so no fresh variable or guard is needed.+normalizeArg st Wildcard = (st, HeadWildcard)+normalizeArg HnfState {counter, seen, guards} (CompoundTerm cname cargs) =+  let fresh = hnfPrefix <> T.pack (show counter)+      st' = HnfState {counter = counter + 1, seen, guards}+      st'' = decomposeCompound st' fresh cname cargs+   in (st'', HeadVar fresh)+normalizeArg HnfState {counter, seen, guards} term =+  let fresh = hnfPrefix <> T.pack (show counter)+   in ( HnfState+          { counter = counter + 1,+            seen,+            guards = D.GuardEqual (R.VarExpr fresh) (headTermToExpr term) : guards+          },+        HeadVar fresh+      )++-- | Decompose a compound term into match and extraction guards. Both+-- 'Qualified' and 'Unqualified' constructor functors are handled+-- uniformly: the renamer canonicalizes data constructors to their+-- 'Qualified' form, and the compiler emits both as a single flat-atom+-- compound (see 'YCHR.Internal.Compile.compileTerm') — so HNF can just emit one+-- 'GuardMatch' per compound regardless of where the name originated.+decomposeCompound :: HnfState -> Text -> Name -> [Term] -> HnfState+decomposeCompound HnfState {counter, seen, guards} parentVar cname cargs =+  let matchGuard = D.GuardMatch (R.VarExpr parentVar) cname (length cargs)+      st' = HnfState {counter, seen, guards = matchGuard : guards}+   in List.foldl' (\s (i, arg) -> decomposeArg s parentVar i arg) st' (zip [0 ..] cargs)++-- | Decompose a single argument of a compound term.+decomposeArg :: HnfState -> Text -> Int -> Term -> HnfState+decomposeArg HnfState {counter, seen, guards} parentVar i (VarTerm v)+  | Set.member v seen =+      -- Duplicate variable: extract and check equality+      let fresh = hnfPrefix <> T.pack (show counter)+          getGuard = D.GuardGetArg fresh (R.VarExpr parentVar) i+          eqGuard = D.GuardEqual (R.VarExpr v) (R.VarExpr fresh)+       in HnfState+            { counter = counter + 1,+              seen,+              guards = eqGuard : getGuard : guards+            }+  | otherwise =+      -- First occurrence: extract and bind+      let getGuard = D.GuardGetArg v (R.VarExpr parentVar) i+       in HnfState+            { counter,+              seen = Set.insert v seen,+              guards = getGuard : guards+            }+decomposeArg st _ _ Wildcard = st+decomposeArg HnfState {counter, seen, guards} parentVar i (CompoundTerm cname cargs) =+  -- Nested compound: extract then recursively decompose+  let fresh = hnfPrefix <> T.pack (show counter)+      getGuard = D.GuardGetArg fresh (R.VarExpr parentVar) i+      st' =+        HnfState+          { counter = counter + 1,+            seen,+            guards = getGuard : guards+          }+   in decomposeCompound st' fresh cname cargs+decomposeArg HnfState {counter, seen, guards} parentVar i term =+  -- Ground term (atom, integer, string): extract and check equality+  let fresh = hnfPrefix <> T.pack (show counter)+      getGuard = D.GuardGetArg fresh (R.VarExpr parentVar) i+      eqGuard = D.GuardEqual (R.VarExpr fresh) (headTermToExpr term)+   in HnfState+        { counter = counter + 1,+          seen,+          guards = eqGuard : getGuard : guards+        }++-- | Desugar a resolved function definition: HNF-normalize its equation+-- patterns and produce a 'D.Function'.+desugarFunctionDef :: R.FunctionDef -> Writer [Diagnostic DesugarError] D.Function+desugarFunctionDef fdef = do+  desugaredEqs <- traverse desugarResolvedEquation fdef.equations+  let (loc, parsed) = case fdef.equations of+        (AnnP _eq eqLoc eqParsed : _) -> (eqLoc, eqParsed)+        [] -> (P.dummyLoc, Atom "function")+  pure+    D.Function+      { name = fdef.name,+        arity = fdef.arity,+        signatures = fdef.signatures,+        requiring = fdef.requiring,+        equations = AnnP desugaredEqs loc parsed+      }++desugarResolvedEquation ::+  AnnP R.FunctionEquation ->+  Writer [Diagnostic DesugarError] D.Equation+desugarResolvedEquation annEq = desugarEquation' annEq.node++desugarEquation' :: R.FunctionEquation -> Writer [Diagnostic DesugarError] D.Equation+desugarEquation' eq = do+  let initState = HnfState 0 Set.empty []+      (st, normalizedArgs) = mapAccumL normalizeArg initState eq.args+      guards = reverse st.guards+  userGuards <- traverse (desugarGuard eq.guard.sourceLoc eq.guard.parsed) eq.guard.node+  (prelude, returnExpr) <-+    classifyFunctionBody eq.rhs.sourceLoc eq.rhs.parsed eq.rhs.node+  pure+    D.Equation+      { params = normalizedArgs,+        guards = guards ++ userGuards,+        prelude = prelude,+        rhs = returnExpr+      }++-- | Split a function-body sequence into its non-final prelude items+-- and the trailing return expression. Each non-final item must be one+-- of @host:f(args)@, @X is E@ (variable LHS), a function call, or+-- @'$call'(F, args)@; anything else is reported as 'NonPreludeFunctionBodyItem'.+-- A non-variable @is@ LHS in non-final position is reported as+-- 'NonVariableIsInFunctionBody'. The return expression is left as-is.+classifyFunctionBody ::+  P.SourceLoc ->+  PExpr ->+  NE.NonEmpty R.Expr ->+  Writer [Diagnostic DesugarError] ([D.FunStmt], R.Expr)+classifyFunctionBody loc origin body = do+  let (initExprs, lastExpr) = (NE.init body, NE.last body)+  stmts <- traverse (classifyFunStmt loc origin) initExprs+  pure (stmts, lastExpr)++-- | Classify a single non-final function-body expression into a 'D.FunStmt'.+-- Emits a diagnostic and returns a no-op placeholder when the shape is+-- not one of the allowed forms; the placeholder is unreachable because+-- compilation aborts whenever any diagnostic is emitted.+classifyFunStmt ::+  P.SourceLoc ->+  PExpr ->+  R.Expr ->+  Writer [Diagnostic DesugarError] D.FunStmt+classifyFunStmt loc origin e = case e of+  R.HostExpr f args -> pure (D.FunHostStmt f args)+  R.CtorExpr (Unqualified "is") [R.VarExpr v, expr] -> pure (D.FunIs v expr)+  R.CtorExpr (Unqualified "is") [_, _] -> do+    tell [Diagnostic Nothing (AnnP (NonVariableIsInFunctionBody e) loc origin)]+    pure (D.FunHostStmt "" [])+  R.CallExpr qn args -> pure (D.FunCall qn args)+  R.ApplyExpr f args -> pure (D.FunApply f args)+  _ -> do+    tell [Diagnostic Nothing (AnnP (NonPreludeFunctionBodyItem e) loc origin)]+    pure (D.FunHostStmt "" [])++-- | Classify a resolved guard expression into a 'D.Guard'.+--+-- Expressions that structurally cannot evaluate to a boolean+-- (non-boolean literals, data constructor applications other than+-- @prelude:true@/@prelude:false@, function references, lambdas,+-- wildcards) are rejected with 'NonBooleanGuard'. This catches+-- categorical bugs like writing @=@ (a data constructor application)+-- or a numeric literal in guard position at desugar time, independent+-- of whether the optional typechecker runs.+desugarGuard ::+  P.SourceLoc ->+  PExpr ->+  R.Expr ->+  Writer [Diagnostic DesugarError] D.Guard+desugarGuard loc origin e+  | guardExprIsAllowed e = pure (D.GuardExpr e)+  | otherwise = do+      tell [Diagnostic Nothing (AnnP (NonBooleanGuard e) loc origin)]+      pure (D.GuardExpr e)++-- | Predicate: can this expression plausibly evaluate to a boolean?+-- Variables, calls, dynamic dispatch, host calls, the bare atoms+-- @true@/@false@, and the canonicalized @prelude:true@/@prelude:false@+-- constructors are accepted. Every other atom is rejected: an+-- unqualified atom that is neither @true@ nor @false@ cannot possibly+-- evaluate to a boolean.+guardExprIsAllowed :: R.Expr -> Bool+guardExprIsAllowed e = case e of+  R.VarExpr {} -> True+  R.CtorExpr (Unqualified "true") [] -> True+  R.CtorExpr (Unqualified "false") [] -> True+  R.CallExpr {} -> True+  R.ApplyExpr {} -> True+  R.HostExpr {} -> True+  R.CtorExpr (Qualified "prelude" "true") [] -> True+  R.CtorExpr (Qualified "prelude" "false") [] -> True+  _ -> False++-- | Desugar a list of query goal expressions into 'BodyGoal's.+-- Returns 'Left' if any desugaring errors occur.+desugarQueryGoals :: [R.Expr] -> Either [Diagnostic DesugarError] [D.BodyGoal]+desugarQueryGoals goals =+  let (results, errs) =+        runWriter $+          desugarBodyGoals Nothing P.dummyLoc (Atom "") goals+   in if null errs then Right results else Left errs++-- ---------------------------------------------------------------------------+-- VarNameSupply: fresh variable generation for desugaring+-- ---------------------------------------------------------------------------++freshVarName :: StateT Int (Writer [Diagnostic DesugarError]) Text+freshVarName = do+  n <- get+  modify (+ 1)+  pure (isPrefix <> T.pack (show n))++runVarNameSupply ::+  StateT Int (Writer [Diagnostic DesugarError]) a ->+  Writer [Diagnostic DesugarError] a+runVarNameSupply m = evalStateT m 0++-- | Desugar a list of body expressions, flattening any multi-goal+-- expansions (e.g. non-variable @is@ LHS).+desugarBodyGoals ::+  Maybe Text ->+  P.SourceLoc ->+  PExpr ->+  [R.Expr] ->+  Writer [Diagnostic DesugarError] [D.BodyGoal]+desugarBodyGoals label loc origin exprs =+  runVarNameSupply $ concat <$> traverse (desugarBodyGoal label loc origin) exprs++-- | Classify a resolved body expression into 'D.BodyGoal's.+--+-- Pattern priority (order matters):+--+-- 1. @X = Y@ -> 'D.BodyUnify'+-- 2. @X is Expr@ (variable LHS) -> 'D.BodyIs'+-- 3. @T is Expr@ (non-variable LHS) -> @R is Expr, R = T@ with fresh @R@+-- 4. 'R.HostExpr' -> 'D.BodyHostStmt'+-- 5. 'R.CallExpr' -> 'D.BodyCall'+-- 6. 'R.ApplyExpr' -> 'D.BodyApply'+-- 7. Constructor with a 'Qualified' name -> 'D.BodyTell'+-- 8. @true@ in any spelling -> 'D.BodyTrue'+-- 9. Anything else -> error+desugarBodyGoal ::+  Maybe Text ->+  P.SourceLoc ->+  PExpr ->+  R.Expr ->+  StateT Int (Writer [Diagnostic DesugarError]) [D.BodyGoal]+desugarBodyGoal label loc origin e = case e of+  -- Surface '=' arrives as CtorExpr "=" from the resolver.+  R.CtorExpr (Unqualified "=") [l, r] -> pure [D.BodyUnify l r]+  -- 'is' with a variable LHS.+  R.CtorExpr (Unqualified "is") [R.VarExpr v, expr] ->+    pure [D.BodyIs v expr]+  -- 'is' with a non-variable LHS: introduce a fresh value, then unify.+  R.CtorExpr (Unqualified "is") [lhs, expr] -> do+    v <- freshVarName+    pure [D.BodyIs v expr, D.BodyUnify (R.VarExpr v) lhs]+  R.HostExpr f args -> pure [D.BodyHostStmt f args]+  R.CtorExpr (Qualified "prelude" "true") [] -> pure [D.BodyTrue]+  R.CtorExpr (Unqualified "true") [] -> pure [D.BodyTrue]+  R.CallExpr qn args -> pure [D.BodyCall qn args]+  R.ApplyExpr f args -> pure [D.BodyApply f args]+  R.CtorExpr (Qualified m b) args ->+    pure [D.BodyTell (QualifiedName m b) args]+  _ -> do+    lift (tell [Diagnostic label (AnnP (UnexpectedBodyExpr e) loc origin)])+    pure [D.BodyTrue]++-- ---------------------------------------------------------------------------+-- Lambda lifting+-- ---------------------------------------------------------------------------++-- | Threaded state for the lambda-lifter: a counter that supplies fresh+-- @__lambda_N@ names, the list of top-level functions that have already+-- been lifted out (in reverse discovery order), and an error accumulator+-- for lambda-body classification failures discovered during the lift.+-- Errors here mirror the diagnostics 'desugarEquation'' emits for the+-- top-level RHS sequence of an equation.+data LiftState = LiftState+  { counter :: !Int,+    liftedFunctions :: [D.Function],+    liftErrors :: [Diagnostic DesugarError]+  }++-- | Collect all variable names referenced inside an expression.+exprVars :: R.Expr -> Set.Set Text+exprVars (R.VarExpr v) = Set.singleton v+exprVars (R.CtorExpr _ args) = Set.unions (map exprVars args)+exprVars (R.CallExpr _ args) = Set.unions (map exprVars args)+exprVars (R.ApplyExpr f args) =+  exprVars f `Set.union` Set.unions (map exprVars args)+exprVars (R.HostExpr _ args) = Set.unions (map exprVars args)+exprVars (R.LambdaExpr params body) =+  sequenceFree (NE.toList body)+    `Set.difference` Set.fromList [v | HeadVar v <- NE.toList params]+exprVars (R.FunRefExpr _ _) = Set.empty+exprVars (R.IntExpr _) = Set.empty+exprVars (R.FloatExpr _) = Set.empty+exprVars (R.TextExpr _) = Set.empty+exprVars R.WildcardExpr = Set.empty++-- | Free variables of a sequenced expression list (lambda body or+-- top-level function body), treating an @X is E@ item as a binder for+-- X: uses of X /before/ the binding (and uses of X in @E@ itself, which+-- is evaluated /before/ the binding takes effect) still count, while+-- uses in /later/ items resolve to the local binding and do not escape.+sequenceFree :: [R.Expr] -> Set.Set Text+sequenceFree = go Set.empty+  where+    go _ [] = Set.empty+    go bound (e : es) =+      let usedHere = case e of+            R.CtorExpr (Unqualified "is") [R.VarExpr _, rhs] -> exprVars rhs+            _ -> exprVars e+          contrib = usedHere `Set.difference` bound+          bound' = case e of+            R.CtorExpr (Unqualified "is") [R.VarExpr v, _] ->+              Set.insert v bound+            _ -> bound+       in contrib `Set.union` go bound' es++-- | Lift lambdas in a single expression. Each 'R.LambdaExpr' is+-- replaced by a /self-describing closure/ of the form+-- @__closure(LambdaId, SourceForm, F1, …, Fn)@: @LambdaId@ is an atom+-- identifying the lifted function, @SourceForm@ is a quoted copy of+-- the original lambda (for pretty-printing), and @F1 .. Fn@ are the+-- captured free variables. The lambda body itself is lifted into a+-- fresh top-level 'D.Function'. Returns the updated state and the+-- rewritten expression.+--+-- @parentRequiring@ is the enclosing bounded declaration's+-- @requiring@ clause (or @[]@ when the lambda's parent is unbounded).+-- Every lifted lambda inherits this clause so that bound-named+-- operations inside the lambda body resolve against the same ambient+-- signatures as in the parent's equation. Nested lambdas inherit+-- recursively.+liftExpr ::+  Text ->+  Set.Set Text ->+  [BoundSig] ->+  LiftState ->+  R.Expr ->+  (LiftState, R.Expr)+liftExpr modName scope parentRequiring st0 expr = case expr of+  R.LambdaExpr params body ->+    let paramsList = NE.toList params+        paramVarNames = Set.fromList [v | HeadVar v <- paramsList]+        bodyList = NE.toList body+        -- Walk the body left-to-right so that a name bound by an+        -- earlier 'X is E' shadows later uses of X but does NOT+        -- shadow uses in the same item's RHS or in items that+        -- precede the binding. The latter still capture the outer+        -- value, which 'fun(X) -> N is N + 1, N end' relies on:+        -- the inner 'N' on the RHS of 'is' is the captured outer N.+        bodyFree = sequenceFree bodyList+        freeVars =+          Set.toAscList+            ( bodyFree+                `Set.intersection` scope+                `Set.difference` paramVarNames+            )+        -- The inner scope is a superset; locally-bound names are+        -- added so nested lambdas can find them, on top of params+        -- and any names bound by prelude 'is' statements.+        innerScope =+          scope+            `Set.union` paramVarNames+            `Set.union` Set.fromList+              [v | R.CtorExpr (Unqualified "is") [R.VarExpr v, _] <- bodyList]+        (st1, liftedBody) =+          mapAccumL+            (liftExpr modName innerScope parentRequiring)+            st0+            bodyList+        liftedBodyNE = NE.fromList liftedBody+        (preludeExprs, rhsExpr) =+          (NE.init liftedBodyNE, NE.last liftedBodyNE)+        (prelude, classifyErrs) =+          runWriter $+            traverse+              (classifyFunStmt P.dummyLoc (Atom ""))+              preludeExprs+        st1' = st1 {liftErrors = st1.liftErrors ++ classifyErrs}+        idx = st1'.counter+        lambdaName = lambdaPrefix <> T.pack (show idx)+        qualName = QualifiedName modName lambdaName+        allParams = map HeadVar freeVars ++ paramsList+        func =+          D.Function+            { name = qualName,+              arity = length allParams,+              signatures = [],+              requiring = parentRequiring,+              equations =+                noAnnP+                  [ D.Equation+                      { params = allParams,+                        guards = [],+                        prelude = prelude,+                        rhs = rhsExpr+                      }+                  ]+            }+        st2 =+          st1'+            { counter = idx + 1,+              liftedFunctions = func : st1'.liftedFunctions+            }+        lambdaId = modName <> "__" <> lambdaName+        -- The quoted source form is for pretty-printing only and must+        -- stay opaque: it contains the lambda body with all its+        -- function-named subterms (@'+'@, @'*'@, user functions, …)+        -- still spelled out, and 'compileExpr' would otherwise+        -- eagerly evaluate them at closure-construction time. Wrap+        -- in @quote/1@ so 'compileExpr' short-circuits via+        -- 'compileTerm' on the 'R.exprToTerm' of the quoted subtree.+        --+        -- 'quoteExpr' also rewrites 'R.LambdaExpr' into a surface+        -- @->@/@fun@ 'CtorExpr' with atomised parameter names.+        -- Keeping a real 'LambdaExpr' here would leave its parameter+        -- variables as 'HeadVar's; 'R.exprToTerm' would turn each+        -- into a 'VarTerm', and 'compileTerm' would then look it up+        -- in the enclosing rule's varMap (where it does not exist)+        -- and raise 'UnboundVariable'. Atomising the parameters+        -- breaks that lookup chain.+        sourceForm =+          R.CtorExpr (Unqualified "quote") [quoteExpr expr]+        closureArgs =+          R.CtorExpr (Unqualified lambdaId) [] : sourceForm : map R.VarExpr freeVars+     in (st2, R.CtorExpr (Unqualified closureFunctor) closureArgs)+  R.CtorExpr name args ->+    let (st1, args') =+          mapAccumL (liftExpr modName scope parentRequiring) st0 args+     in (st1, R.CtorExpr name args')+  R.CallExpr qn args ->+    let (st1, args') =+          mapAccumL (liftExpr modName scope parentRequiring) st0 args+     in (st1, R.CallExpr qn args')+  R.ApplyExpr f args ->+    let (st1, f') = liftExpr modName scope parentRequiring st0 f+        (st2, args') =+          mapAccumL (liftExpr modName scope parentRequiring) st1 args+     in (st2, R.ApplyExpr f' args')+  R.HostExpr f args ->+    let (st1, args') =+          mapAccumL (liftExpr modName scope parentRequiring) st0 args+     in (st1, R.HostExpr f args')+  _ -> (st0, expr)++-- | Lift lambdas in a body goal. Every body goal carries 'Expr'-typed+-- children, so 'liftExpr' walks them uniformly.+liftBodyGoal ::+  Text ->+  Set.Set Text ->+  [BoundSig] ->+  LiftState ->+  D.BodyGoal ->+  (LiftState, D.BodyGoal)+liftBodyGoal modName scope parentRequiring st goal = case goal of+  D.BodyIs v expr ->+    let (st', expr') = liftExpr modName scope parentRequiring st expr+     in (st', D.BodyIs v expr')+  D.BodyCall qn args ->+    let (st', args') =+          mapAccumL (liftExpr modName scope parentRequiring) st args+     in (st', D.BodyCall qn args')+  D.BodyApply f args ->+    let (st', f') = liftExpr modName scope parentRequiring st f+        (st'', args') =+          mapAccumL (liftExpr modName scope parentRequiring) st' args+     in (st'', D.BodyApply f' args')+  D.BodyTell qn args ->+    let (st', args') =+          mapAccumL (liftExpr modName scope parentRequiring) st args+     in (st', D.BodyTell qn args')+  D.BodyUnify t1 t2 ->+    let (st', t1') = liftExpr modName scope parentRequiring st t1+        (st'', t2') = liftExpr modName scope parentRequiring st' t2+     in (st'', D.BodyUnify t1' t2')+  D.BodyHostStmt f args ->+    let (st', args') =+          mapAccumL (liftExpr modName scope parentRequiring) st args+     in (st', D.BodyHostStmt f args')+  D.BodyTrue -> (st, D.BodyTrue)++-- | Lift lambdas in a guard. 'GuardExpr' and 'GuardEqual' carry+-- user-written expressions that can contain a lambda+-- (@X == fun(Y) -> Y end@ is unusual but legal), so both arms walk+-- their operands with 'liftExpr'. 'GuardMatch' and 'GuardGetArg' are+-- HNF-synthetic: their operands are always 'R.VarExpr', so a walk+-- would be a no-op and we leave them untouched.+liftGuard ::+  Text ->+  Set.Set Text ->+  [BoundSig] ->+  LiftState ->+  D.Guard ->+  (LiftState, D.Guard)+liftGuard modName scope parentRequiring st guard_ = case guard_ of+  D.GuardExpr e ->+    let (st', e') = liftExpr modName scope parentRequiring st e+     in (st', D.GuardExpr e')+  D.GuardEqual e1 e2 ->+    let (st', e1') = liftExpr modName scope parentRequiring st e1+        (st'', e2') = liftExpr modName scope parentRequiring st' e2+     in (st'', D.GuardEqual e1' e2')+  _ -> (st, guard_)++-- | Lift lambdas in a function equation. The scope visible to the RHS+-- (and therefore to any lambda captured inside it) includes the pattern+-- parameters /and/ the variables introduced by HNF guards — most+-- importantly 'D.GuardGetArg', which binds the user-written components+-- of a compound pattern like @maplist(F, [X|Xs]) -> ...@.+liftEquation ::+  Text ->+  [BoundSig] ->+  LiftState ->+  D.Equation ->+  (LiftState, D.Equation)+liftEquation modName parentRequiring st eq =+  let scope =+        Set.unions (map headArgVars eq.params)+          `Set.union` guardVars eq.guards+          `Set.union` funStmtBindings eq.prelude+      (st', guards') =+        mapAccumL (liftGuard modName scope parentRequiring) st eq.guards+      (st'', prelude') =+        mapAccumL (liftFunStmt modName scope parentRequiring) st' eq.prelude+      (st''', rhs') = liftExpr modName scope parentRequiring st'' eq.rhs+   in (st''', eq {D.guards = guards', D.prelude = prelude', D.rhs = rhs'})++-- | Lift lambdas in a function-body prelude statement.+liftFunStmt ::+  Text ->+  Set.Set Text ->+  [BoundSig] ->+  LiftState ->+  D.FunStmt ->+  (LiftState, D.FunStmt)+liftFunStmt modName scope parentRequiring st stmt = case stmt of+  D.FunIs v expr ->+    let (st', expr') = liftExpr modName scope parentRequiring st expr+     in (st', D.FunIs v expr')+  D.FunHostStmt f args ->+    let (st', args') =+          mapAccumL (liftExpr modName scope parentRequiring) st args+     in (st', D.FunHostStmt f args')+  D.FunCall qn args ->+    let (st', args') =+          mapAccumL (liftExpr modName scope parentRequiring) st args+     in (st', D.FunCall qn args')+  D.FunApply f args ->+    let (st', f') = liftExpr modName scope parentRequiring st f+        (st'', args') =+          mapAccumL (liftExpr modName scope parentRequiring) st' args+     in (st'', D.FunApply f' args')++-- | Variables bound by a list of function-body prelude statements (only+-- 'FunIs' contributes a binding).+funStmtBindings :: [D.FunStmt] -> Set.Set Text+funStmtBindings = Set.fromList . concatMap binds+  where+    binds (D.FunIs v _) = [v]+    binds _ = []++-- | Lift lambdas in a function definition. The function's own+-- @requiring@ clause is the @parentRequiring@ propagated to every+-- lambda lifted out of its equations.+liftFunction :: LiftState -> D.Function -> (LiftState, D.Function)+liftFunction st func =+  let modName = func.name.moduleName+      (st', eqs') =+        mapAccumL+          (liftEquation modName func.requiring)+          st+          func.equations.node+   in (st', func {D.equations = func.equations {node = eqs'}})++-- | Variables introduced by a single 'HeadArg'. Wildcards contribute+-- nothing.+headArgVars :: HeadArg -> Set.Set Text+headArgVars (HeadVar v) = Set.singleton v+headArgVars HeadWildcard = Set.empty++-- | Extract all variables from a rule head (kept + removed constraints).+ruleHeadVars :: D.Head -> Set.Set Text+ruleHeadVars h =+  Set.unions+    [ headArgVars arg+    | c <- h.kept ++ h.removed,+      arg <- c.args+    ]++-- | Extract the module name from a rule's head constraints. The+-- qualification invariant is enforced by 'QualifiedConstraint'; the+-- only way this can fail is an empty head, which the parser does not+-- produce for well-formed rules.+ruleModName :: D.Head -> Text+ruleModName h = case h.kept ++ h.removed of+  (c : _) -> c.name.moduleName+  [] -> error "Desugar.ruleModName: empty rule head"++-- | Collect all variables from a list of body goals.+bodyGoalVars :: [D.BodyGoal] -> Set.Set Text+bodyGoalVars = Set.unions . map goalVars+  where+    goalVars (D.BodyIs v expr) = Set.insert v (exprVars expr)+    goalVars (D.BodyCall _ args) = Set.unions (map exprVars args)+    goalVars (D.BodyApply f args) =+      exprVars f `Set.union` Set.unions (map exprVars args)+    goalVars (D.BodyTell _ args) = Set.unions (map exprVars args)+    goalVars (D.BodyUnify e1 e2) = exprVars e1 `Set.union` exprVars e2+    goalVars (D.BodyHostStmt _ args) = Set.unions (map exprVars args)+    goalVars D.BodyTrue = Set.empty++-- | Collect all variables from a list of guards.+guardVars :: [D.Guard] -> Set.Set Text+guardVars = Set.unions . map gVars+  where+    gVars (D.GuardExpr e) = exprVars e+    gVars (D.GuardEqual e1 e2) = exprVars e1 `Set.union` exprVars e2+    gVars (D.GuardGetArg v e _) = Set.insert v (exprVars e)+    gVars (D.GuardMatch e _ _) = exprVars e++-- | Lift lambdas in a rule. The scope includes all variables from the+-- entire rule (head, guard, and body). Rules use an empty+-- @parentRequiring@: bounded constraints contribute ambient signatures+-- at type-check time through the head-occurrence mechanism, not by+-- pushing bounds onto lifted lambdas (lambdas in rule bodies that need+-- bound-named operations remain rare in practice).+liftRule :: LiftState -> D.Rule -> (LiftState, D.Rule)+liftRule st rule =+  let headNode = rule.head.node+      scope =+        ruleHeadVars headNode+          `Set.union` guardVars rule.guard.node+          `Set.union` bodyGoalVars rule.body.node+      modName = ruleModName headNode+      (st', guards') =+        mapAccumL (liftGuard modName scope []) st rule.guard.node+      (st'', body') =+        mapAccumL (liftBodyGoal modName scope []) st' rule.body.node+   in ( st'',+        rule+          { D.guard = rule.guard {node = guards'},+            D.body = rule.body {node = body'}+          }+      )++-- | Post-desugaring pass: lift all lambda expressions into top-level+-- functions. Returns any diagnostics produced while classifying lambda+-- body sequences (see 'classifyFunStmt'). Callers must merge these+-- with the rest of the pipeline's errors.+liftAllLambdas :: D.Program -> (D.Program, [Diagnostic DesugarError])+liftAllLambdas prog =+  let initState = LiftState 0 [] []+      (st1, functions') = mapAccumL liftFunction initState prog.functions+      (st2, rules') = mapAccumL liftRule st1 prog.rules+   in ( prog+          { D.functions = functions' ++ st2.liftedFunctions,+            D.rules = rules'+          },+        st2.liftErrors+      )++-- | Lift lambdas from query body goals. Returns the rewritten goals+-- and any generated function definitions (to be compiled on the fly).+-- Uses @\"__query\"@ as the module name for lifted lambdas, and starts+-- the counter high enough to avoid collisions with program lambdas.+-- Query lambdas inherit no @requiring@ clause: the top-level goal has+-- no enclosing bounded declaration whose bound could propagate.+liftQueryLambdas ::+  Int ->+  [D.BodyGoal] ->+  ([D.BodyGoal], [D.Function], [Diagnostic DesugarError])+liftQueryLambdas startCounter goals =+  let scope = bodyGoalVars goals+      initState = LiftState startCounter [] []+      (st, goals') =+        mapAccumL (liftBodyGoal "__query" scope []) initState goals+   in (goals', st.liftedFunctions, st.liftErrors)++{- ---------------------------------------------------------------------------+Notes+-----------------------------------------------------------------------------++Why HNF processes 'kept' constraints before 'removed' ones: variables+that appear for the first time in a kept constraint become the canonical+binding for that name. A variable that then recurs in a removed+constraint is renamed to a fresh @_hnf_N@ and equated to the canonical+one via a 'D.GuardEqual'. Reversing the order would work just as well+mathematically but would mean the canonical binding "moves" whenever a+rule is rewritten from simpagation to simplification/propagation, which+the paper's scheme avoids.++Why there are three different fresh-variable prefixes:++  * @_hnf_N@   — HNF-introduced variables for duplicated or non-variable+                head arguments ('normalizeHead', 'decomposeCompound').+  * @__is_N@   — fresh LHS variables for the non-variable @is@ form+                (@T is E@ becomes @R is E, R = T@). Double-underscore so+                they cannot collide with the HNF prefix or with any+                user-written name.+  * @__lambda_N@ — names of top-level functions created by the+                lambda-lifter. Double-underscore again to stay clear of+                user names.++Each prefix is owned by a different phase and they cannot collide with+each other or with user variables.++Why 'extractSymbolTable' scans both rules and constraintTypes: the symbol+table assigns a numeric ID to every CHR constraint type so the VM can+dispatch activations by array index. Rule heads provide the primary+source (they determine which constraints participate in the &omega;r+activation-dispatch loop). Functions are invoked by name through+'D.BodyFunctionCall', not through the constraint dispatch table, so they+do not need numeric IDs. Constraints declared via ':- chr_constraint'+that never appear in any rule are also included from the+'prog.constraintTypes' map; without a symbol-table entry the compiler+generates no 'tell_c' procedure for them and the user gets a raw+"Constraint not found" error at goal time.++Why 'liftQueryLambdas' uses @\"__query\"@ as the module name: query+goals don't belong to any user module, but lifted lambdas still need a+'Qualified' name. @__query@ is a synthetic qualifier that cannot clash+with a real module (module names in the surface language don't start+with an underscore). The caller ('Run.runProgramWithQuery') passes+a @startCounter@ greater than the number of program lambdas so query+@__lambda_N@ indices do not overlap with ones already baked into the+compiled program.++Why 'liftEquation's scope includes 'guardVars': HNF may decompose a+compound pattern like @[X|Xs]@ into a 'D.GuardGetArg' that binds @X@ and+@Xs@. Those names are no longer visible from @eq.params@ (which only+contains the top-level @_hnf_N@), but they are valid references from+the RHS — including from inside a lambda. The lambda-lifter therefore+has to see them too, otherwise the lambda would be lifted without+capturing them and the reference would dangle at runtime. Test:+@"Desugar.lambda-lift.lambda captures HNF-bound pattern variable"@.+--------------------------------------------------------------------------- -}
+ src/YCHR/Internal/Desugared.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE DuplicateRecordFields #-}++-- | CHR Abstract Syntax Tree+--+-- This module defines the internal AST for CHR programs. This is not+-- the direct output of the parser, but a desugared and semantically+-- precise representation that guides compilation to the VM.+--+-- Desugaring already performed at this stage:+--+--   * Simplification and propagation rules are represented uniformly+--     as simpagation rules. A simplification rule has an empty 'headKept'+--     list; a propagation rule has an empty 'headRemoved' list. The+--     compiler checks whether 'headRemoved' is empty to decide whether+--     propagation history maintenance is needed.+--+--   * Guards and body goals are represented with distinct types+--     ('Guard' and 'BodyGoal') to enforce that only semantically+--     appropriate goals appear in each position.+--+--   * Constraint head names and function names are 'QualifiedName',+--     so the qualification invariant established by the renamer and+--     committed by the resolver is reflected in the type system.+module YCHR.Internal.Desugared+  ( -- * Program structure+    Program (..),+    Rule (..),+    Head (..),+    Function (..),+    Equation (..),++    -- * Goals+    Guard (..),+    BodyGoal (..),+    FunStmt (..),++    -- * Expressions+    Expr (..),++    -- * Re-exports from CHR.Types+    QualifiedConstraint (..),+    QualifiedName (..),+    HeadConstraint (..),+    HeadArg (..),+    Term (..),+    TypeExpr (..),+    TypeDefinition (..),+    BoundSig (..),+  )+where++import Data.Map.Strict (Map)+import Data.Text (Text)+import YCHR.Internal.Parsed (AnnP)+import YCHR.Internal.Resolved (Expr (..))+import YCHR.Internal.Types++data Program = Program+  { rules :: [Rule],+    functions :: [Function],+    constraintTypes :: Map QualifiedName [TypeExpr],+    -- | Bounds declared on each @:- chr_constraint@ that carries a+    -- @requiring@ clause. See 'YCHR.Internal.Resolved.Program' for the+    -- bounded-vs-unbounded convention (constraints without bounds are+    -- absent from the map).+    constraintBounds :: Map QualifiedName [BoundSig],+    typeDefinitions :: [TypeDefinition]+  }+  deriving (Show)++data Rule = Rule+  { name :: Maybe Text,+    head :: AnnP Head,+    guard :: AnnP [Guard],+    body :: AnnP [BodyGoal]+  }+  deriving (Show)++data Head = Head+  { kept :: [HeadConstraint],+    removed :: [HeadConstraint]+  }+  deriving (Show, Eq)++-- | Guards over the typed 'Expr' AST. 'GuardMatch' and 'GuardGetArg'+-- always carry a 'VarExpr' as their operand: HNF only introduces+-- match/getarg guards for fresh variables it has just bound. The+-- operand type is left as 'Expr' rather than 'Text' so the lambda+-- lifter and pretty-printer can walk guards uniformly.+data Guard+  = GuardEqual Expr Expr+  | GuardMatch Expr Name Int+  | GuardGetArg Text Expr Int+  | GuardExpr Expr+  deriving (Show, Eq)++-- | Body goals over the typed 'Expr' AST.+--+-- 'BodyTell' is a tell of a user-declared constraint. Its arguments+-- are 'Expr' and are evaluated at runtime, like every other expression+-- position in the language (function args, constructor args, @is@ RHS,+-- @=@ operands). Head patterns and equation patterns still carry+-- 'Term' (see 'HeadConstraint' / 'Equation'); the call-vs-constructor+-- question is decided structurally for tells but does not arise for+-- patterns.+--+-- 'BodyCall' replaces the legacy @BodyFunctionCall@ for static calls+-- and 'BodyApply' replaces it for dynamic dispatch ('$call').+data BodyGoal+  = BodyTrue+  | BodyTell QualifiedName [Expr]+  | BodyUnify Expr Expr+  | BodyHostStmt Text [Expr]+  | BodyIs Text Expr+  | BodyCall QualifiedName [Expr]+  | BodyApply Expr [Expr]+  deriving (Show, Eq)++data Function = Function+  { name :: QualifiedName,+    arity :: Int,+    signatures :: [([TypeExpr], TypeExpr)],+    -- | Bounds declared on this function via @requiring@. Empty when+    -- the function is unbounded.+    requiring :: [BoundSig],+    equations :: AnnP [Equation]+  }+  deriving (Show)++data Equation = Equation+  { params :: [HeadArg],+    guards :: [Guard],+    -- | Statements executed before evaluating 'rhs'. Empty for+    -- single-expression bodies. The desugarer is responsible for+    -- restricting which 'R.Expr' shapes are accepted in non-final+    -- position; see 'FunStmt'.+    prelude :: [FunStmt],+    rhs :: Expr+  }+  deriving (Show)++-- | A statement appearing in non-final position of a function equation's+-- right-hand side. Strictly a subset of 'BodyGoal' — rule-body-only forms+-- like 'BodyTell', 'BodyUnify', and 'BodyTrue' are intentionally not+-- representable.+data FunStmt+  = -- | @X is E@. The LHS must be a variable; the desugarer rejects+    -- non-variable LHS in this position.+    FunIs Text Expr+  | -- | @host:f(args)@ evaluated for side effects.+    FunHostStmt Text [Expr]+  | -- | Statically resolved user-function call; result discarded.+    FunCall QualifiedName [Expr]+  | -- | Dynamic dispatch (@'$call'(F, args)@); result discarded.+    FunApply Expr [Expr]+  deriving (Show, Eq)
+ src/YCHR/Internal/Diagnostic.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Diagnostic wrapper for annotated errors and warnings.+--+-- A 'Diagnostic' pairs an optional location label (e.g. @"rule transitivity"@+-- or @"function factorial\/1"@) with the 'AnnP'-wrapped error node. The label+-- is displayed between the source-location header and the message body in+-- diagnostic output.+module YCHR.Internal.Diagnostic+  ( Diagnostic (..),+    noDiag,+  )+where++import Data.Text (Text)+import YCHR.Internal.Parsed (AnnP (..))++-- | An annotated error or warning with an optional location label.+data Diagnostic a = Diagnostic+  { -- | Human-readable label for the enclosing context, e.g.+    -- @"rule transitivity"@ or @"function factorial\/1"@.+    diagLabel :: Maybe Text,+    -- | The underlying annotated node.+    diagAnnotation :: AnnP a+  }+  deriving (Show, Eq)++-- | Wrap an 'AnnP' value into a 'Diagnostic' with no label.+noDiag :: AnnP a -> Diagnostic a+noDiag = Diagnostic Nothing
+ src/YCHR/Internal/Display.hs view
@@ -0,0 +1,1020 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Human-readable error display.+module YCHR.Internal.Display+  ( Display (..),+    Severity (..),+    ErrorCode (..),+    displaySrcLoc,+    displayMsgWithSrcLoc,+    displayErrorCode,+    collectErrorCode,+    parseValidationErrorCode,+    resolveErrorCode,+    renameErrorCode,+    renameWarningCode,+    exhaustivenessWarningCode,+    desugarErrorCode,+    compileErrorCode,+    typeCheckErrorCode,+    parseErrorCode,+    operatorConflictCode,+    lambdasInLiveQueryCode,+    runtimeErrorCode,+    goalNotAConstraintCode,+  )+where++import Data.List (intercalate)+import Data.Text qualified as T+import System.Console.ANSI+  ( Color (..),+    ColorIntensity (..),+    ConsoleIntensity (..),+    ConsoleLayer (..),+    SGR (..),+    setSGRCode,+  )+import Text.Parsec.Error qualified as PE+import Text.Parsec.Pos (SourcePos, sourceColumn, sourceLine, sourceName)+import YCHR.Internal.Collect (CollectError (..))+import YCHR.Internal.Compile (CompileError (..))+import YCHR.Internal.Compile.Pipeline (Error (..), GoalRejection (..), Warning (..))+import YCHR.Internal.Desugar (DesugarError (..))+import YCHR.Internal.Diagnostic (Diagnostic (..))+import YCHR.Internal.Exhaustiveness (ExhaustivenessWarning (..))+import YCHR.Internal.Parsed (AnnP (..))+import YCHR.Internal.Parsed qualified as P+import YCHR.Internal.Parser (ParseValidationError (..))+import YCHR.Internal.Pretty (prettyPExprSrc, prettyTermSrc)+import YCHR.Internal.Rename (RenameError (..), RenameWarning (..))+import YCHR.Internal.Resolve (ResolveError (..))+import YCHR.Internal.Resolved qualified as R+import YCHR.Internal.TypeCheck (TypeCheckError (..))+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM (StackFrame (..))++class Display a where+  displayMsg :: a -> String++-- | Diagnostic severity. Drives both the header label (e.g. @=== error+-- ===@) and the foreground color of 'displayMsgWithSrcLoc'.+--+-- 'SevRuntimeError' is the top frame of a runtime-error stack (magenta),+-- and 'SevStackTrace' is each subsequent frame (cyan). Keeping them+-- distinct lets readers locate the actual error site at a glance even+-- when the stack is deep.+data Severity+  = SevError+  | SevWarning+  | SevRuntimeError+  | SevStackTrace++newtype ErrorCode = ErrorCode Int+  deriving (Show, Eq, Ord)++-- | Format an error code as @YCHR-NNNNN@.+displayErrorCode :: ErrorCode -> String+displayErrorCode (ErrorCode n) = "YCHR-" ++ show n++-- | Display a source location as @file:line:col@.+displaySrcLoc :: P.SourceLoc -> String+displaySrcLoc loc = loc.file ++ ":" ++ show loc.line ++ ":" ++ show loc.col++severityLabel :: Severity -> String+severityLabel SevError = "error"+severityLabel SevWarning = "warning"+severityLabel SevRuntimeError = "runtime error"+severityLabel SevStackTrace = "stack trace"++severityColor :: Severity -> Color+severityColor SevError = Red+severityColor SevWarning = Yellow+severityColor SevRuntimeError = Magenta+severityColor SevStackTrace = Cyan++-- | Format a diagnostic message with source location, severity, error code,+-- optional location label, and optional AST context.+--+-- @+-- file:line:col: severity: YCHR-NNNNN+-- location_label+-- message+-- ast_node+-- @+displayMsgWithSrcLoc ::+  ErrorCode ->+  Severity ->+  String ->+  P.SourceLoc ->+  Maybe String ->+  Maybe String ->+  String+displayMsgWithSrcLoc code sev msg loc maybeLabel maybeNode =+  let col = severityColor sev+      lbl = severityLabel sev+      c = setSGRCode [SetColor Foreground Vivid col]+      r = setSGRCode [Reset]+   in c+        ++ "=== "+        ++ lbl+        ++ " ==="+        ++ r+        ++ "\n"+        ++ setSGRCode [SetConsoleIntensity BoldIntensity]+        ++ displaySrcLoc loc+        ++ ": "+        ++ displayErrorCode code+        ++ "\n"+        ++ maybe+          ""+          ( \l ->+              setSGRCode [SetConsoleIntensity BoldIntensity]+                ++ "<<"+                ++ l+                ++ ">>"+                ++ r+                ++ "\n"+          )+          maybeLabel+        ++ msg+        ++ maybe+          ""+          ( \n ->+              -- Skip the message/node separator when msg is empty so a+              -- stack-trace frame (which carries no message of its own)+              -- doesn't render a phantom blank line between '<<label>>'+              -- and the italicized source snippet.+              (if null msg then "" else "\n")+                ++ setSGRCode [SetItalicized True]+                ++ n+                ++ setSGRCode [SetItalicized False]+          )+          maybeNode+        ++ "\n"+        ++ r++-- | Join multiple error messages. Each message is expected to end with+-- a newline, so a single @\"\\n\"@ separator produces a blank line between+-- messages.+displayErrors :: [String] -> String+displayErrors = intercalate "\n"++-- | Append a hint line to a diagnostic message. Hints are rendered as+-- a second sentence, indented two spaces, so they stand apart from the+-- headline inside the 'displayMsgWithSrcLoc' block.+withHint :: String -> String -> String+withHint msg hint = msg ++ "\n  Hint: " ++ hint++-- | Convert a parsec 'Text.Parsec.Pos.SourcePos' to a 'P.SourceLoc'.+sourceLocFromPos :: SourcePos -> P.SourceLoc+sourceLocFromPos sp =+  P.SourceLoc+    { P.file = sourceName sp,+      P.line = sourceLine sp,+      P.col = sourceColumn sp+    }++-- ---------------------------------------------------------------------------+-- Error codes by phase+-- ---------------------------------------------------------------------------++-- | 1xxxx — collect phase+collectErrorCode :: CollectError -> ErrorCode+collectErrorCode (UnknownLibrary _) = ErrorCode 10001+collectErrorCode (CircularLibraryImport _) = ErrorCode 10002++-- | 15xxx — parse validation phase+parseValidationErrorCode :: ParseValidationError -> ErrorCode+parseValidationErrorCode (DiscontiguousEquations _) = ErrorCode 15001+parseValidationErrorCode MalformedImport = ErrorCode 15002+parseValidationErrorCode MalformedConstraint = ErrorCode 15003+parseValidationErrorCode (DiscontiguousFunctionDecls _) = ErrorCode 15004+parseValidationErrorCode (RequiringOnClass _) = ErrorCode 15005+parseValidationErrorCode (RequiringOnExtendClassType _) = ErrorCode 15006+parseValidationErrorCode MalformedDeclaration = ErrorCode 15007+parseValidationErrorCode MalformedExportItem = ErrorCode 15008+parseValidationErrorCode MalformedTypeExpr = ErrorCode 15009+parseValidationErrorCode MalformedDataConstructor = ErrorCode 15010+parseValidationErrorCode MalformedTypeDefinition = ErrorCode 15011+parseValidationErrorCode OpaqueTypeHasConstructors = ErrorCode 15016+parseValidationErrorCode MalformedOpaqueTypeDefinition = ErrorCode 15017+parseValidationErrorCode MalformedBoundSig = ErrorCode 15012+parseValidationErrorCode MalformedFunctionEquation = ErrorCode 15013+parseValidationErrorCode MalformedTopLevel = ErrorCode 15014+parseValidationErrorCode (DuplicateModuleHeader _) = ErrorCode 15015++-- | 16xxx — resolve phase (post-rename, pre-desugar)+resolveErrorCode :: ResolveError -> ErrorCode+resolveErrorCode (ConstraintHasEquations _) = ErrorCode 16001+resolveErrorCode (FunctionInRuleHead _) = ErrorCode 16002+resolveErrorCode (ReservedName _) = ErrorCode 16003+resolveErrorCode (ReservedModuleName _) = ErrorCode 16019+resolveErrorCode (UnqualifiedConstraintName _) = ErrorCode 16004+resolveErrorCode (ExtendsClosedFunction _) = ErrorCode 16005+resolveErrorCode (OrphanFunctionEquation _ _) = ErrorCode 16006+-- Bounded polymorphism (per docs/reference/type-system.md §Bounded+-- Polymorphism §Errors): the unbound-variable, unknown-bound, cycle,+-- and extend-on-bounded checks all live in the resolve phase.+resolveErrorCode (ExtendTypeOnBoundedFunction _) = ErrorCode 16007+resolveErrorCode (UnboundBoundVariable _ _) = ErrorCode 16008+resolveErrorCode (UnknownBoundFunction _ _ _) = ErrorCode 16009+resolveErrorCode (BoundCycle _) = ErrorCode 16010+resolveErrorCode (MultiSigOnFunction _) = ErrorCode 16011+resolveErrorCode (MixedDeclKinds _) = ErrorCode 16012+resolveErrorCode (ExtendClassTypeOnFunction _) = ErrorCode 16013+resolveErrorCode (ExtendClassOnFunction _) = ErrorCode 16014+resolveErrorCode (ExtendFunctionOnClass _) = ErrorCode 16015+resolveErrorCode (ConstraintFunctionCollision _) = ErrorCode 16016+resolveErrorCode (LambdaParamError _) = ErrorCode 16017+resolveErrorCode EmptyLambdaParams = ErrorCode 16018++-- | 2xxxx — rename phase (errors).+-- Code 20004 was previously used for OperatorInImportList; now reserved+-- because operators are permitted in import lists (see UnknownOperatorImport).+renameErrorCode :: RenameError -> ErrorCode+renameErrorCode (AmbiguousName _ _ _) = ErrorCode 20001+renameErrorCode (UnknownName _ _) = ErrorCode 20002+renameErrorCode (UnknownExport _ _ _) = ErrorCode 20003+renameErrorCode (UnknownImport _ _ _) = ErrorCode 20005+renameErrorCode (UnknownOperatorImport _ _) = ErrorCode 20006+renameErrorCode (UseModuleOutOfOrder _) = ErrorCode 20007+renameErrorCode (UnknownExportedConstructor _ _ _ _) = ErrorCode 20008+renameErrorCode (NotExportedByModule _ _ _) = ErrorCode 20009+renameErrorCode (NonExportedConstructor _ _ _) = ErrorCode 20010+renameErrorCode (ConstructorNotExported _ _ _ _) = ErrorCode 20011+renameErrorCode (AmbiguousDataConstructor _ _) = ErrorCode 20012+renameErrorCode (ModuleNotImported _ _ _) = ErrorCode 20014+renameErrorCode (UnknownModule _) = ErrorCode 20015++-- | 2x1xx — rename phase (warnings)+renameWarningCode :: RenameWarning -> ErrorCode+renameWarningCode (UndeclaredDataConstructor _) = ErrorCode 20101+renameWarningCode (DataConstructorArityMismatch _ _) = ErrorCode 20102++-- | 2x1xx — exhaustiveness warnings (a pattern-matching warning, in the+-- same warning band as the rename warnings).+exhaustivenessWarningCode :: ExhaustivenessWarning -> ErrorCode+exhaustivenessWarningCode (NonExhaustiveMatch _ _) = ErrorCode 20103++-- | 3xxxx — desugar phase+desugarErrorCode :: DesugarError -> ErrorCode+desugarErrorCode (UnexpectedBodyExpr _) = ErrorCode 30001+desugarErrorCode (NonBooleanGuard _) = ErrorCode 30002+desugarErrorCode (NonPreludeFunctionBodyItem _) = ErrorCode 30003+desugarErrorCode (NonVariableIsInFunctionBody _) = ErrorCode 30004++-- | 4xxxx — compile phase+compileErrorCode :: CompileError -> ErrorCode+compileErrorCode (UnknownConstraintType _) = ErrorCode 40001+compileErrorCode (UnboundVariable _) = ErrorCode 40002++-- | 6xxxx — type-check phase+typeCheckErrorCode :: TypeCheckError -> ErrorCode+typeCheckErrorCode (InconsistentTypes _ _) = ErrorCode 60001+typeCheckErrorCode (UnboundTypeVar _ _ _) = ErrorCode 60004+typeCheckErrorCode (UndefinedType _ _ _) = ErrorCode 60005+typeCheckErrorCode (NoMatchingOverload _) = ErrorCode 60006+typeCheckErrorCode (DuplicateConstructor _ _) = ErrorCode 60007+typeCheckErrorCode (ConstructorArityMismatch _ _ _) = ErrorCode 60008+typeCheckErrorCode (BoundUnsatisfied _) = ErrorCode 60012++-- | 5xxxx — top-level errors.+--+-- These standalone code constants are not attached to an enumerable error+-- constructor, so the uniqueness guard in @test/YCHR/ErrorCodeTest.hs@+-- cannot discover them by reflection: any new constant added below must+-- also be listed in that test's @standaloneCodes@.+parseErrorCode :: ErrorCode+parseErrorCode = ErrorCode 50001++operatorConflictCode :: ErrorCode+operatorConflictCode = ErrorCode 50002++lambdasInLiveQueryCode :: ErrorCode+lambdasInLiveQueryCode = ErrorCode 50003++-- | 20013 — @ychr run -g GOAL@ received a goal that is not a single+-- declared constraint (bare expression, conjunction, function call,+-- or an unknown name). Lives in the rename/resolution range because+-- the rejection is about goal-name resolution, not runtime behavior.+goalNotAConstraintCode :: ErrorCode+goalNotAConstraintCode = ErrorCode 20013++-- | 6xxxx — shared with type-check; 60001 is also used for runtime errors+-- raised by 'YCHR.Internal.Runtime.Error.runtimeError''/'runtimeErrorS'.+runtimeErrorCode :: ErrorCode+runtimeErrorCode = ErrorCode 60001++-- ---------------------------------------------------------------------------+-- Display instances+-- ---------------------------------------------------------------------------++instance Display (P.AnnP ParseValidationError) where+  displayMsg (AnnP err loc origin) =+    displayMsgWithSrcLoc+      (parseValidationErrorCode err)+      SevError+      (parseValidationErrorMsg err)+      loc+      Nothing+      (Just (prettyPExprSrc origin))++parseValidationErrorMsg :: ParseValidationError -> String+parseValidationErrorMsg (DiscontiguousEquations name) =+  withHint+    ("Equations for function '" ++ T.unpack name ++ "' must be contiguous")+    "declare the function with :- open_function to allow equations from other modules"+parseValidationErrorMsg (DiscontiguousFunctionDecls name) =+  withHint+    ("Declarations for '" ++ T.unpack name ++ "' must be contiguous")+    ( "use :- extend_function (open_function), :- extend_class"+        ++ " or :- extend_class_type (open_class) from another module"+        ++ " to extend an open declaration"+    )+parseValidationErrorMsg MalformedImport =+  withHint+    "Invalid import"+    "expected a module name or library(name)"+parseValidationErrorMsg MalformedConstraint =+  withHint+    "Invalid constraint"+    "expected an atom or compound term"+parseValidationErrorMsg (RequiringOnClass name) =+  withHint+    ( "'requiring' is not allowed on ':- class' / ':- open_class' (declaration '"+        ++ T.unpack name+        ++ "')"+    )+    "bounded polymorphism is reserved for :- function / :- open_function"+parseValidationErrorMsg (RequiringOnExtendClassType name) =+  withHint+    ( "'requiring' is not allowed on ':- extend_class_type' (target '"+        ++ T.unpack name+        ++ "')"+    )+    "bounds belong to the original declaration; an extension cannot introduce them"+parseValidationErrorMsg MalformedDeclaration =+  withHint+    "Invalid declaration"+    "expected name/arity, name(types) -> ret, or sig requiring bounds"+parseValidationErrorMsg MalformedExportItem =+  withHint+    "Invalid export/import list item"+    "expected name/arity, fun name/arity, type(name/arity), or op(prio, type, name)"+parseValidationErrorMsg MalformedTypeExpr =+  withHint+    "Invalid type expression"+    "expected a type variable, atom, or compound type"+parseValidationErrorMsg MalformedDataConstructor =+  withHint+    "Invalid data constructor"+    "expected an atom or compound term in a chr_type alternative"+parseValidationErrorMsg MalformedTypeDefinition =+  withHint+    "Invalid type definition"+    "expected 'name(Vars) ---> con1 ; con2 ; ...'"+parseValidationErrorMsg OpaqueTypeHasConstructors =+  withHint+    "Opaque type cannot have data constructors"+    ( "an opaque type is declared as ':- opaque_type name(Vars).' with no"+        ++ " '---> ...' body; use ':- chr_type' for a type with constructors"+    )+parseValidationErrorMsg MalformedOpaqueTypeDefinition =+  withHint+    "Invalid opaque type definition"+    "expected ':- opaque_type name.' or ':- opaque_type name(Vars).'"+parseValidationErrorMsg MalformedBoundSig =+  withHint+    "Invalid bound signature"+    "expected 'name(t1, ..., tn) -> tret' (or 'name -> tret' for arity zero)"+parseValidationErrorMsg MalformedFunctionEquation =+  withHint+    "Invalid function equation"+    "expected 'lhs [| guard] -> rhs'"+parseValidationErrorMsg MalformedTopLevel =+  withHint+    "Invalid top-level term"+    "expected a directive, rule (<=> or ==>), or function equation (->)"+parseValidationErrorMsg (DuplicateModuleHeader name) =+  withHint+    ("Duplicate ':- module(...)' header for '" ++ T.unpack name ++ "'")+    "a source file may declare at most one module header; remove the redundant directive"++instance Display (Diagnostic ResolveError) where+  displayMsg (Diagnostic lbl (AnnP err loc origin)) =+    displayMsgWithSrcLoc+      (resolveErrorCode err)+      SevError+      (resolveErrorMsg err)+      loc+      (fmap T.unpack lbl)+      (Just (prettyPExprSrc origin))++resolveErrorMsg :: ResolveError -> String+resolveErrorMsg (ConstraintHasEquations name) =+  withHint+    ( "'"+        ++ displayName name+        ++ "' is declared as a constraint but has function equations (->)"+    )+    "either declare it with :- function or remove the equations"+resolveErrorMsg (FunctionInRuleHead name) =+  withHint+    ( "'"+        ++ displayName name+        ++ "' is declared as a function but appears in a rule head"+    )+    "rule heads must be constraints; call the function from the body or a guard instead"+resolveErrorMsg (ReservedName name) =+  "'"+    ++ displayName name+    ++ "' is a reserved name and cannot be used as a constraint or function"+resolveErrorMsg (ReservedModuleName name) =+  withHint+    ("'" ++ T.unpack name ++ "' is a reserved name and cannot be used as a module name")+    "'host' is the wired-in host-call qualifier; rename the module"+resolveErrorMsg (UnqualifiedConstraintName name) =+  withHint+    ( "Internal error: unqualified constraint name reached the resolve phase ('"+        ++ displayName name+        ++ "')"+    )+    "this is a YCHR bug; please report it with the .chr file that triggered it"+resolveErrorMsg (ExtendsClosedFunction name) =+  withHint+    ( "Cannot extend '"+        ++ displayName name+        ++ "' because it is declared as closed"+    )+    "declare it with :- open_function or :- open_class to allow cross-module extensions"+resolveErrorMsg (OrphanFunctionEquation name modName) =+  withHint+    ( "Function '"+        ++ displayName name+        ++ "' is declared elsewhere but has an equation in module '"+        ++ T.unpack modName+        ++ "'"+    )+    ( "use :- extend_function (or :- extend_class) to add equations"+        ++ " to an open declaration from another module"+    )+resolveErrorMsg (ExtendTypeOnBoundedFunction name) =+  withHint+    ( "Cannot extend the type of bounded open function '"+        ++ displayName name+        ++ "'"+    )+    ( "the instance set of a bounded open function is determined by its"+        ++ " requiring clause; declare a new signature of the bound function"+        ++ " instead"+    )+resolveErrorMsg (UnboundBoundVariable declName var) =+  withHint+    ( "Type variable '"+        ++ T.unpack var+        ++ "' in the requiring clause of '"+        ++ T.unpack declName+        ++ "' is not bound by the declaration's primary signature"+    )+    ( "every variable in 'requiring' must also appear in the"+        ++ " declaration's argument or return types"+    )+resolveErrorMsg (UnknownBoundFunction declName boundName arity) =+  withHint+    ( "'"+        ++ T.unpack declName+        ++ "' requires '"+        ++ T.unpack boundName+        ++ "/"+        ++ show arity+        ++ "' but no such function is declared"+    )+    "declare ':- function "+    ++ T.unpack boundName+    ++ "/"+    ++ show arity+    ++ ".' (or import a module that does)"+resolveErrorMsg (BoundCycle names) =+  withHint+    ( "Cyclic 'requiring' clause: "+        ++ intercalate " -> " (map T.unpack names)+    )+    "the bound graph must be acyclic; remove or restructure one of the requiring edges"+resolveErrorMsg (MultiSigOnFunction name) =+  withHint+    ( "'"+        ++ displayName name+        ++ "' is declared with multiple signatures but is not a class"+    )+    ( "use :- class / :- open_class to enable signature overloading,"+        ++ " or keep a single :- function signature"+    )+resolveErrorMsg (MixedDeclKinds name) =+  withHint+    ( "'"+        ++ displayName name+        ++ "' is declared with both :- function and :- class forms"+    )+    ( "pick one form: :- function / :- open_function for single signatures,"+        ++ " :- class / :- open_class for overloads"+    )+resolveErrorMsg (ExtendClassTypeOnFunction name) =+  withHint+    ( "':- extend_class_type' targets '"+        ++ displayName name+        ++ "', which is declared as :- open_function"+    )+    ( "type extensions are only meaningful on :- open_class;"+        ++ " declare the target as :- open_class to overload it"+    )+resolveErrorMsg (ExtendClassOnFunction name) =+  withHint+    ( "':- extend_class' targets '"+        ++ displayName name+        ++ "', which is declared as :- open_function"+    )+    "use :- extend_function to add equations to an :- open_function"+resolveErrorMsg (ExtendFunctionOnClass name) =+  withHint+    ( "':- extend_function' targets '"+        ++ displayName name+        ++ "', which is declared as :- open_class"+    )+    "use :- extend_class to add equations to an :- open_class"+resolveErrorMsg (LambdaParamError term) =+  withHint+    ("Invalid lambda parameter: " ++ prettyTermSrc term)+    "lambda parameters must be variables or the anonymous variable (_)"+resolveErrorMsg EmptyLambdaParams =+  withHint+    "Lambda has no parameters"+    "lambdas must declare at least one parameter; use ':- function' for a no-arg helper"+resolveErrorMsg (ConstraintFunctionCollision name) =+  withHint+    ( "'"+        ++ displayName name+        ++ "' is declared as both :- chr_constraint and a function-like"+        ++ " form in the same module"+    )+    "constraints and functions share the symbol namespace; pick one form for this name"++instance Display (Diagnostic CollectError) where+  displayMsg (Diagnostic lbl (AnnP err loc origin)) =+    displayMsgWithSrcLoc+      (collectErrorCode err)+      SevError+      (collectErrorMsg err)+      loc+      (fmap T.unpack lbl)+      (Just (prettyPExprSrc origin))++collectErrorMsg :: CollectError -> String+collectErrorMsg (UnknownLibrary name) =+  withHint+    ("Unknown library '" ++ T.unpack name ++ "'")+    "check the library name; the built-in libraries are bundled with the compiler"+collectErrorMsg (CircularLibraryImport names) =+  "Circular library import: "+    ++ intercalate " -> " (map T.unpack names)++instance Display (Diagnostic RenameError) where+  displayMsg (Diagnostic lbl (AnnP err loc origin)) =+    displayMsgWithSrcLoc+      (renameErrorCode err)+      SevError+      (renameErrorMsg err)+      loc+      (fmap T.unpack lbl)+      (Just (prettyPExprSrc origin))++renameErrorMsg :: RenameError -> String+renameErrorMsg (AmbiguousName name arity candidates) =+  withHint+    ( "Ambiguous name '"+        ++ T.unpack name+        ++ "/"+        ++ show arity+        ++ "'"+    )+    ( "could be: "+        ++ intercalate ", " (map T.unpack candidates)+        ++ "; qualify the name explicitly to disambiguate"+    )+renameErrorMsg (UnknownName name arity) =+  withHint+    ("Unknown name '" ++ T.unpack name ++ "/" ++ show arity ++ "'")+    "declare it with :- chr_constraint or :- function, or import it from another module"+renameErrorMsg (UnknownExport modName name arity) =+  "Module '"+    ++ T.unpack modName+    ++ "' exports '"+    ++ T.unpack name+    ++ "/"+    ++ show arity+    ++ "' but does not declare it"+renameErrorMsg (UnknownImport modName name arity) =+  "Module '"+    ++ T.unpack modName+    ++ "' does not export '"+    ++ T.unpack name+    ++ "/"+    ++ show arity+    ++ "'"+renameErrorMsg (NotExportedByModule modName name arity) =+  withHint+    ( "Module '"+        ++ T.unpack modName+        ++ "' does not export '"+        ++ T.unpack name+        ++ "/"+        ++ show arity+        ++ "'"+    )+    ( "check the spelling and the export list of '"+        ++ T.unpack modName+        ++ "'"+    )+renameErrorMsg (ModuleNotImported modName name arity) =+  withHint+    ( "Module '"+        ++ T.unpack modName+        ++ "' is not imported (referenced as '"+        ++ T.unpack modName+        ++ ":"+        ++ T.unpack name+        ++ "/"+        ++ show arity+        ++ "')"+    )+    ( "add ':- use_module("+        ++ T.unpack modName+        ++ ").' to import it"+    )+renameErrorMsg (UnknownModule modName) =+  withHint+    ("No module named '" ++ T.unpack modName ++ "'")+    "check the module name, or declare the module"+renameErrorMsg (UnknownOperatorImport modName opName) =+  "Module '"+    ++ T.unpack modName+    ++ "' does not export operator '"+    ++ T.unpack opName+    ++ "'"+renameErrorMsg (UseModuleOutOfOrder modName) =+  withHint+    ( "use_module("+        ++ T.unpack modName+        ++ ") appears out of order"+    )+    ( "use_module directives must come immediately after the :- module"+        ++ " directive, before any other directive or rule"+    )+renameErrorMsg (UnknownExportedConstructor modName tyName tyArity conName) =+  "Module '"+    ++ T.unpack modName+    ++ "' exports type '"+    ++ T.unpack tyName+    ++ "/"+    ++ show tyArity+    ++ "' listing constructor '"+    ++ T.unpack conName+    ++ "', but that constructor is not declared on the type"+renameErrorMsg (NonExportedConstructor modName conName arity) =+  withHint+    ( "Module '"+        ++ T.unpack modName+        ++ "' does not export data constructor '"+        ++ T.unpack conName+        ++ "/"+        ++ show arity+        ++ "'"+    )+    ( "add '"+        ++ T.unpack conName+        ++ "' to the type's constructor export list in '"+        ++ T.unpack modName+        ++ "' (e.g. type(t/n, ["+        ++ T.unpack conName+        ++ ", ...]))"+    )+renameErrorMsg (ConstructorNotExported modName tyName tyArity conName) =+  withHint+    ( "Module '"+        ++ T.unpack modName+        ++ "' declares constructor '"+        ++ T.unpack conName+        ++ "' on type '"+        ++ T.unpack tyName+        ++ "/"+        ++ show tyArity+        ++ "' but does not export it"+    )+    ( "add '"+        ++ T.unpack conName+        ++ "' to the constructor export list of type '"+        ++ T.unpack tyName+        ++ "/"+        ++ show tyArity+        ++ "' in module '"+        ++ T.unpack modName+        ++ "'"+    )+renameErrorMsg (AmbiguousDataConstructor name candidates) =+  withHint+    ("Ambiguous data constructor '" ++ T.unpack name ++ "'")+    ( "exported by: "+        ++ intercalate ", " (map T.unpack candidates)+        ++ "; qualify the constructor explicitly to disambiguate"+    )++instance Display (Diagnostic RenameWarning) where+  displayMsg (Diagnostic lbl (AnnP err loc origin)) =+    displayMsgWithSrcLoc+      (renameWarningCode err)+      SevWarning+      (renameWarningMsg err)+      loc+      (fmap T.unpack lbl)+      (Just (prettyPExprSrc origin))++renameWarningMsg :: RenameWarning -> String+renameWarningMsg (UndeclaredDataConstructor name) =+  withHint+    ("Undeclared data constructor '" ++ T.unpack name ++ "'")+    "declare it with :- chr_type, or check the spelling"+renameWarningMsg (DataConstructorArityMismatch name arity) =+  "Data constructor '"+    ++ T.unpack name+    ++ "' used with "+    ++ show arity+    ++ " argument(s) but declared with a different arity"++instance Display (Diagnostic ExhaustivenessWarning) where+  displayMsg (Diagnostic lbl (AnnP err loc origin)) =+    displayMsgWithSrcLoc+      (exhaustivenessWarningCode err)+      SevWarning+      (exhaustivenessWarningMsg err)+      loc+      (fmap T.unpack lbl)+      (Just (prettyPExprSrc origin))++exhaustivenessWarningMsg :: ExhaustivenessWarning -> String+exhaustivenessWarningMsg (NonExhaustiveMatch name witness) =+  withHint+    ( "Non-exhaustive patterns in function '"+        ++ T.unpack name+        ++ "': no equation matches "+        ++ prettyTermSrc witness+    )+    "add an equation for the missing case, or a catch-all variable/wildcard pattern"++instance Display (Diagnostic DesugarError) where+  displayMsg (Diagnostic lbl (AnnP err loc origin)) =+    displayMsgWithSrcLoc+      (desugarErrorCode err)+      SevError+      (desugarErrorMsg err)+      loc+      (fmap T.unpack lbl)+      (Just (prettyPExprSrc origin))++desugarErrorMsg :: DesugarError -> String+desugarErrorMsg (UnexpectedBodyExpr e) =+  withHint+    ("This expression is not valid in a rule body: " ++ prettyTermSrc (R.exprToTerm e))+    ( "rule bodies may contain constraints, function calls,"+        ++ " unifications (=), 'is' expressions, and 'true'"+    )+desugarErrorMsg (NonBooleanGuard e) =+  withHint+    ( "This expression cannot evaluate to a boolean and is not valid as a guard: "+        ++ prettyTermSrc (R.exprToTerm e)+    )+    ( "guards must be function calls, boolean-typed variables,"+        ++ " true/false, or a host call returning a boolean"+    )+desugarErrorMsg (NonPreludeFunctionBodyItem e) =+  withHint+    ( "This expression is not valid before the final return value in a"+        ++ " function body: "+        ++ prettyTermSrc (R.exprToTerm e)+    )+    ( "non-final items must be an 'is' binding (X is E), a host call"+        ++ " (host:f(args)), or a function call"+    )+desugarErrorMsg (NonVariableIsInFunctionBody e) =+  withHint+    ( "The left-hand side of 'is' in a function body must be a variable: "+        ++ prettyTermSrc (R.exprToTerm e)+    )+    "use 'X is E' to bind, then pattern-match on X in subsequent positions"++instance Display (Diagnostic CompileError) where+  displayMsg (Diagnostic lbl (AnnP err loc origin)) =+    displayMsgWithSrcLoc+      (compileErrorCode err)+      SevError+      (compileErrorMsg err)+      loc+      (fmap T.unpack lbl)+      (Just (prettyPExprSrc origin))++compileErrorMsg :: CompileError -> String+compileErrorMsg (UnknownConstraintType name) =+  withHint+    ("Unknown constraint type '" ++ displayName name ++ "'")+    "declare it with :- chr_constraint name/arity"+compileErrorMsg (UnboundVariable var) =+  withHint+    ("Unbound variable '" ++ T.unpack var ++ "'")+    "variables used in a guard or body must also appear in the rule head"++instance Display (Diagnostic TypeCheckError) where+  displayMsg (Diagnostic lbl (AnnP err loc origin)) =+    displayMsgWithSrcLoc+      (typeCheckErrorCode err)+      SevError+      (typeCheckErrorMsg err)+      loc+      (fmap T.unpack lbl)+      (Just (prettyPExprSrc origin))++typeCheckErrorMsg :: TypeCheckError -> String+typeCheckErrorMsg (InconsistentTypes t1 t2) =+  "Type mismatch: '" ++ T.unpack t1 ++ "' does not match '" ++ T.unpack t2 ++ "'"+typeCheckErrorMsg (UnboundTypeVar typeName conName varName) =+  withHint+    ( "Type variable '"+        ++ T.unpack varName+        ++ "' used in constructor '"+        ++ T.unpack conName+        ++ "' is not in scope"+    )+    ( "add '"+        ++ T.unpack varName+        ++ "' to the parameter list of type '"+        ++ T.unpack typeName+        ++ "'"+    )+typeCheckErrorMsg (NoMatchingOverload name) =+  withHint+    ("No matching type declaration for '" ++ T.unpack name ++ "'")+    "check that the argument types match one of the declared signatures"+typeCheckErrorMsg (UndefinedType typeName conName refName) =+  withHint+    ( "Undefined type '"+        ++ T.unpack refName+        ++ "' referenced in constructor '"+        ++ T.unpack conName+        ++ "' of type '"+        ++ T.unpack typeName+        ++ "'"+    )+    "declare it with :- chr_type, or check the spelling"+typeCheckErrorMsg (DuplicateConstructor conName decls) =+  "Data constructor '"+    ++ T.unpack conName+    ++ "' is declared in multiple types: "+    ++ intercalate ", " [T.unpack t ++ "/" ++ show a | (t, a) <- decls]+typeCheckErrorMsg (ConstructorArityMismatch conName usedArity declaredArity) =+  "Data constructor '"+    ++ T.unpack conName+    ++ "' is used with "+    ++ show usedArity+    ++ " argument(s) but declared with "+    ++ show declaredArity+typeCheckErrorMsg (BoundUnsatisfied boundName) =+  withHint+    ( "No declared signature of '"+        ++ T.unpack boundName+        ++ "' is consistent with the substituted bound at this use site"+    )+    ( "either widen the bound function's overload set or call the bounded"+        ++ " operation at a type for which a signature exists"+    )++displayName :: Types.Name -> String+displayName (Types.Unqualified n) = T.unpack n+displayName (Types.Qualified m n) = T.unpack m ++ ":" ++ T.unpack n++-- | Display a single parse error using our 'displayMsgWithSrcLoc' format.+displayParseError :: PE.ParseError -> String+displayParseError err =+  let loc = sourceLocFromPos (PE.errorPos err)+      -- parsec's @show@ on 'ParseError' prepends a line such as+      -- @\"file\" (line N, column M):@ before the actual messages.+      -- Our 'displayMsgWithSrcLoc' renders the location itself, so+      -- strip parsec's prefix to avoid duplication.+      raw = show err+      msg = case dropWhile (/= '\n') raw of+        ('\n' : rest) -> dropWhile (== '\n') rest+        other -> other+   in displayMsgWithSrcLoc parseErrorCode SevError msg loc Nothing Nothing++instance Display Warning where+  displayMsg (RenameWarnings ws) = displayErrors (map displayMsg ws)+  displayMsg (ExhaustivenessWarnings ws) = displayErrors (map displayMsg ws)++instance Display Error where+  displayMsg (ParseError _ err) = displayParseError err+  displayMsg (ParseValidationErrors errs) = displayErrors (map displayMsg errs)+  displayMsg (CollectErrors errs) = displayErrors (map displayMsg errs)+  displayMsg (RenameErrors errs) = displayErrors (map displayMsg errs)+  displayMsg (ResolveErrors errs) = displayErrors (map displayMsg errs)+  displayMsg (DesugarErrors errs) = displayErrors (map displayMsg errs)+  displayMsg (CompileErrors errs) = displayErrors (map displayMsg errs)+  displayMsg (TypeErrors errs) = displayErrors (map displayMsg errs)+  displayMsg (OperatorConflict (AnnP name loc origin)) =+    displayMsgWithSrcLoc+      operatorConflictCode+      SevError+      ( withHint+          ( "Operator conflict: '"+              ++ T.unpack name+              ++ "' is declared with a different fixity or associativity"+              ++ " than an existing operator"+          )+          ( "re-export the existing declaration instead of redeclaring it,"+              ++ " or rename this one"+          )+      )+      loc+      Nothing+      (Just (prettyPExprSrc origin))+  displayMsg (LambdasInLiveQuery loc origin) =+    displayMsgWithSrcLoc+      lambdasInLiveQueryCode+      SevError+      ( withHint+          ( "Anonymous lambdas (fun(...) -> ... end) are not supported"+              ++ " in live REPL sessions"+          )+          ( "lift the lambda into a named :- function declaration in a file"+              ++ " and reload the session"+          )+      )+      loc+      (Just "live session")+      (Just (prettyPExprSrc origin))+  displayMsg (GoalNotAConstraint c reason) =+    displayMsgWithSrcLoc+      goalNotAConstraintCode+      SevError+      ( withHint+          ( case reason of+              NoSuchConstraint ->+                "Goal '" ++ nameArity ++ "' is not a declared constraint"+              AmbiguousConstraint ms ->+                "Goal '"+                  ++ nameArity+                  ++ "' is ambiguous: exported by "+                  ++ intercalate ", " (map T.unpack ms)+              ConstraintNotExported qn ->+                "Goal '"+                  ++ T.unpack (Types.flattenName (Types.qualifiedToName qn))+                  ++ "/"+                  ++ show (length c.args)+                  ++ "' is not exported by its module"+              NotAConstraintItem qn ->+                "Goal '"+                  ++ T.unpack (Types.flattenName (Types.qualifiedToName qn))+                  ++ "/"+                  ++ show (length c.args)+                  ++ "' names a function, not a constraint"+          )+          ( "`ychr run -g GOAL` accepts only a single declared constraint."+              ++ " For expression goals like `1 + 1` or `X is E`,"+              ++ " conjunctions like `a, b`, or function calls,"+              ++ " use `ychr repl` instead — or wrap them in a helper constraint."+          )+      )+      P.dummyLoc+      (Just "<query>")+      Nothing+    where+      nameArity = T.unpack (Types.flattenName c.name) ++ "/" ++ show (length c.args)+  displayMsg (RuntimeError msg stack) = displayErrors (renderFrames msg stack)+    where+      -- An empty stack means the error fired before any 'PushFrame'; we+      -- still produce a runtime-error block, just anchored at 'dummyLoc'.+      renderFrames m [] =+        [displayMsgWithSrcLoc runtimeErrorCode SevRuntimeError m P.dummyLoc Nothing Nothing]+      renderFrames m (top : rest) = renderTop top m : map renderRest rest+      renderTop frame m =+        displayMsgWithSrcLoc+          runtimeErrorCode+          SevRuntimeError+          m+          frame.frameSourceLoc+          (Just (T.unpack frame.frameLabel))+          (Just (T.unpack frame.frameSourceCode))+      renderRest frame =+        displayMsgWithSrcLoc+          runtimeErrorCode+          SevStackTrace+          ""+          frame.frameSourceLoc+          (Just (T.unpack frame.frameLabel))+          (Just (T.unpack frame.frameSourceCode))
+ src/YCHR/Internal/Exhaustiveness.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Exhaustiveness checking for user-defined functions.+--+-- Warns when a function's pattern-matching equations cannot match some+-- value of a declared algebraic type. The check is type-directed and+-- deliberately narrow:+--+--   * Only /functions/ are checked, never rules.+--+--   * Only positions whose declared type is a declared /algebraic/ type+--     (@:- chr_type t ---> c1 ; c2 ; …@) contribute. Positions of+--     @int@\/@float@\/@string@\/opaque\/type-variable\/@any@\/unknown+--     type can't be enumerated, so they are treated as always covered+--     and are never the source of a warning.+--+--   * Only /closed/, /single-signature/ functions are checked. Open+--     functions/classes may gain equations in modules outside the+--     compilation unit (so a local gap might be filled elsewhere), and+--     multi-signature classes have ambiguous column types.+--+--   * An equation carrying a user guard does not count as covering its+--     pattern: the guard may fail at runtime, so the pattern is not+--     guaranteed handled.+--+-- The core is Maranget's matrix/usefulness algorithm+-- (<http://moscova.inria.fr/~maranget/papers/warn/index.html>),+-- restricted so that only algebraic columns have an enumerable+-- constructor signature. It handles multi-argument functions and+-- nested constructor patterns uniformly, and produces a witness — an+-- example unmatched call — for the warning message.+module YCHR.Internal.Exhaustiveness+  ( ExhaustivenessWarning (..),+    checkExhaustiveness,+  )+where++import Data.List (find)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (listToMaybe, mapMaybe)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import YCHR.Internal.Constructors (ConEnv, buildConEnv, canonicalizeCon, lookupCon)+import YCHR.Internal.Diagnostic (Diagnostic (..))+import YCHR.Internal.Parsed (AnnP (..))+import YCHR.Internal.Resolved qualified as R+import YCHR.Internal.Types+  ( DataConstructor (..),+    Name,+    Term (..),+    TypeDefinition (..),+    TypeExpr (..),+    TypeKind (..),+    flattenName,+    qualifiedToName,+  )++-- | A non-exhaustive function definition. Carries the function's+-- display name (e.g. @"M:f/2"@) and a witness call (e.g. @f(_, blue)@)+-- that no equation matches.+data ExhaustivenessWarning+  = NonExhaustiveMatch Text Term+  deriving (Eq, Show)++-- | A pattern reduced to what matters for exhaustiveness. Variables,+-- wildcards, and every position of a non-algebraic type collapse to+-- 'PWild'; only constructors of a declared algebraic type survive as+-- 'PCon'.+data Pat+  = PWild+  | PCon Name [Pat]+  deriving (Eq, Show)++-- | The type of a matrix column: an algebraic type with its full+-- constructor set, or anything non-enumerable.+data ColType+  = AlgCol [DataConstructor]+  | OtherCol++-- ---------------------------------------------------------------------------+-- Entry point+-- ---------------------------------------------------------------------------++-- | Check every function in a resolved program for exhaustiveness.+checkExhaustiveness :: R.Program -> [Diagnostic ExhaustivenessWarning]+checkExhaustiveness prog =+  let conEnv = buildConEnv prog.typeDefinitions+      typeMap = Map.fromList [(td.name, td) | td <- prog.typeDefinitions]+   in concatMap (checkFunction conEnv typeMap) prog.functions++-- | Check a single function definition. Returns at most one warning.+-- Skips open functions, untyped or multi-signature functions, and+-- functions with no equations.+checkFunction ::+  ConEnv ->+  Map Name TypeDefinition ->+  R.FunctionDef ->+  [Diagnostic ExhaustivenessWarning]+checkFunction conEnv typeMap fd+  | fd.isOpen = []+  | [sig] <- fd.signatures,+    AnnP _ loc origin : _ <- fd.equations =+      let (argTys, _) = sig+          classify = colTypeOf conEnv typeMap+          colTypes = map classify argTys+          -- Only equations without a user guard count as covering.+          matrix =+            [ zipWith (termToPat conEnv typeMap) colTypes eq.args+            | AnnP eq _ _ <- fd.equations,+              null eq.guard.node+            ]+       in case findMissing classify colTypes matrix of+            -- Only warn when the witness commits to a concrete constructor:+            -- a 'PCon' can only come from an uncovered /algebraic/ column,+            -- so its presence is what makes the gap attributable to a+            -- declared algebraic type. An all-wildcard witness means the+            -- non-exhaustiveness stems entirely from non-enumerable columns+            -- (e.g. an @int@ argument with no catch-all, or a function whose+            -- every equation is guarded), which we deliberately do not flag.+            Just witness+              | any hasCon witness ->+                  let warning = NonExhaustiveMatch displayName (witnessCall fd witness)+                   in [Diagnostic (Just label) (AnnP warning loc origin)]+            _ -> []+  | otherwise = []+  where+    displayName = flattenName (qualifiedToName fd.name) <> "/" <> T.pack (show fd.arity)+    label = "function " <> displayName++-- | Build the witness call term @f(w1, …, wn)@ from a witness pattern+-- vector. The functor is the function's unqualified base name so the+-- rendering reads like a source call.+witnessCall :: R.FunctionDef -> [Pat] -> Term+witnessCall fd witness =+  CompoundTerm (qualifiedToName fd.name) (map patToTerm witness)++patToTerm :: Pat -> Term+patToTerm PWild = Wildcard+patToTerm (PCon name sub) = CompoundTerm name (map patToTerm sub)++-- | Whether a witness pattern contains a constructor anywhere. A 'PCon'+-- only ever originates from an uncovered algebraic column, so this is+-- the test for "this gap is attributable to a declared algebraic type".+hasCon :: Pat -> Bool+hasCon PWild = False+hasCon (PCon _ _) = True++-- ---------------------------------------------------------------------------+-- Type-directed pattern reduction+-- ---------------------------------------------------------------------------++-- | Classify a declared type expression. Only a 'TypeCon' naming a+-- declared algebraic type is enumerable; everything else (type+-- variables, built-in @int@\/@float@\/@string@, opaque types, unknown+-- names) is 'OtherCol'.+colTypeOf :: ConEnv -> Map Name TypeDefinition -> TypeExpr -> ColType+colTypeOf _ typeMap (TypeCon name _) =+  case Map.lookup name typeMap of+    Just td -> case td.kind of+      Algebraic cs -> AlgCol cs+      Opaque -> OtherCol+    Nothing -> OtherCol+colTypeOf _ _ (TypeVar _) = OtherCol++-- | Reduce a pattern term against the declared type of its position.+-- Constructors of the position's algebraic type survive (recursing into+-- their fields with the field types); everything else collapses to+-- 'PWild'. A constructor that does not belong to the expected type+-- (only possible in a type-incorrect program, diagnosed elsewhere) is+-- treated conservatively as 'PWild' so it cannot manufacture a spurious+-- warning.+termToPat :: ConEnv -> Map Name TypeDefinition -> ColType -> Term -> Pat+termToPat _ _ OtherCol _ = PWild+termToPat conEnv typeMap (AlgCol cs) term = case term of+  CompoundTerm name sub ->+    let canonical = canonicalizeCon conEnv name+     in case lookupCon conEnv canonical of+          Just (_, dc)+            -- The constructor must belong to this position's type and be+            -- applied at its declared arity; otherwise the program is+            -- type-incorrect (diagnosed elsewhere) and we stay+            -- conservative with a wildcard.+            | dc.conName `elem` [c.conName | c <- cs],+              length sub == length dc.conArgs ->+                PCon dc.conName (zipWith subPat dc.conArgs sub)+          _ -> PWild+  _ -> PWild+  where+    subPat ty = termToPat conEnv typeMap (colTypeOf conEnv typeMap ty)++-- ---------------------------------------------------------------------------+-- Maranget usefulness / missing-pattern search+-- ---------------------------------------------------------------------------++-- | Search for a witness vector that no row of the matrix matches, given+-- the column types. 'Nothing' means the matrix is exhaustive. The+-- @classify@ argument turns a constructor's field types into column+-- types when specializing, so nested patterns are checked with the same+-- type-directed restriction as the top level.+--+-- This is the usefulness of the all-wildcard vector against the matrix,+-- specialized to return a concrete witness. The three cases follow+-- Maranget: no columns left, an algebraic column with a complete+-- constructor signature, and an incomplete/non-enumerable column.+findMissing :: (TypeExpr -> ColType) -> [ColType] -> [[Pat]] -> Maybe [Pat]+findMissing _ [] matrix+  | null matrix = Just [] -- nothing matches the empty value vector+  | otherwise = Nothing -- some row matches it+findMissing classify (t : ts) matrix =+  let present = Set.fromList [c | (PCon c _ : _) <- matrix]+   in case completeSignature t present of+        Just ctors ->+          -- Complete signature: a witness must commit to one constructor.+          listToMaybe (mapMaybe (specializeWitness classify ts matrix) ctors)+        Nothing ->+          -- Incomplete (or non-enumerable): defaulting suffices, and the+          -- witness fills this column with a missing constructor (or a+          -- wildcard when the type is non-enumerable).+          (missingHead t present :) <$> findMissing classify ts (defaultMatrix matrix)++-- | When the column type is algebraic and every one of its constructors+-- appears at the head of the column, return that constructor set;+-- otherwise 'Nothing' (incomplete, or non-enumerable).+completeSignature :: ColType -> Set Name -> Maybe [DataConstructor]+completeSignature OtherCol _ = Nothing+completeSignature (AlgCol ctors) present+  | all (\dc -> dc.conName `Set.member` present) ctors = Just ctors+  | otherwise = Nothing++-- | Recurse into one constructor of a complete signature, rebuilding the+-- witness head if the specialized matrix is non-exhaustive. The+-- constructor's field types become the new leading columns, classified+-- through @classify@ so nested algebraic fields are themselves checked.+specializeWitness ::+  (TypeExpr -> ColType) -> [ColType] -> [[Pat]] -> DataConstructor -> Maybe [Pat]+specializeWitness classify ts matrix dc =+  let argTypes = map classify dc.conArgs+      n = length dc.conArgs+   in case findMissing classify (argTypes ++ ts) (specialize dc matrix) of+        Nothing -> Nothing+        Just w -> Just (PCon dc.conName (take n w) : drop n w)++-- | The witness pattern for an incomplete column: a constructor not+-- present (applied to wildcards) for an algebraic type, or a wildcard+-- for a non-enumerable type.+missingHead :: ColType -> Set Name -> Pat+missingHead OtherCol _ = PWild+missingHead (AlgCol ctors) present =+  case find (\dc -> not (dc.conName `Set.member` present)) ctors of+    Just dc -> PCon dc.conName (replicate (length dc.conArgs) PWild)+    Nothing -> PWild -- unreachable: incomplete implies a missing ctor++-- | Specialize the matrix on a constructor: rows headed by that+-- constructor expose its sub-patterns; rows headed by a wildcard+-- contribute wildcards for its fields; other constructor rows are+-- dropped.+specialize :: DataConstructor -> [[Pat]] -> [[Pat]]+specialize dc = mapMaybe row+  where+    n = length dc.conArgs+    row (PCon c args : rest)+      | c == dc.conName = Just (args ++ rest)+      | otherwise = Nothing+    row (PWild : rest) = Just (replicate n PWild ++ rest)+    row [] = Nothing++-- | The default matrix: rows headed by a wildcard, with that head+-- dropped. Constructor-headed rows are dropped.+defaultMatrix :: [[Pat]] -> [[Pat]]+defaultMatrix = mapMaybe row+  where+    row (PWild : rest) = Just rest+    row (PCon _ _ : _) = Nothing+    row [] = Nothing
+ src/YCHR/Internal/Loc.hs view
@@ -0,0 +1,31 @@+-- | Source location types shared across all AST representations.+module YCHR.Internal.Loc+  ( SourceLoc (..),+    Ann (..),+    noAnn,+    dummyLoc,+  )+where++-- | A source file location (file, line, column).+data SourceLoc = SourceLoc+  { file :: String,+    line :: Int,+    col :: Int+  }+  deriving (Show, Eq)++-- | A value annotated with a source location.+data Ann a = Ann+  { node :: a,+    sourceLoc :: SourceLoc+  }+  deriving (Show, Eq, Functor, Foldable, Traversable)++-- | A dummy source location for programmatically-constructed nodes.+dummyLoc :: SourceLoc+dummyLoc = SourceLoc "<generated>" 1 1++-- | Wrap a value with a dummy source location.+noAnn :: a -> Ann a+noAnn x = Ann x dummyLoc
+ src/YCHR/Internal/Meta.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Meta-level host call registry.+--+-- Provides host functions that require access to modules outside the+-- interpreter, such as the pretty-printer and @read_term_from_string@.+module YCHR.Internal.Meta+  ( metaHostCallRegistry,+    valueToTerm,+    termToValue,+  )+where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict (StateT, evalStateT, gets, modify')+import Data.Char (chr)+import Data.Foldable (toList)+import Data.Map.Strict qualified as Map+import Data.Text (Text, pack)+import Data.Text qualified as T+import Numeric (readHex)+import YCHR.Internal.Parser (builtinOps, parseTermWith)+import YCHR.Internal.Pretty (prettyTerm)+import YCHR.Internal.Runtime.Monad (Chr)+import YCHR.Internal.Runtime.Registry (HostCallFn (..), HostCallRegistry, unit, valueList)+import YCHR.Internal.Runtime.Store (Suspension (..), getAllStoredConstraints, isSuspAlive)+import YCHR.Internal.Runtime.Types (Value (..), VarId)+import YCHR.Internal.Runtime.Var (deref, getVarId, newVar)+import YCHR.Internal.Types (Term (..), flattenName)+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM (Name (..))++-- | Convert a runtime 'Value' to a surface 'Term', dereferencing logical+-- variables. An unbound variable is rendered as 'VarTerm' carrying the+-- alias name from the supplied map (looked up by 'VarId'), or as+-- 'Wildcard' when the variable has no alias.+valueToTerm :: Map.Map VarId Text -> Value -> Chr Term+valueToTerm aliases v = do+  v' <- deref v+  case v' of+    VInt n -> pure (IntTerm n)+    VFloat n -> pure (FloatTerm n)+    VText s -> pure (TextTerm s)+    VBool True -> pure (CompoundTerm (Types.Unqualified "true") [])+    VBool False -> pure (CompoundTerm (Types.Unqualified "false") [])+    VWildcard -> pure Wildcard+    -- 'VAtom' is the runtime form of every 0-arity value (atoms and+    -- declared 0-arity ctors collapse to it; see 'Compile.compileTerm').+    -- Recover the surface name from the mangled functor produced by+    -- 'Compile.Names.vmName': @encodeText m <> "__" <> encodeText n@+    -- for qualified names, @encodeText n@ for unqualified.+    VAtom s -> pure (decodeName s [])+    VTerm "prelude__." ts ->+      CompoundTerm (Types.Unqualified ".") <$> traverse (valueToTerm aliases) ts+    VTerm f ts -> do+      ts' <- traverse (valueToTerm aliases) ts+      pure (decodeName f ts')+    VVar _ -> do+      mvid <- getVarId v'+      case mvid >>= (`Map.lookup` aliases) of+        Just name -> pure (VarTerm name)+        Nothing -> pure Wildcard++-- | Build a 'CompoundTerm' from a mangled functor text and already-decoded+-- argument terms. Splits @s@ into module/base parts (when present) using+-- 'decodeMangled' and turns each @%%u\<6 hex digits\>@ unicode escape+-- back into its source character.+decodeName :: Text -> [Term] -> Term+decodeName s args = case decodeMangled s of+  Just (m, n) ->+    CompoundTerm (Types.Qualified (decodeEscapes m) (decodeEscapes n)) args+  Nothing -> CompoundTerm (Types.Unqualified (decodeEscapes s)) args++-- | Inverse of 'Compile.Names.vmName'. Returns @Just (mod, base)@ when+-- the input is a qualified mangled name, @Nothing@ when it is+-- unqualified.+--+-- The encoding @encodeText m \<\> "__" \<\> encodeText n@ is injective+-- because 'encodeText' never emits @__@ in its output (non-ASCII chars+-- use the @%%u\<6 hex\>@ marker instead) and the lexer rejects @__@+-- in source. So the only @__@ in the mangled form is the module/base+-- separator — finding it is a single 'T.breakOn' away.+--+-- A leading @__@ (e.g. compiler-internal @__lambda_3@) yields an empty+-- module prefix, which the caller treats as unqualified.+decodeMangled :: Text -> Maybe (Text, Text)+decodeMangled s = case T.breakOn "__" s of+  (_, rest) | T.null rest -> Nothing+  (m, _) | T.null m -> Nothing+  (m, rest) -> Just (m, T.drop 2 rest)++-- | Replace every @%%u\<6 hex digits\>@ escape in @s@ with the+-- corresponding character (inverse of 'Compile.Names.encodeText''s+-- non-ASCII case). 'encodeText' emits exactly six lowercase hex+-- digits per escape and never any closing delimiter; the decoder+-- mirrors that.+decodeEscapes :: Text -> Text+decodeEscapes = T.pack . go . T.unpack+  where+    go [] = []+    go ('%' : '%' : 'u' : a : b : c : d : e : f : rest)+      | all isLowerHexDigit hex,+        [(code, "")] <- readHex hex,+        isValidCodePoint code =+          chr code : go rest+      where+        hex = [a, b, c, d, e, f]+    go (c : cs) = c : go cs++    -- A valid Unicode scalar value is in [0, 0x10FFFF] and not in the+    -- surrogate range [0xD800, 0xDFFF]. 'encodeText' only emits scalar+    -- values, so a malformed input outside this range falls through+    -- as a literal char sequence instead of crashing 'chr'.+    isValidCodePoint code =+      code <= 0x10FFFF && not (code >= 0xD800 && code <= 0xDFFF)++isLowerHexDigit :: Char -> Bool+isLowerHexDigit c = (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f')++-- | Pretty-print a 'Value' using the surface pretty-printer.+-- Dereferences logical variables before rendering. Runs inside 'Chr'+-- because dereferencing reads variable state from the session.+prettyValue :: Value -> Chr String+prettyValue v = prettyTerm <$> valueToTerm Map.empty v++-- | Convert a parsed 'Term' to a runtime 'Value', creating fresh logical+-- variables. The same variable name within a term maps to the same fresh+-- variable (tracked via 'StateT').+termToValue :: Term -> StateT (Map.Map Text Value) Chr Value+termToValue (VarTerm name) = do+  existing <- gets (Map.lookup name)+  case existing of+    Just v -> pure v+    Nothing -> do+      v <- lift newVar+      modify' (Map.insert name v)+      pure v+termToValue (IntTerm n) = pure (VInt n)+termToValue (FloatTerm n) = pure (VFloat n)+termToValue (TextTerm s) = pure (VText s)+termToValue Wildcard = pure VWildcard+termToValue (CompoundTerm name []) = pure (VAtom (flattenName name))+termToValue (CompoundTerm name args) = do+  args' <- traverse termToValue args+  pure (VTerm (flattenName name) args')++-- | Host call registry providing meta-level operations that depend on+-- modules outside the interpreter (e.g. the pretty-printer).+metaHostCallRegistry :: HostCallRegistry+metaHostCallRegistry =+  Map.fromList+    [ ( Name "print",+        HostCallFn $ \args -> do+          strs <- mapM prettyValue args+          liftIO (mapM_ putStrLn strs)+          pure unit+      ),+      ( Name "write_term_to_string",+        HostCallFn $ \case+          [arg] -> do+            s <- prettyValue arg+            pure (VText (pack s))+          _ -> error "write_term_to_string: expected 1 argument"+      ),+      ( Name "read_term_from_string",+        HostCallFn $ \case+          [VText s] ->+            case parseTermWith builtinOps "<read_term_from_string>" s of+              Left err -> error $ "read_term_from_string: " ++ show err+              Right term -> evalStateT (termToValue term) Map.empty+          _ -> error "read_term_from_string: expected 1 Text argument"+      ),+      ( Name "print_store",+        HostCallFn $ \_ -> do+          groups <- getAllStoredConstraints+          lines_ <- concat <$> traverse renderGroup groups+          liftIO (mapM_ putStrLn lines_)+          pure unit+      ),+      ( Name "write_store_to_list",+        HostCallFn $ \_ -> do+          groups <- getAllStoredConstraints+          susps <- concat <$> traverse suspsOfGroup groups+          pure (valueList susps)+      )+    ]+  where+    renderGroup (tyName, susps) =+      fmap concat . traverse (renderSusp tyName) . toList $ susps+    renderSusp tyName susp@Suspension {args = sargs} = do+      alive <- isSuspAlive susp+      if not alive+        then pure []+        else do+          argTerms <- traverse (valueToTerm Map.empty) sargs+          pure [prettyTerm (CompoundTerm tyName argTerms)]+    suspsOfGroup (tyName, susps) =+      fmap concat . traverse (suspAsValue tyName) . toList $ susps+    suspAsValue tyName susp@Suspension {args = sargs} = do+      alive <- isSuspAlive susp+      if not alive+        then pure []+        else do+          args' <- traverse deepDeref sargs+          pure [constraintAsValue tyName args']+    constraintAsValue (Types.Unqualified t) args' = VTerm t args'+    constraintAsValue (Types.Qualified m f) args' =+      VTerm ":" [VAtom m, VTerm f args']+    deepDeref v = do+      v' <- deref v+      case v' of+        VTerm f xs -> VTerm f <$> traverse deepDeref xs+        _ -> pure v'
+ src/YCHR/Internal/PExpr.hs view
@@ -0,0 +1,880 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Generic Prolog-like term parser.+--+-- Parses source text into a flat list of dot-terminated, source-annotated+-- terms. Operators are handled via a configurable operator table.+--+-- This module is self-contained: it defines its own 'PExpr' and 'OpTable'+-- types independently of 'YCHR.Internal.Parser'.+--+-- @+-- % Line comments+-- f(X, Y).+-- X + Y * Z.+-- [a, b | T].+-- @+module YCHR.Internal.PExpr+  ( -- * Prolog expressions+    PExpr (..),++    -- * Operator table+    OpTable (..),+    OpType (..),+    mkOpTable,+    mergeOps,+    opTableEntries,+    isInfix,+    isPrefix,+    isPostfix,++    -- * Precedence constants+    maxPrec,+    maxArgPrec,++    -- * Parsing+    parseTerms,+    parseTerm,+    parseTermNoDot,+    parseFirstTerm,+    parseLeadingTerms,++    -- * Pretty-printing+    prettyPExpr,+    renderAtom,+  )+where++import Control.Applicative (some)+import Control.Monad (foldM, void)+import Data.Char (isAlphaNum, isLower)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.List (intercalate, nub)+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 Text.Parsec+  ( ParseError,+    Parsec,+    SourcePos,+    between,+    choice,+    eof,+    getInput,+    getPosition,+    lookAhead,+    many,+    notFollowedBy,+    option,+    optionMaybe,+    parse,+    sepBy,+    try,+    (<|>),+  )+import Text.Parsec.Char (alphaNum, anyChar, char, digit, lower, oneOf, satisfy, string, upper)+import Text.Parsec.Pos (sourceColumn, sourceLine, sourceName)+import Text.Parsec.Text ()+import YCHR.Internal.Loc+import YCHR.Internal.Parsing.Lexer qualified as L++-- ---------------------------------------------------------------------------+-- Terms+-- ---------------------------------------------------------------------------++-- | A Prolog-like term.+data PExpr+  = -- | Uppercase variable (e.g. @X@, @Foo@).+    Var Text+  | -- | Integer literal (arbitrary precision).+    Int Integer+  | -- | Floating-point literal.+    Float Double+  | -- | Atom (lowercase identifier or single-quoted string).+    Atom Text+  | -- | Double-quoted string literal.+    Str Text+  | -- | Compound term: functor and annotated arguments.+    -- Operator expressions are also compounds (e.g. @X + Y@ is+    -- @Compound "+" [X, Y]@).+    Compound Text [Ann PExpr]+  | -- | Anonymous variable (@_@).+    Wildcard+  deriving (Show, Eq)++-- ---------------------------------------------------------------------------+-- Operator table+-- ---------------------------------------------------------------------------++-- | Operator associativity and fixity kind, using Prolog specifier notation.+--+-- Infix operators: @xfx@ (non-associative), @xfy@ (right-associative),+-- @yfx@ (left-associative).+-- Prefix operators: @fx@ (non-chaining), @fy@ (chaining).+-- Postfix operators: @xf@ (non-chaining), @yf@ (chaining).+--+-- An @x@ position requires the argument to have strictly lower fixity+-- (tighter binding) than the operator.  A @y@ position allows equal fixity.+data OpType+  = Xfx+  | Xfy+  | Yfx+  | Fx+  | Fy+  | Xf+  | Yf+  deriving (Show, Eq)++-- | Is the operator an infix operator?+isInfix :: OpType -> Bool+isInfix Xfx = True+isInfix Xfy = True+isInfix Yfx = True+isInfix _ = False++-- | Is the operator a prefix operator?+isPrefix :: OpType -> Bool+isPrefix Fx = True+isPrefix Fy = True+isPrefix _ = False++-- | Is the operator a postfix operator?+isPostfix :: OpType -> Bool+isPostfix Xf = True+isPostfix Yf = True+isPostfix _ = False++-- | Operator table: maps fixity level to a list of operators at that level.+--+-- Lower fixity number means higher precedence (tighter binding), following+-- the Prolog convention.+--+-- Dual-role operators (e.g. @-@ as both @fy 200@ and @yfx 500@) are+-- supported: the prefix entry goes in 'prefixByName' and the infix entry+-- in 'infixByName'.+data OpTable = OpTable+  { opsByFixity :: IntMap [(OpType, Text)],+    -- | Precomputed set of non-symbolic operator names, used to reject+    -- them as atoms.+    wordOpSet :: Set Text,+    -- | Prefix operators indexed by name.+    prefixByName :: Map Text (Int, OpType),+    -- | Infix and postfix operators indexed by name.+    infixByName :: Map Text (Int, OpType)+  }+  deriving (Show)++-- | Build an 'OpTable' from a list of @(fixity, operators)@ pairs.+mkOpTable :: [(Int, [(OpType, Text)])] -> OpTable+mkOpTable entries =+  OpTable+    { opsByFixity = IntMap.fromListWith (++) entries,+      wordOpSet =+        Set.fromList+          [ name+          | (_, ops) <- entries,+            (_, name) <- ops,+            not (isSymbolic name)+          ],+      prefixByName =+        Map.fromList+          [ (name, (fix, ty))+          | (fix, ops) <- entries,+            (ty, name) <- ops,+            isPrefix ty+          ],+      infixByName =+        Map.fromList+          [ (name, (fix, ty))+          | (fix, ops) <- entries,+            (ty, name) <- ops,+            isInfix ty || isPostfix ty+          ]+    }++-- | Merge additional operators into an existing table.+-- Returns @Left name@ if an operator conflicts (same name, same category+-- but different fixity or type).  Dual-role operators (prefix + infix)+-- are allowed.+mergeOps :: OpTable -> [(Int, OpType, Text)] -> Either Text OpTable+mergeOps base decls = do+  checkConflicts+  let userEntries =+        [ (fix, [(ty, name)])+        | (fix, ty, name) <- decls+        ]+  pure+    OpTable+      { opsByFixity =+          IntMap.unionWith+            mergeBucket+            base.opsByFixity+            (IntMap.fromListWith mergeBucket userEntries),+        wordOpSet =+          Set.union+            base.wordOpSet+            (Set.fromList [name | (_, _, name) <- decls, not (isSymbolic name)]),+        prefixByName =+          Map.union+            base.prefixByName+            (Map.fromList [(name, (fix, ty)) | (fix, ty, name) <- decls, isPrefix ty]),+        infixByName =+          Map.union+            base.infixByName+            ( Map.fromList+                [(name, (fix, ty)) | (fix, ty, name) <- decls, isInfix ty || isPostfix ty]+            )+      }+  where+    mergeBucket xs ys = nub (xs ++ ys)+    checkConflicts :: Either Text ()+    checkConflicts =+      let -- Check prefix ops for conflicts+          existingPrefix = Map.toList base.prefixByName+          newPrefix = [(name, (fix, ty)) | (fix, ty, name) <- decls, isPrefix ty]+          -- Check infix/postfix ops for conflicts+          existingInfix = Map.toList base.infixByName+          newInfix =+            [(name, (fix, ty)) | (fix, ty, name) <- decls, isInfix ty || isPostfix ty]+          insert (n, ft) acc = case Map.lookup n acc of+            Nothing -> Right (Map.insert n ft acc)+            Just ft' | ft == ft' -> Right acc+            Just _ -> Left n+       in foldM (flip insert) Map.empty (existingPrefix ++ newPrefix)+            *> foldM (flip insert) Map.empty (existingInfix ++ newInfix)+            *> pure ()++-- | List all operator entries as @(fixity, type, name)@ triples.+opTableEntries :: OpTable -> [(Int, OpType, Text)]+opTableEntries table =+  [ (fix, ty, name)+  | (fix, ops) <- IntMap.toList table.opsByFixity,+    (ty, name) <- ops+  ]++-- ---------------------------------------------------------------------------+-- Precedence constants+-- ---------------------------------------------------------------------------++-- | Maximum operator precedence (Prolog standard: 1200).+maxPrec :: Int+maxPrec = 1200++-- | Maximum precedence for compound-term arguments (999).+-- Operators at fixity 1000 or above (like @,@) act as separators inside+-- @f(...)@ and @[...]@ because they exceed this limit.+maxArgPrec :: Int+maxArgPrec = 999++-- ---------------------------------------------------------------------------+-- Internal helpers+-- ---------------------------------------------------------------------------++-- | Check whether a name consists entirely of symbol characters.+isSymbolic :: Text -> Bool+isSymbolic = T.all (`elem` symbolChars)++-- | Characters that can appear in symbol operators.+symbolChars :: [Char]+symbolChars = "\\:=<>+-*/#@^~!&?"++-- ---------------------------------------------------------------------------+-- Parser type+-- ---------------------------------------------------------------------------++type Parser = Parsec Text ()++-- ---------------------------------------------------------------------------+-- Space consumer and lexeme helpers+-- ---------------------------------------------------------------------------++-- | Consume whitespace and @%@ line comments.+sc :: Parser ()+sc = L.space L.space1 (L.skipLineComment "%")++-- | Wrap a parser to consume trailing whitespace.+lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++-- | Parse a fixed string and consume trailing whitespace.+symbol :: Text -> Parser Text+symbol = L.symbol sc++-- | Parse something enclosed in parentheses.+parens :: Parser a -> Parser a+parens = between (symbol "(") (symbol ")")++-- | Parse a comma separator.+comma :: Parser ()+comma = void (symbol ",")++-- ---------------------------------------------------------------------------+-- Source locations+-- ---------------------------------------------------------------------------++-- | Convert a parsec 'SourcePos' to a 'SourceLoc'.+sourceLocFromPos :: SourcePos -> SourceLoc+sourceLocFromPos sp =+  SourceLoc+    { file = sourceName sp,+      line = sourceLine sp,+      col = sourceColumn sp+    }++-- | Wrap a parser's result with the source location of its first character.+withLoc :: Parser a -> Parser (Ann a)+withLoc p = do+  sp <- getPosition+  x <- p+  pure (Ann x (sourceLocFromPos sp))++-- ---------------------------------------------------------------------------+-- Atoms, variables, wildcards, integers+-- ---------------------------------------------------------------------------++-- | Parse an atom: a lowercase identifier or a single-quoted string.+--+-- Rejects identifiers that are prefix word operators (e.g.+-- @chr_constraint@, @function@) so that the Pratt parser can handle+-- them.  Infix-only word operators (e.g. @div@, @mod@, @is@) are+-- allowed as atoms, following standard Prolog behaviour.+atomP :: OpTable -> Parser Text+atomP table = lexeme (unquotedP <|> quotedAtomP)+  where+    unquotedP = do+      t <- identifierP+      -- Reject only word operators that are prefix operators.+      -- Infix-only word operators (like div, mod) are valid atoms.+      if Set.member t table.wordOpSet && Map.member t table.prefixByName+        then fail ("reserved word: " ++ T.unpack t)+        else pure t++-- | Parse an unquoted lowercase identifier.  Does not reject word operators+-- or double underscores — callers are responsible for validation.+--+-- Unquoted identifiers cannot contain @%@ (it's not in 'alphaNum' or+-- @_@), so the reserved @%%u@ unicode-escape marker can only sneak in+-- via 'quotedAtomP' — which checks for it.+identifierP :: Parser Text+identifierP = do+  name <- (:) <$> lower <*> many (alphaNum <|> char '_')+  let t = T.pack name+  if "__" `T.isInfixOf` t+    then fail "double underscore (__) is not allowed in atoms"+    else pure t++-- | Parse a single-quoted atom (e.g. @\'hello world\'@).+--+-- Two infixes are reserved and rejected: @__@ (the qualified-name+-- separator) and @%%u@ (the unicode-escape marker used by+-- 'YCHR.Internal.Compile.Names.encodeText'). Source atoms must not contain+-- either, so the encoder's output is unambiguously decodable.+quotedAtomP :: Parser Text+quotedAtomP = do+  t <- T.pack <$> (char '\'' *> go)+  if "__" `T.isInfixOf` t+    then fail "double underscore (__) is not allowed in atoms"+    else+      if "%%u" `T.isInfixOf` t+        then fail "%%u is reserved for unicode escapes and is not allowed in atoms"+        else pure t+  where+    go =+      choice+        [ do+            _ <- char '\''+            choice+              [ char '\'' *> (('\'' :) <$> go),+                pure []+              ],+          do+            _ <- char '\\'+            c <- escapeChar+            (c :) <$> go,+          do+            c <- satisfy (\c -> c /= '\'' && c /= '\\')+            (c :) <$> go+        ]+    escapeChar =+      choice+        [ '\'' <$ char '\'',+          '\\' <$ char '\\',+          '\n' <$ char 'n',+          '\t' <$ char 't',+          anyChar+        ]++-- | Parse a variable or the wildcard.+--+-- Variables start with an uppercase letter or an underscore, then+-- letters, digits, or underscores. The bare @_@ is the wildcard;+-- @_X@, @_Tail@, @__Foo@ are ordinary variables.+varOrWildcardP :: Parser PExpr+varOrWildcardP = lexeme $ do+  c <- upper <|> char '_'+  rest <- many (alphaNum <|> char '_')+  pure $+    if c == '_' && null rest+      then Wildcard+      else Var (T.pack (c : rest))++-- | Parse a number: try float first (requires decimal point), then integer.+numberP :: Parser PExpr+numberP = lexeme $ do+  sign <- optionMaybe (char '-')+  let applySign :: (Num a) => a -> Maybe Char -> a+      applySign x Nothing = x+      applySign x (Just _) = negate x+  try+    ( do+        whole <- L.decimal+        _ <- char '.'+        fracStr <- some digit+        let str = show (whole :: Integer) ++ "." ++ fracStr+            val = read str :: Double+        pure (Float (applySign val sign))+    )+    <|> do+      n <- L.decimal+      pure (Int (applySign n sign))++-- | Parse a decimal integer (optionally negative).+intP :: Parser PExpr+intP = numberP++-- ---------------------------------------------------------------------------+-- Operator tokens+-- ---------------------------------------------------------------------------++-- | Try to parse any operator token.  Tries symbol operators (greedy+-- longest-match), then single-character operators (@,@ and @|@), then+-- word operators.+anyOpToken :: OpTable -> Parser Text+anyOpToken table = lexeme (trySymbol <|> trySingleChar <|> tryWord)+  where+    trySymbol = try $ do+      s <- T.pack <$> some (oneOf symbolChars)+      if Map.member s table.prefixByName || Map.member s table.infixByName+        then pure s+        else fail ("unknown operator: " ++ T.unpack s)+    trySingleChar = try $ do+      c <- oneOf (",|;" :: [Char])+      let name = T.singleton c+      if Map.member name table.prefixByName || Map.member name table.infixByName+        then pure name+        else fail ("not an operator: " ++ [c])+    tryWord = try $ do+      w <- T.pack <$> ((:) <$> lower <*> many (alphaNum <|> char '_'))+      if Set.member w table.wordOpSet+        then w <$ notFollowedBy (alphaNum <|> char '_')+        else fail ("not a word operator: " ++ T.unpack w)++-- ---------------------------------------------------------------------------+-- Terms+-- ---------------------------------------------------------------------------++-- | Parse a double-quoted string literal.+stringP :: Parser PExpr+stringP = lexeme $ Str . T.pack <$> (char '"' *> go)+  where+    go =+      choice+        [ do+            _ <- char '"'+            pure [],+          do+            _ <- char '\\'+            c <- escapeCharDQ+            (c :) <$> go,+          do+            c <- satisfy (\c -> c /= '"' && c /= '\\')+            (c :) <$> go+        ]+    escapeCharDQ =+      choice+        [ '"' <$ char '"',+          '\\' <$ char '\\',+          '\n' <$ char 'n',+          '\t' <$ char 't',+          anyChar+        ]++-- | Parse a list term using Prolog list notation.+-- Desugars to nested @Compound "." [H, T]@ terms, with @Atom "[]"@ for+-- the empty list.+listTermP :: OpTable -> Parser PExpr+listTermP table = between (symbol "[") (symbol "]") listBody+  where+    listBody = do+      elems <- withLoc (termP table maxArgPrec) `sepBy` comma+      tail_ <- option (noAnn (Atom "[]")) (symbol "|" *> withLoc (termP table maxArgPrec))+      pure (foldr (\h t -> Compound "." [h, noAnn t]) (tail_.node) elems)++-- | Parse a lambda expression: @fun(X, Y) -> body end@.+--+-- Produces @Compound "->" [Compound "fun" [X, Y], body]@.+-- The @end@ keyword delimits the body, making the entire lambda an+-- atomic term that works inside compound-term arguments without+-- parentheses.  The body is parsed at 'maxPrec', so any operators+-- (including @,@ and @|@) may appear inside.+--+-- This is syntactic sugar: @fun(X) -> X + 1 end@ desugars to the+-- same representation as @\'->'(fun(X), X + 1)@.+lambdaP :: OpTable -> Parser PExpr+lambdaP table = try $ do+  _ <- lexeme (string "fun" <* notFollowedBy (alphaNum <|> char '_'))+  params <- parens (withLoc (termP table maxArgPrec) `sepBy` comma)+  _ <- symbol "->"+  body <- withLoc (termP table maxPrec)+  _ <- lexeme (string "end" <* notFollowedBy (alphaNum <|> char '_'))+  pure (Compound "->" [noAnn (Compound "fun" params), body])++-- | Parse an atomic (non-operator) term.+atomicTermP :: OpTable -> Parser (Ann PExpr)+atomicTermP table =+  withLoc $+    choice+      [ varOrWildcardP,+        try intP,+        stringP,+        listTermP table,+        lambdaP table,+        try (parens (termP table maxPrec)),+        atomOrCompoundP table+      ]++-- | Parse a term with a maximum allowed fixity.+--+-- Only operators with fixity @<= maxFix@ are consumed.  This is the+-- mechanism that makes @,@ (fixity 1000) act as a separator inside+-- compound-term arguments (parsed at 'maxArgPrec' = 999) while being+-- a real operator at the top level (parsed at 'maxPrec' = 1200).+termP :: OpTable -> Int -> Parser PExpr+termP table maxFix = do+  (lhs, lhsFix) <- nudP table maxFix+  (.node) <$> ledLoop table maxFix lhs lhsFix++-- | Parse a prefix expression or atomic term.+-- Returns @(term, effectiveFixity)@; atomic terms have fixity 0.+nudP :: OpTable -> Int -> Parser (Ann PExpr, Int)+nudP table maxFix = try atomicTerm <|> prefixOp+  where+    atomicTerm = (,0) <$> atomicTermP table+    prefixOp = try $ do+      sp <- getPosition+      name <- anyOpToken table+      case Map.lookup name table.prefixByName of+        Just (fix, ty) | fix <= maxFix -> do+          let operandMax = case ty of+                Fy -> fix -- y position: operand may have equal fixity+                _ -> fix - 1 -- x position (Fx): strictly lower+          operand <- withLoc (termP table operandMax)+          pure (Ann (Compound name [operand]) (sourceLocFromPos sp), fix)+        _ -> fail ("not a prefix operator in this context: " ++ T.unpack name)++-- | Infix\/postfix loop for the Pratt parser.+--+-- Repeatedly tries to consume an infix or postfix operator whose fixity+-- is within the allowed range and whose left-position constraint is+-- satisfied by the current left-hand side.+ledLoop :: OpTable -> Int -> Ann PExpr -> Int -> Parser (Ann PExpr)+ledLoop table maxFix lhs lhsFix = do+  mOp <- optionMaybe (lookAhead (try (anyOpToken table)))+  case mOp of+    Just name+      | Just (fix, ty) <- Map.lookup name table.infixByName,+        fix <= maxFix,+        lhsFix <= leftMax ty fix -> do+          _ <- anyOpToken table -- consume+          case ty of+            _ | isPostfix ty -> do+              let result = Ann (Compound name [lhs]) lhs.sourceLoc+              ledLoop table maxFix result fix+            Yfx -> do+              rhs <- withLoc (termP table (fix - 1))+              let result = Ann (Compound name [lhs, rhs]) lhs.sourceLoc+              ledLoop table maxFix result fix+            Xfy -> do+              rhs <- withLoc (termP table fix)+              let result = Ann (Compound name [lhs, rhs]) lhs.sourceLoc+              ledLoop table maxFix result fix+            _ -> do+              -- Xfx (non-associative)+              rhs <- withLoc (termP table (fix - 1))+              let result = Ann (Compound name [lhs, rhs]) lhs.sourceLoc+              ledLoop table maxFix result fix+    _ -> pure lhs++-- | Maximum allowed fixity for the left argument of an operator.+-- @y@ positions allow equal fixity; @x@ positions require strictly lower.+leftMax :: OpType -> Int -> Int+leftMax Yfx fix = fix+leftMax Yf fix = fix+leftMax _ fix = fix - 1++-- | Parse an atom optionally followed by a parenthesised argument list.+--+-- Word operators are allowed as atoms and functors following standard+-- Prolog behaviour (e.g. @div@ is a valid atom and @div(X, Y)@ is a+-- valid compound even though @div@ is an operator).  Only prefix word+-- operators (e.g. @chr_constraint@) are rejected as bare atoms so that+-- the Pratt parser can handle them — but they are still allowed as+-- functors when followed by @(@.+atomOrCompoundP :: OpTable -> Parser PExpr+atomOrCompoundP table = prefixWordAsFunctor <|> regular+  where+    -- Prefix word operators are rejected by atomP, but we still allow+    -- them as functors when followed by '('.+    prefixWordAsFunctor = try $ do+      name <- lexeme identifierP+      if not (Set.member name table.wordOpSet && Map.member name table.prefixByName)+        then fail "not a prefix word operator"+        else do+          _ <- symbol "("+          args <- withLoc (termP table maxArgPrec) `sepBy` comma+          _ <- symbol ")"+          pure (Compound name args)+    regular = do+      name <- atomP table+      maybeOpen <- optionMaybe (symbol "(")+      case maybeOpen of+        Nothing -> pure (Atom name)+        Just _ -> do+          args <- withLoc (termP table maxArgPrec) `sepBy` comma+          _ <- symbol ")"+          pure (Compound name args)++-- ---------------------------------------------------------------------------+-- Public API+-- ---------------------------------------------------------------------------++-- | Parse dot-terminated Prolog terms from source text.+--+-- Each top-level term must be terminated by a dot (@.@).+-- Returns a list of annotated terms.+--+-- The first argument is the operator table. The second is the source file+-- name (used in error messages only).+parseTerms :: OpTable -> String -> Text -> Either ParseError [Ann PExpr]+parseTerms table = parse (sc *> many (withLoc (termP table maxPrec) <* symbol ".") <* eof)++-- | Parse a single dot-terminated term from source text.+parseTerm :: OpTable -> String -> Text -> Either ParseError (Ann PExpr)+parseTerm table = parse (sc *> withLoc (termP table maxPrec) <* symbol "." <* eof)++-- | Parse a single term from source text (no dot terminator required).+parseTermNoDot :: OpTable -> String -> Text -> Either ParseError (Ann PExpr)+parseTermNoDot table = parse (sc *> withLoc (termP table maxPrec) <* eof)++-- | Parse the first dot-terminated term from source text, ignoring the rest.+-- Returns 'Nothing' if the input is empty or starts with something that is+-- not a valid term with the given operator table.+parseFirstTerm ::+  OpTable ->+  String ->+  Text ->+  Either ParseError (Maybe (Ann PExpr))+parseFirstTerm table =+  parse+    ( sc+        *> optionMaybe+          ( try+              ( withLoc (termP table maxPrec)+                  <* symbol+                    "."+              )+          )+        <* void (many anyChar)+    )++-- | Parse leading dot-terminated terms while they parse with the given+-- operator table; stop at the first term that fails to parse.+--+-- Returns the successfully parsed terms plus, if there is unparseable+-- content remaining, the source location at which parsing stopped.+-- Returns 'Nothing' for the location if the entire input was consumed.+parseLeadingTerms ::+  OpTable ->+  String ->+  Text ->+  Either ParseError ([Ann PExpr], Maybe SourceLoc)+parseLeadingTerms table = parse (sc *> loop [])+  where+    loop acc = do+      mTerm <- optionMaybe (try (withLoc (termP table maxPrec) <* symbol "."))+      case mTerm of+        Just t -> loop (t : acc)+        Nothing -> do+          remaining <- getInput+          if T.null remaining+            then pure (reverse acc, Nothing)+            else do+              sp <- getPosition+              _ <- many anyChar+              pure (reverse acc, Just (sourceLocFromPos sp))++-- ---------------------------------------------------------------------------+-- Pretty-printing+-- ---------------------------------------------------------------------------++-- | Render a 'PExpr' as valid Prolog source text.+--+-- Uses the operator table to decide which compounds to render as infix,+-- prefix, or postfix operators, with minimal parenthesisation based on+-- precedence.+prettyPExpr :: OpTable -> PExpr -> String+prettyPExpr table = prettyPrec table.infixByName table.prefixByName table.wordOpSet maxPrec++-- | Render a PExpr within a precedence context.+--+-- The @ctx@ parameter is the maximum fixity the expression may have without+-- needing parentheses. An operator with fixity > ctx is wrapped in parens.+--+-- Prolog operator argument conventions:+--+--   * @y@ — argument may have equal or lower fixity (same or tighter binding)+--   * @x@ — argument must have strictly lower fixity (strictly tighter)+--+-- So for @yfx@ at fixity F: left gets F, right gets F−1.+-- For @xfy@: left gets F−1, right gets F. Etc.+prettyPrec ::+  Map Text (Int, OpType) ->+  Map+    Text+    ( Int,+      OpType+    ) ->+  Set Text ->+  Int ->+  PExpr ->+  String+prettyPrec _ _ _ _ (Var v) = T.unpack v+prettyPrec _ _ _ _ (Int n)+  | n < 0 = "(" ++ show n ++ ")"+  | otherwise = show n+prettyPrec _ _ _ _ (Float n)+  | n < 0 = "(" ++ showFloat n ++ ")"+  | otherwise = showFloat n+  where+    showFloat x =+      let s = show x+       in if '.' `elem` s then s else s ++ ".0"+prettyPrec _ _ _ _ (Atom "[]") = "[]"+prettyPrec _ _ wops _ (Atom a) = renderAtom wops a+prettyPrec _ _ _ _ (Str s) = renderString s+prettyPrec _ _ _ _ Wildcard = "_"+-- List syntax+prettyPrec iops pops wops _ (Compound "." [h, t]) =+  "[" ++ rec maxArgPrec h.node ++ prettyListTail iops pops wops t.node ++ "]"+  where+    rec = prettyPrec iops pops wops+-- Lambda: fun(X, Y) -> body end+prettyPrec iops pops wops _ (Compound "->" [Ann (Compound "fun" params) _, body]) =+  "fun("+    ++ intercalate ", " [rec maxArgPrec a.node | a <- params]+    ++ ") -> "+    ++ rec maxPrec body.node+    ++ " end"+  where+    rec = prettyPrec iops pops wops+-- Infix operators+prettyPrec iops pops wops ctx (Compound f [l, r])+  | Just (fix, ty) <- Map.lookup f iops,+    isInfix ty =+      let (lCtx, rCtx) = case ty of+            Yfx -> (fix, fix - 1)+            Xfy -> (fix - 1, fix)+            _ -> (fix - 1, fix - 1) -- Xfx+          (lSpace, rSpace)+            | f == ":" = ("", "")+            | f == "," || f == ";" = ("", " ")+            | otherwise = (" ", " ")+          rendered =+            rec lCtx l.node+              ++ lSpace+              ++ T.unpack f+              ++ rSpace+              ++ rec rCtx r.node+       in if fix > ctx then "(" ++ rendered ++ ")" else rendered+  where+    rec = prettyPrec iops pops wops+-- Prefix operators+prettyPrec iops pops wops ctx (Compound f [x])+  | Just (fix, ty) <- Map.lookup f pops,+    isPrefix ty =+      let argCtx = case ty of+            Fy -> fix+            _ -> fix - 1 -- Fx+          rendered = T.unpack f ++ " " ++ rec argCtx x.node+       in if fix > ctx then "(" ++ rendered ++ ")" else rendered+  where+    rec = prettyPrec iops pops wops+-- Postfix operators+prettyPrec iops pops wops ctx (Compound f [x])+  | Just (fix, ty) <- Map.lookup f iops,+    isPostfix ty =+      let argCtx = case ty of+            Yf -> fix+            _ -> fix - 1 -- Xf+          rendered = rec argCtx x.node ++ " " ++ T.unpack f+       in if fix > ctx then "(" ++ rendered ++ ")" else rendered+  where+    rec = prettyPrec iops pops wops+-- Regular compounds+prettyPrec iops pops wops _ (Compound f args) =+  renderAtom wops f+    ++ "("+    ++ intercalate ", " [prettyPrec iops pops wops maxArgPrec a.node | a <- args]+    ++ ")"++prettyListTail ::+  Map Text (Int, OpType) ->+  Map+    Text+    ( Int,+      OpType+    ) ->+  Set Text ->+  PExpr ->+  String+prettyListTail _ _ _ (Atom "[]") = ""+prettyListTail iops pops wops (Compound "." [h, t]) =+  ", " ++ rec h.node ++ prettyListTail iops pops wops t.node+  where+    rec = prettyPrec iops pops wops maxArgPrec+prettyListTail iops pops wops other = " | " ++ prettyPrec iops pops wops maxArgPrec other++-- | True if the atom needs single-quote wrapping.+needsQuoting :: Set Text -> Text -> Bool+needsQuoting wordOps t = case T.uncons t of+  Nothing -> True+  Just (c, cs) ->+    not+      ( isLower c+          && T.all (\x -> isAlphaNum x || x == '_') cs+          && not (Set.member t wordOps)+          && not ("__" `T.isInfixOf` t)+      )++-- | Render an atom, quoting with @\'...\'@ if necessary.+renderAtom :: Set Text -> Text -> String+renderAtom wordOps s+  | needsQuoting wordOps s = "'" ++ concatMap esc (T.unpack s) ++ "'"+  | otherwise = T.unpack s+  where+    esc '\'' = "''"+    esc c = [c]++-- | Render a double-quoted string literal with escape sequences.+renderString :: Text -> String+renderString s = "\"" ++ concatMap esc (T.unpack s) ++ "\""+  where+    esc '"' = "\\\""+    esc '\\' = "\\\\"+    esc '\n' = "\\n"+    esc '\t' = "\\t"+    esc c = [c]
+ src/YCHR/Internal/Parsed.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Surface Language AST+--+-- This module defines the AST that is the direct output of the parser.+-- It represents CHR programs in a form close to the Prolog-compatible+-- surface syntax, before any desugaring or semantic analysis.+--+-- Key differences from the internal AST ('YCHR.Internal.Desugared'):+--+--   * All three rule kinds (simplification, propagation, simpagation)+--     are represented explicitly, not yet desugared to simpagation.+--+--   * Guards and bodies are both lists of 'Term', with no type+--     distinction. The classification of goals into guard-specific+--     and body-specific forms happens during desugaring.+--+--   * Goals are just terms. For example, @X = Y@ is represented as+--     @CompoundTerm "=" [VarTerm "X", VarTerm "Y"]@, and @leq(X, Z)@+--     as @CompoundTerm "leq" [VarTerm "X", VarTerm "Z"]@.+--     The atom @true@ is represented as+--     @CompoundTerm (Unqualified "true") []@.+module YCHR.Internal.Parsed+  ( -- * Source locations+    SourceLoc (..),+    Ann (..),+    noAnn,+    dummyLoc,++    -- * Annotated parsed node+    AnnP (..),+    noAnnP,+    noAnnPAt,++    -- * Program structure+    Module (..),+    Import (..),+    Declaration (..),+    FunctionDeclKind (..),+    OpType (..),+    OpDecl (..),+    Rule (..),+    Head (..),+    FunctionEquation (..),++    -- * Re-exports from YCHR.Internal.Types+    Name (..),+    Constraint (..),+    Term (..),+    TypeDefinition (..),+    TypeKind (..),+    typeConstructors,+    DataConstructor (..),+    TypeExpr (..),+    BoundSig (..),+  )+where++import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import YCHR.Internal.Loc (Ann (..), SourceLoc (..), dummyLoc, noAnn)+import YCHR.Internal.PExpr (OpType (..), PExpr (..))+import YCHR.Internal.Types+  ( BoundSig (..),+    Constraint (..),+    DataConstructor (..),+    Name (..),+    Term (..),+    TypeDefinition (..),+    TypeExpr (..),+    TypeKind (..),+    typeConstructors,+  )++-- | A node annotated with a source location and the original 'PExpr'+-- that produced it.+data AnnP a = AnnP+  { node :: a,+    sourceLoc :: SourceLoc,+    parsed :: PExpr+  }+  deriving (Show, Eq, Functor, Foldable, Traversable)++-- | Wrap a node with a dummy source location and a dummy parsed origin.+-- Useful for constructing values in tests where provenance is irrelevant.+noAnnP :: a -> AnnP a+noAnnP x = AnnP x dummyLoc (Atom "")++-- | Wrap a node with a real source location but a dummy parsed origin.+-- Used by the parser to synthesize annotations (e.g. empty guard lists)+-- that have a meaningful location but no underlying surface 'PExpr'.+noAnnPAt :: SourceLoc -> a -> AnnP a+noAnnPAt loc x = AnnP x loc (Atom "")++data Import+  = ModuleImport Text (Maybe [Declaration])+  | LibraryImport Text (Maybe [Declaration])+  deriving (Show, Eq)++data Module = Module+  { name :: Text,+    -- | Source location of the @:- module(...)@ directive. For+    -- header-less files, or synthetic modules built outside the+    -- parser (DSL, query scaffolding), this is 'dummyLoc'.+    nameLoc :: SourceLoc,+    imports :: [AnnP Import],+    decls :: [Ann Declaration],+    extensionTypes :: [Ann Declaration],+    typeDecls :: [Ann TypeDefinition],+    rules :: [Rule],+    equations :: [AnnP FunctionEquation],+    -- | Equations contributed by @:- extend_function@ directives.+    -- Each must target an @:- open_function@.+    extensions :: [AnnP FunctionEquation],+    -- | Equations contributed by @:- extend_class@ directives.+    -- Each must target an @:- open_class@.+    classExtensions :: [AnnP FunctionEquation],+    exports :: Maybe (AnnP [Declaration])+  }+  deriving (Show, Eq)++-- | Whether a function-like declaration was written with the+-- @:- function@ / @:- open_function@ keyword (single signature+-- only, may carry @requiring@) or the @:- class@ / @:- open_class@+-- keyword (overloaded signatures permitted, never carries+-- @requiring@). The two forms produce the same downstream+-- 'YCHR.Internal.Resolved.FunctionDef'; the kind only affects source-level+-- validation.+data FunctionDeclKind = DKFunction | DKClass+  deriving (Show, Eq)++data Declaration+  = ConstraintDecl+      { name :: Text,+        arity :: Int,+        argTypes :: Maybe [TypeExpr],+        -- | Bounded polymorphism: a non-'Nothing' value carries the+        -- @requiring@ clause's bound signatures. Permitted only on+        -- the typed form of a constraint declaration; the parser+        -- enforces this.+        requiring :: Maybe [BoundSig]+      }+  | FunctionDecl+      { name :: Text,+        arity :: Int,+        argTypes :: Maybe [TypeExpr],+        returnType :: Maybe TypeExpr,+        isOpen :: Bool,+        kind :: FunctionDeclKind,+        -- | Bounded polymorphism: a non-'Nothing' value carries the+        -- @requiring@ clause's bound signatures. Permitted only on+        -- the @:- function@ / @:- open_function@ forms (i.e. with+        -- @kind == DKFunction@). The parser rejects @requiring@ on+        -- @:- class@ / @:- open_class@ declarations.+        requiring :: Maybe [BoundSig]+      }+  | -- | Adds an overloaded type signature to an @:- open_class@+    -- declared in another module. The renamer fills in @target@ with+    -- the class's resolved qualified name. After the rename phase,+    -- @target@ is always @Just (Qualified _ _)@; @Nothing@ only appears+    -- in the freshly-parsed AST, before the renamer has run.+    ExtendClassTypeDecl+      { name :: Text,+        arity :: Int,+        argTypes :: Maybe [TypeExpr],+        returnType :: Maybe TypeExpr,+        target :: Maybe Name+      }+  | OperatorDecl OpDecl+  | -- | A type entry in a module's export or import list, written+    -- @type(T/n)@ or @type(T/n, [Con, ...])@. Covers both algebraic and+    -- opaque types: they share one type namespace, so a single export+    -- form is used. Opaque types have no constructors, so a constructor+    -- allowlist on one is rejected by the usual unknown-constructor+    -- check (@YCHR-20008@).+    TypeExportDecl {name :: Text, arity :: Int, conExports :: Maybe [Text]}+  deriving (Show, Eq)++data OpDecl = OpDecl+  { fixity :: Int,+    opType :: OpType,+    opName :: Text+  }+  deriving (Show, Eq)++data FunctionEquation = FunctionEquation+  { funName :: Name,+    args :: [Term],+    guard :: AnnP [Term],+    rhs :: AnnP (NonEmpty Term)+  }+  deriving (Show, Eq)++data Rule = Rule+  { name :: Maybe (Ann Text),+    head :: AnnP Head,+    guard :: AnnP [Term],+    body :: AnnP [Term]+  }+  deriving (Show, Eq)++data Head+  = Simplification [Constraint]+  | Propagation [Constraint]+  | Simpagation [Constraint] [Constraint]+  deriving (Show, Eq)
+ src/YCHR/Internal/Parser.hs view
@@ -0,0 +1,1408 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Parser for the CHR surface language.+--+-- Parses Prolog-compatible CHR syntax into a 'Module' value.+--+-- Implementation: parses source text to generic 'PExpr' terms first+-- (via 'YCHR.Internal.PExpr'), then converts each term to the surface AST.+--+-- Supported syntax:+--+-- @+-- % Line comments+--+-- :- module(order, [leq\/2]). -- Export list specifies visible constraints.+-- :- use_module(stdlib).+--+-- :- chr_constraint leq\/2.+-- :- chr_constraint fib\/2, upto\/1.+--+-- refl \@ leq(X, X) \<=> true.+-- leq(X, X) \<=> true.+-- trans \@ leq(X, Y), leq(Y, Z) ==> leq(X, Z).+-- a \@ kept \\ removed \<=> guard | body.+--+-- [H|T]     -- list with head H and tail T+-- [a, b, c] -- list literal (sugar for '.'(a,'.'(b,'.'(c,'[]'))))+-- @+module YCHR.Internal.Parser+  ( -- * Public parsing functions+    parseModule,+    parseModuleWith,+    parseConstraint,+    parseConstraintWith,+    parseQuery,+    parseQueryWith,+    parseTerm,+    parseTermWith,+    parseRule,++    -- * Operator tables+    OpTable,+    builtinOps,+    mergeOps,+    opTableEntries,++    -- * Module headers+    ModuleHeader (..),+    collectModuleHeader,+    buildModuleOpTable,+    extractOpDecls,++    -- * Validation errors+    ParseValidationError (..),+  )+where++import Data.Either (partitionEithers)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import System.FilePath (takeBaseName)+import Text.Parsec (ParseError)+import YCHR.Internal.PExpr (PExpr (Atom, Compound, Str, Var))+import YCHR.Internal.PExpr qualified as P+import YCHR.Internal.Parsed++-- * Operator tables++-- | Operator table: maps fixity levels to operators.+-- Re-exported from 'YCHR.Internal.PExpr'.+type OpTable = P.OpTable++-- | Built-in operators for CHR syntax.+--+-- This is a minimal table containing only the operators needed for CHR+-- language structure. Arithmetic and comparison operators are provided+-- by the @builtins@ library.+--+-- Directive keywords (@chr_constraint@, @function@, @chr_type@, ...)+-- are prefix operators following standard Prolog convention, so that+-- @:- chr_constraint leq\/2.@ parses as a single term.+builtinOps :: OpTable+builtinOps =+  P.mkOpTable+    [ (100, [(P.Yfx, ":")]),+      (400, [(P.Yfx, "/")]),+      (500, [(P.Fx, "fun")]),+      (750, [(P.Xfx, "is"), (P.Xfx, "=")]),+      (1000, [(P.Xfy, ",")]),+      (1105, [(P.Xfy, "|")]),+      (1110, [(P.Xfy, "->")]),+      (1100, [(P.Xfy, ";"), (P.Xfx, "\\")]),+      -- Bounded polymorphism: @sig requiring bound1, bound2, ...@.+      -- Looser than @->@ (1110) so the bound clause sits outside the+      -- signature's arrow, tighter than the directive prefix at 1180+      -- so a @requiring@ clause stays inside the @:- function@ arg.+      -- Comma (1000) is also tighter, so the bound list on the right+      -- is a comma chain consumed as a single argument here.+      (1140, [(P.Xfx, "requiring")]),+      (1150, [(P.Xfx, "--->")]),+      (1180, [(P.Xfx, "<=>"), (P.Xfx, "==>")]),+      ( 1180,+        [ (P.Fx, "chr_constraint"),+          (P.Fx, "chr_type"),+          (P.Fx, "opaque_type"),+          (P.Fx, "function"),+          (P.Fx, "open_function"),+          (P.Fx, "class"),+          (P.Fx, "open_class"),+          (P.Fx, "extend_class_type"),+          (P.Fx, "extend_class"),+          (P.Fx, "extend_function")+        ]+      ),+      (1190, [(P.Xfx, "@")]),+      (1200, [(P.Fx, ":-")]),+      -- Reserve @end@ as a keyword (for @fun(...) -> ... end@) without+      -- making it a usable operator.  Fixity above 'maxPrec' ensures it+      -- is never consumed by the Pratt parser, but its presence in+      -- 'wordOpSet' prevents 'atomP' from treating it as an atom.+      (P.maxPrec + 1, [(P.Fx, "end")])+    ]++-- | Merge user-defined operators into an existing table.+-- Returns 'Left' with the conflicting operator name if a naming conflict is+-- found (same operator name at a different fixity or type).+mergeOps :: OpTable -> [OpDecl] -> Either Text OpTable+mergeOps base decls =+  P.mergeOps base [(d.fixity, d.opType, d.opName) | d <- decls]++-- | List all operator entries in an 'OpTable' as @(fixity, type, name)@+-- triples. The order is unspecified.+opTableEntries :: OpTable -> [(Int, P.OpType, Text)]+opTableEntries = P.opTableEntries++-- * Public parsing functions++-- | Parse a CHR module from source text using the built-in operator table.+--+-- The first argument is the source file name (used in error messages only).+parseModule ::+  String ->+  Text ->+  Either ParseError (Module, [AnnP ParseValidationError])+parseModule = parseModuleWith builtinOps++-- | Parse a CHR module from source text using a custom operator table.+parseModuleWith ::+  OpTable ->+  String ->+  Text ->+  Either ParseError (Module, [AnnP ParseValidationError])+parseModuleWith table sourceName src = do+  terms <- P.parseTerms table sourceName src+  pure (convertModule (defaultModuleNameForSource sourceName) terms)++-- | Default module name for a header-less source.+--+-- File-backed inputs become @\<basename\>@ (directory and extension+-- stripped), so an ambiguity diagnostic that mentions two header-less+-- files names the files instead of printing two identical placeholders.+-- Empty or degenerate source names fall back to the sentinel+-- @\<no_module\>@; the DSL, REPL one-shots, and parser tests reach this+-- branch.+defaultModuleNameForSource :: String -> Text+defaultModuleNameForSource sourceName =+  case takeBaseName sourceName of+    "" -> "<no_module>"+    base -> "<" <> Text.pack base <> ">"++-- | Parse a single constraint from surface-language 'Text', using the+-- builtin operator table.+--+-- The outer 'Left' is a parsec parse error; the inner 'Left' is a+-- 'ParseValidationError' (the input parsed but did not denote a+-- constraint, e.g. a bare variable or integer).+--+-- The source name (first argument) is used in error messages only.+-- Example: @parseConstraint "\<query\>" "leq(X, Y)"@.+parseConstraint ::+  String ->+  Text ->+  Either ParseError (Either (AnnP ParseValidationError) Constraint)+parseConstraint = parseConstraintWith builtinOps++-- | Parse a single constraint from surface-language 'Text' using a+-- custom operator table. Used by the single-goal entry points so that+-- user-declared operators (e.g. @+@ from the prelude) are recognized+-- in goal arguments, mirroring the multi-goal parser.+parseConstraintWith ::+  OpTable ->+  String ->+  Text ->+  Either ParseError (Either (AnnP ParseValidationError) Constraint)+parseConstraintWith table sourceName src = do+  term <- P.parseTermNoDot table sourceName src+  pure (convertConstraint term)++-- | Parse a single term from surface-language 'Text'.+--+-- The source name (first argument) is used in error messages only.+-- Example: @parseTerm "\<query\>" "f(X, 42)"@.+parseTerm ::+  String ->+  Text ->+  Either ParseError Term+parseTerm = parseTermWith builtinOps++-- | Parse a single term with a custom operator table.+parseTermWith ::+  OpTable ->+  String ->+  Text ->+  Either ParseError Term+parseTermWith table sourceName src = do+  term <- P.parseTermNoDot table sourceName src+  pure (convertTerm term)++-- | Parse a query: a comma-separated list of goals terminated by a dot.+--+-- The source name (first argument) is used in error messages only.+-- Example: @parseQuery "\<query\>" "fib(10, X), Y is X + 1."@.+parseQuery ::+  String ->+  Text ->+  Either ParseError [Term]+parseQuery = parseQueryWith builtinOps++-- | Parse a query with a custom operator table.+--+-- The terminating @.@ is optional: if @src@ (with trailing whitespace+-- stripped) ends in a dot, the dot-terminated parser is used; otherwise+-- the non-terminated one. Picking the parser up front (rather than+-- retrying on failure) keeps the parse error message attached to the+-- right phase — a missing or extra dot is no longer reported as a+-- term-shape error.+parseQueryWith ::+  OpTable ->+  String ->+  Text ->+  Either ParseError [Term]+parseQueryWith table sourceName src =+  let parser = if dotTerminated then P.parseTerm else P.parseTermNoDot+   in map convertTerm . flattenComma <$> parser table sourceName src+  where+    trimmed = Text.stripEnd src+    dotTerminated = not (Text.null trimmed) && Text.last trimmed == '.'++-- | Parse a single CHR rule from surface-language 'Text'.+--+-- The outer 'Left' is a parsec parse error. On parse success, the+-- 'Maybe' is 'Nothing' if the parsed term is not a rule shape (a+-- 'MalformedTopLevel' error is emitted in that case); otherwise it+-- contains the parsed 'Rule' and any 'MalformedConstraint' errors+-- collected from its head.+--+-- The source name (first argument) is used in error messages only.+parseRule ::+  String ->+  Text ->+  Either ParseError (Maybe Rule, [AnnP ParseValidationError])+parseRule sourceName src = do+  term <- P.parseTerm builtinOps sourceName src+  pure (convertRule term)++-- * Module headers++-- | Minimal operator table for the first pass: only enough to parse+-- @:- module(...)@ and @:- use_module(...)@ directives.+firstPassTable :: OpTable+firstPassTable =+  P.mkOpTable+    [ (400, [(P.Yfx, "/")]),+      (500, [(P.Fx, "fun")]),+      (1200, [(P.Fx, ":-")])+    ]++-- | Header information collected from a module's leading directives during+-- the lightweight first parsing pass.+--+-- The header captures everything needed to compute per-module operator+-- visibility before the full parse: the module's name, the operators it+-- exports, the @use_module@ directives that immediately follow the+-- @module@ directive, and the source location at which header parsing+-- stopped (used to detect misplaced @use_module@ directives later in the+-- file).+data ModuleHeader = ModuleHeader+  { modName :: Text,+    -- | Source location of the @:- module(...)@ directive. 'dummyLoc' if+    -- the file does not declare a module.+    modLoc :: SourceLoc,+    -- | The original PExpr of the @module(...)@ body, for diagnostics.+    modOrigin :: PExpr,+    -- | Operators declared in the module's export list.+    exportOps :: [OpDecl],+    -- | @use_module@ imports immediately following the @module@ directive+    -- (or, when there is no module directive, immediately at the start of+    -- the file).+    headerImports :: [AnnP Import],+    -- | Source location of the first content that is not a header+    -- directive, or 'Nothing' if the file ends after the header.+    -- Imports appearing at or beyond this location are misplaced.+    trailingLoc :: Maybe SourceLoc+  }+  deriving (Show, Eq)++-- | Information extracted from a leading @:- module(...)@ directive.+-- Private to 'collectModuleHeader'.+data ModuleDirectiveInfo = ModuleDirectiveInfo+  { name :: Text,+    loc :: SourceLoc,+    origin :: PExpr,+    exportOps :: [OpDecl]+  }++-- | Collect a 'ModuleHeader' from a source file using the minimal first-pass+-- operator table.+--+-- Stops at the first directive or rule that cannot be parsed by the+-- first-pass table — which in practice means anything other than+-- @:- module(...)@ or @:- use_module(...)@.+collectModuleHeader :: String -> Text -> Either ParseError ModuleHeader+collectModuleHeader sourceName src = do+  (terms, tloc) <- P.parseLeadingTerms firstPassTable sourceName src+  let (modPart, rest1) = case terms of+        (t : ts) | Just i <- asModuleDirective t -> (Just i, ts)+        _ -> (Nothing, terms)+      (imps, leftover) = takeImports rest1+      finalLoc = case leftover of+        [] -> tloc+        (Ann _ loc : _) -> Just loc+      info = case modPart of+        Just i -> i+        Nothing ->+          ModuleDirectiveInfo+            { name = defaultModuleNameForSource sourceName,+              loc = dummyLoc,+              origin = Atom "",+              exportOps = []+            }+  pure+    ModuleHeader+      { modName = info.name,+        modLoc = info.loc,+        modOrigin = info.origin,+        exportOps = info.exportOps,+        headerImports = imps,+        trailingLoc = finalLoc+      }+  where+    asModuleDirective (Ann (Compound ":-" [body]) loc)+      | Compound "module" [Ann (Atom name) _, exports] <- body.node =+          Just+            ModuleDirectiveInfo+              { name,+                loc,+                origin = body.node,+                exportOps = extractOpDeclsFromPExpr exports.node+              }+      | Compound "module" [Ann (Atom name) _] <- body.node =+          Just+            ModuleDirectiveInfo+              { name,+                loc,+                origin = body.node,+                exportOps = []+              }+    asModuleDirective _ = Nothing++    takeImports [] = ([], [])+    -- Malformed @use_module@ directives are silently skipped here; the full+    -- parse path emits 'MalformedImport' for them via 'convertDirective'.+    takeImports all_@(Ann (Compound ":-" [body]) loc : rest) = case body.node of+      Compound "use_module" [imp] ->+        let (more, leftover) = takeImports rest+         in case convertImport loc body.node imp of+              Right ann -> (ann : more, leftover)+              Left _ -> (more, leftover)+      Compound "use_module" [imp, importList] ->+        let (more, leftover) = takeImports rest+         in case convertImportWithList loc body.node imp importList of+              Right (ann, _) -> (ann : more, leftover)+              Left _ -> (more, leftover)+      _ -> ([], all_)+    takeImports rest = ([], rest)++-- | Build the per-module operator table for a user module.+--+-- Combines the built-in operators, the always-visible prelude operators,+-- the module's own exported operators, and the operators reachable through+-- its @use_module@ imports. Returns @Left name@ if two operator declarations+-- with the same name disagree on fixity or type.+--+-- For each import:+--+--   * @use_module(M)@ (no item list) brings in every operator @M@ exports.+--   * @use_module(M, [items])@ brings in only the operators listed via+--     @op(...)@ entries inside the item list.+--+-- Operators of unknown source modules (e.g. @use_module(missing_lib)@)+-- contribute nothing here; the resulting unknown-library or unknown-import+-- error is reported elsewhere.+buildModuleOpTable ::+  -- | Built-in operators+  OpTable ->+  -- | Prelude's exported operators (always visible)+  [OpDecl] ->+  -- | Map from module name to that module's exported operators+  Map Text [OpDecl] ->+  -- | The user module's header+  ModuleHeader ->+  Either Text OpTable+buildModuleOpTable base preludeOps exportsByModule header =+  mergeOps base (preludeOps ++ header.exportOps ++ importedOps)+  where+    importedOps = concatMap importedFrom header.headerImports+    importedFrom (AnnP imp _ _) = case imp of+      ModuleImport m Nothing -> Map.findWithDefault [] m exportsByModule+      LibraryImport m Nothing -> Map.findWithDefault [] m exportsByModule+      ModuleImport m (Just items) -> selectOps m items+      LibraryImport m (Just items) -> selectOps m items+    selectOps m items =+      let exported = Map.findWithDefault [] m exportsByModule+       in [op | OperatorDecl op <- items, op `elem` exported]++-- | Extract 'OpDecl' entries from a PExpr representing an export list.+extractOpDeclsFromPExpr :: PExpr -> [OpDecl]+extractOpDeclsFromPExpr pexpr =+  [op | item <- unfoldList pexpr, Just op <- [toOpDecl item.node]]+  where+    toOpDecl (Compound "op" [Ann (P.Int fix) _, Ann tyExpr _, Ann nameExpr _])+      | Just ty <- parseOpTypeFromPExpr tyExpr,+        Just name <- atomName nameExpr =+          Just (OpDecl (fromInteger fix) ty name)+    toOpDecl _ = Nothing++-- | If the expression is an atom, return its text; otherwise 'Nothing'.+atomName :: PExpr -> Maybe Text+atomName (Atom a) = Just a+atomName _ = Nothing++-- | Parse an operator type from a PExpr atom.+parseOpTypeFromPExpr :: PExpr -> Maybe P.OpType+parseOpTypeFromPExpr (Atom "xfx") = Just P.Xfx+parseOpTypeFromPExpr (Atom "xfy") = Just P.Xfy+parseOpTypeFromPExpr (Atom "yfx") = Just P.Yfx+parseOpTypeFromPExpr (Atom "fx") = Just P.Fx+parseOpTypeFromPExpr (Atom "fy") = Just P.Fy+parseOpTypeFromPExpr (Atom "xf") = Just P.Xf+parseOpTypeFromPExpr (Atom "yf") = Just P.Yf+parseOpTypeFromPExpr _ = Nothing++-- | Extract operator declarations from an already-parsed module's export list.+extractOpDecls :: Module -> [OpDecl]+extractOpDecls m = case m.exports of+  Nothing -> []+  Just annExports -> [op | OperatorDecl op <- annExports.node]++-- * Internal: PExpr conversions++{- Note [Qualified name handling]++The qualified-name forms @module:name@ and @module:name(args)@ are+intercepted before the generic 'Compound' fallback. Without this, the parser+would emit a 2-ary @':'@ constructor with two unrelated children, and the+renamer would have to undo that downstream. The same handling is mirrored in+'convertConstraint' and 'convertTypeExpr'.+-}++-- | Convert a 'PExpr' to a 'Term'.+--+-- See Note [Qualified name handling].+convertTerm :: Ann PExpr -> Term+convertTerm (Ann pexpr _) = case pexpr of+  Var t -> VarTerm t+  P.Int n -> IntTerm n+  P.Float n -> FloatTerm n+  Atom t -> CompoundTerm (Unqualified t) []+  Str t -> TextTerm t+  P.Wildcard -> Wildcard+  Compound ":" [Ann (Atom m) _, Ann (Atom n) _] ->+    CompoundTerm (Qualified m n) []+  Compound ":" [Ann (Atom m) _, Ann (Compound n args) _] ->+    CompoundTerm (Qualified m n) (map convertTerm args)+  Compound f args ->+    CompoundTerm (Unqualified f) (map convertTerm args)++-- | Convert a 'PExpr' to a 'Constraint'.+--+-- Returns 'Left' with a 'MalformedConstraint' error when the input is not+-- an atom or compound term (e.g. a bare variable, integer, or string).+--+-- See Note [Qualified name handling].+convertConstraint :: Ann PExpr -> Either (AnnP ParseValidationError) Constraint+convertConstraint (Ann pexpr loc) = case pexpr of+  Atom name ->+    Right (Constraint (Unqualified name) [])+  Compound ":" [Ann (Atom m) _, Ann (Atom n) _] ->+    Right (Constraint (Qualified m n) [])+  Compound ":" [Ann (Atom m) _, Ann (Compound n args) _] ->+    Right (Constraint (Qualified m n) (map convertTerm args))+  Compound name args ->+    Right (Constraint (Unqualified name) (map convertTerm args))+  _ -> Left (AnnP MalformedConstraint loc pexpr)++-- ** Flattening helpers++-- | Flatten a right-nested comma operator into a non-empty list.+-- Note: O(n) because @,@ is @xfy@ so the tree is right-heavy (left child+-- is always a leaf).+flattenComma1 :: Ann PExpr -> NE.NonEmpty (Ann PExpr)+flattenComma1 (Ann (Compound "," [l, r]) _) =+  flattenComma1 l <> flattenComma1 r+flattenComma1 e = NE.singleton e++-- | List-returning view of 'flattenComma1' for callers that don't need+-- the non-emptiness invariant.+flattenComma :: Ann PExpr -> [Ann PExpr]+flattenComma = NE.toList . flattenComma1++-- | Flatten a right-nested semicolon operator into a list.+flattenSemicolon :: Ann PExpr -> [Ann PExpr]+flattenSemicolon (Ann (Compound ";" [l, r]) _) =+  flattenSemicolon l ++ flattenSemicolon r+flattenSemicolon e = [e]++-- | Unfold a Prolog list ('.'\/2 + '[]') to a flat list of elements.+unfoldList :: PExpr -> [Ann PExpr]+unfoldList (Atom "[]") = []+unfoldList (Compound "." [h, t]) = h : unfoldList t.node+unfoldList _ = [] -- non-proper list tail: ignore++-- | Like 'unfoldList', but returns 'Nothing' for inputs that are not a+-- proper Prolog list (i.e. that do not terminate in @[]@). Use this+-- where a non-list argument should be rejected with a structured error+-- rather than silently coerced to an empty list.+unfoldListStrict :: PExpr -> Maybe [Ann PExpr]+unfoldListStrict (Atom "[]") = Just []+unfoldListStrict (Compound "." [h, t]) = (h :) <$> unfoldListStrict t.node+unfoldListStrict _ = Nothing++-- ** Module conversion++-- | Internal directive type.+data Directive+  = DirModule Text SourceLoc PExpr (Maybe [Declaration])+  | DirImport (AnnP Import)+  | DirConstraintDecl [Ann Declaration]+  | DirFunctionDecl [Ann Declaration]+  | DirOpenFunctionDecl [Ann Declaration]+  | DirClassDecl [Ann Declaration]+  | DirOpenClassDecl [Ann Declaration]+  | DirExtendClassTypeDecl [Ann Declaration]+  | DirExtendFunctionEqn (AnnP FunctionEquation)+  | DirExtendClassEqn (AnnP FunctionEquation)+  | DirTypeDecl [Ann TypeDefinition]+  | DirOther++-- | Internal module item type.+data ModuleItem+  = ItemDirective Directive+  | ItemRule Rule+  | ItemEquation (AnnP FunctionEquation)++-- | Validation error detected during module conversion.+data ParseValidationError+  = -- | Equations for a non-open function are not contiguous.+    DiscontiguousEquations Text+  | -- | @:- function@ declarations for a non-open function are not+    -- contiguous within the module.+    DiscontiguousFunctionDecls Text+  | -- | A @use_module@ directive's argument was not a module name or+    -- @library(name)@.+    MalformedImport+  | -- | A constraint position contained something that is not an atom or+    -- compound term (e.g. a bare variable, integer, or string).+    MalformedConstraint+  | -- | A declaration inside @:- chr_constraint@ / @:- function@ /+    -- @:- open_function@ / @:- class@ / @:- open_class@ /+    -- @:- extend_class_type@ has a shape the parser does not recognize.+    -- The declaration is dropped.+    MalformedDeclaration+  | -- | An item in a @module(...)@ export list or @use_module/2@ import+    -- list is not one of the recognized shapes (@name/arity@,+    -- @fun name/arity@, @op(...)@, @type(...)@). The item is dropped.+    MalformedExportItem+  | -- | A type expression (in an argument type, return type, or bound+    -- signature) is not a variable, atom, or compound term — typically a+    -- stray literal or string. The enclosing declaration is dropped.+    MalformedTypeExpr+  | -- | A data constructor in a @:- chr_type ... ---> ...@ definition is+    -- not an atom or compound term. The enclosing type definition is+    -- dropped.+    MalformedDataConstructor+  | -- | A @:- chr_type@ directive does not have the expected+    -- @head ---> alts@ shape. The type definition is dropped.+    MalformedTypeDefinition+  | -- | A @:- opaque_type@ directive carries a constructor body+    -- (@head ---> ...@). Opaque types cannot have data constructors.+    -- The type definition is dropped.+    OpaqueTypeHasConstructors+  | -- | A @:- opaque_type@ directive does not have the expected+    -- @name@ or @name(Vars)@ head shape. The type definition is dropped.+    MalformedOpaqueTypeDefinition+  | -- | A bound signature inside a @requiring@ clause does not have the+    -- expected @name(τ₁, …, τₙ) -> τᵣ@ shape. The enclosing declaration+    -- is dropped.+    MalformedBoundSig+  | -- | A @:- extend_function@ / @:- extend_class@ payload, or a+    -- top-level equation, does not have the expected+    -- @lhs [| guard] -> rhs@ shape. The equation is dropped.+    MalformedFunctionEquation+  | -- | A top-level term is neither a directive, a rule+    -- (@\<=\>@/@==\>@), nor a function equation. The item is dropped.+    MalformedTopLevel+  | -- | More than one @:- module(...)@ directive in the same file.+    -- Only one module header is allowed per source file. The first+    -- header is treated as authoritative; one diagnostic is emitted+    -- per redundant header, carrying its module name.+    DuplicateModuleHeader Text+  | -- | A @requiring@ clause appears on a @:- class@ or+    -- @:- open_class@ declaration. @requiring@ is reserved for+    -- @:- function@ / @:- open_function@; the two forms are+    -- intentionally orthogonal. Carries the class's name.+    RequiringOnClass Text+  | -- | A @requiring@ clause appears on a @:- extend_class_type@+    -- directive. Bounds are part of the original declaration; an+    -- extension cannot introduce them. Carries the extension target's+    -- name.+    RequiringOnExtendClassType Text+  deriving (Eq, Show)++-- | Convert a list of top-level PExpr terms to a 'Module', along with+-- any validation errors (discontiguous equations, malformed imports,+-- malformed constraints).+--+-- Items whose conversion fails entirely are dropped from the resulting+-- module; their errors are still returned in the second component.+convertModule :: Text -> [Ann PExpr] -> (Module, [AnnP ParseValidationError])+convertModule defaultName terms =+  let itemResults = map convertModuleItem terms+      items = [i | (Just i, _) <- itemResults]+      itemErrors = concatMap snd itemResults+      dirs = [d | ItemDirective d <- items]+      rules = [r | ItemRule r <- items]+      eqs = [e | ItemEquation e <- items]+      moduleDirs = [(n, l, p, e) | DirModule n l p e <- dirs]+      (modName_, modNameLoc_, modExports_) = case moduleDirs of+        ((n, l, p, Just decls) : _) -> (n, l, Just (AnnP decls l p))+        ((n, l, _, Nothing) : _) -> (n, l, Nothing)+        [] -> (defaultName, dummyLoc, Nothing)+      modImports_ = [n | DirImport n <- dirs]+      modDecls_ =+        concat [ds | DirConstraintDecl ds <- dirs]+          ++ concat [ds | DirFunctionDecl ds <- dirs]+          ++ concat [ds | DirOpenFunctionDecl ds <- dirs]+          ++ concat [ds | DirClassDecl ds <- dirs]+          ++ concat [ds | DirOpenClassDecl ds <- dirs]+      modExtensionTypes_ = concat [ds | DirExtendClassTypeDecl ds <- dirs]+      modTypeDecls_ = concat [ds | DirTypeDecl ds <- dirs]+      modExtensions_ = [e | ItemDirective (DirExtendFunctionEqn e) <- items]+      modClassExtensions_ = [e | ItemDirective (DirExtendClassEqn e) <- items]+      openNames =+        Set.fromList $+          [d.name | DirOpenFunctionDecl ds <- dirs, Ann d _ <- ds]+            ++ [d.name | DirOpenClassDecl ds <- dirs, Ann d _ <- ds]+      contiguityErrors = checkContiguity openNames items+      duplicateModuleHeaderErrors =+        [ AnnP (DuplicateModuleHeader n) l p+        | (n, l, p, _) <- drop 1 moduleDirs+        ]+      mod_ =+        Module+          { name = modName_,+            nameLoc = modNameLoc_,+            imports = modImports_,+            decls = modDecls_,+            extensionTypes = modExtensionTypes_,+            typeDecls = modTypeDecls_,+            rules = rules,+            equations = eqs,+            extensions = modExtensions_,+            classExtensions = modClassExtensions_,+            exports = modExports_+          }+   in (mod_, itemErrors ++ contiguityErrors ++ duplicateModuleHeaderErrors)++-- | Check that equations for non-open functions are contiguous.+-- Returns an error for each function whose equations are separated by+-- other items.+checkContiguity :: Set.Set Text -> [ModuleItem] -> [AnnP ParseValidationError]+checkContiguity openNames items =+  checkEquationContiguity openNames items+    ++ checkDeclContiguity openNames items++-- | Equation contiguity: equations for the same non-open function name+-- must be a contiguous block of module items.+checkEquationContiguity ::+  Set.Set Text -> [ModuleItem] -> [AnnP ParseValidationError]+checkEquationContiguity openNames = go Set.empty Nothing+  where+    -- closed: function names whose equation block has ended.+    -- prev: the function name of the immediately preceding equation (if any).+    go _closed _prev [] = []+    go closed prev (ItemEquation annEq : rest) =+      let n = eqName annEq.node.funName+       in if n `Set.member` openNames+            then go closed prev rest+            else case prev of+              Just p | p == n -> go closed prev rest -- still contiguous+              _ ->+                let closed' = maybe closed (`Set.insert` closed) prev+                 in if n `Set.member` closed'+                      then+                        AnnP (DiscontiguousEquations n) annEq.sourceLoc annEq.parsed+                          : go closed' (Just n) rest+                      else go closed' (Just n) rest+    go closed prev (_ : rest) =+      go (maybe closed (`Set.insert` closed) prev) Nothing rest++    eqName (Unqualified n) = n+    eqName (Qualified _ n) = n++-- | Declaration contiguity: @:- function@ (and @:- open_function@)+-- directives for the same non-open function name must be a contiguous+-- block of module items. Decls inside a single directive (e.g.+-- @:- function f\/1, g\/1.@) count as one block per function and do+-- not close each other.+checkDeclContiguity ::+  Set.Set Text -> [ModuleItem] -> [AnnP ParseValidationError]+checkDeclContiguity openNames = go Set.empty Set.empty+  where+    -- closed: function names whose decl block has ended.+    -- active: function names declared by the immediately preceding decl+    -- directive (still contiguous).+    go _closed _active [] = []+    go closed active (ItemDirective dir : rest)+      | Just ds <- declListOf dir =+          let names = [(d.name, loc) | Ann d loc <- ds]+              nonOpenNames = [n | n <- map fst names, n `Set.notMember` openNames]+              reopened =+                [ noAnnPAt loc (DiscontiguousFunctionDecls n)+                | (n, loc) <- names,+                  n `Set.notMember` openNames,+                  n `Set.member` closed,+                  n `Set.notMember` active+                ]+              active' = Set.fromList nonOpenNames `Set.union` active+           in reopened ++ go closed active' rest+    go closed active (_ : rest) =+      go (active `Set.union` closed) Set.empty rest++    declListOf (DirFunctionDecl ds) = Just ds+    declListOf (DirOpenFunctionDecl ds) = Just ds+    declListOf (DirClassDecl ds) = Just ds+    declListOf (DirOpenClassDecl ds) = Just ds+    declListOf _ = Nothing++-- | Classify and convert a single top-level PExpr, collecting any errors+-- raised during conversion. Returns 'Nothing' if the term does not denote+-- a recognized top-level item; a 'MalformedTopLevel' error is emitted+-- in that case.+convertModuleItem ::+  Ann PExpr -> (Maybe ModuleItem, [AnnP ParseValidationError])+convertModuleItem expr = case expr.node of+  -- Directive: :- body+  Compound ":-" [_] ->+    let (d, errs) = convertDirective expr in (Just (ItemDirective d), errs)+  -- Named rule: name @ ...+  Compound "@" [_, Ann (Compound "<=>" _) _] -> ruleItem+  Compound "@" [_, Ann (Compound "==>" _) _] -> ruleItem+  -- Unnamed rule+  Compound "<=>" _ -> ruleItem+  Compound "==>" _ -> ruleItem+  -- Function equation (contains -> at top level)+  Compound "->" _ ->+    let (mEq, errs) = convertFunctionEquation expr+     in (ItemEquation <$> mEq, errs)+  -- Anything else at top level is malformed.+  _ -> (Nothing, [AnnP MalformedTopLevel expr.sourceLoc expr.node])+  where+    ruleItem = let (mr, errs) = convertRule expr in (ItemRule <$> mr, errs)++-- ** Directive conversion++-- | Convert a directive PExpr to a 'Directive', collecting any errors+-- raised during conversion. Malformed sub-items (declarations, equations,+-- export items) are dropped and reported via 'ParseValidationError's.+convertDirective :: Ann PExpr -> (Directive, [AnnP ParseValidationError])+convertDirective (Ann (Compound ":-" [body]) loc) = case body.node of+  -- :- module(name, [exports]).+  Compound "module" [Ann (Atom name) _, exports] ->+    let (decls, errs) = collectMaybes (map convertExportItem (unfoldList exports.node))+     in (DirModule name loc body.node (Just decls), errs)+  -- :- module(name).  (no export list — exports everything)+  Compound "module" [Ann (Atom name) _] ->+    (DirModule name loc body.node Nothing, [])+  -- :- use_module(name).  or  :- use_module(library(name)).+  Compound "use_module" [imp, importList] ->+    case convertImportWithList loc body.node imp importList of+      Right (ann, errs) -> (DirImport ann, errs)+      Left err -> (DirOther, [err])+  Compound "use_module" [imp] ->+    case convertImport loc body.node imp of+      Right ann -> (DirImport ann, [])+      Left err -> (DirOther, [err])+  -- :- chr_constraint leq/2, fib/2.+  -- Parsed as prefix op: Compound "chr_constraint" [body]+  Compound "chr_constraint" [decls] ->+    let (decls', errs) = collectDecls convertConstraintDecl decls+     in (DirConstraintDecl decls', errs)+  -- :- function foo/2.  or  :- function factorial(int) -> int.+  Compound "function" [decls] ->+    let (decls', errs) = collectDecls convertFunctionDecl decls+     in (DirFunctionDecl decls', errs)+  -- :- open_function foo/2.+  Compound "open_function" [decls] ->+    let (decls', errs) = collectDecls convertOpenFunctionDecl decls+     in (DirOpenFunctionDecl decls', errs)+  -- :- class size(int) -> int.  or  :- class (size(int) -> int), (size(string) -> int).+  Compound "class" [decls] ->+    let (decls', errs) = collectDecls convertClassDecl decls+        classReqErrs = requiringOnClassErrors loc body.node decls'+     in (DirClassDecl decls', errs ++ classReqErrs)+  -- :- open_class size(int) -> int.+  Compound "open_class" [decls] ->+    let (decls', errs) = collectDecls convertOpenClassDecl decls+        classReqErrs = requiringOnClassErrors loc body.node decls'+     in (DirOpenClassDecl decls', errs ++ classReqErrs)+  -- :- extend_class_type (foo(int) -> int).+  Compound "extend_class_type" [decls] ->+    let (decls', errs) = collectDecls convertExtendClassTypeDecl decls+     in (DirExtendClassTypeDecl decls', errs)+  -- :- extend_function name(args) [| guards] -> body.+  Compound "extend_function" [eqn] ->+    case convertFunctionEquation eqn of+      (Just annEq, errs) -> (DirExtendFunctionEqn annEq, errs)+      (Nothing, errs) -> (DirOther, errs)+  -- :- extend_class name(args) [| guards] -> body.+  Compound "extend_class" [eqn] ->+    case convertFunctionEquation eqn of+      (Just annEq, errs) -> (DirExtendClassEqn annEq, errs)+      (Nothing, errs) -> (DirOther, errs)+  -- :- chr_type name ---> con1 ; con2 ; ...+  -- Parsed as prefix op: Compound "chr_type" [Compound "--->" [head, alts]]+  Compound "chr_type" [typeBody] ->+    case convertTypeDefinition typeBody of+      (Just annDef, errs) -> (DirTypeDecl [annDef], errs)+      (Nothing, errs) -> (DirOther, errs)+  -- :- opaque_type name(Vars).+  -- Parsed as prefix op (1180): Compound "opaque_type" [head]. A+  -- constructor body @---> ...@ (1150) nests inside as+  -- Compound "opaque_type" [Compound "--->" [..]] and is rejected by+  -- 'convertOpaqueTypeDefinition'.+  Compound "opaque_type" [typeBody] ->+    case convertOpaqueTypeDefinition typeBody of+      (Just annDef, errs) -> (DirTypeDecl [annDef], errs)+      (Nothing, errs) -> (DirOther, errs)+  -- Unknown directives (any other @:- name(...)@ shape).+  _ -> (DirOther, [])+convertDirective _ = (DirOther, [])++-- | Run a per-declaration converter over a comma-separated declaration+-- list, dropping declarations that failed conversion and accumulating+-- their errors.+collectDecls ::+  (Ann PExpr -> (Maybe (Ann Declaration), [AnnP ParseValidationError])) ->+  Ann PExpr ->+  ([Ann Declaration], [AnnP ParseValidationError])+collectDecls conv = collectMaybes . map conv . flattenComma++-- | Flatten a list of @(Maybe a, errors)@ results: keep the successes,+-- concatenate the errors.+collectMaybes :: [(Maybe a, [e])] -> ([a], [e])+collectMaybes results = ([a | (Just a, _) <- results], concatMap snd results)++-- | Convert an import PExpr (use_module/1, imports everything).+-- Returns 'Left' with a 'MalformedImport' error if the argument is not a+-- module name or @library(name)@.+convertImport ::+  SourceLoc ->+  PExpr ->+  Ann PExpr ->+  Either (AnnP ParseValidationError) (AnnP Import)+convertImport dirLoc dirPExpr (Ann pexpr loc) = case pexpr of+  Compound "library" [Ann (Atom name) _] ->+    Right (AnnP (LibraryImport name Nothing) dirLoc dirPExpr)+  Atom name -> Right (AnnP (ModuleImport name Nothing) dirLoc dirPExpr)+  _ -> Left (AnnP MalformedImport loc pexpr)++-- | Convert an import PExpr with an explicit import list (use_module/2).+-- Returns 'Left' with a 'MalformedImport' error if the import target is not+-- a module name or @library(name)@. On success, also returns any+-- 'MalformedExportItem' errors from items inside the import list.+convertImportWithList ::+  SourceLoc ->+  PExpr ->+  Ann PExpr ->+  Ann PExpr ->+  Either+    (AnnP ParseValidationError)+    (AnnP Import, [AnnP ParseValidationError])+convertImportWithList dirLoc dirPExpr imp importList =+  let (items, itemErrs) =+        collectMaybes (map convertExportItem (unfoldList importList.node))+   in case imp.node of+        Compound "library" [Ann (Atom name) _] ->+          Right (AnnP (LibraryImport name (Just items)) dirLoc dirPExpr, itemErrs)+        Atom name ->+          Right (AnnP (ModuleImport name (Just items)) dirLoc dirPExpr, itemErrs)+        _ -> Left (AnnP MalformedImport imp.sourceLoc imp.node)++-- | Report a 'RequiringOnClass' error for every declaration inside a+-- @:- class@ or @:- open_class@ directive that carries a @requiring@+-- clause. Bounded polymorphism is reserved for @:- function@ /+-- @:- open_function@; the two forms are intentionally orthogonal.+-- The shared location and origin come from the surrounding directive+-- so the diagnostic points at the whole @:- class@.+requiringOnClassErrors ::+  SourceLoc -> PExpr -> [Ann Declaration] -> [AnnP ParseValidationError]+requiringOnClassErrors loc origin decls =+  [ AnnP (RequiringOnClass d.name) loc origin+  | Ann d _ <- decls,+    case d of+      FunctionDecl {requiring = Just _} -> True+      _ -> False+  ]++-- | Convert an export item PExpr to a 'Declaration'. Items whose shape+-- is not recognized are dropped with a 'MalformedExportItem' error.+--+-- For @type(name\/arity, [con1, …])@ the constructor list is validated+-- strictly: a non-list argument or any non-atom element causes the+-- entire export item to be dropped, with one 'MalformedExportItem'+-- error per offending position. Dropping (rather than salvaging the+-- well-formed atoms) keeps the parser uniform with the rest of the+-- malformed-input policy, and avoids accidentally widening or+-- narrowing the constructor allowlist relative to what the user wrote.+convertExportItem ::+  Ann PExpr -> (Maybe Declaration, [AnnP ParseValidationError])+convertExportItem (Ann pexpr loc) = case pexpr of+  Compound "fun" [Ann (Compound "/" [Ann (Atom name) _, Ann (P.Int arity) _]) _] ->+    ( Just+        ( FunctionDecl+            name+            (fromInteger arity)+            Nothing+            Nothing+            False+            DKFunction+            Nothing+        ),+      []+    )+  Compound "/" [Ann (Atom name) _, Ann (P.Int arity) _] ->+    (Just (ConstraintDecl name (fromInteger arity) Nothing Nothing), [])+  Compound "op" [Ann (P.Int fix) _, Ann tyExpr _, Ann nameExpr _]+    | Just ty <- parseOpTypeFromPExpr tyExpr,+      Just name <- atomName nameExpr ->+        (Just (OperatorDecl (OpDecl (fromInteger fix) ty name)), [])+  -- @type(name/arity)@ — covers both algebraic and opaque types (they+  -- share one type namespace).+  Compound "type" [Ann (Compound "/" [Ann (Atom name) _, Ann (P.Int arity) _]) _] ->+    (Just (TypeExportDecl name (fromInteger arity) Nothing), [])+  Compound "type" [spec, conList]+    | Compound "/" [Ann (Atom name) _, Ann (P.Int arity) _] <- spec.node ->+        case unfoldListStrict conList.node of+          Nothing ->+            (Nothing, [AnnP MalformedExportItem conList.sourceLoc conList.node])+          Just items -> case partitionEithers (map atomElement items) of+            ([], names) ->+              (Just (TypeExportDecl name (fromInteger arity) (Just names)), [])+            (errs, _) -> (Nothing, errs)+  _ -> (Nothing, [AnnP MalformedExportItem loc pexpr])+  where+    atomElement (Ann (Atom n) _) = Right n+    atomElement (Ann e l) = Left (AnnP MalformedExportItem l e)++-- | Convert a PExpr to a constraint declaration. Returns 'Nothing' and+-- a 'MalformedDeclaration' (or 'MalformedTypeExpr' / 'MalformedBoundSig'+-- from sub-conversions) error if the declaration cannot be converted.+convertConstraintDecl ::+  Ann PExpr -> (Maybe (Ann Declaration), [AnnP ParseValidationError])+convertConstraintDecl (Ann pexpr loc) = case pexpr of+  -- @sig requiring bound, ...@+  Compound "requiring" [sig, bounds] -> case sig.node of+    Compound name args ->+      let (argTypeErrs, argTypes) = partitionEithers (map convertTypeExpr args)+          (boundErrs, bs) =+            partitionEithers (map convertBoundSig (flattenComma bounds))+       in case argTypeErrs ++ boundErrs of+            [] ->+              ( Just+                  ( Ann+                      ( ConstraintDecl+                          name+                          (length args)+                          (Just argTypes)+                          (Just bs)+                      )+                      loc+                  ),+                []+              )+            errs -> (Nothing, errs)+    _ -> (Nothing, [AnnP MalformedDeclaration loc pexpr])+  -- Untyped: name/arity+  Compound "/" [Ann (Atom name) _, Ann (P.Int arity) _] ->+    (Just (Ann (ConstraintDecl name (fromInteger arity) Nothing Nothing) loc), [])+  -- Typed: name(type, ...)+  Compound name args -> case partitionEithers (map convertTypeExpr args) of+    ([], argTypes) ->+      ( Just+          ( Ann+              (ConstraintDecl name (length args) (Just argTypes) Nothing)+              loc+          ),+        []+      )+    (errs, _) -> (Nothing, errs)+  -- Zero-arity bare atom+  Atom name ->+    (Just (Ann (ConstraintDecl name 0 Nothing Nothing) loc), [])+  _ -> (Nothing, [AnnP MalformedDeclaration loc pexpr])++-- | Convert a PExpr to a closed-function declaration.+convertFunctionDecl ::+  Ann PExpr -> (Maybe (Ann Declaration), [AnnP ParseValidationError])+convertFunctionDecl = convertFunctionDeclWith False DKFunction++-- | Convert a PExpr to an open-function declaration.+convertOpenFunctionDecl ::+  Ann PExpr -> (Maybe (Ann Declaration), [AnnP ParseValidationError])+convertOpenFunctionDecl = convertFunctionDeclWith True DKFunction++-- | Convert a PExpr to a closed-class declaration.+convertClassDecl ::+  Ann PExpr -> (Maybe (Ann Declaration), [AnnP ParseValidationError])+convertClassDecl = convertFunctionDeclWith False DKClass++-- | Convert a PExpr to an open-class declaration.+convertOpenClassDecl ::+  Ann PExpr -> (Maybe (Ann Declaration), [AnnP ParseValidationError])+convertOpenClassDecl = convertFunctionDeclWith True DKClass++-- | Convert a PExpr to an extension type declaration. Targets+-- @:- open_class@ declarations and adds an overloaded signature.+-- Only the typed form @name(types) -> type@ is supported.+--+-- A @requiring@ clause on an @:- extend_class_type@ is rejected+-- syntactically: bounds belong to the original declaration, not to+-- an extension. The inner signature is still converted so that any+-- sub-errors (malformed type expressions) are reported alongside the+-- 'RequiringOnExtendClassType' error.+convertExtendClassTypeDecl ::+  Ann PExpr -> (Maybe (Ann Declaration), [AnnP ParseValidationError])+convertExtendClassTypeDecl (Ann pexpr loc) = case pexpr of+  -- @requiring@ is Xfx, so the inner @sig@ is never another @requiring@.+  Compound "requiring" [sig, _] ->+    let (mDecl, errs) = convertSig sig+        targetName = case sig.node of+          Compound "->" [Ann (Compound n _) _, _] -> n+          _ -> "<unknown>"+        reqErr = AnnP (RequiringOnExtendClassType targetName) loc pexpr+     in (mDecl, reqErr : errs)+  _ -> convertSig (Ann pexpr loc)+  where+    convertSig (Ann e l) = case e of+      Compound "->" [Ann (Compound name args) _, ret] ->+        case (partitionEithers (map convertTypeExpr args), convertTypeExpr ret) of+          (([], argTypes), Right retType) ->+            ( Just+                ( Ann+                    ( ExtendClassTypeDecl+                        name+                        (length args)+                        (Just argTypes)+                        (Just retType)+                        Nothing+                    )+                    l+                ),+              []+            )+          ((argErrs, _), retE) ->+            (Nothing, argErrs ++ leftToList retE)+      _ -> (Nothing, [AnnP MalformedDeclaration l e])++-- | Shared implementation of 'convertFunctionDecl',+-- 'convertOpenFunctionDecl', 'convertClassDecl' and+-- 'convertOpenClassDecl'. The 'Bool' argument is the @open@ flag and+-- the 'FunctionDeclKind' selects between @:- function@ and @:- class@.+-- Malformed declarations are dropped and reported via errors.+convertFunctionDeclWith ::+  Bool ->+  FunctionDeclKind ->+  Ann PExpr ->+  (Maybe (Ann Declaration), [AnnP ParseValidationError])+convertFunctionDeclWith open kind (Ann pexpr loc) = case pexpr of+  -- @name(types) -> ret requiring bound, ...@+  Compound "requiring" [sig, bounds] -> case sig.node of+    Compound "->" [Ann (Compound name args) _, ret] ->+      let (argErrs, argTypes) = partitionEithers (map convertTypeExpr args)+          retResult = convertTypeExpr ret+          (boundErrs, bs) =+            partitionEithers (map convertBoundSig (flattenComma bounds))+       in case (argErrs, retResult, boundErrs) of+            ([], Right retType, []) ->+              ( Just+                  ( Ann+                      ( FunctionDecl+                          name+                          (length args)+                          (Just argTypes)+                          (Just retType)+                          open+                          kind+                          (Just bs)+                      )+                      loc+                  ),+                []+              )+            _ -> (Nothing, argErrs ++ leftToList retResult ++ boundErrs)+    _ -> (Nothing, [AnnP MalformedDeclaration loc pexpr])+  -- Untyped: name/arity+  Compound "/" [Ann (Atom name) _, Ann (P.Int arity) _] ->+    ( Just+        ( Ann+            ( FunctionDecl+                name+                (fromInteger arity)+                Nothing+                Nothing+                open+                kind+                Nothing+            )+            loc+        ),+      []+    )+  -- Typed: name(type, ...) -> type+  Compound "->" [Ann (Compound name args) _, ret] ->+    case (partitionEithers (map convertTypeExpr args), convertTypeExpr ret) of+      (([], argTypes), Right retType) ->+        ( Just+            ( Ann+                ( FunctionDecl+                    name+                    (length args)+                    (Just argTypes)+                    (Just retType)+                    open+                    kind+                    Nothing+                )+                loc+            ),+          []+        )+      ((argErrs, _), retE) -> (Nothing, argErrs ++ leftToList retE)+  _ -> (Nothing, [AnnP MalformedDeclaration loc pexpr])++-- | Lift a single 'Left' into a singleton list of errors, dropping the+-- 'Right' case. Used when threading 'Either'-based sub-conversion+-- results into an accumulating @[error]@ list.+leftToList :: Either e a -> [e]+leftToList = either pure (const [])++-- | Convert a single bound signature inside a @requiring@ clause. The+-- expected shape is @name(τ₁, ..., τₙ) -> τᵣ@; a bare @name -> τᵣ@ is+-- treated as a zero-arity bound. A malformed shape (or a malformed type+-- inside) is returned as 'Left'; the enclosing declaration is then+-- dropped.+convertBoundSig :: Ann PExpr -> Either (AnnP ParseValidationError) BoundSig+convertBoundSig (Ann pexpr loc) = case pexpr of+  Compound "->" [Ann (Compound name args) _, ret] -> do+    argTypes <- traverse convertTypeExpr args+    returnType <- convertTypeExpr ret+    Right+      BoundSig+        { name = Unqualified name,+          arity = length args,+          argTypes,+          returnType,+          loc+        }+  Compound "->" [Ann (Atom name) _, ret] -> do+    returnType <- convertTypeExpr ret+    Right+      BoundSig+        { name = Unqualified name,+          arity = 0,+          argTypes = [],+          returnType,+          loc+        }+  _ -> Left (AnnP MalformedBoundSig loc pexpr)++-- | Convert a PExpr to a 'TypeExpr'.+--+-- Returns 'Left' with a 'MalformedTypeExpr' error when the input is not+-- a variable, atom, or compound term (e.g. a stray literal or string in+-- a type position).+--+-- See Note [Qualified name handling].+convertTypeExpr :: Ann PExpr -> Either (AnnP ParseValidationError) TypeExpr+convertTypeExpr (Ann pexpr loc) = case pexpr of+  Var t -> Right (TypeVar t)+  Atom "[]" -> Right (TypeCon (Unqualified "[]") [])+  Atom name -> Right (TypeCon (Unqualified name) [])+  Compound ":" [Ann (Atom m) _, Ann (Atom n) _] ->+    Right (TypeCon (Qualified m n) [])+  Compound ":" [Ann (Atom m) _, Ann (Compound n args) _] ->+    TypeCon (Qualified m n) <$> traverse convertTypeExpr args+  Compound "." args ->+    TypeCon (Unqualified ".") <$> traverse convertTypeExpr args+  Compound name args ->+    TypeCon (Unqualified name) <$> traverse convertTypeExpr args+  _ -> Left (AnnP MalformedTypeExpr loc pexpr)++-- | Convert a PExpr to a 'TypeDefinition'. Returns 'Nothing' and a+-- 'MalformedTypeDefinition' (or 'MalformedDataConstructor' /+-- 'MalformedTypeExpr' from sub-conversions) error if the definition+-- cannot be converted.+convertTypeDefinition ::+  Ann PExpr -> (Maybe (Ann TypeDefinition), [AnnP ParseValidationError])+convertTypeDefinition (Ann pexpr loc) = case pexpr of+  -- name(Vars) ---> con1 ; con2 ; ...+  Compound "--->" [typeHead, alts] -> case typeHeadShape typeHead.node of+    Nothing -> (Nothing, [AnnP MalformedTypeDefinition loc pexpr])+    Just (tname, tvars) ->+      case partitionEithers+        (map convertDataConstructor (flattenSemicolon alts)) of+        ([], cons) ->+          ( Just+              ( Ann+                  (TypeDefinition (Unqualified tname) tvars (Algebraic cons) loc)+                  loc+              ),+            []+          )+        (errs, _) -> (Nothing, errs)+  _ -> (Nothing, [AnnP MalformedTypeDefinition loc pexpr])+  where+    typeHeadShape (Atom n) = Just (n, [])+    typeHeadShape (Compound n vars) = Just (n, [v | Ann (Var v) _ <- vars])+    typeHeadShape _ = Nothing++-- | Convert the body of a @:- opaque_type@ directive to an opaque+-- 'TypeDefinition'. An opaque type has no data constructors, so a+-- constructor body (@---> ...@) is rejected with+-- 'OpaqueTypeHasConstructors'; any other non-head shape is+-- 'MalformedOpaqueTypeDefinition'.+convertOpaqueTypeDefinition ::+  Ann PExpr -> (Maybe (Ann TypeDefinition), [AnnP ParseValidationError])+convertOpaqueTypeDefinition (Ann pexpr loc) = case pexpr of+  Compound "--->" _ -> (Nothing, [AnnP OpaqueTypeHasConstructors loc pexpr])+  Atom n -> (Just (mk n []), [])+  Compound n vars -> (Just (mk n [v | Ann (Var v) _ <- vars]), [])+  _ -> (Nothing, [AnnP MalformedOpaqueTypeDefinition loc pexpr])+  where+    mk tname tvars =+      Ann (TypeDefinition (Unqualified tname) tvars Opaque loc) loc++-- | Convert a PExpr to a 'DataConstructor'. Returns 'Left' if the+-- constructor or any of its argument types is malformed.+convertDataConstructor ::+  Ann PExpr -> Either (AnnP ParseValidationError) DataConstructor+convertDataConstructor (Ann pexpr loc) = case pexpr of+  Atom "[]" -> Right (DataConstructor (Unqualified "[]") [])+  Atom name -> Right (DataConstructor (Unqualified name) [])+  -- [T|list(T)] — list constructor sugar+  Compound "." args ->+    DataConstructor (Unqualified ".") <$> traverse convertTypeExpr args+  Compound name args ->+    DataConstructor (Unqualified name) <$> traverse convertTypeExpr args+  _ -> Left (AnnP MalformedDataConstructor loc pexpr)++-- ** Rule conversion++-- | Convert a top-level PExpr to a 'Rule', collecting any+-- 'MalformedConstraint' errors found in its head.+--+-- Returns 'Nothing' and a 'MalformedTopLevel' error when the input is+-- not a recognized rule shape (named or unnamed @\<=\>@/@==\>@).+convertRule :: Ann PExpr -> (Maybe Rule, [AnnP ParseValidationError])+convertRule expr =+  let (mName, ruleExpr) = case expr.node of+        Compound "@" [Ann (Atom name) nameLoc, body] ->+          (Just (Ann name nameLoc), body)+        _ -> (Nothing, expr)+   in case ruleExpr.node of+        Compound "<=>" [h, gb] ->+          let (head_, headErrs) = convertHead h+              (guard_, body_) = splitGuardBody gb+           in (Just (Rule mName head_ guard_ body_), headErrs)+        Compound "==>" [h, gb] ->+          let (head_, headErrs) = convertPropagationHead h+              (guard_, body_) = splitGuardBody gb+           in (Just (Rule mName head_ guard_ body_), headErrs)+        _ -> (Nothing, [AnnP MalformedTopLevel expr.sourceLoc expr.node])++-- | Convert the head of a simplification or simpagation rule. Malformed+-- constraints are dropped from the resulting head and reported as errors.+convertHead :: Ann PExpr -> (AnnP Head, [AnnP ParseValidationError])+convertHead (Ann pexpr loc) = case pexpr of+  Compound "\\" [kept, removed] ->+    let (keptErrs, keptOk) = partitionEithers (map convertConstraint (flattenComma kept))+        ( removedErrs,+          removedOk+          ) = partitionEithers (map convertConstraint (flattenComma removed))+     in (AnnP (Simpagation keptOk removedOk) loc pexpr, keptErrs ++ removedErrs)+  _ ->+    let constraints = flattenComma (Ann pexpr loc)+        (errs, ok) = partitionEithers (map convertConstraint constraints)+     in (AnnP (Simplification ok) loc pexpr, errs)++-- | Convert the head of a propagation rule. Malformed constraints are+-- dropped from the resulting head and reported as errors.+convertPropagationHead :: Ann PExpr -> (AnnP Head, [AnnP ParseValidationError])+convertPropagationHead (Ann pexpr loc) =+  let (errs, ok) = partitionEithers (map convertConstraint (flattenComma (Ann pexpr loc)))+   in (AnnP (Propagation ok) loc pexpr, errs)++-- | Split a guard|body PExpr into guard and body term lists.+splitGuardBody :: Ann PExpr -> (AnnP [Term], AnnP [Term])+splitGuardBody expr = case expr.node of+  Compound "|" [guard_, body_] ->+    ( AnnP (map convertTerm (flattenComma guard_)) guard_.sourceLoc guard_.node,+      AnnP (map convertTerm (flattenComma body_)) body_.sourceLoc body_.node+    )+  _ ->+    ( noAnnPAt expr.sourceLoc [],+      AnnP (map convertTerm (flattenComma expr)) expr.sourceLoc expr.node+    )++-- ** Function equation conversion++-- | Convert a top-level PExpr to a 'FunctionEquation'. Returns 'Nothing'+-- and a 'MalformedFunctionEquation' error when the input is not of the+-- expected @lhs [| guard] -> rhs@ shape.+convertFunctionEquation ::+  Ann PExpr -> (Maybe (AnnP FunctionEquation), [AnnP ParseValidationError])+convertFunctionEquation (Ann pexpr loc) = case pexpr of+  Compound "->" [lhs, rhs] -> case lhs.node of+    -- Guarded: lhs_pattern | guard -> rhs+    Compound "|" [pat, guard_] -> case extractFunNameArgs pat of+      Just (name, args) ->+        ( Just+            ( AnnP+                ( FunctionEquation+                    (Unqualified name)+                    args+                    ( AnnP+                        (map convertTerm (flattenComma guard_))+                        guard_.sourceLoc+                        guard_.node+                    )+                    (AnnP (convertRhsSequence rhs) rhs.sourceLoc rhs.node)+                )+                loc+                pexpr+            ),+          []+        )+      Nothing -> (Nothing, [AnnP MalformedFunctionEquation loc pexpr])+    -- Unguarded: lhs_pattern -> rhs+    _ -> case extractFunNameArgs lhs of+      Just (name, args) ->+        ( Just+            ( AnnP+                ( FunctionEquation+                    (Unqualified name)+                    args+                    (noAnnPAt lhs.sourceLoc [])+                    (AnnP (convertRhsSequence rhs) rhs.sourceLoc rhs.node)+                )+                loc+                pexpr+            ),+          []+        )+      Nothing -> (Nothing, [AnnP MalformedFunctionEquation loc pexpr])+  _ -> (Nothing, [AnnP MalformedFunctionEquation loc pexpr])++-- | Flatten a function-equation RHS (or lambda body) on the top-level+-- comma operator. Non-empty by construction.+convertRhsSequence :: Ann PExpr -> NE.NonEmpty Term+convertRhsSequence = fmap convertTerm . flattenComma1++-- | Extract the function name and argument list from an equation LHS.+--+-- Handles prefix notation @name(args)@ and operator notation @X op Y@+-- (which parses as @Compound op [X, Y]@). Returns 'Nothing' if the LHS+-- is a literal, variable, wildcard, or string.+extractFunNameArgs :: Ann PExpr -> Maybe (Text, [Term])+extractFunNameArgs (Ann pexpr _) = case pexpr of+  -- Prefix: name(arg1, arg2, ...) — also covers operator notation.+  Compound name args -> Just (name, map convertTerm args)+  -- Bare atom (zero-arity function)+  Atom name -> Just (name, [])+  _ -> Nothing
+ src/YCHR/Internal/Parsing/Lexer.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Lexer helpers shared by 'YCHR.Internal.SExpr' and 'YCHR.Internal.PExpr'.+--+-- A small set of parsec combinators that mimic the parts of+-- 'Text.Megaparsec.Char.Lexer' the codebase used to depend on:+-- whitespace + line-comment consumer ('space'), 'lexeme', 'symbol',+-- integer 'decimal', and a permissive C-style 'charLiteral'.+module YCHR.Internal.Parsing.Lexer+  ( space,+    space1,+    lexeme,+    symbol,+    decimal,+    charLiteral,+    skipLineComment,+  )+where++import Data.Text (Text)+import Data.Text qualified as T+import Text.Parsec (ParsecT, Stream, (<|>))+import Text.Parsec qualified as P+import Text.Parsec.Char qualified as PC++-- | Whitespace + optional line-comment consumer. Mirrors+-- 'Text.Megaparsec.Char.Lexer.space'. The third argument (block+-- comments) is omitted because the YCHR grammars don't use them.+space :: (Stream s m Char) => ParsecT s u m () -> ParsecT s u m () -> ParsecT s u m ()+space ws lineCmt = P.skipMany (ws <|> lineCmt)++-- | One or more whitespace characters. Replaces+-- 'Text.Megaparsec.Char.space1'.+space1 :: (Stream s m Char) => ParsecT s u m ()+space1 = P.skipMany1 PC.space++-- | Run @p@, then consume trailing whitespace with @sc@.+lexeme :: (Stream s m Char) => ParsecT s u m () -> ParsecT s u m a -> ParsecT s u m a+lexeme sc p = p <* sc++-- | Parse a fixed text symbol and consume trailing whitespace.+symbol :: (Stream s m Char) => ParsecT s u m () -> Text -> ParsecT s u m Text+symbol sc s = lexeme sc (T.pack <$> PC.string (T.unpack s))++-- | Parse one or more decimal digits as an 'Integer' (arbitrary precision).+decimal :: (Stream s m Char) => ParsecT s u m Integer+decimal = read <$> P.many1 PC.digit++-- | Skip everything from a literal prefix to (but not including) the+-- end-of-line. Mirrors 'Text.Megaparsec.Char.Lexer.skipLineComment'.+skipLineComment :: (Stream s m Char) => Text -> ParsecT s u m ()+skipLineComment prefix = do+  _ <- PC.string (T.unpack prefix)+  _ <- P.manyTill PC.anyChar (P.lookAhead (P.eof <|> (() <$ PC.char '\n')))+  pure ()++-- | A permissive character literal that interprets a small set of+-- common escape sequences. Used inside double-quoted s-expression+-- strings; the caller is responsible for the surrounding quotes.+charLiteral :: (Stream s m Char) => ParsecT s u m Char+charLiteral = do+  c <- PC.anyChar+  case c of+    '\\' -> escape+    _ -> pure c+  where+    escape =+      P.choice+        [ '\n' <$ PC.char 'n',+          '\t' <$ PC.char 't',+          '\r' <$ PC.char 'r',+          '\\' <$ PC.char '\\',+          '"' <$ PC.char '"',+          '\'' <$ PC.char '\'',+          PC.anyChar+        ]
+ src/YCHR/Internal/Pretty.hs view
@@ -0,0 +1,415 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Pretty-printing utilities for CHR terms and binding maps.+module YCHR.Internal.Pretty+  ( -- * Pretty-printing functions+    prettyTerm,+    prettyBindings,+    prettyQueryResult,+    prettyTermSrc,+    prettyConstraintSrc,+    prettyHeadSrc,+    prettyRuleSrc,+    prettyPExprSrc,+    renderAtom,++    -- * Declaration pretty-printers+    DeclKind (..),+    prettyQualifiedName,+    prettyConstraintDecl,+    prettyFunctionDecl,+    prettyTypeDecl,+    prettyTypeExpr,+  )+where++import Data.Char (isUpper)+import Data.List (intercalate)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import YCHR.Internal.Loc (Ann (..), noAnn)+import YCHR.Internal.PExpr qualified as PE+import YCHR.Internal.Parsed qualified as P+import YCHR.Internal.Parser (builtinOps)+import YCHR.Internal.Types+  ( BoundSig (..),+    Constraint (..),+    DataConstructor (..),+    Name (..),+    QualifiedName (..),+    Term (..),+    TypeDefinition (..),+    TypeExpr (..),+    TypeKind (..),+  )++-- ---------------------------------------------------------------------------+-- Operator table for source pretty-printing+-- ---------------------------------------------------------------------------++-- | Operator table for source pretty-printing.+-- Extends 'builtinOps' with the standard arithmetic\/comparison operators+-- from the builtins library.+prettyOps :: PE.OpTable+prettyOps = case PE.mergeOps builtinOps stdArithOps of+  Right t -> t+  Left _ -> builtinOps+  where+    stdArithOps =+      [ (200, PE.Fy, "-"),+        (500, PE.Yfx, "+"),+        (500, PE.Yfx, "-"),+        (400, PE.Yfx, "*"),+        (400, PE.Yfx, "div"),+        (400, PE.Yfx, "mod"),+        (400, PE.Yfx, "rem"),+        (700, PE.Xfx, "<"),+        (700, PE.Xfx, ">"),+        (700, PE.Xfx, ">="),+        (700, PE.Xfx, "=<"),+        (700, PE.Xfx, "==")+      ]++-- ---------------------------------------------------------------------------+-- AST → PExpr conversion+-- ---------------------------------------------------------------------------++-- | Convert a 'Term' to a 'PE.PExpr'.+-- This is the inverse of 'convertTerm' in "YCHR.Internal.Parser".+termToPExpr :: Term -> PE.PExpr+termToPExpr (VarTerm v) = PE.Var v+termToPExpr (IntTerm n) = PE.Int n+termToPExpr (FloatTerm n) = PE.Float n+termToPExpr (TextTerm s) = PE.Str s+termToPExpr Wildcard = PE.Wildcard+termToPExpr (CompoundTerm (Unqualified f) []) = PE.Atom f+termToPExpr (CompoundTerm (Qualified m f) []) =+  PE.Compound ":" [noAnn (PE.Atom m), noAnn (PE.Atom f)]+termToPExpr (CompoundTerm (Qualified m f) args) =+  PE.Compound ":" [noAnn (PE.Atom m), noAnn (PE.Compound f (map (noAnn . termToPExpr) args))]+termToPExpr (CompoundTerm (Unqualified f) args) =+  PE.Compound f (map (noAnn . termToPExpr) args)++-- | Convert a 'Constraint' to a 'PE.PExpr'.+-- This is the inverse of 'convertConstraint' in "YCHR.Internal.Parser".+constraintToPExpr :: Constraint -> PE.PExpr+constraintToPExpr (Constraint (Unqualified name) args) =+  PE.Compound name (map (noAnn . termToPExpr) args)+constraintToPExpr (Constraint (Qualified m name) args) =+  PE.Compound+    ":"+    [ noAnn (PE.Atom m),+      noAnn (PE.Compound name (map (noAnn . termToPExpr) args))+    ]++-- | Convert a parsed 'P.Head' to a 'PE.PExpr'.+headToPExpr :: P.Head -> PE.PExpr+headToPExpr (P.Simplification cs) = commaSepPExpr (map constraintToPExpr cs)+headToPExpr (P.Propagation cs) = commaSepPExpr (map constraintToPExpr cs)+headToPExpr (P.Simpagation ks rs) =+  PE.Compound+    "\\"+    [ noAnn (commaSepPExpr (map constraintToPExpr ks)),+      noAnn (commaSepPExpr (map constraintToPExpr rs))+    ]++-- | Convert a parsed 'P.Rule' to a 'PE.PExpr'.+ruleToPExpr :: P.Rule -> PE.PExpr+ruleToPExpr r =+  let headPE = headToPExpr r.head.node+      arrow = case r.head.node of+        P.Propagation {} -> "==>"+        _ -> "<=>"+      bodyPE = commaSepPExpr (map termToPExpr r.body.node)+      guardAndBody = case r.guard.node of+        [] -> bodyPE+        gs -> PE.Compound "|" [noAnn (commaSepPExpr (map termToPExpr gs)), noAnn bodyPE]+      arrowExpr = PE.Compound arrow [noAnn headPE, noAnn guardAndBody]+   in case r.name of+        Nothing -> arrowExpr+        Just ann -> PE.Compound "@" [noAnn (PE.Atom ann.node), noAnn arrowExpr]++-- | Right-fold a list of 'PE.PExpr' into a comma-operator chain.+commaSepPExpr :: [PE.PExpr] -> PE.PExpr+commaSepPExpr [] = PE.Atom "true"+commaSepPExpr [x] = x+commaSepPExpr (x : xs) = PE.Compound "," [noAnn x, noAnn (commaSepPExpr xs)]++-- ---------------------------------------------------------------------------+-- Surface pretty-printers (via PExpr)+-- ---------------------------------------------------------------------------++-- | Render a 'Term' as valid surface-language source text.+-- Unlike 'prettyTerm', variable names are preserved rather than collapsed to @_@.+prettyTermSrc :: Term -> String+prettyTermSrc = PE.prettyPExpr prettyOps . termToPExpr++-- | Render a 'Constraint' as valid surface-language source text.+prettyConstraintSrc :: Constraint -> String+prettyConstraintSrc = PE.prettyPExpr prettyOps . constraintToPExpr++-- | Render a parsed 'P.Head' as valid surface-language source text.+prettyHeadSrc :: P.Head -> String+prettyHeadSrc = PE.prettyPExpr prettyOps . headToPExpr++-- | Render a parsed 'P.Rule' as valid surface-language source text.+prettyRuleSrc :: P.Rule -> String+prettyRuleSrc r = PE.prettyPExpr prettyOps (ruleToPExpr r) ++ "."++-- | Render an atom, quoting with @\'...\'@ if necessary.+renderAtom :: Text -> String+renderAtom = PE.renderAtom prettyOps.wordOpSet++-- ---------------------------------------------------------------------------+-- Runtime pretty-printer (via PExpr)+-- ---------------------------------------------------------------------------++-- | Render a 'Term' as a Prolog-compatible string.+-- 'Wildcard' is shown as @_@; 'VarTerm' is shown by its name (it+-- appears here only when 'YCHR.Internal.Meta.valueToTerm' decided to surface+-- an alias for an unbound variable).+-- Operators are displayed using their declared fixity and precedence.+prettyTerm :: Term -> String+prettyTerm = PE.prettyPExpr prettyOps . runtimeToPExpr++-- | Convert a runtime 'Term' to a 'PE.PExpr' for pretty-printing.+-- Like 'termToPExpr' but renders 'Wildcard' as @_@ (the form+-- 'YCHR.Internal.Meta.valueToTerm' uses for unaliased free variables) and+-- unwraps closure terms to show their source form.+runtimeToPExpr :: Term -> PE.PExpr+runtimeToPExpr (VarTerm v) = PE.Var v+runtimeToPExpr Wildcard = PE.Wildcard+runtimeToPExpr (CompoundTerm (Unqualified "__closure") (_ : sourceForm : _)) =+  unquoteToPExpr sourceForm+-- Canonicalized cons/nil: render as the surface list syntax. This+-- mirrors the analogous case in 'YCHR.Internal.Meta.valueToTerm', kept here too+-- because Term values constructed without going through 'valueToTerm'+-- (e.g. round-trips of already-rendered runtime values) still hit+-- this path.+runtimeToPExpr (CompoundTerm (Unqualified "prelude__[]") []) = PE.Atom "[]"+runtimeToPExpr (CompoundTerm (Qualified "prelude" "[]") []) = PE.Atom "[]"+runtimeToPExpr (CompoundTerm (Unqualified "prelude__.") args) =+  PE.Compound "." (map (noAnn . runtimeToPExpr) args)+runtimeToPExpr (CompoundTerm (Unqualified f) []) = PE.Atom f+runtimeToPExpr (CompoundTerm (Qualified m f) []) =+  PE.Compound ":" [noAnn (PE.Atom m), noAnn (PE.Atom f)]+runtimeToPExpr (CompoundTerm (Qualified m f) args) =+  PE.Compound+    ":"+    [ noAnn (PE.Atom m),+      noAnn (PE.Compound f (map (noAnn . runtimeToPExpr) args))+    ]+runtimeToPExpr (CompoundTerm (Unqualified f) args) =+  PE.Compound f (map (noAnn . runtimeToPExpr) args)+runtimeToPExpr (IntTerm n) = PE.Int n+runtimeToPExpr (FloatTerm n) = PE.Float n+runtimeToPExpr (TextTerm s) = PE.Str s++-- | Like 'runtimeToPExpr' but reverses the 'quoteTerm' transformation:+-- atoms that look like variable names (start with uppercase or @_@) are+-- rendered as variables. Used for closure source forms where 'quoteTerm'+-- has turned @VarTerm v@ into a 0-arity unqualified compound.+unquoteToPExpr :: Term -> PE.PExpr+unquoteToPExpr (CompoundTerm (Unqualified s) [])+  | Just (c, _) <- T.uncons s, isUpper c || c == '_' = PE.Var s+  | otherwise = PE.Atom s+unquoteToPExpr (CompoundTerm (Unqualified f) args) =+  PE.Compound f (map (noAnn . unquoteToPExpr) args)+unquoteToPExpr (CompoundTerm (Qualified m f) []) =+  PE.Compound ":" [noAnn (PE.Atom m), noAnn (PE.Atom f)]+unquoteToPExpr (CompoundTerm (Qualified m f) args) =+  PE.Compound+    ":"+    [ noAnn (PE.Atom m),+      noAnn (PE.Compound f (map (noAnn . unquoteToPExpr) args))+    ]+unquoteToPExpr t = runtimeToPExpr t++-- ---------------------------------------------------------------------------+-- User-facing output (binding map)+-- ---------------------------------------------------------------------------++-- | Serialize a variable binding map to the golden file format.+--+-- Keys are sorted alphabetically for determinism. Each line has the form+-- @K = V@ followed by a newline, matching the output of 'unlines'.+prettyBindings :: Map Text Term -> String+prettyBindings m =+  unlines [T.unpack k ++ " = " ++ prettyTerm v | (k, v) <- Map.toAscList m]++-- | Render a variable binding map as a Prolog-style query result.+--+-- Variables starting with @_@ are filtered out (internal/wildcard).+-- If no user-visible bindings remain, returns an empty string.+-- Otherwise, comma-separated @K = V@ lines terminated with a dot.+prettyQueryResult :: Map Text Term -> String+prettyQueryResult m =+  let visible = [(k, v) | (k, v) <- Map.toAscList m, not ("_" `T.isPrefixOf` k)]+   in case visible of+        [] -> ""+        _ -> formatBindings visible+  where+    formatBindings [] = ""+    formatBindings [(k, v)] = T.unpack k ++ " = " ++ prettyTerm v ++ ".\n"+    formatBindings ((k, v) : rest) =+      T.unpack k ++ " = " ++ prettyTerm v ++ ",\n" ++ formatBindings rest++-- | Render a 'PExpr' as valid surface-language source text.+prettyPExprSrc :: PE.PExpr -> String+prettyPExprSrc = PE.prettyPExpr prettyOps++-- ---------------------------------------------------------------------------+-- Declaration pretty-printers (used by the REPL @:info@ command)+-- ---------------------------------------------------------------------------++-- | The four flavors a 'FunctionDef' can have, recovered by the+-- @:info@ command from the original 'P.Declaration' kept in+-- 'CompiledProgram.allModules'.+data DeclKind+  = DKFunction+  | DKOpenFunction+  | DKClass+  | DKOpenClass+  deriving (Show, Eq)++declKindKeyword :: DeclKind -> String+declKindKeyword DKFunction = "function"+declKindKeyword DKOpenFunction = "open_function"+declKindKeyword DKClass = "class"+declKindKeyword DKOpenClass = "open_class"++-- | Convert a 'TypeExpr' to a 'PE.PExpr' for pretty-printing. The+-- module qualifier on 'Qualified' constructors is intentionally+-- dropped: declaration-body rendering follows the user-facing+-- source form where types are usually written unqualified. The+-- qualified name is still shown on the header line of @:info@+-- output, so no information is lost. The special case for+-- @TypeCon (Unqualified ".") args@ preserves the surface @[H|T]@+-- list-cons syntax.+typeExprToPExpr :: TypeExpr -> PE.PExpr+typeExprToPExpr (TypeVar v) = PE.Var v+typeExprToPExpr (TypeCon (Unqualified ".") args) =+  PE.Compound "." (map (noAnn . typeExprToPExpr) args)+typeExprToPExpr (TypeCon name []) = PE.Atom (typeConBaseName name)+typeExprToPExpr (TypeCon name args) =+  PE.Compound (typeConBaseName name) (map (noAnn . typeExprToPExpr) args)++typeConBaseName :: Name -> Text+typeConBaseName (Unqualified n) = n+typeConBaseName (Qualified _ n) = n++-- | Render a 'TypeExpr' as valid surface-language source text.+prettyTypeExpr :: TypeExpr -> String+prettyTypeExpr = PE.prettyPExpr prettyOps . typeExprToPExpr++-- | Render a 'QualifiedName' as @mod:name@ with both halves atom-quoted+-- where necessary (so @prelude:'+'@ comes out correctly).+prettyQualifiedName :: QualifiedName -> String+prettyQualifiedName (QualifiedName m n) = renderAtom m ++ ":" ++ renderAtom n++-- | Render a function signature @name(T1, ..., Tn) -> Tret@. The name+-- is rendered through 'renderAtom' so operator names like @'+'@ quote+-- correctly. Used for both standalone declarations and elements of a+-- multi-sig @:- class@ list.+prettyFunSig :: Text -> [TypeExpr] -> TypeExpr -> String+prettyFunSig name argTys retTy =+  renderAtom name+    ++ "("+    ++ intercalate ", " (map prettyTypeExpr argTys)+    ++ ") -> "+    ++ prettyTypeExpr retTy++-- | Render a single bound signature in a @requiring@ clause, using+-- the bound's base name (qualified-name module is dropped to match+-- the surface @requiring@ form).+prettyBoundSig :: BoundSig -> String+prettyBoundSig b =+  let baseName = case b.name of+        Unqualified n -> n+        Qualified _ n -> n+   in prettyFunSig baseName b.argTypes b.returnType++-- | Render a list of bounds as the @requiring B1, B2, ..., Bn@ trailer+-- (no leading space, no trailing period). Empty input renders as the+-- empty string so callers can append unconditionally.+prettyRequiring :: [BoundSig] -> String+prettyRequiring [] = ""+prettyRequiring bs = " requiring " ++ intercalate ", " (map prettyBoundSig bs)++-- | Render a @:- chr_constraint@ declaration. The base name (not the+-- qualified form) is used inside the declaration body, matching the+-- surface syntax users write. Untyped constraints use the @name/arity@+-- form; typed constraints use the @name(T1, ..., Tn)@ form, optionally+-- followed by a @requiring@ clause.+prettyConstraintDecl :: QualifiedName -> Int -> Maybe [TypeExpr] -> [BoundSig] -> String+prettyConstraintDecl qn arity mArgTys bounds = case mArgTys of+  Nothing ->+    ":- chr_constraint " ++ renderAtom qn.baseName ++ "/" ++ show arity ++ "."+  Just argTys ->+    ":- chr_constraint "+      ++ renderAtom qn.baseName+      ++ "("+      ++ intercalate ", " (map prettyTypeExpr argTys)+      ++ ")"+      ++ prettyRequiring bounds+      ++ "."++-- | Render a function-flavored declaration (@:- function@,+-- @:- open_function@, @:- class@, @:- open_class@). Single-signature+-- forms stay on one line; multi-signature forms switch to the indented+-- per-line layout used in @libraries\/prelude.chr@. A @requiring@ clause+-- is only emitted for function-flavored kinds; it is rejected on+-- classes by the parser, so a non-empty bound list there is silently+-- dropped.+prettyFunctionDecl ::+  QualifiedName ->+  Int ->+  [([TypeExpr], TypeExpr)] ->+  [BoundSig] ->+  DeclKind ->+  String+prettyFunctionDecl qn arity sigs bounds kind =+  let keyword = declKindKeyword kind+      isFunction = kind == DKFunction || kind == DKOpenFunction+      reqStr = if isFunction then prettyRequiring bounds else ""+   in case sigs of+        [] ->+          -- An unsignatured function declaration falls back to the+          -- @name/arity@ form. This shape is not currently produced by+          -- the resolver but is handled here so the printer is total.+          ":- " ++ keyword ++ " " ++ renderAtom qn.baseName ++ "/" ++ show arity ++ "."+        [(argTys, retTy)] ->+          ":- " ++ keyword ++ " " ++ prettyFunSig qn.baseName argTys retTy ++ reqStr ++ "."+        _ ->+          let oneSig (argTys, retTy) = "    (" ++ prettyFunSig qn.baseName argTys retTy ++ ")"+           in ":- " ++ keyword ++ "\n" ++ intercalate ",\n" (map oneSig sigs) ++ reqStr ++ "."++-- | Render a @:- chr_type@ declaration: the type head (with its type+-- variables) followed by @--->@ and the list of data constructors+-- separated by @;@. The type's base name is used unqualified, matching+-- the surface form. Constructor rendering is routed through 'PE.PExpr'+-- so the empty-list atom and cons-cell list constructor render with+-- their surface @[]@ \/ @[H|T]@ syntax rather than as quoted @'[]'@ \/+-- @'.'(H, T)@.+prettyTypeDecl :: TypeDefinition -> String+prettyTypeDecl td =+  let tname = renderAtom (typeConBaseName td.name)+      head_ = case td.typeVars of+        [] -> tname+        vs -> tname ++ "(" ++ intercalate ", " (map T.unpack vs) ++ ")"+   in case td.kind of+        Opaque -> ":- opaque_type " ++ head_ ++ "."+        Algebraic cs ->+          ":- chr_type " ++ head_ ++ " ---> " ++ intercalate " ; " (map ctorToString cs) ++ "."++ctorToString :: DataConstructor -> String+ctorToString c =+  let baseName = case c.conName of+        Unqualified n -> n+        Qualified _ n -> n+      pexpr = case c.conArgs of+        [] -> PE.Atom baseName+        args -> PE.Compound baseName (map (noAnn . typeExprToPExpr) args)+   in PE.prettyPExpr prettyOps pexpr
+ src/YCHR/Internal/Rename.hs view
@@ -0,0 +1,1360 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module      : YCHR.Internal.Rename+-- Description : Resolves and qualifies symbolic names across a multi-module program.+--+-- The Renamer is a whole-program pass that replaces every surface+-- 'Unqualified' callable name with a 'Qualified' one built from its+-- declaring module. Its responsibilities are:+--+-- 1. /Global environment building/: one pass over all modules collects+--    declaration, export, data-constructor, type-declaration, and+--    type-export maps (see 'RenameCtx').+--+-- 2. /Namespace resolution/ for constraints, functions, and types. Both+--    'Unqualified' and fully 'Qualified' references are subject to the+--    same visibility rules: the target must be the current module or an+--    imported module that exports the name.+--+-- 3. /Export-list validation/: every entry in a @module M(..)@ directive+--    must correspond to a real declaration in @M@.+--+-- 4. /Ambiguity enforcement/: when multiple visible providers match an+--    unqualified name, the user is forced to qualify it.+--+-- 5. /Resolution-mode handling/: whether a compound-term functor is+--    resolved to a callable depends on where it appears (head argument+--    vs. rule body vs. guard or @is@-RHS). See 'ResolveMode'.+--+-- 6. /Special cases in 'renameTerm'/: @is@, lambdas (@fun(...) -> ...@),+--    function references (@name\/arity@), and zero-arity atom promotion+--    each have their own branch.+--+-- 7. /Data-constructor warnings/: unresolved names in expression contexts+--    emit a warning unless they match a declared data constructor.+--+-- 8. /Type-definition renaming/: type names and constructor names inside+--    'TypeDefinition' values are qualified with their declaring module.+--+-- This pass guarantees that the subsequent Desugaring phase can treat the+-- program as a flat, unambiguous collection of rules.+module YCHR.Internal.Rename+  ( -- * Entry points+    renameProgram,+    renameQueryGoals,+    renameQueryArgs,+    buildExportEnv,++    -- * Errors and warnings+    RenameError (..),+    RenameWarning (..),++    -- * Configuration+    RenameInputs (..),+    defaultRenameInputs,+  )+where++import Control.Monad (when)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Writer.CPS (Writer, WriterT, runWriter, runWriterT, tell)+import Data.Foldable (traverse_)+import Data.List (nub)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import YCHR.Internal.Collected (CollectedImport (..), CollectedModule (..))+import YCHR.Internal.Diagnostic (Diagnostic, noDiag)+import YCHR.Internal.PExpr (PExpr (Atom))+import YCHR.Internal.Parsed+import YCHR.Internal.Rename.Types+import YCHR.Internal.Types++data RenameError+  = AmbiguousName Text Int [Text]+  | UnknownName Text Int+  | UnknownExport Text Text Int+  | UnknownImport Text Text Int+  | -- | A qualified reference @M:n/a@ where @M@ /is/ imported by the+    -- current module but does not export @(n, arity)@ (or the name is+    -- excluded by a restricted import list). Carries the source module+    -- name, the name, and the arity. See 'ModuleNotImported' and+    -- 'UnknownModule' for the not-imported / non-existent cases.+    NotExportedByModule Text Text Int+  | -- | A qualified reference @M:n/a@ where module @M@ exists in the+    -- program but the current module never imports it (qualification+    -- does not bypass the import requirement). Carries the source+    -- module name, the name, and the arity.+    ModuleNotImported Text Text Int+  | -- | A qualified reference @M:n/a@ where no module named @M@ exists+    -- anywhere in the program. Carries the unknown module name.+    UnknownModule Text+  | -- | An @op(...)@ entry inside an import list refers to an operator+    -- that the source module does not export. Carries the source module+    -- name and the operator name.+    UnknownOperatorImport Text Text+  | -- | A @use_module(...)@ directive appears after a non-import directive+    -- (or any rule). Carries the imported module name.+    UseModuleOutOfOrder Text+  | -- | A @type(t/n, [c, ...])@ export or import entry names a constructor+    -- that is not declared on type @t@. Carries the source module name,+    -- the type name, the type arity, and the offending constructor name.+    UnknownExportedConstructor Text Text Int Text+  | -- | A qualified compound term @M:c/a@ names a data constructor that+    -- @M@ declares but does not export (per the @type(t/n, [...])@+    -- allowlist in @M@'s module header). Carries the source module+    -- name, the constructor name, and the arity.+    NonExportedConstructor Text Text Int+  | -- | A @type(t/n, [c, ...])@ entry in a @use_module@ import list+    -- names a constructor that @M@ declares on @t@ but does not export.+    -- Distinct from 'UnknownExportedConstructor' (which fires when the+    -- constructor is genuinely not declared). Carries the source module+    -- name, the type name, the type arity, and the offending+    -- constructor name.+    ConstructorNotExported Text Text Int Text+  | -- | An unqualified bare reference to a data constructor that is+    -- exported by more than one visible module. Parallel to+    -- 'AmbiguousName' (YCHR-20001) for the function/constraint+    -- namespace, but without arity: data constructors are not+    -- arity-overloadable, so the name alone identifies the clash.+    -- Carries the constructor name and the list of providers.+    AmbiguousDataConstructor Text [Text]+  deriving (Eq, Show)++data RenameWarning+  = UndeclaredDataConstructor Text+  | DataConstructorArityMismatch Text Int+  deriving (Eq, Show)++-- | Maps data constructor names to their declared arities (from type+-- declarations). A single name may be declared at several arities across+-- different types.+type DataConEnv = Map Text [Int]++-- | Maps @(constructorName, arity)@ to the list of modules that declare it.+-- Built from the same declarations as 'DataConEnv' but indexed and valued+-- so the renamer can canonicalize bare uses of declared constructors to+-- their qualified form (the runtime then sees one canonical flat atom).+type DataConProviders = Map (Text, Int) [Text]++-- | Identifier for a type declaration: declaring module + type name + arity.+-- Used as the key of constructor-visibility maps so that two distinct+-- types with the same unqualified name (in different modules) don't+-- collide.+data DeclaredType = DeclaredType+  { declaringModule :: Text,+    typeName :: Text,+    typeArity :: Int+  }+  deriving (Eq, Ord, Show)++-- | Renamer monad: two stacked 'Writer's, one for errors (inner) and+-- one for warnings (outer). Concrete type so callers don't need 'mtl'+-- classes; 'emitError' lifts past the warning layer.+type Rename = WriterT [Diagnostic RenameWarning] (Writer [Diagnostic RenameError])++emitError :: AnnP RenameError -> Rename ()+emitError e = lift (tell [noDiag e])++emitWarning :: AnnP RenameWarning -> Rename ()+emitWarning w = tell [noDiag w]++-- | Global environments consulted while renaming one module. Bundled+-- into a record so recursive helpers don't have to thread six parameters.+--+-- @currentModule@ is the module currently being renamed; it provides the+-- import list against which imported-name references are validated, and+-- the name used when a reference resolves to the module itself.+data RenameCtx = RenameCtx+  { declEnv :: DeclEnv,+    exportEnv :: ExportEnv,+    dataConEnv :: DataConEnv,+    dataConProviders :: DataConProviders,+    -- | All declared @(constructorName, arity)@ providers across the+    -- program, /unfiltered/ by visibility. Used to disambiguate+    -- diagnostics for qualified references: if a missing+    -- @'Qualified' m n@ matches an entry whose providers include @m@,+    -- the user named a real-but-hidden constructor and gets+    -- 'NonExportedConstructor'; otherwise they get 'NotExportedByModule'+    -- as before.+    allDataConProviders :: DataConProviders,+    typeDeclEnv :: DeclEnv,+    typeExportEnv :: ExportEnv,+    -- | Operators exported by each module, keyed by module name. Used to+    -- validate that an @op(...)@ entry in an import list names a real+    -- exported operator.+    operatorExports :: Map Text [OpDecl],+    -- | Source location at which header parsing stopped for the current+    -- module — i.e. the location of the first non-import directive.+    -- Imports beyond this location are out of order.+    currentTrailingLoc :: Maybe SourceLoc,+    -- | Every module name present in the program. Used to distinguish a+    -- qualified reference to a real-but-unimported module+    -- ('ModuleNotImported') from one to a non-existent module+    -- ('UnknownModule').+    allModuleNames :: [Text],+    currentModule :: CollectedModule+  }++-- | Inputs to 'renameProgram' beyond the module list itself. Lets the+-- caller supply per-module operator export tables and trailing-location+-- information without hard-coding additional parameters.+data RenameInputs = RenameInputs+  { -- | Map from module name to its exported operators (used to validate+    -- @op(...)@ entries inside import lists).+    operatorExports :: Map Text [OpDecl],+    -- | Map from module name to the source location where its header+    -- parsing stopped. Used to detect @use_module@ directives that+    -- appear after non-import content.+    trailingLoc :: Map Text (Maybe SourceLoc)+  }++-- | An empty 'RenameInputs' suitable for callers that do not have header+-- information (e.g. test fixtures, query renaming).+defaultRenameInputs :: RenameInputs+defaultRenameInputs =+  RenameInputs+    { operatorExports = Map.empty,+      trailingLoc = Map.empty+    }++-- ---------------------------------------------------------------------------+-- Environment building+-- ---------------------------------------------------------------------------++-- | Build a map of data-constructor names to their declared arities,+-- restricted to constructors visible to the current module (per the+-- supplied 'visibleDataCons' map). Constructors come from type+-- declarations and are always 'Unqualified' at this point (the parser+-- never produces qualified constructor names).+buildDataConEnv :: Map DeclaredType (Set.Set Text) -> [CollectedModule] -> DataConEnv+buildDataConEnv visible mods =+  Map.fromListWith+    (++)+    [ (t, [length dc.conArgs])+    | m <- mods,+      Ann td _ <- m.typeDecls,+      let key =+            DeclaredType m.name (unqualifiedText td.name) (length td.typeVars),+      Just visibleCons <- [Map.lookup key visible],+      dc <- typeConstructors td,+      Unqualified t <- [dc.conName],+      t `Set.member` visibleCons+    ]++-- | Build the @(constructorName, arity) -> [declaringModule]@ index used+-- by the renamer's data-constructor canonicalization. Same scope as+-- 'buildDataConEnv': only constructors whose declaring type is visible+-- to the current module, and only constructors permitted by the+-- visibility map's value-side allowlist.+buildDataConProviders ::+  Map DeclaredType (Set.Set Text) -> [CollectedModule] -> DataConProviders+buildDataConProviders visible mods =+  Map.fromListWith+    (++)+    [ ((t, length dc.conArgs), [m.name])+    | m <- mods,+      Ann td _ <- m.typeDecls,+      let key =+            DeclaredType m.name (unqualifiedText td.name) (length td.typeVars),+      Just visibleCons <- [Map.lookup key visible],+      dc <- typeConstructors td,+      Unqualified t <- [dc.conName],+      t `Set.member` visibleCons+    ]++-- | Like 'buildDataConProviders' but ignores the visibility map. The+-- result lists every declared @(constructorName, arity)@ alongside the+-- modules that declare it, regardless of export allowlists or import+-- lists. Used to distinguish "declared but hidden" from "not declared+-- at all" when emitting diagnostics for qualified references.+buildAllDataConProviders :: [CollectedModule] -> DataConProviders+buildAllDataConProviders mods =+  Map.fromListWith+    (++)+    [ ((t, length dc.conArgs), [m.name])+    | m <- mods,+      Ann td _ <- m.typeDecls,+      dc <- typeConstructors td,+      Unqualified t <- [dc.conName]+    ]++-- | Canonicalize a use-site data-constructor reference to its declared+-- 'Qualified' form when exactly one declaration matches @(name, arity)@.+-- Returns 'Nothing' for unknown or ambiguous names — callers fall back to+-- their existing handling (typically: leave the name 'Unqualified' and+-- emit an undeclared-data-constructor warning).+canonicalizeDataCon :: RenameCtx -> Text -> Int -> Maybe Name+canonicalizeDataCon ctx n arity = case Map.lookup (n, arity) ctx.dataConProviders of+  Just [m] -> Just (Qualified m n)+  _ -> Nothing++-- | Variant that takes a 'Name' (so compound-functor sites can call it+-- without unwrapping). 'Qualified' names pass through unchanged;+-- 'Unqualified' names are canonicalized via 'canonicalizeDataCon'.+canonicalizeData :: RenameCtx -> Name -> Int -> Name+canonicalizeData _ name@(Qualified _ _) _ = name+canonicalizeData ctx (Unqualified n) arity =+  case canonicalizeDataCon ctx n arity of+    Just qn -> qn+    Nothing -> Unqualified n++-- | Emit 'AmbiguousDataConstructor' (YCHR-20012) when the data-constructor+-- providers map lists more than one module for @(n, arity)@. Mirrors+-- the multi-provider arm of 'resolveName' (YCHR-20001) but for the+-- constructor namespace. Callers invoke this at every non-opaque use+-- site that would otherwise silently fall through 'canonicalizeData'+-- (which collapses both unknown and ambiguous into a no-op rewrite).+checkAmbiguousDataCon ::+  RenameCtx -> SourceLoc -> PExpr -> Text -> Int -> Rename ()+checkAmbiguousDataCon ctx loc origin n arity =+  case Map.lookup (n, arity) ctx.dataConProviders of+    Just ms@(_ : _ : _) ->+      emitError (AnnP (AmbiguousDataConstructor n ms) loc origin)+    _ -> pure ()++-- | All declared constraints and functions across all modules, indexed by+-- @(name, arity)@. Functions and constraints share a namespace, so both+-- kinds of declaration are included.+buildDeclEnv :: [CollectedModule] -> DeclEnv+buildDeclEnv mods =+  makeDeclEnv+    [ ((d.name, d.arity), [m.name])+    | m <- mods,+      Ann d _ <- m.decls+    ]++-- | Only /exported/ constraints and functions (for cross-module resolution).+-- Modules without a @module@ directive (@exports = Nothing@) export+-- everything. Operator and type export declarations are filtered out — they+-- live in separate namespaces.+buildExportEnv :: [CollectedModule] -> ExportEnv+buildExportEnv mods =+  makeExportEnv+    [ ((d.name, d.arity), [m.name])+    | m <- mods,+      d <- case m.exports of+        Nothing -> map (.node) m.decls+        Just annExports -> filter isConstraintOrFunctionDecl annExports.node+    ]++-- | All type declarations across all modules.+buildTypeDeclEnv :: [CollectedModule] -> DeclEnv+buildTypeDeclEnv mods =+  makeDeclEnv+    [ ((unqualifiedText td.name, length td.typeVars), [m.name])+    | m <- mods,+      Ann td _ <- m.typeDecls+    ]++-- | Only /exported/ types (for cross-module resolution). Modules without an+-- export list export every type they declare.+buildTypeExportEnv :: [CollectedModule] -> ExportEnv+buildTypeExportEnv mods =+  makeExportEnv+    [ ((d.name, d.arity), [m.name])+    | m <- mods,+      d <- case m.exports of+        Nothing ->+          [ TypeExportDecl (unqualifiedText td.name) (length td.typeVars) Nothing+          | Ann td _ <-+              m.typeDecls+          ]+        Just annExports -> filter isTypeExportDecl annExports.node+    ]++isConstraintOrFunctionDecl :: Declaration -> Bool+isConstraintOrFunctionDecl ConstraintDecl {} = True+isConstraintOrFunctionDecl FunctionDecl {} = True+isConstraintOrFunctionDecl _ = False++isTypeExportDecl :: Declaration -> Bool+isTypeExportDecl TypeExportDecl {} = True+isTypeExportDecl _ = False++-- | Extract the unqualified base text of a 'Name', dropping any module+-- prefix. Unlike 'flattenName' this does /not/ round-trip — it is used for+-- keying environments and for type declarations whose 'Name' is always+-- 'Unqualified' at this point.+unqualifiedText :: Name -> Text+unqualifiedText (Unqualified t) = t+unqualifiedText (Qualified _ t) = t++-- ---------------------------------------------------------------------------+-- Entry points+-- ---------------------------------------------------------------------------++-- | Rename a multi-module program: qualify every constraint, function,+-- type, and data-constructor reference against the appropriate provider+-- module, and validate export and import lists. Caller-supplied+-- 'RenameInputs' carries per-module operator-export tables and trailing+-- header locations gathered by 'YCHR.Internal.Collect'; pass 'defaultRenameInputs'+-- when those tables are unavailable (tests, query renaming).+-- Returns the renamed modules and any warnings on success, or the+-- accumulated diagnostics on failure.+renameProgram ::+  RenameInputs ->+  [CollectedModule] ->+  Either+    [Diagnostic RenameError]+    ( [CollectedModule],+      [Diagnostic RenameWarning]+    )+renameProgram inputs mods =+  let declEnv0 = buildDeclEnv mods+      exportEnv0 = buildExportEnv mods+      typeDeclEnv0 = buildTypeDeclEnv mods+      typeExportEnv0 = buildTypeExportEnv mods+      allCons = buildAllDataConProviders mods+      ctxFor m =+        let ctx0 =+              RenameCtx+                { declEnv = declEnv0,+                  exportEnv = exportEnv0,+                  dataConEnv = Map.empty,+                  dataConProviders = Map.empty,+                  allDataConProviders = allCons,+                  typeDeclEnv = typeDeclEnv0,+                  typeExportEnv = typeExportEnv0,+                  operatorExports = inputs.operatorExports,+                  currentTrailingLoc =+                    Map.findWithDefault Nothing m.name inputs.trailingLoc,+                  allModuleNames = map (.name) mods,+                  currentModule = m+                }+            visible = visibleDataCons mods ctx0+         in ctx0+              { dataConEnv = buildDataConEnv visible mods,+                dataConProviders = buildDataConProviders visible mods+              }+      ( (result, warnings),+        errs+        ) =+          runWriter+            ( runWriterT $ do+                validateExports mods+                traverse (\m -> renameModule mods (ctxFor m)) mods+            )+   in if null errs then Right (result, warnings) else Left errs++-- | Check that every name in a module's export list is actually declared.+validateExports :: [CollectedModule] -> Rename ()+validateExports = traverse_ validateOne+  where+    validateOne m = case m.exports of+      Nothing -> pure ()+      Just (AnnP exports loc origin) -> traverse_ (checkExport m loc origin) exports++    checkExport m loc origin d = case d of+      ConstraintDecl {name, arity}+        | not (isDeclared m name arity) ->+            emitError (AnnP (UnknownExport m.name name arity) loc origin)+      FunctionDecl {name, arity}+        | not (isDeclared m name arity) ->+            emitError (AnnP (UnknownExport m.name name arity) loc origin)+      TypeExportDecl {name, arity, conExports}+        | not (isTypeDeclared m name arity) ->+            emitError (AnnP (UnknownExport m.name name arity) loc origin)+        | otherwise ->+            checkConList m loc origin name arity conExports+      _ -> pure ()++    checkConList _ _ _ _ _ Nothing = pure ()+    checkConList m loc origin tyName tyArity (Just cs) =+      let declared = declaredConstructors m tyName tyArity+       in traverse_+            ( \c ->+                when (c `notElem` declared) $+                  emitError+                    ( AnnP+                        (UnknownExportedConstructor m.name tyName tyArity c)+                        loc+                        origin+                    )+            )+            cs++    isDeclared m n a = (n, a) `elem` [(d.name, d.arity) | Ann d _ <- m.decls]+    isTypeDeclared m n a =+      (n, a)+        `elem` [ ( unqualifiedText td.name,+                   length td.typeVars+                 )+               | Ann td _ <- m.typeDecls+               ]++    declaredConstructors m n a =+      [ unqualifiedText dc.conName+      | Ann td _ <- m.typeDecls,+        unqualifiedText td.name == n,+        length td.typeVars == a,+        dc <- typeConstructors td+      ]++-- ---------------------------------------------------------------------------+-- Module, rule, equation, head renaming+-- ---------------------------------------------------------------------------++renameModule :: [CollectedModule] -> RenameCtx -> Rename CollectedModule+renameModule mods ctx = do+  let m = ctx.currentModule+  validateImportLists mods ctx+  renamedRules <- traverse (renameRule ctx) m.rules+  renamedEquations <- traverse (traverse (renameEquation ctx)) m.equations+  renamedExtensions <- traverse (traverse (renameEquation ctx)) m.extensions+  renamedClassExtensions <- traverse (traverse (renameEquation ctx)) m.classExtensions+  let renamedTypeDecls = map (fmap (renameTypeDefinition ctx)) m.typeDecls+  renamedDecls <- traverse (renameAnnDecl ctx) m.decls+  renamedExtensionTypes <- traverse (renameAnnDecl ctx) m.extensionTypes+  -- Explicit construction (not @m { ... }@ record update): because+  -- 'CollectedModule' and 'Module' share field names, a record update of+  -- the variable @m@ is ambiguous (GHC cannot tell which record type is+  -- being updated). Naming the constructor resolves it unambiguously.+  pure+    CollectedModule+      { name = m.name,+        nameLoc = m.nameLoc,+        imports = m.imports,+        rules = renamedRules,+        equations = renamedEquations,+        extensions = renamedExtensions,+        classExtensions = renamedClassExtensions,+        typeDecls = renamedTypeDecls,+        decls = renamedDecls,+        extensionTypes = renamedExtensionTypes,+        exports = m.exports+      }++-- | Validate import lists. Four checks:+--+--   * @op(...)@ entries must name an operator that the source module+--     actually exports ('UnknownOperatorImport').+--   * Constraint, function, and type imports must name something the+--     source module exports ('UnknownImport').+--   * A @type(t/n, [c, ...])@ import must list constructors that the+--     source module exports for that type ('UnknownExportedConstructor').+--   * Each @use_module@ directive must appear before the first non-import+--     directive in the file ('UseModuleOutOfOrder').+validateImportLists :: [CollectedModule] -> RenameCtx -> Rename ()+validateImportLists mods ctx =+  traverse_ checkImport ctx.currentModule.imports+  where+    checkImport (AnnP imp loc origin) = do+      checkPlacement imp loc origin+      case imp.importItems of+        Just decls -> traverse_ (checkItem imp.importModule loc origin) decls+        Nothing -> pure ()++    checkPlacement imp loc origin = case ctx.currentTrailingLoc of+      Just tloc+        | loc.file == tloc.file,+          locAtOrAfter loc tloc ->+            emitError (AnnP (UseModuleOutOfOrder imp.importModule) loc origin)+      _ -> pure ()++    checkItem mn loc origin (OperatorDecl op) =+      when (op `notElem` Map.findWithDefault [] mn ctx.operatorExports) $+        emitError (AnnP (UnknownOperatorImport mn op.opName) loc origin)+    checkItem mn loc origin (ConstraintDecl n a _ _) =+      when (mn `notElem` lookupExport (n, a) ctx.exportEnv) $+        emitError (AnnP (UnknownImport mn n a) loc origin)+    checkItem mn loc origin (FunctionDecl n a _ _ _ _ _) =+      when (mn `notElem` lookupExport (n, a) ctx.exportEnv) $+        emitError (AnnP (UnknownImport mn n a) loc origin)+    checkItem _ _ _ ExtendClassTypeDecl {} = pure ()+    checkItem mn loc origin (TypeExportDecl n a cs) =+      if mn `notElem` lookupExport (n, a) ctx.typeExportEnv+        then emitError (AnnP (UnknownImport mn n a) loc origin)+        else checkImportedCons mn loc origin n a cs++    checkImportedCons _ _ _ _ _ Nothing = pure ()+    checkImportedCons mn loc origin n a (Just xs) =+      let declared = declaredConstructorsOn mn n a+          exported = filterByExporterAllowlist mn n a declared+       in traverse_+            ( \c ->+                if c `notElem` declared+                  then+                    emitError+                      (AnnP (UnknownExportedConstructor mn n a c) loc origin)+                  else+                    when (c `notElem` exported) $+                      emitError+                        (AnnP (ConstructorNotExported mn n a c) loc origin)+            )+            xs++    -- All constructors of type @n/a@ declared in module @mn@, ignoring+    -- the module's export allowlist.+    declaredConstructorsOn mn n a =+      case [m | m <- mods, m.name == mn] of+        (m : _) ->+          [ unqualifiedText dc.conName+          | Ann td _ <- m.typeDecls,+            unqualifiedText td.name == n,+            length td.typeVars == a,+            dc <- typeConstructors td+          ]+        [] -> []++    -- Intersect the supplied 'declared' list with @mn@'s optional+    -- @type(...)@ allowlist (or pass through unchanged if @mn@ has no+    -- export list, in which case everything declared is exported).+    filterByExporterAllowlist mn n a declared =+      case [m | m <- mods, m.name == mn] of+        (m : _) ->+          let allowed = case m.exports of+                Nothing -> Nothing+                Just (AnnP exports _ _) ->+                  case [acs | TypeExportDecl tn ta acs <- exports, tn == n, ta == a] of+                    (acs : _) -> acs+                    [] -> Just []+           in case allowed of+                Nothing -> declared+                Just xs -> filter (`elem` xs) declared+        [] -> []++-- | True when @a@ is at or after @b@ in source order. Both locations+-- must come from the same file (caller's responsibility).+locAtOrAfter :: SourceLoc -> SourceLoc -> Bool+locAtOrAfter a b = (a.line, a.col) >= (b.line, b.col)++renameRule :: RenameCtx -> Rule -> Rename Rule+renameRule ctx r = do+  h <- traverse (renameHead ctx r.head.sourceLoc r.head.parsed) r.head+  g <-+    traverse+      (traverse (renameTerm ctx r.guard.sourceLoc r.guard.parsed ResolveAll))+      r.guard+  b <-+    traverse+      (traverse (renameTerm ctx r.body.sourceLoc r.body.parsed ResolveTop))+      r.body+  pure r {head = h, guard = g, body = b}++renameEquation :: RenameCtx -> FunctionEquation -> Rename FunctionEquation+renameEquation ctx eq = do+  -- Equation args don't carry their own SourceLoc; use the guard's as a proxy.+  let loc = eq.guard.sourceLoc+      origin = eq.guard.parsed+  resolvedFunName <- resolveName ResolveTop ctx loc origin eq.funName (length eq.args)+  renamedArgs <- traverse (renameTerm ctx loc origin NoResolve) eq.args+  renamedGuard <- traverse (traverse (renameTerm ctx loc origin ResolveAll)) eq.guard+  renamedRhs <-+    traverse+      (traverse (renameTerm ctx eq.rhs.sourceLoc eq.rhs.parsed ResolveAll))+      eq.rhs+  pure+    eq+      { funName = resolvedFunName,+        args = renamedArgs,+        guard = renamedGuard,+        rhs = renamedRhs+      }++renameHead :: RenameCtx -> SourceLoc -> PExpr -> Head -> Rename Head+renameHead ctx loc origin h = case h of+  Simplification cs -> Simplification <$> traverse (renameCon ctx loc origin) cs+  Propagation cs -> Propagation <$> traverse (renameCon ctx loc origin) cs+  Simpagation k r ->+    Simpagation+      <$> traverse (renameCon ctx loc origin) k+      <*> traverse (renameCon ctx loc origin) r++renameCon :: RenameCtx -> SourceLoc -> PExpr -> Constraint -> Rename Constraint+renameCon ctx loc origin (Constraint cname cargs) = do+  renamedName <- resolveName ResolveTop ctx loc origin cname (length cargs)+  renamedArgs <- traverse (renameTerm ctx loc origin NoResolve) cargs+  pure (Constraint renamedName renamedArgs)++-- ---------------------------------------------------------------------------+-- Resolution mode and term renaming+-- ---------------------------------------------------------------------------++-- | Controls how deeply name resolution is applied to a term, and how+-- unresolved names are treated.+--+-- * 'NoResolve' — head arguments and nested data terms. Names are never+--   looked up because they represent data constructors, not callable+--   entities.+--+-- * 'ResolveTop' — rule bodies. The outermost functor must be a declared+--   constraint or function (unknown names are errors). Its arguments are+--   data terms and are renamed with 'NoResolve'.+--+-- * 'ResolveAll' — guards and @is@-RHS expressions. Every nesting level+--   is resolved, but unknown names are /tolerated/ (they may be data+--   constructors like @.@ for lists). Unresolved names trigger a+--   data-constructor warning.+--+-- * 'NoResolveQuoted' — inside a @quote(...)@ body. Same name policy as+--   'NoResolve' (functors stay unqualified, declared data constructors+--   still get canonicalized to @Mod:name@), but the undeclared-+--   constructor warning is suppressed because the body is intentionally+--   opaque (see the language reference §The @quote/1@ quoting form).+data ResolveMode+  = NoResolve+  | NoResolveQuoted+  | ResolveTop+  | ResolveAll+  deriving (Eq)++-- | Whether 'resolveName' should error on unresolved names. Derived from+-- 'ResolveMode': 'ResolveTop' requires declarations, 'ResolveAll' tolerates+-- missing ones, and 'NoResolve' never calls 'resolveName'.+errorOnUnknown :: ResolveMode -> Bool+errorOnUnknown ResolveTop = True+errorOnUnknown _ = False++-- | Whether the current position evaluates expressions (so the syntactic+-- special cases for @is@, lambdas, and @fun name/arity@ apply). Returns+-- 'False' for both pattern positions ('NoResolve') and quoted bodies+-- ('NoResolveQuoted'), where these forms must remain literal compound+-- terms instead of being interpreted.+isResolving :: ResolveMode -> Bool+isResolving ResolveTop = True+isResolving ResolveAll = True+isResolving _ = False++-- | Rename a lambda body, walking through any top-level comma sequencer+-- without treating @,@ itself as a data constructor. Each comma-separated+-- item is renamed in 'ResolveAll' mode like an ordinary lambda body.+renameLambdaBody :: RenameCtx -> SourceLoc -> PExpr -> Term -> Rename Term+renameLambdaBody ctx loc origin t = case t of+  CompoundTerm (Unqualified ",") [l, r] -> do+    l' <- renameLambdaBody ctx loc origin l+    r' <- renameLambdaBody ctx loc origin r+    pure (CompoundTerm (Unqualified ",") [l', r'])+  _ -> renameTerm ctx loc origin ResolveAll t++renameTerm :: RenameCtx -> SourceLoc -> PExpr -> ResolveMode -> Term -> Rename Term+renameTerm ctx loc origin mode t = case t of+  -- Special case: @is@ LHS is a pattern (no resolution), RHS is an expression.+  CompoundTerm (Unqualified "is") [lhs, rhs] | isResolving mode -> do+    renamedLhs <- renameTerm ctx loc origin NoResolve lhs+    renamedRhs <- renameTerm ctx loc origin ResolveAll rhs+    pure (CompoundTerm (Unqualified "is") [renamedLhs, renamedRhs])+  -- Lambda: @fun(params) -> body end@. A lambda is a first-class value,+  -- not data; @'->'@ and @fun@ are surface syntax for the desugarable+  -- compound @'->'(fun(params), body)@, never data constructors. The+  -- arm therefore fires in every non-quoted position (pattern or+  -- expression) so a lambda passed straight as a constraint or partner+  -- argument is not mis-warned as @YCHR-20101 Undeclared data+  -- constructor 'fun'/'->'@. The body is always an expression and is+  -- renamed in 'ResolveAll' regardless of the surrounding mode; the+  -- body may also use top-level comma sequencing (@A, B, C@), which+  -- 'renameLambdaBody' walks through without treating @,@ as a data+  -- constructor. The explicit opt-out for opaque shape is @quote/1@,+  -- handled in the 'NoResolveQuoted' branch below.+  CompoundTerm+    (Unqualified "->")+    [ CompoundTerm (Unqualified "fun") params,+      body+      ] | mode /= NoResolveQuoted -> do+      renamedBody <- renameLambdaBody ctx loc origin body+      pure+        ( CompoundTerm+            (Unqualified "->")+            [ CompoundTerm (Unqualified "fun") params,+              renamedBody+            ]+        )+  -- Quoting: @quote(X)@ keeps its argument opaque. Functor names inside+  -- stay unqualified, declared data constructors are silently+  -- canonicalized, and undeclared-data-constructor warnings are+  -- suppressed because the body is intentionally not subject to those+  -- checks (see docs/reference/language.md §The @quote/1@ quoting form).+  -- Fires in any surrounding mode so a nested @quote(...)@ behind a+  -- 'NoResolve' parent (e.g. a body-position constraint argument) is+  -- also covered.+  CompoundTerm (Unqualified "quote") [arg] -> do+    renamedArg <- renameTerm ctx loc origin NoResolveQuoted arg+    pure (CompoundTerm (Unqualified "quote") [renamedArg])+  -- Function reference: @fun name/arity@. A function reference is a+  -- first-class value, not data; @fun@ here is surface syntax for the+  -- desugarable compound @'fun'('/'(name, arity))@, never a data+  -- constructor. The arm fires in every non-quoted position (pattern+  -- or expression) so a funref passed straight as a constraint or+  -- partner argument is not mis-warned as @YCHR-20101 Undeclared data+  -- constructor 'fun'@. Resolution always happens in 'ResolveTop' mode+  -- (errors on unknowns), which is the right behavior wherever a+  -- funref appears; the @fun@ wrapper is then stripped so downstream+  -- passes see bare @name/arity@. The explicit opt-out for opaque+  -- shape is @quote/1@.+  CompoundTerm+    (Unqualified "fun")+    [ CompoundTerm+        (Unqualified "/")+        [ CompoundTerm (Unqualified fname) [],+          IntTerm farity+          ]+      ] | mode /= NoResolveQuoted -> do+      resolved <-+        resolveName ResolveTop ctx loc origin (Unqualified fname) (fromInteger farity)+      pure+        ( CompoundTerm+            (Unqualified "/")+            [CompoundTerm (Unqualified (flattenName resolved)) [], IntTerm farity]+        )+  -- 0-arity unqualified compounds (the AST form of bare atoms after+  -- the parser's @Atom t@ rewrite): always lenient under resolution.+  -- A bare atom in body or guard position has the same surface meaning+  -- as a 0-arity data-constructor use, so we force 'ResolveAll' here+  -- (warn but don't error on undeclared) regardless of the surrounding+  -- 'ResolveTop'. Then fall back to data-constructor canonicalization.+  CompoundTerm (Unqualified n) [] -> do+    resolved <- case mode of+      NoResolve -> do+        warnUnknownDataCon ctx.dataConEnv loc origin n 0+        case visibleProviders ctx n 0 of+          ms@(_ : _ : _) ->+            emitError (AnnP (AmbiguousName n 0 ms) loc origin)+          _ -> pure ()+        pure (Unqualified n)+      NoResolveQuoted ->+        pure (Unqualified n)+      _ -> resolveName ResolveAll ctx loc origin (Unqualified n) 0+    case resolved of+      Qualified _ _ -> pure (CompoundTerm resolved [])+      Unqualified _ -> do+        case mode of+          NoResolveQuoted -> pure ()+          _ ->+            when (null (visibleProviders ctx n 0)) $+              checkAmbiguousDataCon ctx loc origin n 0+        case canonicalizeDataCon ctx n 0 of+          Just qn -> pure (CompoundTerm qn [])+          Nothing -> pure (CompoundTerm (Unqualified n) [])+  CompoundTerm name args -> do+    let childMode = case mode of+          NoResolve -> NoResolve+          NoResolveQuoted -> NoResolveQuoted+          ResolveTop -> NoResolve+          ResolveAll -> ResolveAll+    renamedArgs <- traverse (renameTerm ctx loc origin childMode) args+    newName <- case mode of+      NoResolve -> do+        case name of+          -- Three legs by what the function/constraint namespace says:+          --   []      — no visible callable; this is a pattern-style+          --             use of an unqualified name. Run the data-+          --             constructor checks ('warnUnknownDataCon' for+          --             the bare 'is this declared anywhere' question,+          --             'checkAmbiguousDataCon' for the cross-module+          --             data-constructor ambiguity question).+          --   [_]     — exactly one callable; 'Resolve.termToExpr' will+          --             canonicalize this to a 'CallExpr' for tell-side+          --             argument evaluation, so it is not a misspelled+          --             data constructor. Any data-constructor ambiguity+          --             with the same name is moot for this use.+          --   _:_:_   — multiple callables and 'Resolve.termToExpr' has+          --             no way to pick one (the multi-provider entry+          --             silently falls through to 'CtorExpr', see+          --             'Resolve.hs' on the @CompoundTerm Unqualified@+          --             arm). Mirror the multi-provider arm of+          --             'resolveName' (which 'ResolveTop'/'ResolveAll'+          --             positions already go through) so that pattern-+          --             position uses get the same 'AmbiguousName'+          --             diagnostic instead of a silent downstream+          --             failure.+          Unqualified n ->+            case visibleProviders ctx n (length args) of+              [] -> do+                warnUnknownDataCon ctx.dataConEnv loc origin n (length args)+                checkAmbiguousDataCon ctx loc origin n (length args)+              [_] -> pure ()+              ms -> emitError (AnnP (AmbiguousName n (length args) ms) loc origin)+          -- Qualified references in pattern position (head args,+          -- body-tell args) get the same visibility check as in+          -- resolving positions; the parser can't tell a constructor,+          -- a function/constraint, or a type-tag apart at the term+          -- level, so any of those visibility leg passes.+          Qualified m n -> validateQualified ctx loc origin m n (length args)+        pure (canonicalizeData ctx name (length args))+      NoResolveQuoted ->+        -- Inside a 'quote/1' quote the body is fully opaque: no+        -- visibility checks fire and qualified atoms are kept+        -- as-written. This is the supported escape hatch for+        -- constructing arbitrary qualified atoms as data (e.g. type+        -- tags inside the typechecker's CHR program).+        pure (canonicalizeData ctx name (length args))+      _ -> do+        resolved <- resolveName mode ctx loc origin name (length args)+        case resolved of+          Unqualified n -> do+            -- Gate on 'null visibleProviders' so we don't pile a+            -- YCHR-20012 on top of the YCHR-20001 that 'resolveName'+            -- has already emitted when both namespaces are ambiguous.+            when (null (visibleProviders ctx n (length args))) $+              checkAmbiguousDataCon ctx loc origin n (length args)+            pure (canonicalizeData ctx resolved (length args))+          Qualified _ _ -> pure resolved+    pure (CompoundTerm newName renamedArgs)+  other -> pure other++-- ---------------------------------------------------------------------------+-- Name resolution+-- ---------------------------------------------------------------------------++-- | Resolve a name to a 'Qualified' one and verify its existence.+--+-- For 'Unqualified' names: the current module's own declarations are+-- checked first ('DeclEnv'), then the exports of imported modules+-- ('ExportEnv' restricted to the import list). Exactly one match is+-- required; zero matches are handled according to the 'ResolveMode', and+-- multiple matches produce an 'AmbiguousName' error.+--+-- For already-'Qualified' names: the same visibility rules apply. A+-- reference @M:n@ is accepted only if @M@ is the current module (via+-- 'DeclEnv') or if @M@ is imported and exports @n@ (via 'ExportEnv').+-- Names qualified with @\"host\"@ are external calls and bypass validation.+resolveName ::+  ResolveMode ->+  RenameCtx ->+  SourceLoc ->+  PExpr ->+  Name ->+  Int ->+  Rename Name+resolveName mode ctx loc origin (Unqualified n) arity+  | isReserved n = pure (Unqualified n)+  | otherwise =+      case visibleProviders ctx n arity of+        [m] -> pure (Qualified m n)+        [] ->+          if errorOnUnknown mode+            then do+              emitError (AnnP (UnknownName n arity) loc origin)+              pure (Unqualified n)+            else do+              warnUnknownDataCon ctx.dataConEnv loc origin n arity+              pure (Unqualified n)+        ms -> do+          emitError (AnnP (AmbiguousName n arity ms) loc origin)+          pure (Unqualified n)+resolveName _ ctx loc origin name@(Qualified m n) arity = do+  validateQualified ctx loc origin m n arity+  pure name++-- | Verify that a qualified reference @M:n/a@ is in scope as a+-- /value-level/ identifier: function, constraint, or data+-- constructor. Types are intentionally not accepted — they live in a+-- separate namespace and cannot appear in value positions. Users who+-- need a qualified atom as opaque data (e.g. the typechecker's+-- type-name tags) must wrap it with @quote/1@, which switches the+-- renamer into 'NoResolveQuoted' mode and skips this check entirely.+-- The @host@ pseudo-module is exempt (host calls are external).+--+-- For a miss, the diagnostic pinpoints the actual cause:+--+--   * constructor-flavored ('NonExportedConstructor', YCHR-20010) iff+--     @M@ declares @(n, arity)@ as a constructor anywhere — the user+--     named a real but hidden ctor;+--   * 'UnknownModule' (YCHR-20015) iff no module named @M@ exists;+--   * 'ModuleNotImported' (YCHR-20014) iff @M@ exists but the current+--     module never imports it (qualification does not bypass the+--     import requirement);+--   * 'NotExportedByModule' (YCHR-20009) otherwise — @M@ is imported+--     but does not export @(n, arity)@ (or a restricted import list+--     excludes it).+--+-- Callers return the 'Qualified' name unchanged so traversal can continue.+validateQualified ::+  RenameCtx -> SourceLoc -> PExpr -> Text -> Text -> Int -> Rename ()+validateQualified ctx loc origin m n arity+  | m == "host" = pure ()+  | m `elem` visibleProviders ctx n arity = pure ()+  | m `elem` Map.findWithDefault [] (n, arity) ctx.dataConProviders = pure ()+  | m `elem` Map.findWithDefault [] (n, arity) ctx.allDataConProviders =+      emitError (AnnP (NonExportedConstructor m n arity) loc origin)+  | m `notElem` ctx.allModuleNames =+      emitError (AnnP (UnknownModule m) loc origin)+  | m `notElem` importedModuleNames ctx =+      emitError (AnnP (ModuleNotImported m n arity) loc origin)+  | otherwise =+      emitError (AnnP (NotExportedByModule m n arity) loc origin)++-- | Every module the current module imports. Used to decide whether a+-- qualified reference's target module is in scope at all (distinct from+-- whether it exports the referenced name).+importedModuleNames :: RenameCtx -> [Text]+importedModuleNames ctx =+  [imp.importModule | AnnP imp _ _ <- ctx.currentModule.imports]++-- | All modules that can provide @(name, arity)@ to the current module:+-- the current module itself if it declares the name, plus every imported+-- module that /exports/ it.+visibleProviders :: RenameCtx -> Text -> Int -> [Text]+visibleProviders ctx n arity =+  let ownProviders =+        filter+          (== ctx.currentModule.name)+          (lookupDecl (n, arity) ctx.declEnv)+      imports =+        [ (imp.importModule, imp.importItems)+        | AnnP imp _ _ <- ctx.currentModule.imports+        ]+      importProviders =+        filter+          (\mn -> any (\(imn, il) -> imn == mn && importListPermits n arity il) imports)+          (lookupExport (n, arity) ctx.exportEnv)+   in -- Deduplicate: multiple declarations with the same name/arity in+      -- one module (e.g., overloaded function signatures) are not ambiguous.+      nub (ownProviders ++ importProviders)++-- | Check whether a name/arity is permitted by an import list.+-- 'Nothing' means import everything; 'Just' restricts to listed items.+importListPermits :: Text -> Int -> Maybe [Declaration] -> Bool+importListPermits _ _ Nothing = True+importListPermits n arity (Just decls) = any match decls+  where+    match (ConstraintDecl dn da _ _) = dn == n && da == arity+    match (FunctionDecl dn da _ _ _ _ _) = dn == n && da == arity+    match _ = False++-- | Check whether a type name/arity is permitted by an import list.+importListPermitsType :: Text -> Int -> Maybe [Declaration] -> Bool+importListPermitsType _ _ Nothing = True+importListPermitsType n arity (Just decls) = any match decls+  where+    match (TypeExportDecl tn ta _) = tn == n && ta == arity+    match _ = False++-- | The set of constructor names a single import-list entry permits for+-- type @n/a@. The fallback is the supplied @allCons@ — used when no+-- constructor clause is present (i.e. the import is @type(n/a)@ rather+-- than @type(n/a, [...])@).+importListPermitsCons ::+  Text -> Int -> Set.Set Text -> Maybe [Declaration] -> Set.Set Text+importListPermitsCons _ _ allCons Nothing = allCons+importListPermitsCons n arity allCons (Just decls) =+  case [cs | TypeExportDecl tn ta cs <- decls, tn == n, ta == arity] of+    (Nothing : _) -> allCons+    (Just xs : _) -> Set.fromList xs+    [] -> Set.empty++-- | For each type visible to the current module, the set of constructor+-- names also visible. Locally declared types contribute every declared+-- constructor; imported types contribute @exporterAllowlist ∩+-- importerAllowlist@ where each side defaults to "all constructors" when+-- its @type(...)@ clause has no constructor list. A type with an empty+-- constructor set still appears in the map: the type itself remains+-- visible (type-level visibility is governed independently by+-- 'resolveTypeName'), only its constructors are hidden.+visibleDataCons :: [CollectedModule] -> RenameCtx -> Map DeclaredType (Set.Set Text)+visibleDataCons mods ctx =+  Map.fromList+    [ entry+    | m <- mods,+      Ann td _ <- m.typeDecls,+      Just entry <- [entryFor m td]+    ]+  where+    imports =+      [(imp.importModule, imp.importItems) | AnnP imp _ _ <- ctx.currentModule.imports]++    entryFor m td =+      let n = unqualifiedText td.name+          a = length td.typeVars+          key = DeclaredType m.name n a+          allCons =+            Set.fromList [unqualifiedText dc.conName | dc <- typeConstructors td]+       in if m.name == ctx.currentModule.name+            then Just (key, allCons)+            else case ( exporterAllowance m n a allCons,+                        importerAllowance m.name n a allCons+                      ) of+              (Just expSet, Just impSet) ->+                Just (key, Set.intersection expSet impSet)+              _ -> Nothing++    exporterAllowance m n a allCons = case m.exports of+      Nothing -> Just allCons+      Just (AnnP exports _ _) ->+        case [cs | TypeExportDecl tn ta cs <- exports, tn == n, ta == a] of+          (Nothing : _) -> Just allCons+          (Just xs : _) -> Just (Set.fromList xs)+          [] -> Nothing++    importerAllowance mn n a allCons =+      let relevant = [il | (imn, il) <- imports, imn == mn]+       in if null relevant+            then Nothing+            else+              Just+                ( Set.unions+                    [importListPermitsCons n a allCons il | il <- relevant]+                )++-- | Check an unresolved name against data-constructor declarations.+-- If found with matching arity: silent. If found with wrong arity: warning.+-- If not found at all: warning. A type-constructor name used in term+-- position (e.g. @set@ for an opaque type, or @list@ for an algebraic+-- one) is not a declared data constructor, so it falls through to the+-- 'UndeclaredDataConstructor' warning like any other unknown functor.+warnUnknownDataCon :: DataConEnv -> SourceLoc -> PExpr -> Text -> Int -> Rename ()+warnUnknownDataCon dataConEnv loc origin n arity =+  case Map.lookup n dataConEnv of+    Just arities+      | arity `elem` arities -> pure ()+      | otherwise -> emitWarning (AnnP (DataConstructorArityMismatch n arity) loc origin)+    Nothing -> emitWarning (AnnP (UndeclaredDataConstructor n) loc origin)++-- ---------------------------------------------------------------------------+-- Type definition renaming+-- ---------------------------------------------------------------------------++-- | Rename a type definition: qualify the type name and constructor names+-- with the declaring module, and resolve type references in constructor+-- arguments.+--+-- Pure (not in 'Eff'): type renaming never fails — unknown types simply+-- stay 'Unqualified' so the interpreter can decide what to do with them+-- (e.g. built-in @int@). If type errors are introduced later this will+-- need to move into 'Rename'.+renameTypeDefinition :: RenameCtx -> TypeDefinition -> TypeDefinition+renameTypeDefinition ctx td =+  TypeDefinition+    { name = Qualified ctx.currentModule.name (unqualifiedText td.name),+      typeVars = td.typeVars,+      kind = case td.kind of+        Opaque -> Opaque+        Algebraic cs -> Algebraic (map (renameDataConstructor ctx) cs),+      loc = td.loc+    }++renameDataConstructor :: RenameCtx -> DataConstructor -> DataConstructor+renameDataConstructor ctx dc =+  DataConstructor+    { conName = Qualified ctx.currentModule.name (unqualifiedText dc.conName),+      conArgs = map (renameTypeExpr ctx) dc.conArgs+    }++renameAnnDecl :: RenameCtx -> Ann Declaration -> Rename (Ann Declaration)+renameAnnDecl ctx (Ann d loc) = do+  d' <- renameDeclaration ctx loc d+  pure (Ann d' loc)++renameDeclaration ::+  RenameCtx -> SourceLoc -> Declaration -> Rename Declaration+renameDeclaration ctx loc (ConstraintDecl n a argTypes requiring) = do+  requiring' <- traverse (traverse (renameBoundSig ctx loc)) requiring+  pure+    ConstraintDecl+      { name = n,+        arity = a,+        argTypes = fmap (map (renameTypeExpr ctx)) argTypes,+        requiring = requiring'+      }+renameDeclaration+  ctx+  loc+  (FunctionDecl n a argTypes returnType isOpen kind requiring) = do+    requiring' <- traverse (traverse (renameBoundSig ctx loc)) requiring+    pure+      FunctionDecl+        { name = n,+          arity = a,+          argTypes = fmap (map (renameTypeExpr ctx)) argTypes,+          returnType = fmap (renameTypeExpr ctx) returnType,+          isOpen = isOpen,+          kind = kind,+          requiring = requiring'+        }+renameDeclaration ctx loc d@ExtendClassTypeDecl {name, arity, argTypes, returnType} = do+  resolved <- resolveName ResolveTop ctx loc (Atom name) (Unqualified name) arity+  pure+    d+      { argTypes = fmap (map (renameTypeExpr ctx)) argTypes,+        returnType = fmap (renameTypeExpr ctx) returnType,+        target = Just resolved+      }+renameDeclaration _ _ d = pure d++-- | Rename a 'BoundSig' inside a @requiring@ clause: resolve the bound+-- function's name to a 'Qualified' form (so the resolver can look it up+-- by qualified name) and rename type-expression references in the+-- argument and return types. Unresolvable bound names are deferred to+-- the resolver, which emits the dedicated 'unknown_bound_function'+-- diagnostic (YCHR-16009) with the requiring-clause context. We do not+-- reuse 'resolveName' here because 'ResolveTop' would emit the generic+-- 'UnknownName' (YCHR-20002) on a miss and 'ResolveAll' would trigger+-- spurious 'warnUnknownDataCon' warnings — a bound reference never+-- names a data constructor.+renameBoundSig :: RenameCtx -> SourceLoc -> BoundSig -> Rename BoundSig+renameBoundSig ctx _ bs = do+  resolved <- resolveBoundName+  pure+    BoundSig+      { name = resolved,+        arity = bs.arity,+        argTypes = map (renameTypeExpr ctx) bs.argTypes,+        returnType = renameTypeExpr ctx bs.returnType,+        loc = bs.loc+      }+  where+    boundSigName b = case b.name of+      Unqualified t -> t+      Qualified _ t -> t+    origin = Atom (boundSigName bs)+    resolveBoundName = case bs.name of+      Qualified m n -> do+        validateQualified ctx bs.loc origin m n bs.arity+        pure (Qualified m n)+      Unqualified n+        | isReserved n -> pure (Unqualified n)+        | otherwise ->+            case visibleProviders ctx n bs.arity of+              [m] -> pure (Qualified m n)+              [] -> pure (Unqualified n)+              ms -> do+                emitError (AnnP (AmbiguousName n bs.arity ms) bs.loc origin)+                pure (Unqualified n)++renameTypeExpr :: RenameCtx -> TypeExpr -> TypeExpr+renameTypeExpr _ (TypeVar v) = TypeVar v+renameTypeExpr ctx (TypeCon n args) =+  TypeCon+    (resolveTypeName ctx (unqualifiedText n) (length args))+    (map (renameTypeExpr ctx) args)++-- | Resolve a type name against the type declaration and export+-- environments. Unknown types (e.g., the built-in @int@) are kept+-- 'Unqualified'.+resolveTypeName :: RenameCtx -> Text -> Int -> Name+resolveTypeName ctx n arity =+  let ownProviders =+        filter+          (== ctx.currentModule.name)+          (lookupDecl (n, arity) ctx.typeDeclEnv)+      imports =+        [ (imp.importModule, imp.importItems)+        | AnnP imp _ _ <- ctx.currentModule.imports+        ]+      importProviders =+        filter+          ( \mn ->+              any+                (\(imn, il) -> imn == mn && importListPermitsType n arity il)+                imports+          )+          (lookupExport (n, arity) ctx.typeExportEnv)+      matches = ownProviders ++ importProviders+   in case matches of+        [m] -> Qualified m n+        _ -> Unqualified n++-- ---------------------------------------------------------------------------+-- Query renaming+-- ---------------------------------------------------------------------------++-- | Like 'renameQueryGoals' but uses 'NoResolve' mode — appropriate+-- for the argument terms of a single goal constraint, where each+-- term is data (constructors / atoms / variables) rather than a+-- callable. Canonicalizes bare data-constructor references the same+-- way the renamer does for head-pattern arguments.+renameQueryArgs ::+  [CollectedModule] ->+  [Term] ->+  Either+    [Diagnostic RenameError]+    ( [Term],+      [Diagnostic RenameWarning]+    )+renameQueryArgs mods args = renameQueryTerms mods NoResolve args++-- | Rename a list of query goal terms using all modules as the visible+-- scope. Each term is renamed at 'ResolveTop' level (same as rule bodies).+-- Returns 'Left' if any rename errors occur.+renameQueryGoals ::+  [CollectedModule] ->+  [Term] ->+  Either+    [Diagnostic RenameError]+    ( [Term],+      [Diagnostic RenameWarning]+    )+renameQueryGoals mods goals = renameQueryTerms mods ResolveTop goals++renameQueryTerms ::+  [CollectedModule] ->+  ResolveMode ->+  [Term] ->+  Either [Diagnostic RenameError] ([Term], [Diagnostic RenameWarning])+renameQueryTerms mods mode terms =+  let queryMod =+        CollectedModule+          { name = "<query>",+            nameLoc = dummyLoc,+            imports = [noAnnP (CollectedImport m.name Nothing) | m <- mods],+            decls = [],+            extensionTypes = [],+            typeDecls = [],+            rules = [],+            equations = [],+            extensions = [],+            classExtensions = [],+            exports = Nothing+          }+      ctx0 =+        RenameCtx+          { declEnv = buildDeclEnv mods,+            exportEnv = buildExportEnv mods,+            dataConEnv = Map.empty,+            dataConProviders = Map.empty,+            allDataConProviders = buildAllDataConProviders mods,+            typeDeclEnv = buildTypeDeclEnv mods,+            typeExportEnv = buildTypeExportEnv mods,+            operatorExports = Map.empty,+            currentTrailingLoc = Nothing,+            allModuleNames = map (.name) mods,+            currentModule = queryMod+          }+      visible = visibleDataCons mods ctx0+      ctx =+        ctx0+          { dataConEnv = buildDataConEnv visible mods,+            dataConProviders = buildDataConProviders visible mods+          }+      ((renamed, warnings), errs) =+        runWriter+          ( runWriterT $+              traverse (renameTerm ctx dummyLoc (Atom "") mode) terms+          )+   in if null errs then Right (renamed, warnings) else Left errs++{- ---------------------------------------------------------------------------+Notes+-----------------------------------------------------------------------------++Why 'reservedSymbolSet' exists as a safety net in 'resolveName' even though+@is@, @->@, and @/@ are already handled by early special cases in+'renameTerm': those special cases only match specific shapes (@is/2@,+@->/2@ with a @fun(...)@ LHS, @//2@ with atom+int args). Any other shape+falls through to the default compound-term branch, where the reserved+check keeps them 'Unqualified' rather than producing a spurious+'UnknownName' error.++Why the @is@ LHS is renamed with 'NoResolve' while its RHS uses+'ResolveAll': the LHS is a pattern (typically a single variable or a data+term to unify with) and does not contain callable references, whereas the+RHS is an arbitrary expression.++Why a bare atom in expression position can emit an+'UndeclaredDataConstructor' warning: at the AST level there is no+separate atom form — the parser already represents bare names as+@CompoundTerm (Unqualified n) []@, so the renamer treats them+uniformly as zero-arity data constructors. If the name is instead+declared as a zero-arity constraint or function, the dedicated 0-arity+arm in 'renameTerm' canonicalizes it to the qualified form before the+warning path runs.++Why 'renameTypeDefinition' is pure while the rule/equation helpers live in+'Eff': type renaming currently emits no errors or warnings (unknown types+fall through as 'Unqualified'). If type checking is introduced later,+these helpers will need to move into 'Rename'.+--------------------------------------------------------------------------- -}
+ src/YCHR/Internal/Rename/Types.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module      : YCHR.Internal.Rename.Types+-- Description : Environment types shared by the renamer.+--+-- The renamer (see "YCHR.Internal.Rename") consults two kinds of global environments+-- when resolving a surface name to a fully-qualified one:+--+-- * 'DeclEnv' — where each @(name, arity)@ is /declared/. Used to resolve+--   references to the module a rule belongs to (\"what does this module+--   itself provide?\") and to validate already-qualified references.+-- * 'ExportEnv' — where each @(name, arity)@ is /exported/. Used to resolve+--   references to imported modules (\"what do the modules I import give+--   me?\").+--+-- Both wrap a @Map (name, arity) [module]@ because a single identifier can+-- resolve to several modules (which triggers an ambiguity error). They are+-- kept as distinct newtypes so that callers can't accidentally use a+-- declaration map in place of an export map.+module YCHR.Internal.Rename.Types+  ( -- * Export environment+    ExportEnv,+    makeExportEnv,+    lookupExport,+    toListExport,++    -- * Declaration environment+    DeclEnv,+    makeDeclEnv,+    lookupDecl,+    toListDecl,++    -- * Reserved names+    isReserved,+  )+where++import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)++-- | All names exported by each module, indexed by @(name, arity)@. For a+-- module without an explicit @module@ directive, every declaration is+-- considered exported.+newtype ExportEnv = ExportEnv (Map.Map (Text, Int) [Text])++makeExportEnv :: [((Text, Int), [Text])] -> ExportEnv+makeExportEnv = ExportEnv . Map.fromListWith (++)++lookupExport :: (Text, Int) -> ExportEnv -> [Text]+lookupExport k (ExportEnv m) = Map.findWithDefault [] k m++toListExport :: ExportEnv -> [((Text, Int), [Text])]+toListExport (ExportEnv m) = Map.toList m++-- | All names declared anywhere in the program, indexed by @(name, arity)@.+-- Unlike 'ExportEnv', this ignores export lists: it answers \"is this name+-- visible within its own declaring module?\".+newtype DeclEnv = DeclEnv (Map.Map (Text, Int) [Text])++makeDeclEnv :: [((Text, Int), [Text])] -> DeclEnv+makeDeclEnv = DeclEnv . Map.fromListWith (++)++lookupDecl :: (Text, Int) -> DeclEnv -> [Text]+lookupDecl k (DeclEnv m) = Map.findWithDefault [] k m++toListDecl :: DeclEnv -> [((Text, Int), [Text])]+toListDecl (DeclEnv m) = Map.toList m++-- | Names that must stay 'YCHR.Types.Unqualified' even in resolving+-- contexts. These are desugaring-level keywords (@true@, @=@, @is@, @->@,+-- @$call@) that the desugarer matches by name; qualifying them+-- would break that dispatch.+--+-- Most of these forms are handled by dedicated shape-matching cases in+-- 'YCHR.Internal.Rename.renameTerm'. This set is the fallback for shapes that don't+-- match those cases (e.g. @is/3@).+reservedSymbolSet :: Set Text+reservedSymbolSet = Set.fromList ["true", "=", "is", "->", "$call", "quote", "fun"]++isReserved :: Text -> Bool+isReserved t = Set.member t reservedSymbolSet
+ src/YCHR/Internal/Repl.hs view
@@ -0,0 +1,799 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Interactive REPL for compiled CHR programs.+--+-- Owns all REPL UI: outer command loop (one-off queries plus colon+-- commands like @:list_declarations@), live-session loop (persistent+-- constraint store between queries, exit with @:end@), prompts, and+-- the help text. Line input (history, tab completion, EOF handling)+-- is delegated to 'YCHR.Internal.LineInput', whose implementation differs+-- between GHC (haskeline) and MicroHS (bare 'getLine'). Only+-- 'runRepl' is exported; everything else is internal.+module YCHR.Internal.Repl+  ( runRepl,+  )+where++import Control.Exception (SomeException, displayException, fromException, try)+import Control.Monad (unless, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask, runReaderT)+import Data.List (intercalate, sort, stripPrefix)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import System.Exit (exitFailure)+import System.IO (hPutStr, hPutStrLn, stderr, stdout)+import YCHR.Internal.Collected (CollectedModule (..))+import YCHR.Internal.Compile.Pipeline (CompiledProgram (..), ExportResolution (..))+import YCHR.Internal.Desugared qualified as D+import YCHR.Internal.Display (Display (..), displayMsg)+import YCHR.Internal.LineInput (LineInput (..), LineInputSettings (..), mkLineInput)+import YCHR.Internal.PExpr qualified as P+import YCHR.Internal.Parsed qualified as Parsed+import YCHR.Internal.Parser (opTableEntries, parseTermWith)+import YCHR.Internal.Pretty+  ( DeclKind (..),+    prettyConstraintDecl,+    prettyFunctionDecl,+    prettyQualifiedName,+    prettyQueryResult,+    prettyTypeDecl,+    renderAtom,+  )+import YCHR.Internal.Runtime.Interpreter (HostCallRegistry)+import YCHR.Internal.Runtime.Monad (Chr)+import YCHR.Internal.Runtime.Session+  ( toSessionInput,+    withCHR,+    withCHRExtra,+    withCHRExtraTraced,+    withTraceHandler,+  )+import YCHR.Internal.Runtime.Trace (defaultTraceHandler)+import YCHR.Internal.TypeCheck (typeCheckProgram)+import YCHR.Internal.Types+  ( BoundSig,+    DataConstructor (..),+    Name (..),+    QualifiedName (..),+    Term (..),+    TypeDefinition (..),+    TypeExpr,+    typeConstructors,+  )+import YCHR.Internal.Types qualified as Types+import YCHR.Run+  ( Error (..),+    PreparedQuery (..),+    Warning,+    compileFiles,+    executePreparedQuery,+    prepareQuery,+  )++-- ---------------------------------------------------------------------------+-- Entry point+-- ---------------------------------------------------------------------------++-- | Run the interactive REPL on the given files. Compiles the inputs+-- (or an empty program if @files@ is empty), prints any warnings and+-- type errors to stderr, then enters the outer command loop. The+-- session continues until the user types @:quit@ or hits EOF. When+-- @werror@ is set, warnings during the initial load abort startup;+-- during @:recompile@ they keep the previous program loaded.+runRepl :: HostCallRegistry -> Bool -> Bool -> [FilePath] -> IO ()+runRepl hostCalls quietMode werror files = do+  result <- compileFiles True files+  case result of+    Left err -> do+      putStr (displayMsg err)+      exitFailure+    Right (prog, warnings) -> do+      let warnsFatal = werror && not (null warnings)+      when (warnsFatal || not quietMode) (printWarnings warnings)+      when warnsFatal exitFailure+      unless quietMode (printTypeErrors prog)+      let exported = exportedNames prog+      outerInput <-+        mkLineInput+          LineInputSettings+            { historyFile = Just "ychr/history",+              completionCandidates = commandNames ++ exported+            }+      liveInput <-+        mkLineInput+          LineInputSettings+            { historyFile = Just "ychr/history",+              completionCandidates = ":end" : exported+            }+      outerLoop hostCalls quietMode werror files outerInput liveInput prog++-- ---------------------------------------------------------------------------+-- Outer REPL loop+-- ---------------------------------------------------------------------------++outerLoop ::+  HostCallRegistry ->+  Bool ->+  Bool ->+  [FilePath] ->+  LineInput ->+  LineInput ->+  CompiledProgram ->+  IO ()+outerLoop hostCalls quietMode werror files outerInput liveInput = go+  where+    prompt = if quietMode then "" else "ychr> "+    go prog = do+      minput <- outerInput.readLine prompt+      case minput of+        Nothing -> pure ()+        Just input -> dispatch prog input+    dispatch prog input = case input of+      ":quit" -> pure ()+      ":q" -> pure ()+      ":help" -> showHelp *> go prog+      ":h" -> showHelp *> go prog+      ":recompile" -> recompile prog+      ":r" -> recompile prog+      ":list_files" -> showFiles files *> go prog+      ":list_modules" -> showModules prog *> go prog+      ":list_declarations" -> showDeclarations prog *> go prog+      ":list_operators" -> showOperators prog *> go prog+      ":info" -> showInfoUsage *> go prog+      ":i" -> showInfoUsage *> go prog+      ":trace" -> showTraceUsage *> go prog+      ":begin" -> do+        runLiveSession hostCalls liveInput quietMode werror prog+        go prog+      "" -> go prog+      line+        | Just rest <- stripPrefix ":info " line -> showInfo prog rest *> go prog+        | Just rest <- stripPrefix ":i " line -> showInfo prog rest *> go prog+        | Just rest <- stripPrefix ":trace " line ->+            runTracedQuery hostCalls werror prog rest *> go prog+        | otherwise -> runOuterQuery hostCalls werror prog line *> go prog+    recompile prog = do+      result <- compileFiles True files+      case result of+        Left err -> putStr (displayMsg err) *> go prog+        Right (prog', warnings)+          | werror && not (null warnings) -> do+              printWarnings warnings+              -- Surface type errors of the rejected program too, so the+              -- user sees the full diagnostic picture before deciding+              -- what to fix; the previous program stays loaded.+              printTypeErrors prog'+              go prog+          | otherwise -> do+              printWarnings warnings+              printTypeErrors prog'+              go prog'++-- | Run a one-off query in the outer REPL: parse, typecheck, execute+-- in a fresh CHR session. Distinct exception classes are surfaced+-- differently — 'Error' values via 'displayMsg', everything else as+-- @"Error: " ++ displayException@. Under @--Werror@, query-rename+-- warnings short-circuit before execution; the constraint store is+-- untouched (one-shot queries get a fresh store anyway).+runOuterQuery :: HostCallRegistry -> Bool -> CompiledProgram -> String -> IO ()+runOuterQuery hostCalls werror prog line = do+  prepResult <-+    try @SomeException $+      prepareQuery prog (T.pack line)+  case prepResult of+    Left exc -> reportException exc+    Right (prep, ws) -> do+      printWarnings ws+      unless (werror && not (null ws)) $ do+        execResult <-+          try @SomeException $+            withCHRExtra (toSessionInput prog) hostCalls prep.extraProcs $+              executePreparedQuery prep.liftedGoals+        case execResult of+          Left exc -> reportException exc+          Right bindings -> putStr (prettyQueryResult bindings)+  where+    reportException exc = case fromException exc of+      Just err -> putStr (displayMsg (err :: Error))+      Nothing -> putStrLn ("Error: " ++ displayException exc)++-- | Run a one-off query in the outer REPL with refined-operational-+-- semantics tracing enabled. Output is the trace stream only —+-- bindings are intentionally not printed, matching the documented+-- @:trace@ behaviour. To see bindings, re-run the goal without+-- @:trace@.+runTracedQuery :: HostCallRegistry -> Bool -> CompiledProgram -> String -> IO ()+runTracedQuery hostCalls werror prog line = do+  prepResult <-+    try @SomeException $+      prepareQuery prog (T.pack line)+  case prepResult of+    Left exc -> reportException exc+    Right (prep, ws) -> do+      printWarnings ws+      unless (werror && not (null ws)) $ do+        execResult <-+          try @SomeException $+            withCHRExtraTraced+              (toSessionInput prog)+              hostCalls+              prep.extraProcs+              (defaultTraceHandler stdout)+              (executePreparedQuery prep.liftedGoals)+        case execResult of+          Left exc -> reportException exc+          Right _ -> pure ()+  where+    reportException exc = case fromException exc of+      Just err -> putStr (displayMsg (err :: Error))+      Nothing -> putStrLn ("Error: " ++ displayException exc)++showTraceUsage :: IO ()+showTraceUsage =+  putStrLn ":trace GOAL  -- run GOAL with refined-operational-semantics tracing"++-- ---------------------------------------------------------------------------+-- Live REPL session+-- ---------------------------------------------------------------------------++-- | Run an interactive live session. A single 'withCHR' call wraps+-- the whole session, so the constraint store, propagation history,+-- and reactivation queue persist across queries entered at the+-- @ychr live>@ prompt. The session ends when the user types @:end@,+-- hits EOF, or a runtime error aborts execution.+runLiveSession ::+  HostCallRegistry ->+  LineInput ->+  Bool ->+  Bool ->+  CompiledProgram ->+  IO ()+runLiveSession hostCalls liveInput quietMode werror cp =+  withCHR (toSessionInput cp) hostCalls liveLoop+  where+    prompt = if quietMode then "" else "ychr live> "+    liveLoop :: Chr ()+    liveLoop = do+      mline <- liftIO (liveInput.readLine prompt)+      case mline of+        Nothing -> pure ()+        Just line -> dispatch line+    dispatch line+      | stripped == ":end" = pure ()+      | T.null stripped = liveLoop+      | Just rest <- T.stripPrefix ":trace " stripped = do+          outcome <-+            withTraceHandler (defaultTraceHandler stdout) $+              handleLiveQuery cp werror rest+          case outcome of+            QueryOk _ -> liveLoop+            QueryRecoverable msg -> do+              liftIO (hPutStr stderr msg)+              liveLoop+            QueryFatal msg -> liftIO $ do+              hPutStr stderr msg+              hPutStrLn stderr "live session aborted due to runtime error."+      | stripped == ":trace" = do+          liftIO showTraceUsage+          liveLoop+      | otherwise = do+          outcome <- handleLiveQuery cp werror (T.pack line)+          case outcome of+            QueryOk bindings -> do+              liftIO (putStr (prettyQueryResult bindings))+              liveLoop+            QueryRecoverable msg -> do+              liftIO (hPutStr stderr msg)+              liveLoop+            QueryFatal msg -> liftIO $ do+              hPutStr stderr msg+              hPutStrLn stderr "live session aborted due to runtime error."+      where+        stripped = T.strip (T.pack line)++-- | Outcome of executing a single live-session query.+data QueryOutcome+  = -- | Query ran to completion. Carries the resulting bindings.+    QueryOk (Map Text Term)+  | -- | A pre-execution problem (parse, type, lambdas-rejected) that+    -- left the constraint store untouched. The session can continue.+    QueryRecoverable String+  | -- | A runtime exception thrown during goal execution. The store+    -- and bindings may be inconsistent; the live session must abort.+    QueryFatal String++-- | Handle one query inside an existing live session: parse / typecheck+-- in 'IO' (catching 'Error'), reject lifted lambdas (live sessions+-- cannot grow the procedure map), then execute and catch any runtime+-- exception as a fatal outcome. Under @--Werror@, query-rename+-- warnings short-circuit before execution: the warnings are printed+-- to stderr and the query is treated as recoverable, leaving the+-- session's constraint store untouched.+handleLiveQuery ::+  CompiledProgram ->+  Bool ->+  Text ->+  Chr QueryOutcome+handleLiveQuery cp werror src = do+  prepResult <- liftIO (try @SomeException (prepareQuery cp src))+  case prepResult of+    Left exc -> pure (classifyAsRecoverable exc)+    Right (prep, ws) -> do+      liftIO (printWarnings ws)+      if werror && not (null ws)+        then pure (QueryRecoverable "")+        else case prep.queryLambdas of+          (lam : _) ->+            let lamEqs = lam.equations :: Parsed.AnnP [D.Equation]+                Parsed.AnnP _ loc origin = lamEqs+             in pure (QueryRecoverable (displayMsg (LambdasInLiveQuery loc origin)))+          [] -> do+            env <- ask+            execResult <-+              liftIO $+                try @SomeException $+                  runReaderT (executePreparedQuery prep.liftedGoals) env+            case execResult of+              Left exc -> pure (QueryFatal (renderFatal exc))+              Right bindings -> pure (QueryOk bindings)+  where+    classifyAsRecoverable exc = case fromException exc :: Maybe Error of+      Just err -> QueryRecoverable (displayMsg err)+      Nothing -> QueryFatal (renderFatal exc)+    -- A fatal exception is most often an 'Error' (e.g. a runtime error+    -- escaping 'executePreparedQuery'); rendering through 'displayMsg'+    -- gives the same nicely-formatted output the outer REPL produces.+    -- Anything else falls back to 'displayException'.+    renderFatal exc = case fromException exc :: Maybe Error of+      Just err -> displayMsg err+      Nothing -> displayException exc ++ "\n"++-- ---------------------------------------------------------------------------+-- Commands+-- ---------------------------------------------------------------------------++-- | A REPL colon-command. The names list is the command plus its+-- aliases; @description@ is the help text. This list is the single+-- source of truth for tab-completion and the @:help@ output.+data Command = Command+  { names :: [String],+    description :: String+  }++commands :: [Command]+commands =+  [ Command [":help", ":h"] "Show this help message",+    Command [":recompile", ":r"] "Recompile the loaded files",+    Command [":list_files"] "List the compiled files",+    Command [":list_modules"] "List the compiled modules",+    Command [":list_declarations"] "List visible declarations",+    Command [":list_operators"] "List defined operators",+    Command [":info", ":i"] "Show information about an identifier",+    Command [":trace"] "Run a goal with refined-operational-semantics tracing",+    Command [":begin"] "Start a live CHR session (end with :end)",+    Command [":quit", ":q"] "Exit the REPL"+  ]++commandNames :: [String]+commandNames = concatMap (\c -> c.names) commands++-- ---------------------------------------------------------------------------+-- Command handlers+-- ---------------------------------------------------------------------------++showHelp :: IO ()+showHelp = do+  putStrLn "Commands:"+  mapM_ (putStrLn . renderCommand) commands+  where+    -- Align descriptions at column 25 to match the original layout.+    renderCommand c =+      let label = intercalate ", " c.names+          padding = replicate (max 1 (23 - length label)) ' '+       in "  " ++ label ++ padding ++ c.description++showFiles :: [FilePath] -> IO ()+showFiles = mapM_ putStrLn++showModules :: CompiledProgram -> IO ()+showModules prog =+  mapM_ (\(CollectedModule {name = n}) -> putStrLn (T.unpack n)) prog.allModules++showDeclarations :: CompiledProgram -> IO ()+showDeclarations prog = mapM_ putStrLn declLines+  where+    declLines = dedup entries+    entries =+      [ (kw, m.name, n, a)+      | m <- prog.allModules,+        Parsed.Ann d _ <- m.decls,+        (kw, n, a) <- case d of+          Parsed.ConstraintDecl {name = n, arity = a} -> [("chr_constraint", n, a)]+          Parsed.FunctionDecl {name = n, arity = a, isOpen = o, kind = k} ->+            let kw = case (o, k) of+                  (False, Parsed.DKFunction) -> "function"+                  (True, Parsed.DKFunction) -> "open_function"+                  (False, Parsed.DKClass) -> "class"+                  (True, Parsed.DKClass) -> "open_class"+             in [(kw, n, a)]+          Parsed.ExtendClassTypeDecl {name = n, arity = a} ->+            [("extend_class_type", n, a)]+          _ -> []+      ]+    dedup = go Set.empty+      where+        go _ [] = []+        go seen (e@(kw, modName, n, a) : rest)+          | Set.member e seen = go seen rest+          | otherwise = renderDecl kw modName n a : go (Set.insert e seen) rest+    renderDecl kw modName name arity =+      ":- "+        ++ kw+        ++ " "+        ++ renderAtom modName+        ++ ":"+        ++ renderAtom name+        ++ "/"+        ++ show arity+        ++ "."++showOperators :: CompiledProgram -> IO ()+showOperators prog = mapM_ (putStrLn . renderOp) entries+  where+    entries = sort [(fix, opTypeStr ty, name) | (fix, ty, name) <- opTableEntries prog.opTable]+    renderOp (fix, ty, name) =+      "op(" ++ show fix ++ ", " ++ ty ++ ", " ++ renderAtom name ++ ")"+    opTypeStr ty = case ty of+      P.Xfx -> "xfx"+      P.Xfy -> "xfy"+      P.Yfx -> "yfx"+      P.Fx -> "fx"+      P.Fy -> "fy"+      P.Xf -> "xf"+      P.Yf -> "yf"++-- ---------------------------------------------------------------------------+-- :info / :i — identifier inspection+-- ---------------------------------------------------------------------------++-- | Hard-coded set of names recognized as base types of the+-- @'$typechecker'@ module. These match the @ty@ ADT constructors+-- treated specially by 'YCHR.Internal.TypeCheck.encodeTypeExpr'.+builtinTypeNames :: [Text]+builtinTypeNames = ["int", "float", "string", "any"]++showInfoUsage :: IO ()+showInfoUsage = putStrLn "usage: :info <identifier>"++-- | Parse the argument to @:info@. Accepts @name@, @name/arity@,+-- @mod:name@, or @mod:name/arity@. Returns 'Nothing' if the parse+-- fails or the resulting term is not a recognized identifier shape,+-- in which case 'showInfo' falls back to "unknown identifier".+parseInfoArg :: CompiledProgram -> Text -> Maybe (Either Text QualifiedName, Maybe Int)+parseInfoArg prog raw = case parseTermWith prog.opTable "<:info>" raw of+  Left _ -> Nothing+  Right t -> termToInfoArg t++termToInfoArg :: Term -> Maybe (Either Text QualifiedName, Maybe Int)+termToInfoArg = \case+  CompoundTerm (Unqualified "/") [headT, IntTerm a] -> do+    (nm, _) <- termToInfoArg headT+    pure (nm, Just (fromInteger a))+  CompoundTerm (Unqualified n) [] ->+    Just (Left n, Nothing)+  CompoundTerm (Qualified m n) [] ->+    Just (Right (QualifiedName m n), Nothing)+  _ -> Nothing++-- | One discovered fact about an identifier. The qualified name is+-- always attached so 'renderInfoEntry' does not need to re-derive it.+data InfoEntry+  = -- | The identifier is a constraint. The @Maybe [TypeExpr]@ is+    -- 'Just' when the constraint is typed (declared via+    -- @:- chr_constraint name(T1, ..., Tn)@), 'Nothing' otherwise.+    IEConstraint QualifiedName Int (Maybe [TypeExpr]) [BoundSig]+  | -- | The identifier is a function or class. The 'DeclKind' comes+    -- from the original 'Parsed.Declaration' in 'allModules'.+    IEFunction D.Function DeclKind+  | -- | The identifier is a user-declared type.+    IEType TypeDefinition+  | -- | The identifier is a data constructor of the carried type.+    IEDataCtor TypeDefinition DataConstructor+  | -- | The identifier is one of the four typechecker-module base+    -- types (@int@, @float@, @string@, @any@).+    IEBuiltinType QualifiedName+  | -- | The identifier exists at this arity but is exported by+    -- multiple modules; the user must qualify to disambiguate. The+    -- list of module names mirrors the @AmbiguousExport@ entry in+    -- 'CompiledProgram.exportMap'.+    IEAmbiguous Text Int [Text]+  deriving (Show)++-- | Look up every fact known about an identifier. Order matters: the+-- caller prints entries in the order returned, so the most specific+-- match is emitted first.+lookupInfo :: CompiledProgram -> Either Text QualifiedName -> Maybe Int -> [InfoEntry]+lookupInfo prog name mArity =+  let arityMatches a = maybe True (== a) mArity+   in case name of+        Right qn -> qualifiedLookup prog qn mArity+        Left n ->+          let builtinEntries =+                [ IEBuiltinType (QualifiedName "$typechecker" n)+                | n `elem` builtinTypeNames,+                  arityMatches 0+                ]+              exportEntries =+                concatMap (resolveExportArity prog n) (matchingArities prog n mArity)+              typeEntries =+                [ IEType td+                | td <- prog.desugaredProgram.typeDefinitions,+                  typeBaseName td == n,+                  arityMatches (length td.typeVars)+                ]+              ctorEntries =+                [ IEDataCtor td c+                | td <- prog.desugaredProgram.typeDefinitions,+                  c <- typeConstructors td,+                  ctorBaseName c == n,+                  arityMatches (length c.conArgs),+                  isCtorExportedByParent prog td c+                ]+           in builtinEntries ++ exportEntries ++ typeEntries ++ ctorEntries++-- | Arities to inspect for an unqualified name. When the user supplied+-- an arity, only that one is returned; otherwise every arity present+-- in 'exportMap' under this name is returned (in ascending order so+-- output is deterministic).+matchingArities :: CompiledProgram -> Text -> Maybe Int -> [Int]+matchingArities prog n = \case+  Just a -> [a | Map.member (Types.UnqualifiedIdentifier n a) prog.exportMap]+  Nothing ->+    sort+      [ a+      | Types.UnqualifiedIdentifier n' a <- Map.keys prog.exportMap,+        n' == n+      ]++-- | Resolve an unqualified name at a specific arity through 'exportMap'.+-- An unambiguous match dispatches to 'classifyQualified'; an ambiguous+-- one becomes a single 'IEAmbiguous' entry that the user must clear+-- by qualifying.+resolveExportArity :: CompiledProgram -> Text -> Int -> [InfoEntry]+resolveExportArity prog n a =+  case Map.lookup (Types.UnqualifiedIdentifier n a) prog.exportMap of+    Nothing -> []+    Just (UniqueExport qn) -> classifyQualified prog qn a+    Just (AmbiguousExport ms) -> [IEAmbiguous n a ms]++-- | Look up a qualified name directly in the compiled program. No+-- 'exportMap' traversal because the user has already disambiguated.+-- Types and constructors are matched regardless of arity when the user+-- omitted it (matching the behavior of the unqualified path).+qualifiedLookup :: CompiledProgram -> QualifiedName -> Maybe Int -> [InfoEntry]+qualifiedLookup prog qn mArity =+  let arityMatches a = maybe True (== a) mArity+      classifyAt = case mArity of+        Just a -> classifyQualified prog qn a+        Nothing ->+          -- Without an arity, scan every arity the program declares+          -- for this qualified name across constraints/functions.+          let cTyArities =+                [ length args+                | (qn', args) <- Map.toList prog.desugaredProgram.constraintTypes,+                  qn' == qn+                ]+              fArities =+                [f.arity | f <- prog.desugaredProgram.functions, f.name == qn]+              exportArities =+                [ a+                | Types.QualifiedIdentifier m n a <- Set.toAscList prog.exportedSet,+                  m == qn.moduleName && n == qn.baseName+                ]+              allArities =+                sort (Set.toAscList (Set.fromList (cTyArities ++ fArities ++ exportArities)))+           in concatMap (classifyQualified prog qn) allArities+      typeEntries =+        [ IEType td+        | td <- prog.desugaredProgram.typeDefinitions,+          typeMatchesQN td qn,+          arityMatches (length td.typeVars)+        ]+      ctorEntries =+        [ IEDataCtor td c+        | td <- prog.desugaredProgram.typeDefinitions,+          c <- typeConstructors td,+          ctorMatchesQN c qn,+          arityMatches (length c.conArgs),+          isCtorExportedByParent prog td c+        ]+      builtinEntries =+        [ IEBuiltinType qn+        | qn.moduleName == "$typechecker",+          qn.baseName `elem` builtinTypeNames,+          arityMatches 0+        ]+   in builtinEntries ++ classifyAt ++ typeEntries ++ ctorEntries++-- | Decide what kind of declaration a @(qn, arity)@ pair refers to.+-- Priority: function over constraint — an identifier cannot be both+-- at the same arity (the resolver rejects that as+-- @ConstraintFunctionCollision@). Every declared constraint, typed+-- or not, lives in 'constraintTypes' (untyped constraints have an+-- @any@-filled signature synthesized by the resolver), so a single+-- lookup there covers both forms.+classifyQualified :: CompiledProgram -> QualifiedName -> Int -> [InfoEntry]+classifyQualified prog qn arity =+  case [f | f <- prog.desugaredProgram.functions, f.name == qn, f.arity == arity] of+    (f : _) -> [IEFunction f (functionDeclKind prog qn arity)]+    [] -> case Map.lookup qn prog.desugaredProgram.constraintTypes of+      Just args+        | length args == arity ->+            let bs = Map.findWithDefault [] qn prog.desugaredProgram.constraintBounds+             in [IEConstraint qn arity (Just args) bs]+      _ -> []++-- | Recover the @function@ / @open_function@ / @class@ / @open_class@+-- keyword for a 'D.Function' by scanning every parsed module's+-- declarations. Returns the first matching 'Parsed.FunctionDecl' (in+-- 'allModules' iteration order); defaults to 'DKFunction' if none is+-- found, which only happens for synthetic declarations like lifted+-- lambdas (@__lambda_N@) that users would not normally inspect.+functionDeclKind :: CompiledProgram -> QualifiedName -> Int -> DeclKind+functionDeclKind prog qn arity =+  let matches =+        [ (d.isOpen, d.kind)+        | m <- prog.allModules,+          m.name == qn.moduleName,+          Parsed.Ann d _ <- m.decls,+          Parsed.FunctionDecl {} <- [d],+          d.name == qn.baseName,+          d.arity == arity+        ]+   in case matches of+        ((False, Parsed.DKFunction) : _) -> DKFunction+        ((True, Parsed.DKFunction) : _) -> DKOpenFunction+        ((False, Parsed.DKClass) : _) -> DKClass+        ((True, Parsed.DKClass) : _) -> DKOpenClass+        [] -> DKFunction++-- The renamer guarantees that 'TypeDefinition.name' and+-- 'DataConstructor.conName' are always 'Qualified' once resolution+-- completes (see 'renameDataConstructor' and 'renameTypeDefinition'+-- in "YCHR.Internal.Rename"). The 'Unqualified' arms below are defensive+-- fallbacks that compare on the base name only; they should never+-- fire in a well-formed compiled program.++typeBaseName :: TypeDefinition -> Text+typeBaseName td = case td.name of+  Unqualified n -> n+  Qualified _ n -> n++ctorBaseName :: DataConstructor -> Text+ctorBaseName c = case c.conName of+  Unqualified n -> n+  Qualified _ n -> n++typeMatchesQN :: TypeDefinition -> QualifiedName -> Bool+typeMatchesQN td qn = case td.name of+  Qualified m n -> m == qn.moduleName && n == qn.baseName+  Unqualified _ -> False++ctorMatchesQN :: DataConstructor -> QualifiedName -> Bool+ctorMatchesQN c qn = case c.conName of+  Qualified m n -> m == qn.moduleName && n == qn.baseName+  Unqualified _ -> False++-- | Is the given data constructor visible through its parent type's+-- module export list? @:info@ uses this to refuse direct queries on+-- hidden constructors while still listing them inside the parent+-- type's declaration body (when the user asks about the type or+-- another visible constructor of the same type).+--+-- The rule mirrors 'YCHR.Internal.Rename.exporterAllowance': a module with no+-- @:- module(_, [...])@ exports everything; an explicit+-- @type(T\/A)@ entry exports every constructor; @type(T\/A, [C1,+-- C2])@ exports only the listed names; and a type missing from the+-- export list exports no constructors at all.+isCtorExportedByParent ::+  CompiledProgram -> TypeDefinition -> DataConstructor -> Bool+isCtorExportedByParent prog td c =+  let tn = typeBaseName td+      ta = length td.typeVars+      cn = ctorBaseName c+      parentModule = case td.name of+        Qualified m _ -> Just m+        Unqualified _ -> Nothing+   in case parentModule >>= findModule prog of+        Nothing -> True+        Just m -> case m.exports of+          Nothing -> True+          Just (Parsed.AnnP exports _ _) ->+            case [cs | Parsed.TypeExportDecl tn' ta' cs <- exports, tn' == tn, ta' == ta] of+              (Nothing : _) -> True+              (Just xs : _) -> cn `elem` xs+              [] -> False++findModule :: CompiledProgram -> Text -> Maybe CollectedModule+findModule prog modName =+  case [m | m <- prog.allModules, m.name == modName] of+    (m : _) -> Just m+    [] -> Nothing++-- | Print the result of an @:info@ query. The qualified name and the+-- declaration form are printed on consecutive lines for each match;+-- multiple matches are separated by blank lines. An empty result set+-- (no matches in any category) prints "unknown identifier: <raw>".+showInfo :: CompiledProgram -> String -> IO ()+showInfo prog raw =+  let trimmed = T.strip (T.pack raw)+   in if T.null trimmed+        then showInfoUsage+        else case parseInfoArg prog trimmed of+          Nothing -> printUnknown (T.unpack trimmed)+          Just (name, mArity) ->+            case lookupInfo prog name mArity of+              [] -> printUnknown (T.unpack trimmed)+              entries -> putStr (renderInfo entries)+  where+    printUnknown s = putStrLn ("unknown identifier: " ++ s)++renderInfo :: [InfoEntry] -> String+renderInfo = intercalate "\n" . map renderInfoEntry++renderInfoEntry :: InfoEntry -> String+renderInfoEntry = \case+  IEBuiltinType qn ->+    prettyQualifiedName qn ++ "\nbuilt-in type\n"+  IEConstraint qn arity mArgs bounds ->+    prettyQualifiedName qn+      ++ "\n"+      ++ prettyConstraintDecl qn arity mArgs bounds+      ++ "\n"+  IEFunction f kind ->+    prettyQualifiedName f.name+      ++ "\n"+      ++ prettyFunctionDecl f.name f.arity f.signatures f.requiring kind+      ++ "\n"+  IEType td ->+    let qn = case td.name of+          Unqualified n -> QualifiedName "" n+          Qualified m n -> QualifiedName m n+     in prettyQualifiedName qn ++ "\n" ++ prettyTypeDecl td ++ "\n"+  IEDataCtor td c ->+    let qn = case c.conName of+          Unqualified n -> QualifiedName "" n+          Qualified m n -> QualifiedName m n+     in prettyQualifiedName qn ++ "\n" ++ prettyTypeDecl td ++ "\n"+  IEAmbiguous n arity ms ->+    "ambiguous identifier: "+      ++ T.unpack n+      ++ "/"+      ++ show arity+      ++ " is exported by "+      ++ intercalate ", " (map T.unpack ms)+      ++ "; qualify with mod:name to disambiguate\n"++-- ---------------------------------------------------------------------------+-- Reporting helpers+-- ---------------------------------------------------------------------------++-- | Sorted list of unqualified exported constraint names from a+-- compiled program. Used as completion candidates in both modes.+exportedNames :: CompiledProgram -> [String]+exportedNames prog =+  Set.toAscList . Set.fromList $+    [T.unpack n | Types.UnqualifiedIdentifier n _ <- Map.keys prog.exportMap]++printWarnings :: [Warning] -> IO ()+printWarnings = mapM_ (hPutStr stderr . displayMsg)++printTypeErrors :: CompiledProgram -> IO ()+printTypeErrors prog = do+  errs <- typeCheckProgram prog.desugaredProgram+  mapM_ (hPutStr stderr . displayMsg) errs
+ src/YCHR/Internal/Resolve.hs view
@@ -0,0 +1,1180 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Post-rename resolution.+--+-- Flattens @[CollectedModule]@ into a single 'R.Program', grouping function+-- equations under their declarations and verifying that declaration+-- kinds are used consistently.+module YCHR.Internal.Resolve+  ( -- * Errors+    ResolveError (..),++    -- * Resolution+    resolveProgram,+    termToExpr,++    -- * Visibility+    FunVisibility,+    buildQueryFunctionVisibility,+  )+where++import Control.Monad.Trans.Writer.CPS (Writer, runWriter, tell)+import Data.List (nub)+import Data.List.NonEmpty (NonEmpty (..))+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 YCHR.Internal.Collected (CollectedImport (..), CollectedModule (..))+import YCHR.Internal.Diagnostic (Diagnostic, noDiag)+import YCHR.Internal.PExpr qualified as PExpr+import YCHR.Internal.Parsed (FunctionDeclKind (..))+import YCHR.Internal.Parsed qualified as P+import YCHR.Internal.Resolved qualified as R+import YCHR.Internal.Types+  ( BoundSig (..),+    Constraint (..),+    HeadArg (..),+    Name (..),+    QualifiedConstraint (..),+    QualifiedIdentifier (..),+    QualifiedName (..),+    Term (..),+    TypeExpr (..),+    flattenName,+  )++data ResolveError+  = -- | A name declared as a constraint has function equations.+    ConstraintHasEquations Name+  | -- | A name declared as a function appears in a rule head.+    FunctionInRuleHead Name+  | -- | A name collides with a reserved built-in.+    ReservedName Name+  | -- | A user module is declared with a reserved name (currently+    -- only @host@, which is wired in as the host-call qualifier).+    ReservedModuleName Text+  | -- | A constraint name reached the resolve phase without being+    -- module-qualified by the renamer. Indicates a renamer bug rather+    -- than user error.+    UnqualifiedConstraintName Name+  | -- | An @:- extend_class_type@, @:- extend_function@, or+    -- @:- extend_class@ directive targets a declaration that is not+    -- open (no @open_function@ / @open_class@ keyword).+    ExtendsClosedFunction Name+  | -- | A free-floating function equation appears in a module that is+    -- not the declaring module of the function. Carries the qualified+    -- function name and the module in which the equation was found.+    OrphanFunctionEquation Name Text+  | -- | An @:- extend_class_type@ directive targets an open class+    -- that itself carries a @requiring@ clause. The instance set of a+    -- bounded open class is determined by its bounds, not by+    -- enumerated extensions.+    ExtendTypeOnBoundedFunction Name+  | -- | A @requiring@ clause references a type variable that does not+    -- appear in the enclosing declaration's primary signature. Carries+    -- the enclosing declaration's flattened name and the offending+    -- variable name.+    UnboundBoundVariable Text Text+  | -- | A @requiring@ clause names a function that is not declared in+    -- the program (or is declared at a different arity). Carries the+    -- enclosing declaration's flattened name, the bound function's+    -- flattened name, and the bound's arity.+    UnknownBoundFunction Text Text Int+  | -- | The bound graph contains a cycle. Carries the flattened names+    -- of the declarations on the cycle in source order.+    BoundCycle [Text]+  | -- | A @:- function@ or @:- open_function@ declaration carries+    -- more than one signature for the same name and arity. Multiple+    -- signatures require the @:- class@ / @:- open_class@ form.+    MultiSigOnFunction Name+  | -- | The same name and arity is declared with both @:- function@+    -- / @:- open_function@ and @:- class@ / @:- open_class@. The two+    -- forms are mutually exclusive.+    MixedDeclKinds Name+  | -- | An @:- extend_class_type@ directive targets a declaration+    -- declared with @:- function@ / @:- open_function@. The type+    -- extension only makes sense against an @:- open_class@.+    ExtendClassTypeOnFunction Name+  | -- | An @:- extend_class@ directive targets a declaration+    -- declared with @:- function@ / @:- open_function@; use+    -- @:- extend_function@ instead.+    ExtendClassOnFunction Name+  | -- | An @:- extend_function@ directive targets a declaration+    -- declared with @:- class@ / @:- open_class@; use+    -- @:- extend_class@ instead.+    ExtendFunctionOnClass Name+  | -- | The same name and arity is declared as both+    -- @:- chr_constraint@ and @:- function@ / @:- open_function@ /+    -- @:- class@ / @:- open_class@ in a single module. Constraints+    -- and functions share the symbol namespace, so the collision is+    -- ambiguous regardless of whether the name is ever referenced.+    ConstraintFunctionCollision Name+  | -- | A lambda parameter is neither a variable nor a wildcard.+    -- Lambda params must be patterns; literals and compound terms+    -- are rejected here so the resolved AST guarantees well-formed+    -- 'R.LambdaExpr' values.+    LambdaParamError Term+  | -- | A lambda was written with an empty parameter list+    -- (@fun() -> Body end@). Lambdas must take at least one+    -- parameter; users who want a no-arg helper should declare a+    -- named function via @:- function@. The 'R.LambdaExpr' parameter+    -- list is 'NonEmpty', so the resolver substitutes a single+    -- wildcard for recovery.+    EmptyLambdaParams+  deriving (Eq, Show)++-- | Flatten modules into a single resolved program.+--+-- 1. Collect constraint and function declarations.+-- 2. Group equations under their function declarations.+-- 3. Check that no equation targets a constraint name.+-- 4. Check that no rule head references a function name.+resolveProgram :: [CollectedModule] -> Either [Diagnostic ResolveError] R.Program+resolveProgram mods =+  let constraintNames = buildConstraintNames mods+      functionNames = buildFunctionNames mods+      conTypes = collectConstraintTypes mods+      conBounds = collectConstraintBounds mods+      typeDefs = [td.node | m <- mods, td <- m.typeDecls]+      funcOpenness = buildFunctionOpenness mods+      funcKinds = buildFunctionKinds mods+      funcRequiring = buildFunctionRequiring mods+      eqErrors = checkEquations constraintNames mods+      headErrors = checkRuleHeads (Set.map qualifiedNameToLooseName functionNames) mods+      reservedErrors = checkReservedNames mods+      reservedModuleErrors = checkReservedModuleNames mods+      orphanEqErrors = checkOrphanEquations functionNames mods+      extendsClosedErrors = checkExtendsClosed funcOpenness mods+      extendsBoundedErrors = checkExtendsBounded funcRequiring mods+      boundedDeclErrors = checkBoundedDeclarations functionNames mods+      multiSigErrors = checkMultiSigOnFunction mods+      mixedKindErrors = checkMixedDeclKinds mods+      extensionKindErrors = checkExtensionKinds funcKinds mods+      collisionErrors = checkConstraintFunctionCollision mods+      funVisibility = buildFunctionVisibility mods+      (resolvedRules, ruleErrs) = resolveRules funVisibility mods+      (resolvedFunctions, funErrs) = resolveFunctions funVisibility mods+      errs =+        eqErrors+          ++ headErrors+          ++ reservedErrors+          ++ reservedModuleErrors+          ++ orphanEqErrors+          ++ extendsClosedErrors+          ++ extendsBoundedErrors+          ++ boundedDeclErrors+          ++ multiSigErrors+          ++ mixedKindErrors+          ++ extensionKindErrors+          ++ collisionErrors+          ++ ruleErrs+          ++ funErrs+   in if null errs+        then+          Right+            R.Program+              { rules = resolvedRules,+                functions = resolvedFunctions,+                constraintTypes = conTypes,+                constraintBounds = conBounds,+                functionNames = functionNames,+                typeDefinitions = typeDefs+              }+        else Left errs++qualifiedNameToLooseName :: QualifiedName -> Name+qualifiedNameToLooseName (QualifiedName m b) = Qualified m b++-- ---------------------------------------------------------------------------+-- Declaration collection+-- ---------------------------------------------------------------------------++buildConstraintNames :: [CollectedModule] -> Set QualifiedIdentifier+buildConstraintNames mods =+  Set.fromList+    [ QualifiedIdentifier m.name d.name d.arity+    | m <- mods,+      P.Ann d _ <- m.decls,+      P.ConstraintDecl {} <- [d]+    ]++buildFunctionNames :: [CollectedModule] -> Set QualifiedName+buildFunctionNames mods =+  Set.fromList+    [ QualifiedName m.name d.name+    | m <- mods,+      P.Ann d _ <- m.decls,+      P.FunctionDecl {} <- [d]+    ]++{- Note [FunVisibility vs renamer visibility]++The renamer qualifies every constraint, type, and data-constructor+reference per-module: it knows which providers each module imports+and rewrites bare names to 'Qualified' form. So by the time we reach+Resolve, those three name classes are already disambiguated.++Functions are different. In @NoResolve@ positions (compound+arguments of tell-side body constraints and top-level goals) the+renamer deliberately leaves compound heads unqualified — the+call-vs-constructor decision is structural and gets made here in+'termToExpr'. To make that decision we need the same+function-visibility view the renamer uses for @ResolveAll@ /+@ResolveTop@ positions, but restricted to 'FunctionDecl': hence+'FunVisibility'.++The model is per-module: 'buildFunctionVisibility' produces one+table per source module, keyed by the local @(name, arity)@ a term+might mention; 'buildQueryFunctionVisibility' produces a single+combined table for the synthetic @<query>@ module the renamer+fabricates for top-level goals (see 'Rename.renameQueryGoals'). Both+are read by 'termToExpr' to commit each compound to a 'CallExpr' or+'CtorExpr'.+-}++-- | Per-module function visibility. Maps each local @(name, arity)@+-- reachable from the module to the qualified names of the function+-- declarations that provide it.+-- See Note [FunVisibility vs renamer visibility].+type FunVisibility = Map (Text, Int) [QualifiedName]++-- | Build a function-visibility map for every module in a program.+--+-- A function declared in module @P@ is visible in module @M@ iff+-- either @P == M@, or @M@ has a @use_module(P)@ import whose import+-- list permits the declared @(name, arity)@ and @P@'s export list+-- (if any) includes the declaration. By this stage+-- 'YCHR.Internal.Collect.rewriteImports' has collapsed every import into a+-- 'CollectedImport', so there is only one import kind to handle.+buildFunctionVisibility :: [CollectedModule] -> Map Text FunVisibility+buildFunctionVisibility mods =+  Map.fromList [(m.name, perModule m) | m <- mods]+  where+    perModule selfMod =+      Map.fromListWith+        (\a b -> nub (a ++ b))+        [ ((d.name, d.arity), [QualifiedName provider.name d.name])+        | provider <- mods,+          P.Ann d _ <- provider.decls,+          P.FunctionDecl {} <- [d],+          visibleTo selfMod provider d+        ]++    visibleTo selfMod provider d+      | provider.name == selfMod.name = True+      | not (importPermits selfMod provider d) = False+      | otherwise = exportPermits provider d++    importPermits selfMod provider d =+      any+        (matchesImport provider.name d)+        [im.node | im <- selfMod.imports]++    matchesImport providerName d im+      | im.importModule == providerName = importListPermitsFun d im.importItems+      | otherwise = False++    importListPermitsFun _ Nothing = True+    importListPermitsFun d (Just decls) = any (matchesFunDecl d) decls++    exportPermits provider d = case provider.exports of+      Nothing -> True+      Just annExports -> any (matchesFunDecl d) annExports.node++    matchesFunDecl d (P.FunctionDecl {name = n, arity = a}) =+      n == d.name && a == d.arity+    matchesFunDecl d (P.ConstraintDecl {name = n, arity = a}) =+      n == d.name && a == d.arity+    matchesFunDecl _ _ = False++-- | Look up the function-visibility table for a single module,+-- returning the empty map for unknown modules.+funVisibilityFor :: Map Text FunVisibility -> Text -> FunVisibility+funVisibilityFor mv m = Map.findWithDefault Map.empty m mv++-- | Visibility table for query-time term resolution. A query has no+-- enclosing module and sees every /exported/ function declared by any+-- loaded module, mirroring the synthetic @\<query\>@ module the+-- renamer builds in 'Rename.renameQueryGoals' (which imports every+-- module with @use_module(M)@ and resolves names through each+-- module's export list). Used by 'YCHR.Run' to translate top-level+-- goal and argument terms.+--+-- See Note [FunVisibility vs renamer visibility].+buildQueryFunctionVisibility :: [CollectedModule] -> FunVisibility+buildQueryFunctionVisibility mods =+  Map.fromListWith+    (\a b -> nub (a ++ b))+    [ ((d.name, d.arity), [QualifiedName m.name d.name])+    | m <- mods,+      P.Ann d _ <- m.decls,+      P.FunctionDecl {} <- [d],+      exportedBy m d+    ]+  where+    exportedBy m d = case m.exports of+      Nothing -> True+      Just annExports -> any (matchesFunDecl d) annExports.node++    matchesFunDecl d (P.FunctionDecl {name = n, arity = a}) =+      n == d.name && a == d.arity+    matchesFunDecl d (P.ConstraintDecl {name = n, arity = a}) =+      n == d.name && a == d.arity+    matchesFunDecl _ _ = False++-- | Map each declared function to whether its declaration is open.+buildFunctionOpenness :: [CollectedModule] -> Map.Map QualifiedName Bool+buildFunctionOpenness mods =+  Map.fromList+    [ (QualifiedName m.name d.name, d.isOpen)+    | m <- mods,+      P.Ann d _ <- m.decls,+      P.FunctionDecl {} <- [d]+    ]++-- | Map each declared function to the kind of its primary declaration.+-- When the same name is declared with both kinds, an arbitrary winner+-- is recorded here; the conflict is reported separately by+-- 'checkMixedDeclKinds'.+buildFunctionKinds :: [CollectedModule] -> Map.Map QualifiedName FunctionDeclKind+buildFunctionKinds mods =+  Map.fromList+    [ (QualifiedName m.name d.name, d.kind)+    | m <- mods,+      P.Ann d _ <- m.decls,+      P.FunctionDecl {} <- [d]+    ]++collectConstraintTypes :: [CollectedModule] -> Map.Map QualifiedName [TypeExpr]+collectConstraintTypes mods =+  Map.fromList+    [ (QualifiedName m.name d.name, ts)+    | m <- mods,+      P.Ann d _ <- m.decls,+      P.ConstraintDecl {} <- [d],+      let ts = case d.argTypes of+            Just types -> types+            Nothing -> replicate d.arity (TypeCon (Unqualified "any") [])+    ]++-- | Bounds declared on every @:- chr_constraint@ that carries a+-- @requiring@ clause. Unbounded constraints are absent from the map.+collectConstraintBounds :: [CollectedModule] -> Map.Map QualifiedName [BoundSig]+collectConstraintBounds mods =+  Map.fromList+    [ (QualifiedName m.name d.name, bs)+    | m <- mods,+      P.Ann d _ <- m.decls,+      P.ConstraintDecl {requiring = Just bs} <- [d]+    ]++-- | Bounds declared on every @:- function@ / @:- open_function@ that+-- carries a @requiring@ clause. Unbounded functions are absent.+buildFunctionRequiring :: [CollectedModule] -> Map.Map QualifiedName [BoundSig]+buildFunctionRequiring mods =+  Map.fromList+    [ (QualifiedName m.name d.name, bs)+    | m <- mods,+      P.Ann d _ <- m.decls,+      P.FunctionDecl {requiring = Just bs} <- [d]+    ]++-- ---------------------------------------------------------------------------+-- Validation (integrated into resolution)+-- ---------------------------------------------------------------------------++-- | Check that no equation targets a constraint-declared name.+-- Reports only the first equation per name.+checkEquations :: Set QualifiedIdentifier -> [CollectedModule] -> [Diagnostic ResolveError]+checkEquations cNames mods = snd $ foldl go (Set.empty, []) allEqs+  where+    allEqs = [annEq | m <- mods, annEq <- m.equations]+    go (seen, errs) annEq =+      case toQualId annEq.node.funName (length annEq.node.args) of+        Just qid+          | qid `Set.member` cNames,+            qid `Set.notMember` seen ->+              ( Set.insert qid seen,+                errs+                  ++ [ noDiag+                         ( P.AnnP+                             (ConstraintHasEquations annEq.node.funName)+                             annEq.sourceLoc+                             annEq.parsed+                         )+                     ]+              )+        _ -> (seen, errs)++-- | Check that no free-floating equation lives in a module that is not+-- the declaring module of the function. Equations contributed from+-- other modules must be wrapped in @:- extend_function ...@ directives.+-- Unknown function names are skipped here; they are reported by the+-- renamer as YCHR-20002.+checkOrphanEquations :: Set QualifiedName -> [CollectedModule] -> [Diagnostic ResolveError]+checkOrphanEquations functionNames mods =+  [ noDiag+      ( P.AnnP+          (OrphanFunctionEquation annEq.node.funName m.name)+          annEq.sourceLoc+          annEq.parsed+      )+  | m <- mods,+    annEq <- m.equations,+    Qualified targetMod baseName <- [annEq.node.funName],+    targetMod /= m.name,+    QualifiedName targetMod baseName `Set.member` functionNames+  ]++-- | Check that @:- extend_class_type@, @:- extend_function@, and+-- @:- extend_class@ directives only target open declarations.+-- Targets unknown to the compiler are already reported by the renamer.+checkExtendsClosed ::+  Map.Map QualifiedName Bool -> [CollectedModule] -> [Diagnostic ResolveError]+checkExtendsClosed funcOpenness mods =+  let declErrs =+        [ noDiag+            (P.AnnP (ExtendsClosedFunction target) loc (PExpr.Atom d.name))+        | m <- mods,+          P.Ann d loc <- m.extensionTypes,+          Just target <- [d.target],+          isKnownClosed funcOpenness target+        ]+      eqnErrs =+        [ noDiag+            ( P.AnnP+                (ExtendsClosedFunction annEq.node.funName)+                annEq.sourceLoc+                annEq.parsed+            )+        | m <- mods,+          annEq <- m.extensions ++ m.classExtensions,+          isKnownClosed funcOpenness annEq.node.funName+        ]+   in declErrs ++ eqnErrs+  where+    isKnownClosed openness (Qualified mn n) =+      case Map.lookup (QualifiedName mn n) openness of+        Just False -> True+        _ -> False+    isKnownClosed _ _ = False++-- | Reject @:- function@ / @:- open_function@ groups that carry more+-- than one typed signature for the same name and arity.+-- Multi-signature overloading requires @:- class@ / @:- open_class@.+-- Untyped declarations contribute no signature, so they are not+-- counted. One diagnostic is emitted per group, pointing at the+-- second offending declaration.+checkMultiSigOnFunction :: [CollectedModule] -> [Diagnostic ResolveError]+checkMultiSigOnFunction mods =+  [ noDiag (P.AnnP (MultiSigOnFunction (Qualified m.name d.name)) loc (PExpr.Atom d.name))+  | (_, decls) <- groupedFunctionDecls mods,+    let typedFunDecls =+          [ entry+          | entry@(d, _, _, _) <- decls,+            P.FunctionDecl+              { kind = DKFunction,+                argTypes = Just _,+                returnType = Just _+              } <-+              [d]+          ],+    (d, m, loc, _) : _ <- [drop 1 typedFunDecls]+  ]++-- | Reject groups where the same name+arity is declared with both+-- @:- function@-style and @:- class@-style keywords. One diagnostic+-- is emitted per group, pointing at the first declaration whose kind+-- differs from the group's first declaration.+checkMixedDeclKinds :: [CollectedModule] -> [Diagnostic ResolveError]+checkMixedDeclKinds mods =+  [ noDiag (P.AnnP (MixedDeclKinds (Qualified m.name d.name)) loc (PExpr.Atom d.name))+  | (_, decls@((P.FunctionDecl {kind = k0}, _, _, _) : _)) <- groupedFunctionDecls mods,+    let kinds = [k | (P.FunctionDecl {kind = k}, _, _, _) <- decls],+    any (/= k0) kinds,+    (d, m, loc, _) : _ <-+      [[entry | entry@(P.FunctionDecl {kind = k}, _, _, _) <- decls, k /= k0]]+  ]++-- | Reject same name+arity declared as both @:- chr_constraint@ and a+-- function-like form (@:- function@, @:- open_function@, @:- class@,+-- @:- open_class@) in a single module. Constraints and functions share+-- the symbol namespace, so the collision is ambiguous regardless of+-- whether the name is ever referenced. One diagnostic per+-- @(module, name, arity)@ collision, pointed at the first+-- function-side declaration (subsequent function-side declarations of+-- the same name are suppressed to avoid duplicate diagnostics when a+-- name is declared as e.g. both @:- function@ and @:- class@).+checkConstraintFunctionCollision :: [CollectedModule] -> [Diagnostic ResolveError]+checkConstraintFunctionCollision mods = snd $ foldl go (Set.empty, []) entries+  where+    entries =+      [ (m, d, loc)+      | m <- mods,+        let conKeys =+              Set.fromList+                [(c.name, c.arity) | P.Ann c _ <- m.decls, P.ConstraintDecl {} <- [c]],+        P.Ann d loc <- m.decls,+        P.FunctionDecl {} <- [d],+        Set.member (d.name, d.arity) conKeys+      ]+    go (seen, errs) (m, d, loc) =+      let key = (m.name, d.name, d.arity)+       in if Set.member key seen+            then (seen, errs)+            else+              ( Set.insert key seen,+                errs+                  ++ [ noDiag+                         ( P.AnnP+                             (ConstraintFunctionCollision (Qualified m.name d.name))+                             loc+                             (PExpr.Atom d.name)+                         )+                     ]+              )++-- | Reject extension directives whose declaration kind disagrees with+-- the target's kind:+--+--   * @:- extend_class_type@ on a @DKFunction@ target+--   * @:- extend_class@ on a @DKFunction@ target+--   * @:- extend_function@ on a @DKClass@ target+--+-- Targets unknown to the compiler are already reported by the renamer.+checkExtensionKinds ::+  Map.Map QualifiedName FunctionDeclKind ->+  [CollectedModule] ->+  [Diagnostic ResolveError]+checkExtensionKinds funcKinds mods =+  classTypeErrs ++ extendFunErrs ++ extendClassErrs+  where+    classTypeErrs =+      [ noDiag+          (P.AnnP (ExtendClassTypeOnFunction target) loc (PExpr.Atom d.name))+      | m <- mods,+        P.Ann d loc <- m.extensionTypes,+        Just target <- [d.target],+        targetKind target == Just DKFunction+      ]+    extendFunErrs =+      [ noDiag+          ( P.AnnP+              (ExtendFunctionOnClass annEq.node.funName)+              annEq.sourceLoc+              annEq.parsed+          )+      | m <- mods,+        annEq <- m.extensions,+        targetKind annEq.node.funName == Just DKClass+      ]+    extendClassErrs =+      [ noDiag+          ( P.AnnP+              (ExtendClassOnFunction annEq.node.funName)+              annEq.sourceLoc+              annEq.parsed+          )+      | m <- mods,+        annEq <- m.classExtensions,+        targetKind annEq.node.funName == Just DKFunction+      ]+    targetKind (Qualified mn n) = Map.lookup (QualifiedName mn n) funcKinds+    targetKind _ = Nothing++-- | Group every @FunctionDecl@ in the program by qualified name and+-- arity, returning the declarations along with their owning module,+-- source location, and a small origin atom for diagnostics. Used by+-- the kind / cardinality checks above. Per-group entries appear in+-- source order (left-to-right across modules, then top-to-bottom+-- within each module), so callers that want "the first/second+-- offending declaration" can rely on list position.+groupedFunctionDecls ::+  [CollectedModule] ->+  [((Text, Text, Int), [(P.Declaration, CollectedModule, P.SourceLoc, PExpr.PExpr)])]+groupedFunctionDecls mods =+  -- 'Map.fromListWith (++)' would build groups in *reverse* source+  -- order (right-associative accumulation). We want source order, so+  -- we accumulate a difference list (left-to-right append) and+  -- materialize each group at the end.+  [(k, vs []) | (k, vs) <- Map.toList grouped]+  where+    grouped =+      Map.fromListWith+        (\new old -> old . new)+        [ ((m.name, d.name, d.arity), ([(d, m, loc, PExpr.Atom d.name)] ++))+        | m <- mods,+          P.Ann d loc <- m.decls,+          P.FunctionDecl {} <- [d]+        ]++-- | Reject @:- extend_class_type@ directives that target a bounded+-- open function. The instance set of a bounded open function is+-- determined by its bound-named functions, not by enumerated extensions.+-- @:- extend_function@ / @:- extend_class@ (equation extension) are+-- /not/ rejected here — new equations of a bounded open function are+-- valid and are checked under the same ambient bound as the original+-- equations.+checkExtendsBounded ::+  Map.Map QualifiedName [BoundSig] -> [CollectedModule] -> [Diagnostic ResolveError]+checkExtendsBounded funcRequiring mods =+  [ noDiag+      (P.AnnP (ExtendTypeOnBoundedFunction target) loc (PExpr.Atom d.name))+  | m <- mods,+    P.Ann d loc <- m.extensionTypes,+    Just target <- [d.target],+    isBounded target+  ]+  where+    isBounded (Qualified mn n) =+      Map.member (QualifiedName mn n) funcRequiring+    isBounded _ = False++-- | Validate every @requiring@ clause in the program.+--+-- Reports three kinds of error:+--+--   * 'UnboundBoundVariable' — a type variable in the @requiring@+--     clause has no occurrence in the enclosing declaration's primary+--     signature.+--   * 'UnknownBoundFunction' — the bound's named function (with that+--     exact arity) is not declared anywhere in the program.+--   * 'BoundCycle' — the bound graph (with vertices for every function+--     and bounded constraint, and edges from each declaration to the+--     functions named in its @requiring@ clause) contains a cycle.+--+-- All three checks run together so the user sees every shape of bound+-- error in a single pass.+checkBoundedDeclarations ::+  Set QualifiedName -> [CollectedModule] -> [Diagnostic ResolveError]+checkBoundedDeclarations functionNames mods =+  let funcBounds =+        [ (QualifiedName m.name d.name, primaryVars, bs, originForDecl m d)+        | m <- mods,+          P.Ann d _ <- m.decls,+          P.FunctionDecl {requiring = Just bs, argTypes, returnType} <- [d],+          let primaryVars =+                Set.fromList $+                  concatMap typeExprVars (maybe [] id argTypes)+                    ++ maybe [] typeExprVars returnType+        ]+      conBounds =+        [ (QualifiedName m.name d.name, primaryVars, bs, originForDecl m d)+        | m <- mods,+          P.Ann d _ <- m.decls,+          P.ConstraintDecl {requiring = Just bs, argTypes} <- [d],+          let primaryVars =+                Set.fromList (concatMap typeExprVars (maybe [] id argTypes))+        ]+      allBounded = funcBounds ++ conBounds+      varErrs =+        [ noDiag (P.AnnP (UnboundBoundVariable declText v) bs.loc origin)+        | (qn, primary, bsigs, origin) <- allBounded,+          let declText = qualifiedToLooseText qn,+          bs <- bsigs,+          let bsVars =+                Set.fromList+                  (concatMap typeExprVars bs.argTypes ++ typeExprVars bs.returnType),+          v <- Set.toList bsVars,+          Set.notMember v primary+        ]+      unknownErrs =+        [ noDiag+            ( P.AnnP+                (UnknownBoundFunction declText (flattenName bs.name) bs.arity)+                bs.loc+                origin+            )+        | (qn, _, bsigs, origin) <- allBounded,+          let declText = qualifiedToLooseText qn,+          bs <- bsigs,+          not (boundResolvesToFunction bs)+        ]+      cycleErrs = detectBoundCycles allBounded+   in varErrs ++ unknownErrs ++ cycleErrs+  where+    qualifiedToLooseText qn = flattenName (qualifiedNameToLooseName qn)+    boundResolvesToFunction bs = case bs.name of+      Qualified m n -> Set.member (QualifiedName m n) functionNames+      Unqualified _ ->+        -- If the renamer left the name 'Unqualified', no visible+        -- provider exposes a function (or anything else) at this+        -- name/arity — emit the dedicated 'UnknownBoundFunction'+        -- diagnostic ourselves. (The renamer used to pre-report+        -- this as the generic YCHR-20002; it now defers to us.)+        False+    originForDecl m d = PExpr.Atom (m.name <> ":" <> d.name)++{- Note [Bound graph cycle detection]++Vertices of the bound graph are the qualified names of bounded+declarations (functions and constraints carrying a @requiring@+clause). There is an edge from @f@ to @g@ whenever @g@ appears in+@f@'s @requiring@ clause; bounded references always resolve to a+function per the spec.++Edges are derived from the @allBounded@ list assembled in+'checkBoundedDeclarations', which itself draws from+'buildFunctionRequiring' (function bounds) and the constraint-side+@requiring@ field collected by 'collectConstraintBounds'.++Detection is iterative DFS rather than recursive: bound chains may be+arbitrarily deep, so we keep the work stack on the heap. A vertex is+added to @visited@ only after its entire subtree has been explored,+so each simple cycle is reported exactly once even when several+starting vertices reach it.++'BoundCycle' carries the cycle in source order: 'dfs' builds the+cycle by reversing the current DFS path from the re-entered vertex+back to itself, which is the same order in which the bounds were+encountered while walking @requiring@ clauses top-to-bottom.+-}++-- | Detect cycles in the bound graph by depth-first search.+-- See Note [Bound graph cycle detection].+detectBoundCycles ::+  [(QualifiedName, Set Text, [BoundSig], PExpr.PExpr)] ->+  [Diagnostic ResolveError]+detectBoundCycles bounded =+  let graph :: Map.Map QualifiedName [QualifiedName]+      graph =+        Map.fromList+          [ ( qn,+              [ QualifiedName m n+              | b <- bs,+                Qualified m n <- [b.name]+              ]+            )+          | (qn, _, bs, _) <- bounded+          ]+      origins :: Map.Map QualifiedName PExpr.PExpr+      origins = Map.fromList [(qn, origin) | (qn, _, _, origin) <- bounded]+      (_, cycles) = foldl visit (Set.empty, []) (Map.keys graph)+      visit (visited, acc) qn = dfs graph visited [] acc qn+   in map (emitCycleDiag origins) cycles++-- | Iterative DFS from @qn@ that pushes any detected cycle onto the+-- accumulator and returns the updated @(visited, cycles)@ pair.+-- See Note [Bound graph cycle detection].+dfs ::+  Map.Map QualifiedName [QualifiedName] ->+  Set QualifiedName ->+  [QualifiedName] ->+  [[QualifiedName]] ->+  QualifiedName ->+  (Set QualifiedName, [[QualifiedName]])+dfs graph visited path acc qn+  | qn `elem` path =+      let cycle_ = qn : reverse (takeWhile (/= qn) path) ++ [qn]+       in (visited, cycle_ : acc)+  | qn `Set.member` visited = (visited, acc)+  | otherwise =+      let neighbors = Map.findWithDefault [] qn graph+          (visited', acc') =+            foldl+              (\(v, a) target -> dfs graph v (qn : path) a target)+              (visited, acc)+              neighbors+       in (Set.insert qn visited', acc')++emitCycleDiag ::+  Map.Map QualifiedName PExpr.PExpr ->+  [QualifiedName] ->+  Diagnostic ResolveError+emitCycleDiag origins cycle_ =+  let names = map (flattenName . qualifiedNameToLooseName) cycle_+      origin = case cycle_ of+        (q : _) -> Map.findWithDefault (PExpr.Atom "<bound_cycle>") q origins+        [] -> PExpr.Atom "<bound_cycle>"+      loc' = P.SourceLoc "<bound_cycle>" 0 0+   in noDiag (P.AnnP (BoundCycle names) loc' origin)++-- | Collect every type variable mentioned in a type expression.+typeExprVars :: TypeExpr -> [Text]+typeExprVars (TypeVar v) = [v]+typeExprVars (TypeCon _ args) = concatMap typeExprVars args++-- | Check that no rule head constraint is a function-declared name.+-- Reports only the first rule per name.+checkRuleHeads :: Set Name -> [CollectedModule] -> [Diagnostic ResolveError]+checkRuleHeads fNames mods = snd $ foldl go (Set.empty, []) allRules+  where+    allRules = [(r, m) | m <- mods, r <- m.rules]+    go (seen, errs) (r, _m) =+      let cs = headConstraints r.head.node+          new =+            [ ( c.name,+                noDiag (P.AnnP (FunctionInRuleHead c.name) r.head.sourceLoc r.head.parsed)+              )+            | c <- cs,+              c.name `Set.member` fNames,+              c.name `Set.notMember` seen+            ]+       in (foldl (\s (n, _) -> Set.insert n s) seen new, errs ++ map snd new)++-- | Reserved names that cannot be used as constraint or function declarations.+reservedDeclNames :: Set Text+reservedDeclNames = Set.fromList ["quote"]++-- | Check that no declaration uses a reserved name.+checkReservedNames :: [CollectedModule] -> [Diagnostic ResolveError]+checkReservedNames mods =+  [ noDiag (P.AnnP (ReservedName (Qualified m.name d.name)) loc (PExpr.Atom ""))+  | m <- mods,+    P.Ann d loc <- m.decls,+    isDeclNamed d,+    d.name `Set.member` reservedDeclNames+  ]+  where+    isDeclNamed P.ConstraintDecl {} = True+    isDeclNamed P.FunctionDecl {} = True+    isDeclNamed _ = False++-- | Reserved names that cannot be used as user module names. Currently+-- just @host@, which is wired in as the host-call qualifier in+-- @Resolve.termToExpr@; allowing it as a user module name would shadow+-- the user's own functions at their definition site.+reservedModuleNames :: Set Text+reservedModuleNames = Set.fromList ["host"]++-- | Check that no module uses a reserved name.+checkReservedModuleNames :: [CollectedModule] -> [Diagnostic ResolveError]+checkReservedModuleNames mods =+  [ noDiag (P.AnnP (ReservedModuleName m.name) m.nameLoc (PExpr.Atom ""))+  | m <- mods,+    m.name `Set.member` reservedModuleNames+  ]++headConstraints :: P.Head -> [P.Constraint]+headConstraints (P.Simplification cs) = cs+headConstraints (P.Propagation cs) = cs+headConstraints (P.Simpagation ks rs) = ks ++ rs++toQualId :: Name -> Int -> Maybe QualifiedIdentifier+toQualId (Qualified m n) a = Just (QualifiedIdentifier m n a)+toQualId (Unqualified _) _ = Nothing++-- ---------------------------------------------------------------------------+-- Module flattening+-- ---------------------------------------------------------------------------++resolveRules ::+  Map Text FunVisibility ->+  [CollectedModule] ->+  ([R.Rule], [Diagnostic ResolveError])+resolveRules visMap mods =+  let raws = [(r, m) | m <- mods, r <- m.rules]+      go (acc, errs) (r, m) =+        let vis = funVisibilityFor visMap m.name+         in case resolveHead r.head.sourceLoc r.head.parsed r.head.node of+              Right rh ->+                let (guardExprs, guardErrs) =+                      runWriter+                        ( traverse+                            (termToExpr vis r.guard.sourceLoc r.guard.parsed)+                            r.guard.node+                        )+                    (bodyExprs, bodyErrs) =+                      runWriter+                        ( traverse+                            (termToExpr vis r.body.sourceLoc r.body.parsed)+                            r.body.node+                        )+                    rule =+                      R.Rule+                        { name = r.name,+                          head = P.AnnP rh r.head.sourceLoc r.head.parsed,+                          guard = P.AnnP guardExprs r.guard.sourceLoc r.guard.parsed,+                          body = P.AnnP bodyExprs r.body.sourceLoc r.body.parsed+                        }+                 in (acc ++ [rule], errs ++ guardErrs ++ bodyErrs)+              Left newErrs -> (acc, errs ++ newErrs)+   in foldl go ([], []) raws++resolveHead ::+  P.SourceLoc ->+  PExpr.PExpr ->+  P.Head ->+  Either [Diagnostic ResolveError] R.Head+resolveHead loc origin h = case h of+  P.Simplification cs -> R.Simplification <$> traverse (qualifyConstraint loc origin) cs+  P.Propagation cs -> R.Propagation <$> traverse (qualifyConstraint loc origin) cs+  P.Simpagation ks rs ->+    R.Simpagation+      <$> traverse (qualifyConstraint loc origin) ks+      <*> traverse (qualifyConstraint loc origin) rs++qualifyConstraint ::+  P.SourceLoc ->+  PExpr.PExpr ->+  Constraint ->+  Either [Diagnostic ResolveError] QualifiedConstraint+qualifyConstraint loc origin (Constraint n args) = case n of+  Qualified m b -> Right (QualifiedConstraint (QualifiedName m b) args)+  Unqualified _ ->+    Left [noDiag (P.AnnP (UnqualifiedConstraintName n) loc origin)]++resolveFunctions ::+  Map Text FunVisibility ->+  [CollectedModule] ->+  ([R.FunctionDef], [Diagnostic ResolveError])+resolveFunctions visMap mods =+  let -- Collect all function declarations with their module context+      allDecls =+        [ (QualifiedName m.name d.name, d.arity, d, m)+        | m <- mods,+          P.Ann d _ <- m.decls,+          P.FunctionDecl {} <- [d]+        ]+      -- Group by (qualifiedName, arity)+      grouped =+        Map.toList $+          Map.fromListWith+            (++)+            [ ((qn, ar), [(d, m)])+            | (qn, ar, d, m) <- allDecls+            ]+      build ((qn, ar), decls) =+        let (eqss, declErrss) =+              unzip+                [ gatherEquations visMap mods m d+                | (d, m) <- decls+                ]+            def =+              R.FunctionDef+                { name = qn,+                  arity = ar,+                  signatures =+                    collectSignatures decls+                      ++ collectExtensionSignatures mods qn ar,+                  isOpen = any (\(d, _) -> d.isOpen) decls,+                  requiring = concatMap (\(d, _) -> maybe [] id d.requiring) decls,+                  equations = concat eqss+                }+         in (def, concat declErrss)+      (defs, defErrss) = unzip (map build grouped)+   in (defs, concat defErrss)++-- | Collect type signatures from a group of declarations for the same function.+collectSignatures :: [(P.Declaration, CollectedModule)] -> [([TypeExpr], TypeExpr)]+collectSignatures decls =+  [ (argTys, retTy)+  | (d, _) <- decls,+    Just argTys <- [d.argTypes],+    Just retTy <- [d.returnType]+  ]++-- | Collect signatures contributed by @:- extend_class_type@+-- directives in any module. Only signatures whose resolved target+-- matches the given qualified name and arity are included.+collectExtensionSignatures ::+  [CollectedModule] -> QualifiedName -> Int -> [([TypeExpr], TypeExpr)]+collectExtensionSignatures mods qn ar =+  [ (argTys, retTy)+  | m <- mods,+    P.Ann d _ <- m.extensionTypes,+    d.arity == ar,+    Just (Qualified tm tn) <- [d.target],+    QualifiedName tm tn == qn,+    Just argTys <- [d.argTypes],+    Just retTy <- [d.returnType]+  ]++-- | Gather equations for a function declaration, stripping the funName.+-- Free-floating equations only come from the declaring module+-- (orphans are rejected by 'checkOrphanEquations'). Extension equations+-- contributed via @:- extend_function@ or @:- extend_class@ are pulled+-- from every module's @extensions@ and @classExtensions@ lists; the+-- @checkExtensionKinds@ pass rejects mismatches between the directive+-- and the target's kind, so by the time we get here either list is a+-- legitimate source for this declaration.+gatherEquations ::+  Map Text FunVisibility ->+  [CollectedModule] ->+  CollectedModule ->+  P.Declaration ->+  ([P.AnnP R.FunctionEquation], [Diagnostic ResolveError])+gatherEquations visMap mods m d =+  let qualName = Qualified m.name d.name+      primaryEqs =+        [ (annEq, m)+        | annEq <- m.equations,+          annEq.node.funName == qualName,+          length annEq.node.args == d.arity+        ]+      extensionEqs =+        [ (annEq, mod_)+        | mod_ <- mods,+          annEq <- mod_.extensions ++ mod_.classExtensions,+          annEq.node.funName == qualName,+          length annEq.node.args == d.arity+        ]+      strip (annEq, srcMod) =+        stripFunName (funVisibilityFor visMap srcMod.name) annEq+      (eqs, eqErrss) = unzip (map strip (primaryEqs ++ extensionEqs))+   in (eqs, concat eqErrss)++stripFunName ::+  FunVisibility ->+  P.AnnP P.FunctionEquation ->+  (P.AnnP R.FunctionEquation, [Diagnostic ResolveError])+stripFunName vis (P.AnnP eq loc parsed) =+  let (guardExprs, guardErrs) =+        runWriter+          ( traverse+              (termToExpr vis eq.guard.sourceLoc eq.guard.parsed)+              eq.guard.node+          )+      (rhsExprs, rhsErrs) =+        runWriter+          ( traverse+              (termToExpr vis eq.rhs.sourceLoc eq.rhs.parsed)+              eq.rhs.node+          )+      resolvedEq =+        R.FunctionEquation+          { args = eq.args,+            guard = P.AnnP guardExprs eq.guard.sourceLoc eq.guard.parsed,+            rhs = P.AnnP rhsExprs eq.rhs.sourceLoc eq.rhs.parsed+          }+   in (P.AnnP resolvedEq loc parsed, guardErrs ++ rhsErrs)++-- | Flatten the top-level comma operator of a 'Term' into a non-empty+-- sequence. Used to give lambda bodies the same sequenced form as+-- top-level function equations.+flattenTermComma :: Term -> NonEmpty Term+flattenTermComma t = case t of+  CompoundTerm (Unqualified ",") [l, r] ->+    flattenTermComma l <> flattenTermComma r+  _ -> t :| []++-- ---------------------------------------------------------------------------+-- Term -> Expr translation+-- ---------------------------------------------------------------------------++-- | Translate a renamed surface 'Term' into the structurally typed+-- 'R.Expr'. The 'FunVisibility' tells us which qualified compounds+-- are static calls — every other qualified compound is a data+-- constructor. '$call', 'fun name/arity', lambdas, 'host:f' calls,+-- and the @quote/1@ quoting form are recognized by their canonical+-- post-rename shape.+--+-- See Note [FunVisibility vs renamer visibility] for why this pass+-- recomputes function visibility instead of relying on the renamer.+--+-- Diagnostics accumulate in the writer; the translator always returns+-- an 'R.Expr', substituting plausible placeholders so traversal can+-- continue. The enclosing call sites use the accumulated diagnostics+-- (combined with the rest of 'resolveProgram''s checks) to decide+-- whether to fail.+termToExpr ::+  FunVisibility ->+  P.SourceLoc ->+  PExpr.PExpr ->+  Term ->+  Writer [Diagnostic ResolveError] R.Expr+termToExpr vis loc origin = go+  where+    go t = case t of+      VarTerm v -> pure (R.VarExpr v)+      IntTerm n -> pure (R.IntExpr n)+      FloatTerm n -> pure (R.FloatExpr n)+      TextTerm s -> pure (R.TextExpr s)+      Wildcard -> pure R.WildcardExpr+      -- '$call'(F, A1..An) — surface dynamic dispatch. The callee is+      -- the first argument; the rest are the call's actual arguments.+      CompoundTerm (Unqualified "$call") (f : args)+        | not (null args) -> R.ApplyExpr <$> go f <*> traverse go args+      -- 'fun name/arity' — canonicalized by the renamer to a single+      -- 0-arity compound holding the flat 'module:name'.+      CompoundTerm+        (Unqualified "/")+        [CompoundTerm (Unqualified flatName) [], IntTerm arity] ->+          pure (R.FunRefExpr (parseFlatName flatName) (fromInteger arity))+      -- Lambda 'fun(P1..Pn) -> body'. Params are patterns; invalid+      -- params get reported here and replaced with 'HeadWildcard' so+      -- traversal can keep going. An empty parameter list is rejected+      -- here ('EmptyLambdaParams', YCHR-16018); we substitute a single+      -- wildcard so the resulting 'R.LambdaExpr' satisfies the+      -- 'NonEmpty' invariant and downstream stages can continue.+      CompoundTerm+        (Unqualified "->")+        [CompoundTerm (Unqualified "fun") params, body] -> do+          body' <- traverse go (flattenTermComma body)+          case params of+            [] -> do+              tell [noDiag (P.AnnP EmptyLambdaParams loc origin)]+              pure (R.LambdaExpr (HeadWildcard :| []) body')+            p : ps -> do+              hargs <- traverse classifyParam (p :| ps)+              pure (R.LambdaExpr hargs body')+      -- 'quote(arg)' — quoting suppresses evaluation of the subtree;+      -- every compound inside is a data constructor.+      CompoundTerm (Unqualified "quote") [arg] ->+        pure (R.CtorExpr (Unqualified "quote") [quotedToExpr arg])+      -- 'host:f(args)' — host language call.+      CompoundTerm (Qualified "host" f) args ->+        R.HostExpr f <$> traverse go args+      -- Qualified compound: call if declared as a function visible to+      -- this module, else a data constructor application. Qualified+      -- references that survived the renamer are already+      -- visibility-validated, so the @elem@ check here is effectively+      -- a function-vs-constructor distinction.+      CompoundTerm name@(Qualified m b) args+        | QualifiedName m b `elem` Map.findWithDefault [] (b, length args) vis ->+            R.CallExpr (QualifiedName m b) <$> traverse go args+        | otherwise ->+            R.CtorExpr name <$> traverse go args+      -- Unqualified compound. If exactly one declared function with+      -- this local name is visible to the current module, canonicalize+      -- to a 'CallExpr'; this is how nested function-call arguments+      -- of tell-side body constraints (and top-level goals) get+      -- evaluated, since the renamer's 'NoResolve' mode leaves+      -- body-compound children unqualified. Zero matches (the name+      -- is genuinely a data constructor or undefined) and ambiguous+      -- matches both fall through to 'CtorExpr'; the renamer is+      -- responsible for the corresponding diagnostics+      -- (@UnknownName@/@AmbiguousName@ in @ResolveAll@ positions,+      -- @UndeclaredDataConstructor@ in @NoResolve@).+      CompoundTerm name@(Unqualified n) args ->+        case Map.lookup (n, length args) vis of+          Just [qn] -> R.CallExpr qn <$> traverse go args+          _ -> R.CtorExpr name <$> traverse go args++    classifyParam :: Term -> Writer [Diagnostic ResolveError] HeadArg+    classifyParam (VarTerm v) = pure (HeadVar v)+    classifyParam Wildcard = pure HeadWildcard+    classifyParam bad = do+      tell [noDiag (P.AnnP (LambdaParamError bad) loc origin)]+      pure HeadWildcard++-- | Translate a 'Term' that lives inside a @quote/1@ quotation. No+-- function-set lookup happens here: quoting suppresses evaluation, so+-- every compound is a data constructor.+quotedToExpr :: Term -> R.Expr+quotedToExpr (VarTerm v) = R.VarExpr v+quotedToExpr (IntTerm n) = R.IntExpr n+quotedToExpr (FloatTerm n) = R.FloatExpr n+quotedToExpr (TextTerm s) = R.TextExpr s+quotedToExpr Wildcard = R.WildcardExpr+quotedToExpr (CompoundTerm name args) =+  R.CtorExpr name (map quotedToExpr args)++-- | Recover a 'QualifiedName' from a flat @"module:name"@ atom emitted+-- by the renamer (see 'YCHR.Internal.Rename.renameTerm' for @fun name/arity@).+-- The renamer always emits a colon-separated form, so the missing-+-- separator case is an internal invariant violation rather than a+-- user-facing error.+parseFlatName :: Text -> QualifiedName+parseFlatName t = case T.breakOn ":" t of+  (m, rest) | not (T.null rest) -> QualifiedName m (T.drop 1 rest)+  _ ->+    error+      ( "YCHR.Internal.Resolve.parseFlatName: missing ':' separator in "+          <> T.unpack t+          <> " — renamer post-condition violated"+      )
+ src/YCHR/Internal/Resolved.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Resolved AST+--+-- This module defines the AST produced by the resolve phase, which sits+-- between renaming and desugaring. It is the result of flattening all+-- modules into a single program and grouping function equations under+-- their declarations.+--+-- Key properties that hold by construction:+--+--   * Function equations live inside their 'FunctionDef', so there is+--     no way for a constraint-declared name to have equations.+--+--   * Rule heads are verified during resolution: no function-declared+--     name can appear in a rule head.+--+--   * Constraint head names and function names are 'QualifiedName',+--     so the qualification invariant established by the renamer is+--     reflected in the type system.+module YCHR.Internal.Resolved+  ( -- * Types+    Program (..),+    Rule (..),+    Head (..),+    FunctionDef (..),+    FunctionEquation (..),+    Expr (..),++    -- * Operations+    exprToTerm,+  )+where++import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Set (Set)+import Data.Text (Text)+import YCHR.Internal.Loc (Ann)+import YCHR.Internal.Parsed (AnnP)+import YCHR.Internal.Types+  ( BoundSig,+    HeadArg,+    Name (..),+    QualifiedConstraint,+    QualifiedName,+    Term (..),+    TypeDefinition,+    TypeExpr,+    flattenName,+    headArgToTerm,+    qualifiedToName,+  )++-- | A resolved program: all modules flattened, equations grouped under+-- their function declarations.+data Program = Program+  { rules :: [Rule],+    functions :: [FunctionDef],+    constraintTypes :: Map QualifiedName [TypeExpr],+    -- | Bounds declared on each @:- chr_constraint@ that carries a+    -- @requiring@ clause. Constraints without bounds do not appear in+    -- this map (rather than mapping to @[]@) so a single membership+    -- check distinguishes "bounded constraint" from "unbounded".+    constraintBounds :: Map QualifiedName [BoundSig],+    functionNames :: Set QualifiedName,+    typeDefinitions :: [TypeDefinition]+  }+  deriving (Show)++-- | A rule in the resolved AST. Structurally identical to the parsed+-- rule; the three head kinds are preserved for desugaring to flatten.+--+-- Guards and bodies are 'Expr' (not 'Term'): the resolver has already+-- decided, for every compound, whether it is a function call, a data+-- constructor application, a dynamic dispatch, a function reference,+-- or a lambda. Downstream passes dispatch structurally and never need+-- to re-check the function-name set.+data Rule = Rule+  { name :: Maybe (Ann Text),+    head :: AnnP Head,+    guard :: AnnP [Expr],+    body :: AnnP [Expr]+  }+  deriving (Show)++-- | Resolved rule head. Mirrors 'YCHR.Internal.Parsed.Head' but with+-- 'QualifiedConstraint' so the constraint-name qualification invariant+-- is reflected in the type. Desugaring flattens the three kinds into+-- the uniform @kept \/ removed@ shape of 'YCHR.Internal.Desugared.Head'.+data Head+  = Simplification [QualifiedConstraint]+  | Propagation [QualifiedConstraint]+  | Simpagation [QualifiedConstraint] [QualifiedConstraint]+  deriving (Show, Eq)++-- | A function definition with its equations grouped together.+data FunctionDef = FunctionDef+  { name :: QualifiedName,+    arity :: Int,+    signatures :: [([TypeExpr], TypeExpr)],+    isOpen :: Bool,+    -- | Bounds declared on this function via @requiring@. Empty when+    -- the function is unbounded.+    requiring :: [BoundSig],+    equations :: [AnnP FunctionEquation]+  }+  deriving (Show)++-- | A function equation. Unlike 'YCHR.Internal.Parsed.FunctionEquation', there+-- is no @funName@ field — the name comes from the enclosing 'FunctionDef'.+--+-- 'args' stays as @[Term]@ because equation arguments are patterns:+-- they are normalized to 'HeadArg's by HNF in the desugarer, and the+-- call-vs-constructor question does not arise for them. 'guard' and+-- 'rhs' carry expression-position 'Expr's.+data FunctionEquation = FunctionEquation+  { args :: [Term],+    guard :: AnnP [Expr],+    rhs :: AnnP (NonEmpty Expr)+  }+  deriving (Show)++-- | An expression in a body, guard, or function RHS. Each constructor+-- corresponds to a single dynamic behavior at runtime, eliminating the+-- ambiguity of the uniform 'Term' shape:+--+--   * 'CallExpr' is a statically-known call to a user-declared+--     function.+--   * 'CtorExpr' is a data constructor application — compiled to a+--     @MakeTerm@ in the VM.+--   * 'ApplyExpr' is dynamic dispatch (the surface @'$call'(F, A1..An)@).+--   * 'FunRefExpr' is a first-class function reference+--     (the surface @fun name/arity@).+--   * 'LambdaExpr' is an anonymous function value. It exists between+--     resolution and the desugarer's lambda-lifting pass, after which+--     it is rewritten to a @__closure@-headed 'CtorExpr'. The+--     parameter list is 'NonEmpty': the resolver rejects+--     @fun() -> Body end@ with 'EmptyLambdaParams' (YCHR-16018) and+--     downstream stages can rely on at least one parameter.+--   * 'HostExpr' is a call into the host language+--     (the surface @host:f(args)@).+data Expr+  = VarExpr Text+  | IntExpr Integer+  | FloatExpr Double+  | TextExpr Text+  | WildcardExpr+  | CtorExpr Name [Expr]+  | CallExpr QualifiedName [Expr]+  | ApplyExpr Expr [Expr]+  | FunRefExpr QualifiedName Int+  | LambdaExpr (NonEmpty HeadArg) (NonEmpty Expr)+  | HostExpr Text [Expr]+  deriving (Show, Eq)++-- | Convert an 'Expr' back to a surface-shaped 'Term'. Used as a+-- narrow bridge for code that still operates on 'Term' (notably the+-- @args@ field of 'YCHR.Internal.Types.QualifiedConstraint', which body-+-- constraint goals carry verbatim).+--+-- The conversion flattens every node to its surface compound shape:+-- 'CallExpr' becomes a 'CompoundTerm' with the function's qualified+-- 'Name' as the head, 'ApplyExpr' becomes a @'$call'@ compound,+-- 'LambdaExpr' becomes its surface @fun(...) -> body@ shape, and so+-- on. The result discards the call/host/apply distinctions — those+-- live only in the 'Expr' tree. This is intentional: every consumer+-- of the resulting 'Term' (e.g. 'YCHR.Internal.Compile.compileTerm',+-- 'YCHR.Run.termToValue') treats every compound as data, which+-- matches CHR's value semantics for constraint arguments and quoted+-- @quote\/1@ subtrees.+exprToTerm :: Expr -> Term+exprToTerm (VarExpr v) = VarTerm v+exprToTerm (IntExpr n) = IntTerm n+exprToTerm (FloatExpr n) = FloatTerm n+exprToTerm (TextExpr s) = TextTerm s+exprToTerm WildcardExpr = Wildcard+exprToTerm (CtorExpr name args) = CompoundTerm name (map exprToTerm args)+exprToTerm (CallExpr qn args) =+  CompoundTerm (qualifiedToName qn) (map exprToTerm args)+exprToTerm (ApplyExpr f args) =+  CompoundTerm (Unqualified "$call") (exprToTerm f : map exprToTerm args)+exprToTerm (HostExpr f args) =+  CompoundTerm (Qualified "host" f) (map exprToTerm args)+exprToTerm (FunRefExpr qn arity) =+  CompoundTerm+    (Unqualified "/")+    [ CompoundTerm (Unqualified (flattenName (qualifiedToName qn))) [],+      IntTerm (fromIntegral arity)+    ]+exprToTerm (LambdaExpr params body) =+  CompoundTerm+    (Unqualified "->")+    [ CompoundTerm (Unqualified "fun") (map headArgToTerm (NE.toList params)),+      sequenceToTerm body+    ]++-- | Re-build a comma-sequence 'Term' from a non-empty list of 'Expr's.+-- Inverse of the comma flattening done at the equation- and lambda-body+-- boundaries.+sequenceToTerm :: NonEmpty Expr -> Term+sequenceToTerm = go . NE.toList+  where+    go [e] = exprToTerm e+    go (e : es) = CompoundTerm (Unqualified ",") [exprToTerm e, go es]+    go [] = CompoundTerm (Unqualified "true") [] -- unreachable: NonEmpty
+ src/YCHR/Internal/Runtime/Error.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Helpers that raise runtime errors from any 'Chr' action+-- ('runtimeError'', 'runtimeErrorS'), the 'CallStack' alias they read+-- through, and the 'RuntimeErrorThrown' exception they throw. Living+-- here keeps "YCHR.Internal.Runtime.Registry" and "YCHR.Internal.Runtime.Session" free of+-- import cycles with "YCHR.Internal.Runtime.Interpreter".+--+-- Rendering lives in "YCHR.Internal.Display": the top-level driver catches+-- 'RuntimeErrorThrown', lifts it into 'YCHR.Run.RuntimeError', and+-- displays it via the same 'displayMsgWithSrcLoc' machinery used by+-- every other diagnostic.+module YCHR.Internal.Runtime.Error+  ( -- * Call stack+    CallStack,++    -- * Raising runtime errors+    RuntimeErrorThrown (..),+    runtimeError',+    runtimeErrorS,+  )+where++import Control.Exception (Exception, throwIO)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask)+import Data.IORef (readIORef)+import Data.Text qualified as T+import YCHR.Internal.Runtime.Monad (CallStack, Chr, SessionEnv (..))+import YCHR.Internal.VM (StackFrame)++-- | Exception thrown by 'runtimeError'' and 'runtimeErrorS'. Carries+-- the message and the call stack captured at the throw site (newest+-- frame first). The top-level driver catches this and lifts it into+-- 'YCHR.Run.RuntimeError' for rendering.+data RuntimeErrorThrown = RuntimeErrorThrown String [StackFrame]+  deriving (Show)++instance Exception RuntimeErrorThrown++-- | Raise a runtime error with the current call stack.+runtimeError' :: String -> T.Text -> Chr a+runtimeError' prefix detail = do+  SessionEnv {callStack} <- ask+  stack <- liftIO $ readIORef callStack+  liftIO $ throwIO (RuntimeErrorThrown (prefix ++ T.unpack detail) stack)++-- | Raise a runtime error with the current call stack (String-only variant).+runtimeErrorS :: String -> Chr a+runtimeErrorS msg = do+  SessionEnv {callStack} <- ask+  stack <- liftIO $ readIORef callStack+  liftIO $ throwIO (RuntimeErrorThrown msg stack)
+ src/YCHR/Internal/Runtime/History.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedRecordDot #-}++-- | Propagation history for the CHR Haskell runtime.+--+-- Tracks which rule has fired with which combination of constraint+-- identifiers, to prevent redundant re-firing of propagation rules.+module YCHR.Internal.Runtime.History+  ( addHistory,+    notInHistory,+  )+where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask)+import Data.IORef+import Data.Set qualified as Set+import YCHR.Internal.Runtime.Monad (Chr, SessionEnv (..))+import YCHR.Internal.Runtime.Types (SuspensionId)+import YCHR.Internal.VM (RuleId)++-- | Record that a rule has fired with the given constraint identifiers.+addHistory :: RuleId -> [SuspensionId] -> Chr ()+addHistory ruleId ids = do+  SessionEnv {history} <- ask+  liftIO $ modifyIORef' history (Set.insert (ruleId, ids))++-- | Check that a rule has /not/ fired with the given constraint identifiers.+-- Returns 'True' if the entry is absent (i.e. the rule may fire).+notInHistory :: RuleId -> [SuspensionId] -> Chr Bool+notInHistory ruleId ids = do+  SessionEnv {history} <- ask+  liftIO $ Set.notMember (ruleId, ids) <$> readIORef history
+ src/YCHR/Internal/Runtime/Interpreter.hs view
@@ -0,0 +1,879 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Haskell interpreter for CHR VM programs.+--+-- Executes VM programs directly using the 'Chr' runtime monad. The+-- 'Chr' monad reads a 'SessionEnv' that bundles the constraint store,+-- propagation history, reactivation queue, unification-variable+-- counter, interpreter call stack, the procedure map and the host-call+-- registry. Per-procedure-call local variables ('Env') live in a+-- mutable 'IORef' read through a thin 'ReaderT' layer so exception-driven+-- non-local jumps preserve state across catches.+--+-- Non-local control flow ('Return', labelled 'Continue', 'Break') is+-- implemented with real 'Control.Exception' exceptions thrown in 'IO':+-- 'try' delimits each procedure invocation and each 'Foreach' body.+module YCHR.Internal.Runtime.Interpreter+  ( -- * Public API+    interpret,+    HostCallFn (..),+    HostCallRegistry,+    baseHostCallRegistry,++    -- * Deep-eval walker (shared with the query-time evaluator)+    deepEvalValue,++    -- * Tracing helpers (shared with the query-time driver)+    emitTrace,+    snapshotValue,+    snapshotValues,+    suspensionView,+    constraintTypeLabel,+    lookupRuleName,++    -- * Internal (for testing)+    callProc,+    bindParams,+    unit,+  )+where++import Control.Exception+  ( Exception,+    SomeAsyncException,+    SomeException,+    bracket,+    displayException,+    fromException,+    throwIO,+    try,+  )+import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import Data.Foldable (toList, traverse_)+import Data.IORef+  ( IORef,+    atomicModifyIORef',+    modifyIORef',+    newIORef,+    readIORef,+    writeIORef,+  )+import Data.IntMap.Strict qualified as IntMap+import Data.List qualified as List+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Sequence qualified as Seq+import Data.Text (Text)+import Data.Text qualified as T+import YCHR.Internal.Meta (valueToTerm)+import YCHR.Internal.Pretty (prettyTerm)+import YCHR.Internal.Runtime.Error (RuntimeErrorThrown, runtimeError', runtimeErrorS)+import YCHR.Internal.Runtime.History (addHistory, notInHistory)+import YCHR.Internal.Runtime.Monad+  ( Chr,+    HostCallFn (..),+    HostCallRegistry,+    SessionEnv (..),+    initSessionEnv,+    runChr,+  )+import YCHR.Internal.Runtime.Reactivation (drainQueue, enqueue)+import YCHR.Internal.Runtime.Registry+  ( baseHostCallRegistry,+    unit,+  )+import YCHR.Internal.Runtime.Store+  ( Suspension (..),+    aliveConstraint,+    createConstraint,+    getConstraintArg,+    getConstraintType,+    getStoreSnapshot,+    idEqual,+    isConstraintType,+    isSuspAlive,+    killConstraint,+    lookupSusp,+    storeConstraint,+    suspArg,+  )+import YCHR.Internal.Runtime.Trace (TraceEvent (..))+import YCHR.Internal.Runtime.Types (CallVal (..), SuspensionId, Value (..))+import YCHR.Internal.Runtime.Var+  ( deref,+    equal,+    getArg,+    makeTerm,+    matchTerm,+    newVar,+    unify,+  )+import YCHR.Internal.Types (Term)+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM++-- ---------------------------------------------------------------------------+-- Types+-- ---------------------------------------------------------------------------++-- | Local variable environment for a procedure call. Split by kind:+-- value-bound names live in 'envValues', id-bound names in 'envIds'.+-- The IR ensures each name appears in only one map.+data Env = Env+  { envValues :: !(Map Name Value),+    envIds :: !(Map Name SuspensionId)+  }++emptyEnv :: Env+emptyEnv = Env Map.empty Map.empty++insertVal :: Name -> Value -> Env -> Env+insertVal n v e = e {envValues = Map.insert n v e.envValues}++insertId :: Name -> SuspensionId -> Env -> Env+insertId n s e = e {envIds = Map.insert n s e.envIds}++-- | Maximum number of call stack frames to keep.+maxCallStackDepth :: Int+maxCallStackDepth = 10++-- | Non-local control flow signals. Thrown as exceptions to escape+-- the current procedure or 'Foreach' loop and caught at the matching+-- boundary. 'CFReturn' is caught by 'callProc'; 'CFContinue' / 'CFBreak'+-- by 'execForeach' on its labelled loop.+data ControlFlow+  = CFReturn Value+  | CFContinue Label+  | CFBreak Label++instance Show ControlFlow where+  show (CFReturn _) = "CFReturn <val>"+  show (CFContinue l) = "CFContinue " ++ T.unpack l.unLabel+  show (CFBreak l) = "CFBreak " ++ T.unpack l.unLabel++instance Exception ControlFlow++-- | The interpreter's local stack: an 'IORef Env' threaded above 'Chr'.+-- Using a ref lets exception-driven jumps preserve any state changes+-- made before the jump, matching the original effectful-static-Local+-- 'runError'-with-outer-state semantics.+type InterpM = ReaderT (IORef Env) Chr++-- ---------------------------------------------------------------------------+-- Public API+-- ---------------------------------------------------------------------------++-- | Interpret a VM program by calling a named procedure with the given+-- value arguments. Builds a fresh 'SessionEnv' for the program and+-- runs the call inside it.+interpret :: Program -> HostCallRegistry -> Name -> [Value] -> IO Value+interpret prog hostCalls entryName args = do+  let procMap = Map.fromList [(p.name, p) | p <- prog.procedures]+      evaluableMap = Map.fromList prog.evaluables+  env <-+    initSessionEnv+      prog.typeNames+      prog.ruleNames+      procMap+      hostCalls+      evaluableMap+      Map.empty+      mempty+  runChr (callProc entryName (map CVal args)) env++-- ---------------------------------------------------------------------------+-- Env helpers+-- ---------------------------------------------------------------------------++getEnv :: InterpM Env+getEnv = do+  ref <- ask+  liftIO (readIORef ref)++modifyEnv :: (Env -> Env) -> InterpM ()+modifyEnv f = do+  ref <- ask+  liftIO (modifyIORef' ref f)++withFreshEnv :: Env -> InterpM a -> Chr a+withFreshEnv env action = do+  ref <- liftIO (newIORef env)+  runReaderT action ref++-- ---------------------------------------------------------------------------+-- Session helpers+-- ---------------------------------------------------------------------------++lookupProc :: Name -> Chr (Maybe Procedure)+lookupProc name = do+  SessionEnv {procMap} <- ask+  pm <- liftIO (readIORef procMap)+  pure (Map.lookup name pm)++lookupHostCall :: Name -> Chr (Maybe HostCallFn)+lookupHostCall name = do+  SessionEnv {hostCalls} <- ask+  pure (Map.lookup name hostCalls)++pushFrame :: StackFrame -> Chr ()+pushFrame frame = do+  SessionEnv {callStack} <- ask+  liftIO $+    atomicModifyIORef' callStack $ \stack ->+      (take maxCallStackDepth (frame : stack), ())++-- | Save the call stack, run @action@, and restore the saved frames+-- on the way out — whether @action@ returns normally or throws. The+-- restore-on-throw matters because the REPL's outer @try@ may catch+-- a 'RuntimeErrorThrown' that escapes a procedure call; without+-- bracketing, frames pushed during the failed call would leak into+-- the next operation that observes the same 'SessionEnv'.+withSavedCallStack :: Chr a -> Chr a+withSavedCallStack action = do+  env@SessionEnv {callStack} <- ask+  liftIO $+    bracket+      (readIORef callStack)+      (writeIORef callStack)+      (\_ -> runChr action env)++-- | Catch a 'ControlFlow' exception thrown inside a 'Chr' action.+-- Uses 'try' at the 'IO' layer so the action's state changes (in+-- 'SessionEnv' refs and in any 'InterpM' env ref currently in scope)+-- survive the catch.+tryControlFlow :: Chr a -> Chr (Either ControlFlow a)+tryControlFlow m = do+  env <- ask+  liftIO (try (runChr m env))++-- ---------------------------------------------------------------------------+-- Tracing helpers+-- ---------------------------------------------------------------------------++-- | Emit a 'TraceEvent' if a handler is installed. The event is built+-- lazily — when tracing is off, the action passed in is not run, so+-- callers can place expensive snapshotValues (e.g. 'valueToTerm' walks)+-- inside it without paying the cost when tracing is disabled.+emitTrace :: Chr TraceEvent -> Chr ()+emitTrace mkEv = do+  env <- ask+  mh <- liftIO (readIORef env.traceHandler)+  case mh of+    Nothing -> pure ()+    Just h -> do+      ev <- mkEv+      depth <- liftIO (readIORef env.traceDepth)+      liftIO (h depth ev)+{-# INLINE emitTrace #-}++-- | Run @action@ at depth @depth + 1@, restoring the previous depth+-- on the way out (including on exception). No-op when tracing is off.+withTraceDepth :: Chr a -> Chr a+withTraceDepth action = do+  env <- ask+  mh <- liftIO (readIORef env.traceHandler)+  case mh of+    Nothing -> action+    Just _ -> do+      let depthRef = env.traceDepth+      liftIO $+        bracket+          (atomicModifyIORef' depthRef (\d -> (d + 1, ())))+          (\() -> atomicModifyIORef' depthRef (\d -> (d - 1, ())))+          (\() -> runChr action env)++-- | Snapshot a 'Value' as a 'Term' for inclusion in a trace event.+-- Wraps 'valueToTerm' with an empty alias map — trace events do not+-- need the per-query alias-class machinery; raw variable names are+-- fine for inspection.+snapshotValue :: Value -> Chr Term+snapshotValue = valueToTerm Map.empty++snapshotValues :: [Value] -> Chr [Term]+snapshotValues = traverse snapshotValue++-- | Look up a suspension by id and return its constraint-type and+-- argument values. Used by trace-event builders that need both.+suspensionView :: SuspensionId -> Chr (ConstraintType, [Value])+suspensionView sid = do+  susp <- lookupSusp sid+  pure (susp.suspType, susp.args)++-- | Look up a rule's display name from the session-cached+-- 'ruleNames' table. Falls back to @__rule_N@ on miss.+lookupRuleName :: SessionEnv -> RuleId -> Text+lookupRuleName env (RuleId i) =+  case IntMap.lookup i env.ruleNames of+    Just n -> n+    Nothing -> T.pack ("__rule_" ++ show i)++-- ---------------------------------------------------------------------------+-- Core interpreter+-- ---------------------------------------------------------------------------++-- | Call a procedure. Creates a fresh local 'Env' with parameter+-- bindings, executes the body, and catches 'CFReturn'. Default+-- return: 'VBool False'. Emits trace events at entry (and on return+-- for user functions / lambdas) when tracing is on; uses the+-- procedure's 'procKind' tag to label the event and decide whether+-- to bump the trace indentation.+callProc :: Name -> [CallVal] -> Chr Value+callProc name args = do+  mproc <- lookupProc name+  case mproc of+    Nothing -> runtimeError' "callProc: unknown procedure " name.unName+    Just proc -> do+      env <- case bindParams name proc.params args of+        Right e -> pure e+        Left msg -> runtimeErrorS msg+      traceEntry proc args+      let runBody = withSavedCallStack $ do+            result <- tryControlFlow (withFreshEnv env (execStmts proc.body))+            case result of+              Right () -> pure (VBool False)+              Left (CFReturn v) -> pure v+              Left (CFContinue l) -> runtimeError' "callProc: uncaught Continue " l.unLabel+              Left (CFBreak l) -> runtimeError' "callProc: uncaught Break " l.unLabel+      result <-+        if bumpDepthFor proc.procKind+          then withTraceDepth runBody+          else runBody+      traceExit proc.procKind result+      pure result++-- | Should entering a procedure of this kind increase trace+-- indentation? Tells, activates, occurrences, reactivate-dispatch,+-- and user functions/lambdas do; the @$call@ dispatcher is a thin+-- router and would just add noise.+bumpDepthFor :: ProcKind -> Bool+bumpDepthFor PKTell {} = True+bumpDepthFor PKActivate {} = True+bumpDepthFor PKOccurrence {} = True+bumpDepthFor PKReactivateDispatch = True+bumpDepthFor PKFunction {} = True+bumpDepthFor PKCallDispatch {} = False++-- | Emit the entry-time event for a procedure call, if tracing is on.+-- Reactivation events are emitted at the per-suspension boundary+-- inside 'DrainReactivationQueue' (where the constraint id is in+-- hand), not here.+traceEntry :: Procedure -> [CallVal] -> Chr ()+traceEntry proc args = case proc.procKind of+  PKTell ct -> emitTrace $ do+    ctName <- constraintTypeLabel ct+    ts <- snapshotValues [v | CVal v <- args]+    pure (TETell ctName ts)+  PKActivate _ -> emitTrace $ do+    let sid = activateSuspensionId args+    (ct, vs) <- suspensionView sid+    ctName <- constraintTypeLabel ct+    ts <- snapshotValues vs+    pure (TEActivate ctName sid ts)+  PKOccurrence ct n _ display -> emitTrace $ do+    ctName <- constraintTypeLabel ct+    pure (TETryOccurrence ctName n display)+  PKReactivateDispatch -> pure ()+  PKCallDispatch _ -> pure ()+  PKFunction qn _ -> emitTrace $ do+    let fname = Types.flattenName (Types.qualifiedToName qn)+    ts <- snapshotValues [v | CVal v <- args]+    pure (TECallFunction fname ts)++-- | Emit a 'TEReturn' event for procedures whose return value is+-- user-meaningful: user functions and lambdas. The framework+-- procedures (tell / activate / occurrence) return a boolean control+-- flag that has no surface meaning; the depth dedent alone makes+-- their completion visible.+traceExit :: ProcKind -> Value -> Chr ()+traceExit (PKFunction _ _) v = emitTrace $ do+  t <- snapshotValue v+  pure (TEReturn t)+traceExit _ _ = pure ()++-- | Render a 'ConstraintType' as its source name using the session's+-- 'storeTypeNames' table. Falls back to @c#type_N@ when the type is+-- unknown (which should never happen for compiler-generated code).+constraintTypeLabel :: ConstraintType -> Chr Text+constraintTypeLabel ct = do+  env <- ask+  let i = ct.unConstraintType+  case IntMap.lookup i env.storeTypeNames of+    Just name -> pure (Types.flattenName name)+    Nothing -> pure (T.pack ("c#type_" ++ show i))++-- | Pull the leading suspension id out of an activate / occurrence /+-- reactivate-dispatch procedure's argument list. The compiler always+-- emits the id as the first parameter.+activateSuspensionId :: [CallVal] -> SuspensionId+activateSuspensionId (CId s : _) = s+activateSuspensionId _ = error "activateSuspensionId: expected leading id argument"++-- | Bind procedure parameters into the appropriate environment slot+-- based on the runtime tag of each argument.+bindParams :: Name -> [Name] -> [CallVal] -> Either String Env+bindParams pname params args+  | length params /= length args =+      Left $+        "bindParams: arity mismatch in "+          ++ T.unpack pname.unName+          ++ ": "+          ++ show (length params)+          ++ " params, "+          ++ show (length args)+          ++ " args"+  | otherwise = Right (List.foldl' step emptyEnv (zip params args))+  where+    step e (p, CVal v) = insertVal p v e+    step e (p, CId s) = insertId p s e++-- | Execute a list of statements sequentially.+execStmts :: [Stmt] -> InterpM ()+execStmts = traverse_ execStmt++-- | Execute a single statement. Mutates the local 'Env' for binders,+-- delegates control-flow stmts to the throw-and-catch machinery, and+-- routes store / history / reactivation effects through 'Chr'.+execStmt :: Stmt -> InterpM ()+execStmt (LetVal name expr) = do+  v <- evalValExpr expr+  modifyEnv (insertVal name v)+execStmt (LetId name expr) = do+  s <- evalIdExpr expr+  modifyEnv (insertId name s)+execStmt (AssignVal name expr) = do+  v <- evalValExpr expr+  modifyEnv (insertVal name v)+execStmt (AssignId name expr) = do+  s <- evalIdExpr expr+  modifyEnv (insertId name s)+execStmt (If cond thenBranch elseBranch) = do+  b <- evalBoolExpr cond+  if b then execStmts thenBranch else execStmts elseBranch+execStmt (Foreach lbl cType suspVar conditions body) = do+  snapshot <- lift (getStoreSnapshot cType)+  let susps = toList snapshot+  execForeach lbl suspVar conditions body susps+execStmt (Continue lbl) = liftIO (throwIO (CFContinue lbl))+execStmt (Break lbl) = liftIO (throwIO (CFBreak lbl))+execStmt (Return expr) = do+  v <- evalValExpr expr+  liftIO (throwIO (CFReturn v))+execStmt (ExprStmt expr) = do+  _ <- evalValExpr expr+  pure ()+execStmt (BoolExprStmt expr) = do+  _ <- evalBoolExpr expr+  pure ()+execStmt (Store expr) = do+  sid <- evalIdExpr expr+  lift $ do+    storeConstraint sid+    emitTrace $ do+      (ct, vs) <- suspensionView sid+      ctName <- constraintTypeLabel ct+      ts <- snapshotValues vs+      pure (TEStore sid ctName ts)+execStmt (Kill expr) = do+  sid <- evalIdExpr expr+  lift $ do+    killConstraint sid+    emitTrace (pure (TEKill sid))+execStmt (AddHistory ruleId exprs) = do+  sids <- traverse evalIdExpr exprs+  lift $ do+    emitTrace $ do+      env <- ask+      let rn = lookupRuleName env ruleId+      pure (TEFire rn sids)+    addHistory ruleId sids+execStmt (DrainReactivationQueue suspVar body) = do+  envRef <- ask+  lift $+    drainQueue $ \sid -> do+      alive <- aliveConstraint sid+      if alive+        then do+          emitTrace $ do+            (ct, vs) <- suspensionView sid+            ctName <- constraintTypeLabel ct+            ts <- snapshotValues vs+            pure (TEReactivate sid ctName ts)+          liftIO (modifyIORef' envRef (insertId suspVar sid))+          runReaderT (execStmts body) envRef+        else pure ()+execStmt (PushFrame frame) = lift (pushFrame frame)++-- ---------------------------------------------------------------------------+-- Foreach implementation+-- ---------------------------------------------------------------------------++-- | Iterate the body of a 'Foreach' over a snapshot of candidate+-- suspensions. Dead suspensions and suspensions failing the index+-- conditions are skipped without entering the body. Labelled+-- 'CFContinue' / 'CFBreak' are caught here; non-matching labels and+-- 'CFReturn' propagate to the next outer handler.+execForeach ::+  Label ->+  Name ->+  [(ArgIndex, ValExpr)] ->+  [Stmt] ->+  [Suspension] ->+  InterpM ()+execForeach _ _ _ _ [] = pure ()+execForeach lbl suspVar conditions body (susp : rest) = do+  alive <- lift (isSuspAlive susp)+  if not alive+    then execForeach lbl suspVar conditions body rest+    else do+      ok <- checkConditions susp conditions+      if not ok+        then execForeach lbl suspVar conditions body rest+        else do+          lift $ emitTrace $ do+            ctName <- constraintTypeLabel susp.suspType+            ts <- snapshotValues susp.args+            pure (TEPartner ctName susp.suspId ts)+          modifyEnv (insertId suspVar susp.suspId)+          envRef <- ask+          result <- lift (withTraceDepth (tryControlFlow (runReaderT (execStmts body) envRef)))+          case result of+            Right () -> execForeach lbl suspVar conditions body rest+            Left (CFContinue l)+              | l == lbl -> execForeach lbl suspVar conditions body rest+              | otherwise -> liftIO (throwIO (CFContinue l))+            Left (CFBreak l)+              | l == lbl -> pure ()+              | otherwise -> liftIO (throwIO (CFBreak l))+            Left cf@(CFReturn _) -> liftIO (throwIO cf)++checkConditions :: Suspension -> [(ArgIndex, ValExpr)] -> InterpM Bool+checkConditions _ [] = pure True+checkConditions susp ((ArgIndex i, expr) : rest) = do+  v <- evalValExpr expr+  let argVal = suspArg susp i+  eq <- lift (equal v argVal)+  if eq+    then checkConditions susp rest+    else pure False++-- ---------------------------------------------------------------------------+-- Value-expression evaluator (normal mode)+-- ---------------------------------------------------------------------------++-- | Evaluate a 'ValExpr' in normal (non-deep) mode. Variable references+-- return whatever value is currently bound; chains are not followed.+-- 'EvalDeep' delegates to 'evalValExprDeep'.+evalValExpr :: ValExpr -> InterpM Value+evalValExpr (Var name) = do+  env <- getEnv+  case Map.lookup name env.envValues of+    Just v -> pure v+    Nothing -> lift (runtimeError' "evalValExpr: unbound variable " name.unName)+evalValExpr (Lit (IntLit n)) = pure (VInt n)+evalValExpr (Lit (FloatLit n)) = pure (VFloat n)+evalValExpr (Lit (AtomLit s)) = pure (VAtom s)+evalValExpr (Lit (TextLit s)) = pure (VText s)+evalValExpr (Lit (BoolLit b)) = pure (VBool b)+evalValExpr (Lit WildcardLit) = pure VWildcard+evalValExpr (CallExpr name args) = do+  argVals <- traverse evalCallArg args+  lift (callProc name argVals)+evalValExpr (HostCall name args) = do+  argVals <- traverse evalValExpr args+  derefedVals <- lift (traverse deref argVals)+  lift (invokeHostCall name derefedVals)+evalValExpr NewVar = lift newVar+evalValExpr (MakeTerm functor args) = do+  argVals <- traverse evalValExpr args+  pure $ makeTerm functor.unName argVals+evalValExpr (GetArg expr idx) = do+  v <- evalValExpr expr+  lift (getArg v idx)+evalValExpr (FieldArg expr (ArgIndex i)) = do+  sid <- evalIdExpr expr+  lift (getConstraintArg sid i)+evalValExpr (FieldType expr) = do+  sid <- evalIdExpr expr+  ct <- lift (getConstraintType sid)+  pure (VInt (fromIntegral ct.unConstraintType))+evalValExpr (EvalDeep expr) = evalValExprDeep expr+-- 'EvalIs' is the @is@-with-variable-RHS marker. The compiler only+-- emits it for @R is X@ where @X@ is syntactically a variable; the+-- inner expression is therefore always a 'Var'. We evaluate that+-- 'Var', dereference, and then walk the resulting value with+-- 'deepEvalValue' so a bound compound whose functor is a declared+-- function actually evaluates (matching SWI Prolog's @is@ on a+-- variable). Other 'EvalDeep' use sites (guards, non-variable @is@+-- RHSes) do not invoke the walker.+evalValExpr (EvalIs expr) = do+  v <- evalValExprDeep expr+  lift (deepEvalValue v)++-- ---------------------------------------------------------------------------+-- Bool-expression evaluator (normal mode)+-- ---------------------------------------------------------------------------++-- | Evaluate a 'BoolExpr' in normal (non-deep) mode. Logical connectives+-- short-circuit. 'BEvalDeep' delegates to 'evalBoolExprDeep'.+evalBoolExpr :: BoolExpr -> InterpM Bool+evalBoolExpr (BLit b) = pure b+evalBoolExpr (BNot e) = not <$> evalBoolExpr e+evalBoolExpr (BAnd e1 e2) = do+  b1 <- evalBoolExpr e1+  if b1 then evalBoolExpr e2 else pure False+evalBoolExpr (BOr e1 e2) = do+  b1 <- evalBoolExpr e1+  if b1 then pure True else evalBoolExpr e2+evalBoolExpr (BMatchTerm expr functor arity) = do+  v <- evalValExpr expr+  lift (matchTerm v functor.unName arity)+evalBoolExpr (BEqual e1 e2) = do+  v1 <- evalValExpr e1+  v2 <- evalValExpr e2+  lift (equal v1 v2)+evalBoolExpr (BIdEqual e1 e2) = do+  s1 <- evalIdExpr e1+  s2 <- evalIdExpr e2+  pure (idEqual s1 s2)+evalBoolExpr (BAlive expr) = do+  sid <- evalIdExpr expr+  lift (aliveConstraint sid)+evalBoolExpr (BIsConstraintType expr cType) = do+  sid <- evalIdExpr expr+  lift (isConstraintType sid cType)+evalBoolExpr (BNotInHistory ruleId args) = do+  sids <- traverse evalIdExpr args+  ok <- lift (notInHistory ruleId sids)+  unless ok $+    lift $+      emitTrace $ do+        env <- ask+        let rn = lookupRuleName env ruleId+        pure (TEHistoryHit rn sids)+  pure ok+evalBoolExpr (BUnify e1 e2) = do+  v1 <- evalValExpr e1+  v2 <- evalValExpr e2+  lift $ do+    env <- ask+    mh <- liftIO (readIORef env.traceHandler)+    case mh of+      Nothing -> unifyOrError v1 v2+      Just _ -> do+        t1 <- snapshotValue v1+        t2 <- snapshotValue v2+        beforeLen <- liftIO (Seq.length <$> readIORef env.reactQueue)+        ok <- unifyOrError v1 v2+        afterLen <- liftIO (Seq.length <$> readIORef env.reactQueue)+        emitTrace (pure (TEUnify t1 t2 (afterLen - beforeLen)))+        pure ok+evalBoolExpr (BFromVal expr) = do+  v <- evalValExpr expr+  case v of+    VBool b -> pure b+    _ -> lift (runtimeErrorS "guard did not evaluate to a boolean")+evalBoolExpr (BEvalDeep expr) = evalBoolExprDeep expr++-- ---------------------------------------------------------------------------+-- Id-expression evaluator+-- ---------------------------------------------------------------------------++-- | Evaluate an 'IdExpr' to a 'SuspensionId': either a lookup in the+-- id slot of the local 'Env', or a fresh suspension created from a+-- 'CreateConstraint' (not yet 'Store'd).+evalIdExpr :: IdExpr -> InterpM SuspensionId+evalIdExpr (IdVar name) = do+  env <- getEnv+  case Map.lookup name env.envIds of+    Just s -> pure s+    Nothing -> lift (runtimeError' "evalIdExpr: unbound id variable " name.unName)+evalIdExpr (CreateConstraint cType args) = do+  argVals <- traverse evalValExpr args+  lift (createConstraint cType argVals)++-- ---------------------------------------------------------------------------+-- Call-arg evaluator+-- ---------------------------------------------------------------------------++evalCallArg :: CallArg -> InterpM CallVal+evalCallArg (AVal e) = CVal <$> evalValExpr e+evalCallArg (AId e) = CId <$> evalIdExpr e++-- ---------------------------------------------------------------------------+-- Host call dispatch+-- ---------------------------------------------------------------------------++-- | Dispatch a host call by name. Only synchronous, non-control-flow+-- exceptions thrown by the host body get wrapped as runtime errors:+-- 'ControlFlow' (interpreter-internal: Return/Continue/Break) and+-- async exceptions (Ctrl+C, thread kill) must keep their identity so+-- they reach their intended handler; 'RuntimeErrorThrown' is re-thrown+-- verbatim so nested host calls preserve the original message and+-- stack frames.+invokeHostCall :: Name -> [Value] -> Chr Value+invokeHostCall name argVals = do+  mfn <- lookupHostCall name+  case mfn of+    Just (HostCallFn f) -> do+      env <- ask+      result <- liftIO (try @SomeException (runChr (f argVals) env))+      case result of+        Right v -> do+          emitTrace $ do+            argTs <- snapshotValues argVals+            resT <- snapshotValue v+            pure (TECallHost name.unName argTs resT)+          pure v+        Left exc+          | Just (cf :: ControlFlow) <- fromException exc ->+              liftIO (throwIO cf)+          | Just (ae :: SomeAsyncException) <- fromException exc ->+              liftIO (throwIO ae)+          | Just (rte :: RuntimeErrorThrown) <- fromException exc ->+              liftIO (throwIO rte)+          | otherwise ->+              runtimeErrorS $+                "host call " ++ T.unpack name.unName ++ ": " ++ displayException exc+    Nothing -> runtimeError' "invokeHostCall: unknown host call " name.unName++-- | Unify two already-evaluated values (tell semantics). Enqueues+-- observers of any variables affected by the unification — including+-- on failure, where partial bindings may still have produced+-- observers worth reactivating. Raises a runtime error with both+-- operands pretty-printed when unification fails.+unifyOrError :: Value -> Value -> Chr Bool+unifyOrError v1 v2 = do+  (ok, observers) <- unify v1 v2+  enqueue observers+  if ok+    then pure True+    else do+      t1 <- valueToTerm Map.empty v1+      t2 <- valueToTerm Map.empty v2+      runtimeErrorS $+        "unification failure: cannot unify "+          ++ prettyTerm t1+          ++ " with "+          ++ prettyTerm t2++-- ---------------------------------------------------------------------------+-- Value-expression evaluator (deep deref mode)+-- ---------------------------------------------------------------------------++-- | Evaluate a value expression with automatic dereferencing: variable+-- references follow binding chains before use, and this mode propagates+-- into sub-expressions. Used to implement 'EvalDeep' (guards and @is@ RHS).+--+-- This evaluator dereferences 'Var' references once. The+-- 'EvalDeep' case at 'evalValExpr' is responsible for the additional+-- value-side walk that evaluates a dereferenced compound term —+-- it applies only when the outer 'EvalDeep' is a bare 'Var', so that+-- @R is X@ (RHS is a variable) walks @X@'s bound term but+-- @R is copy_term(quote(X))@ (RHS is a host call) leaves @X@'s bound+-- compound symbolic for the host call's benefit. This intentionally+-- mirrors the type checker's rule: only @R is X@ widens the LHS to+-- @any@.+evalValExprDeep :: ValExpr -> InterpM Value+evalValExprDeep (Var name) = do+  v <- evalValExpr (Var name)+  lift (deref v)+evalValExprDeep (HostCall name args) = do+  argVals <- traverse evalValExprDeep args+  lift (invokeHostCall name argVals)+evalValExprDeep (CallExpr name args) = do+  argVals <- traverse evalCallArgDeep args+  lift (callProc name argVals)+evalValExprDeep (MakeTerm functor args) = do+  argVals <- traverse evalValExprDeep args+  pure $ makeTerm functor.unName argVals+evalValExprDeep expr = evalValExpr expr++-- | Walk a runtime 'Value', evaluating any compound subterm whose+-- @(functor, arity)@ names a declared host call or a compiled user+-- function. Atomic values pass through. Unbound variables are+-- dereferenced once and then re-walked, so a chain of bindings+-- ending in a compound triggers full evaluation. Functors that do+-- not name an evaluable declaration (constructors, undeclared+-- atoms) raise a runtime error — mirroring SWI Prolog's+-- @type_error(evaluable, F\/N)@.+--+-- Caveat: the host-call fallback below looks up @key.functor@ only,+-- discarding the arity, because 'HostCallRegistry' is keyed by name+-- alone. So @X = '-'(1), R is X@ reports the arity mismatch from+-- inside the @-@ primitive rather than as+-- @is: functor is not evaluable: -\/1@. The Scheme runtime keys its+-- equivalent table by @(name, arity)@ and so reports the latter — a+-- known divergence, tracked in @dev-docs\/SCHEME_BACKEND_GAPS.md@.+--+-- 'MakeTerm' callers do /not/ funnel through this walker — the+-- @quote/1@ quoting form must continue to produce the symbolic+-- compound it was asked to build.+deepEvalValue :: Value -> Chr Value+deepEvalValue v = do+  v' <- deref v+  case v' of+    VTerm functor args -> do+      args' <- traverse deepEvalValue args+      let key = EvaluableKey {functor = Name functor, arity = length args}+      invokeByKey key args'+    _ -> pure v'++-- | Dispatch a value-side deep-evaluation step: prefer a user-defined+-- function (resolved through the compiler-emitted 'evaluables' table),+-- fall back to the host-call registry, and raise a runtime error if+-- neither matches. The two-tier order lets a user shadow a prelude+-- host call by declaring a function of the same name and arity.+invokeByKey :: EvaluableKey -> [Value] -> Chr Value+invokeByKey key args = do+  SessionEnv {evaluables, hostCalls} <- ask+  case Map.lookup key evaluables of+    Just procName -> callProc procName (map CVal args)+    Nothing ->+      case Map.lookup key.functor hostCalls of+        Just _ -> invokeHostCall key.functor args+        Nothing ->+          runtimeError'+            "is: functor is not evaluable: "+            (key.functor.unName <> "/" <> T.pack (show key.arity))++evalCallArgDeep :: CallArg -> InterpM CallVal+evalCallArgDeep (AVal e) = CVal <$> evalValExprDeep e+evalCallArgDeep (AId e) = CId <$> evalIdExpr e++-- ---------------------------------------------------------------------------+-- Bool-expression evaluator (deep deref mode)+-- ---------------------------------------------------------------------------++-- | Deep-deref evaluation for 'BoolExpr'. Mirrors 'evalValExprDeep':+-- propagates deep mode into 'ValExpr' and 'IdExpr' payloads.+evalBoolExprDeep :: BoolExpr -> InterpM Bool+evalBoolExprDeep (BNot e) = not <$> evalBoolExprDeep e+evalBoolExprDeep (BAnd e1 e2) = do+  b1 <- evalBoolExprDeep e1+  if b1 then evalBoolExprDeep e2 else pure False+evalBoolExprDeep (BOr e1 e2) = do+  b1 <- evalBoolExprDeep e1+  if b1 then pure True else evalBoolExprDeep e2+evalBoolExprDeep (BMatchTerm expr functor arity) = do+  v <- evalValExprDeep expr+  lift (matchTerm v functor.unName arity)+evalBoolExprDeep (BEqual e1 e2) = do+  v1 <- evalValExprDeep e1+  v2 <- evalValExprDeep e2+  lift (equal v1 v2)+evalBoolExprDeep (BUnify e1 e2) = do+  v1 <- evalValExprDeep e1+  v2 <- evalValExprDeep e2+  lift (unifyOrError v1 v2)+evalBoolExprDeep (BFromVal expr) = do+  v <- evalValExprDeep expr+  case v of+    VBool b -> pure b+    _ -> lift (runtimeErrorS "guard did not evaluate to a boolean")+evalBoolExprDeep (BEvalDeep expr) = evalBoolExprDeep expr+evalBoolExprDeep expr = evalBoolExpr expr
+ src/YCHR/Internal/Runtime/Monad.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE OverloadedRecordDot #-}++-- | The 'Chr' monad and the 'SessionEnv' it reads from.+--+-- 'Chr' is the host-side runtime monad: a 'ReaderT' over a record of+-- mutable references that hold the constraint store, propagation+-- history, reactivation queue, unification-variable counter, the+-- interpreter call stack, the procedure map, and immutable references+-- to the host-call registry and export-resolution maps.+--+-- The compiler never sees 'Chr'; it only emits VM code. 'Chr' is the+-- shape of the *interpreter* that executes that VM code, plus the+-- query-time driver that calls into the interpreter.+module YCHR.Internal.Runtime.Monad+  ( -- * The Chr monad+    Chr,+    runChr,++    -- * Session environment+    SessionEnv (..),+    initSessionEnv,++    -- * Auxiliary types+    CallStack,+    ProcMap,+    HostCallFn (..),+    HostCallRegistry,+    EvaluableRegistry,+  )+where++import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import Data.IORef+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Map.Strict (Map)+import Data.Sequence (Seq)+import Data.Sequence qualified as Seq+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import YCHR.Internal.Compile.Pipeline (ExportResolution)+import YCHR.Internal.Runtime.Trace (TraceHandler)+import YCHR.Internal.Runtime.Types (Suspension, SuspensionId, Value, VarId (..))+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM (EvaluableKey, Procedure, RuleId, StackFrame)+import YCHR.Internal.VM qualified as VM++-- | The runtime call stack (newest frame first), used for error reporting.+type CallStack = [StackFrame]++-- | Map from procedure name to its VM definition.+type ProcMap = Map VM.Name Procedure++-- | Registry of host-language functions callable from compiled code.+type HostCallRegistry = Map VM.Name HostCallFn++-- | Registry of user-defined functions that the deep-evaluator can+-- dispatch to. Maps a @(functor, arity)@ key (as seen on a 'VTerm')+-- to the mangled 'ProcMap' key that resolves the corresponding+-- compiled procedure.+type EvaluableRegistry = Map EvaluableKey VM.Name++-- | The host-side runtime monad.+type Chr = ReaderT SessionEnv IO++-- | A host call function. Operates inside 'Chr' so it can read mutable+-- runtime state (logical variables, the store, the call stack) the+-- same way the interpreter does.+newtype HostCallFn = HostCallFn+  { runHostCall :: [Value] -> Chr Value+  }++-- | The mutable session state plus the immutable program-level lookups+-- the runtime needs. All long-lived state lives here; per-procedure+-- locals (e.g. 'Env') stay layered in a 'StateT' above 'Chr' where+-- they belong.+data SessionEnv = SessionEnv+  { -- | Counter for fresh logical-variable IDs.+    varCounter :: !(IORef VarId),+    -- | Type-indexed store: one append-only sequence per constraint+    -- type, keyed by the integer wrapped in 'ConstraintType'.+    storeByType :: !(IORef (IntMap (Seq Suspension))),+    -- | Source names parallel to 'storeByType', indexed by+    -- 'ConstraintType'.+    storeTypeNames :: !(IntMap Types.Name),+    -- | Display names of rules, indexed by 'RuleId'. Carried so the+    -- tracer can label 'AddHistory' / 'BNotInHistory' events+    -- without a second lookup into the original 'Program'.+    ruleNames :: !(IntMap Text),+    -- | Map from suspension id to the suspension record. Populated on+    -- 'createConstraint'.+    storeById :: !(IORef (IntMap Suspension)),+    -- | Counter for the next suspension id.+    storeNextId :: !(IORef Int),+    -- | Propagation history: which rules have fired with which id tuples.+    history :: !(IORef (Set (RuleId, [SuspensionId]))),+    -- | Queue of constraint ids pending reactivation (filled by 'unify',+    -- drained by 'DrainReactivationQueue').+    reactQueue :: !(IORef (Seq SuspensionId)),+    -- | Interpreter call stack (newest first), capped in length.+    callStack :: !(IORef CallStack),+    -- | All known procedures. Mutable so query-time lambdas can be+    -- inserted without rebuilding the env.+    procMap :: !(IORef ProcMap),+    -- | Host-call registry.+    hostCalls :: !HostCallRegistry,+    -- | Deep-evaluator dispatch table for the @is@ operator.+    -- Populated from the compiler's user-defined-function list at+    -- session init.+    evaluables :: !EvaluableRegistry,+    -- | Export map from the compiler — used to resolve unqualified+    -- constraint names at 'tellConstraint' time.+    exportMap :: !(Map Types.UnqualifiedIdentifier ExportResolution),+    -- | The set of all qualified identifiers exported by the program.+    exportedSet :: !(Set Types.QualifiedIdentifier),+    -- | Optional tracing sink. When 'Just', the interpreter emits a+    -- 'TraceEvent' at each ωr step and at function / host-call+    -- boundaries. Stored as an 'IORef' so the REPL can swap a+    -- handler in for the duration of one @:trace@ query inside an+    -- otherwise-untraced live session.+    traceHandler :: !(IORef (Maybe TraceHandler)),+    -- | Current indentation depth for the tracer. Only meaningful+    -- when 'traceHandler' is 'Just'; the interpreter bumps it on+    -- entry to ωr procedures (activate / occurrence / reactivate+    -- dispatch) and on user-function / lambda entry, via @bracket@+    -- so 'ControlFlow' exceptions still pop.+    traceDepth :: !(IORef Int)+  }++-- | Build a fresh 'SessionEnv' for a compiled program.+initSessionEnv ::+  [Types.Name] ->+  [Text] ->+  ProcMap ->+  HostCallRegistry ->+  EvaluableRegistry ->+  Map Types.UnqualifiedIdentifier ExportResolution ->+  Set Types.QualifiedIdentifier ->+  IO SessionEnv+initSessionEnv typeNames rNames pm hc ev expMap expSet = do+  vc <- newIORef (VarId 0)+  let typeCount = length typeNames+      emptyStore = IntMap.fromList [(i, Seq.empty) | i <- [0 .. typeCount - 1]]+      typeNameMap = IntMap.fromList (zip [0 ..] typeNames)+      ruleNameMap = IntMap.fromList (zip [0 ..] rNames)+  bt <- newIORef emptyStore+  bi <- newIORef IntMap.empty+  ni <- newIORef 0+  hi <- newIORef Set.empty+  rq <- newIORef Seq.empty+  cs <- newIORef []+  pmRef <- newIORef pm+  th <- newIORef Nothing+  td <- newIORef 0+  pure+    SessionEnv+      { varCounter = vc,+        storeByType = bt,+        storeTypeNames = typeNameMap,+        ruleNames = ruleNameMap,+        storeById = bi,+        storeNextId = ni,+        history = hi,+        reactQueue = rq,+        callStack = cs,+        procMap = pmRef,+        hostCalls = hc,+        evaluables = ev,+        exportMap = expMap,+        exportedSet = expSet,+        traceHandler = th,+        traceDepth = td+      }++-- | Run a 'Chr' action against a built 'SessionEnv'. Thin alias around+-- 'runReaderT' so callers don't need to import the transformer module.+runChr :: Chr a -> SessionEnv -> IO a+runChr = runReaderT
+ src/YCHR/Internal/Runtime/Reactivation.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}++-- | Reactivation queue for the CHR Haskell runtime.+--+-- Accumulates constraint suspension IDs that need reactivation (typically+-- enqueued as a side effect of unification) and provides a drain operation+-- that processes them one at a time. The drain re-reads the queue on every+-- iteration so that IDs enqueued by reentrant unifications during the+-- callback are picked up.+module YCHR.Internal.Runtime.Reactivation+  ( enqueue,+    drainQueue,+  )+where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask)+import Data.IORef+import Data.Sequence (Seq (..))+import Data.Sequence qualified as Seq+import YCHR.Internal.Runtime.Monad (Chr, SessionEnv (..))+import YCHR.Internal.Runtime.Types (SuspensionId)++-- | Append suspension IDs to the back of the queue.+enqueue :: [SuspensionId] -> Chr ()+enqueue ids = do+  SessionEnv {reactQueue} <- ask+  liftIO $ modifyIORef' reactQueue (<> Seq.fromList ids)++-- | Drain the queue one element at a time, calling the callback for each.+-- Re-reads the queue on every iteration so that IDs enqueued by the+-- callback (via reentrant unifications) are picked up.+drainQueue :: (SuspensionId -> Chr ()) -> Chr ()+drainQueue callback = go+  where+    go = do+      SessionEnv {reactQueue} <- ask+      mNext <- liftIO $ atomicModifyIORef' reactQueue $ \case+        Empty -> (Seq.empty, Nothing)+        x :<| rest -> (rest, Just x)+      case mNext of+        Nothing -> pure ()+        Just sid -> callback sid >> go
+ src/YCHR/Internal/Runtime/Registry.hs view
@@ -0,0 +1,333 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Host call registry for the CHR runtime.+--+-- Provides a base registry of host language functions (arithmetic,+-- comparisons, string operations, type predicates) and generic helpers+-- for building custom host calls.+module YCHR.Internal.Runtime.Registry+  ( -- * Types (re-exported from "YCHR.Internal.Runtime.Monad")+    HostCallFn (..),+    HostCallRegistry,++    -- * Registry+    baseHostCallRegistry,++    -- * Utilities+    unit,++    -- * Value predicates+    isInteger,+    isFloat,+    isAtom,+    isBoolean,+    isString,+    isVar,+    isNonvar,++    -- * Generic helpers+    allM,+    collectVars,+    copyTerm,+    fromValueList,+    valueList,+  )+where++import Control.Monad.IO.Class (liftIO)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text qualified as T+import YCHR.Internal.Runtime.Error (runtimeErrorS)+import YCHR.Internal.Runtime.Monad (Chr, HostCallFn (..), HostCallRegistry)+import YCHR.Internal.Runtime.Types (Value (..), VarId)+import YCHR.Internal.Runtime.Var (deref, equal, getVarId, newVar, unifiable)+import YCHR.Internal.VM (Name (..))++-- ---------------------------------------------------------------------------+-- Registry+-- ---------------------------------------------------------------------------++-- | A base host call registry providing arithmetic, comparison, string,+-- and type predicate operations.+baseHostCallRegistry :: HostCallRegistry+baseHostCallRegistry =+  Map.fromList+    [ (Name "+", numArith2 (+) (+)),+      (Name "-", numArith2 (-) (-)),+      (Name "*", numArith2 (*) (*)),+      (Name "div", intDivOp2 "div" div),+      (Name "mod", intDivOp2 "mod" mod),+      (Name "rem", intDivOp2 "rem" rem),+      (Name "/", floatArith2 (/)),+      (Name "<", numCmp (<) (<)),+      (Name ">", numCmp (>) (>)),+      (Name "=<", numCmp (<=) (<=)),+      (Name ">=", numCmp (>=) (>=)),+      (Name "==", valEq),+      (Name "not", notBool),+      (Name "float", typePred isFloat),+      (Name "int_to_float", toFloatFn),+      (Name "float_to_int", toIntFn),+      (Name "unifiable", unifiableHost),+      (Name "string_concat", stringConcat),+      (Name "string_length", stringLength),+      (Name "string_upper", stringUpper),+      (Name "string_lower", stringLower),+      (Name "__chr_error", chrError),+      (Name "write", writeStr),+      (Name "writeln", writeStrLn),+      (Name "integer", typePred isInteger),+      (Name "atom", typePred isAtom),+      (Name "boolean", typePred isBoolean),+      (Name "string", typePred isString),+      (Name "var", typePred isVar),+      (Name "nonvar", typePred isNonvar),+      (Name "ground", groundPred),+      (Name "term_variables", termVariablesPred),+      (Name "compound_to_list", compoundToList),+      (Name "list_to_compound", listToCompound),+      (Name "copy_term", copyTermHost)+    ]+  where+    numArith2 intOp floatOp = HostCallFn $ \case+      [VInt a, VInt b] -> pure (VInt (intOp a b))+      [VFloat a, VFloat b] -> pure (VFloat (floatOp a b))+      args ->+        runtimeErrorS $+          "arithmetic host call: expected 2 numeric arguments of same type, got "+            ++ show (length args)+    intDivOp2 opName op = HostCallFn $ \case+      [VInt _, VInt 0] ->+        runtimeErrorS $ "integer " ++ opName ++ ": division by zero"+      [VInt a, VInt b] -> pure (VInt (op a b))+      args ->+        runtimeErrorS $+          "integer arithmetic host call: expected 2 Int arguments, got "+            ++ show (length args)+    floatArith2 op = HostCallFn $ \case+      [VFloat a, VFloat b] -> pure (VFloat (op a b))+      args ->+        runtimeErrorS $+          "float arithmetic host call: expected 2 Float arguments, got "+            ++ show (length args)+    numCmp intOp floatOp = HostCallFn $ \case+      [VInt a, VInt b] -> pure (VBool (intOp a b))+      [VFloat a, VFloat b] -> pure (VBool (floatOp a b))+      args ->+        runtimeErrorS $+          "comparison host call: expected 2 numeric arguments of same type, got "+            ++ show (length args)+    toFloatFn = HostCallFn $ \case+      [VInt n] -> pure (VFloat (fromIntegral n))+      [VFloat n] -> pure (VFloat n)+      _ -> runtimeErrorS "int_to_float: expected 1 numeric argument"+    toIntFn = HostCallFn $ \case+      [VFloat n] -> pure (VInt (truncate n))+      [VInt n] -> pure (VInt n)+      _ -> runtimeErrorS "float_to_int: expected 1 numeric argument"+    unifiableHost = HostCallFn $ \case+      [a, b] -> VBool <$> unifiable a b+      args ->+        runtimeErrorS $+          "unifiable host call: expected 2 arguments, got " ++ show (length args)+    valEq = HostCallFn $ \case+      [a, b] -> VBool <$> equal a b+      args ->+        runtimeErrorS $+          "== host call: expected 2 arguments, got " ++ show (length args)+    notBool = HostCallFn $ \case+      [v] -> do+        v' <- deref v+        case v' of+          VBool b -> pure (VBool (not b))+          _ -> runtimeErrorS "not: expected a boolean argument"+      args ->+        runtimeErrorS $+          "not host call: expected 1 argument, got " ++ show (length args)+    stringConcat = HostCallFn $ \case+      [VText a, VText b] -> pure (VText (a <> b))+      _ -> runtimeErrorS "string_concat: expected 2 Text arguments"+    stringLength = HostCallFn $ \case+      [VText s] -> pure (VInt (fromIntegral (T.length s)))+      _ -> runtimeErrorS "string_length: expected 1 Text argument"+    stringUpper = HostCallFn $ \case+      [VText s] -> pure (VText (T.toUpper s))+      _ -> runtimeErrorS "string_upper: expected 1 Text argument"+    stringLower = HostCallFn $ \case+      [VText s] -> pure (VText (T.toLower s))+      _ -> runtimeErrorS "string_lower: expected 1 Text argument"+    chrError = HostCallFn $ \_ -> runtimeErrorS "CHR runtime error: no matching equation"+    writeStr = HostCallFn $ \case+      [VText s] -> unit <$ liftIO (putStr (T.unpack s))+      _ -> runtimeErrorS "write: expected 1 Text argument"+    writeStrLn = HostCallFn $ \case+      [VText s] -> unit <$ liftIO (putStrLn (T.unpack s))+      _ -> runtimeErrorS "writeln: expected 1 Text argument"+    typePred p = HostCallFn $ \case+      [v] -> do+        v' <- deref v+        pure (VBool (p v'))+      _ -> runtimeErrorS "type predicate: expected 1 argument"+    groundPred = HostCallFn $ \case+      [v] -> VBool <$> isGround v+      _ -> runtimeErrorS "ground: expected 1 argument"+    isGround v = do+      v' <- deref v+      case v' of+        VVar _ -> pure False+        VWildcard -> pure False+        VTerm _ args -> allM isGround args+        _ -> pure True+    termVariablesPred = HostCallFn $ \case+      [v] -> do+        (vars, _) <- collectVars Set.empty v+        pure (valueList vars)+      _ -> runtimeErrorS "term_variables: expected 1 argument"+    compoundToList = HostCallFn $ \case+      [VTerm f args] -> pure (valueList (VAtom f : args))+      [v@(VAtom _)] -> pure (valueList [v])+      _ -> runtimeErrorS "compound_to_list: expected 1 compound or atom argument"+    listToCompound = HostCallFn $ \case+      [list] -> case fromValueList list of+        Just [VAtom f] -> pure (VAtom f)+        Just (VAtom f : args) -> pure (VTerm f args)+        _ -> runtimeErrorS "list_to_compound: expected a non-empty list with an atom head"+      _ -> runtimeErrorS "list_to_compound: expected 1 list argument"+    copyTermHost = HostCallFn $ \case+      [v] -> copyTerm v+      _ -> runtimeErrorS "copy_term: expected 1 argument"++-- ---------------------------------------------------------------------------+-- Utilities+-- ---------------------------------------------------------------------------++-- | The unit return value for host calls that are only used for side effects.+unit :: Value+unit = VAtom "()"++-- ---------------------------------------------------------------------------+-- Value predicates+-- ---------------------------------------------------------------------------++isInteger :: Value -> Bool+isInteger (VInt _) = True+isInteger _ = False++isFloat :: Value -> Bool+isFloat (VFloat _) = True+isFloat _ = False++isAtom :: Value -> Bool+isAtom (VAtom _) = True+isAtom _ = False++isBoolean :: Value -> Bool+isBoolean (VBool _) = True+isBoolean _ = False++isString :: Value -> Bool+isString (VText _) = True+isString _ = False++isVar :: Value -> Bool+isVar (VVar _) = True+isVar VWildcard = True+isVar _ = False++isNonvar :: Value -> Bool+isNonvar = not . isVar++-- ---------------------------------------------------------------------------+-- Generic helpers+-- ---------------------------------------------------------------------------++-- | Deep-copy a term, replacing all unbound variables with fresh ones.+-- Preserves sharing: the same original variable always maps to the same+-- fresh variable across the entire copied term.+copyTerm :: Value -> Chr Value+copyTerm val = fst <$> go Map.empty val+  where+    go cache v = do+      v' <- deref v+      case v' of+        VVar _ -> do+          mid <- getVarId v'+          case mid of+            Just vid -> case Map.lookup vid cache of+              Just fresh -> pure (fresh, cache)+              Nothing -> do+                fresh <- newVar+                pure (fresh, Map.insert vid fresh cache)+            Nothing -> pure (v', cache)+        VWildcard -> do+          fresh <- newVar+          pure (fresh, cache)+        VTerm f args -> do+          (args', cache') <- goMany cache args+          pure (VTerm f args', cache')+        other -> pure (other, cache)++    goMany cache [] = pure ([], cache)+    goMany cache (x : xs) = do+      (x', cache') <- go cache x+      (xs', cache'') <- goMany cache' xs+      pure (x' : xs', cache'')++-- | Collect all unique unbound variables in a term, traversing into+-- compound term arguments. Wildcards are replaced with fresh variables.+-- Returns the collected variables and the updated set of seen 'VarId's.+collectVars ::+  Set.Set VarId ->+  Value ->+  Chr ([Value], Set.Set VarId)+collectVars seen v = do+  v' <- deref v+  case v' of+    VVar _ -> do+      mid <- getVarId v'+      case mid of+        Just vid+          | Set.member vid seen -> pure ([], seen)+          | otherwise -> pure ([v'], Set.insert vid seen)+        Nothing -> pure ([], seen)+    VWildcard -> do+      fresh <- newVar+      pure ([fresh], seen)+    VTerm _ args -> collectVarsMany seen args+    _ -> pure ([], seen)+  where+    collectVarsMany s [] = pure ([], s)+    collectVarsMany s (x : xs) = do+      (vars, s') <- collectVars s x+      (rest, s'') <- collectVarsMany s' xs+      pure (vars ++ rest, s'')++-- | Monadic version of 'all'. Short-circuits on the first 'False'.+allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool+allM _ [] = pure True+allM p (x : xs) = do+  b <- p x+  if b then allM p xs else pure False++-- | Build a Prolog-style list (@[H|T]@) from a Haskell list of values.+--+-- The empty list is represented as the atom @[]@, and cons cells as+-- @.(H, T)@ compound terms.+valueList :: [Value] -> Value+valueList [] = VAtom "prelude__[]"+valueList (x : xs) = VTerm "prelude__." [x, valueList xs]++-- | Decompose a Prolog-style list back into a Haskell list. Recognizes+-- both the canonicalized cons form (@prelude__.@/@prelude__[]@,+-- emitted by the renamer-driven pipeline) and the legacy bare form+-- (@.@/@[]@, used by Haskell-side code that constructs values without+-- going through the renamer — e.g. test fixtures, the DSL).+-- Returns 'Nothing' if the value is not a well-formed list.+fromValueList :: Value -> Maybe [Value]+fromValueList (VAtom "prelude__[]") = Just []+fromValueList (VAtom "[]") = Just []+fromValueList (VTerm "prelude__." [x, rest]) = (x :) <$> fromValueList rest+fromValueList (VTerm "." [x, rest]) = (x :) <$> fromValueList rest+fromValueList _ = Nothing
+ src/YCHR/Internal/Runtime/Session.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++-- | The CHR session: a running interpreter state for a compiled+-- program (constraint store, propagation history, reactivation queue,+-- unification variables, call stack), packaged as the 'Chr' monad.+--+-- Lives in its own module so the type-checker can open a CHR session+-- without depending on "YCHR.Run" (which would otherwise form a cycle+-- once "YCHR.Run" calls into the type-checker for goal-time checks).+module YCHR.Internal.Runtime.Session+  ( -- * The CHR monad (re-exported)+    Chr,+    SessionEnv (..),+    initSessionEnv,+    runChr,++    -- * Session input+    SessionInput (..),+    toSessionInput,++    -- * Session setup+    withCHR,+    withCHRExtra,+    withCHRExtraTraced,+    withTraceHandler,++    -- * Telling constraints+    tellConstraint,+  )+where++import Control.Exception (bracket_)+import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask)+import Data.IORef (readIORef, writeIORef)+import Data.List (intercalate)+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 qualified as T+import YCHR.Internal.Compile (tellProcName)+import YCHR.Internal.Compile.Pipeline (CompiledProgram (..), ExportResolution (..))+import YCHR.Internal.Runtime.Error (runtimeErrorS)+import YCHR.Internal.Runtime.Interpreter (HostCallRegistry, callProc)+import YCHR.Internal.Runtime.Monad+  ( Chr,+    SessionEnv (..),+    initSessionEnv,+    runChr,+  )+import YCHR.Internal.Runtime.Trace (TraceHandler)+import YCHR.Internal.Runtime.Types (CallVal (..), Value (..))+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM (Name (..), Procedure (..), Program (..))++-- | The narrow slice of a compiled program that 'withCHR' /+-- 'withCHRExtra' need: the VM 'Program' and the export-resolution maps+-- used by 'tellConstraint' to canonicalize unqualified constraint+-- names. A 'CompiledProgram' projects to one via 'toSessionInput'; the+-- pre-compiled type-checker bundle is a 'SessionInput' directly.+data SessionInput = SessionInput+  { program :: Program,+    exportMap :: Map Types.UnqualifiedIdentifier ExportResolution,+    exportedSet :: Set Types.QualifiedIdentifier+  }+  deriving ()++-- | Project a 'CompiledProgram' down to the slice 'withCHR' /+-- 'withCHRExtra' actually read.+toSessionInput :: CompiledProgram -> SessionInput+toSessionInput cp =+  SessionInput+    { program = cp.program,+      exportMap = cp.exportMap,+      exportedSet = cp.exportedSet+    }++-- | Run a CHR action in a fresh session for a compiled program. All+-- runtime state (constraint store, propagation history, reactivation+-- queue, unification variables, call stack) is initialised and+-- persists for the duration of the computation.+withCHR :: SessionInput -> HostCallRegistry -> Chr a -> IO a+withCHR si hc action = withCHRExtra si hc [] action++-- | Like 'withCHR' but merges extra procedures (e.g. query-time lambda+-- compilations and updated call dispatches) into the procedure map+-- visible to the action.+withCHRExtra ::+  SessionInput ->+  HostCallRegistry ->+  [Procedure] ->+  Chr a ->+  IO a+withCHRExtra si hc extraProcs action = do+  let baseProcMap =+        Map.fromList [(p.name, p) | p <- si.program.procedures]+      extraProcMap = Map.fromList [(p.name, p) | p <- extraProcs]+      procMap = extraProcMap `Map.union` baseProcMap+  let evaluableMap = Map.fromList si.program.evaluables+  env <-+    initSessionEnv+      si.program.typeNames+      si.program.ruleNames+      procMap+      hc+      evaluableMap+      si.exportMap+      si.exportedSet+  runChr action env++-- | Like 'withCHRExtra' but also installs a trace handler so that the+-- interpreter emits 'TraceEvent's at each canonical ωr step (plus+-- function and host-call boundaries). Used by the REPL's @:trace@+-- one-shot dispatch. The handler is bound for the duration of the+-- action; the session and its mutable state are fresh, so no clear-up+-- on the way out is needed.+withCHRExtraTraced ::+  SessionInput ->+  HostCallRegistry ->+  [Procedure] ->+  TraceHandler ->+  Chr a ->+  IO a+withCHRExtraTraced si hc extraProcs handler action =+  withCHRExtra si hc extraProcs $ do+    env <- ask+    liftIO $ do+      writeIORef env.traceHandler (Just handler)+      writeIORef env.traceDepth 0+    action++-- | Install a trace handler around a 'Chr' action inside an existing+-- session, restoring the previous handler (and depth) on the way out+-- — including on exceptions. Used by the REPL's live-mode @:trace@+-- so that one query traces without affecting subsequent untraced+-- queries against the same persistent store.+withTraceHandler :: TraceHandler -> Chr a -> Chr a+withTraceHandler handler action = do+  env <- ask+  liftIO $ do+    prevHandler <- readIORef env.traceHandler+    prevDepth <- readIORef env.traceDepth+    bracket_+      ( do+          writeIORef env.traceHandler (Just handler)+          writeIORef env.traceDepth 0+      )+      ( do+          writeIORef env.traceHandler prevHandler+          writeIORef env.traceDepth prevDepth+      )+      (runChr action env)++-- | Add a constraint to the store. The constraint name can be+-- unqualified (resolved via the session's export map) or fully+-- qualified.+tellConstraint :: Types.Name -> [Value] -> Chr ()+tellConstraint name args = do+  SessionEnv {procMap, exportMap, exportedSet} <- ask+  let arity = length args+  resolved <- case resolveByExport exportMap exportedSet name arity of+    Left err -> runtimeErrorS err+    Right qname -> pure qname+  let tellName = tellProcName resolved arity+  pm <- liftIO (readIORef procMap)+  unless (Map.member tellName pm) $+    runtimeErrorS ("Constraint not found: " ++ T.unpack tellName.unName)+  _ <- callProc tellName (map CVal args)+  pure ()++-- | Name resolution against the export map and qualified-name set.+-- Used by 'tellConstraint' to canonicalize an unqualified constraint+-- name to its module-qualified form so the proc-map lookup matches.+resolveByExport ::+  Map Types.UnqualifiedIdentifier ExportResolution ->+  Set Types.QualifiedIdentifier ->+  Types.Name ->+  Int ->+  Either String Types.Name+resolveByExport expMap expSet name arity = case name of+  Types.Unqualified n ->+    case Map.lookup (Types.UnqualifiedIdentifier n arity) expMap of+      Just (UniqueExport qname) -> Right (Types.qualifiedToName qname)+      Just (AmbiguousExport ms) ->+        Left+          ( "Ambiguous constraint: "+              ++ T.unpack n+              ++ "/"+              ++ show arity+              ++ ", exported by: "+              ++ intercalate ", " (map T.unpack ms)+          )+      Nothing -> Left ("Unknown constraint: " ++ T.unpack n ++ "/" ++ show arity)+  Types.Qualified m n ->+    if Set.member (Types.QualifiedIdentifier m n arity) expSet+      then Right name+      else+        Left+          ( "Constraint not exported: "+              ++ T.unpack m+              ++ ":"+              ++ T.unpack n+              ++ "/"+              ++ show arity+          )
+ src/YCHR/Internal/Runtime/Store.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE OverloadedRecordDot #-}++-- | Constraint store for the CHR Haskell runtime.+--+-- Manages constraint suspensions: creation, storage, killing, liveness+-- checking, field access, and snapshot-based iteration. Integrates with+-- the observer/reactivation mechanism in "YCHR.Internal.Runtime.Var": when a+-- constraint is stored, it registers as an observer on its variable+-- arguments so that future unification triggers reactivation.+module YCHR.Internal.Runtime.Store+  ( -- * Types+    Suspension (..),++    -- * Operations+    createConstraint,+    storeConstraint,+    killConstraint,+    aliveConstraint,+    getConstraintArg,+    getConstraintType,+    idEqual,+    isConstraintType,+    getStoreSnapshot,+    getAllStoredConstraints,+    isSuspAlive,+    suspArg,+    lookupSusp,+  )+where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask)+import Data.IORef+import Data.IntMap.Strict qualified as IntMap+import Data.Sequence (Seq)+import Data.Sequence qualified as Seq+import YCHR.Internal.Runtime.Monad (Chr, SessionEnv (..))+import YCHR.Internal.Runtime.Types (Suspension (..), SuspensionId (..), Value (..))+import YCHR.Internal.Runtime.Var (addObserver)+import YCHR.Internal.Types (ConstraintType (..), Name)++-- ---------------------------------------------------------------------------+-- Operations+-- ---------------------------------------------------------------------------++-- | Look up a suspension by id. Calls 'error' on miss because every id+-- in circulation must have been allocated via 'createConstraint'; a miss+-- is a runtime invariant violation, not a user-facing failure.+lookupSusp :: SuspensionId -> Chr Suspension+lookupSusp (SuspensionId sid) = do+  SessionEnv {storeById} <- ask+  m <- liftIO $ readIORef storeById+  case IntMap.lookup sid m of+    Just s -> pure s+    Nothing -> error $ "lookupSusp: unknown SuspensionId " ++ show sid++-- | Allocate a new constraint suspension. The constraint is alive but+-- not yet in the type-indexed store. Use 'storeConstraint' to add it.+createConstraint :: ConstraintType -> [Value] -> Chr SuspensionId+createConstraint cType cArgs = do+  SessionEnv {storeNextId, storeById} <- ask+  sid <- liftIO $ do+    n <- readIORef storeNextId+    writeIORef storeNextId (n + 1)+    pure (SuspensionId n)+  aliveRef <- liftIO $ newIORef True+  let susp = Suspension sid cType cArgs aliveRef+  liftIO $ modifyIORef' storeById (IntMap.insert (let SuspensionId n = sid in n) susp)+  pure sid++-- | Add a constraint to the type-indexed store and register it as an+-- observer on each of its variable arguments.+storeConstraint :: SuspensionId -> Chr ()+storeConstraint sid = do+  susp <- lookupSusp sid+  SessionEnv {storeByType} <- ask+  let Suspension {suspType = ConstraintType idx, args = sargs} = susp+  liftIO $ modifyIORef' storeByType (IntMap.adjust (Seq.|> susp) idx)+  mapM_ (addObserver sid) sargs++-- | Kill a constraint (set alive to False).+killConstraint :: SuspensionId -> Chr ()+killConstraint sid = do+  Suspension {alive} <- lookupSusp sid+  liftIO $ writeIORef alive False++-- | Check if a constraint is still alive.+aliveConstraint :: SuspensionId -> Chr Bool+aliveConstraint sid = do+  Suspension {alive} <- lookupSusp sid+  liftIO $ readIORef alive++-- | Get a constraint argument by 0-based index.+getConstraintArg :: SuspensionId -> Int -> Chr Value+getConstraintArg sid idx = do+  Suspension {args = sargs} <- lookupSusp sid+  if idx >= 0 && idx < length sargs+    then pure (sargs !! idx)+    else error $ "getConstraintArg: index " ++ show idx ++ " out of bounds"++-- | Get the constraint type of a suspension.+getConstraintType :: SuspensionId -> Chr ConstraintType+getConstraintType sid = do+  Suspension {suspType} <- lookupSusp sid+  pure suspType++-- | Compare two suspension IDs for equality. Pure.+idEqual :: SuspensionId -> SuspensionId -> Bool+idEqual = (==)++-- | Check if a suspension has the given constraint type.+isConstraintType :: SuspensionId -> ConstraintType -> Chr Bool+isConstraintType sid cType = do+  t <- getConstraintType sid+  pure (t == cType)++-- | Get a snapshot of all suspensions of a given type. The returned+-- 'Seq' is an immutable snapshot: new constraints appended after this+-- call are invisible to the iterator.+getStoreSnapshot :: ConstraintType -> Chr (Seq Suspension)+getStoreSnapshot (ConstraintType idx) = do+  SessionEnv {storeByType} <- ask+  liftIO $ IntMap.findWithDefault Seq.empty idx <$> readIORef storeByType++-- | Return a snapshot of every constraint type in the store, paired with+-- its source name and the sequence of stored suspensions. Types are+-- returned in 'ConstraintType' index order. The returned 'Seq's are+-- immutable snapshots; callers still need to filter out dead suspensions+-- via 'isSuspAlive'.+getAllStoredConstraints :: Chr [(Name, Seq Suspension)]+getAllStoredConstraints = do+  SessionEnv {storeByType, storeTypeNames} <- ask+  storeMap <- liftIO (readIORef storeByType)+  pure+    [ (name, IntMap.findWithDefault Seq.empty i storeMap)+    | (i, name) <- IntMap.toAscList storeTypeNames+    ]++-- | Check if a suspension is alive by reading its IORef.+isSuspAlive :: Suspension -> Chr Bool+isSuspAlive Suspension {alive} = liftIO $ readIORef alive++-- | Get a suspension argument by 0-based index. Pure.+suspArg :: Suspension -> Int -> Value+suspArg Suspension {args = sargs} idx = sargs !! idx
+ src/YCHR/Internal/Runtime/Trace.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Tracing events for the Haskell interpreter.+--+-- The interpreter emits a 'TraceEvent' at each canonical point of the+-- refined operational semantics (ωr): activation of a constraint,+-- entry into an occurrence procedure, partner match, history hit,+-- rule fire, store, kill, reactivation, unification. It also emits+-- events for function calls, lambda calls, and host calls so the+-- whole picture — not just the CHR scheduling — is visible.+--+-- 'SessionEnv' carries a @Maybe (TraceEvent -> IO ())@ handler; when+-- @Nothing@, the cost of tracing is a single pointer test inside the+-- interpreter's emission helper. The REPL's @:trace@ command installs+-- 'defaultTraceHandler' for the duration of one query.+module YCHR.Internal.Runtime.Trace+  ( TraceEvent (..),+    TraceHandler,+    defaultTraceHandler,+    formatEvent,+  )+where++import Data.List (intercalate)+import Data.Text (Text)+import Data.Text qualified as T+import System.IO (Handle, hPutStrLn)+import YCHR.Internal.Pretty (prettyTerm)+import YCHR.Internal.Runtime.Types (SuspensionId (..))+import YCHR.Internal.Types (Term)++-- | Signature of a trace handler. Takes the current indentation depth+-- (managed by the interpreter) plus the event, and runs whatever+-- side-effect the consumer wants (typically formatting and writing to+-- a handle, but tests can capture events instead).+type TraceHandler = Int -> TraceEvent -> IO ()++-- | A single observable event during interpretation. The interpreter+-- constructs these only when tracing is on; pretty-printing lives in+-- the handler so different consumers can render differently.+data TraceEvent+  = -- | Entering @tell_c@. Carries the constraint type name and the+    -- (already-dereferenced) argument terms.+    TETell {ctype :: !Text, args :: ![Term]}+  | -- | Entering @activate_c@.+    TEActivate {ctype :: !Text, sid :: !SuspensionId, args :: ![Term]}+  | -- | Entering @occurrence_c_j@.+    TETryOccurrence {ctype :: !Text, occNum :: !Int, ruleName :: !Text}+  | -- | Partner constraint matched in a 'Foreach'.+    TEPartner {ctype :: !Text, sid :: !SuspensionId, args :: ![Term]}+  | -- | Propagation history rejected the candidate combination.+    TEHistoryHit {ruleName :: !Text, sids :: ![SuspensionId]}+  | -- | Rule fires. Emitted at 'AddHistory' for propagation rules;+    -- simplification rules without history also reach a unique+    -- @kill@/@store@ sequence so the absence is visible via depth.+    TEFire {ruleName :: !Text, sids :: ![SuspensionId]}+  | -- | A constraint is added to the store.+    TEStore {sid :: !SuspensionId, ctype :: !Text, args :: ![Term]}+  | -- | A constraint is removed from the store.+    TEKill {sid :: !SuspensionId}+  | -- | A constraint is being reactivated from the queue.+    TEReactivate {sid :: !SuspensionId, ctype :: !Text, args :: ![Term]}+  | -- | A successful 'BUnify'. Carries the two operand terms (as they+    -- looked before the unify) and the number of constraints that+    -- the runtime enqueued for reactivation as a result.+    TEUnify {lhs :: !Term, rhs :: !Term, reactivated :: !Int}+  | -- | Call into a user-defined function (or lifted lambda). For+    -- lambdas, @fname@ contains the synthesised @module:__lambda_N@+    -- name; the formatter renders these as @lambda#N@.+    TECallFunction {fname :: !Text, args :: ![Term]}+  | -- | Function or lambda returned the given value.+    TEReturn {value :: !Term}+  | -- | A host-language call (arithmetic, comparisons, prelude+    -- primitives, etc.). Emitted once per call with both inputs and+    -- result.+    TECallHost {hname :: !Text, args :: ![Term], result :: !Term}+  deriving (Show)++-- | The default trace handler: formats the event with two-space+-- indentation per level and writes a line to the given handle.+defaultTraceHandler :: Handle -> TraceHandler+defaultTraceHandler h depth ev = hPutStrLn h (formatEvent depth ev)++-- | Render a single event at the given depth. Pure, so callers can+-- format to any sink (tests use this directly).+formatEvent :: Int -> TraceEvent -> String+formatEvent depth ev = indent ++ body+  where+    indent = replicate (2 * depth) ' '+    body = case ev of+      TETell ct as ->+        "tell " ++ T.unpack ct ++ argList as+      TEActivate ct s as ->+        "activate " ++ showSid s ++ ": " ++ T.unpack ct ++ argList as+      TETryOccurrence ct n r ->+        "try occurrence " ++ T.unpack ct ++ " #" ++ show n ++ " (rule " ++ T.unpack r ++ ")"+      TEPartner ct s as ->+        "partner " ++ showSid s ++ ": " ++ T.unpack ct ++ argList as+      TEHistoryHit r ss ->+        "history hit " ++ T.unpack r ++ " " ++ sidList ss+      TEFire r ss ->+        "fire " ++ T.unpack r ++ " " ++ sidList ss+      TEStore s ct as ->+        "store " ++ showSid s ++ ": " ++ T.unpack ct ++ argList as+      TEKill s ->+        "kill " ++ showSid s+      TEReactivate s ct as ->+        "reactivate " ++ showSid s ++ ": " ++ T.unpack ct ++ argList as+      TEUnify l r n ->+        let suffix+              | n == 0 = ""+              | n == 1 = " (1 constraint reactivated)"+              | otherwise = " (" ++ show n ++ " constraints reactivated)"+         in "unify " ++ prettyTerm l ++ " = " ++ prettyTerm r ++ suffix+      TECallFunction f as ->+        "call " ++ T.unpack (renderFnName f) ++ argList as+      TEReturn v ->+        "return " ++ prettyTerm v+      TECallHost f as r ->+        "host call " ++ T.unpack f ++ argList as ++ " = " ++ prettyTerm r++argList :: [Term] -> String+argList [] = ""+argList ts = "(" ++ intercalate ", " (map prettyTerm ts) ++ ")"++sidList :: [SuspensionId] -> String+sidList ss = "[" ++ intercalate ", " (map showSid ss) ++ "]"++showSid :: SuspensionId -> String+showSid (SuspensionId i) = "c#" ++ show i++-- | Render a function name. Lifted lambdas are surfaced as+-- @lambda#N@ to match the user-facing language ("lambdas" rather than+-- "the synthesised @__lambda_N@ function").+renderFnName :: Text -> Text+renderFnName fname =+  case T.breakOn lambdaPrefix fname of+    (_, rest)+      | not (T.null rest) ->+          "lambda#" <> T.drop (T.length lambdaPrefix) rest+    _ -> fname+  where+    lambdaPrefix :: Text+    lambdaPrefix = "__lambda_"
+ src/YCHR/Internal/Runtime/Types.hs view
@@ -0,0 +1,76 @@+-- | Shared types for the CHR Haskell runtime.+module YCHR.Internal.Runtime.Types+  ( SuspensionId (..),+    VarId (..),+    Var (..),+    VarState (..),+    Value (..),+    CallVal (..),+    Suspension (..),+  )+where++import Data.IORef+import Data.Text (Text)+import YCHR.Internal.Types (ConstraintType)++-- | Unique identifier for a constraint suspension. Also serves as the+-- observer key on variables for selective reactivation.+newtype SuspensionId = SuspensionId Int+  deriving (Eq, Ord, Show)++-- | Unique identifier for a logical variable.+newtype VarId = VarId Int+  deriving (Eq, Ord, Show)++-- | A logical variable, backed by a mutable cell.+newtype Var = Var (IORef VarState)++-- | The state of a logical variable.+data VarState+  = -- | Not yet bound. Carries a unique ID and a list of observer IDs+    -- (constraints watching this variable for reactivation).+    Unbound !VarId ![SuspensionId]+  | -- | Bound to a value (possibly another variable, forming a chain).+    Bound !Value++-- | Runtime values that flow through the VM. Constraint identifiers+-- are a separate runtime kind ('SuspensionId'); they never inhabit+-- this type.+data Value+  = -- | A logical variable (possibly unbound, possibly bound).+    -- 'YCHR.Run.deref' follows the chain to what it stands for.+    VVar !Var+  | -- | Arbitrary-precision integer.+    VInt !Integer+  | -- | Floating-point number.+    VFloat !Double+  | -- | Atom: a symbolic constant. Zero-arity compounds collapse to+    -- this form at run time, unlike in the AST.+    VAtom !Text+  | -- | String.+    VText !Text+  | -- | Boolean. Guards and the prelude's comparisons produce these.+    VBool !Bool+  | -- | Compound term: functor and arguments.+    VTerm !Text ![Value]+  | -- | Wildcard: unifies with anything without binding.+    VWildcard++-- | Procedure-call argument at runtime. Procedures take a heterogeneous+-- mix of value and id parameters; this wrapper carries the kind across+-- the call boundary so the callee can bind each parameter into the right+-- environment slot. Mirrors 'YCHR.Internal.VM.Types.CallArg' on the IR side.+data CallVal+  = CVal !Value+  | CId !SuspensionId++-- | A constraint suspension in the store. The 'alive' flag is mutable so+-- that 'killConstraint' is O(1) and copies of the suspension obtained+-- before the kill see the updated state without an explicit lookup.+data Suspension = Suspension+  { suspId :: !SuspensionId,+    suspType :: !ConstraintType,+    args :: ![Value],+    alive :: !(IORef Bool)+  }
+ src/YCHR/Internal/Runtime/Var.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Logical variables, compound terms, unification, and equality.+--+-- This module provides the foundational layer of the CHR Haskell runtime:+-- mutable logical variables with binding chains, Prolog-style unification+-- (tell semantics) and equality checking (ask semantics), and compound+-- term construction and inspection.+--+-- Unification collects observer IDs from bound variables, enabling+-- selective constraint reactivation (per the paper, Section 5.3).+-- Path compression is applied during dereferencing to amortize+-- future lookups.+module YCHR.Internal.Runtime.Var+  ( -- * Types (re-exported from YCHR.Internal.Runtime.Types)+    VarId (..),+    Var (..),+    VarState (..),+    Value (..),++    -- * Operations+    newVar,+    deref,+    unify,+    unifiable,+    equal,+    makeTerm,+    matchTerm,+    getArg,+    addObserver,+    getVarId,+  )+where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask)+import Data.IORef+import Data.Text (Text)+import YCHR.Internal.Runtime.Monad (Chr, SessionEnv (..))+import YCHR.Internal.Runtime.Types+  ( SuspensionId,+    Value (..),+    Var (..),+    VarId (..),+    VarState (..),+  )++-- ---------------------------------------------------------------------------+-- Internal Unify primitives+-- ---------------------------------------------------------------------------++readVarState :: Var -> Chr VarState+readVarState (Var ref) = liftIO $ readIORef ref++writeVarState :: Var -> VarState -> Chr ()+writeVarState (Var ref) st = liftIO $ writeIORef ref st++newVarRef :: VarState -> Chr Var+newVarRef st = liftIO $ Var <$> newIORef st++freshVarId :: Chr VarId+freshVarId = do+  SessionEnv {varCounter} <- ask+  liftIO $ do+    vid@(VarId n) <- readIORef varCounter+    writeIORef varCounter (VarId (n + 1))+    pure vid++-- ---------------------------------------------------------------------------+-- Operations+-- ---------------------------------------------------------------------------++-- | Create a fresh unbound logical variable.+newVar :: Chr Value+newVar = do+  vid <- freshVarId+  v <- newVarRef (Unbound vid [])+  pure (VVar v)++-- | Follow binding chains to find the ultimate value, applying+-- path compression along the way. If the result is an unbound+-- variable, returns the 'VVar' wrapping it.+deref :: Value -> Chr Value+deref val@(VVar var@(Var ref)) = do+  st <- readVarState var+  case st of+    Unbound {} -> pure val+    Bound v -> do+      v' <- deref v+      case v' of+        VVar (Var ref')+          | ref == ref' -> pure ()+        _ -> writeVarState var (Bound v')+      pure v'+deref val = pure val++-- | Unify two values (tell semantics, Prolog @=@).+--+-- Returns @(success, observers)@: the boolean indicates whether+-- unification succeeded, and the list is the observer ids gathered+-- from every variable that was bound during the call. Callers+-- (typically the 'BUnify' interpretation in+-- "YCHR.Internal.Runtime.Interpreter") forward the observers to the+-- reactivation queue.+--+-- The observer list is meaningful even when @success@ is 'False':+-- 'unifyArgs' short-circuits on the first failing argument pair, but+-- variables bound by earlier pairs remain bound (we do not roll back),+-- and the observers from those bindings are still returned. Callers+-- must enqueue them so the half-committed bindings are followed up on.+unify :: Value -> Value -> Chr (Bool, [SuspensionId])+unify v1 v2 = do+  d1 <- deref v1+  d2 <- deref v2+  unify' d1 d2++unify' :: Value -> Value -> Chr (Bool, [SuspensionId])+unify' VWildcard _ = pure (True, [])+unify' _ VWildcard = pure (True, [])+unify' (VVar (Var ref1)) (VVar (Var ref2))+  | ref1 == ref2 = pure (True, [])+unify' (VVar var1) v2@(VVar var2) = do+  st1 <- readVarState var1+  case st1 of+    Bound {} -> error "unify': unexpected Bound after deref"+    Unbound _ obs1 -> do+      st2 <- readVarState var2+      case st2 of+        Unbound vid2 obs2 -> do+          writeVarState var1 (Bound v2)+          writeVarState var2 (Unbound vid2 (obs1 ++ obs2))+          pure (True, obs1)+        Bound {} -> error "unify': unexpected Bound after deref"+unify' (VVar var) v = do+  st <- readVarState var+  case st of+    Bound {} -> error "unify': unexpected Bound after deref"+    Unbound _ obs -> do+      writeVarState var (Bound v)+      pure (True, obs)+unify' v (VVar vr) = unify' (VVar vr) v+unify' (VInt a) (VInt b) = pure (a == b, [])+unify' (VFloat a) (VFloat b) = pure (a == b, [])+unify' (VAtom a) (VAtom b) = pure (a == b, [])+unify' (VText a) (VText b) = pure (a == b, [])+unify' (VBool a) (VBool b) = pure (a == b, [])+unify' (VTerm f1 args1) (VTerm f2 args2)+  | f1 == f2 && length args1 == length args2 = unifyArgs args1 args2+unify' _ _ = pure (False, [])++-- | Unify argument lists pairwise. Short-circuits on the first failure.+-- Observer lists from successful element unifications are concatenated.+unifyArgs :: [Value] -> [Value] -> Chr (Bool, [SuspensionId])+unifyArgs [] [] = pure (True, [])+unifyArgs (a : as) (b : bs) = do+  (ok, obs) <- unify a b+  if ok+    then do+      (ok', obs') <- unifyArgs as bs+      pure (ok', obs ++ obs')+    else pure (False, obs)+unifyArgs _ _ = pure (False, [])++-- | Check whether two values can be unified, without committing any+-- bindings. Returns 'True' iff 'unify' would succeed.+--+-- Mutations made to variable cells during the check are recorded on a+-- local trail and rolled back before returning, so the operation is+-- observably pure with respect to variable bindings. Path compression+-- performed by 'deref' is preserved (it is semantically invisible).+-- Observer lists are never modified.+unifiable :: Value -> Value -> Chr Bool+unifiable a b = do+  trailRef <- liftIO $ newIORef []+  result <- uni trailRef a b+  liftIO $ do+    entries <- readIORef trailRef+    -- Entries are prepended newest-first, so walking front-to-back+    -- restores each cell to its oldest captured state.+    mapM_ (\(Var ref, st) -> writeIORef ref st) entries+  pure result+  where+    trailWrite trailRef var@(Var ref) newSt = liftIO $ do+      cur <- readIORef ref+      modifyIORef' trailRef ((var, cur) :)+      writeIORef ref newSt++    uni trailRef v1 v2 = do+      d1 <- deref v1+      d2 <- deref v2+      uni' trailRef d1 d2++    uni' _ VWildcard _ = pure True+    uni' _ _ VWildcard = pure True+    uni' _ (VVar (Var ref1)) (VVar (Var ref2))+      | ref1 == ref2 = pure True+    uni' trailRef (VVar var1) v2@(VVar _) = do+      st1 <- readVarState var1+      case st1 of+        Bound {} -> error "unifiable: unexpected Bound after deref"+        Unbound _ _ -> do+          trailWrite trailRef var1 (Bound v2)+          pure True+    uni' trailRef (VVar var) v = do+      st <- readVarState var+      case st of+        Bound {} -> error "unifiable: unexpected Bound after deref"+        Unbound _ _ -> do+          trailWrite trailRef var (Bound v)+          pure True+    uni' trailRef v (VVar vr) = uni' trailRef (VVar vr) v+    uni' _ (VInt x) (VInt y) = pure (x == y)+    uni' _ (VFloat x) (VFloat y) = pure (x == y)+    uni' _ (VAtom x) (VAtom y) = pure (x == y)+    uni' _ (VText x) (VText y) = pure (x == y)+    uni' _ (VBool x) (VBool y) = pure (x == y)+    uni' trailRef (VTerm f1 args1) (VTerm f2 args2)+      | f1 == f2 && length args1 == length args2 = uniArgs trailRef args1 args2+    uni' _ _ _ = pure False++    uniArgs _ [] [] = pure True+    uniArgs trailRef (x : xs) (y : ys) = do+      ok <- uni trailRef x y+      if ok then uniArgs trailRef xs ys else pure False+    uniArgs _ _ _ = pure False++-- | Check equality of two values (ask semantics, Prolog @==@).+--+-- No mutation beyond path compression during dereferencing.+-- Two distinct unbound variables are /not/ equal.+equal :: Value -> Value -> Chr Bool+equal v1 v2 = do+  d1 <- deref v1+  d2 <- deref v2+  equal' d1 d2++equal' :: Value -> Value -> Chr Bool+equal' (VVar (Var ref1)) (VVar (Var ref2)) = pure (ref1 == ref2)+equal' (VVar _) _ = pure False+equal' _ (VVar _) = pure False+equal' (VInt a) (VInt b) = pure (a == b)+equal' (VFloat a) (VFloat b) = pure (a == b)+equal' (VAtom a) (VAtom b) = pure (a == b)+equal' (VText a) (VText b) = pure (a == b)+equal' (VBool a) (VBool b) = pure (a == b)+equal' (VTerm f1 args1) (VTerm f2 args2)+  | f1 == f2 && length args1 == length args2 = allEqual args1 args2+equal' _ _ = pure False++allEqual :: [Value] -> [Value] -> Chr Bool+allEqual [] [] = pure True+allEqual (a : as) (b : bs) = do+  ok <- equal a b+  if ok then allEqual as bs else pure False+allEqual _ _ = pure False++-- | Construct a compound term. Pure.+makeTerm :: Text -> [Value] -> Value+makeTerm = VTerm++-- | Check whether a value is a compound term with the given functor and+-- arity. Dereferences first. 0-arity compounds collapse to 'VAtom' at+-- the runtime layer, so a 'VAtom' matches when @arity == 0@ and its+-- name matches @functor@.+matchTerm :: Value -> Text -> Int -> Chr Bool+matchTerm v functor arity = do+  d <- deref v+  case d of+    VAtom a -> pure (arity == 0 && a == functor)+    VTerm f args -> pure (f == functor && length args == arity)+    _ -> pure False++-- | Extract an argument from a compound term by 0-based index.+-- Dereferences first. Raises an error if the value is not a term+-- or the index is out of bounds.+getArg :: Value -> Int -> Chr Value+getArg v idx = do+  d <- deref v+  case d of+    VTerm _ args+      | idx >= 0 && idx < length args -> pure (args !! idx)+      | otherwise -> error $ "getArg: index " ++ show idx ++ " out of bounds"+    _ -> error "getArg: not a compound term"++-- | Register an observer on every unbound variable reachable from a+-- value. A bare unbound variable is registered directly; a compound+-- term is traversed so that variables nested inside its arguments+-- (e.g. the @X@ in @pair(X, 1)@ or @[X, X]@) are observed too. Without+-- the recursion a constraint stored with such an argument would never+-- be reactivated when the nested variable is later bound, missing an+-- ωr /Reactivate/ step. Anything else (already bound, or a non-variable+-- leaf) is a no-op.+addObserver :: SuspensionId -> Value -> Chr ()+addObserver oid v = do+  d <- deref v+  case d of+    VVar var -> do+      st <- readVarState var+      case st of+        Unbound vid obs -> writeVarState var (Unbound vid (oid : obs))+        Bound {} -> pure ()+    VTerm _ args -> mapM_ (addObserver oid) args+    _ -> pure ()++-- | Extract the 'VarId' of an unbound variable after dereferencing.+-- Returns 'Nothing' if the value is not an unbound variable.+getVarId :: Value -> Chr (Maybe VarId)+getVarId v = do+  d <- deref v+  case d of+    VVar var -> do+      st <- readVarState var+      case st of+        Unbound vid _ -> pure (Just vid)+        Bound {} -> pure Nothing+    _ -> pure Nothing
+ src/YCHR/Internal/SExpr.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Generic s-expression type with printer and parser.+--+-- The s-expression grammar:+--+-- @+-- sexpr  = atom | int | float | string | list+-- atom   = [a-zA-Z_][a-zA-Z0-9_-]*+-- int    = [-]?[0-9]++-- float  = [-]?[0-9]+\.[0-9]+([eE][-+]?[0-9]+)?+-- string = '"' (escape | [^"\\])* '"'+-- list   = '(' sexpr* ')'+-- @+--+-- Line comments start with @;@ and extend to end of line.+module YCHR.Internal.SExpr+  ( SExpr (..),+    printSExpr,+    parseSExpr,+  )+where++import Data.Char (isAlpha, isAlphaNum)+import Data.Text (Text)+import Data.Text qualified as T+import Text.Parsec (Parsec, between, choice, eof, many, parse, try)+import Text.Parsec qualified as P+import Text.Parsec.Char (char, satisfy)+import Text.Parsec.Text ()+import Text.Read (readMaybe)+import YCHR.Internal.Parsing.Lexer+  ( charLiteral,+    skipLineComment,+    space,+    space1,+  )++-- | A generic s-expression.+data SExpr+  = -- | Unquoted identifier (e.g. @let@, @create-constraint@).+    SAtom Text+  | -- | Integer literal (arbitrary precision).+    SInt Integer+  | -- | Floating-point literal.+    SFloat Double+  | -- | Double-quoted string literal.+    SString Text+  | -- | Parenthesised list of sub-expressions.+    SList [SExpr]+  deriving (Show, Eq)++-- ---------------------------------------------------------------------------+-- Printer+-- ---------------------------------------------------------------------------++-- | Render an s-expression as 'Text'.  The output is single-line; use+-- 'printSExprPretty' (not yet implemented) for indented multi-line output.+printSExpr :: SExpr -> Text+printSExpr (SAtom t) = t+printSExpr (SInt n) = T.pack (show n)+printSExpr (SFloat n) =+  let s = show n+   in T.pack (if '.' `elem` s then s else s ++ ".0")+printSExpr (SString t) = "\"" <> escapeString t <> "\""+printSExpr (SList xs) = "(" <> T.intercalate " " (map printSExpr xs) <> ")"++escapeString :: Text -> Text+escapeString = T.concatMap esc+  where+    esc '\\' = "\\\\"+    esc '"' = "\\\""+    esc '\n' = "\\n"+    esc '\t' = "\\t"+    esc c = T.singleton c++-- ---------------------------------------------------------------------------+-- Parser+-- ---------------------------------------------------------------------------++type Parser = Parsec Text ()++-- | Parse a single s-expression from 'Text'.+parseSExpr :: Text -> Either String SExpr+parseSExpr input = case parse (sc *> pSExpr <* eof) "<sexpr>" input of+  Left err -> Left (show err)+  Right s -> Right s++-- | Parse a single s-expression, consuming trailing whitespace.+pSExpr :: Parser SExpr+pSExpr = choice [pList, pString, pAtomOrInt] <* sc++pList :: Parser SExpr+pList = SList <$> between (char '(' *> sc) (char ')') (many pSExpr)++pString :: Parser SExpr+pString = SString . T.pack <$> (char '"' *> P.manyTill charLiteral (try (char '"')))++pAtomOrInt :: Parser SExpr+pAtomOrInt = do+  tok <- T.pack <$> P.many1 (satisfy isAtomChar)+  pure $ case readInt tok of+    Just n -> SInt n+    Nothing+      | T.any (== '.') tok, Just f <- readMaybe (T.unpack tok) -> SFloat f+      | otherwise -> SAtom tok++readInt :: Text -> Maybe Integer+readInt t = case T.uncons t of+  Just ('-', rest)+    | not (T.null rest), T.all isDigit rest -> Just (negate (read (T.unpack rest)))+  Just (c, _)+    | isDigit c, T.all isDigit t -> Just (read (T.unpack t))+  _ -> Nothing+  where+    isDigit c = c >= '0' && c <= '9'++-- | A token character. Includes @.@ to support float literals; tokens+-- containing @.@ are dispatched to 'SFloat' if they parse as a Double.+isAtomChar :: Char -> Bool+isAtomChar c = isAlphaNum c || c == '_' || c == '-' || c == '.'++-- | Whitespace consumer (spaces + line comments starting with @;@).+sc :: Parser ()+sc = space space1 (skipLineComment ";")++-- | Check if the first character is valid for an atom start.+_isAtomStart :: Char -> Bool+_isAtomStart c = isAlpha c || c == '_'
+ src/YCHR/Internal/StdLib.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Standard library loading.+--+-- The @libraries\/@ directory ships a small set of @.chr@ files+-- (@prelude@, @lists@, @strings@, @meta@) that every user+-- program may import via @:- use_module(library(...))@. The sources+-- are embedded into the binary at compile time via+-- 'YCHR.Internal.StdLib.TH.embeddedStdLibSources'; 'stdlib' parses them on+-- first demand.+module YCHR.Internal.StdLib+  ( -- * Pure API+    StdLibError (..),+    parseStdLib,++    -- * Default value (parsed lazily on first demand)+    stdlib,+  )+where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import System.FilePath (dropExtension, takeFileName)+import YCHR.Internal.Parsed (Module)+import YCHR.Internal.Parser+  ( ModuleHeader (..),+    OpTable,+    builtinOps,+    collectModuleHeader,+    mergeOps,+    parseModuleWith,+  )+import YCHR.Internal.StdLib.TH (embeddedStdLibSources)++-- | Errors that can arise while parsing the standard library.+data StdLibError+  = -- | A library source failed to parse. Carries the file path and+    -- the rendered parser error.+    StdLibParseError FilePath String+  | -- | A library header could not be collected (first-pass parse).+    StdLibHeaderError FilePath String+  | -- | Two libraries declared conflicting operators.+    StdLibOpConflict Text+  | -- | A library produced post-parse validation errors.+    StdLibValidationError FilePath String+  deriving (Show)++-- | Parse a list of @(path, source)@ pairs as the standard library.+-- Pure: any IO required to get the sources is the caller's problem.+parseStdLib :: [(FilePath, Text)] -> Either StdLibError (Map Text Module)+parseStdLib sources = do+  hdrs <-+    traverse+      ( \(fp, src) -> case collectModuleHeader fp src of+          Left e -> Left (StdLibHeaderError fp (show e))+          Right h -> Right h+      )+      sources+  let allOps = concatMap (.exportOps) hdrs+  table <- case mergeOps builtinOps allOps of+    Left conflict -> Left (StdLibOpConflict conflict)+    Right t -> Right t+  entries <- mapM (parseLib table) sources+  pure (Map.fromList entries)++parseLib :: OpTable -> (FilePath, Text) -> Either StdLibError (Text, Module)+parseLib table (path, src) =+  let name = T.pack (dropExtension (takeFileName path))+   in case parseModuleWith table path src of+        Left e -> Left (StdLibParseError path (show e))+        Right (m, errs)+          | not (null errs) -> Left (StdLibValidationError path (show errs))+          | otherwise -> Right (name, m)++-- | The default standard library, parsed once on first demand from+-- the sources embedded at compile time by 'embeddedStdLibSources'.+stdlib :: Map Text Module+stdlib = case parseStdLib $(embeddedStdLibSources) of+  Right m -> m+  Left err -> error ("Failed to parse embedded standard library: " ++ show err)
+ src/YCHR/Internal/StdLib/TH.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Compile-time embedding of the standard library sources.+--+-- The @libraries/*.chr@ files are read by GHC at build time and+-- spliced into 'YCHR.Internal.StdLib' as a list of @(path, source)@ pairs.+-- The resulting binary is self-contained: no runtime directory+-- lookup, no @YCHR_LIB_DIR@ env var, no cwd-relative path.+--+-- 'addDependentFile' registers each embedded file with GHC's+-- recompilation tracking. In practice cabal's higher-level cache+-- may not consult those registrations, so editing or adding a+-- @.chr@ in @libraries\/@ does not reliably trigger a rebuild;+-- @cabal clean@ or touching this module's source is the safe+-- recipe during development.+module YCHR.Internal.StdLib.TH (embeddedStdLibSources) where++import Data.Text (Text)+import Data.Text.IO qualified as TIO+import Language.Haskell.TH (Exp, Q)+import Language.Haskell.TH.Syntax (addDependentFile, lift, runIO)+import System.Directory (listDirectory)+import System.FilePath (takeExtension, (</>))++-- | Splice yielding @[(FilePath, Text)]@: every @libraries\/*.chr@+-- file paired with its UTF-8 contents.+embeddedStdLibSources :: Q Exp+embeddedStdLibSources = do+  -- Resolved relative to the package root (GHC runs splices with the+  -- cabal package directory as cwd).+  let dir = "libraries"+  files <- runIO (filter ((== ".chr") . takeExtension) <$> listDirectory dir)+  pairs <- mapM (readOne dir) files+  lift (pairs :: [(FilePath, Text)])+  where+    readOne dir f = do+      let path = dir </> f+      addDependentFile path+      contents <- runIO (TIO.readFile path)+      pure (path, contents)
+ src/YCHR/Internal/TypeCheck.hs view
@@ -0,0 +1,1657 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Haskell driver for the YCHR type checker.+--+-- Walks the desugared AST and feeds constraints into a CHR session+-- running the pre-compiled type-checker program. The type checker+-- catches type inconsistencies statically, while remaining optional:+-- programs without type annotations are accepted without errors.+--+-- == @tc_unify@ argument order invariant+--+-- The CHR-side @tc_unify(T1, T2, Ctx)@ rules are asymmetric in how+-- they handle @any@: when @any@ appears on the left, it succeeds+-- without binding the right side (which may be a type parameter that+-- should stay open). When @any@ appears on the right and the left is+-- a var, the var is bound to @any@. The discipline is therefore:+-- source-variable type on the LEFT, declared type on the RIGHT.+--+-- The driver enforces this indirectly: every source-vs-declared+-- meeting is routed through @check_constraint_use@,+-- @check_function_use@, or @check_constructor_use@, and the CHR rules+-- for those constraints produce @tc_unify@ calls in the correct+-- order. Direct @check_unify@ calls from the driver only happen+-- between two source-variable types (body @X = Y@, body @X is e@,+-- guard @X = Y@), where the ordering is irrelevant.+module YCHR.Internal.TypeCheck+  ( TypeCheckError (..),+    typeCheckProgram,+    typeCheckGoals,+  )+where++import Control.Monad (foldM, replicateM, when, zipWithM_)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)+import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, put)+import Data.List qualified as List+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import YCHR.Internal.Compile.Names (vmName)+import YCHR.Internal.Constructors (buildConAlias, buildConMap)+import YCHR.Internal.Desugared qualified as D+import YCHR.Internal.Diagnostic (Diagnostic (..))+import YCHR.Internal.PExpr (PExpr (Atom))+import YCHR.Internal.Parsed (AnnP (..), SourceLoc (..))+import YCHR.Internal.Resolved qualified as R+import YCHR.Internal.Runtime.Interpreter (baseHostCallRegistry)+import YCHR.Internal.Runtime.Monad (Chr)+import YCHR.Internal.Runtime.Registry (fromValueList, valueList)+import YCHR.Internal.Runtime.Session (tellConstraint, withCHR)+import YCHR.Internal.Runtime.Types (Value (..))+import YCHR.Internal.Runtime.Var (deref, newVar)+import YCHR.Internal.TypeCheck.Compiled (typeCheckerProgram)+import YCHR.Internal.TypeCheck.Error (TypeCheckError (..))+import YCHR.Internal.Types+  ( BoundSig (..),+    DataConstructor (..),+    HeadArg (..),+    Name (..),+    Term (..),+    TypeDefinition (..),+    TypeExpr (..),+    flattenName,+    headArgToTerm,+    headConstraintToConstraint,+    typeConstructors,+  )+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM qualified as VM++-- | Flatten a 'Name' to the same single-atom form used by the runtime+-- (see 'YCHR.Internal.Compile.Names.vmName'). Required so CHR-side constraints+-- emitted from this Haskell driver match what compiled CHR rules+-- produce after the renamer canonicalizes data-constructor names.+runtimeName :: Name -> Text+runtimeName name = let VM.Name t = vmName name in t++-- | Runtime functor name of a constructor declared in the+-- @'$typechecker'@ module — base types (@int@), record/tag+-- constructors (@sig@), and compound shapes (@tcon@, @fun@) alike.+-- The renamer canonicalizes such names to @$typechecker:<n>@; the+-- runtime functor symbol is the flattened form @$typechecker__<n>@.+-- Used as the functor argument of 'VTerm' values this Haskell driver+-- builds, of any arity.+tcAtom :: Text -> Text+tcAtom n = "$typechecker__" <> n++-- | A 0-arity declared constructor of the @'$typechecker'@ module+-- (@int@, @float@, @string@, @any@) as a runtime 'Value'. 0-arity+-- compounds collapse to 'VAtom' at the runtime layer; 'BMatchTerm'+-- accepts 'VAtom' for arity-0 dispatch, so this matches the shape+-- compiled head patterns produce.+tcCon0 :: Text -> Value+tcCon0 n = VAtom (tcAtom n)++-- ---------------------------------------------------------------------------+-- Type-check environment and context+-- ---------------------------------------------------------------------------++-- | Program-wide immutable environment, shared via 'Reader'.+data TypeCheckEnv = TypeCheckEnv+  { -- | Map from constructor name to its parent type definition and constructor info.+    conMap :: Map Name (TypeDefinition, DataConstructor),+    -- | Resolves a use-site unqualified name to its declaration's qualified+    -- name when exactly one constructor matches. Constructors are name-only+    -- in YCHR's type system (arity is not part of their identity), so this+    -- is keyed by name alone — wrong-arity uses are diagnosed separately by+    -- 'validateConstructorArities'. Ambiguous names (declared in more than+    -- one module) are omitted so the canonicalization falls through and the+    -- lookup behaves as if the name were unknown.+    conAlias :: Map Text Name,+    -- | Declared bounds for every bounded @:- chr_constraint@. Used+    -- by 'checkRule' to allocate per-head-occurrence ambient+    -- signatures and emit the head-occurrence bound checks+    -- (§Bounded constraints §Use sites).+    constraintBoundsEnv :: Map Types.QualifiedName [BoundSig],+    -- | Declared argument types for every @:- chr_constraint@ —+    -- the same data 'tellConstraintSigs' tells to the CHR program.+    -- Pulled in here so 'checkRule' can encode a bounded+    -- constraint's primary signature against the same σ as its+    -- ambient signatures.+    constraintTypesEnv :: Map Types.QualifiedName [TypeExpr]+  }++-- | Per-rule or per-equation checking context, passed explicitly+-- because it changes at each scope boundary.+data CheckCtx = CheckCtx+  { -- | Maps source variable names to fresh type variables (Values).+    varTypes :: Map Text Value,+    -- | Human-readable label for error messages (e.g., "rule trans").+    label :: Maybe Text,+    -- | Source location of the current AST section.+    loc :: SourceLoc,+    -- | Original PExpr for the current AST section.+    origin :: PExpr,+    -- | Ambient signatures contributed by the enclosing bounded+    -- declarations. Keyed by the runtime name of the bound's target+    -- function. Each entry is the list of @sig(args, ret)@ values+    -- visible at every call site in this scope; the list has one+    -- entry per relevant bound currently active. Empty for code+    -- outside any bounded scope.+    --+    -- A call to a function whose name appears in this map is emitted+    -- as @check_function_use_with_ambient@; calls to other functions+    -- use the ordinary @check_function_use@ path. See the CHR+    -- @check_with_ambient_*@ rules in+    -- @typechecker\/typechecker.chr@.+    ambientSigs :: Map Text [Value]+  }++-- | Detect data constructors declared in more than one type definition.+-- Two constructors collide when they share a 'Qualified m n' after+-- renaming, regardless of arity (the type checker keys constructor+-- lookups on name only — see 'buildConMap' and the CHR-side+-- @delegate_guard_getarg@ / @constructor_match@ rules in+-- @typechecker/typechecker.chr@). Without this check, 'Map.fromList'+-- in 'buildConMap' would silently drop the earlier declaration.+detectDuplicateConstructors :: [TypeDefinition] -> [Diagnostic TypeCheckError]+detectDuplicateConstructors tds =+  [ Diagnostic+      Nothing+      ( AnnP+          (DuplicateConstructor (flattenName name) (map dropLoc sortedByLoc))+          firstLoc+          (Atom firstTypeName)+      )+  | (name, decls) <- Map.toList grouped,+    length decls > 1,+    let sortedByLoc = List.sortOn (\(_, _, l) -> (l.file, l.line, l.col)) decls,+    (firstTypeName, _, firstLoc) : _ <- [sortedByLoc]+  ]+  where+    dropLoc (tn, ar, _) = (tn, ar)+    grouped =+      Map.fromListWith+        (++)+        [ (dc.conName, [(flattenName td.name, length dc.conArgs, td.loc)])+        | td <- tds,+          dc <- typeConstructors td+        ]++-- | Map a use-site constructor name to its declared, qualified form when a+-- unique match exists. 'Qualified' names pass through unchanged;+-- 'Unqualified' names are resolved through 'conAlias'. When no unique+-- match exists the name is returned as-is.+canonicalizeConName :: TypeCheckEnv -> Name -> Name+canonicalizeConName _ name@(Qualified _ _) = name+canonicalizeConName env (Unqualified n) =+  Map.findWithDefault (Unqualified n) n env.conAlias++-- | True when @name@ is a known data constructor and its declared arity+-- matches @useArity@. Wrong-arity uses are diagnosed by+-- 'validateConstructorArities'; this predicate gates the @check_constructor_use@+-- emissions so we don't pile a spurious tcon mismatch on top of the+-- arity-mismatch error.+knownConstructorWithArity :: TypeCheckEnv -> Name -> Int -> Bool+knownConstructorWithArity env name useArity =+  case Map.lookup name env.conMap of+    Just (_, dc) -> length dc.conArgs == useArity+    Nothing -> False++-- | Source-location info recovered from a CHR-side @Ctx@ handle.+data CtxInfo = CtxInfo+  { label :: Maybe Text,+    loc :: SourceLoc,+    origin :: PExpr+  }++-- | Opaque handle into 'CtxMap'. Travels through the CHR program as+-- the @Ctx@ argument of every @check_*@ constraint and comes back in+-- 'decodeError' to recover the originating source location. Lives in+-- its own newtype so it cannot be confused with 'ScopeId' (they are+-- both small integers in different namespaces).+newtype CtxHandle = CtxHandle Int+  deriving (Eq, Ord)++-- | Materialize a 'CtxHandle' as the 'Value' the CHR program sees.+ctxHandleValue :: CtxHandle -> Value+ctxHandleValue (CtxHandle n) = VInt (fromIntegral n)++-- | Ambient-signature scope id. Each bounded scope (a bounded+-- function's equation or a rule with a bounded head constraint) gets+-- its own; @active_scope@ / @end_scope@ pair up by this id so the+-- right ambient signatures are torn down.+newtype ScopeId = ScopeId Int+  deriving (Eq, Ord)++-- | Materialize a 'ScopeId' as the 'Value' the CHR program sees.+scopeIdValue :: ScopeId -> Value+scopeIdValue (ScopeId n) = VInt (fromIntegral n)++-- | Map from 'CtxHandle' to the originating source location.+type CtxMap = Map CtxHandle CtxInfo++-- | Holds the source-location info for every allocated 'CtxHandle'+-- together with separate counters for 'ScopeId's and rigid-type-var+-- ids. Threaded as a single 'State' effect so all counters and the+-- location map stay in step.+data CtxStore = CtxStore+  { nextCtxHandle :: !CtxHandle,+    ctxMap :: !CtxMap,+    nextScopeId :: !ScopeId,+    -- | Fresh-id counter for rigid type variables. Each rigid tvar+    -- is encoded as the runtime term @rigid(N)@ where @N@ is a+    -- globally unique integer from this counter; distinct rigid+    -- identities therefore never accidentally unify.+    nextRigidId :: !Int+  }++emptyCtxStore :: CtxStore+emptyCtxStore =+  CtxStore+    { nextCtxHandle = CtxHandle 0,+      ctxMap = Map.empty,+      nextScopeId = ScopeId 0,+      nextRigidId = 0+    }++-- | Internal monad of the type-check driver: a 'ReaderT' carrying the+-- program-wide environment over a 'StateT' for the context store,+-- both sitting above the 'Chr' session monad.+type TC = ReaderT TypeCheckEnv (StateT CtxStore Chr)++-- | Lift a 'Chr' action into 'TC'.+chrOp :: Chr a -> TC a+chrOp = lift . lift++-- | Read the context store.+getStore :: TC CtxStore+getStore = lift get++-- | Replace the context store.+putStore :: CtxStore -> TC ()+putStore = lift . put++-- | Allocate a fresh ambient-sig 'ScopeId'.+freshScopeId :: TC ScopeId+freshScopeId = do+  store <- getStore+  let ScopeId n = store.nextScopeId+  putStore store {nextScopeId = ScopeId (n + 1)}+  pure (ScopeId n)++-- | Allocate a fresh rigid type variable. Distinct allocations get+-- distinct identities; the only way two rigid tvars unify is if+-- they share the same identity (typically via the same entry in a+-- @tvars@ map shared between the declaration's parameter encoding+-- and its ambient bound signatures).+freshRigidTypeVar :: TC Value+freshRigidTypeVar = do+  store <- getStore+  let n = store.nextRigidId+  putStore store {nextRigidId = n + 1}+  pure (VTerm (tcAtom "rigid") [VInt (fromIntegral n)])++-- | Allocate fresh rigid type variables for each unique type variable+-- name. Mirrors 'freshTypeVarsForDecl' but uses rigid identities;+-- intended for a polymorphic function's own equation-body scope, where+-- the enclosing tvars must enforce a structural match (so calls to+-- overloaded operations at those tvars fail without a covering+-- @requiring@ clause).+--+-- Lives in 'TC' rather than 'Chr' because the rigid-id counter is in+-- 'CtxStore' (the @StateT@ layer); 'freshTypeVarsForDecl' has no such+-- counter so it can live in 'Chr' directly.+freshRigidTypeVarsForDecl :: [Text] -> TC (Map Text Value)+freshRigidTypeVarsForDecl vars = do+  let unique = Set.toList (Set.fromList vars)+  pairs <- mapM (\v -> (v,) <$> freshRigidTypeVar) unique+  pure (Map.fromList pairs)++-- ---------------------------------------------------------------------------+-- Main entry point+-- ---------------------------------------------------------------------------++-- | Type-check a desugared program.+--+-- Returns a list of diagnostics for every type inconsistency found.+-- An empty list means the program is well-typed (or has no type+-- annotations — unannotated programs are accepted without errors+-- because missing types default to @any@).+--+-- Type errors prevent compilation from proceeding; the caller is+-- responsible for aborting when the list is non-empty.+typeCheckProgram :: D.Program -> IO [Diagnostic TypeCheckError]+typeCheckProgram prog = do+  let conMap = buildConMap prog.typeDefinitions+      conAlias = buildConAlias prog.typeDefinitions+      -- Haskell-side validation+      env =+        TypeCheckEnv+          { conMap,+            conAlias,+            constraintBoundsEnv = prog.constraintBounds,+            constraintTypesEnv = prog.constraintTypes+          }+      hsErrors =+        validateTypeDefinitions+          prog.typeDefinitions+          ( Map.fromList+              [ ( td.name,+                  td+                )+              | td <- prog.typeDefinitions+              ]+          )+          ++ detectDuplicateConstructors prog.typeDefinitions+          ++ validateConstructorArities env prog+  chrErrors <-+    withCHR typeCheckerProgram baseHostCallRegistry $+      evalStateT+        ( runReaderT+            ( do+                -- Initialize error accumulator+                chrOp (tellConstraint (Qualified "$typechecker" "errors") [valueList []])+                -- Tell environment: constraint, function, and constructor signatures+                tellConstraintSigs prog+                tellFunctionSigs prog+                tellConSigs prog+                -- Check each rule and function equation+                mapM_ checkRule prog.rules+                mapM_ checkFunction prog.functions+                -- Collect errors from the CHR session+                collectErrors+            )+            env+        )+        emptyCtxStore+  pure (hsErrors ++ chrErrors)++-- | Type-check a list of body goals (a query or single goal) against+-- the signatures of an already-compiled program.+--+-- Mirrors 'typeCheckProgram' but skips Haskell-side validations that+-- only make sense on a whole program (no new type definitions or+-- constructors are introduced by a goal). Variables are gathered once+-- across the whole goal list so a name shared between goals refers to+-- the same type slot — matching how rule bodies are checked.+--+-- Pass the desugared program whose signatures should be in scope. For+-- queries that introduce lifted lambdas, extend @prog.functions@ with+-- those lambdas before calling so their (default-@any@) signatures are+-- visible to @check_function_use@.+typeCheckGoals ::+  D.Program ->+  SourceLoc ->+  Maybe Text ->+  [D.BodyGoal] ->+  IO [Diagnostic TypeCheckError]+typeCheckGoals prog loc lbl goals = do+  let conMap = buildConMap prog.typeDefinitions+      conAlias = buildConAlias prog.typeDefinitions+      env =+        TypeCheckEnv+          { conMap,+            conAlias,+            constraintBoundsEnv = prog.constraintBounds,+            constraintTypesEnv = prog.constraintTypes+          }+  withCHR typeCheckerProgram baseHostCallRegistry $+    evalStateT+      ( runReaderT+          ( do+              chrOp (tellConstraint (Qualified "$typechecker" "errors") [valueList []])+              tellConstraintSigs prog+              tellFunctionSigs prog+              tellConSigs prog+              let allVarNames = foldMap collectVarsInBodyGoal goals+              varTypes <-+                Map.fromList+                  <$> mapM (\v -> (v,) <$> chrOp newVar) (Set.toList allVarNames)+              let cctx =+                    CheckCtx+                      { varTypes,+                        label = lbl,+                        loc,+                        origin = Atom "",+                        ambientSigs = Map.empty+                      }+              mapM_ (checkBodyGoal cctx) goals+              collectErrors+          )+          env+      )+      emptyCtxStore++-- ---------------------------------------------------------------------------+-- Context helpers+-- ---------------------------------------------------------------------------++-- | Allocate a fresh 'CtxHandle' and store the current 'CheckCtx''s+-- source-location info in 'CtxMap' under it. The handle travels+-- through the CHR program as the @Ctx@ argument of every @check_*@+-- constraint (materialised via 'ctxHandleValue'); on error decoding+-- we look it back up to recover the source location for the+-- diagnostic.+freshCtxHandle :: CheckCtx -> TC CtxHandle+freshCtxHandle cctx = do+  store <- getStore+  let CtxHandle n = store.nextCtxHandle+      handle = CtxHandle n+      info = CtxInfo {label = cctx.label, loc = cctx.loc, origin = cctx.origin}+  putStore+    store+      { nextCtxHandle = CtxHandle (n + 1),+        ctxMap = Map.insert handle info store.ctxMap+      }+  pure handle++-- ---------------------------------------------------------------------------+-- Environment setup+-- ---------------------------------------------------------------------------++-- | Tell @constraint_sig@ for every declared constraint. Bounded+-- constraints additionally emit @constraint_bounds@ using the SAME+-- shared type-variable map so a single @copy_term@ at the use site+-- freshens both the argument types and the bound signatures+-- consistently.+tellConstraintSigs :: D.Program -> TC ()+tellConstraintSigs prog =+  Map.foldlWithKey'+    ( \m name argTypes ->+        m >> do+          let bounds = Map.findWithDefault [] name prog.constraintBounds+              allVars = collectTypeVars argTypes ++ concatMap boundSigVars bounds+          tvars <- chrOp (freshTypeVarsForDecl allVars)+          encodedArgs <- chrOp (traverse (encodeTypeExpr tvars) argTypes)+          let runtimeNm = runtimeName (Types.qualifiedToName name)+          chrOp $+            tellConstraint+              (Qualified "$typechecker" "constraint_sig")+              [VAtom runtimeNm, valueList encodedArgs]+          case bounds of+            [] -> pure ()+            _ -> do+              encodedBounds <- chrOp (traverse (encodeNamedBound tvars) bounds)+              chrOp $+                tellConstraint+                  (Qualified "$typechecker" "constraint_bounds")+                  [VAtom runtimeNm, valueList encodedBounds]+    )+    (pure ())+    prog.constraintTypes++-- | Tell @function_sig@ or @function_sigs@ for every declared+-- function. Bounded single-sig functions additionally emit+-- @function_bounds@ using a shared type-variable map so a single+-- @copy_term@ at the use site freshens the signature and the+-- bound signatures consistently (see+-- 'YCHR.Internal.Types.BoundSig' and the @bounded_function_match@ rule).+tellFunctionSigs :: D.Program -> TC ()+tellFunctionSigs prog = mapM_ tellOne prog.functions+  where+    tellOne f =+      let fName = Types.qualifiedToName f.name+          runtimeNm = runtimeName fName+       in case (f.signatures, f.requiring) of+            ([], _) -> do+              -- No annotations: default to all-any. Bounded functions+              -- always have one signature (the resolver guarantees+              -- this), so a missing signature implies no bounds.+              let anyArgs = replicate f.arity (tcCon0 "any")+                  sig = VTerm (tcAtom "sig") [valueList anyArgs, tcCon0 "any"]+              chrOp $+                tellConstraint+                  (Qualified "$typechecker" "function_sig")+                  [VAtom runtimeNm, sig]+            ([s], bounds@(_ : _)) -> do+              let (argTys, retTy) = s+                  allVars =+                    collectTypeVars argTys+                      ++ collectTypeVarsExpr retTy+                      ++ concatMap boundSigVars bounds+              tvars <- chrOp (freshTypeVarsForDecl allVars)+              encodedArgs <- chrOp (traverse (encodeTypeExpr tvars) argTys)+              encodedRet <- chrOp (encodeTypeExpr tvars retTy)+              let sig = VTerm (tcAtom "sig") [valueList encodedArgs, encodedRet]+              encodedBounds <- chrOp (traverse (encodeNamedBound tvars) bounds)+              chrOp $+                tellConstraint+                  (Qualified "$typechecker" "function_sig")+                  [VAtom runtimeNm, sig]+              chrOp $+                tellConstraint+                  (Qualified "$typechecker" "function_bounds")+                  [VAtom runtimeNm, valueList encodedBounds]+            ([s], []) -> do+              sig <- chrOp (encodeFunctionSig s)+              chrOp $+                tellConstraint+                  (Qualified "$typechecker" "function_sig")+                  [VAtom runtimeNm, sig]+            (ss, _) -> do+              sigs <- chrOp (traverse encodeFunctionSig ss)+              chrOp $+                tellConstraint+                  (Qualified "$typechecker" "function_sigs")+                  [VAtom runtimeNm, valueList sigs]++-- | Encode one declared @(arg-types, return-type)@ pair as a runtime+-- @sig(args, ret)@ value, allocating fresh logical variables for the+-- type variables shared between the args and the return.+encodeFunctionSig :: ([TypeExpr], TypeExpr) -> Chr Value+encodeFunctionSig (argTys, retTy) = do+  tvars <- freshTypeVarsForDecl (collectTypeVars argTys ++ collectTypeVarsExpr retTy)+  encodedArgs <- traverse (encodeTypeExpr tvars) argTys+  encodedRet <- encodeTypeExpr tvars retTy+  pure (VTerm (tcAtom "sig") [valueList encodedArgs, encodedRet])++-- | Encode a single 'BoundSig' against a shared type-variable map+-- as a runtime @nbound(GName, args, ret)@ value (the flat shape+-- expected by the CHR-side @bound_named@ algebraic type). The+-- shared map is essential: every bound on the same declaration uses+-- the same logical variables for the declaration's type parameters,+-- so a single @copy_term@ at the call site freshens them+-- consistently across signature and bounds.+encodeNamedBound :: Map Text Value -> BoundSig -> Chr Value+encodeNamedBound tvars bs = do+  encodedArgs <- traverse (encodeTypeExpr tvars) bs.argTypes+  encodedRet <- encodeTypeExpr tvars bs.returnType+  pure+    ( VTerm+        (tcAtom "nbound")+        [VAtom (runtimeName bs.name), valueList encodedArgs, encodedRet]+    )++-- | Collect every type variable mentioned in a 'BoundSig'.+boundSigVars :: BoundSig -> [Text]+boundSigVars bs = collectTypeVars bs.argTypes ++ collectTypeVarsExpr bs.returnType++tellConSigs :: D.Program -> TC ()+tellConSigs prog =+  mapM_+    ( \td ->+        mapM_+          ( \dc -> do+              let allVars = td.typeVars+              tvars <- chrOp (freshTypeVarsForDecl allVars)+              let parentType = encodeTCon tvars td.name td.typeVars+              encodedFields <- chrOp (traverse (encodeTypeExpr tvars) dc.conArgs)+              let sig = VTerm (tcAtom "sig") [parentType, valueList encodedFields]+              chrOp $+                tellConstraint+                  (Qualified "$typechecker" "con_sig")+                  [ VAtom+                      ( runtimeName+                          dc.conName+                      ),+                    sig+                  ]+          )+          (typeConstructors td)+    )+    prog.typeDefinitions++-- | Encode a 'Name' as a runtime 'Value', matching the runtime+-- representation produced by 'YCHR.Internal.Compile.compileTerm' for declared+-- constructors: every name becomes a 'VAtom' with the @vmName@+-- encoding (@m__n@ for qualified, plain @n@ for unqualified).+-- 'BMatchTerm' accepts 'VAtom' for arity-0 dispatch, matching the+-- shape compiled head patterns produce.+encodeName :: Name -> Value+encodeName (Unqualified n) = VAtom n+encodeName name@(Qualified _ _) = VAtom (runtimeName name)++-- | Encode a type constructor application: tcon(name, [arg1, arg2, ...])+encodeTCon :: Map Text Value -> Name -> [Text] -> Value+encodeTCon tvars name vars =+  VTerm+    (tcAtom "tcon")+    [ encodeName name,+      valueList (map (\v -> Map.findWithDefault (tcCon0 "any") v tvars) vars)+    ]++-- ---------------------------------------------------------------------------+-- Type encoding+-- ---------------------------------------------------------------------------++-- | Collect type variable names from a list of type expressions.+collectTypeVars :: [TypeExpr] -> [Text]+collectTypeVars = concatMap collectTypeVarsExpr++collectTypeVarsExpr :: TypeExpr -> [Text]+collectTypeVarsExpr (TypeVar v) = [v]+collectTypeVarsExpr (TypeCon _ args) = concatMap collectTypeVarsExpr args++-- | Create fresh logical variables for each unique type variable name.+freshTypeVarsForDecl :: [Text] -> Chr (Map Text Value)+freshTypeVarsForDecl vars = do+  let unique = Set.toList (Set.fromList vars)+  pairs <- mapM (\v -> (v,) <$> newVar) unique+  pure (Map.fromList pairs)++-- | Encode a TypeExpr as a runtime Value.+encodeTypeExpr :: Map Text Value -> TypeExpr -> Chr Value+encodeTypeExpr tvars (TypeVar v) =+  case Map.lookup v tvars of+    Just val -> pure val+    Nothing -> pure (tcCon0 "any")+encodeTypeExpr _ (TypeCon (Unqualified "int") []) = pure (tcCon0 "int")+encodeTypeExpr _ (TypeCon (Unqualified "float") []) = pure (tcCon0 "float")+encodeTypeExpr _ (TypeCon (Unqualified "string") []) = pure (tcCon0 "string")+encodeTypeExpr _ (TypeCon (Unqualified "any") []) = pure (tcCon0 "any")+-- Function type: fun(A, B) -> C is parsed as TypeCon "->" [TypeCon "fun" [A, B], C]+encodeTypeExpr+  tvars+  ( TypeCon+      (Unqualified "->")+      [ TypeCon (Unqualified "fun") argTys,+        retTy+        ]+    ) = do+    encodedArgs <- traverse (encodeTypeExpr tvars) argTys+    encodedRet <- encodeTypeExpr tvars retTy+    pure (VTerm (tcAtom "fun") [valueList encodedArgs, encodedRet])+encodeTypeExpr tvars (TypeCon name args) = do+  encodedArgs <- traverse (encodeTypeExpr tvars) args+  pure (VTerm (tcAtom "tcon") [encodeName name, valueList encodedArgs])++-- ---------------------------------------------------------------------------+-- Per-rule checking+-- ---------------------------------------------------------------------------++checkRule :: D.Rule -> TC ()+checkRule rule = do+  env <- ask+  let allVarNames = collectVarsInRule rule+  varTypes <- Map.fromList <$> mapM (\v -> (v,) <$> chrOp newVar) (Set.toList allVarNames)+  let ruleLabel = fmap (\n -> "rule " <> n) rule.name+      AnnP hd headLoc headOrigin = rule.head+      AnnP guards guardLoc guardOrigin = rule.guard+      AnnP body bodyLoc bodyOrigin = rule.body+      headCtx0 =+        CheckCtx+          { varTypes,+            label = ruleLabel,+            loc = headLoc,+            origin = headOrigin,+            ambientSigs = Map.empty+          }+      headConstraints = hd.kept ++ hd.removed+      hasBoundedHead =+        any+          (\hc -> Map.member hc.name env.constraintBoundsEnv)+          headConstraints+  -- Allocate this rule's ambient-sig scope id. Unused when no+  -- bounded constraint sits in the head, but allocating eagerly is+  -- cheap and avoids carrying a "no-scope" sentinel through+  -- 'checkHeadConstraint'.+  scopeId <- freshScopeId+  -- Walk each head constraint. For bounded constraints, allocate a+  -- fresh σ for this head occurrence (per §Use sites: each+  -- occurrence's type variables are freshly allocated even when the+  -- same bounded constraint appears twice) and emit ambient sigs ++  -- bound-discharge residuals. For unbounded constraints, fall+  -- through to the ordinary check.+  ambientPerName <-+    fmap (Map.unionsWith (++)) $+      traverse (checkHeadConstraint headCtx0 scopeId env) headConstraints+  -- Activate the scope so the CHR-side ambient_sig entries are+  -- visible to the body's checks. Skip when there are no bounds:+  -- emitting active_scope with no ambient_sig would still be sound+  -- but pollutes the constraint store.+  when hasBoundedHead $+    chrOp $+      tellConstraint+        (Qualified "$typechecker" "active_scope")+        [scopeIdValue scopeId]+  let guardCtx =+        CheckCtx+          { varTypes,+            label = ruleLabel,+            loc = guardLoc,+            origin = guardOrigin,+            ambientSigs = ambientPerName+          }+      bodyCtx =+        CheckCtx+          { varTypes,+            label = ruleLabel,+            loc = bodyLoc,+            origin = bodyOrigin,+            ambientSigs = ambientPerName+          }+  checkGuards guardCtx guards+  mapM_ (checkBodyGoal bodyCtx) body+  when hasBoundedHead $+    chrOp $+      tellConstraint+        (Qualified "$typechecker" "end_scope")+        [scopeIdValue scopeId]++-- | Check one head constraint occurrence. Returns the ambient sigs+-- this occurrence contributes (empty for unbounded constraints).+--+-- Constraint head occurrences use *flexible* tvars per occurrence,+-- not rigid. The reason is intra-rule type sharing: a rule like+-- @trans @@ leq(X, Y), leq(Y, Z) ==> leq(X, Z).@ over a polymorphic+-- @:- chr_constraint leq(T, T).@ relies on the type variables in+-- the two head occurrences being unifiable. Rigid tvars (distinct+-- identities per occurrence) would reject this idiom. Per the spec+-- §Use sites "each occurrence's type variables are freshly+-- allocated"; under flexible σ "fresh" just means a new+-- unification variable that can later unify with another fresh+-- one. The function-equation soundness gap rigidity closes+-- (§Soundness) does not apply at rule heads: rule bodies are not+-- the "implementation" of the constraint declaration in the way+-- that function equations are the implementation of a function.+checkHeadConstraint ::+  CheckCtx ->+  ScopeId ->+  TypeCheckEnv ->+  D.HeadConstraint ->+  TC (Map Text [Value])+checkHeadConstraint cctx scopeId env hc =+  case Map.lookup hc.name env.constraintBoundsEnv of+    Nothing -> do+      checkConstraintUse cctx (headConstraintToConstraint hc)+      pure Map.empty+    Just bounds -> do+      let argTypes = Map.findWithDefault [] hc.name env.constraintTypesEnv+          allVars = collectTypeVars argTypes ++ concatMap boundSigVars bounds+      tvars <- chrOp (freshTypeVarsForDecl allVars)+      encodedDeclArgs <- chrOp (traverse (encodeTypeExpr tvars) argTypes)+      headArgValues <- traverse (typeOfTerm cctx . headArgToTerm) hc.args+      ctx <- freshCtxHandle cctx+      zipWithM_ (tellCheckUnify ctx) headArgValues encodedDeclArgs+      ambEntries <- traverse (emitAmbientAndBound scopeId ctx tvars) bounds+      pure (Map.fromListWith (++) ambEntries)++-- | Emit a @check_unify(t1, t2, ctx)@ constraint. The argument order+-- matches the CHR rule: source-variable type first, declared type+-- second. See the @tc_unify@ argument-order note in the module+-- header.+tellCheckUnify :: CtxHandle -> Value -> Value -> TC ()+tellCheckUnify ctx t1 t2 =+  chrOp $+    tellConstraint+      (Qualified "$typechecker" "check_unify")+      [t1, t2, ctxHandleValue ctx]++-- | Encode one bound, tell its @ambient_sig@ (for in-scope calls to+-- the bound's named function) and a @check_bound@ residual (for the+-- spec's head-occurrence discharge rule). Returns the @(runtimeName,+-- [sigValue])@ entry the caller folds into the rule's ambient-sigs+-- map so 'CheckCtx.ambientSigs' carries the same data the CHR-side+-- 'check_function_use_with_ambient' rule needs.+emitAmbientAndBound ::+  ScopeId ->+  CtxHandle ->+  Map Text Value ->+  BoundSig ->+  TC (Text, [Value])+emitAmbientAndBound scopeId ctx tvars bs = do+  encodedArgs <- chrOp (traverse (encodeTypeExpr tvars) bs.argTypes)+  encodedRet <- chrOp (encodeTypeExpr tvars bs.returnType)+  let sigVal = VTerm (tcAtom "sig") [valueList encodedArgs, encodedRet]+      runtimeNm = runtimeName bs.name+  chrOp $+    tellConstraint+      (Qualified "$typechecker" "ambient_sig")+      [scopeIdValue scopeId, VAtom runtimeNm, sigVal]+  chrOp $+    tellConstraint+      (Qualified "$typechecker" "check_bound")+      [VAtom runtimeNm, valueList encodedArgs, encodedRet, ctxHandleValue ctx]+  pure (runtimeNm, [sigVal])++-- | Head-side constraint use: the arguments are still 'Term' patterns+-- (they reached the typechecker through 'headConstraintToConstraint').+-- Goes through @check_constraint_use@ which @copy_term@s the stored+-- declared sig, allocating fresh flexible tvars per use — so two+-- head occurrences of a polymorphic constraint in the same rule get+-- their own flex σ that can later unify when a body goal forces it.+checkConstraintUse :: CheckCtx -> Types.QualifiedConstraint -> TC ()+checkConstraintUse cctx c = do+  argTypeVars <- traverse (typeOfTerm cctx) c.args+  emitConstraintUse cctx c.name argTypeVars++-- | Tell-side constraint use: arguments are 'Expr's and are evaluated+-- like any other expression position.+checkConstraintTell :: CheckCtx -> Types.QualifiedName -> [D.Expr] -> TC ()+checkConstraintTell cctx qn args = do+  argTypeVars <- traverse (typeOfExpr cctx) args+  emitConstraintUse cctx qn argTypeVars++emitConstraintUse :: CheckCtx -> Types.QualifiedName -> [Value] -> TC ()+emitConstraintUse cctx qn argTypeVars = do+  ctx <- freshCtxHandle cctx+  chrOp $+    tellConstraint+      (Qualified "$typechecker" "check_constraint_use")+      [ VAtom (runtimeName (Types.qualifiedToName qn)),+        valueList argTypeVars,+        ctxHandleValue ctx+      ]++-- ---------------------------------------------------------------------------+-- Guard checking+-- ---------------------------------------------------------------------------++-- | Process a guard list left-to-right, threading the canonicalized+-- constructor name from each 'D.GuardMatch' into any 'D.GuardGetArg's+-- that follow on the same term. Per 'docs/reference/type-system.md' (Desugared+-- guards / HNF synthetic guards), a @GuardGetArg@ always follows a+-- @GuardMatch@ on the same term — the match establishes which+-- constructor's field types to use, which the get-arg then needs to+-- resolve a field index.+checkGuards :: CheckCtx -> [D.Guard] -> TC ()+checkGuards cctx = go Nothing+  where+    go _ [] = pure ()+    go lastConName (g : gs) = do+      newLastCon <- checkGuard cctx lastConName g+      go newLastCon gs++checkGuard :: CheckCtx -> Maybe Name -> D.Guard -> TC (Maybe Name)+checkGuard cctx lastConName (D.GuardEqual e1 e2) = do+  tv1 <- typeOfExpr cctx e1+  tv2 <- typeOfExpr cctx e2+  ctx <- freshCtxHandle cctx+  tellCheckUnify ctx tv1 tv2+  pure lastConName+checkGuard cctx _ (D.GuardMatch operand conName arity) = do+  env <- ask+  let canonical = canonicalizeConName env conName+  when (knownConstructorWithArity env canonical arity) $ do+    operandType <- typeOfExpr cctx operand+    argTypeVars <- chrOp (replicateM arity newVar)+    ctx <- freshCtxHandle cctx+    chrOp $+      tellConstraint+        (Qualified "$typechecker" "check_constructor_use")+        [ VAtom (runtimeName canonical),+          valueList argTypeVars,+          operandType,+          ctxHandleValue ctx+        ]+  pure (Just canonical)+checkGuard cctx lastConName (D.GuardGetArg varName operand idx) = do+  resultTypeVar <- chrOp (varType cctx varName)+  conName <- case lastConName of+    Just cn -> pure cn+    Nothing -> pure (Unqualified varName)+  env <- ask+  let withinArity =+        case Map.lookup conName env.conMap of+          Just (_, dc) -> idx < length dc.conArgs+          Nothing -> True+  when withinArity $ do+    operandType <- typeOfExpr cctx operand+    ctx <- freshCtxHandle cctx+    chrOp $+      tellConstraint+        (Qualified "$typechecker" "check_guard_getarg")+        [ resultTypeVar,+          operandType,+          VAtom (runtimeName conName),+          VInt (fromIntegral idx),+          ctxHandleValue ctx+        ]+  pure lastConName+checkGuard cctx _ (D.GuardExpr expr) = do+  tv <- typeOfExpr cctx expr+  ctx <- freshCtxHandle cctx+  chrOp $+    tellConstraint+      (Qualified "$typechecker" "check_guard_bool")+      [tv, ctxHandleValue ctx]+  pure Nothing++-- ---------------------------------------------------------------------------+-- Body goal checking+-- ---------------------------------------------------------------------------++checkBodyGoal :: CheckCtx -> D.BodyGoal -> TC ()+checkBodyGoal _ D.BodyTrue = pure ()+checkBodyGoal cctx (D.BodyTell qn args) =+  checkConstraintTell cctx qn args+checkBodyGoal cctx (D.BodyUnify e1 e2) = do+  tv1 <- typeOfExpr cctx e1+  tv2 <- typeOfExpr cctx e2+  ctx <- freshCtxHandle cctx+  tellCheckUnify ctx tv1 tv2+checkBodyGoal cctx (D.BodyIs v expr) = do+  vType <- chrOp (varType cctx v)+  exprType <- typeOfExpr cctx expr+  ctx <- freshCtxHandle cctx+  tellCheckUnify ctx vType exprType+checkBodyGoal cctx (D.BodyCall qn args) = do+  argTypeVars <- traverse (typeOfExpr cctx) args+  retTypeVar <- chrOp newVar+  emitFunctionCall cctx (Types.qualifiedToName qn) argTypeVars retTypeVar+checkBodyGoal cctx (D.BodyApply f args) = do+  _ <- typeOfExpr cctx f+  mapM_ (typeOfExpr cctx) args+checkBodyGoal cctx (D.BodyHostStmt _ args) =+  mapM_ (typeOfExpr cctx) args++-- | Type-check a function-body prelude statement and return a 'CheckCtx'+-- to use for the remainder of the body. A 'FunIs' binding allocates a+-- /fresh/ type slot for the bound variable (mirroring the runtime's+-- lexical shadowing — 'compileFunStmt' emits 'LetVal', not unification),+-- so subsequent statements and the return expression see the new slot.+-- The RHS itself is typed against the previous slot, so @N is N + 1@+-- with N captured from an outer scope still type-checks against the+-- outer N's type.+checkFunStmt :: CheckCtx -> D.FunStmt -> TC CheckCtx+checkFunStmt cctx (D.FunIs v expr) = do+  exprType <- typeOfExpr cctx expr+  newSlot <- chrOp newVar+  ctx <- freshCtxHandle cctx+  tellCheckUnify ctx newSlot exprType+  pure cctx {varTypes = Map.insert v newSlot cctx.varTypes}+checkFunStmt cctx (D.FunHostStmt _ args) = do+  mapM_ (typeOfExpr cctx) args+  pure cctx+checkFunStmt cctx (D.FunCall qn args) = do+  argTypeVars <- traverse (typeOfExpr cctx) args+  retTypeVar <- chrOp newVar+  emitFunctionCall cctx (Types.qualifiedToName qn) argTypeVars retTypeVar+  pure cctx+checkFunStmt cctx (D.FunApply f args) = do+  _ <- typeOfExpr cctx f+  mapM_ (typeOfExpr cctx) args+  pure cctx++checkFunStmts :: CheckCtx -> [D.FunStmt] -> TC CheckCtx+checkFunStmts = foldM checkFunStmt++-- | Emit a function-call type check. Routes through+-- @check_function_use_with_ambient@ when the call's target name has+-- ambient signatures in the current 'CheckCtx' (i.e. the call sits+-- inside a bounded function's equation or under a bounded+-- constraint's head occurrence in a rule). Otherwise falls back to+-- the plain @check_function_use@ path. The CHR side handles both+-- forms with the same overload-resolution mechanism.+emitFunctionCall ::+  CheckCtx ->+  Name ->+  [Value] ->+  Value ->+  TC ()+emitFunctionCall cctx name argTypeVars retTypeVar = do+  ctx <- freshCtxHandle cctx+  let runtimeFname = runtimeName name+      ctxVal = ctxHandleValue ctx+  case Map.lookup runtimeFname cctx.ambientSigs of+    Just ambs@(_ : _) ->+      chrOp $+        tellConstraint+          (Qualified "$typechecker" "check_function_use_with_ambient")+          [ VAtom runtimeFname,+            valueList ambs,+            valueList argTypeVars,+            retTypeVar,+            ctxVal+          ]+    _ ->+      chrOp $+        tellConstraint+          (Qualified "$typechecker" "check_function_use")+          [ VAtom runtimeFname,+            valueList argTypeVars,+            retTypeVar,+            ctxVal+          ]++-- ---------------------------------------------------------------------------+-- Per-equation checking+-- ---------------------------------------------------------------------------++checkFunction :: D.Function -> TC ()+checkFunction func = do+  let AnnP eqs eqLoc eqOrigin = func.equations+  mapM_ (checkEquation func eqLoc eqOrigin) eqs++checkEquation ::+  D.Function ->+  SourceLoc ->+  PExpr ->+  D.Equation ->+  TC ()+checkEquation func loc origin eq = do+  let allVarNames = collectVarsInEq eq+  varTypes <- Map.fromList <$> mapM (\v -> (v,) <$> chrOp newVar) (Set.toList allVarNames)+  case (func.signatures, func.requiring) of+    ([], _) -> do+      let cctx = freshCheckCtx varTypes Map.empty+      checkGuards cctx eq.guards+    -- Single-sig (bounded or unbounded): allocate the function's+    -- declared tvars as rigid for this equation. Calls inside the+    -- body that target the rigid tvars must resolve through ambient+    -- signatures contributed by a `requiring` clause; without a+    -- matching clause, an overloaded operator at the tvar fails+    -- with @no_matching_overload@. Empty @bounds@ is fine — it just+    -- means no ambient signatures are emitted.+    ([sig], bounds) -> checkSingleSigEquation func sig bounds varTypes eq+    -- Multi-sig (class) equations stay on the flexible path:+    -- @check_function_use@ runs overload resolution against the+    -- declared sigs and any of them that matches makes the equation+    -- accepted. Rigid tvars would conflict with that semantics+    -- (every sig is a separate candidate, not a single parametric+    -- shape). `:- class` with `requiring` is rejected upstream as+    -- @RequiringOnClass@, so this branch never sees a class with+    -- bounds.+    (_, _) -> do+      let cctx = freshCheckCtx varTypes Map.empty+      argTypeVars <- traverse (typeOfTerm cctx . headArgToTerm) eq.params+      cctx' <- checkFunStmts cctx eq.prelude+      retTypeVar <- typeOfExpr cctx' eq.rhs+      ctx <- freshCtxHandle cctx'+      chrOp $+        tellConstraint+          (Qualified "$typechecker" "check_function_use")+          [ VAtom (runtimeName (Types.qualifiedToName func.name)),+            valueList argTypeVars,+            retTypeVar,+            ctxHandleValue ctx+          ]+      checkGuards cctx eq.guards+  where+    freshCheckCtx vt ambs =+      CheckCtx+        { varTypes = vt,+          label = Just ("function " <> flattenName (Types.qualifiedToName func.name)),+          loc,+          origin,+          ambientSigs = ambs+        }++-- | Check an equation of a single-signature function (bounded or+-- unbounded). Allocates the function's declared type variables as+-- *rigid* identities, shared between the equation's parameter types,+-- RHS type, and any ambient signatures contributed by a @requiring@+-- clause. The rigid identity is what makes the spec's "the ambient+-- signature's type variables share identity with the enclosing+-- function's declared type variables" property hold: a call to a+-- bound-named function inside the equation that resolves through the+-- ambient sig stays polymorphic in T, because T is the SAME rigid+-- term the equation parameters' types are bound to. Rigidity also+-- closes the soundness gap for /unbounded/ polymorphic functions:+-- @foo(T, T) -> bool@ with body @X > Y@ now fails to type-check+-- (no_matching_overload on @>@), because there is no ambient sig and+-- no declared sig of @>@ is consistent with the rigid @T@.+checkSingleSigEquation ::+  D.Function ->+  ([TypeExpr], TypeExpr) ->+  [BoundSig] ->+  Map Text Value ->+  D.Equation ->+  TC ()+checkSingleSigEquation func (argTys, retTy) bounds varTypes eq = do+  let allVars =+        collectTypeVars argTys+          ++ collectTypeVarsExpr retTy+          ++ concatMap boundSigVars bounds+  tvars <- freshRigidTypeVarsForDecl allVars+  encodedArgs <- chrOp (traverse (encodeTypeExpr tvars) argTys)+  encodedRet <- chrOp (encodeTypeExpr tvars retTy)+  scopeId <- freshScopeId+  let AnnP _ eqLoc eqOrigin = func.equations+  let baseCtx =+        CheckCtx+          { varTypes,+            label = Just ("function " <> flattenName (Types.qualifiedToName func.name)),+            loc = eqLoc,+            origin = eqOrigin,+            ambientSigs = Map.empty+          }+  ctx <- freshCtxHandle baseCtx+  ambEntries <-+    traverse (emitAmbientAndBound scopeId ctx tvars) bounds+  let ambMap = Map.fromListWith (++) ambEntries+      cctx = baseCtx {ambientSigs = ambMap}+      hasBounds = not (null bounds)+  -- Skip the @active_scope@ / @end_scope@ pair when there are no+  -- bounds: with no ambient sigs to scope, emitting them would just+  -- pollute the constraint store. Mirrors the same gate in 'checkRule'.+  when hasBounds $+    chrOp $+      tellConstraint+        (Qualified "$typechecker" "active_scope")+        [scopeIdValue scopeId]+  paramTypes <- traverse (typeOfTerm cctx . headArgToTerm) eq.params+  zipWithM_ (tellCheckUnify ctx) paramTypes encodedArgs+  cctx' <- checkFunStmts cctx eq.prelude+  rhsType <- typeOfExpr cctx' eq.rhs+  tellCheckUnify ctx rhsType encodedRet+  checkGuards cctx eq.guards+  when hasBounds $+    chrOp $+      tellConstraint+        (Qualified "$typechecker" "end_scope")+        [scopeIdValue scopeId]++-- ---------------------------------------------------------------------------+-- Term typing+-- ---------------------------------------------------------------------------++-- | Look up a source variable's pre-allocated type slot.+-- 'collectVarsInRule' / 'collectVarsInEq' walk the same nodes that+-- 'typeOfTerm' / @checkGuard@ / @checkBodyGoal@ visit, so every+-- variable has an entry in 'CheckCtx.varTypes' before type checking+-- begins. A missing entry signals a broken invariant in the desugarer+-- or the variable collector.+varType :: CheckCtx -> Text -> Chr Value+varType cctx v = case Map.lookup v cctx.varTypes of+  Just val -> pure val+  Nothing -> error ("TypeCheck.varType: missing var slot for " <> T.unpack v)++-- | Type a 'Term' at a value position. Used for the 'Term'-typed slots+-- the desugared AST still carries: head occurrence arguments and the+-- 'GuardMatch' / 'GuardGetArg' operand of head normal-form guards.+-- Every 'CompoundTerm' is treated as a data-constructor application —+-- call vs constructor disambiguation has been moved upstream into the+-- 'D.Expr' AST.+typeOfTerm :: CheckCtx -> Term -> TC Value+typeOfTerm cctx (VarTerm v) = chrOp (varType cctx v)+typeOfTerm _ (IntTerm _) = pure (tcCon0 "int")+typeOfTerm _ (FloatTerm _) = pure (tcCon0 "float")+typeOfTerm _ (TextTerm _) = pure (tcCon0 "string")+typeOfTerm _ Wildcard = chrOp newVar+typeOfTerm cctx (CompoundTerm name args) =+  typeOfTermCtor cctx name args++-- | Type a 'Term'-shaped constructor application. Used for the+-- 'Term'-typed positions that the desugared AST still carries: head+-- arguments (via 'headArgToTerm').+--+-- Head/equation patterns are unevaluated: a compound whose head+-- happens to name a declared function is still a literal term in+-- pattern position, never a call. We therefore treat every compound+-- as a constructor application here. Calls inside expression positions+-- are handled structurally by 'typeOfExpr' against 'R.CallExpr'.+typeOfTermCtor :: CheckCtx -> Name -> [Term] -> TC Value+typeOfTermCtor cctx name args = do+  env <- ask+  let arity = length args+      canonical = canonicalizeConName env name+  if knownConstructorWithArity env canonical arity+    then do+      argTypes <- traverse (typeOfTerm cctx) args+      resultType <- chrOp newVar+      ctx <- freshCtxHandle cctx+      chrOp $+        tellConstraint+          (Qualified "$typechecker" "check_constructor_use")+          [ VAtom (runtimeName canonical),+            valueList argTypes,+            resultType,+            ctxHandleValue ctx+          ]+      pure resultType+    else do+      mapM_ (typeOfTerm cctx) args+      pure (tcCon0 "any")++-- | Type an expression. Each 'D.Expr' constructor maps to a specific+-- typechecker query; the call-vs-constructor split is structural here,+-- replacing the legacy @typeOfCompound@'s @funSet@ membership test.+typeOfExpr :: CheckCtx -> D.Expr -> TC Value+typeOfExpr cctx e = case e of+  R.VarExpr v -> chrOp (varType cctx v)+  R.IntExpr _ -> pure (tcCon0 "int")+  R.FloatExpr _ -> pure (tcCon0 "float")+  R.TextExpr _ -> pure (tcCon0 "string")+  R.WildcardExpr -> chrOp newVar+  R.CtorExpr name args -> typeOfExprCtor cctx name args+  R.CallExpr qn args -> do+    argTypes <- traverse (typeOfExpr cctx) args+    resultType <- chrOp newVar+    emitFunctionCall cctx (Types.qualifiedToName qn) argTypes resultType+    pure resultType+  R.ApplyExpr f args -> do+    _ <- typeOfExpr cctx f+    mapM_ (typeOfExpr cctx) args+    pure (tcCon0 "any")+  R.HostExpr _ args -> do+    mapM_ (typeOfExpr cctx) args+    pure (tcCon0 "any")+  R.FunRefExpr qn arity -> do+    argTypeVars <- chrOp (replicateM arity newVar)+    retTypeVar <- chrOp newVar+    emitFunctionCall cctx (Types.qualifiedToName qn) argTypeVars retTypeVar+    pure (VTerm (tcAtom "fun") [valueList argTypeVars, retTypeVar])+  R.LambdaExpr params body -> do+    paramTypeVars <- traverse (typeOfHeadArg cctx) params+    -- Type each non-final body item; the lambda's value type is the+    -- type of its trailing return expression.+    let initExprs = NE.init body+        lastExpr = NE.last body+    mapM_ (typeOfExpr cctx) initExprs+    bodyType <- typeOfExpr cctx lastExpr+    pure (VTerm (tcAtom "fun") [valueList (NE.toList paramTypeVars), bodyType])+  where+    typeOfHeadArg c (HeadVar v) = chrOp (varType c v)+    typeOfHeadArg _ HeadWildcard = chrOp newVar++-- | Type a 'CtorExpr' application. Mirrors 'typeOfTermCtor' for the+-- typed-expression side: constructors with a known declared arity emit+-- @check_constructor_use@; everything else falls back to @any@.+typeOfExprCtor :: CheckCtx -> Name -> [D.Expr] -> TC Value+typeOfExprCtor cctx name args = do+  env <- ask+  let arity = length args+      canonical = canonicalizeConName env name+  if knownConstructorWithArity env canonical arity+    then do+      argTypes <- traverse (typeOfExpr cctx) args+      resultType <- chrOp newVar+      ctx <- freshCtxHandle cctx+      chrOp $+        tellConstraint+          (Qualified "$typechecker" "check_constructor_use")+          [ VAtom (runtimeName canonical),+            valueList argTypes,+            resultType,+            ctxHandleValue ctx+          ]+      pure resultType+    else do+      mapM_ (typeOfExpr cctx) args+      pure (tcCon0 "any")++-- ---------------------------------------------------------------------------+-- Variable collection+-- ---------------------------------------------------------------------------++collectVarsInRule :: D.Rule -> Set Text+collectVarsInRule rule =+  let AnnP hd _ _ = rule.head+      AnnP guards _ _ = rule.guard+      AnnP body _ _ = rule.body+      headCs = map headConstraintToConstraint (hd.kept ++ hd.removed)+   in mconcat+        [ foldMap collectVarsInConstraint headCs,+          foldMap collectVarsInGuard guards,+          foldMap collectVarsInBodyGoal body+        ]++collectVarsInEq :: D.Equation -> Set Text+collectVarsInEq eq =+  mconcat+    [ foldMap collectVarsInHeadArg eq.params,+      foldMap collectVarsInGuard eq.guards,+      foldMap collectVarsInFunStmt eq.prelude,+      collectVarsInExpr eq.rhs+    ]++collectVarsInFunStmt :: D.FunStmt -> Set Text+collectVarsInFunStmt (D.FunIs v e) = Set.singleton v <> collectVarsInExpr e+collectVarsInFunStmt (D.FunHostStmt _ args) = foldMap collectVarsInExpr args+collectVarsInFunStmt (D.FunCall _ args) = foldMap collectVarsInExpr args+collectVarsInFunStmt (D.FunApply f args) =+  collectVarsInExpr f <> foldMap collectVarsInExpr args++collectVarsInConstraint :: Types.QualifiedConstraint -> Set Text+collectVarsInConstraint c = foldMap collectVarsInTerm c.args++collectVarsInHeadArg :: HeadArg -> Set Text+collectVarsInHeadArg (HeadVar v) = Set.singleton v+collectVarsInHeadArg HeadWildcard = Set.empty++collectVarsInGuard :: D.Guard -> Set Text+collectVarsInGuard (D.GuardEqual e1 e2) = collectVarsInExpr e1 <> collectVarsInExpr e2+collectVarsInGuard (D.GuardMatch e _ _) = collectVarsInExpr e+collectVarsInGuard (D.GuardGetArg v e _) = Set.singleton v <> collectVarsInExpr e+collectVarsInGuard (D.GuardExpr e) = collectVarsInExpr e++collectVarsInBodyGoal :: D.BodyGoal -> Set Text+collectVarsInBodyGoal D.BodyTrue = Set.empty+collectVarsInBodyGoal (D.BodyTell _ args) = foldMap collectVarsInExpr args+collectVarsInBodyGoal (D.BodyUnify e1 e2) = collectVarsInExpr e1 <> collectVarsInExpr e2+collectVarsInBodyGoal (D.BodyHostStmt _ args) = foldMap collectVarsInExpr args+collectVarsInBodyGoal (D.BodyIs v e) = Set.singleton v <> collectVarsInExpr e+collectVarsInBodyGoal (D.BodyCall _ args) = foldMap collectVarsInExpr args+collectVarsInBodyGoal (D.BodyApply f args) =+  collectVarsInExpr f <> foldMap collectVarsInExpr args++collectVarsInTerm :: Term -> Set Text+collectVarsInTerm (VarTerm v) = Set.singleton v+collectVarsInTerm (CompoundTerm _ args) = foldMap collectVarsInTerm args+collectVarsInTerm _ = Set.empty++-- | Collect every variable name an expression mentions, including+-- lambda parameter names. Type-slot allocation needs *all* names+-- (lambda params become local bindings the typechecker must type),+-- which is wider than what the lambda lifter uses when computing+-- captures.+collectVarsInExpr :: D.Expr -> Set Text+collectVarsInExpr (R.VarExpr v) = Set.singleton v+collectVarsInExpr (R.CtorExpr _ args) = foldMap collectVarsInExpr args+collectVarsInExpr (R.CallExpr _ args) = foldMap collectVarsInExpr args+collectVarsInExpr (R.ApplyExpr f args) =+  collectVarsInExpr f <> foldMap collectVarsInExpr args+collectVarsInExpr (R.HostExpr _ args) = foldMap collectVarsInExpr args+collectVarsInExpr (R.LambdaExpr params body) =+  Set.fromList [v | HeadVar v <- NE.toList params]+    <> foldMap collectVarsInExpr (NE.toList body)+collectVarsInExpr _ = Set.empty++-- ---------------------------------------------------------------------------+-- Error collection+-- ---------------------------------------------------------------------------++collectErrors :: TC [Diagnostic TypeCheckError]+collectErrors = do+  errVar <- chrOp newVar+  chrOp (tellConstraint (Qualified "$typechecker" "collect") [errVar])+  errVal <- chrOp (deref errVar)+  store <- getStore+  chrOp (decodeErrorList store.ctxMap errVal)++decodeErrorList :: CtxMap -> Value -> Chr [Diagnostic TypeCheckError]+decodeErrorList ctxMap val = do+  case fromValueList val of+    Just items -> concat <$> traverse (decodeError ctxMap) items+    Nothing -> pure []++decodeError :: CtxMap -> Value -> Chr [Diagnostic TypeCheckError]+decodeError ctxMap val = do+  val' <- deref val+  case val' of+    VTerm errorFunctor [ctxValRaw, codeVal, detailVal]+      | errorFunctor == tcAtom "error" -> decodeErrorBody ctxValRaw codeVal detailVal+    _ ->+      error ("TypeCheck.decodeError: malformed error term: " <> showValueShape val')+  where+    decodeErrorBody ctxValRaw codeVal detailVal = do+      ctxVal <- deref ctxValRaw+      let info = case ctxVal of+            VInt n ->+              Map.findWithDefault+                (error ("TypeCheck.decodeError: orphan Ctx handle " <> show n))+                (CtxHandle (fromInteger n))+                ctxMap+            _ ->+              error+                ( "TypeCheck.decodeError: non-Int Ctx value: "+                    <> showValueShape ctxVal+                )+      code <- deref codeVal+      detail <- deref detailVal+      case code of+        VAtom c | c == tcAtom "inconsistent" -> do+          (t1text, t2text) <- case detail of+            VTerm pf [t1, t2] | pf == tcAtom "pair" -> do+              t1' <- deref t1+              t2' <- deref t2+              pure (showType t1', showType t2')+            _ -> pure ("?", "?")+          pure+            [ Diagnostic+                info.label+                ( AnnP+                    (InconsistentTypes t1text t2text)+                    info.loc+                    info.origin+                )+            ]+        VAtom c | c == tcAtom "no_matching_overload" -> do+          nameText <- showValue detail+          pure+            [ Diagnostic+                info.label+                ( AnnP+                    (NoMatchingOverload nameText)+                    info.loc+                    info.origin+                )+            ]+        VAtom c | c == tcAtom "bound_unsatisfied" -> do+          nameText <- showValue detail+          pure+            [ Diagnostic+                info.label+                ( AnnP+                    (BoundUnsatisfied nameText)+                    info.loc+                    info.origin+                )+            ]+        VAtom c ->+          error+            ( "TypeCheck.decodeError: unknown error code "+                <> T.unpack (displayQualifiedAtom c)+            )+        _ -> error "TypeCheck.decodeError: malformed error code value"++-- | One-line description of a runtime 'Value''s outer shape, used only+-- in 'error' messages for broken-invariant cases in 'decodeError'.+showValueShape :: Value -> String+showValueShape (VTerm f xs) =+  "VTerm " <> T.unpack f <> "/" <> show (length xs)+showValueShape (VAtom a) = "VAtom " <> T.unpack a+showValueShape (VInt _) = "VInt"+showValueShape (VFloat _) = "VFloat"+showValueShape (VText _) = "VText"+showValueShape (VBool _) = "VBool"+showValueShape (VVar _) = "VVar"+showValueShape VWildcard = "VWildcard"++showType :: Value -> Text+showType (VAtom a) = displayTypeAtom a+showType (VTerm functor [a, b])+  | functor == tcAtom "tcon" =+      let name = showTypeName a+       in case fromValueList b of+            Just [] -> name+            Just as -> name <> "(" <> T.intercalate ", " (map showType as) <> ")"+            Nothing -> name <> "(?)"+  | functor == tcAtom "fun" =+      case fromValueList a of+        Just as -> "fun(" <> T.intercalate ", " (map showType as) <> ") -> " <> showType b+        Nothing -> "fun(?) -> " <> showType b+-- Rigid type variable: rendered with its synthetic id so distinct+-- rigids are distinguishable in inconsistency messages. The original+-- source-level tvar name (@T@, @A@, ...) is not preserved because the+-- driver does not currently maintain an id-to-name map; @T#<n>@ is+-- enough to communicate "this is a polymorphic type variable" to the+-- reader.+showType (VTerm functor [VInt n])+  | functor == tcAtom "rigid" = "T#" <> T.pack (show n)+showType (VVar _) = "_"+showType (VInt n) = T.pack (show n)+showType _ = "?"++showTypeName :: Value -> Text+showTypeName (VAtom a) = displayTypeAtom a+showTypeName _ = "?"++showValue :: Value -> Chr Text+showValue v = do+  v' <- deref v+  case v' of+    VAtom a -> pure (displayQualifiedAtom a)+    _ -> pure "?"++-- | Convert a runtime-flattened qualified atom (@m__n@) back to the+-- source-level display form (@m:n@). No-op when the atom doesn't+-- contain @__@. Used in error messages so users see familiar syntax.+-- Inverse of 'runtimeName'.+displayQualifiedAtom :: Text -> Text+displayQualifiedAtom = T.replace "__" ":"++-- | Like 'displayQualifiedAtom', but additionally hides the internal+-- @'$typechecker'@ module qualifier so built-in type names+-- (@int@, @float@, @string@, @any@) render bare. User-defined types+-- stay module-qualified.+displayTypeAtom :: Text -> Text+displayTypeAtom t =+  let q = displayQualifiedAtom t+   in fromMaybe q (T.stripPrefix "$typechecker:" q)++-- ---------------------------------------------------------------------------+-- Type definition validation (pure, Haskell-side)+-- ---------------------------------------------------------------------------++validateTypeDefinitions ::+  [TypeDefinition] ->+  Map Name TypeDefinition ->+  [Diagnostic TypeCheckError]+validateTypeDefinitions tds typeMap =+  concatMap (validateTypeDef typeMap) tds++validateTypeDef :: Map Name TypeDefinition -> TypeDefinition -> [Diagnostic TypeCheckError]+validateTypeDef typeMap td =+  concatMap (validateConstructor typeMap td) (typeConstructors td)++validateConstructor ::+  Map Name TypeDefinition ->+  TypeDefinition ->+  DataConstructor ->+  [Diagnostic TypeCheckError]+validateConstructor typeMap td dc =+  concatMap (validateFieldType typeMap td dc) dc.conArgs++validateFieldType ::+  Map Name TypeDefinition ->+  TypeDefinition ->+  DataConstructor ->+  TypeExpr ->+  [Diagnostic TypeCheckError]+validateFieldType _ td dc (TypeVar v)+  | v `elem` td.typeVars = []+  | otherwise =+      [ Diagnostic+          Nothing+          ( AnnP+              (UnboundTypeVar (flattenName td.name) (flattenName dc.conName) v)+              td.loc+              (Atom (flattenName td.name))+          )+      ]+validateFieldType typeMap td dc (TypeCon name args) =+  let nameErrors = case name of+        Unqualified n+          | n `elem` ["int", "float", "string", "any"] -> []+        _ ->+          if Map.member name typeMap+            then []+            else+              [ Diagnostic+                  Nothing+                  ( AnnP+                      ( UndefinedType+                          (flattenName td.name)+                          (flattenName dc.conName)+                          (flattenName name)+                      )+                      td.loc+                      (Atom (flattenName td.name))+                  )+              ]+      argErrors = concatMap (validateFieldType typeMap td dc) args+   in nameErrors ++ argErrors++-- ---------------------------------------------------------------------------+-- Constructor arity validation (pure, Haskell-side)+-- ---------------------------------------------------------------------------++-- | Walk every term in every rule and equation, and report each use of a+-- known data constructor whose arity differs from its declaration. Done as+-- a pre-pass — separately from the CHR session — so the diagnostic is a+-- direct ConstructorArityMismatch rather than a downstream tcon+-- inconsistency. The check phase silently skips wrong-arity sites+-- (treating them as @any@) so this error is the only one reported for+-- such uses.+validateConstructorArities :: TypeCheckEnv -> D.Program -> [Diagnostic TypeCheckError]+validateConstructorArities env prog =+  concatMap validateRule prog.rules+    ++ concatMap validateFunction prog.functions+  where+    validateRule rule =+      let AnnP hd headLoc headOrigin = rule.head+          AnnP guards guardLoc guardOrigin = rule.guard+          AnnP body bodyLoc bodyOrigin = rule.body+          ruleLabel = fmap (\n -> "rule " <> n) rule.name+          headArgs = concatMap (map headArgToTerm . (.args)) (hd.kept ++ hd.removed)+          inHead = foldMap termArity headArgs+          inGuards = foldMap guardArity guards+          inBody = foldMap bodyArity body+       in mkDiags ruleLabel headLoc headOrigin inHead+            ++ mkDiags ruleLabel guardLoc guardOrigin inGuards+            ++ mkDiags ruleLabel bodyLoc bodyOrigin inBody+    validateFunction func =+      let AnnP eqs loc origin = func.equations+          funLabel =+            Just ("function " <> flattenName (Types.qualifiedToName func.name))+          inEqs = foldMap eqArity eqs+       in mkDiags funLabel loc origin inEqs+    eqArity eq =+      foldMap (termArity . headArgToTerm) eq.params+        <> foldMap guardArity eq.guards+        <> exprArity eq.rhs+    guardArity (D.GuardEqual e1 e2) = exprArity e1 <> exprArity e2+    guardArity (D.GuardMatch e conName arity) = checkArity conName arity <> exprArity e+    guardArity (D.GuardGetArg _ e _) = exprArity e+    guardArity (D.GuardExpr e) = exprArity e+    bodyArity D.BodyTrue = mempty+    bodyArity (D.BodyTell _ args) = foldMap exprArity args+    bodyArity (D.BodyUnify e1 e2) = exprArity e1 <> exprArity e2+    bodyArity (D.BodyIs _ e) = exprArity e+    bodyArity (D.BodyCall _ args) = foldMap exprArity args+    bodyArity (D.BodyApply f args) = exprArity f <> foldMap exprArity args+    bodyArity (D.BodyHostStmt _ args) = foldMap exprArity args+    -- An atom is a 0-arity constructor use; a 'CtorExpr' is an n-arity+    -- use. 'CallExpr', 'ApplyExpr', 'HostExpr', 'FunRefExpr', and+    -- 'LambdaExpr' are not constructor applications: their children+    -- are walked, but the heads themselves are not subjected to the+    -- arity check.+    exprArity (R.CtorExpr name args) =+      checkArity name (length args) <> foldMap exprArity args+    exprArity (R.CallExpr _ args) = foldMap exprArity args+    exprArity (R.ApplyExpr f args) = exprArity f <> foldMap exprArity args+    exprArity (R.HostExpr _ args) = foldMap exprArity args+    exprArity (R.LambdaExpr _ body) = foldMap exprArity (NE.toList body)+    exprArity _ = mempty+    -- Walks the surviving 'Term'-typed positions in the desugared AST+    -- (equation parameters). Pattern shapes that 'headTermToExpr'+    -- would otherwise round-trip through @fun(...) -> body@ /+    -- @name/arity@ are short-circuited here.+    termArity+      ( CompoundTerm+          (Unqualified "/")+          [CompoundTerm (Unqualified _) [], IntTerm _]+        ) = mempty+    termArity (CompoundTerm (Unqualified "->") [CompoundTerm (Unqualified "fun") _, body]) =+      termArity body+    termArity (CompoundTerm name args) =+      checkArity name (length args) <> foldMap termArity args+    termArity _ = mempty+    checkArity name useArity =+      let canonical = canonicalizeConName env name+       in case Map.lookup canonical env.conMap of+            Just (_, dc)+              | length dc.conArgs /= useArity ->+                  [(canonical, useArity, length dc.conArgs)]+            _ -> []+    mkDiags lbl loc origin =+      map+        ( \(name, useArity, declaredArity) ->+            Diagnostic+              lbl+              ( AnnP+                  (ConstructorArityMismatch (flattenName name) useArity declaredArity)+                  loc+                  origin+              )+        )
+ src/YCHR/Internal/TypeCheck/Compiled.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | The pre-compiled YCHR type-checker as a 'SessionInput'.+--+-- The type-checker is itself a CHR program. Its source is embedded+-- into the binary at compile time via+-- 'YCHR.Internal.TypeCheck.TH.embeddedTypeCheckerSource'; the first reader of+-- 'typeCheckerProgram' pays the compile cost, everyone after gets+-- the memoized 'SessionInput'.+--+-- 'compileTypeChecker' is the underlying pure function; embedders+-- that want explicit control over when (or whether) the type-checker+-- is compiled can call it directly with their own source.+module YCHR.Internal.TypeCheck.Compiled+  ( -- * Pure API+    compileTypeChecker,++    -- * Default value (compiled lazily on first demand)+    typeCheckerProgram,+  )+where++import Data.Text (Text)+import YCHR.Internal.Compile.Pipeline (Error, compileModules)+import YCHR.Internal.Runtime.Session (SessionInput, toSessionInput)+import YCHR.Internal.TypeCheck.TH (embeddedTypeCheckerSource, typeCheckerPath)++-- | Compile the YCHR type-checker from its CHR source. Pure; the+-- @True@ flag passed to 'compileModules' disables type-checking the+-- type-checker itself (the bootstrap issue).+compileTypeChecker :: FilePath -> Text -> Either Error SessionInput+compileTypeChecker path src =+  case compileModules True [(path, src)] of+    Left err -> Left err+    Right (cp, _warnings) -> Right (toSessionInput cp)++-- | The default compiled type-checker. The source is embedded at+-- compile time; compilation runs once on first demand.+typeCheckerProgram :: SessionInput+typeCheckerProgram =+  case compileTypeChecker typeCheckerPath $(embeddedTypeCheckerSource) of+    Left err ->+      error ("Failed to compile embedded type checker: " ++ show err)+    Right si -> si
+ src/YCHR/Internal/TypeCheck/Error.hs view
@@ -0,0 +1,35 @@+-- | Type-check error variants. Lives in its own module so that both+-- "YCHR.Internal.TypeCheck" and "YCHR.Internal.Compile.Pipeline" can refer to the type+-- without forming an import cycle ("YCHR.Internal.TypeCheck" already depends on+-- "YCHR.Internal.Compile.Pipeline" for 'CompiledProgram').+module YCHR.Internal.TypeCheck.Error+  ( TypeCheckError (..),+  )+where++import Data.Text (Text)++-- | Errors reported by the type-checker pass.+data TypeCheckError+  = InconsistentTypes Text Text+  | NoMatchingOverload Text+  | UnboundTypeVar Text Text Text+  | UndefinedType Text Text Text+  | -- | A constructor name is declared by more than one type.+    -- Carries the flattened constructor name and the+    -- @(typeName, arity)@ pairs of every declaration.+    DuplicateConstructor Text [(Text, Int)]+  | -- | A known data constructor used with the wrong number of+    -- arguments. Carries the flattened constructor name, the+    -- use-site arity, and the declared arity. Constructors are+    -- name-only in YCHR's type system, so the declared arity is+    -- part of a constructor's identity and any mismatch is an+    -- error rather than a fall-through to @any@.+    ConstructorArityMismatch Text Int Int+  | -- | A use site of a bounded function or constraint infers a+    -- substitution whose required signatures cannot be satisfied by+    -- any declared signature of the bound's named function. Carries+    -- the bound function's flattened name. Emitted at the call site+    -- (or head/body occurrence for a bounded constraint).+    BoundUnsatisfied Text+  deriving (Show, Eq)
+ src/YCHR/Internal/TypeCheck/TH.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Compile-time embedding of the type-checker source.+--+-- @typechecker\/typechecker.chr@ is read by GHC at build time and+-- spliced into 'YCHR.Internal.TypeCheck.Compiled'. The resulting binary is+-- self-contained: no @YCHR_TC_PATH@ env var, no cwd-relative path.+--+-- 'addDependentFile' makes GHC recompile when the embedded file+-- changes.+module YCHR.Internal.TypeCheck.TH+  ( typeCheckerPath,+    embeddedTypeCheckerSource,+  )+where++import Data.Text (Text)+import Data.Text.IO qualified as TIO+import Language.Haskell.TH (Exp, Q)+import Language.Haskell.TH.Syntax (addDependentFile, lift, runIO)++-- | The path of the type-checker source, relative to the package+-- root. Used both as the read path during the TH splice (GHC runs+-- splices with the cabal package directory as cwd) and as the path+-- string surfaced in error messages.+typeCheckerPath :: FilePath+typeCheckerPath = "typechecker/typechecker.chr"++-- | Splice yielding the type-checker source as 'Text'.+embeddedTypeCheckerSource :: Q Exp+embeddedTypeCheckerSource = do+  addDependentFile typeCheckerPath+  contents <- runIO (TIO.readFile typeCheckerPath)+  lift (contents :: Text)
+ src/YCHR/Internal/Types.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Shared types for CHR representations.+--+-- This module contains types that are identical across the surface+-- language AST ('YCHR.Internal.Parsed') and the internal AST+-- ('YCHR.Internal.Desugared'). The embedder-facing subset ('Term',+-- 'Name', 'Constraint', and the type-declaration vocabulary) is+-- re-exported from "YCHR.Types", which is the module covered by the+-- package version policy; everything else here is compiler-internal.+module YCHR.Internal.Types+  ( -- * Constraints+    Constraint (..),+    QualifiedConstraint (..),+    ConstraintType (..),+    Identifier (..),+    QualifiedIdentifier (..),+    UnqualifiedIdentifier (..),+    Name (..),+    QualifiedName (..),++    -- * Post-HNF head constraints+    HeadConstraint (..),+    HeadArg (..),+    headArgToTerm,+    headConstraintToConstraint,++    -- * Rules+    RuleId (..),++    -- * Symbol table+    SymbolTable,+    mkSymbolTable,+    lookupSymbol,+    symbolTableToList,+    symbolTableSize,++    -- * Name helpers+    flattenName,+    qualifiedToName,+    qualifiedNameToIdentifier,++    -- * Terms+    Term (..),++    -- * Type declarations+    TypeDefinition (..),+    TypeKind (..),+    typeConstructors,+    DataConstructor (..),+    TypeExpr (..),++    -- * Bounded polymorphism+    BoundSig (..),+  )+where++import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import YCHR.Internal.Loc (SourceLoc)++-- | A numeric identifier for a constraint type, assigned by the symbol table.+newtype ConstraintType = ConstraintType {unConstraintType :: Int}+  deriving (Show, Eq, Ord)++-- | A numeric identifier for a rule, assigned in source order during+-- occurrence collection. Used as the propagation history key. Keeping+-- identity numeric (rather than textual) ensures two rules named+-- @trans@ in different modules cannot collide in the history.+newtype RuleId = RuleId {unRuleId :: Int}+  deriving (Show, Eq, Ord)++-- | A name together with its arity, identifying a constraint or function.+data Identifier = Identifier {name :: Name, arity :: Int}+  deriving (Show, Eq, Ord)++-- | An unqualified name with its arity.  Used in 'exportMap' where+-- names are looked up before qualification.+data UnqualifiedIdentifier = UnqualifiedIdentifier+  { localName :: Text,+    arity :: Int+  }+  deriving (Show, Eq, Ord)++-- | A fully-qualified name with its arity.  Used in 'exportedSet' where+-- all names are guaranteed to be module-qualified.+data QualifiedIdentifier = QualifiedIdentifier+  { moduleName :: Text,+    localName :: Text,+    arity :: Int+  }+  deriving (Show, Eq, Ord)++-- | Maps identifiers (name + arity) to unique 0-indexed numeric IDs.+newtype SymbolTable = SymbolTable (Map Identifier ConstraintType)+  deriving (Show, Eq)++-- | Build a 'SymbolTable' from identifier\/ID pairs. Later entries win on+-- a duplicate 'Identifier', following 'Map.fromList'.+mkSymbolTable :: [(Identifier, ConstraintType)] -> SymbolTable+mkSymbolTable = SymbolTable . Map.fromList++-- | Look up the 'ConstraintType' assigned to an identifier, or 'Nothing'+-- if the constraint is not in the table.+lookupSymbol :: Identifier -> SymbolTable -> Maybe ConstraintType+lookupSymbol n (SymbolTable m) = Map.lookup n m++-- | All entries, ordered by 'Identifier' (name, then arity) — /not/ by+-- 'ConstraintType' index. Sort on the ID when index order matters.+symbolTableToList :: SymbolTable -> [(Identifier, ConstraintType)]+symbolTableToList (SymbolTable m) = Map.toList m++-- | Number of distinct constraints in the table. Because IDs are+-- 0-indexed and contiguous, this is also one past the largest+-- 'ConstraintType' — the store's pre-allocation size.+symbolTableSize :: SymbolTable -> Int+symbolTableSize (SymbolTable m) = Map.size m++-- | Represents a name that can be either raw or module-qualified.+data Name+  = -- | e.g., "leq"+    Unqualified Text+  | -- | e.g., "Order", "leq"+    Qualified Text Text+  deriving (Show, Eq, Ord)++-- | A name guaranteed to be module-qualified. Established by the+-- resolve phase and propagated through 'YCHR.Internal.Resolved' and+-- 'YCHR.Internal.Desugared'. Compare with 'Name', which admits an+-- 'Unqualified' constructor used in the parser and renamer.+data QualifiedName = QualifiedName+  { moduleName :: !Text,+    baseName :: !Text+  }+  deriving (Show, Eq, Ord)++-- | Flatten a 'Name' to its surface 'Text' form. Qualified names are+-- rendered as @"Module:name"@.+flattenName :: Name -> Text+flattenName (Unqualified t) = t+flattenName (Qualified m t) = m <> ":" <> t++-- | Lift a 'QualifiedName' back to the loose 'Name' for display,+-- diagnostics, or compatibility with code that has not yet been+-- tightened.+qualifiedToName :: QualifiedName -> Name+qualifiedToName (QualifiedName m b) = Qualified m b++-- | Build an 'Identifier' from a 'QualifiedName' and arity.+qualifiedNameToIdentifier :: QualifiedName -> Int -> Identifier+qualifiedNameToIdentifier qn a = Identifier (qualifiedToName qn) a++-- | A CHR constraint occurrence.+data Constraint = Constraint+  { name :: Name,+    args :: [Term]+  }+  deriving (Show, Eq)++-- | A CHR constraint occurrence with a qualified head name. Used in+-- 'YCHR.Internal.Resolved' and 'YCHR.Internal.Desugared' rule heads and bodies, where+-- the resolve phase has guaranteed every constraint name is+-- module-qualified.+data QualifiedConstraint = QualifiedConstraint+  { name :: QualifiedName,+    args :: [Term]+  }+  deriving (Show, Eq)++-- | A head argument after Head Normal Form. The desugarer guarantees+-- that every head argument is either a variable or a wildcard;+-- non-variable patterns are lifted into 'YCHR.Internal.Desugared.GuardMatch',+-- 'YCHR.Internal.Desugared.GuardGetArg', and 'YCHR.Internal.Desugared.GuardEqual' guards+-- and replaced with fresh variables in the head. This narrower type+-- enforces that invariant.+data HeadArg+  = HeadVar Text+  | HeadWildcard+  deriving (Show, Eq)++-- | A constraint occurrence in a post-HNF rule head. Mirrors+-- 'QualifiedConstraint' but with the narrower 'HeadArg' for arguments.+data HeadConstraint = HeadConstraint+  { name :: QualifiedName,+    args :: [HeadArg]+  }+  deriving (Show, Eq)++-- | Lossless conversion from a 'HeadArg' to a 'Term'. Used at the+-- boundary with code that operates uniformly on terms (the+-- typechecker, pretty-printers).+headArgToTerm :: HeadArg -> Term+headArgToTerm (HeadVar v) = VarTerm v+headArgToTerm HeadWildcard = Wildcard++-- | Lossless conversion from a 'HeadConstraint' to a+-- 'QualifiedConstraint'.+headConstraintToConstraint :: HeadConstraint -> QualifiedConstraint+headConstraintToConstraint hc =+  QualifiedConstraint hc.name (map headArgToTerm hc.args)++-- | A CHR type declaration.+data TypeDefinition = TypeDefinition+  { name :: Name,+    typeVars :: [Text],+    kind :: TypeKind,+    loc :: SourceLoc+  }+  deriving (Show, Eq)++-- | The kind of a type declaration.+--+-- An 'Algebraic' type is declared with @:- chr_type@ and carries one or+-- more data constructors. An 'Opaque' type is declared with+-- @:- opaque_type@, is nominal, and has no data constructors — its+-- values are introduced and eliminated only by (host-backed) functions.+-- Encoding opacity as a sum makes "opaque implies no constructors"+-- unrepresentable rather than a runtime invariant.+data TypeKind+  = Algebraic [DataConstructor]+  | Opaque+  deriving (Show, Eq)++-- | The data constructors of a type definition: the declared+-- constructors for an 'Algebraic' type, and none for an 'Opaque' type.+typeConstructors :: TypeDefinition -> [DataConstructor]+typeConstructors td = case td.kind of+  Algebraic cs -> cs+  Opaque -> []++-- | A data constructor within a type declaration.+data DataConstructor = DataConstructor+  { conName :: Name,+    conArgs :: [TypeExpr]+  }+  deriving (Show, Eq)++-- | A type expression (argument of a data constructor).+data TypeExpr+  = TypeVar Text+  | TypeCon Name [TypeExpr]+  deriving (Show, Eq)++-- | A required signature appearing inside a @requiring@ clause on a+-- bounded function or constraint declaration. Carries the same shape+-- as a function signature (name + arg types + return type) plus the+-- arity (redundant with @length argTypes@ but kept explicit so the+-- bound-graph code can compare against function declarations by+-- @(name, arity)@ without re-counting).+--+-- The 'name' field follows the same Unqualified-to-Qualified+-- progression as 'Constraint.name': the parser emits 'Unqualified',+-- the renamer rewrites it to 'Qualified', and the resolver checks+-- it against the program's declared functions.+data BoundSig = BoundSig+  { name :: Name,+    arity :: Int,+    argTypes :: [TypeExpr],+    returnType :: TypeExpr,+    loc :: SourceLoc+  }+  deriving (Show, Eq)++-- | Prolog-compatible terms.+--+-- Atoms and zero-arity compounds collapse to the same AST form+-- @CompoundTerm name []@: downstream phases (Resolve, Desugar,+-- TypeCheck, Compile) dispatch on a uniform shape. The runtime+-- representation is asymmetric — zero-arity compounds become 'VAtom'+-- for cheap allocation and comparison — but the AST keeps the+-- compound form so pattern matching stays uniform.+-- The 'Ord' instance carries no semantic meaning — it exists so that a+-- 'Term' can key a 'Data.Map.Map' or inhabit a 'Data.Set.Set'. Structural+-- CHR equality on /runtime/ values is 'YCHR.Run.equal', not this instance.+--+-- Caveat: it inherits 'Double''s NaN behaviour, so it is not a total+-- order. A @'FloatTerm' nan@ (reachable from CHR — @R is 0.0 \/ 0.0@)+-- compares unequal to itself, which breaks the 'Data.Map.Map' and+-- 'Data.Set.Set' invariants for that one key: the term cannot be looked+-- up again, and a set will hold duplicates of it. Filter or normalize+-- NaN before using a 'Term' as a key if floats can reach it.+data Term+  = VarTerm Text+  | IntTerm Integer+  | FloatTerm Double+  | TextTerm Text+  | CompoundTerm Name [Term]+  | Wildcard+  deriving (Show, Eq, Ord)
+ src/YCHR/Internal/VM.hs view
@@ -0,0 +1,31 @@+-- | CHR Virtual Machine — re-exports from "YCHR.Internal.VM.Types".+module YCHR.Internal.VM+  ( -- * Program structure+    Program (..),+    Procedure (..),+    ProcKind (..),+    EvaluableKey (..),++    -- * Statements+    Stmt (..),++    -- * Expressions+    ValExpr (..),+    IdExpr (..),+    BoolExpr (..),+    CallArg (..),++    -- * Runtime call stack frames+    StackFrame (..),++    -- * Supporting types+    ConstraintType (..),+    RuleId (..),+    Literal (..),+    ArgIndex (..),+    Name (..),+    Label (..),+  )+where++import YCHR.Internal.VM.Types
+ src/YCHR/Internal/VM/SExpr.hs view
@@ -0,0 +1,509 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Serialization and deserialization of VM programs as s-expressions.+--+-- The s-expression format uses kebab-case identifiers that mirror the+-- Haskell VM constructors.  This format is designed for consumption by+-- external backends (Erlang, Python, Clojure, etc.) and as a+-- compilation cache artifact.+--+-- Example:+--+-- @+-- (program 1+--   (procedure "tell_leq" ("X" "Y")+--     (let-id "id" (create-constraint 0 (var "X") (var "Y")))+--     (store (id-var "id"))+--     (expr-stmt (call-expr "activate_leq" (arg-id (id-var "id"))))))+-- @+module YCHR.Internal.VM.SExpr+  ( -- * VMProgram+    VMProgram (..),++    -- * High-level API+    serialize,+    deserialize,++    -- * Low-level API+    programToSExpr,+    programFromSExpr,+  )+where++import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Text.Read (readMaybe)+import YCHR.Internal.Loc (SourceLoc (..))+import YCHR.Internal.SExpr (SExpr (..), parseSExpr, printSExpr)+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM.Types++-- ---------------------------------------------------------------------------+-- VMProgram+-- ---------------------------------------------------------------------------++-- | A VM program bundled with metadata needed by external backends.+data VMProgram = VMProgram+  { program :: Program,+    exportedSet :: Set Types.QualifiedIdentifier,+    symbolTable :: Types.SymbolTable+  }+  deriving (Show, Eq)++-- ---------------------------------------------------------------------------+-- High-level API+-- ---------------------------------------------------------------------------++-- | Serialize a VM program to s-expression text.+serialize :: VMProgram -> Text+serialize = printSExpr . vmProgramToSExpr++-- | Deserialize a VM program from s-expression text.+deserialize :: Text -> Either Text VMProgram+deserialize input = case parseSExpr input of+  Left e -> Left (T.pack e)+  Right sexpr -> vmProgramFromSExpr sexpr++-- ---------------------------------------------------------------------------+-- Serialization (VM → SExpr)+-- ---------------------------------------------------------------------------++vmProgramToSExpr :: VMProgram -> SExpr+vmProgramToSExpr vmp =+  SList+    [ SAtom "vm-program",+      programToSExpr vmp.program,+      SList (SAtom "exports" : map identToSExpr (Set.toAscList vmp.exportedSet)),+      symbolTableToSExpr vmp.symbolTable+    ]++symbolTableToSExpr :: Types.SymbolTable -> SExpr+symbolTableToSExpr st =+  SList (SAtom "symbol-table" : map entryToSExpr (Types.symbolTableToList st))+  where+    entryToSExpr (Types.Identifier n arity, Types.ConstraintType ct) =+      SList+        [ chrNameToSExpr n,+          SInt (fromIntegral arity),+          SInt (fromIntegral ct)+        ]++identToSExpr :: Types.QualifiedIdentifier -> SExpr+identToSExpr (Types.QualifiedIdentifier m n arity) =+  SList+    [ chrNameToSExpr+        ( Types.Qualified+            m+            n+        ),+      SInt (fromIntegral arity)+    ]++chrNameToSExpr :: Types.Name -> SExpr+chrNameToSExpr (Types.Unqualified t) = SString t+chrNameToSExpr (Types.Qualified m t) = SList [SAtom "qualified", SString m, SString t]++programToSExpr :: Program -> SExpr+programToSExpr prog =+  SList+    ( SAtom "program"+        : SInt (fromIntegral prog.numTypes)+        : SList (SAtom "type-names" : map chrNameToSExpr prog.typeNames)+        : SInt (fromIntegral prog.numRules)+        : SList (SAtom "rule-names" : map SString prog.ruleNames)+        : SList (SAtom "evaluables" : map evaluableEntryToSExpr prog.evaluables)+        : map procedureToSExpr prog.procedures+    )++evaluableEntryToSExpr :: (EvaluableKey, Name) -> SExpr+evaluableEntryToSExpr (key, procName) =+  SList [nameToSExpr key.functor, SInt (fromIntegral key.arity), nameToSExpr procName]++procedureToSExpr :: Procedure -> SExpr+procedureToSExpr proc =+  SList+    ( SAtom "procedure"+        : SString proc.name.unName+        : SList (map nameToSExpr proc.params)+        : procKindToSExpr proc.procKind+        : map stmtToSExpr proc.body+    )++procKindToSExpr :: ProcKind -> SExpr+procKindToSExpr (PKTell ct) = SList [SAtom "tell", constraintTypeToSExpr ct]+procKindToSExpr (PKActivate ct) = SList [SAtom "activate", constraintTypeToSExpr ct]+procKindToSExpr (PKOccurrence ct n rid display) =+  SList+    [ SAtom "occurrence",+      constraintTypeToSExpr ct,+      SInt (fromIntegral n),+      ruleIdToSExpr rid,+      SString display+    ]+procKindToSExpr PKReactivateDispatch = SList [SAtom "reactivate-dispatch"]+procKindToSExpr (PKCallDispatch arity) =+  SList [SAtom "call-dispatch", SInt (fromIntegral arity)]+procKindToSExpr (PKFunction qn arity) =+  SList+    [ SAtom "function",+      SString qn.moduleName,+      SString qn.baseName,+      SInt (fromIntegral arity)+    ]++stmtToSExpr :: Stmt -> SExpr+stmtToSExpr (LetVal n e) = SList [SAtom "let-val", nameToSExpr n, valExprToSExpr e]+stmtToSExpr (LetId n e) = SList [SAtom "let-id", nameToSExpr n, idExprToSExpr e]+stmtToSExpr (AssignVal n e) = SList [SAtom "assign-val", nameToSExpr n, valExprToSExpr e]+stmtToSExpr (AssignId n e) = SList [SAtom "assign-id", nameToSExpr n, idExprToSExpr e]+stmtToSExpr (If c ts es) =+  SList [SAtom "if", boolExprToSExpr c, SList (map stmtToSExpr ts), SList (map stmtToSExpr es)]+stmtToSExpr (Foreach lbl ct sv conds body) =+  SList+    [ SAtom "foreach",+      labelToSExpr lbl,+      constraintTypeToSExpr ct,+      nameToSExpr sv,+      SList [SList [SInt (fromIntegral i), valExprToSExpr e] | (ArgIndex i, e) <- conds],+      SList (map stmtToSExpr body)+    ]+stmtToSExpr (Continue lbl) = SList [SAtom "continue", labelToSExpr lbl]+stmtToSExpr (Break lbl) = SList [SAtom "break", labelToSExpr lbl]+stmtToSExpr (Return e) = SList [SAtom "return", valExprToSExpr e]+stmtToSExpr (ExprStmt e) = SList [SAtom "expr-stmt", valExprToSExpr e]+stmtToSExpr (BoolExprStmt e) = SList [SAtom "bool-expr-stmt", boolExprToSExpr e]+stmtToSExpr (Store e) = SList [SAtom "store", idExprToSExpr e]+stmtToSExpr (Kill e) = SList [SAtom "kill", idExprToSExpr e]+stmtToSExpr (AddHistory rid es) =+  SList (SAtom "add-history" : ruleIdToSExpr rid : map idExprToSExpr es)+stmtToSExpr (DrainReactivationQueue sv body) =+  SList (SAtom "drain-reactivation-queue" : nameToSExpr sv : map stmtToSExpr body)+stmtToSExpr (PushFrame frame) =+  SList+    [ SAtom "push-frame",+      SAtom frame.frameLabel,+      SAtom (T.pack (show frame.frameSourceLoc.line)),+      SAtom (T.pack (show frame.frameSourceLoc.col)),+      SAtom (T.pack frame.frameSourceLoc.file),+      SAtom frame.frameSourceCode+    ]++valExprToSExpr :: ValExpr -> SExpr+valExprToSExpr (Var n) = SList [SAtom "var", nameToSExpr n]+valExprToSExpr (Lit l) = literalToSExpr l+valExprToSExpr (CallExpr n es) =+  SList (SAtom "call-expr" : nameToSExpr n : map callArgToSExpr es)+valExprToSExpr (HostCall n es) =+  SList (SAtom "host-call" : nameToSExpr n : map valExprToSExpr es)+valExprToSExpr (EvalDeep e) = SList [SAtom "eval-deep", valExprToSExpr e]+valExprToSExpr (EvalIs e) = SList [SAtom "eval-is", valExprToSExpr e]+valExprToSExpr NewVar = SAtom "new-var"+valExprToSExpr (MakeTerm n es) =+  SList (SAtom "make-term" : nameToSExpr n : map valExprToSExpr es)+valExprToSExpr (GetArg e i) = SList [SAtom "get-arg", valExprToSExpr e, SInt (fromIntegral i)]+valExprToSExpr (FieldArg e (ArgIndex i)) =+  SList [SAtom "field-arg", idExprToSExpr e, SInt (fromIntegral i)]+valExprToSExpr (FieldType e) = SList [SAtom "field-type", idExprToSExpr e]++boolExprToSExpr :: BoolExpr -> SExpr+boolExprToSExpr (BLit True) = SAtom "btrue"+boolExprToSExpr (BLit False) = SAtom "bfalse"+boolExprToSExpr (BNot e) = SList [SAtom "bnot", boolExprToSExpr e]+boolExprToSExpr (BAnd a b) = SList [SAtom "band", boolExprToSExpr a, boolExprToSExpr b]+boolExprToSExpr (BOr a b) = SList [SAtom "bor", boolExprToSExpr a, boolExprToSExpr b]+boolExprToSExpr (BMatchTerm e n a) =+  SList+    [ SAtom "bmatch-term",+      valExprToSExpr e,+      nameToSExpr n,+      SInt (fromIntegral a)+    ]+boolExprToSExpr (BEqual a b) = SList [SAtom "bequal", valExprToSExpr a, valExprToSExpr b]+boolExprToSExpr (BIdEqual a b) = SList [SAtom "bid-equal", idExprToSExpr a, idExprToSExpr b]+boolExprToSExpr (BAlive e) = SList [SAtom "balive", idExprToSExpr e]+boolExprToSExpr (BIsConstraintType e ct) =+  SList [SAtom "bis-constraint-type", idExprToSExpr e, constraintTypeToSExpr ct]+boolExprToSExpr (BNotInHistory rid es) =+  SList (SAtom "bnot-in-history" : ruleIdToSExpr rid : map idExprToSExpr es)+boolExprToSExpr (BUnify a b) = SList [SAtom "bunify", valExprToSExpr a, valExprToSExpr b]+boolExprToSExpr (BFromVal e) = SList [SAtom "bfrom-val", valExprToSExpr e]+boolExprToSExpr (BEvalDeep e) = SList [SAtom "beval-deep", boolExprToSExpr e]++idExprToSExpr :: IdExpr -> SExpr+idExprToSExpr (IdVar n) = SList [SAtom "id-var", nameToSExpr n]+idExprToSExpr (CreateConstraint ct es) =+  SList (SAtom "create-constraint" : constraintTypeToSExpr ct : map valExprToSExpr es)++callArgToSExpr :: CallArg -> SExpr+callArgToSExpr (AVal e) = SList [SAtom "arg-val", valExprToSExpr e]+callArgToSExpr (AId e) = SList [SAtom "arg-id", idExprToSExpr e]++literalToSExpr :: Literal -> SExpr+literalToSExpr (IntLit n) = SList [SAtom "int", SInt n]+literalToSExpr (FloatLit n) = SList [SAtom "float", SFloat n]+literalToSExpr (AtomLit s) = SList [SAtom "atom", SString s]+literalToSExpr (TextLit s) = SList [SAtom "text", SString s]+literalToSExpr (BoolLit True) = SAtom "true"+literalToSExpr (BoolLit False) = SAtom "false"+literalToSExpr WildcardLit = SAtom "wildcard"++nameToSExpr :: Name -> SExpr+nameToSExpr (Name t) = SString t++labelToSExpr :: Label -> SExpr+labelToSExpr (Label t) = SString t++ruleIdToSExpr :: RuleId -> SExpr+ruleIdToSExpr (RuleId n) = SInt (fromIntegral n)++constraintTypeToSExpr :: ConstraintType -> SExpr+constraintTypeToSExpr (ConstraintType n) = SInt (fromIntegral n)++-- ---------------------------------------------------------------------------+-- Deserialization (SExpr → VM)+-- ---------------------------------------------------------------------------++type Err a = Either Text a++err :: Text -> Err a+err = Left++vmProgramFromSExpr :: SExpr -> Err VMProgram+vmProgramFromSExpr+  ( SList+      [ SAtom "vm-program",+        progS,+        SList (SAtom "exports" : exportSexprs),+        stS+        ]+    ) = do+    prog <- programFromSExpr progS+    exports <- traverse identFromSExpr exportSexprs+    st <- symbolTableFromSExpr stS+    pure VMProgram {program = prog, exportedSet = Set.fromList exports, symbolTable = st}+vmProgramFromSExpr s = err ("expected (vm-program ...), got: " <> printSExpr s)++symbolTableFromSExpr :: SExpr -> Err Types.SymbolTable+symbolTableFromSExpr (SList (SAtom "symbol-table" : entries)) = do+  pairs <- traverse entryFromSExpr entries+  pure (Types.mkSymbolTable pairs)+  where+    entryFromSExpr (SList [n, SInt arity, SInt ct]) = do+      name <- chrNameFromSExpr n+      pure (Types.Identifier name (fromInteger arity), Types.ConstraintType (fromInteger ct))+    entryFromSExpr s = err ("expected (name arity int), got: " <> printSExpr s)+symbolTableFromSExpr s = err ("expected (symbol-table ...), got: " <> printSExpr s)++identFromSExpr :: SExpr -> Err Types.QualifiedIdentifier+identFromSExpr (SList [n, SInt arity]) = do+  name <- chrNameFromSExpr n+  case name of+    Types.Qualified m t -> pure (Types.QualifiedIdentifier m t (fromInteger arity))+    Types.Unqualified t -> err ("expected qualified name in export, got: " <> t)+identFromSExpr s = err ("expected (name arity), got: " <> printSExpr s)++chrNameFromSExpr :: SExpr -> Err Types.Name+chrNameFromSExpr (SString t) = pure (Types.Unqualified t)+chrNameFromSExpr (SList [SAtom "qualified", SString m, SString t]) = pure (Types.Qualified m t)+chrNameFromSExpr s = err ("expected name, got: " <> printSExpr s)++programFromSExpr :: SExpr -> Err Program+programFromSExpr+  ( SList+      ( SAtom "program"+          : SInt n+          : SList (SAtom "type-names" : tnSexprs)+          : SInt nr+          : SList (SAtom "rule-names" : rnSexprs)+          : SList (SAtom "evaluables" : evSexprs)+          : procs+        )+    ) = do+    tns <- traverse chrNameFromSExpr tnSexprs+    rns <- traverse textFromSExpr rnSexprs+    evs <- traverse evaluableEntryFromSExpr evSexprs+    ps <- traverse procedureFromSExpr procs+    pure+      Program+        { numTypes = fromInteger n,+          typeNames = tns,+          numRules = fromInteger nr,+          ruleNames = rns,+          evaluables = evs,+          procedures = ps+        }+programFromSExpr s = err ("expected (program ...), got: " <> printSExpr s)++evaluableEntryFromSExpr :: SExpr -> Err (EvaluableKey, Name)+evaluableEntryFromSExpr (SList [fSexpr, SInt arity, pSexpr]) = do+  functor <- nameFromSExpr fSexpr+  procName <- nameFromSExpr pSexpr+  pure (EvaluableKey {functor = functor, arity = fromInteger arity}, procName)+evaluableEntryFromSExpr s = err ("expected evaluable entry, got: " <> printSExpr s)++textFromSExpr :: SExpr -> Err Text+textFromSExpr (SString t) = pure t+textFromSExpr s = err ("expected name string, got: " <> printSExpr s)++procedureFromSExpr :: SExpr -> Err Procedure+procedureFromSExpr+  (SList (SAtom "procedure" : SString nm : SList paramSexprs : kindSexpr : bodyExprs)) =+    do+      params' <- traverse nameFromSExpr paramSexprs+      kind' <- procKindFromSExpr kindSexpr+      body' <- traverse stmtFromSExpr bodyExprs+      pure+        Procedure+          { name = Name nm,+            params = params',+            body = body',+            procKind = kind'+          }+procedureFromSExpr s = err ("expected (procedure ...), got: " <> printSExpr s)++procKindFromSExpr :: SExpr -> Err ProcKind+procKindFromSExpr (SList [SAtom "tell", ct]) =+  PKTell <$> constraintTypeFromSExpr ct+procKindFromSExpr (SList [SAtom "activate", ct]) =+  PKActivate <$> constraintTypeFromSExpr ct+procKindFromSExpr (SList [SAtom "occurrence", ct, SInt n, rid, SString display]) =+  PKOccurrence+    <$> constraintTypeFromSExpr ct+    <*> pure (fromInteger n)+    <*> ruleIdFromSExpr rid+    <*> pure display+procKindFromSExpr (SList [SAtom "reactivate-dispatch"]) = pure PKReactivateDispatch+procKindFromSExpr (SList [SAtom "call-dispatch", SInt arity]) =+  pure (PKCallDispatch (fromInteger arity))+procKindFromSExpr (SList [SAtom "function", SString m, SString b, SInt arity]) =+  pure (PKFunction (Types.QualifiedName m b) (fromInteger arity))+procKindFromSExpr s = err ("expected proc-kind, got: " <> printSExpr s)++stmtFromSExpr :: SExpr -> Err Stmt+stmtFromSExpr (SList [SAtom "let-val", n, e]) =+  LetVal <$> nameFromSExpr n <*> valExprFromSExpr e+stmtFromSExpr (SList [SAtom "let-id", n, e]) =+  LetId <$> nameFromSExpr n <*> idExprFromSExpr e+stmtFromSExpr (SList [SAtom "assign-val", n, e]) =+  AssignVal <$> nameFromSExpr n <*> valExprFromSExpr e+stmtFromSExpr (SList [SAtom "assign-id", n, e]) =+  AssignId <$> nameFromSExpr n <*> idExprFromSExpr e+stmtFromSExpr (SList [SAtom "if", c, SList ts, SList es]) =+  If <$> boolExprFromSExpr c <*> traverse stmtFromSExpr ts <*> traverse stmtFromSExpr es+stmtFromSExpr (SList [SAtom "foreach", lbl, ct, sv, SList conds, SList body]) =+  Foreach+    <$> labelFromSExpr lbl+    <*> constraintTypeFromSExpr ct+    <*> nameFromSExpr sv+    <*> traverse condFromSExpr conds+    <*> traverse stmtFromSExpr body+stmtFromSExpr (SList [SAtom "continue", lbl]) = Continue <$> labelFromSExpr lbl+stmtFromSExpr (SList [SAtom "break", lbl]) = Break <$> labelFromSExpr lbl+stmtFromSExpr (SList [SAtom "return", e]) = Return <$> valExprFromSExpr e+stmtFromSExpr (SList [SAtom "expr-stmt", e]) = ExprStmt <$> valExprFromSExpr e+stmtFromSExpr (SList [SAtom "bool-expr-stmt", e]) = BoolExprStmt <$> boolExprFromSExpr e+stmtFromSExpr (SList [SAtom "store", e]) = Store <$> idExprFromSExpr e+stmtFromSExpr (SList [SAtom "kill", e]) = Kill <$> idExprFromSExpr e+stmtFromSExpr (SList (SAtom "add-history" : rid : es)) =+  AddHistory <$> ruleIdFromSExpr rid <*> traverse idExprFromSExpr es+stmtFromSExpr (SList (SAtom "drain-reactivation-queue" : sv : body)) =+  DrainReactivationQueue <$> nameFromSExpr sv <*> traverse stmtFromSExpr body+stmtFromSExpr+  ( SList+      [ SAtom "push-frame",+        SAtom label,+        SAtom lineStr,+        SAtom colStr,+        SAtom file,+        SAtom src+        ]+    ) =+    case (readMaybe (T.unpack lineStr), readMaybe (T.unpack colStr)) of+      (Just l, Just c) ->+        pure $ PushFrame $ StackFrame label (SourceLoc (T.unpack file) l c) src+      _ -> err "push-frame: invalid line/col"+stmtFromSExpr s = err ("expected statement, got: " <> printSExpr s)++valExprFromSExpr :: SExpr -> Err ValExpr+valExprFromSExpr (SList [SAtom "var", n]) = Var <$> nameFromSExpr n+valExprFromSExpr (SList [SAtom "int", SInt n]) = pure (Lit (IntLit n))+valExprFromSExpr (SList [SAtom "float", SFloat n]) = pure (Lit (FloatLit n))+valExprFromSExpr (SList [SAtom "atom", SString s]) = pure (Lit (AtomLit s))+valExprFromSExpr (SList [SAtom "text", SString s]) = pure (Lit (TextLit s))+valExprFromSExpr (SAtom "true") = pure (Lit (BoolLit True))+valExprFromSExpr (SAtom "false") = pure (Lit (BoolLit False))+valExprFromSExpr (SAtom "wildcard") = pure (Lit WildcardLit)+valExprFromSExpr (SList (SAtom "call-expr" : n : es)) =+  CallExpr <$> nameFromSExpr n <*> traverse callArgFromSExpr es+valExprFromSExpr (SList (SAtom "host-call" : n : es)) =+  HostCall <$> nameFromSExpr n <*> traverse valExprFromSExpr es+valExprFromSExpr (SList [SAtom "eval-deep", e]) = EvalDeep <$> valExprFromSExpr e+valExprFromSExpr (SList [SAtom "eval-is", e]) = EvalIs <$> valExprFromSExpr e+valExprFromSExpr (SAtom "new-var") = pure NewVar+valExprFromSExpr (SList (SAtom "make-term" : n : es)) =+  MakeTerm <$> nameFromSExpr n <*> traverse valExprFromSExpr es+valExprFromSExpr (SList [SAtom "get-arg", e, SInt i]) =+  GetArg <$> valExprFromSExpr e <*> pure (fromInteger i)+valExprFromSExpr (SList [SAtom "field-arg", e, SInt i]) =+  FieldArg <$> idExprFromSExpr e <*> pure (ArgIndex (fromInteger i))+valExprFromSExpr (SList [SAtom "field-type", e]) =+  FieldType <$> idExprFromSExpr e+valExprFromSExpr s = err ("expected value expression, got: " <> printSExpr s)++boolExprFromSExpr :: SExpr -> Err BoolExpr+boolExprFromSExpr (SAtom "btrue") = pure (BLit True)+boolExprFromSExpr (SAtom "bfalse") = pure (BLit False)+boolExprFromSExpr (SList [SAtom "bnot", e]) = BNot <$> boolExprFromSExpr e+boolExprFromSExpr (SList [SAtom "band", a, b]) =+  BAnd <$> boolExprFromSExpr a <*> boolExprFromSExpr b+boolExprFromSExpr (SList [SAtom "bor", a, b]) =+  BOr <$> boolExprFromSExpr a <*> boolExprFromSExpr b+boolExprFromSExpr (SList [SAtom "bmatch-term", e, n, SInt a]) =+  BMatchTerm <$> valExprFromSExpr e <*> nameFromSExpr n <*> pure (fromInteger a)+boolExprFromSExpr (SList [SAtom "bequal", a, b]) =+  BEqual <$> valExprFromSExpr a <*> valExprFromSExpr b+boolExprFromSExpr (SList [SAtom "bid-equal", a, b]) =+  BIdEqual <$> idExprFromSExpr a <*> idExprFromSExpr b+boolExprFromSExpr (SList [SAtom "balive", e]) = BAlive <$> idExprFromSExpr e+boolExprFromSExpr (SList [SAtom "bis-constraint-type", e, ct]) =+  BIsConstraintType <$> idExprFromSExpr e <*> constraintTypeFromSExpr ct+boolExprFromSExpr (SList (SAtom "bnot-in-history" : rid : es)) =+  BNotInHistory <$> ruleIdFromSExpr rid <*> traverse idExprFromSExpr es+boolExprFromSExpr (SList [SAtom "bunify", a, b]) =+  BUnify <$> valExprFromSExpr a <*> valExprFromSExpr b+boolExprFromSExpr (SList [SAtom "bfrom-val", e]) = BFromVal <$> valExprFromSExpr e+boolExprFromSExpr (SList [SAtom "beval-deep", e]) = BEvalDeep <$> boolExprFromSExpr e+boolExprFromSExpr s = err ("expected boolean expression, got: " <> printSExpr s)++idExprFromSExpr :: SExpr -> Err IdExpr+idExprFromSExpr (SList [SAtom "id-var", n]) = IdVar <$> nameFromSExpr n+idExprFromSExpr (SList (SAtom "create-constraint" : ct : es)) =+  CreateConstraint <$> constraintTypeFromSExpr ct <*> traverse valExprFromSExpr es+idExprFromSExpr s = err ("expected id expression, got: " <> printSExpr s)++callArgFromSExpr :: SExpr -> Err CallArg+callArgFromSExpr (SList [SAtom "arg-val", e]) = AVal <$> valExprFromSExpr e+callArgFromSExpr (SList [SAtom "arg-id", e]) = AId <$> idExprFromSExpr e+callArgFromSExpr s = err ("expected call argument, got: " <> printSExpr s)++condFromSExpr :: SExpr -> Err (ArgIndex, ValExpr)+condFromSExpr (SList [SInt i, e]) = (ArgIndex (fromInteger i),) <$> valExprFromSExpr e+condFromSExpr s = err ("expected (index expr), got: " <> printSExpr s)++nameFromSExpr :: SExpr -> Err Name+nameFromSExpr (SString t) = pure (Name t)+nameFromSExpr s = err ("expected string (name), got: " <> printSExpr s)++labelFromSExpr :: SExpr -> Err Label+labelFromSExpr (SString t) = pure (Label t)+labelFromSExpr s = err ("expected string (label), got: " <> printSExpr s)++ruleIdFromSExpr :: SExpr -> Err RuleId+ruleIdFromSExpr (SInt n) = pure (RuleId (fromInteger n))+ruleIdFromSExpr s = err ("expected int (rule id), got: " <> printSExpr s)++constraintTypeFromSExpr :: SExpr -> Err ConstraintType+constraintTypeFromSExpr (SInt n) = pure (ConstraintType (fromInteger n))+constraintTypeFromSExpr s = err ("expected int (constraint type), got: " <> printSExpr s)
+ src/YCHR/Internal/VM/Types.hs view
@@ -0,0 +1,425 @@+-- | CHR Virtual Machine — type definitions.+--+-- This module defines the abstract VM that serves as the intermediate+-- representation for the CHR compiler. The VM is a small imperative+-- language with domain-specific instructions for CHR constraint store+-- operations, logical variables, term manipulation, and propagation+-- history management.+--+-- Architecture:+--+--   CHR source (Prolog-compatible syntax)+--     → CHR compiler (Haskell)+--       → VM program (this representation)+--         → Backend: JavaScript code + JS runtime+--         → Backend: Scheme code + Scheme runtime+--         → Backend: Haskell interpreter + Haskell runtime+--+-- Design principles:+--+--   1. The VM instruction set is the complete interface between the+--      compiler and the runtime. The compiler never emits calls to+--      runtime functions by name.+--+--   2. CallExpr is used exclusively for calling compiler-generated+--      procedures (occurrence procedures, activate, tell, etc.).+--+--   3. HostCall is used for calling host language functions (arithmetic,+--      user-written guards and body expressions, etc.).+--+--   4. Logical variables and algebraic terms are opaque values from the+--      VM's perspective. The runtime provides NewVar, Unify, Equal,+--      MakeTerm, MatchTerm, and GetArg as primitives.+--+--   5. Recursion optimizations (trampolining, explicit stack) are the+--      responsibility of each backend, not the VM.+--+--   6. Expressions are split by the kind of value they produce:+--      'ValExpr' produces an ordinary 'Value' (the unification domain),+--      'IdExpr' produces a constraint identifier, and 'BoolExpr'+--      produces a boolean. Constraint identifiers cannot flow into+--      unification or term construction; the operands of conditionals+--      and short-circuiting operators are statically booleans. The+--      bridge from 'ValExpr' to 'BoolExpr' is the explicit 'BFromVal'+--      constructor, which carries a runtime check at the boundary.+module YCHR.Internal.VM.Types+  ( -- * Program structure+    Program (..),+    Procedure (..),+    ProcKind (..),+    EvaluableKey (..),++    -- * Statements+    Stmt (..),++    -- * Expressions+    ValExpr (..),+    IdExpr (..),+    BoolExpr (..),+    CallArg (..),++    -- * Runtime call stack frames+    StackFrame (..),++    -- * Supporting types+    ConstraintType (..),+    RuleId (..),+    Literal (..),+    ArgIndex (..),+    Name (..),+    Label (..),+  )+where++import Data.String (IsString (..))+import Data.Text (Text)+import Data.Text qualified as T+import YCHR.Internal.Loc (SourceLoc)+import YCHR.Internal.Types (ConstraintType (..), RuleId (..))+import YCHR.Internal.Types qualified as Types++-- | A runtime call stack frame.+--+-- Emitted by the compiler at rule fire and function entry points.+-- The interpreter maintains a stack of these for error reporting.+data StackFrame = StackFrame+  { -- | Human-readable label (e.g. @"rule transitivity"@ or @"function factorial\/1"@).+    frameLabel :: Text,+    -- | Source file location.+    frameSourceLoc :: SourceLoc,+    -- | Pretty-printed source code (from the parsed expression).+    frameSourceCode :: Text+  }+  deriving (Show, Eq)++-- | A VM program is a collection of named procedures.+data Program = Program+  { -- | Number of distinct constraint types (for pre-allocating the store).+    numTypes :: !Int,+    -- | Source names of constraint types, indexed by the 'ConstraintType'+    -- integer. @typeNames !! i@ is the structured source name of the+    -- type with index @i@. Used by runtime introspection (e.g.+    -- @print_store@) and preserved across VM serialization.+    typeNames :: ![Types.Name],+    -- | Number of rules in the program.+    numRules :: !Int,+    -- | Display names of rules, indexed by the 'RuleId' integer.+    -- @ruleNames !! i@ is the source name (or synthetic @__rule_N@+    -- fallback for anonymous rules) of the rule with id @i@. Used+    -- by runtime introspection and preserved across VM serialization.+    ruleNames :: ![Text],+    -- | The procedures that make up the program.+    procedures :: [Procedure],+    -- | Dispatch table for the @is@ deep-evaluator. Maps a+    -- @(functor, arity)@ key (as found on a @VTerm@) to the+    -- mangled procedure name in 'procedures'. One entry per+    -- user-defined function (prelude host calls are handled by+    -- the runtime's host-call registry, which is bare-functor+    -- keyed). Used by the runtime to call into user-defined+    -- functions when @is@ walks a dereferenced compound term.+    evaluables :: ![(EvaluableKey, Name)]+  }+  deriving (Show, Eq)++-- | Dispatch key for the @is@ deep-evaluator. Parallel in structure+-- to 'YCHR.Internal.Types.Identifier', but carries the VM-encoded form of the+-- functor (the same text stored on @VTerm@ values), so dispatch is+-- a direct map lookup with no need to invert+-- 'YCHR.Internal.Compile.Names.encodeText'.+data EvaluableKey = EvaluableKey+  { functor :: !Name,+    arity :: !Int+  }+  deriving (Show, Eq, Ord)++-- | A named procedure with parameters and a body.+--+-- The compiler generates procedures for:+--   * @tell_c@: adding a constraint from host language or rule bodies+--   * @activate_c@: trying all occurrences for a constraint+--   * @occurrence_c_j@: checking one occurrence of a constraint+--   * @reactivate_dispatch@: dispatching reactivation by constraint type+--+-- Note: @reactivate_all@ (paper §5.1–5.2) is not generated.  YCHR+-- implements the /Selective Constraint Reactivation/ optimization+-- (paper §5.3, observer pattern): 'Store' registers constraints as+-- observers of their arguments, 'Unify' populates the reactivation+-- queue for affected constraints, and 'DrainReactivationQueue'+-- processes only those constraints.+data Procedure = Procedure+  { -- | Procedure name+    name :: Name,+    -- | Parameter names+    params :: [Name],+    -- | Body statements+    body :: [Stmt],+    -- | Structural classification of the procedure. The compiler sets+    -- this at the (single) construction site; the interpreter reads it+    -- to label trace events without re-parsing the mangled name.+    -- Backends that don't care about tracing simply ignore the field.+    procKind :: !ProcKind+  }+  deriving (Show, Eq)++-- | Structural classification of a generated 'Procedure'.+--+-- Used by the interpreter's tracer (`:trace` in the REPL) to label+-- events with their ωr role without parsing the procedure's mangled+-- name. Each constructor carries the source-level data the tracer+-- needs to render readable output.+--+-- Lifted lambdas use 'PKFunction' with a name beginning with+-- @__lambda_@; the trace formatter recognises the prefix and renders+-- them as @lambda#N@.+data ProcKind+  = -- | @tell_c@: entry point for adding a constraint.+    PKTell !ConstraintType+  | -- | @activate_c@: try all occurrences for a constraint.+    PKActivate !ConstraintType+  | -- | @occurrence_c_j@: the @j@-th occurrence of constraint @c@,+    -- belonging to the rule identified by 'RuleId'. The display name+    -- is carried alongside so the tracer can label events without a+    -- second lookup into 'Program.ruleNames'.+    PKOccurrence !ConstraintType !Int !RuleId !Text+  | -- | @reactivate_dispatch@: route a reactivated constraint to its+    -- @activate_c@.+    PKReactivateDispatch+  | -- | @call_N@: dispatcher for @'$call'/N@.+    PKCallDispatch !Int+  | -- | A user-defined function or lifted lambda. Carries the source+    -- qualified name and arity.+    PKFunction !Types.QualifiedName !Int+  deriving (Show, Eq)++-- | Statements (imperative, side-effecting).+data Stmt+  = -- General control flow++    -- | Bind a local variable to the result of a value expression.+    LetVal Name ValExpr+  | -- | Bind a local variable to the result of an id expression.+    LetId Name IdExpr+  | -- | Mutate an existing value-bound variable.+    AssignVal Name ValExpr+  | -- | Mutate an existing id-bound variable.+    AssignId Name IdExpr+  | -- | Conditional: condition, then-branch, else-branch.+    If BoolExpr [Stmt] [Stmt]+  | -- | Labeled loop over constraint store.+    --+    -- @Foreach label constraintType suspVar indexConditions body@+    --+    -- Iterates over all stored constraints of the given type that+    -- satisfy the index conditions. Each condition @(i, expr)@ requires+    -- that argument @i@ of the constraint is 'Equal' to @expr@.+    --+    -- The current constraint suspension is bound to @suspVar@ in each+    -- iteration; references it via 'IdVar' inside the body, and use+    -- 'FieldArg'/'FieldType' to access its fields.+    --+    -- The iterator must satisfy the robustness, correctness,+    -- completeness, and weak termination properties as specified+    -- in the CHR compilation literature.+    Foreach Label ConstraintType Name [(ArgIndex, ValExpr)] [Stmt]+  | -- | Jump to the next iteration of the labeled 'Foreach' loop.+    Continue Label+  | -- | Exit the labeled 'Foreach' loop.+    Break Label+  | -- | Return a value from the current procedure.+    Return ValExpr+  | -- | Evaluate a value expression for its side effects, discard the result.+    ExprStmt ValExpr+  | -- | Evaluate a boolean expression for its side effects, discard the result.+    BoolExprStmt BoolExpr+  | -- Constraint store operations++    -- | Add a constraint suspension to the constraint store.+    -- The argument is a constraint identifier (as returned+    -- by 'CreateConstraint'). This also registers the constraint+    -- as an observer of its arguments for reactivation purposes.+    Store IdExpr+  | -- | Remove a constraint from the constraint store and mark it+    -- as no longer alive.+    Kill IdExpr+  | -- Propagation history++    -- | Record that a rule has fired with the given combination+    -- of constraint identifiers, to prevent redundant re-firing+    -- of propagation rules.+    AddHistory RuleId [IdExpr]+  | -- Reactivation++    -- | Process all constraints pending reactivation.+    --+    -- @DrainReactivationQueue suspVar body@+    --+    -- Iterates over the reactivation queue (populated as a side+    -- effect of 'Unify'), binding each pending constraint suspension+    -- to @suspVar@ (referenced via 'IdVar') and executing @body@.+    -- The body typically dispatches to the appropriate @activate_c@+    -- procedure based on constraint type.+    DrainReactivationQueue Name [Stmt]+  | -- Call stack frames++    -- | Push a frame onto the runtime call stack.+    -- Emitted by the compiler at rule fire and function entry points.+    -- The interpreter automatically pops frames when a procedure+    -- returns (save\/restore around 'callProc').+    PushFrame StackFrame+  deriving (Show, Eq)++-- | Value-producing expressions: everything that evaluates to an+-- ordinary 'Value' from the unification domain.+data ValExpr+  = -- | Reference to a value-bound variable (local or parameter).+    Var Name+  | -- | A literal value.+    Lit Literal+  | -- | Call a compiler-generated procedure and return its result.+    CallExpr Name [CallArg]+  | -- | Call a host language function. Used for arithmetic operators,+    -- comparisons, and user-written expressions in guards and bodies.+    -- Host functions return values; they cannot return constraint+    -- identifiers.+    HostCall Name [ValExpr]+  | -- | Switch evaluation into deep deref-aware mode for the nested+    -- expression: 'Var' references are dereferenced (following binding+    -- chains) before use, and this mode propagates recursively into+    -- sub-expressions ('CallExpr', 'MakeTerm', etc.). Used for guard+    -- expressions and the non-'Var' right-hand sides of @is@.+    EvalDeep ValExpr+  | -- | The @is@-with-variable-RHS case: evaluate the nested expression+    -- in deep-deref mode and then walk the resulting 'Value',+    -- evaluating any compound subterm whose @(functor, arity)@ names+    -- a declared evaluable. Emitted only by 'compileBodyGoal' for+    -- @D.BodyIs v expr@ when @expr@ is syntactically a variable; this+    -- is the marker that makes the walker fire for @R is X@ without+    -- affecting guards or other 'EvalDeep' use sites. See the+    -- "Variable RHS in @is@" subsection of the type-system reference.+    EvalIs ValExpr+  | -- Logical variables++    -- | Create a fresh unbound logical variable.+    NewVar+  | -- Term operations++    -- | Construct a compound term: @MakeTerm functor args@.+    MakeTerm Name [ValExpr]+  | -- | Extract an argument from a compound term by index (0-based).+    GetArg ValExpr Int+  | -- Suspension field access++    -- | Extract a constraint argument from a suspension by index.+    FieldArg IdExpr ArgIndex+  | -- | Extract the constraint type tag from a suspension.+    FieldType IdExpr+  deriving (Show, Eq)++-- | Boolean-producing expressions. Operands of 'If', 'BNot', 'BAnd',+-- and 'BOr' are statically booleans, so the interpreter never has to+-- runtime-check the shape of a boolean condition. The 'BFromVal'+-- constructor is the explicit bridge for a 'ValExpr' (typically a+-- user-defined function call or an arbitrary host call) used in+-- boolean position; it carries a runtime shape check at evaluation.+data BoolExpr+  = -- | Boolean literal.+    BLit Bool+  | -- | Logical negation.+    BNot BoolExpr+  | -- | Logical conjunction (short-circuiting).+    BAnd BoolExpr BoolExpr+  | -- | Logical disjunction (short-circuiting).+    BOr BoolExpr BoolExpr+  | -- | Check whether a value is a compound term with the given+    -- functor and arity: @BMatchTerm expr functor arity@.+    BMatchTerm ValExpr Name Int+  | -- | Check equality of two terms (ask semantics). No mutation.+    -- Uses Prolog @==@ semantics: two distinct unbound variables+    -- are not equal.+    BEqual ValExpr ValExpr+  | -- | Compare two constraint identifiers for equality.+    BIdEqual IdExpr IdExpr+  | -- | Check whether a constraint (identified by its constraint+    -- identifier) is still alive in the constraint store.+    BAlive IdExpr+  | -- | Check whether a constraint suspension has the given type.+    -- Used for dispatching in the reactivation procedure.+    BIsConstraintType IdExpr ConstraintType+  | -- | Check that a rule has not previously fired with the given+    -- combination of constraint identifiers.+    BNotInHistory RuleId [IdExpr]+  | -- | Unify two terms (tell semantics). Returns a boolean indicating+    -- success. May mutate logical variables as a side effect. On+    -- success, also pushes affected constraints onto the reactivation+    -- queue (see 'DrainReactivationQueue').+    BUnify ValExpr ValExpr+  | -- | Bridge from 'ValExpr' to 'BoolExpr'. Used for value expressions+    -- whose result the compiler cannot statically prove is a boolean+    -- (e.g. user-defined function calls in guards, host calls whose+    -- return kind isn't recorded). Runtime-checks that the wrapped+    -- value evaluates to 'VBool'.+    BFromVal ValExpr+  | -- | Switch evaluation into deep deref-aware mode for the nested+    -- boolean expression. Mirrors 'EvalDeep' for 'BoolExpr': any+    -- 'ValExpr' or 'IdExpr' payloads inside the nested expression+    -- are evaluated in deep-deref mode.+    BEvalDeep BoolExpr+  deriving (Show, Eq)++-- | Constraint-identifier-producing expressions.+--+-- Constraint identifiers are produced in only three ways: by+-- 'CreateConstraint', by referencing an id-bound variable+-- ('IdVar' — populated by the parameter list, 'Foreach',+-- 'DrainReactivationQueue', or a 'LetId' binding), or by+-- a procedure that returns one (currently no such procedure+-- is generated, but the constructor is reserved).+data IdExpr+  = -- | Reference to an id-bound variable (local or parameter).+    IdVar Name+  | -- | Create a new constraint suspension with the given type and+    -- arguments. Returns a constraint identifier. The constraint+    -- is not yet stored; use 'Store' to add it to the constraint store.+    CreateConstraint ConstraintType [ValExpr]+  deriving (Show, Eq)++-- | Procedure-call argument. Procedures may take a heterogeneous+-- mix of value and id parameters; this wrapper makes the kind+-- explicit at every call site.+data CallArg+  = AVal ValExpr+  | AId IdExpr+  deriving (Show, Eq)++-- | Literal values.+data Literal+  = -- | Integer literal. Arbitrary precision; the runtime carries+    -- 'Integer' end to end so user programs cannot silently overflow.+    IntLit Integer+  | -- | Floating-point literal.+    FloatLit Double+  | -- | Atom literal (symbolic constant).+    AtomLit Text+  | -- | Text (string) literal.+    TextLit Text+  | -- | Boolean literal.+    BoolLit Bool+  | -- | Wildcard literal: evaluates to 'VWildcard'.+    WildcardLit+  deriving (Show, Eq)++-- | Zero-based index into a constraint's argument list.+newtype ArgIndex = ArgIndex Int+  deriving (Show, Eq)++-- | Variable or procedure name.+newtype Name = Name {unName :: Text}+  deriving (Show, Eq, Ord)++instance IsString Name where fromString = Name . T.pack++-- | Label for 'Foreach' loops, used with 'Continue' and 'Break'.+newtype Label = Label {unLabel :: Text}+  deriving (Show, Eq, Ord)++instance IsString Label where fromString = Label . T.pack
+ src/YCHR/Run.hs view
@@ -0,0 +1,725 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Top-level orchestration: compile a program, then run goals or+-- multi-goal queries against it. The CHR session machinery lives in+-- "YCHR.Internal.Runtime.Session"; the compilation pipeline lives in+-- "YCHR.Internal.Compile.Pipeline". This module ties the two together and+-- adds the query-time goal evaluator used by 'runProgramWithQuery'+-- and the live REPL session in "YCHR.Internal.Repl".+module YCHR.Run+  ( -- * Compilation (re-exported from "YCHR.Internal.Compile.Pipeline")+    Error (..),+    GoalRejection (..),+    Warning (..),+    CompiledProgram,+    compileModules,+    compileFiles,+    compileParsedModules,++    -- * Rendering diagnostics+    displayError,+    displayWarning,++    -- * Running goals+    runProgramWithGoal,+    runProgramWithGoalDSL,+    runProgramWithQuery,++    -- * CHR sessions+    Chr,+    withCHR,+    withTraceHandler,+    tellConstraint,++    -- * Runtime values+    Value (..),+    newVar,+    deref,+    equal,+    unify,++    -- * Query pipeline+    -- $queryPipeline+    ExportResolution (..),+    resolveQueryConstraint,+    resolveQueryTellOrThrow,+    prepareGoal,+    goalShapeConstraint,+    runPreparedGoal,+    PreparedQuery (..),+    prepareQuery,+    executePreparedQuery,+    withCHRExtraTraced,+    toSessionInput,+  )+where++import Control.Exception+  ( SomeAsyncException,+    SomeException,+    displayException,+    fromException,+    handle,+    throwIO,+    try,+  )+import Control.Monad (unless, void, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ask, runReaderT)+import Control.Monad.Trans.State.Strict (StateT, evalStateT, get, modify)+import Control.Monad.Trans.Writer.CPS (runWriter)+import Data.IORef (readIORef)+import Data.List.NonEmpty (NonEmpty (..))+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import YCHR.Internal.Compile+  ( compileFunctionDef,+    funcProcName,+    genCallFunDispatches,+    vmName,+  )+import YCHR.Internal.Compile.Pipeline+  ( CompiledProgram (..),+    Error (..),+    ExportResolution (..),+    GoalRejection (..),+    Warning (..),+    compileFiles,+    compileModules,+    compileParsedModules,+  )+import YCHR.Internal.Desugar (desugarQueryGoals, liftQueryLambdas)+import YCHR.Internal.Desugared qualified as D+import YCHR.Internal.Diagnostic (Diagnostic)+import YCHR.Internal.Display (displayMsg)+import YCHR.Internal.Meta (valueToTerm)+import YCHR.Internal.PExpr (PExpr (Atom))+import YCHR.Internal.Parsed (AnnP (..), SourceLoc (..))+import YCHR.Internal.Parser (ParseValidationError (..), parseConstraintWith, parseQueryWith)+import YCHR.Internal.Pretty (prettyPExprSrc, prettyTerm)+import YCHR.Internal.Rename (renameQueryArgs, renameQueryGoals)+import YCHR.Internal.Resolve (ResolveError, termToExpr)+import YCHR.Internal.Resolved qualified as R+import YCHR.Internal.Runtime.Error (RuntimeErrorThrown (..), runtimeErrorS)+import YCHR.Internal.Runtime.Interpreter+  ( HostCallFn (..),+    HostCallRegistry,+    callProc,+    constraintTypeLabel,+    deepEvalValue,+    emitTrace,+    snapshotValue,+    snapshotValues,+    suspensionView,+  )+import YCHR.Internal.Runtime.Monad (Chr, SessionEnv (..))+import YCHR.Internal.Runtime.Reactivation (drainQueue, enqueue)+import YCHR.Internal.Runtime.Session+  ( tellConstraint,+    toSessionInput,+    withCHR,+    withCHRExtra,+    withCHRExtraTraced,+    withTraceHandler,+  )+import YCHR.Internal.Runtime.Store (aliveConstraint)+import YCHR.Internal.Runtime.Trace (TraceEvent (..))+import YCHR.Internal.Runtime.Types (CallVal (..), Value (..), VarId)+import YCHR.Internal.Runtime.Var (deref, equal, getVarId, newVar, unify)+import YCHR.Internal.TypeCheck (typeCheckGoals)+import YCHR.Internal.Types (Constraint (..), Term (..))+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM (Name (..), Procedure (..))++-- ---------------------------------------------------------------------------+-- Single-goal API+-- ---------------------------------------------------------------------------++-- | Resolve a query constraint against the export map. The resolved+-- form is a 'Types.QualifiedConstraint' since name resolution always+-- produces a fully-qualified name. On failure, returns a structured+-- 'GoalRejection' so 'resolveQueryTellOrThrow' can surface a+-- @YCHR-NNNNN@-coded diagnostic. The rejection only covers+-- name-resolution failures; the post-resolution check that the+-- resolved name actually refers to a constraint (and not a function)+-- lives in 'resolveQueryTellOrThrow', which has the desugared program+-- in hand.+resolveQueryConstraint ::+  CompiledProgram ->+  Constraint ->+  Either GoalRejection Types.QualifiedConstraint+resolveQueryConstraint cp (Constraint cname cargs) = case cname of+  Types.Unqualified n ->+    let arity = length cargs+     in case Map.lookup (Types.UnqualifiedIdentifier n arity) cp.exportMap of+          Just (UniqueExport qname) ->+            Right (Types.QualifiedConstraint qname cargs)+          Just (AmbiguousExport ms) ->+            Left (AmbiguousConstraint ms)+          Nothing -> Left NoSuchConstraint+  Types.Qualified m n ->+    let arity = length cargs+     in if Set.member (Types.QualifiedIdentifier m n arity) cp.exportedSet+          then Right (Types.QualifiedConstraint (Types.QualifiedName m n) cargs)+          else Left (ConstraintNotExported (Types.QualifiedName m n))++-- | Resolve a query constraint to its qualified name and 'Expr'-typed+-- arguments. The arguments are lifted from the surface 'Term' shape via+-- 'termToExpr', so they are evaluated like any other tell-side+-- argument when the goal runs. The outer 'Either' carries+-- name-resolution failures (in the same string format as+-- 'resolveQueryConstraint'); the inner diagnostic list collects any+-- non-fatal resolve errors emitted while typing the arguments.+resolveQueryTell ::+  CompiledProgram ->+  Constraint ->+  Either GoalRejection ((Types.QualifiedName, [R.Expr]), [Diagnostic ResolveError])+resolveQueryTell cp c = do+  qc <- resolveQueryConstraint cp c+  let (exprs, errs) =+        runWriter+          (traverse (termToExpr cp.queryFunctionVisibility queryLoc queryOrigin) qc.args)+  pure ((qc.name, exprs), errs)++-- | Run a single CHR constraint against a compiled program. Returns+-- the per-query variable bindings.+runProgramWithGoalDSL ::+  CompiledProgram ->+  HostCallRegistry ->+  Constraint ->+  IO (Map Text Term)+runProgramWithGoalDSL cp hostCalls constraint = convertRuntimeError $ do+  (qn, exprs) <- resolveQueryTellOrThrow cp constraint+  let (lifted, lambdas, liftErrs) =+        liftQueryLambdas cp.nextLambdaIndex [D.BodyTell qn exprs]+  unless (null liftErrs) (throwIO (DesugarErrors liftErrs))+  let queryProcs = compileQueryLambdas lambdas+      allFuns = cp.allFunctions ++ lambdas+      queryDispatches = genCallFunDispatches allFuns+      extraProcs = queryProcs ++ queryDispatches+  withCHRExtra (toSessionInput cp) hostCalls extraProcs $+    executePreparedQuery lifted++-- | Resolve a goal and throw on any failure. Used by both+-- 'runProgramWithGoalDSL' and 'runPreparedGoal'.+--+-- A name-resolution failure (or a name that resolves to a function+-- rather than a constraint) becomes 'GoalNotAConstraint', so the CLI's+-- single-constraint goal surface surfaces a @YCHR-20013@ diagnostic+-- with a hint pointing at the REPL.+resolveQueryTellOrThrow ::+  CompiledProgram -> Constraint -> IO (Types.QualifiedName, [R.Expr])+resolveQueryTellOrThrow cp c = case resolveQueryTell cp c of+  Left rejection -> throwIO (GoalNotAConstraint c rejection)+  Right ((qn, exprs), errs)+    | not (Map.member qn cp.desugaredProgram.constraintTypes) ->+        throwIO (GoalNotAConstraint c (NotAConstraintItem qn))+    | otherwise -> do+        unless (null errs) (throwIO (ResolveErrors errs))+        pure (qn, exprs)++queryLoc :: SourceLoc+queryLoc = SourceLoc "<query>" 1 1++queryOrigin :: PExpr+queryOrigin = Atom ""++-- $queryPipeline+-- The staged internals behind 'runProgramWithGoal' and+-- 'runProgramWithQuery': resolve a goal, prepare it, then execute it.+-- They exist so the REPL can interleave its own work between the+-- stages, and are exported for the same reason the @YCHR.Internal@+-- modules are.+--+-- __These are not covered by the package version policy.__ Several of+-- them mention types from @YCHR.Internal.*@ in their signatures, which+-- is the giveaway. Use 'runProgramWithGoal', 'runProgramWithQuery', or+-- the typed wrappers in "YCHR.Convert" unless you specifically need to+-- drive the stages yourself.++-- | Render an 'Error' the way the @ychr@ command-line tool does:+-- @file:line:col:@ prefix, the @YCHR-NNNNN@ code, the message, and the+-- offending source line where one is available.+--+-- Prefer this to 'show': the derived 'Show' instance dumps the internal+-- diagnostic representation, whereas this is the supported, stable+-- rendering. The @YCHR-NNNNN@ codes are covered by the package version+-- policy and catalogued in+-- <https://github.com/lortabac/ychr/blob/master/docs/reference/errors.md>.+--+-- The result is a 'String' (not 'Data.Text.Text') because it is meant to+-- go straight to a handle:+--+-- > case compileModules True mods of+-- >   Left err -> hPutStr stderr (displayError err)+-- >   Right (cp, ws) -> mapM_ (hPutStr stderr . displayWarning) ws >> ...+--+-- __The result contains ANSI colour escapes__, unconditionally — there is+-- no terminal detection and no @NO_COLOR@ handling yet. That suits a+-- terminal, but strip them before putting the string in a log file, a JSON+-- payload, or a test assertion.+displayError :: Error -> String+displayError = displayMsg++-- | Render a 'Warning' in the same format as 'displayError'.+displayWarning :: Warning -> String+displayWarning = displayMsg++-- | Re-throw 'RuntimeErrorThrown' (from the runtime layer) as the+-- user-facing 'RuntimeError' constructor of 'Error'. Applied at the+-- top-level IO entry points so callers can pattern-match a single+-- exception type ('Error') without depending on the runtime's+-- internal exception.+convertRuntimeError :: IO a -> IO a+convertRuntimeError = handle $ \(RuntimeErrorThrown msg stack) ->+  throwIO (RuntimeError msg stack)++-- | 'Chr'-flavored version of 'convertRuntimeError', applied at the+-- 'executePreparedQuery' boundary so the REPL's catch helpers see a+-- uniform 'Error' value regardless of which path raised it.+convertRuntimeErrorChr :: Chr a -> Chr a+convertRuntimeErrorChr m = do+  env <- ask+  liftIO $+    handle (\(RuntimeErrorThrown msg stack) -> throwIO (RuntimeError msg stack)) $+      runReaderT m env++-- | Parse and rename a goal, returning the canonicalized 'Constraint'+-- alongside any rename warnings. Throws on parse or rename errors.+-- Splitting this out lets the CLI surface goal-argument warnings before+-- the goal runs (notably for @--Werror@).+prepareGoal :: CompiledProgram -> Text -> IO (Constraint, [Warning])+prepareGoal cp src = case parseConstraintWith cp.opTable "<query>" src of+  Left err -> throwIO (ParseError "<query>" err)+  Right parsed -> case either goalShapeConstraint Right parsed of+    Left validErr -> throwIO (ParseValidationErrors [validErr])+    Right (Constraint cname cargs) -> do+      (renamedArgs, ws) <-+        either+          (throwIO . RenameErrors)+          pure+          (renameQueryArgs cp.allModules cargs)+      let warnings = [RenameWarnings ws | not (null ws)]+      pure (Constraint cname renamedArgs, warnings)++-- | Recover a 'Constraint' from a goal-parse validation error.+-- 'convertConstraint' rejects goals that are not constraint-shaped (a+-- bare literal, variable, or wildcard) with 'MalformedConstraint'. For a+-- /goal/ (unlike a rule head) this is the same failure category as+-- @1 + 1@ or @a, b@: synthesize a 0-arity goal name from the offending+-- term so the normal name-resolution path rejects it as+-- 'NoSuchConstraint' (YCHR-20013) at the same stage and with the same+-- code as other non-constraint goals — mirroring how the bare-atom goal+-- @true@ renders as @Goal \'true\/0\'@ — instead of the YCHR-15003+-- 'MalformedConstraint' reserved for malformed rule heads. The catch-all+-- keeps any other validation error (none are emitted today) on its+-- original path.+goalShapeConstraint ::+  AnnP ParseValidationError -> Either (AnnP ParseValidationError) Constraint+goalShapeConstraint (AnnP MalformedConstraint _ pexpr) =+  Right (Constraint (Types.Unqualified (T.pack (prettyPExprSrc pexpr))) [])+goalShapeConstraint other = Left other++-- | Type-check and run a previously prepared single-goal constraint.+-- Throws 'TypeErrors' on goal-time type errors. Returns the per-query+-- variable bindings.+runPreparedGoal ::+  CompiledProgram ->+  HostCallRegistry ->+  Constraint ->+  IO (Map Text Term)+runPreparedGoal cp hostCalls original = do+  tcErrs <- case resolveQueryTell cp original of+    Right ((qn, exprs), errs)+      | null errs ->+          typeCheckGoals+            cp.desugaredProgram+            queryLoc+            (Just "query")+            [D.BodyTell qn exprs]+    -- Skip type-checking if name resolution failed or termToExpr+    -- raised diagnostics; the runtime path will surface the same+    -- errors with the same messages.+    _ -> pure []+  unless (null tcErrs) (throwIO (TypeErrors tcErrs))+  runProgramWithGoalDSL cp hostCalls original++-- | Like 'runProgramWithGoalDSL' but accepts a query as surface-language 'Text'.+runProgramWithGoal ::+  CompiledProgram ->+  HostCallRegistry ->+  Text ->+  IO (Map Text Term)+runProgramWithGoal cp hostCalls src = do+  (constraint, _ws) <- prepareGoal cp src+  runPreparedGoal cp hostCalls constraint++-- ---------------------------------------------------------------------------+-- Multi-goal query API+-- ---------------------------------------------------------------------------++-- | Result of parsing, desugaring, lambda-lifting, and type-checking+-- a query — everything that can be done before entering the CHR effect+-- stack. 'queryLambdas' is non-empty iff the query introduced anonymous+-- @fun(...) -> ... end@ expressions; 'extraProcs' must be added to the+-- 'ProcMap' before executing the query.+data PreparedQuery = PreparedQuery+  { liftedGoals :: [D.BodyGoal],+    queryLambdas :: [D.Function],+    extraProcs :: [Procedure]+  }++-- | Parse, rename, desugar, lambda-lift, and type-check a query.+prepareQuery :: CompiledProgram -> Text -> IO (PreparedQuery, [Warning])+prepareQuery cp src = do+  goals <-+    either+      (throwIO . ParseError "<query>")+      pure+      ( parseQueryWith+          cp.opTable+          "<query>"+          src+      )+  (renamed, renameWs) <-+    either+      (throwIO . RenameErrors)+      pure+      ( renameQueryGoals+          cp.allModules+          goals+      )+  let vis = cp.queryFunctionVisibility+      (exprs, exprErrs) =+        runWriter (traverse (termToExpr vis queryLoc queryOrigin) renamed)+  unless (null exprErrs) (throwIO (ResolveErrors exprErrs))+  bodyGoals <-+    either+      (throwIO . DesugarErrors)+      pure+      (desugarQueryGoals exprs)+  let (lifted, lambdas, liftErrs) = liftQueryLambdas cp.nextLambdaIndex bodyGoals+  unless (null liftErrs) (throwIO (DesugarErrors liftErrs))+  let cdp = cp.desugaredProgram+      progForCheck =+        D.Program+          { rules = cdp.rules,+            functions = cdp.functions ++ lambdas,+            constraintTypes = cdp.constraintTypes,+            constraintBounds = cdp.constraintBounds,+            typeDefinitions = cdp.typeDefinitions+          }+  tcErrs <- typeCheckGoals progForCheck queryLoc (Just "query") lifted+  unless (null tcErrs) (throwIO (TypeErrors tcErrs))+  let allFuns = cp.allFunctions ++ lambdas+      queryProcs = compileQueryLambdas lambdas+      queryDispatches = genCallFunDispatches allFuns+      warnings = [RenameWarnings renameWs | not (null renameWs)]+  pure+    ( PreparedQuery+        { liftedGoals = lifted,+          queryLambdas = lambdas,+          extraProcs = queryProcs ++ queryDispatches+        },+      warnings+    )++-- | Execute the lifted goals of a 'PreparedQuery' inside an existing CHR+-- session. Opens its own per-query variable scope and returns the+-- resulting bindings. The host-call registry is read from the ambient+-- 'SessionEnv'; the action only needs the goals.+executePreparedQuery :: [D.BodyGoal] -> Chr (Map Text Term)+executePreparedQuery lifted =+  convertRuntimeErrorChr $+    evalStateT+      ( do+          mapM_ executeBodyGoal lifted+          varMap <- get+          classes <- lift (buildAliasClasses varMap)+          lift $+            Map.traverseWithKey+              (\k v -> valueToTerm (perKeyAliases classes k) v)+              varMap+      )+      (Map.empty :: Map Text Value)++-- | Group the user-visible query variables by their underlying+-- 'VarId'. Each class is non-empty by construction: a fresh class+-- starts as a one-element 'NonEmpty', and subsequent variables sharing+-- the same 'VarId' are appended.+buildAliasClasses :: Map Text Value -> Chr (Map VarId (NonEmpty Text))+buildAliasClasses varMap = do+  pairs <- traverse vidOf (Map.toAscList varMap)+  pure $ Map.fromListWith (flip (<>)) [(vid, k :| []) | (k, Just vid) <- pairs]+  where+    vidOf (k, v)+      | "_" `T.isPrefixOf` k = pure (k, Nothing)+      | otherwise = do+          mvid <- getVarId v+          pure (k, mvid)++-- | Build the 'VarId' → display name map that 'valueToTerm' should+-- use when printing the binding for surface variable @k@. A singleton+-- alias class contributes nothing (no aliasing); otherwise we pick the+-- name that follows @k@ in the class, wrapping back to the canonical+-- (head) name if @k@ is at the end of, or absent from, the class.+perKeyAliases :: Map VarId (NonEmpty Text) -> Text -> Map VarId Text+perKeyAliases classes k = Map.mapMaybe pick classes+  where+    pick (_ :| []) = Nothing+    pick names@(canonical :| _) = Just $ case break (== k) (NE.toList names) of+      (_, _ : next : _) -> next+      (_, [_]) -> canonical+      (_, []) -> canonical++-- | Run a multi-goal query against a compiled program.+runProgramWithQuery :: CompiledProgram -> HostCallRegistry -> Text -> IO (Map Text Term)+runProgramWithQuery cp hostCalls src = do+  (prep, _ws) <- prepareQuery cp src+  withCHRExtra (toSessionInput cp) hostCalls prep.extraProcs $+    executePreparedQuery prep.liftedGoals++-- ---------------------------------------------------------------------------+-- Query goal evaluator (internal)+-- ---------------------------------------------------------------------------++type QueryM = StateT (Map Text Value) Chr++-- | Resolve a surface 'Term' to a 'Value' inside the per-query+-- variable scope, allocating a fresh logical variable for each new+-- 'VarTerm' the query introduces.+termToValue :: Term -> QueryM Value+termToValue (VarTerm n) = do+  varMap <- get+  case Map.lookup n varMap of+    Just v -> pure v+    Nothing -> do+      v <- lift newVar+      modify (Map.insert n v)+      pure v+termToValue (IntTerm n) = pure (VInt n)+termToValue (FloatTerm n) = pure (VFloat n)+termToValue (TextTerm s) = pure (VText s)+termToValue Wildcard = pure VWildcard+-- Native-bool fast path. Mirrors 'Compile.compileTerm' for+-- @prelude:true@/@prelude:false@: the @=@-operand lowering must+-- produce 'VBool' so structural unification with comparison results+-- (which return 'VBool' directly) succeeds.+termToValue (CompoundTerm (Types.Qualified "prelude" "true") []) = pure (VBool True)+termToValue (CompoundTerm (Types.Qualified "prelude" "false") []) = pure (VBool False)+-- 0-arity ctors collapse to atoms at the runtime layer. Qualified+-- 0-arity uses the @vmName@-mangled @m__n@ form; unqualified 0-arity+-- (user-quoted atoms, undeclared bare names) keeps the raw name.+-- See 'YCHR.Internal.Compile.compileTerm' for the rationale.+termToValue (CompoundTerm name@(Types.Qualified _ _) []) =+  pure (VAtom (vmName name).unName)+termToValue (CompoundTerm (Types.Unqualified n) []) = pure (VAtom n)+termToValue (CompoundTerm name ts) = VTerm (vmName name).unName <$> traverse termToValue ts++-- | Execute a single desugared body goal in the query context.+executeBodyGoal :: D.BodyGoal -> QueryM ()+executeBodyGoal D.BodyTrue = pure ()+executeBodyGoal (D.BodyUnify l r) = do+  v1 <- exprToValue l+  v2 <- exprToValue r+  lift (queryUnify v1 v2)+executeBodyGoal (D.BodyHostStmt f args) = do+  argVals <- traverse evalNestedExpr args+  env <- lift ask+  result <- lift (hostCall (Map.lookup (Name f) env.hostCalls) f argVals)+  lift $+    emitTrace $ do+      argTs <- snapshotValues argVals+      resT <- snapshotValue result+      pure (TECallHost f argTs resT)+executeBodyGoal (D.BodyIs v expr) = do+  -- Mirror 'evalValExpr (EvalDeep (Var _))' in the compiled interpreter:+  -- when the RHS is syntactically a variable, walk the dereferenced+  -- value so a bound compound with an evaluable functor gets evaluated+  -- (@X = 1 + 1, R is X@ ⇒ @R = 2@). For all other RHS shapes the+  -- result of the outer typed operation is already final.+  raw <- evalNestedExpr expr+  result <- case expr of+    R.VarExpr _ -> lift (deepEvalValue raw)+    _ -> pure raw+  varMap <- get+  case Map.lookup v varMap of+    Just existing -> lift (queryUnify existing result)+    Nothing -> modify (Map.insert v result)+executeBodyGoal (D.BodyTell qn args) = do+  argVals <- traverse evalNestedExpr args+  lift (tellConstraint (Types.qualifiedToName qn) argVals)+executeBodyGoal (D.BodyCall qn args) = do+  argVals <- traverse evalNestedExpr args+  let funcName = Types.qualifiedToName qn+  _ <- lift (callProc (funcProcName funcName (length argVals)) (map CVal argVals))+  pure ()+executeBodyGoal (D.BodyApply f args) = do+  fAndArgVals <- traverse evalNestedExpr (f : args)+  let n = length args+      dispatchName = Name ("call_" <> T.pack (show n))+  _ <- lift (callProc dispatchName (map CVal fAndArgVals))+  pure ()++-- | Raise a runtime error describing a failed unification.+raiseUnifyFailure :: Value -> Value -> Chr ()+raiseUnifyFailure v1 v2 = do+  t1 <- valueToTerm Map.empty v1+  t2 <- valueToTerm Map.empty v2+  runtimeErrorS $+    "unification failure: cannot unify "+      ++ prettyTerm t1+      ++ " with "+      ++ prettyTerm t2++-- | Call a host function, failing with a coded runtime error if it is not+-- registered or if it throws.+--+-- Mirrors 'YCHR.Internal.Runtime.Interpreter.invokeHostCall': an+-- arbitrary exception out of a host function (an 'IOException' from a+-- user 'YCHR.Convert.hostFnValues' handler, a parse failure inside a+-- built-in) is re-raised through 'runtimeErrorS' so it reaches the caller+-- as 'Error''s 'RuntimeError' with a call stack, rather than escaping raw.+-- Async and already-coded exceptions keep their identity.+--+-- Unlike 'invokeHostCall' there is no @ControlFlow@ case: that exception+-- is interpreter-internal, is caught by 'callProc' before control+-- returns, and is not exported — so no 'HostCallFn' reachable from here,+-- built-in or user-supplied, can raise it.+hostCall :: Maybe HostCallFn -> Text -> [Value] -> Chr Value+hostCall (Just (HostCallFn f)) name args = do+  env <- ask+  result <- liftIO (try @SomeException (runReaderT (f args) env))+  case result of+    Right v -> pure v+    Left exc+      | Just (ae :: SomeAsyncException) <- fromException exc ->+          liftIO (throwIO ae)+      | Just (rte :: RuntimeErrorThrown) <- fromException exc ->+          liftIO (throwIO rte)+      | otherwise ->+          runtimeErrorS $+            "host call " ++ T.unpack name ++ ": " ++ displayException exc+hostCall Nothing name _ =+  runtimeErrorS $ "Unknown host function: " ++ T.unpack name++-- | Drain the reactivation queue, dispatching each constraint.+-- Mirrors the VM's 'DrainReactivationQueue' statement, including+-- the per-suspension 'TEReactivate' event for the tracer.+drainReactivation :: Chr ()+drainReactivation =+  drainQueue $ \sid -> do+    alive <- aliveConstraint sid+    when alive $ do+      emitTrace $ do+        (ct, vs) <- suspensionView sid+        ctName <- constraintTypeLabel ct+        ts <- snapshotValues vs+        pure (TEReactivate sid ctName ts)+      void $ callProc (Name "reactivate_dispatch") [CId sid]++-- | Run a query-side unification, mirroring the interpreter's+-- 'evalBoolExpr (BUnify ...)' branch: snapshot the operand terms+-- /before/ the unify mutates anything (only when tracing is on),+-- run the unify, enqueue observers, emit a 'TEUnify' event on+-- success with the number of observers reactivated, raise on+-- failure, then drain the reactivation queue. The trace event is+-- skipped on failure for consistency with the interpreter path.+queryUnify :: Value -> Value -> Chr ()+queryUnify v1 v2 = do+  env <- ask+  mh <- liftIO (readIORef env.traceHandler)+  case mh of+    Nothing -> do+      (ok, observers) <- unify v1 v2+      enqueue observers+      unless ok (raiseUnifyFailure v1 v2)+      drainReactivation+    Just _ -> do+      t1 <- snapshotValue v1+      t2 <- snapshotValue v2+      (ok, observers) <- unify v1 v2+      enqueue observers+      if ok+        then do+          emitTrace (pure (TEUnify t1 t2 (length observers)))+          drainReactivation+        else raiseUnifyFailure v1 v2++-- | Build a runtime 'Value' from a desugared 'D.Expr' without+-- evaluating embedded function calls. Mirrors 'termToValue' on the+-- typed side by round-tripping through the surface 'Term' shape via+-- 'R.exprToTerm', so query-time value construction stays bit-for-bit+-- compatible with the pre-refactor behaviour.+exprToValue :: D.Expr -> QueryM Value+exprToValue = termToValue . R.exprToTerm++-- | Evaluate an expression in the query context (used for @is@ RHS+-- and guard expressions). 'CallExpr', 'ApplyExpr', and 'HostExpr'+-- evaluate their arguments and invoke the appropriate procedure;+-- 'CtorExpr' (and the @quote\/1@ quoting form) build values+-- structurally without re-evaluating their children.+evalNestedExpr :: D.Expr -> QueryM Value+evalNestedExpr (R.IntExpr n) = pure (VInt n)+evalNestedExpr (R.FloatExpr n) = pure (VFloat n)+evalNestedExpr (R.TextExpr s) = pure (VText s)+evalNestedExpr R.WildcardExpr = pure VWildcard+evalNestedExpr (R.VarExpr v) = do+  varMap <- get+  case Map.lookup v varMap of+    Just val -> lift (deref val)+    Nothing -> do+      fresh <- lift newVar+      modify (Map.insert v fresh)+      pure fresh+evalNestedExpr (R.CallExpr qn args) = do+  argVals <- traverse evalNestedExpr args+  let funcName = Types.qualifiedToName qn+  lift (callProc (funcProcName funcName (length argVals)) (map CVal argVals))+evalNestedExpr (R.ApplyExpr f args) = do+  fAndArgVals <- traverse evalNestedExpr (f : args)+  let n = length args+      dispatchName = Name ("call_" <> T.pack (show n))+  lift (callProc dispatchName (map CVal fAndArgVals))+evalNestedExpr (R.HostExpr f args) = do+  argVals <- traverse evalNestedExpr args+  env <- lift ask+  lift (hostCall (Map.lookup (Name f) env.hostCalls) f argVals)+-- @quote(X)@ short-circuit: build the inner value as data, no+-- nested-call evaluation. Mirrors the legacy 'termToValue arg' path.+evalNestedExpr (R.CtorExpr (Types.Unqualified "quote") [arg]) = exprToValue arg+-- Native-bool fast path. Mirrors 'Compile.compileExpr' for+-- @prelude:true@/@prelude:false@: queries must produce 'VBool' just+-- like compiled rules, so a REPL @is@ RHS or tell-side argument+-- agrees with comparison results (which return 'VBool' directly).+evalNestedExpr (R.CtorExpr (Types.Qualified "prelude" "true") []) = pure (VBool True)+evalNestedExpr (R.CtorExpr (Types.Qualified "prelude" "false") []) = pure (VBool False)+-- 0-arity ctors collapse to atoms at the runtime layer.+evalNestedExpr (R.CtorExpr name@(Types.Qualified _ _) []) =+  pure (VAtom (vmName name).unName)+evalNestedExpr (R.CtorExpr (Types.Unqualified n) []) = pure (VAtom n)+evalNestedExpr (R.CtorExpr name args) =+  -- Recurse with 'evalNestedExpr' (not 'exprToValue'): a 'CtorExpr'+  -- can contain nested 'CallExpr' / 'HostExpr' children that must+  -- evaluate before the surrounding compound is built. Mirrors the+  -- compiled path in 'Compile.compileExpr' for 'CtorExpr'.+  VTerm (vmName name).unName <$> traverse evalNestedExpr args+evalNestedExpr e@(R.FunRefExpr _ _) = exprToValue e+evalNestedExpr (R.LambdaExpr _ _) =+  error "Run.evalNestedExpr: LambdaExpr survived lambda lifting"++-- | Compile lifted query lambdas into VM procedures. Discards the+-- error channel: by the time this runs, 'prepareQuery' has already+-- lifted these lambdas from a desugared program that compiled+-- cleanly and has type-checked them, so any error here would+-- indicate a compiler bug rather than a user problem.+compileQueryLambdas :: [D.Function] -> [Procedure]+compileQueryLambdas lambdas =+  let (procs, _errs) = runWriter $ traverse compileFunctionDef lambdas+   in procs
+ src/YCHR/Types.hs view
@@ -0,0 +1,30 @@+-- | The embedder-facing core types: the 'Term' values that cross the+-- program boundary, the 'Name's inside them, the 'Constraint' shape of+-- a raw goal, and the type-declaration vocabulary used by "YCHR.DSL".+--+-- This is the supported, version-policy-covered subset of the+-- compiler's shared type module. The compiler-internal remainder+-- (symbol tables, qualified-name forms, post-HNF head shapes, …) lives+-- in "YCHR.Internal.Types" and is not covered by the package version+-- policy.+module YCHR.Types+  ( -- * Terms+    Term (..),++    -- * Names+    Name (..),+    flattenName,++    -- * Constraints+    Constraint (..),++    -- * Type declarations+    TypeDefinition,+    TypeKind (..),+    typeConstructors,+    DataConstructor,+    TypeExpr (..),+  )+where++import YCHR.Internal.Types
+ src/ghc/YCHR/Convert/Generic.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- | GHC-only Generic derivation for the "YCHR.Convert" classes.+--+-- Deriving 'GHC.Generics.Generic' on a data type is enough to get+-- 'YCHR.Convert.ToTerm' / 'YCHR.Convert.FromTerm' instances via the two+-- helpers here — no hand-written instance body required:+--+-- > import GHC.Generics (Generic)+-- > import YCHR.Convert (ToTerm (..), FromTerm (..))+-- > import YCHR.Convert.Generic (genericToTerm, genericFromTerm)+-- >+-- > data Color = Red | Green | Blue deriving (Show, Generic)+-- >+-- > instance ToTerm   Color where toTerm   = genericToTerm    -- Red -> atom "red"+-- > instance FromTerm Color where fromTerm = genericFromTerm+--+-- = Encoding+--+-- A constructor becomes a compound whose functor is the constructor name+-- with its first character lowercased (Haskell constructors are uppercase;+-- CHR functor atoms are lowercase). Fields become positional arguments in+-- declaration order; a nullary constructor becomes an atom. Record field+-- names are ignored (positional encoding), so a generic-derived instance+-- agrees with a hand-written one.+--+-- This module depends on "GHC.Generics", which MicroHS cannot compile, so+-- it is built only under GHC (see @if impl(ghc)@ in @ychr.cabal@). The core+-- "YCHR.Convert" is Generics-free and works on every backend.+module YCHR.Convert.Generic+  ( genericToTerm,+    genericFromTerm,+  )+where++import Data.Char (toLower)+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Generics+import YCHR.Convert+  ( ConvertError,+    FromTerm (..),+    ToTerm (..),+    argAt,+    compound,+    decodeSum,+  )+import YCHR.Types (Term)++-- | Encode any 'Generic' value as a 'Term'. See the module header for the+-- constructor-to-functor convention.+genericToTerm :: (Generic a, GToTerm (Rep a)) => a -> Term+genericToTerm = gToTerm . from++-- | Decode a 'Term' into any 'Generic' value. The inverse of+-- 'genericToTerm': dispatches on functor and arity across the type's+-- constructors.+genericFromTerm :: forall a. (Generic a, GFromTerm (Rep a)) => Term -> Either ConvertError a+genericFromTerm t = to <$> decodeSum (gRows @(Rep a)) t++-- | The functor atom for a constructor name: lowercase the first character+-- only. @Red -> "red"@, @MkPoint -> "mkPoint"@.+functorName :: String -> Text+functorName [] = ""+functorName (c : cs) = Text.pack (toLower c : cs)++-- ---------------------------------------------------------------------------+-- ToTerm side+-- ---------------------------------------------------------------------------++-- | Encode a generic representation as a whole 'Term' (datatype, sum, and+-- constructor levels).+class GToTerm f where+  gToTerm :: f p -> Term++-- | Encode a generic product as a positional argument list.+class GProdTo f where+  gProdTo :: f p -> [Term]++instance (GToTerm f) => GToTerm (M1 D d f) where+  gToTerm (M1 x) = gToTerm x++instance (GToTerm f, GToTerm g) => GToTerm (f :+: g) where+  gToTerm (L1 x) = gToTerm x+  gToTerm (R1 y) = gToTerm y++instance (Constructor c, GProdTo f) => GToTerm (M1 C c f) where+  gToTerm m@(M1 x) = compound (functorName (conName m)) (gProdTo x)++instance (GProdTo f, GProdTo g) => GProdTo (f :*: g) where+  gProdTo (a :*: b) = gProdTo a ++ gProdTo b++instance (GProdTo f) => GProdTo (M1 S s f) where+  gProdTo (M1 x) = gProdTo x++instance (ToTerm c) => GProdTo (K1 R c) where+  gProdTo (K1 x) = [toTerm x]++instance GProdTo U1 where+  gProdTo U1 = []++-- ---------------------------------------------------------------------------+-- FromTerm side+-- ---------------------------------------------------------------------------++-- | Rows describing each constructor of a generic representation:+-- @(functor, arity, build-from-args)@. Fed to 'decodeSum'.+class GFromTerm f where+  gRows :: [(Text, Int, [Term] -> Either ConvertError (f p))]++-- | Build a generic product from a positional argument list, and report how+-- many arguments it consumes.+class GProdFrom f where+  gArity :: Int+  gBuild :: [Term] -> Either ConvertError (f p)++instance (GFromTerm f) => GFromTerm (M1 D d f) where+  gRows = map (\(n, ar, h) -> (n, ar, fmap M1 . h)) (gRows @f)++instance (GFromTerm f, GFromTerm g) => GFromTerm (f :+: g) where+  gRows =+    map (\(n, ar, h) -> (n, ar, fmap L1 . h)) (gRows @f)+      ++ map (\(n, ar, h) -> (n, ar, fmap R1 . h)) (gRows @g)++instance (Constructor c, GProdFrom f) => GFromTerm (M1 C c f) where+  gRows =+    [ ( functorName (conName (undefined :: M1 C c f p)),+        gArity @f,+        \args -> M1 <$> gBuild args+      )+    ]++instance (GProdFrom f, GProdFrom g) => GProdFrom (f :*: g) where+  gArity = gArity @f + gArity @g+  gBuild args =+    let (la, lb) = splitAt (gArity @f) args+     in (:*:) <$> gBuild la <*> gBuild lb++instance (GProdFrom f) => GProdFrom (M1 S s f) where+  gArity = gArity @f+  gBuild args = M1 <$> gBuild args++instance (FromTerm c) => GProdFrom (K1 R c) where+  gArity = 1+  gBuild args = K1 <$> argAt 0 args++instance GProdFrom U1 where+  gArity = 0+  gBuild _ = Right U1
+ src/ghc/YCHR/Internal/LineInput.hs view
@@ -0,0 +1,78 @@+-- | Line-input backend for the REPL, GHC build.+--+-- Wraps @haskeline@: prompt + history file + tab completion. The+-- twin module under @src\/mhs\/YCHR\/LineInput.hs@ provides a+-- bare-'getLine' implementation for MicroHS; the two are switched by+-- @if impl(...)@ blocks in @ychr.cabal@.+module YCHR.Internal.LineInput+  ( LineInputSettings (..),+    LineInput (..),+    mkLineInput,+  )+where++import Data.List (isPrefixOf)+import System.Console.Haskeline+  ( Completion (isFinished),+    Settings (complete, historyFile),+    completeWord,+    defaultSettings,+    getInputLine,+    runInputT,+    simpleCompletion,+  )+import System.Console.Haskeline qualified as H+import System.Console.Haskeline.Completion (CompletionFunc)+import System.Directory (XdgDirectory (..), createDirectoryIfMissing, getXdgDirectory)+import System.FilePath (takeDirectory)++-- | Configuration for a line-input session.+--+-- The 'historyFile' field is interpreted as an XDG-data-relative+-- subpath (e.g. @\"ychr\/history\"@); the GHC backend resolves it via+-- 'getXdgDirectory' and creates the parent directory on demand. The+-- MicroHS backend ignores both fields.+data LineInputSettings = LineInputSettings+  { historyFile :: Maybe FilePath,+    completionCandidates :: [String]+  }++-- | Read one line of input. 'Nothing' signals EOF (e.g. Ctrl-D).+newtype LineInput = LineInput+  { readLine :: String -> IO (Maybe String)+  }++-- | Build a 'LineInput' from settings. Under haskeline @runInputT@ is+-- entered per 'readLine' call; the per-call cost (history file+-- re-read, signal handler re-install) is imperceptible at human+-- typing speed and keeps the API plain 'IO'.+mkLineInput :: LineInputSettings -> IO LineInput+mkLineInput s = do+  resolved <- traverse resolveHistoryPath s.historyFile+  let hSettings =+        (defaultSettings :: H.Settings IO)+          { historyFile = resolved,+            complete = matchAgainst s.completionCandidates+          }+  pure (LineInput {readLine = \prompt -> runInputT hSettings (getInputLine prompt)})++resolveHistoryPath :: FilePath -> IO FilePath+resolveHistoryPath sub = do+  path <- getXdgDirectory XdgData sub+  createDirectoryIfMissing True (takeDirectory path)+  pure path++-- | Build a haskeline completion function that prefix-matches against+-- a fixed list of candidates. Word boundaries are space and comma,+-- matching how a constraint conjunction is written. The+-- @isFinished = False@ flag suppresses the auto-appended space after+-- a completion, which matters when the user is part-way through a+-- conjunction.+matchAgainst :: [String] -> CompletionFunc IO+matchAgainst candidates =+  completeWord Nothing " ," $ \prefix ->+    pure+      [ (simpleCompletion n) {isFinished = False}+      | n <- candidates,+        prefix `isPrefixOf` n+      ]
+ src/mhs/YCHR/Internal/LineInput.hs view
@@ -0,0 +1,39 @@+-- | Line-input backend for the REPL, MicroHS build.+--+-- Bare-'getLine' fallback: no history, no tab completion. The twin+-- module under @src\/ghc\/YCHR\/LineInput.hs@ provides the+-- haskeline-backed implementation for GHC; the two are switched by+-- @if impl(...)@ blocks in @ychr.cabal@.+module YCHR.Internal.LineInput+  ( LineInputSettings (..),+    LineInput (..),+    mkLineInput,+  )+where++import Control.Exception (IOException, try)+import System.IO (hFlush, stdout)++-- | Configuration for a line-input session. Both fields are ignored+-- by this backend; they exist for source compatibility with the GHC+-- backend.+data LineInputSettings = LineInputSettings+  { historyFile :: Maybe FilePath,+    completionCandidates :: [String]+  }++-- | Read one line of input. 'Nothing' signals EOF (e.g. Ctrl-D).+newtype LineInput = LineInput+  { readLine :: String -> IO (Maybe String)+  }++mkLineInput :: LineInputSettings -> IO LineInput+mkLineInput _ = pure (LineInput {readLine = readOneLine})+  where+    readOneLine prompt = do+      putStr prompt+      hFlush stdout+      r <- try @IOException getLine+      pure $ case r of+        Left _ -> Nothing+        Right s -> Just s
+ test/Main.hs view
@@ -0,0 +1,55 @@+module Main (main) where++import Test.Tasty (defaultMain, testGroup)+import YCHR.CollectTest qualified+import YCHR.CompileTest qualified+import YCHR.ConvertTest qualified+import YCHR.DSLTest qualified+import YCHR.DesugarTest qualified+import YCHR.ErrorCodeTest qualified+import YCHR.ExhaustivenessTest qualified+import YCHR.GoldenTest qualified+import YCHR.MetaTest qualified+import YCHR.PExprRoundtripTest qualified+import YCHR.PExprTest qualified+import YCHR.ParserTest qualified+import YCHR.PrettyTest qualified+import YCHR.RenameTest qualified+import YCHR.RoundtripTest qualified+import YCHR.RunTest qualified+import YCHR.Runtime.HistoryTest qualified+import YCHR.Runtime.InterpreterTest qualified+import YCHR.Runtime.ReactivationTest qualified+import YCHR.Runtime.StoreTest qualified+import YCHR.Runtime.VarTest qualified+import YCHR.VM.SExprTest qualified++main :: IO ()+main = do+  golden <- YCHR.GoldenTest.tests+  defaultMain $+    testGroup+      "ychr"+      [ golden,+        YCHR.CollectTest.tests,+        YCHR.CompileTest.tests,+        YCHR.PrettyTest.tests,+        YCHR.RunTest.tests,+        YCHR.MetaTest.tests,+        YCHR.DSLTest.tests,+        YCHR.ConvertTest.tests,+        YCHR.DesugarTest.tests,+        YCHR.ErrorCodeTest.tests,+        YCHR.ExhaustivenessTest.tests,+        YCHR.ParserTest.tests,+        YCHR.PExprTest.tests,+        YCHR.PExprRoundtripTest.tests,+        YCHR.RoundtripTest.tests,+        YCHR.RenameTest.tests,+        YCHR.Runtime.VarTest.tests,+        YCHR.Runtime.StoreTest.tests,+        YCHR.Runtime.HistoryTest.tests,+        YCHR.Runtime.ReactivationTest.tests,+        YCHR.Runtime.InterpreterTest.tests,+        YCHR.VM.SExprTest.tests+      ]
+ test/YCHR/CollectTest.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.CollectTest (tests) where++import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import YCHR.Internal.Collect+import YCHR.Internal.Collected qualified as C+import YCHR.Internal.Diagnostic (Diagnostic (..), noDiag)+import YCHR.Internal.PExpr (PExpr (Atom))+import YCHR.Internal.Parsed++tests :: TestTree+tests =+  testGroup+    "Collect"+    [ testCase "no seeds, no closure" $+        resolveLibraryClosure False Map.empty [] @?= Right [],+      testCase "resolves a single library import" $+        let libs = Map.fromList [("foo", libMod "foo")]+         in case resolveLibraryClosure False libs [noAnnP "foo"] of+              Right mods -> length mods @?= 1+              Left errs -> fail (show errs),+      testCase "library imports collapse into CollectedImport, name preserved" $+        let userMod_ = userMod [noAnnP (LibraryImport "foo" Nothing)]+            rewritten = rewriteImports [userMod_]+            -- The library/module distinction is erased at the type level+            -- (every import is a CollectedImport); assert the conversion+            -- preserves the source module name.+            names = [imp.node.importModule | m <- rewritten, imp <- m.imports]+         in names @?= ["foo"],+      testCase "transitive library imports resolved" $+        let libA = (libMod "a") {imports = [noAnnP (LibraryImport "b" Nothing)]}+            libB = libMod "b"+            libs = Map.fromList [("a", libA), ("b", libB)]+         in case resolveLibraryClosure False libs [noAnnP "a"] of+              Right mods -> length mods @?= 2+              Left errs -> fail (show errs),+      testCase "unknown library reports error" $+        resolveLibraryClosure False Map.empty [noAnnP "missing"]+          @?= Left [noDiag (AnnP (UnknownLibrary "missing") dummyLoc (Atom ""))],+      testCase "prelude not auto-included when includeStdlib is False" $+        let libs = Map.fromList [("prelude", libMod "prelude")]+         in resolveLibraryClosure False libs [] @?= Right [],+      testCase "stdlib included when includeStdlib is True" $+        let libs = Map.fromList [("prelude", libMod "prelude")]+         in case resolveLibraryClosure True libs [] of+              Right mods -> length mods @?= 1+              Left errs -> fail (show errs),+      testCase "circular import reports error" $+        let libA = (libMod "a") {imports = [noAnnP (LibraryImport "b" Nothing)]}+            libB = (libMod "b") {imports = [noAnnP (LibraryImport "a" Nothing)]}+            libs = Map.fromList [("a", libA), ("b", libB)]+         in case resolveLibraryClosure False libs [noAnnP "a"] of+              Left errs ->+                any isCircularError errs @?= True+              Right _ -> fail "expected circular import error",+      testCase "addLibraryPrelude prepends prelude to non-prelude libraries" $+        case addLibraryPrelude [libMod "foo", libMod "prelude"] of+          [foo, prelude] -> do+            length foo.imports @?= 1+            length prelude.imports @?= 0+          mods -> fail $ "expected 2 modules, got " ++ show (length mods)+    ]++userMod :: [AnnP Import] -> Module+userMod imps =+  Module+    { name = "user",+      nameLoc = dummyLoc,+      imports = imps,+      decls = [],+      extensionTypes = [],+      typeDecls = [],+      rules = [],+      equations = [],+      extensions = [],+      classExtensions = [],+      exports = Nothing+    }++libMod :: Text -> Module+libMod name =+  Module+    { name = name,+      nameLoc = dummyLoc,+      imports = [],+      decls = [],+      extensionTypes = [],+      typeDecls = [],+      rules = [],+      equations = [],+      extensions = [],+      classExtensions = [],+      exports = Nothing+    }++isCircularError :: Diagnostic CollectError -> Bool+isCircularError (Diagnostic _ (AnnP (CircularLibraryImport _) _ _)) = True+isCircularError _ = False
+ test/YCHR/CompileTest.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Pure compilation tests: assertions about the VM code emitted by+-- 'YCHR.Internal.Compile.compile' for representative CHR programs. These tests+-- inspect the generated 'YCHR.Internal.VM.Program' AST directly without running+-- it through the interpreter.+module YCHR.CompileTest (tests) where++import Data.Maybe (isJust, isNothing)+import Data.Text (Text)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import YCHR.Internal.Compile.Pipeline (CompiledProgram (..))+import YCHR.Internal.VM qualified as VM+import YCHR.Run (compileModules)++tests :: TestTree+tests =+  testGroup+    "YCHR.Internal.Compile"+    [ indexConditionPushdownTests,+      passiveOccurrencesTests+    ]++-- ---------------------------------------------------------------------------+-- Shared helpers+-- ---------------------------------------------------------------------------++compileOrFail :: [(FilePath, Text)] -> IO CompiledProgram+compileOrFail inputs = case compileModules False inputs of+  Left err -> assertFailure $ show err+  Right (cp, _) -> pure cp++-- | Find the (single) Foreach statement reachable from a list of+-- statements. All compiler-generated occurrence procedures contain at+-- most one top-level Foreach per partner level; for the leqSource rules+-- below this helper returns the outermost (and only) Foreach.+findForeach :: [VM.Stmt] -> Maybe VM.Stmt+findForeach [] = Nothing+findForeach (s : rest) = case s of+  f@(VM.Foreach {}) -> Just f+  VM.If _ thn els -> case findForeach thn of+    Just f -> Just f+    Nothing -> case findForeach els of+      Just f -> Just f+      Nothing -> findForeach rest+  _ -> findForeach rest++foreachConditions :: VM.Stmt -> [(VM.ArgIndex, VM.ValExpr)]+foreachConditions (VM.Foreach _ _ _ conds _) = conds+foreachConditions _ = error "foreachConditions: not a Foreach"++-- | Whether any statement (recursively through If/Foreach and other+-- nested bodies) calls the named procedure in value position. Sufficient+-- for the activate procedure, whose occurrence calls are+-- @LetVal _ (CallExpr occName ..)@.+callsProcedure :: Text -> [VM.Stmt] -> Bool+callsProcedure name = any go+  where+    want = VM.Name name+    go (VM.LetVal _ e) = valCalls e+    go (VM.AssignVal _ e) = valCalls e+    go (VM.ExprStmt e) = valCalls e+    go (VM.Return e) = valCalls e+    go (VM.If _ t e) = callsProcedure name t || callsProcedure name e+    go (VM.Foreach _ _ _ _ body) = callsProcedure name body+    go (VM.DrainReactivationQueue _ body) = callsProcedure name body+    go _ = False+    valCalls (VM.CallExpr n _) = n == want+    valCalls _ = False++-- | Look up a procedure by name in a compiled program.+findProcedure :: CompiledProgram -> Text -> Maybe VM.Procedure+findProcedure prog wanted =+  let want = VM.Name wanted+   in case filter (\p -> p.name == want) prog.program.procedures of+        [p] -> Just p+        _ -> Nothing++-- | Assert that the named occurrence procedure contains a Foreach with+-- the given index conditions.+assertForeachConditions ::+  CompiledProgram ->+  Text ->+  [(VM.ArgIndex, VM.ValExpr)] ->+  IO ()+assertForeachConditions prog procName expected =+  case findProcedure prog procName of+    Nothing -> assertFailure $ "procedure not found: " ++ show procName+    Just p -> case findForeach p.body of+      Nothing -> assertFailure $ "no Foreach in " ++ show procName+      Just f -> foreachConditions f @?= expected++-- ---------------------------------------------------------------------------+-- LEQ surface source (duplicated from RunTest so this module is+-- self-contained — both files exercise leq.chr but for different reasons).+-- ---------------------------------------------------------------------------++leqSource :: Text+leqSource =+  ":- module(order, [leq/2]).\n\+  \:- chr_constraint leq/2.\n\+  \\n\+  \reflexivity @ leq(X, X) <=> true.\n\+  \antisymmetry @ leq(X, Y), leq(Y, X) <=> X = Y.\n\+  \idempotence @ leq(X, Y) \\ leq(X, Y) <=> true.\n\+  \transitivity @ leq(X, Y), leq(Y, Z) ==> leq(X, Z).\n"++-- ---------------------------------------------------------------------------+-- Foreach index-condition pushdown+-- ---------------------------------------------------------------------------++indexConditionPushdownTests :: TestTree+indexConditionPushdownTests =+  testGroup+    "Foreach index-condition pushdown"+    [ testCase "leq antisymmetry: active occurrence's partner args constrained" $ do+        -- antisymmetry @ leq(X, Y), leq(Y, X) <=> X = Y.+        -- Occurrence 3 (the second head) is elided as a passive symmetric+        -- occurrence (see passiveOccurrencesTests); the surviving+        -- occurrence 2 lifts both equalities into its partner Foreach.+        prog <- compileOrFail [("order.chr", leqSource)]+        assertForeachConditions+          prog+          "occurrence_order__leq2_2"+          [(VM.ArgIndex 1, VM.Var "X_0"), (VM.ArgIndex 0, VM.Var "X_1")],+      testCase "leq idempotence: active occurrence's partner args constrained" $ do+        -- idempotence @ leq(X, Y) \ leq(X, Y) <=> true.+        -- Occurrence 5 (the kept head) is elided as subsumed by the+        -- removed head; occurrence 4 survives.+        prog <- compileOrFail [("order.chr", leqSource)]+        assertForeachConditions+          prog+          "occurrence_order__leq2_4"+          [(VM.ArgIndex 0, VM.Var "X_0"), (VM.ArgIndex 1, VM.Var "X_1")],+      testCase "leq transitivity: single shared variable lifted" $ do+        -- transitivity @ leq(X, Y), leq(Y, Z) ==> leq(X, Z).+        -- Each occurrence has exactly one HNF equality on the partner.+        prog <- compileOrFail [("order.chr", leqSource)]+        assertForeachConditions+          prog+          "occurrence_order__leq2_6"+          [(VM.ArgIndex 1, VM.Var "X_0")]+        assertForeachConditions+          prog+          "occurrence_order__leq2_7"+          [(VM.ArgIndex 0, VM.Var "X_1")],+      testCase "leq reflexivity: no partners, equality stays residual" $ do+        -- reflexivity @ leq(X, X) <=> true.+        -- The Foreach is absent (single-headed rule), and the residual+        -- check guard contains the active-self equality.+        prog <- compileOrFail [("order.chr", leqSource)]+        case findProcedure prog "occurrence_order__leq2_1" of+          Nothing -> assertFailure "occurrence_order__leq2_1 not found"+          Just p -> do+            findForeach p.body @?= Nothing+            -- The residual check should contain Equal X_0 X_1.+            let hasSelfEqual = any containsSelfEqual p.body+            assertBool "expected residual Equal X_0 X_1" hasSelfEqual+    ]+  where+    containsSelfEqual (VM.If e _ _) = exprHasSelfEqual e+    containsSelfEqual _ = False+    exprHasSelfEqual (VM.BEqual (VM.Var "X_0") (VM.Var "X_1")) = True+    exprHasSelfEqual (VM.BEqual (VM.Var "X_1") (VM.Var "X_0")) = True+    exprHasSelfEqual (VM.BAnd a b) = exprHasSelfEqual a || exprHasSelfEqual b+    exprHasSelfEqual _ = False++-- ---------------------------------------------------------------------------+-- Passive occurrences+-- ---------------------------------------------------------------------------++-- | A non-symmetric two-head simplification: the two heads share only one+-- variable (in different positions), so neither occurrence is passive.+nonSymSource :: Text+nonSymSource =+  ":- module(m, [nsym/2]).\n\+  \:- chr_constraint nsym/2.\n\+  \r @ nsym(X, Y), nsym(Y, Z) <=> true.\n"++passiveOccurrencesTests :: TestTree+passiveOccurrencesTests =+  testGroup+    "Passive occurrences"+    [ testCase "leq: passive occurrence procedures are elided" $ do+        prog <- compileOrFail [("order.chr", leqSource)]+        -- Occurrence 3 (antisymmetry, by symmetry) and occurrence 5+        -- (idempotence, kept head subsumed by removed) are passive, so no+        -- procedure is emitted for them.+        assertAbsent prog "occurrence_order__leq2_3"+        assertAbsent prog "occurrence_order__leq2_5"+        -- Every active occurrence is still present, with its ωr number+        -- unchanged (numbering runs before the passivity pass).+        mapM_+          (assertPresent prog)+          [ "occurrence_order__leq2_1",+            "occurrence_order__leq2_2",+            "occurrence_order__leq2_4",+            "occurrence_order__leq2_6",+            "occurrence_order__leq2_7"+          ],+      testCase "leq: activate does not call passive occurrences" $ do+        prog <- compileOrFail [("order.chr", leqSource)]+        case findProcedure prog "activate_order__leq2" of+          Nothing -> assertFailure "activate_order__leq2 not found"+          Just p -> do+            assertBool "activate must not call passive occurrence 3" $+              not (callsProcedure "occurrence_order__leq2_3" p.body)+            assertBool "activate must not call passive occurrence 5" $+              not (callsProcedure "occurrence_order__leq2_5" p.body)+            mapM_+              ( \n ->+                  assertBool ("activate must still call " ++ show n) $+                    callsProcedure n p.body+              )+              [ "occurrence_order__leq2_2",+                "occurrence_order__leq2_4",+                "occurrence_order__leq2_6",+                "occurrence_order__leq2_7"+              ],+      testCase "non-symmetric two-head rule keeps both occurrences" $ do+        prog <- compileOrFail [("m.chr", nonSymSource)]+        assertPresent prog "occurrence_m__nsym2_1"+        assertPresent prog "occurrence_m__nsym2_2"+    ]+  where+    assertAbsent prog n =+      assertBool (show n ++ " should be elided (passive)") $+        isNothing (findProcedure prog n)+    assertPresent prog n =+      assertBool (show n ++ " should be present") $+        isJust (findProcedure prog n)
+ test/YCHR/ConvertTest.hs view
@@ -0,0 +1,486 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module YCHR.ConvertTest (tests) where++import Control.Exception (SomeException, try)+import Control.Monad.IO.Class (liftIO)+import Data.List (isInfixOf, sort)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import Hedgehog (Gen, Property, forAll, property, (===))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty)+import YCHR.Convert+import YCHR.Convert.Generic (genericFromTerm, genericToTerm)+import YCHR.DSL+  ( declaring,+    defining,+    exporting,+    hostCall,+    int,+    is,+    module',+    term,+    text,+    var,+    (.*),+    (.=.),+    (//),+    (<=>),+  )+import YCHR.Internal.Parsed (Module)+import YCHR.Internal.Types (Name (..), Term (..))+import YCHR.Run (compileParsedModules)++tests :: TestTree+tests =+  testGroup+    "YCHR.Convert"+    [ roundTripTests,+      encodingTests,+      acceptanceTests,+      errorTests,+      endToEndTests,+      hostFunctionTests+    ]++-- ---------------------------------------------------------------------------+-- A generic-derived fixture type+-- ---------------------------------------------------------------------------++data Shape = Dot | Circle Int | Rect Int Int+  deriving (Eq, Show, Generic)++instance ToTerm Shape where+  toTerm = genericToTerm++instance FromTerm Shape where+  fromTerm = genericFromTerm++-- | Type-pinned 'fromTerm' at 'Shape', to keep the error-case tests short.+decodeShape :: Term -> Either ConvertError Shape+decodeShape = fromTerm++-- ---------------------------------------------------------------------------+-- Generators+-- ---------------------------------------------------------------------------++genInt :: Gen Int+genInt = Gen.int (Range.linearFrom 0 (-100000) 100000)++genInteger :: Gen Integer+genInteger = Gen.integral (Range.linearFrom 0 (-1000000000) 1000000000)++genDouble :: Gen Double+genDouble = Gen.double (Range.linearFracFrom 0 (-1000000) 1000000)++genText :: Gen Text+genText = Gen.text (Range.linear 0 12) Gen.unicode++genShape :: Gen Shape+genShape =+  Gen.choice+    [ pure Dot,+      Circle <$> genInt,+      Rect <$> genInt <*> genInt+    ]++-- ---------------------------------------------------------------------------+-- Round-trip properties+-- ---------------------------------------------------------------------------++roundTrip :: (ToTerm a, FromTerm a, Eq a, Show a) => Gen a -> Property+roundTrip gen = property $ do+  x <- forAll gen+  fromTerm (toTerm x) === Right x++roundTripTests :: TestTree+roundTripTests =+  testGroup+    "round-trip"+    [ testProperty "Int" (roundTrip genInt),+      testProperty "Integer" (roundTrip genInteger),+      testProperty "Double" (roundTrip genDouble),+      testProperty "Bool" (roundTrip Gen.bool),+      testProperty "Text" (roundTrip genText),+      testProperty "()" (roundTrip (pure ())),+      testProperty "Maybe Int" (roundTrip (Gen.maybe genInt)),+      testProperty+        "Either Int Text"+        (roundTrip (Gen.choice [Left <$> genInt, Right <$> genText]) :: Property),+      testProperty "[Int]" (roundTrip (Gen.list (Range.linear 0 10) genInt)),+      testProperty+        "[[Int]]"+        (roundTrip (Gen.list (Range.linear 0 5) (Gen.list (Range.linear 0 5) genInt))),+      testProperty "(Int, Text)" (roundTrip ((,) <$> genInt <*> genText)),+      testProperty+        "(Int, Text, Bool)"+        (roundTrip ((,,) <$> genInt <*> genText <*> Gen.bool)),+      testProperty "Shape (generic)" (roundTrip genShape)+    ]++-- ---------------------------------------------------------------------------+-- Exact-encoding unit tests+-- ---------------------------------------------------------------------------++encodingTests :: TestTree+encodingTests =+  testGroup+    "encoding"+    [ testCase "True" $+        toTerm True @?= CompoundTerm (Unqualified "true") [],+      testCase "False" $+        toTerm False @?= CompoundTerm (Unqualified "false") [],+      testCase "Nothing" $+        toTerm (Nothing :: Maybe Int) @?= CompoundTerm (Unqualified "nothing") [],+      testCase "Just 1" $+        toTerm (Just (1 :: Int)) @?= CompoundTerm (Unqualified "just") [IntTerm 1],+      testCase "[]" $+        toTerm ([] :: [Int]) @?= CompoundTerm (Unqualified "[]") [],+      testCase "[1]" $+        toTerm [1 :: Int]+          @?= CompoundTerm (Unqualified ".") [IntTerm 1, CompoundTerm (Unqualified "[]") []],+      testCase "(1, \"a\")" $+        toTerm (1 :: Int, "a" :: Text)+          @?= CompoundTerm (Unqualified "tuple") [IntTerm 1, TextTerm "a"],+      testCase "()" $+        toTerm () @?= CompoundTerm (Unqualified "()") [],+      testCase "Dot (generic nullary)" $+        toTerm Dot @?= CompoundTerm (Unqualified "dot") [],+      testCase "Circle 3 (generic product)" $+        toTerm (Circle 3) @?= CompoundTerm (Unqualified "circle") [IntTerm 3],+      testCase "quote wraps a Term in quote/1 unchanged" $+        quote (compound "plus" [int 2, int 3])+          @?= CompoundTerm+            (Unqualified "quote")+            [CompoundTerm (Unqualified "plus") [IntTerm 2, IntTerm 3]],+      testCase "quote routes a non-Term through toTerm" $+        quote (Circle 3)+          @?= CompoundTerm+            (Unqualified "quote")+            [CompoundTerm (Unqualified "circle") [IntTerm 3]],+      testCase "quote nests" $+        quote (quote (int 1))+          @?= CompoundTerm+            (Unqualified "quote")+            [CompoundTerm (Unqualified "quote") [IntTerm 1]]+    ]++-- ---------------------------------------------------------------------------+-- Decode acceptance: result-shaped inputs (prelude-qualified / mangled forms)+-- ---------------------------------------------------------------------------++acceptanceTests :: TestTree+acceptanceTests =+  testGroup+    "decode acceptance"+    [ testCase "prelude:true decodes to True" $+        (fromTerm (CompoundTerm (Qualified "prelude" "true") []) :: Either ConvertError Bool)+          @?= Right True,+      testCase "prelude:[] decodes to []" $+        (fromTerm (CompoundTerm (Qualified "prelude" "[]") []) :: Either ConvertError [Int])+          @?= Right [],+      testCase "unqualified cons list decodes" $+        ( fromTerm+            (CompoundTerm (Unqualified ".") [IntTerm 1, CompoundTerm (Unqualified "[]") []]) ::+            Either ConvertError [Int]+        )+          @?= Right [1]+    ]++-- ---------------------------------------------------------------------------+-- Decode error cases+-- ---------------------------------------------------------------------------++errorTests :: TestTree+errorTests =+  testGroup+    "decode errors"+    [ testCase "unknown functor" $+        case decodeShape (CompoundTerm (Unqualified "square") [IntTerm 1]) of+          Left (UnknownFunctor names found) -> do+            found @?= Unqualified "square"+            sort names @?= ["circle", "dot", "rect"]+          other -> assertFailure ("expected UnknownFunctor, got: " <> show other),+      testCase "arity mismatch" $+        decodeShape (CompoundTerm (Unqualified "circle") [IntTerm 1, IntTerm 2])+          @?= Left (ArityMismatch (Unqualified "circle") 1 2),+      testCase "unbound value" $+        (fromTerm (VarTerm "X") :: Either ConvertError Int)+          @?= Left (UnboundValue (VarTerm "X")),+      testCase "type mismatch" $+        (fromTerm (IntTerm 1) :: Either ConvertError Text)+          @?= Left (TypeMismatch "Text" (IntTerm 1)),+      testCase "missing binding" $+        (decodeVar "missing" Map.empty :: Either ConvertError Int)+          @?= Left (MissingBinding "missing")+    ]++-- ---------------------------------------------------------------------------+-- End-to-end typed queries (compile + run + decode)+-- ---------------------------------------------------------------------------++endToEndTests :: TestTree+endToEndTests =+  testGroup+    "end-to-end"+    [ e2eScalar,+      e2eList,+      e2eRecord,+      e2eMalformedGoal,+      e2eCompiled+    ]++-- | 'runQueryCompiled' compiles a program once and drives several+-- independent queries against it, each decoded with 'FromTerm'.+e2eCompiled :: TestTree+e2eCompiled =+  testCase "runQueryCompiled: compile once, query twice" $ do+    let m =+          module' "conv_double_c"+            `exporting` ["double" // 2]+            `declaring` ["double" // 2]+            `defining` [ [term "double" [var "X", var "R"]]+                           <=> [var "R" `is` (var "X" .* int 2)]+                       ]+    cp <- case compileParsedModules True [m] of+      Left err -> assertFailure ("compile failed: " ++ show err)+      Right (cp, _warnings) -> pure cp+    r1 <- runQueryCompiled cp (term "double" [int 21, var "R"]) "R"+    r1 @?= (Right 42 :: Either ConvertError Int)+    r2 <- runQueryCompiled cp (term "double" [int 50, var "R"]) "R"+    r2 @?= (Right 100 :: Either ConvertError Int)++-- | A non-compound goal is reported as a 'ConvertError', not a crash.+e2eMalformedGoal :: TestTree+e2eMalformedGoal =+  testCase "runQuery: non-compound goal -> Left MalformedGoal" $ do+    let m = module' "conv_noop" `declaring` ["p" // 1]+    r <- runQuery [m] (int 5) "R"+    r @?= (Left (MalformedGoal (IntTerm 5)) :: Either ConvertError Int)++-- | A numeric result decoded as an 'Int'.+e2eScalar :: TestTree+e2eScalar =+  testCase "runQuery: double(21, R) -> R = 42 :: Int" $ do+    let m =+          module' "conv_double"+            `exporting` ["double" // 2]+            `declaring` ["double" // 2]+            `defining` [ [term "double" [var "X", var "R"]]+                           <=> [var "R" `is` (var "X" .* int 2)]+                       ]+    r <- runQuery [m] (term "double" [int 21, var "R"]) "R"+    r @?= (Right 42 :: Either ConvertError Int)++-- | A structural list result decoded as @[Int]@. The list term built by+-- 'toTerm' round-trips through unification and the runtime binding.+e2eList :: TestTree+e2eList =+  testCase "runQuery: pack(R) -> R = [1,2,3] :: [Int]" $ do+    let m =+          module' "conv_pack"+            `exporting` ["pack" // 1]+            `declaring` ["pack" // 1]+            `defining` [ [term "pack" [var "R"]]+                           <=> [var "R" .=. toTerm ([1, 2, 3] :: [Int])]+                       ]+    r <- runQuery [m] (term "pack" [var "R"]) "R"+    r @?= (Right [1, 2, 3] :: Either ConvertError [Int])++-- | 'runQueryWith' decoding several goal variables into a tuple.+e2eRecord :: TestTree+e2eRecord =+  testCase "runQueryWith: pair(X, Y) -> (1, 2)" $ do+    let m =+          module' "conv_pair"+            `exporting` ["pair" // 2]+            `declaring` ["pair" // 2]+            `defining` [ [term "pair" [var "X", var "Y"]]+                           <=> [var "X" .=. int 1, var "Y" .=. int 2]+                       ]+    r <-+      runQueryWith+        [m]+        (term "pair" [var "X", var "Y"])+        (\bs -> (,) <$> decodeVar "X" bs <*> decodeVar "Y" bs)+    r @?= (Right (1, 2) :: Either ConvertError (Int, Int))++-- ---------------------------------------------------------------------------+-- Custom host functions+-- ---------------------------------------------------------------------------++-- | A program exercising every adapter. Compilation does not resolve+-- @host:@ names, so all custom functions are supplied at run time by the+-- registry; each rule binds @R@ to the result of one host call.+hostProgram :: Module+hostProgram =+  module' "conv_host"+    `exporting` [ "compute_add" // 2,+                  "compute_shout" // 2,+                  "compute_eff" // 2,+                  "compute_now" // 1,+                  "compute_sum" // 1,+                  "compute_add3" // 1,+                  "compute_add3m" // 1,+                  "compute_raw" // 2,+                  "compute_nested" // 1,+                  "bad_arity" // 1,+                  "bad_type" // 1,+                  "bad_unbound" // 2,+                  "ov" // 1,+                  "use_builtin" // 1+                ]+    `declaring` [ "compute_add" // 2,+                  "compute_shout" // 2,+                  "compute_eff" // 2,+                  "compute_now" // 1,+                  "compute_sum" // 1,+                  "compute_add3" // 1,+                  "compute_add3m" // 1,+                  "compute_raw" // 2,+                  "compute_nested" // 1,+                  "bad_arity" // 1,+                  "bad_type" // 1,+                  "bad_unbound" // 2,+                  "ov" // 1,+                  "use_builtin" // 1+                ]+    `defining` [ [term "compute_add" [var "X", var "R"]]+                   <=> [var "R" `is` hostCall "my_add" [var "X", int 3]],+                 [term "compute_shout" [var "X", var "R"]]+                   <=> [var "R" `is` hostCall "shout" [var "X"]],+                 [term "compute_eff" [var "X", var "R"]]+                   <=> [var "R" `is` hostCall "effectful_add" [var "X", int 10]],+                 [term "compute_now" [var "R"]]+                   <=> [var "R" `is` hostCall "now" []],+                 [term "compute_sum" [var "R"]]+                   <=> [var "R" `is` hostCall "sum_all" [int 1, int 2, int 3, int 4]],+                 [term "compute_add3" [var "R"]]+                   <=> [var "R" `is` hostCall "add3" [int 1, int 2, int 3]],+                 [term "compute_add3m" [var "R"]]+                   <=> [var "R" `is` hostCall "add3m" [int 1, int 2, int 3]],+                 [term "compute_raw" [var "X", var "R"]]+                   <=> [var "R" `is` hostCall "raw_inc" [var "X"]],+                 [term "compute_nested" [var "R"]]+                   <=> [ var "X" .=. int 5,+                         var "R" `is` hostCall "echo" [term "wrap" [var "X", int 2]]+                       ],+                 [term "bad_arity" [var "R"]]+                   <=> [var "R" `is` hostCall "my_add" [int 1]],+                 [term "bad_type" [var "R"]]+                   <=> [var "R" `is` hostCall "my_add" [text "hi", int 3]],+                 -- Y is a head variable left unbound by the goal, so it is an+                 -- unbound logical variable at run time (not a compile-time+                 -- singleton), which the argument marshalling must reject.+                 [term "bad_unbound" [var "Y", var "R"]]+                   <=> [var "R" `is` hostCall "my_add" [var "Y", int 3]],+                 [term "ov" [var "R"]]+                   <=> [var "R" `is` hostCall "+" [int 1, int 1]],+                 [term "use_builtin" [var "R"]]+                   <=> [var "R" `is` hostCall "-" [int 10, int 3]]+               ]++-- | The default registry extended with one function per adapter kind.+hostRegistry :: HostCallRegistry+hostRegistry =+  withDefaultHostFunctions+    [ ("my_add", hostFn2 ((+) :: Int -> Int -> Int)),+      ("shout", hostFn1 T.toUpper),+      -- effectful (Chr / IO) binary adapter+      ("effectful_add", hostFn2M (\a b -> liftIO (pure ((a + b) :: Int)))),+      -- nullary effectful adapter+      ("now", hostFn0M (liftIO (pure (7 :: Int)))),+      -- variadic, Term-marshalled+      ("sum_all", hostFnN sumTerms),+      -- ternary, pure and effectful+      ("add3", hostFn3 (\a b c -> (a + b + c) :: Int)),+      ("add3m", hostFn3M (\a b c -> pure ((a + b + c) :: Int))),+      -- raw escape hatch: no Term marshalling, operates on Value directly+      ( "raw_inc",+        hostFnValues $ \vals -> case vals of+          [VInt n] -> pure (VInt (n + 1))+          _ -> pure (VInt 0)+      ),+      -- identity over Term, to observe deep dereferencing+      ("echo", hostFn1 (id :: Term -> Term))+    ]+  where+    sumTerms :: [Term] -> Either ConvertError Term+    sumTerms ts = toTerm . sum <$> (traverse fromTerm ts :: Either ConvertError [Int])++runHost :: (FromTerm a) => HostCallRegistry -> Term -> IO (Either ConvertError a)+runHost reg goal = runQueryWithHostCallRegistry reg [hostProgram] goal (decodeVar "R")++-- | Assert that running @goal@ raises a runtime error whose message+-- contains @needle@.+expectHostError :: String -> Term -> IO ()+expectHostError needle goal = do+  outcome <- try @SomeException (runHost hostRegistry goal :: IO (Either ConvertError Term))+  case outcome of+    Left exc ->+      assertBool+        ("expected error containing " ++ show needle ++ ", got: " ++ show exc)+        (needle `isInfixOf` show exc)+    Right r -> assertFailure ("expected an error, got success: " ++ show r)++hostFunctionTests :: TestTree+hostFunctionTests =+  testGroup+    "host functions"+    [ testCase "hostFn2: host:my_add(2, 3) -> 5" $ do+        r <- runHost hostRegistry (term "compute_add" [int 2, var "R"])+        r @?= (Right 5 :: Either ConvertError Int),+      testCase "hostFn1: host:shout(\"hi\") -> \"HI\"" $ do+        r <- runHost hostRegistry (term "compute_shout" [text "hi", var "R"])+        r @?= (Right "HI" :: Either ConvertError Text),+      testCase "hostFn2M: effectful binary adapter runs in Chr/IO" $ do+        r <- runHost hostRegistry (term "compute_eff" [int 5, var "R"])+        r @?= (Right 15 :: Either ConvertError Int),+      testCase "hostFn0M: nullary effectful host:now() -> 7" $ do+        r <- runHost hostRegistry (term "compute_now" [var "R"])+        r @?= (Right 7 :: Either ConvertError Int),+      testCase "hostFnN: variadic host:sum_all(1,2,3,4) -> 10" $ do+        r <- runHost hostRegistry (term "compute_sum" [var "R"])+        r @?= (Right 10 :: Either ConvertError Int),+      testCase "hostFn3: host:add3(1,2,3) -> 6" $ do+        r <- runHost hostRegistry (term "compute_add3" [var "R"])+        r @?= (Right 6 :: Either ConvertError Int),+      testCase "hostFn3M: effectful ternary adapter -> 6" $ do+        r <- runHost hostRegistry (term "compute_add3m" [var "R"])+        r @?= (Right 6 :: Either ConvertError Int),+      testCase "hostFnValues: raw Value adapter host:raw_inc(41) -> 42" $ do+        r <- runHost hostRegistry (term "compute_raw" [int 41, var "R"])+        r @?= (Right 42 :: Either ConvertError Int),+      testCase "arg marshalling deep-derefs a variable nested in a compound" $ do+        r <- runHost hostRegistry (term "compute_nested" [var "R"])+        case (r :: Either ConvertError Term) of+          Right (CompoundTerm _ args) ->+            assertBool+              ("nested variable not resolved to 5: " ++ show args)+              (IntTerm 5 `elem` args)+          other -> assertFailure ("unexpected result: " ++ show other),+      testCase "arity mismatch raises a runtime error" $+        expectHostError "expected 2 argument" (term "bad_arity" [var "R"]),+      testCase "type mismatch raises a runtime error" $+        expectHostError "TypeMismatch" (term "bad_type" [var "R"]),+      testCase "unbound argument raises a runtime error" $+        expectHostError "UnboundValue" (term "bad_unbound" [var "Y", var "R"]),+      testCase "withDefaultHostFunctions: a custom entry overrides a builtin" $ do+        let overrideReg =+              withDefaultHostFunctions+                [("+", hostFn2 (\a b -> (a * 100 + b) :: Int))]+        r <- runHost overrideReg (term "ov" [var "R"])+        r @?= (Right 101 :: Either ConvertError Int),+      testCase "hostFunctions <> base still resolves builtins" $ do+        let composed = hostFunctions [] <> baseHostCallRegistry+        r <- runHost composed (term "use_builtin" [var "R"])+        r @?= (Right 7 :: Either ConvertError Int)+    ]
+ test/YCHR/DSLTest.hs view
@@ -0,0 +1,755 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.DSLTest (tests) where++import Data.Map.Strict qualified as Map+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import YCHR.DSL+import YCHR.Internal.Parsed++tests :: TestTree+tests =+  testGroup+    "DSL"+    [ moduleTests,+      declarationTests,+      functionDeclarationTests,+      typeDeclarationTests,+      operatorDeclarationTests,+      ruleTests,+      guardTests,+      termTests,+      lambdaTests,+      numericInstanceTests,+      integrationTests,+      endToEndTests+    ]++--------------------------------------------------------------------------------+-- Fixtures+--------------------------------------------------------------------------------++orderModule :: Module+orderModule =+  module' "Order"+    `declaring` ["leq" // 2]+    `defining` [ "refl" @: ([term "leq" [var "X", var "X"]] <=> [atom "true"])+               ]++logicModule :: Module+logicModule =+  module' "Logic"+    `importing` ["Order"]+    `defining` [ "trans"+                   @: ( [term "leq" [var "X", var "Y"], term "leq" [var "Y", var "Z"]]+                          ==> [term "leq" [var "X", var "Z"]]+                      )+               ]++--------------------------------------------------------------------------------+-- Tests+--------------------------------------------------------------------------------++moduleTests :: TestTree+moduleTests =+  testGroup+    "module"+    [ testCase "module' produces empty module" $+        module' "Foo" @?= emptyModule "Foo",+      testCase "importing sets modImports" $+        module' "Foo" `importing` ["Bar", "Baz"]+          @?= (emptyModule "Foo")+            { imports =+                [ noAnnP (ModuleImport "Bar" Nothing),+                  noAnnP (ModuleImport "Baz" Nothing)+                ]+            },+      testCase "declaring sets modDecls" $+        module' "Foo" `declaring` ["leq" // 2]+          @?= (emptyModule "Foo")+            { decls = [noAnn (ConstraintDecl "leq" 2 Nothing Nothing)]+            },+      testCase "defining sets modRules" $+        let r = [term "leq" [var "X"]] <=> [atom "true"]+         in module' "Foo" `defining` [r]+              @?= (emptyModule "Foo") {rules = [r]},+      testCase "chaining importing, declaring, defining" $+        let r = [term "c" []] <=> [atom "true"]+         in module' "M"+              `importing` ["A"]+              `declaring` ["c" // 0]+              `defining` [r]+              @?= (emptyModule "M")+                { imports = [noAnnP (ModuleImport "A" Nothing)],+                  decls = [noAnn (ConstraintDecl "c" 0 Nothing Nothing)],+                  rules = [r]+                },+      testCase "exporting sets modExports" $+        module' "Foo" `exporting` ["leq" // 2]+          @?= (emptyModule "Foo")+            { exports = Just (noAnnP [ConstraintDecl "leq" 2 Nothing Nothing])+            },+      testCase "library appends a LibraryImport" $+        module' "Foo" `library` "lists" `library` "math"+          @?= (emptyModule "Foo")+            { imports =+                [ noAnnP (LibraryImport "lists" Nothing),+                  noAnnP (LibraryImport "math" Nothing)+                ]+            },+      testCase "exporting appends to an existing export list" $+        -- Two calls should accumulate, not replace — pinning the+        -- documented append-semantics in DSL.hs.+        module' "Foo" `exporting` ["a" // 1] `exporting` ["b" // 2]+          @?= (emptyModule "Foo")+            { exports =+                Just+                  ( noAnnP+                      [ ConstraintDecl "a" 1 Nothing Nothing,+                        ConstraintDecl "b" 2 Nothing Nothing+                      ]+                  )+            },+      testCase "withEquations appends to module.equations" $+        let eq = equation "f" [int 0] [] (int 1)+            m = module' "M" `withEquations` [eq]+         in m.equations @?= [noAnnP eq]+    ]+  where+    emptyModule n =+      Module+        { name = n,+          nameLoc = dummyLoc,+          imports = [],+          decls = [],+          extensionTypes = [],+          typeDecls = [],+          rules = [],+          equations = [],+          extensions = [],+          classExtensions = [],+          exports = Nothing+        }++declarationTests :: TestTree+declarationTests =+  testGroup+    "declaration"+    [ testCase "\"leq\" // 2 produces ConstraintDecl" $+        "leq" // 2 @?= ConstraintDecl "leq" 2 Nothing Nothing,+      testCase "\"foo\" // 0 produces ConstraintDecl with arity 0" $+        "foo" // 0 @?= ConstraintDecl "foo" 0 Nothing Nothing,+      testCase "extendClassType produces ExtendClassTypeDecl" $+        extendClassType+          "classify"+          [TypeCon (Unqualified "int") []]+          (TypeCon (Unqualified "int") [])+          @?= ExtendClassTypeDecl+            { name = "classify",+              arity = 1,+              argTypes = Just [TypeCon (Unqualified "int") []],+              returnType = Just (TypeCon (Unqualified "int") []),+              target = Nothing+            },+      testCase "withExtensions appends to module.extensions" $+        let eq = equation "classify" [atom "dog"] [] (atom "animal")+            m = module' "ext" `withExtensions` [eq]+         in m.extensions @?= [noAnnP eq],+      testCase "withClassExtensions appends to module.classExtensions" $+        let eq = equation "classify" [atom "dog"] [] (atom "animal")+            m = module' "ext" `withClassExtensions` [eq]+         in m.classExtensions @?= [noAnnP eq]+    ]++functionDeclarationTests :: TestTree+functionDeclarationTests =+  testGroup+    "function declaration"+    [ testCase "function produces FunctionDecl with isOpen = False" $+        function "factorial" 1+          @?= FunctionDecl+            { name = "factorial",+              arity = 1,+              argTypes = Nothing,+              returnType = Nothing,+              isOpen = False,+              kind = DKFunction,+              requiring = Nothing+            },+      testCase "openFunction produces FunctionDecl with isOpen = True" $+        openFunction "show" 1+          @?= FunctionDecl+            { name = "show",+              arity = 1,+              argTypes = Nothing,+              returnType = Nothing,+              isOpen = True,+              kind = DKFunction,+              requiring = Nothing+            },+      testCase "class_ produces FunctionDecl with kind = DKClass" $+        class_ "size" 1+          @?= FunctionDecl+            { name = "size",+              arity = 1,+              argTypes = Nothing,+              returnType = Nothing,+              isOpen = False,+              kind = DKClass,+              requiring = Nothing+            },+      testCase "openClass produces FunctionDecl with kind = DKClass and isOpen = True" $+        openClass "show" 1+          @?= FunctionDecl+            { name = "show",+              arity = 1,+              argTypes = Nothing,+              returnType = Nothing,+              isOpen = True,+              kind = DKClass,+              requiring = Nothing+            },+      testCase "extendClassType arity matches argTypes length" $+        let intCon = TypeCon (Unqualified "int") []+         in extendClassType "add" [intCon, intCon] intCon+              @?= ExtendClassTypeDecl+                { name = "add",+                  arity = 2,+                  argTypes = Just [intCon, intCon],+                  returnType = Just intCon,+                  target = Nothing+                },+      testCase "extendClassType with zero args is allowed" $+        let intCon = TypeCon (Unqualified "int") []+         in extendClassType "zero" [] intCon+              @?= ExtendClassTypeDecl+                { name = "zero",+                  arity = 0,+                  argTypes = Just [],+                  returnType = Just intCon,+                  target = Nothing+                }+    ]++typeDeclarationTests :: TestTree+typeDeclarationTests =+  testGroup+    "type declaration"+    [ testCase "typeExport with no allowlist" $+        typeExport "color" 0 @?= TypeExportDecl "color" 0 Nothing,+      testCase "typeExportWith carries the allowlist" $+        typeExportWith "color" 0 ["red", "green", "blue"]+          @?= TypeExportDecl "color" 0 (Just ["red", "green", "blue"]),+      testCase "typeExportWith with empty allowlist exports type only" $+        -- Empty list is distinct from Nothing: exports the type tag+        -- without any of its constructors.+        typeExportWith "opaque" 0 []+          @?= TypeExportDecl "opaque" 0 (Just []),+      testCase "tyDef with no type variables (mono-type)" $+        tyDef "color" [] [dataCtor "red" [], dataCtor "green" []]+          @?= TypeDefinition+            { name = Unqualified "color",+              typeVars = [],+              kind =+                Algebraic+                  [ DataConstructor (Unqualified "red") [],+                    DataConstructor (Unqualified "green") []+                  ],+              loc = dummyLoc+            },+      testCase "tyDef with type variables (parametric)" $+        -- The recursive 'list(a)' shape exercises both TypeVar (in cons+        -- field 0) and TypeCon-with-args (in cons field 1: list(a)).+        let listCon = TypeCon (Unqualified "list") [TypeVar "a"]+         in tyDef+              "list"+              ["a"]+              [ dataCtor "nil" [],+                dataCtor "cons" [TypeVar "a", listCon]+              ]+              @?= TypeDefinition+                { name = Unqualified "list",+                  typeVars = ["a"],+                  kind =+                    Algebraic+                      [ DataConstructor (Unqualified "nil") [],+                        DataConstructor (Unqualified "cons") [TypeVar "a", listCon]+                      ],+                  loc = dummyLoc+                }+    ]++operatorDeclarationTests :: TestTree+operatorDeclarationTests =+  testGroup+    "operator declaration"+    [ testCase "op produces OperatorDecl with the given fixity and type" $+        op 700 Xfx "is"+          @?= OperatorDecl+            OpDecl {fixity = 700, opType = Xfx, opName = "is"},+      testCase "op accepts each fixity variant we expose" $+        -- Spot-check the four OpType variants that don't appear in+        -- existing tests; if one of them were ever removed, this would+        -- catch it.+        [ op 200 Fy "-",+          op 500 Yfx "+",+          op 400 Xfy ":-",+          op 700 Xfx "<"+        ]+          @?= [ OperatorDecl (OpDecl 200 Fy "-"),+                OperatorDecl (OpDecl 500 Yfx "+"),+                OperatorDecl (OpDecl 400 Xfy ":-"),+                OperatorDecl (OpDecl 700 Xfx "<")+              ]+    ]++ruleTests :: TestTree+ruleTests =+  testGroup+    "rule"+    [ testCase "(<=>): simplification rule" $+        [term "a" []] <=> [atom "true"]+          @?= Rule+            Nothing+            (noAnnP (Simplification [a0]))+            (noAnnP [])+            (noAnnP [atom "true"]),+      testCase "(==>): propagation rule" $+        [term "a" []] ==> [term "b" []]+          @?= Rule+            Nothing+            (noAnnP (Propagation [a0]))+            (noAnnP [])+            (noAnnP [term "b" []]),+      testCase "(\\): simpagation rule" $+        [term "k" []] \\ [term "r" []] <=> [atom "true"]+          @?= Rule+            Nothing+            ( noAnnP+                ( Simpagation+                    [Constraint (Unqualified "k") []]+                    [Constraint (Unqualified "r") []]+                )+            )+            (noAnnP [])+            (noAnnP [atom "true"]),+      testCase "(@:): sets rule name" $+        ("my_rule" @: ([term "a" []] <=> [atom "true"]))+          @?= Rule+            (Just (noAnn "my_rule"))+            (noAnnP (Simplification [a0]))+            (noAnnP [])+            (noAnnP [atom "true"]),+      testCase "(|-): sets rule guard" $+        (([term "a" [var "X"]] <=> [atom "true"]) |- [var "X" .=. atom "zero"])+          @?= Rule+            Nothing+            (noAnnP (Simplification [Constraint (Unqualified "a") [var "X"]]))+            (noAnnP [var "X" .=. atom "zero"])+            (noAnnP [atom "true"])+    ]+  where+    a0 = Constraint (Unqualified "a") []++guardTests :: TestTree+guardTests =+  testGroup+    "rule guard"+    [ testCase "(|-) attaches a single-conjunct guard" $+        (([term "p" [var "X"]] <=> [bool True]) |- [var "X" .> int 0])+          @?= Rule+            Nothing+            (noAnnP (Simplification [Constraint (Unqualified "p") [var "X"]]))+            (noAnnP [var "X" .> int 0])+            (noAnnP [bool True]),+      testCase "(|-) attaches a multi-conjunct guard" $+        -- The guard slot in 'Rule' is a list, so a list with multiple+        -- conjuncts is the surface form for @g1, g2, g3@. Pin that+        -- shape directly.+        ( ([term "p" [var "X"]] <=> [bool True])+            |- [var "X" .> int 0, var "X" .< int 100, var "X" .=. var "Y"]+        )+          @?= Rule+            Nothing+            (noAnnP (Simplification [Constraint (Unqualified "p") [var "X"]]))+            ( noAnnP+                [ var "X" .> int 0,+                  var "X" .< int 100,+                  var "X" .=. var "Y"+                ]+            )+            (noAnnP [bool True]),+      testCase "(|-) attaches a guard to a propagation rule" $+        ( ([term "p" [var "X"]] ==> [term "q" [var "X"]])+            |- [var "X" .> int 0]+        )+          @?= Rule+            Nothing+            (noAnnP (Propagation [Constraint (Unqualified "p") [var "X"]]))+            (noAnnP [var "X" .> int 0])+            (noAnnP [term "q" [var "X"]])+    ]++termTests :: TestTree+termTests =+  testGroup+    "term"+    [ testCase "var produces VarTerm" $+        var "X" @?= VarTerm "X",+      testCase "atom produces AtomTerm" $+        atom "true" @?= CompoundTerm (Unqualified "true") [],+      testCase "term produces unqualified CompoundTerm" $+        term "f" [var "X"] @?= CompoundTerm (Unqualified "f") [var "X"],+      testCase "qterm produces qualified CompoundTerm" $+        qterm "Order" "leq" [var "X", var "Y"]+          @?= CompoundTerm (Qualified "Order" "leq") [VarTerm "X", VarTerm "Y"],+      testCase "qterm with zero arguments" $+        qterm "M" "marker" []+          @?= CompoundTerm (Qualified "M" "marker") [],+      testCase "(.=.) produces unification term" $+        var "X" .=. var "Y"+          @?= CompoundTerm (Unqualified "=") [VarTerm "X", VarTerm "Y"],+      testCase "hostCall produces host wrapper" $+        hostCall "print" [var "X"]+          @?= CompoundTerm (Qualified "host" "print") [VarTerm "X"],+      testCase "wildcard produces Wildcard" $+        wildcard @?= Wildcard,+      testCase "`is` produces is term" $+        var "X" `is` term "+" [int 1, int 2]+          @?= CompoundTerm+            (Unqualified "is")+            [VarTerm "X", CompoundTerm (Unqualified "+") [IntTerm 1, IntTerm 2]],+      -- Literal builders not yet exercised in their own test.+      testCase "int produces IntTerm" $+        int 42 @?= IntTerm 42,+      testCase "float produces FloatTerm" $+        float 1.5 @?= FloatTerm 1.5,+      testCase "text produces TextTerm" $+        text "hello" @?= TextTerm "hello",+      testCase "bool True maps to AtomTerm \"true\"" $+        bool True @?= CompoundTerm (Unqualified "true") [],+      testCase "bool False maps to AtomTerm \"false\"" $+        bool False @?= CompoundTerm (Unqualified "false") []+    ]++lambdaTests :: TestTree+lambdaTests =+  testGroup+    "lambda and funRef"+    [ testCase "lambda builds the '->' compound shape" $+        -- A lambda is sugar for ->(fun(args), body); the AST shows+        -- both the params block and the body as siblings of '->'.+        lambda [var "X"] (var "X" .+ int 1)+          @?= CompoundTerm+            (Unqualified "->")+            [ CompoundTerm (Unqualified "fun") [VarTerm "X"],+              CompoundTerm (Unqualified "+") [VarTerm "X", IntTerm 1]+            ],+      testCase "lambda with multiple params" $+        lambda [var "X", var "Y"] (var "X" .+ var "Y")+          @?= CompoundTerm+            (Unqualified "->")+            [ CompoundTerm+                (Unqualified "fun")+                [VarTerm "X", VarTerm "Y"],+              CompoundTerm (Unqualified "+") [VarTerm "X", VarTerm "Y"]+            ],+      testCase "higher-order lambda: returning a lambda" $+        -- 'fun(X) -> fun(Y) -> X + Y end end' — a curried add. The+        -- outer body is itself a '->' compound.+        lambda [var "X"] (lambda [var "Y"] (var "X" .+ var "Y"))+          @?= CompoundTerm+            (Unqualified "->")+            [ CompoundTerm (Unqualified "fun") [VarTerm "X"],+              CompoundTerm+                (Unqualified "->")+                [ CompoundTerm (Unqualified "fun") [VarTerm "Y"],+                  CompoundTerm (Unqualified "+") [VarTerm "X", VarTerm "Y"]+                ]+            ],+      testCase "lambda with zero params" $+        lambda [] (int 42)+          @?= CompoundTerm+            (Unqualified "->")+            [ CompoundTerm (Unqualified "fun") [],+              IntTerm 42+            ],+      testCase "funRef builds fun(name/arity)" $+        funRef "factorial" 1+          @?= CompoundTerm+            (Unqualified "fun")+            [ CompoundTerm+                (Unqualified "/")+                [CompoundTerm (Unqualified "factorial") [], IntTerm 1]+            ],+      testCase "call_ wraps args after the callable" $+        call_ (funRef "f" 2) [int 1, int 2]+          @?= CompoundTerm+            (Unqualified "$call")+            [ funRef "f" 2,+              IntTerm 1,+              IntTerm 2+            ],+      testCase "call_ on a lambda value" $+        call_ (lambda [var "X"] (var "X" .+ int 1)) [int 5]+          @?= CompoundTerm+            (Unqualified "$call")+            [ lambda [var "X"] (var "X" .+ int 1),+              IntTerm 5+            ]+    ]++numericInstanceTests :: TestTree+numericInstanceTests =+  testGroup+    "Num instance and comparison sugar"+    [ -- The 'Num' instance for 'Term' lets users write @1 + 2@ instead+      -- of @int 1 .+ int 2@; fromInteger and +/-/* must compile to the+      -- corresponding compound terms.+      testCase "fromInteger: literal 7 produces IntTerm 7" $+        (7 :: Term) @?= IntTerm 7,+      testCase "Num (+) builds '+' compound" $+        ((var "X" + int 1) :: Term)+          @?= CompoundTerm (Unqualified "+") [VarTerm "X", IntTerm 1],+      testCase "Num (-) builds '-' compound" $+        ((var "X" - int 1) :: Term)+          @?= CompoundTerm (Unqualified "-") [VarTerm "X", IntTerm 1],+      testCase "Num (*) builds '*' compound" $+        ((var "X" * int 2) :: Term)+          @?= CompoundTerm (Unqualified "*") [VarTerm "X", IntTerm 2],+      testCase "negate builds unary '-' compound" $+        negate (var "X") @?= CompoundTerm (Unqualified "-") [VarTerm "X"],+      -- A negative literal must fold into the literal, not build a unary+      -- '-' compound: there is no unary minus in the prelude, so the+      -- compound form dies with an arity error at tell time.+      testCase "negative integer literal folds into IntTerm" $+        ((-1) :: Term) @?= IntTerm (-1),+      testCase "negate of an integer literal folds into IntTerm" $+        negate (int 3) @?= IntTerm (-3),+      testCase "negate of a float literal folds into FloatTerm" $+        negate (float 1.5) @?= FloatTerm (-1.5),+      testCase "abs builds 'abs' compound" $+        abs (var "X") @?= CompoundTerm (Unqualified "abs") [VarTerm "X"],+      testCase "signum builds 'sign' compound" $+        signum (var "X") @?= CompoundTerm (Unqualified "sign") [VarTerm "X"],+      -- Prefixed operators that bypass the Num machinery.+      testCase "(.+) (.-) (.*) (./) build the expected compounds" $+        [var "X" .+ int 1, var "X" .- int 1, var "X" .* int 2, var "X" ./ int 2]+          @?= [ CompoundTerm (Unqualified "+") [VarTerm "X", IntTerm 1],+                CompoundTerm (Unqualified "-") [VarTerm "X", IntTerm 1],+                CompoundTerm (Unqualified "*") [VarTerm "X", IntTerm 2],+                CompoundTerm (Unqualified "/") [VarTerm "X", IntTerm 2]+              ],+      -- Comparison sugar: each produces the surface operator name+      -- (note '.<=' renders as '=<', matching Prolog convention).+      testCase "comparison sugar builds correct compound names" $+        [ var "X" .< var "Y",+          var "X" .<= var "Y",+          var "X" .> var "Y",+          var "X" .>= var "Y",+          var "X" .== var "Y"+        ]+          @?= [ CompoundTerm (Unqualified "<") [VarTerm "X", VarTerm "Y"],+                CompoundTerm (Unqualified "=<") [VarTerm "X", VarTerm "Y"],+                CompoundTerm (Unqualified ">") [VarTerm "X", VarTerm "Y"],+                CompoundTerm (Unqualified ">=") [VarTerm "X", VarTerm "Y"],+                CompoundTerm (Unqualified "==") [VarTerm "X", VarTerm "Y"]+              ]+    ]++integrationTests :: TestTree+integrationTests =+  testGroup+    "integration"+    [ testCase "orderModule structure" $+        orderModule+          @?= Module+            { name = "Order",+              nameLoc = dummyLoc,+              imports = [],+              decls = [noAnn (ConstraintDecl "leq" 2 Nothing Nothing)],+              extensionTypes = [],+              typeDecls = [],+              rules =+                [ Rule+                    (Just (noAnn "refl"))+                    ( noAnnP+                        ( Simplification+                            [ Constraint+                                (Unqualified "leq")+                                [VarTerm "X", VarTerm "X"]+                            ]+                        )+                    )+                    (noAnnP [])+                    (noAnnP [CompoundTerm (Unqualified "true") []])+                ],+              equations = [],+              extensions = [],+              classExtensions = [],+              exports = Nothing+            },+      testCase "logicModule structure" $+        logicModule+          @?= Module+            { name = "Logic",+              nameLoc = dummyLoc,+              imports = [noAnnP (ModuleImport "Order" Nothing)],+              decls = [],+              extensionTypes = [],+              typeDecls = [],+              rules =+                [ Rule+                    (Just (noAnn "trans"))+                    ( noAnnP+                        ( Propagation+                            [ Constraint (Unqualified "leq") [VarTerm "X", VarTerm "Y"],+                              Constraint (Unqualified "leq") [VarTerm "Y", VarTerm "Z"]+                            ]+                        )+                    )+                    (noAnnP [])+                    ( noAnnP+                        [CompoundTerm (Unqualified "leq") [VarTerm "X", VarTerm "Z"]]+                    )+                ],+              equations = [],+              extensions = [],+              classExtensions = [],+              exports = Nothing+            }+    ]++--------------------------------------------------------------------------------+-- End-to-end: build with the DSL, compile, and run+--------------------------------------------------------------------------------++endToEndTests :: TestTree+endToEndTests =+  testGroup+    "endToEnd"+    [ leqEndToEnd,+      crossModuleEndToEnd,+      factorialEndToEnd,+      chrTypeEndToEnd,+      guardEndToEnd+    ]++-- | A full @leq@ handler exercising simplification, simpagation, and+-- propagation. Querying the reflexive case @leq(X, X)@ leaves @X@ unbound+-- (matches @test/golden/leq@).+leqEndToEnd :: TestTree+leqEndToEnd =+  testCase "leq: reflexivity collapses leq(X, X)" $ do+    let m =+          module' "order"+            `exporting` ["leq" // 2]+            `declaring` ["leq" // 2]+            `defining` [ "refl" @: [term "leq" [var "X", var "X"]] <=> [bool True],+                         "antisymm"+                           @: [term "leq" [var "X", var "Y"], term "leq" [var "Y", var "X"]]+                           <=> [var "X" .=. var "Y"],+                         "idemp"+                           @: [term "leq" [var "X", var "Y"]]+                           \\ [term "leq" [var "X", var "Y"]]+                           <=> [bool True],+                         "trans"+                           @: [term "leq" [var "X", var "Y"], term "leq" [var "Y", var "Z"]]+                           ==> [term "leq" [var "X", var "Z"]]+                       ]+    bindings <- runDSL [m] (term "leq" [var "X", var "X"])+    Map.keys bindings @?= ["X"]++-- | Two-module program. The library module @cross_lib@ exports a @double@+-- constraint; the main module @cross_main@ uses it to define @quadruple@.+-- Mirrors the @cross_module_import@ golden test.+crossModuleEndToEnd :: TestTree+crossModuleEndToEnd =+  testCase "cross-module: quadruple via cross_lib:double" $ do+    let lib =+          module' "cross_lib"+            `exporting` ["double" // 2]+            `declaring` ["double" // 2]+            `defining` [ [term "double" [var "X", var "R"]]+                           <=> [var "R" `is` (var "X" .* int 2)]+                       ]+        main_ =+          module' "cross_main"+            `importing` ["cross_lib"]+            `exporting` ["quadruple" // 2]+            `declaring` ["quadruple" // 2]+            `defining` [ [term "quadruple" [var "X", var "R"]]+                           <=> [ term "double" [var "X", var "Y"],+                                 term "double" [var "Y", var "R"]+                               ]+                       ]+    bindings <- runDSL [lib, main_] (term "quadruple" [int 7, var "R"])+    Map.lookup "R" bindings @?= Just (IntTerm 28)++-- | Function definition with multiple equations and recursion. Driven via a+-- @compute(R)@ constraint that calls @factorial(5)@ in its body.+factorialEndToEnd :: TestTree+factorialEndToEnd =+  testCase "factorial: function equations and recursion" $ do+    let m =+          module' "fact"+            `exporting` ["compute" // 1]+            `declaring` [ "compute" // 1,+                          function "factorial" 1+                        ]+            `withEquations` [ equation "factorial" [int 0] [] (int 1),+                              equation+                                "factorial"+                                [var "N"]+                                [var "N" .> int 0]+                                (var "N" .* call_ (funRef "factorial" 1) [var "N" .- int 1])+                            ]+            `defining` [ [term "compute" [var "R"]]+                           <=> [var "R" `is` call_ (funRef "factorial" 1) [int 5]]+                       ]+    bindings <- runDSL [m] (term "compute" [var "R"])+    Map.lookup "R" bindings @?= Just (IntTerm 120)++-- | Algebraic-type definition (@:- chr_type color ---> red ; green ; blue@).+-- The constraint @paint/1@ is declared with a typed argument; the rule simply+-- removes any @paint@ to verify the typed program compiles and runs.+chrTypeEndToEnd :: TestTree+chrTypeEndToEnd =+  testCase "chr_type color: typed constraint compiles and runs" $ do+    let m =+          module' "tc"+            `exporting` ["paint" // 1]+            `declaring` ["paint" // 1]+            `chrType` tyDef+              "color"+              []+              [ dataCtor "red" [],+                dataCtor "green" [],+                dataCtor "blue" []+              ]+            `defining` [[term "paint" [var "C"]] <=> [bool True]]+    bindings <- runDSL [m] (term "paint" [atom "red"])+    Map.keys bindings @?= []++-- | Simplification with a guard built from @is@ and @(.<)@. Mirrors the+-- @clamp@ shape of @test/golden/guard@: the low branch fires when @X < Lo@,+-- so @clamp(3, 5, R)@ binds @R = 5@.+guardEndToEnd :: TestTree+guardEndToEnd =+  testCase "guard: clamp(3, 5, R) → R = 5" $ do+    let m =+          module' "g"+            `exporting` ["clamp" // 3]+            `declaring` ["clamp" // 3]+            `defining` [ "low"+                           @: [term "clamp" [var "X", var "Lo", var "R"]]+                           <=> [var "R" .=. var "Lo"]+                           |- [var "X" .< var "Lo"],+                         "high"+                           @: [term "clamp" [var "X", var "Lo", var "R"]]+                           <=> [var "R" .=. var "X"]+                           |- [var "X" .>= var "Lo"]+                       ]+    bindings <- runDSL [m] (term "clamp" [int 3, int 5, var "R"])+    Map.lookup "R" bindings @?= Just (IntTerm 5)
+ test/YCHR/DesugarTest.hs view
@@ -0,0 +1,821 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.DesugarTest (tests) where++import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import YCHR.DSL+import YCHR.Internal.Collect (rewriteImports)+import YCHR.Internal.Desugar+  ( DesugarError (..),+    desugarProgram,+    extractSymbolTable,+    liftAllLambdas,+  )+import YCHR.Internal.Desugared qualified as D+import YCHR.Internal.Diagnostic (noDiag)+import YCHR.Internal.PExpr (PExpr (Atom))+import YCHR.Internal.Parsed+import YCHR.Internal.Resolve (ResolveError (..), resolveProgram)+import YCHR.Internal.Resolved qualified as R+import YCHR.Internal.Types+  ( ConstraintType (..),+    Identifier (..),+    lookupSymbol,+    mkSymbolTable,+    symbolTableSize,+  )++getNode :: AnnP a -> a+getNode (AnnP n _ _) = n++tests :: TestTree+tests =+  testGroup+    "Desugar"+    [ headTests,+      hnfTests,+      guardTests,+      bodyTests,+      errorTests,+      flatteningTests,+      ruleNameTests,+      symbolTableTests,+      lambdaLiftTests+    ]++resolve :: [Module] -> IO R.Program+resolve mods = case resolveProgram (rewriteImports mods) of+  Right p -> return p+  Left errs -> assertFailure $ "unexpected resolve errors: " ++ show errs++desugar :: [Module] -> IO D.Program+desugar mods = do+  rprog <- resolve mods+  case desugarProgram rprog of+    Right p -> return p+    Left errs -> assertFailure $ "unexpected errors: " ++ show errs++singleRule :: [Module] -> IO D.Rule+singleRule mods = do+  prog <- desugar mods+  let rules = prog.rules+  case rules of+    [r] -> return r+    rs -> assertFailure $ "expected 1 rule, got " ++ show (length rs)++-- | Test-local helper: build a fully-qualified 'Constraint' value to+-- populate raw 'Simplification' / 'Propagation' / 'Simpagation' heads.+-- The DSL itself only exposes the 'Term' constructors 'term' / 'qterm';+-- this helper is the AST-level escape hatch the desugar tests need.+qcon :: Text -> Text -> [Term] -> Constraint+qcon m n args = Constraint (Qualified m n) args++leqQual :: Constraint+leqQual = qcon "M" "leq" [var "X", var "Y"]++leqQual2 :: Constraint+leqQual2 = qcon "M" "leq" [var "A", var "B"]++-- | Convert a fully-qualified parsed 'Constraint' to a+-- 'D.HeadConstraint' for comparison against post-desugar values.+-- Only valid on constraints whose name is 'Qualified' and whose+-- arguments are HNF-shape ('VarTerm' or 'Wildcard'); the test+-- fixtures here always pass that.+hc :: Constraint -> D.HeadConstraint+hc (Constraint (Qualified m n) args) =+  D.HeadConstraint (D.QualifiedName m n) (map toHeadArg args)+  where+    toHeadArg (VarTerm v) = D.HeadVar v+    toHeadArg Wildcard = D.HeadWildcard+    toHeadArg t = error ("hc: non-head-arg in test fixture: " ++ show t)+hc c = error ("hc: expected Qualified constraint, got " ++ show c)++mod1rule :: Head -> Rule+mod1rule h = Rule Nothing (noAnnP h) (noAnnP []) (noAnnP [atom "true"])++simpleModule :: Head -> Module+simpleModule h = module' "M" `defining` [mod1rule h]++--------------------------------------------------------------------------------+-- Head normalization+--------------------------------------------------------------------------------++headTests :: TestTree+headTests =+  testGroup+    "head-normalization"+    [ testCase "Simplification maps to kept=[], removed=constraints" $ do+        rule <- singleRule [simpleModule (Simplification [leqQual])]+        getNode rule.head @?= D.Head {kept = [], removed = [hc leqQual]},+      testCase "Propagation maps to kept=constraints, removed=[]" $ do+        rule <- singleRule [simpleModule (Propagation [leqQual])]+        getNode rule.head @?= D.Head {kept = [hc leqQual], removed = []},+      testCase "Simpagation maps kept and removed correctly" $ do+        rule <- singleRule [simpleModule (Simpagation [leqQual] [leqQual2])]+        getNode rule.head @?= D.Head {kept = [hc leqQual], removed = [hc leqQual2]}+    ]++--------------------------------------------------------------------------------+-- Head Normal Form+--------------------------------------------------------------------------------++hnfTests :: TestTree+hnfTests =+  testGroup+    "hnf"+    [ testCase "distinct variables: no change" $ do+        let m = simpleModule (Simplification [qcon "M" "leq" [var "X", var "Y"]])+        rule <- singleRule [m]+        getNode rule.head+          @?= D.Head+            []+            [ D.HeadConstraint+                (D.QualifiedName "M" "leq")+                [ D.HeadVar "X",+                  D.HeadVar "Y"+                ]+            ]+        getNode rule.guard @?= [],+      testCase "duplicate variable generates equality guard" $ do+        let m = simpleModule (Simplification [qcon "M" "leq" [var "X", var "X"]])+        rule <- singleRule [m]+        getNode rule.head+          @?= D.Head+            []+            [ D.HeadConstraint+                (D.QualifiedName "M" "leq")+                [ D.HeadVar "X",+                  D.HeadVar "_hnf_0"+                ]+            ]+        getNode rule.guard @?= [D.GuardEqual (R.VarExpr "X") (R.VarExpr "_hnf_0")],+      testCase "non-variable argument (integer) generates equality guard" $ do+        let m = simpleModule (Simplification [qcon "M" "leq" [var "X", IntTerm 5]])+        rule <- singleRule [m]+        getNode rule.head+          @?= D.Head+            []+            [ D.HeadConstraint+                (D.QualifiedName "M" "leq")+                [ D.HeadVar "X",+                  D.HeadVar "_hnf_0"+                ]+            ]+        getNode rule.guard @?= [D.GuardEqual (R.VarExpr "_hnf_0") (R.IntExpr 5)],+      testCase "non-variable argument (atom) generates equality guard" $ do+        let m = simpleModule (Simplification [qcon "M" "leq" [var "X", atom "foo"]])+        rule <- singleRule [m]+        getNode rule.head+          @?= D.Head+            []+            [ D.HeadConstraint+                (D.QualifiedName "M" "leq")+                [ D.HeadVar "X",+                  D.HeadVar "_hnf_0"+                ]+            ]+        getNode rule.guard @?= [D.GuardMatch (R.VarExpr "_hnf_0") (Unqualified "foo") 0],+      testCase "cross-constraint duplicate variable" $ do+        let m =+              simpleModule+                ( Simplification+                    [ qcon "M" "leq" [var "X", var "Y"],+                      qcon "M" "leq" [var "Y", var "Z"]+                    ]+                )+        rule <- singleRule [m]+        getNode rule.head+          @?= D.Head+            []+            [ D.HeadConstraint (D.QualifiedName "M" "leq") [D.HeadVar "X", D.HeadVar "Y"],+              D.HeadConstraint (D.QualifiedName "M" "leq") [D.HeadVar "_hnf_0", D.HeadVar "Z"]+            ]+        getNode rule.guard @?= [D.GuardEqual (R.VarExpr "Y") (R.VarExpr "_hnf_0")],+      testCase "simpagation: kept processed before removed" $ do+        let m =+              simpleModule+                ( Simpagation+                    [qcon "M" "leq" [var "X", var "Y"]]+                    [qcon "M" "leq" [var "Y", var "Z"]]+                )+        rule <- singleRule [m]+        getNode rule.head+          @?= D.Head+            [D.HeadConstraint (D.QualifiedName "M" "leq") [D.HeadVar "X", D.HeadVar "Y"]]+            [D.HeadConstraint (D.QualifiedName "M" "leq") [D.HeadVar "_hnf_0", D.HeadVar "Z"]]+        getNode rule.guard @?= [D.GuardEqual (R.VarExpr "Y") (R.VarExpr "_hnf_0")],+      testCase "hnf guards prepended before user guards" $ do+        let m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [qcon "M" "leq" [var "X", var "X"]]))+                               (noAnnP [hostCall "gt" [var "X", IntTerm 0]])+                               (noAnnP [atom "true"])+                           ]+        rule <- singleRule [m]+        getNode rule.guard+          @?= [ D.GuardEqual (R.VarExpr "X") (R.VarExpr "_hnf_0"),+                D.GuardExpr (R.HostExpr "gt" [R.VarExpr "X", R.IntExpr 0])+              ],+      testCase "wildcard passes through HNF unchanged" $ do+        let m = simpleModule (Simplification [qcon "M" "foo" [wildcard]])+        rule <- singleRule [m]+        getNode rule.head+          @?= D.Head [] [D.HeadConstraint (D.QualifiedName "M" "foo") [D.HeadWildcard]]+        getNode rule.guard @?= [],+      testCase "two wildcards stay as wildcards without guards" $ do+        let m = simpleModule (Simplification [qcon "M" "foo" [wildcard, wildcard]])+        rule <- singleRule [m]+        getNode rule.head+          @?= D.Head+            []+            [D.HeadConstraint (D.QualifiedName "M" "foo") [D.HeadWildcard, D.HeadWildcard]]+        getNode rule.guard @?= [],+      testCase "wildcard and non-variable: only non-variable gets guard" $ do+        let m = simpleModule (Simplification [qcon "M" "foo" [wildcard, IntTerm 1]])+        rule <- singleRule [m]+        getNode rule.head+          @?= D.Head+            []+            [ D.HeadConstraint+                (D.QualifiedName "M" "foo")+                [ D.HeadWildcard,+                  D.HeadVar "_hnf_0"+                ]+            ]+        getNode rule.guard @?= [D.GuardEqual (R.VarExpr "_hnf_0") (R.IntExpr 1)]+    ]++--------------------------------------------------------------------------------+-- Guard classification+--------------------------------------------------------------------------------++guardTests :: TestTree+guardTests =+  testGroup+    "guard-classification"+    [ testCase "host call becomes GuardExpr" $ do+        let m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               ( noAnnP+                                   [ hostCall "gt" [var "X", IntTerm 0]+                                   ]+                               )+                               (noAnnP [atom "true"])+                           ]+        rule <- singleRule [m]+        getNode rule.guard+          @?= [ D.GuardExpr+                  ( R.HostExpr+                      "gt"+                      [ R.VarExpr "X",+                        R.IntExpr 0+                      ]+                  )+              ],+      testCase "atom true becomes GuardExpr" $ do+        let m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               ( noAnnP+                                   [ atom+                                       "true"+                                   ]+                               )+                               (noAnnP [atom "true"])+                           ]+        rule <- singleRule [m]+        getNode rule.guard @?= [D.GuardExpr (R.CtorExpr (Unqualified "true") [])]+    ]++--------------------------------------------------------------------------------+-- Body goal classification+--------------------------------------------------------------------------------++bodyTests :: TestTree+bodyTests =+  testGroup+    "body-classification"+    [ testCase "= becomes BodyUnify" $ do+        rule <- singleRule [simpleModule' (Simplification [leqQual]) [var "X" .=. var "Y"]]+        getNode rule.body @?= [D.BodyUnify (R.VarExpr "X") (R.VarExpr "Y")],+      testCase "is becomes BodyIs" $ do+        rule <-+          singleRule+            [ simpleModule'+                (Simplification [leqQual])+                [ var "X" `is` term "+" [int 1, int 2]+                ]+            ]+        getNode rule.body+          @?= [ D.BodyIs+                  "X"+                  ( R.CtorExpr+                      (Unqualified "+")+                      [ R.IntExpr 1,+                        R.IntExpr 2+                      ]+                  )+              ],+      testCase "Qualified compound becomes BodyTell" $ do+        let body = [CompoundTerm (Qualified "M" "leq") [var "X"]]+        rule <- singleRule [simpleModule' (Simplification [leqQual]) body]+        getNode rule.body+          @?= [D.BodyTell (D.QualifiedName "M" "leq") [R.VarExpr "X"]],+      testCase "hostCall becomes BodyHostStmt" $ do+        rule <-+          singleRule+            [ simpleModule'+                (Simplification [leqQual])+                [ hostCall+                    "print"+                    [ var+                        "X"+                    ]+                ]+            ]+        getNode rule.body @?= [D.BodyHostStmt "print" [R.VarExpr "X"]],+      testCase "atom true becomes BodyTrue" $ do+        rule <- singleRule [simpleModule' (Simplification [leqQual]) [atom "true"]]+        getNode rule.body @?= [D.BodyTrue]+    ]+  where+    simpleModule' h body =+      module' "M"+        `defining` [ Rule+                       Nothing+                       (noAnnP h)+                       (noAnnP [])+                       ( noAnnP+                           body+                       )+                   ]++--------------------------------------------------------------------------------+-- Error handling+--------------------------------------------------------------------------------++errorTests :: TestTree+errorTests =+  testGroup+    "error-handling"+    [ testCase "unqualified compound in body produces UnexpectedBodyExpr" $ do+        let badExpr = R.CtorExpr (Unqualified "foo") [R.VarExpr "X"]+            m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               (noAnnP [])+                               (noAnnP [term "foo" [var "X"]])+                           ]+        rprog <- resolve [m]+        case desugarProgram rprog of+          Left errs -> errs @?= [noDiag (AnnP (UnexpectedBodyExpr badExpr) dummyLoc (Atom ""))]+          Right _ -> assertFailure "expected Left",+      testCase "two unqualified compounds collect both errors" $ do+        let bad1 = R.CtorExpr (Unqualified "foo") [R.VarExpr "X"]+            bad2 = R.CtorExpr (Unqualified "bar") [R.VarExpr "Y"]+            m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               (noAnnP [])+                               (noAnnP [term "foo" [var "X"], term "bar" [var "Y"]])+                           ]+        rprog <- resolve [m]+        case desugarProgram rprog of+          Left errs ->+            errs+              @?= [ noDiag (AnnP (UnexpectedBodyExpr bad1) dummyLoc (Atom "")),+                    noDiag (AnnP (UnexpectedBodyExpr bad2) dummyLoc (Atom ""))+                  ]+          Right _ -> assertFailure "expected Left",+      testCase "bare variable in body produces UnexpectedBodyExpr" $ do+        let badExpr = R.VarExpr "X"+            m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               (noAnnP [])+                               (noAnnP [var "X"])+                           ]+        rprog <- resolve [m]+        case desugarProgram rprog of+          Left errs -> errs @?= [noDiag (AnnP (UnexpectedBodyExpr badExpr) dummyLoc (Atom ""))]+          Right _ -> assertFailure "expected Left",+      testCase "bare integer in body produces UnexpectedBodyExpr" $ do+        let badExpr = R.IntExpr 42+            m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               (noAnnP [])+                               (noAnnP [int 42])+                           ]+        rprog <- resolve [m]+        case desugarProgram rprog of+          Left errs -> errs @?= [noDiag (AnnP (UnexpectedBodyExpr badExpr) dummyLoc (Atom ""))]+          Right _ -> assertFailure "expected Left",+      testCase "non-true atom in body produces UnexpectedBodyExpr" $ do+        let badExpr = R.CtorExpr (Unqualified "foo") []+            m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               (noAnnP [])+                               (noAnnP [atom "foo"])+                           ]+        rprog <- resolve [m]+        case desugarProgram rprog of+          Left errs -> errs @?= [noDiag (AnnP (UnexpectedBodyExpr badExpr) dummyLoc (Atom ""))]+          Right _ -> assertFailure "expected Left",+      testCase "bare variable in guard becomes GuardExpr" $ do+        let goal = var "X"+            m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               (noAnnP [goal])+                               (noAnnP [atom "true"])+                           ]+        rprog <- resolve [m]+        case desugarProgram rprog of+          Left errs -> assertFailure ("unexpected errors: " ++ show errs)+          Right prog -> case prog.rules of+            (rule : _) -> getNode rule.guard @?= [D.GuardExpr (R.VarExpr "X")]+            [] -> assertFailure "expected at least 1 rule",+      testCase "bare integer in guard produces NonBooleanGuard" $ do+        let badExpr = R.IntExpr 42+            m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               (noAnnP [int 42])+                               (noAnnP [atom "true"])+                           ]+        rprog <- resolve [m]+        case desugarProgram rprog of+          Left errs -> errs @?= [noDiag (AnnP (NonBooleanGuard badExpr) dummyLoc (Atom ""))]+          Right _ -> assertFailure "expected Left",+      testCase "bare float in guard produces NonBooleanGuard" $ do+        let badExpr = R.FloatExpr 3.14+            m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               (noAnnP [float 3.14])+                               (noAnnP [atom "true"])+                           ]+        rprog <- resolve [m]+        case desugarProgram rprog of+          Left errs -> errs @?= [noDiag (AnnP (NonBooleanGuard badExpr) dummyLoc (Atom ""))]+          Right _ -> assertFailure "expected Left",+      testCase "bare string in guard produces NonBooleanGuard" $ do+        let badExpr = R.TextExpr "hi"+            m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               (noAnnP [text "hi"])+                               (noAnnP [atom "true"])+                           ]+        rprog <- resolve [m]+        case desugarProgram rprog of+          Left errs -> errs @?= [noDiag (AnnP (NonBooleanGuard badExpr) dummyLoc (Atom ""))]+          Right _ -> assertFailure "expected Left",+      testCase "non-true/false atom in guard produces NonBooleanGuard" $ do+        let badExpr = R.CtorExpr (Unqualified "foo") []+            m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               (noAnnP [atom "foo"])+                               (noAnnP [atom "true"])+                           ]+        rprog <- resolve [m]+        case desugarProgram rprog of+          Left errs -> errs @?= [noDiag (AnnP (NonBooleanGuard badExpr) dummyLoc (Atom ""))]+          Right _ -> assertFailure "expected Left",+      testCase "atom false becomes GuardExpr" $ do+        let m =+              module' "M"+                `defining` [ Rule+                               Nothing+                               (noAnnP (Simplification [leqQual]))+                               (noAnnP [atom "false"])+                               (noAnnP [atom "true"])+                           ]+        rule <- singleRule [m]+        getNode rule.guard @?= [D.GuardExpr (R.CtorExpr (Unqualified "false") [])]+    ]++--------------------------------------------------------------------------------+-- Multi-module flattening+--------------------------------------------------------------------------------++flatteningTests :: TestTree+flatteningTests =+  testGroup+    "flattening"+    [ testCase "two modules with one rule each yield two rules" $ do+        let m1 = module' "A" `defining` [[qterm "A" "c" []] <=> [atom "true"]]+            m2 = module' "B" `defining` [[qterm "B" "d" []] <=> [atom "true"]]+        prog <- desugar [m1, m2]+        length prog.rules @?= 2,+      testCase "empty module list yields empty program" $ do+        prog <- desugar []+        length prog.rules @?= 0,+      testCase "module with no rules contributes no rules" $ do+        let empty = module' "Empty"+            m = module' "M" `defining` [[qterm "M" "c" []] <=> [atom "true"]]+        prog <- desugar [empty, m]+        length prog.rules @?= 1+    ]++--------------------------------------------------------------------------------+-- Rule name preservation+--------------------------------------------------------------------------------++ruleNameTests :: TestTree+ruleNameTests =+  testGroup+    "rule-name"+    [ testCase "named rule preserves name" $ do+        let m =+              module' "M"+                `defining` [ "my_rule"+                               @: [qterm "M" "leq" [var "X", var "Y"]]+                               <=> [atom "true"]+                           ]+        rule <- singleRule [m]+        rule.name @?= Just "my_rule",+      testCase "anonymous rule has Nothing name" $ do+        rule <- singleRule [simpleModule (Simplification [leqQual])]+        rule.name @?= Nothing+    ]++--------------------------------------------------------------------------------+-- Symbol table+--------------------------------------------------------------------------------++symbolTableTests :: TestTree+symbolTableTests =+  testGroup+    "symbol-table"+    [ testCase "empty program yields empty table" $+        extractSymbolTable (D.Program [] [] Map.empty Map.empty []) @?= mkSymbolTable [],+      testCase "one qualified constraint in head gets id 0" $ do+        let prog =+              D.Program+                [ D.Rule+                    Nothing+                    (noAnnP (D.Head [] [D.HeadConstraint (D.QualifiedName "M" "leq") []]))+                    (noAnnP [])+                    (noAnnP [])+                ]+                []+                Map.empty+                Map.empty+                []+        extractSymbolTable prog+          @?= mkSymbolTable+            [ ( Identifier (Qualified "M" "leq") 0,+                ConstraintType 0+              )+            ],+      testCase "two distinct qualified constraints get sequential ids" $ do+        let prog =+              D.Program+                [ D.Rule+                    Nothing+                    ( noAnnP+                        ( D.Head+                            []+                            [ D.HeadConstraint (D.QualifiedName "A" "c") [],+                              D.HeadConstraint (D.QualifiedName "B" "d") []+                            ]+                        )+                    )+                    (noAnnP [])+                    (noAnnP [])+                ]+                []+                Map.empty+                Map.empty+                []+        let table = extractSymbolTable prog+        symbolTableSize table @?= 2,+      testCase "same constraint in head and body appears only once" $ do+        let prog =+              D.Program+                [ D.Rule+                    Nothing+                    ( noAnnP+                        (D.Head [] [D.HeadConstraint (D.QualifiedName "M" "leq") []])+                    )+                    (noAnnP [])+                    ( noAnnP+                        [D.BodyTell (D.QualifiedName "M" "leq") []]+                    )+                ]+                []+                Map.empty+                Map.empty+                []+        extractSymbolTable prog+          @?= mkSymbolTable+            [ ( Identifier (Qualified "M" "leq") 0,+                ConstraintType 0+              )+            ],+      testCase "unqualified name in body not in table" $ do+        let prog =+              D.Program+                [ D.Rule+                    Nothing+                    (noAnnP (D.Head [] [D.HeadConstraint (D.QualifiedName "M" "leq") []]))+                    (noAnnP [])+                    (noAnnP [D.BodyHostStmt "print" []])+                ]+                []+                Map.empty+                Map.empty+                []+        let table = extractSymbolTable prog+        lookupSymbol (Identifier (Unqualified "print") 0) table @?= Nothing,+      testCase "ids assigned in Set.toList order (module-first then name)" $ do+        -- Qualified "A" "z" < Qualified "B" "a" by derived Ord+        let prog =+              D.Program+                [ D.Rule+                    Nothing+                    ( noAnnP+                        ( D.Head+                            []+                            [ D.HeadConstraint (D.QualifiedName "A" "z") [],+                              D.HeadConstraint (D.QualifiedName "B" "a") []+                            ]+                        )+                    )+                    (noAnnP [])+                    (noAnnP [])+                ]+                []+                Map.empty+                Map.empty+                []+        let table = extractSymbolTable prog+        ( lookupSymbol (Identifier (Qualified "A" "z") 0) table,+          lookupSymbol (Identifier (Qualified "B" "a") 0) table+          )+          @?= (Just (ConstraintType 0), Just (ConstraintType 1)),+      testCase "same name different arities get distinct ids" $ do+        let prog =+              D.Program+                [ D.Rule+                    Nothing+                    ( noAnnP+                        ( D.Head+                            []+                            [ D.HeadConstraint+                                (D.QualifiedName "M" "foo")+                                [D.HeadVar "X"]+                            ]+                        )+                    )+                    (noAnnP [])+                    ( noAnnP+                        [ D.BodyTell+                            (D.QualifiedName "M" "foo")+                            [R.VarExpr "X", R.VarExpr "Y"]+                        ]+                    )+                ]+                []+                Map.empty+                Map.empty+                []+        let table = extractSymbolTable prog+        symbolTableSize table @?= 2+    ]++--------------------------------------------------------------------------------+-- Lambda lifting+--------------------------------------------------------------------------------++lambdaLiftTests :: TestTree+lambdaLiftTests =+  testGroup+    "lambda-lift"+    [ testCase "lambda captures HNF-bound pattern variable" $ do+        -- f([X|Xs]) -> fun(Y) -> Y + X+        --+        -- HNF decomposes the compound pattern so that X is bound by a+        -- GuardGetArg, not by the surface parameter list. The+        -- lambda-lifter must therefore treat HNF-introduced bindings as+        -- in scope; otherwise the fun(Y) lambda would be lifted without+        -- capturing X and the reference inside the body would dangle.+        let lambdaBody = term "+" [var "Y", var "X"]+            -- Resolved-AST shape of the lambda body. The test module has+            -- no prelude import, so '+' stays 'Unqualified' through+            -- resolution and lands as a 'CtorExpr' (not a 'CallExpr').+            lambdaBodyExpr =+              R.CtorExpr+                (Unqualified "+")+                [R.VarExpr "Y", R.VarExpr "X"]+            lambdaTerm =+              CompoundTerm+                (Unqualified "->")+                [CompoundTerm (Unqualified "fun") [var "Y"], lambdaBody]+            listPattern = term "." [var "X", var "Xs"]+            funDecl =+              noAnn+                FunctionDecl+                  { name = "f",+                    arity = 1,+                    argTypes = Nothing,+                    returnType = Nothing,+                    isOpen = False,+                    kind = DKFunction,+                    requiring = Nothing+                  }+            funEq =+              noAnnP+                FunctionEquation+                  { funName = Qualified "M" "f",+                    args = [listPattern],+                    guard = noAnnP [],+                    rhs = noAnnP (NE.singleton lambdaTerm)+                  }+            m = (module' "M") {decls = [funDecl], equations = [funEq]}+        prog <- desugar [m]+        let (lifted, liftErrs) = liftAllLambdas prog+        liftErrs @?= []+        let isLambda f = f.name.baseName == "__lambda_0"+        case filter isLambda lifted.functions of+          [lam] -> do+            lam.arity @?= 2+            case lam.equations.node of+              [eq] -> do+                eq.params @?= [D.HeadVar "X", D.HeadVar "Y"]+                eq.guards @?= []+                eq.prelude @?= []+                eq.rhs @?= lambdaBodyExpr+              eqs -> assertFailure $ "expected 1 equation, got " ++ show (length eqs)+          fs -> assertFailure $ "expected exactly one __lambda_0, got " ++ show (length fs),+      testCase "rejects non-variable lambda parameter" $ do+        -- fun("hello") -> "world" end is rejected at the resolve phase:+        -- the resolver's term-to-Expr translator validates lambda+        -- parameter shapes and raises 'LambdaParamError' before the+        -- desugarer (or lambda lifter) ever sees the program.+        let lambdaTerm =+              CompoundTerm+                (Unqualified "->")+                [ CompoundTerm (Unqualified "fun") [TextTerm "hello"],+                  TextTerm "world"+                ]+            funDecl =+              Ann (FunctionDecl "f" 1 Nothing Nothing False DKFunction Nothing) dummyLoc+            funEq =+              AnnP+                FunctionEquation+                  { funName = Qualified "M" "f",+                    args = [var "X"],+                    guard = noAnnP [],+                    rhs = noAnnP (NE.singleton lambdaTerm)+                  }+                dummyLoc+                (Atom "")+            m = (module' "M") {decls = [funDecl], equations = [funEq]}+        case resolveProgram (rewriteImports [m]) of+          Left errs ->+            errs+              @?= [ noDiag+                      ( AnnP+                          (LambdaParamError (TextTerm "hello"))+                          dummyLoc+                          (Atom "")+                      )+                  ]+          Right _ -> assertFailure "expected LambdaParamError"+    ]
+ test/YCHR/ErrorCodeTest.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Guards the uniqueness of error codes (@YCHR-NNNNN@).+--+-- Error codes are assigned by hand in "YCHR.Internal.Display": one @*ErrorCode@+-- function per error type maps each constructor to a literal 'ErrorCode',+-- plus a handful of standalone constants for codes not tied to a+-- constructor. Nothing in the production code stops two of those literals+-- from colliding. This module reflects over every error constructor with+-- 'Data.Data' and asserts that no code number is reused (except the small,+-- documented 'intentionalShared' allowlist).+--+-- Using 'Data' to enumerate constructors keeps the check exhaustive+-- automatically: a newly added error constructor is picked up by+-- 'dataTypeConstrs' without anyone touching this file. The orphan 'Data'+-- instances below are test-only — 'src/' (and the MicroHs-compiled+-- library) carries no 'Data'/'Typeable' usage.+module YCHR.ErrorCodeTest (tests) where++import Data.Data+  ( Data,+    dataTypeConstrs,+    dataTypeOf,+    fromConstr,+    gunfold,+    mkNoRepType,+    toConstr,+  )+import Data.List (sort)+import Data.Map.Strict qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import YCHR.Internal.Collect (CollectError (..))+import YCHR.Internal.Compile (CompileError (..))+import YCHR.Internal.Desugar (DesugarError (..))+import YCHR.Internal.Display+  ( ErrorCode (..),+    collectErrorCode,+    compileErrorCode,+    desugarErrorCode,+    exhaustivenessWarningCode,+    goalNotAConstraintCode,+    lambdasInLiveQueryCode,+    operatorConflictCode,+    parseErrorCode,+    parseValidationErrorCode,+    renameErrorCode,+    renameWarningCode,+    resolveErrorCode,+    runtimeErrorCode,+    typeCheckErrorCode,+  )+import YCHR.Internal.Exhaustiveness (ExhaustivenessWarning (..))+import YCHR.Internal.Parser (ParseValidationError (..))+import YCHR.Internal.Rename (RenameError (..), RenameWarning (..))+import YCHR.Internal.Resolve (ResolveError (..))+import YCHR.Internal.Resolved qualified as R+import YCHR.Internal.TypeCheck (TypeCheckError (..))+import YCHR.Internal.Types (Name, Term)++-- ---------------------------------------------------------------------------+-- Opaque Data instances for the error payload types that are not already+-- Data. These satisfy the constraint that the derived 'gunfold' for each+-- error type imposes on its fields; their methods are never invoked because+-- the @*ErrorCode@ functions are lazy in their payloads, so the values we+-- build with 'fromConstr' fill these fields with bottom and never force them.+-- ---------------------------------------------------------------------------++instance Data Name where+  gunfold _ _ = error "Data Name: gunfold (unused)"+  toConstr _ = error "Data Name: toConstr (unused)"+  dataTypeOf _ = mkNoRepType "YCHR.Types.Name"++instance Data Term where+  gunfold _ _ = error "Data Term: gunfold (unused)"+  toConstr _ = error "Data Term: toConstr (unused)"+  dataTypeOf _ = mkNoRepType "YCHR.Types.Term"++instance Data R.Expr where+  gunfold _ _ = error "Data R.Expr: gunfold (unused)"+  toConstr _ = error "Data R.Expr: toConstr (unused)"+  dataTypeOf _ = mkNoRepType "YCHR.Internal.Resolved.Expr"++deriving instance Data CollectError++deriving instance Data ParseValidationError++deriving instance Data ResolveError++deriving instance Data RenameError++deriving instance Data RenameWarning++deriving instance Data ExhaustivenessWarning++deriving instance Data DesugarError++deriving instance Data CompileError++deriving instance Data TypeCheckError++-- ---------------------------------------------------------------------------+-- Code collection+-- ---------------------------------------------------------------------------++-- | Enumerate every constructor of an error type and pair its name with the+-- code number its @*ErrorCode@ function assigns. 'fromConstr' builds a value+-- with bottom payloads, which is safe because the @*ErrorCode@ functions+-- match only on the constructor.+enumCodes :: forall e. (Data e) => (e -> ErrorCode) -> [(String, Int)]+enumCodes f =+  [ (show c, n)+  | c <- dataTypeConstrs (dataTypeOf (undefined :: e)),+    let ErrorCode n = f (fromConstr c)+  ]++constructorCodes :: [(String, Int)]+constructorCodes =+  concat+    [ enumCodes collectErrorCode,+      enumCodes parseValidationErrorCode,+      enumCodes resolveErrorCode,+      enumCodes renameErrorCode,+      enumCodes renameWarningCode,+      enumCodes exhaustivenessWarningCode,+      enumCodes desugarErrorCode,+      enumCodes compileErrorCode,+      enumCodes typeCheckErrorCode+    ]++-- | Codes not attached to an enumerable constructor (see "YCHR.Internal.Display").+standaloneCodes :: [(String, Int)]+standaloneCodes =+  [ ("parseErrorCode", n parseErrorCode),+    ("operatorConflictCode", n operatorConflictCode),+    ("lambdasInLiveQueryCode", n lambdasInLiveQueryCode),+    ("goalNotAConstraintCode", n goalNotAConstraintCode),+    ("runtimeErrorCode", n runtimeErrorCode)+  ]+  where+    n (ErrorCode k) = k++allCodes :: [(String, Int)]+allCodes = constructorCodes ++ standaloneCodes++-- | Codes deliberately shared by more than one error. Every entry needs a+-- comment justifying the share; the @allowlist is not stale@ test keeps this+-- honest by rejecting entries that no longer correspond to a real duplicate.+intentionalShared :: Set Int+intentionalShared =+  Set.fromList+    [ 60001 -- runtimeErrorCode shares with TypeCheckError's InconsistentTypes+    ]++-- | Map each code number to the labels (constructor / constant names) that+-- assign it.+codesByNumber :: Map.Map Int [String]+codesByNumber =+  Map.fromListWith (++) [(n, [label]) | (label, n) <- allCodes]++-- ---------------------------------------------------------------------------+-- Tests+-- ---------------------------------------------------------------------------++tests :: TestTree+tests =+  testGroup+    "ErrorCode"+    [ testCase "every error code is unique" $+        let offenders =+              [ (n, sort labels)+              | (n, labels) <- Map.toList codesByNumber,+                length labels > 1,+                not (n `Set.member` intentionalShared)+              ]+         in case offenders of+              [] -> pure ()+              _ ->+                assertFailure $+                  "Duplicate error codes:\n"+                    ++ unlines+                      [ "  YCHR-" ++ show n ++ " assigned by " ++ show labels+                      | (n, labels) <- offenders+                      ],+      testCase "intentional-share allowlist is not stale" $+        let stale =+              [ n+              | n <- Set.toList intentionalShared,+                length (Map.findWithDefault [] n codesByNumber) < 2+              ]+         in stale @?= []+    ]
+ test/YCHR/ExhaustivenessTest.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Unit tests for the function exhaustiveness checker+-- ('YCHR.Internal.Exhaustiveness'). Each test drives the real compilation+-- pipeline on a small program and inspects the exhaustiveness warnings+-- it returns, so the witness and function name are pinned precisely+-- (the golden harness only asserts a warning's presence or absence).+module YCHR.ExhaustivenessTest (tests) where++import Data.Text (Text)+import Data.Text qualified as T+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import YCHR.Internal.Compile.Pipeline (Error, Warning (..), compileModules)+import YCHR.Internal.Diagnostic (Diagnostic (..))+import YCHR.Internal.Exhaustiveness (ExhaustivenessWarning (..))+import YCHR.Internal.Parsed (AnnP (..))+import YCHR.Internal.Pretty (prettyTermSrc)++-- | Compile a single-module program and return the exhaustiveness+-- warnings (function display name + rendered witness call).+exhWarnings :: Text -> IO [(Text, String)]+exhWarnings src =+  case compileModules False [("test.chr", src)] of+    Left err -> assertFailure ("unexpected compile error: " ++ show (err :: Error))+    Right (_, ws) ->+      pure+        [ (name, prettyTermSrc witness)+        | ExhaustivenessWarnings ds <- ws,+          Diagnostic _ (AnnP (NonExhaustiveMatch name witness) _ _) <- ds+        ]++tests :: TestTree+tests =+  testGroup+    "Exhaustiveness"+    [ testCase "exhaustive algebraic match emits no warning" $ do+        ws <-+          exhWarnings $+            mod_+              [ "rank(red) -> 1.",+                "rank(green) -> 2.",+                "rank(blue) -> 3."+              ]+        ws @?= [],+      testCase "missing constructor warns with that constructor as witness" $ do+        ws <-+          exhWarnings $+            mod_+              [ "rank(red) -> 1.",+                "rank(green) -> 2."+              ]+        ws @?= [("m:rank/1", "m:rank(m:blue)")],+      testCase "wildcard catch-all is exhaustive" $ do+        ws <-+          exhWarnings $+            mod_+              [ "rank(red) -> 1.",+                "rank(_) -> 0."+              ]+        ws @?= [],+      testCase "guarded equation does not count as covering" $ do+        -- Every constructor has a clause, but each clause is guarded, so+        -- none is guaranteed to match: the function is non-exhaustive.+        ws <-+          exhWarnings $+            mod_+              [ "rank(red) | true -> 1.",+                "rank(green) | true -> 2.",+                "rank(blue) | true -> 3."+              ]+        ws @?= [("m:rank/1", "m:rank(m:red)")],+      testCase "non-algebraic (int) argument never warns" $ do+        ws <-+          exhWarnings $+            T.unlines+              [ ":- module(m, [c/1]).",+                ":- chr_constraint c/1.",+                ":- function describe(int) -> int.",+                "describe(0) -> 100.",+                "describe(1) -> 200.",+                "c(R) <=> R is describe(0)."+              ]+        ws @?= [],+      testCase "fully guarded function over a non-algebraic type never warns" $ do+        -- Every equation is guarded (so none counts as covering) and the+        -- argument is int, which is not enumerable: the only witness is an+        -- all-wildcard one, which is not attributable to an algebraic gap.+        ws <-+          exhWarnings $+            T.unlines+              [ ":- module(m, [c/1]).",+                ":- chr_constraint c/1.",+                ":- function myabs(int) -> int.",+                "myabs(X) | X >= 0 -> X.",+                "myabs(X) | X < 0 -> 0 - X.",+                "c(R) <=> R is myabs(5)."+              ]+        ws @?= [],+      testCase "untyped function never warns" $ do+        -- No declared signature => no algebraic column to enumerate.+        ws <-+          exhWarnings $+            T.unlines+              [ ":- module(m, [c/1]).",+                ":- chr_type color ---> red ; green ; blue.",+                ":- chr_constraint c/1.",+                ":- function rank/1.",+                "rank(red) -> 1.",+                "c(R) <=> R is rank(red)."+              ]+        ws @?= [],+      testCase "open function is not checked" $ do+        ws <-+          exhWarnings $+            T.unlines+              [ ":- module(m, [c/1]).",+                ":- chr_type color ---> red ; green ; blue.",+                ":- chr_constraint c/1.",+                ":- open_function rank(color) -> int.",+                "rank(red) -> 1.",+                "rank(green) -> 2.",+                "c(R) <=> R is rank(red)."+              ]+        ws @?= [],+      testCase "nested missing case warns with a nested witness" $ do+        ws <-+          exhWarnings $+            T.unlines+              [ ":- module(m, [c/1]).",+                ":- chr_type color ---> red ; green ; blue.",+                ":- chr_type pair ---> pair(color, color).",+                ":- chr_constraint c/1.",+                ":- function pick(pair) -> int.",+                "pick(pair(red, _)) -> 1.",+                "pick(pair(green, _)) -> 2.",+                "c(R) <=> R is pick(pair(red, blue))."+              ]+        ws @?= [("m:pick/1", "m:pick(m:pair(m:blue, m:red))")],+      testCase "multi-argument gap warns with a wildcard in the covered column" $ do+        ws <-+          exhWarnings $+            T.unlines+              [ ":- module(m, [c/1]).",+                ":- chr_type color ---> red ; green ; blue.",+                ":- chr_constraint c/1.",+                ":- function m2(int, color) -> int.",+                "m2(_, red) -> 1.",+                "m2(_, green) -> 2.",+                "c(R) <=> R is m2(0, red)."+              ]+        ws @?= [("m:m2/2", "m:m2(_, m:blue)")]+    ]++-- | Wrap a list of @rank/1@ equations over the @color@ type in a minimal+-- module, declaring the function with a @color -> int@ signature and a+-- rule that exercises it.+mod_ :: [Text] -> Text+mod_ equations =+  T.unlines $+    [ ":- module(m, [c/1]).",+      ":- chr_type color ---> red ; green ; blue.",+      ":- chr_constraint c/1.",+      ":- function rank(color) -> int."+    ]+      ++ equations+      ++ ["c(R) <=> R is rank(red)."]
+ test/YCHR/GoldenTest.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.GoldenTest (tests) where++import Control.Exception (SomeException, fromException, try)+import Control.Monad (filterM)+import Data.Char (isSpace)+import Data.Foldable (traverse_)+import Data.List (isInfixOf, partition, sort, sortOn)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath (dropExtension, takeExtension, (<.>), (</>))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import YCHR.Internal.Compile.Pipeline (CompiledProgram (..))+import YCHR.Internal.Display (Display (..))+import YCHR.Internal.Meta (metaHostCallRegistry)+import YCHR.Internal.Pretty (prettyBindings)+import YCHR.Internal.Runtime.Interpreter (baseHostCallRegistry)+import YCHR.Internal.TypeCheck (typeCheckProgram)+import YCHR.Run+  ( Error,+    Warning,+    compileFiles,+    prepareGoal,+    runPreparedGoal,+  )++-- | Test directories whose @.chr@ programs or goals deliberately+-- reference bare atoms that the renamer cannot resolve — typically+-- because the test exists to verify the renamer's behaviour on+-- unexported or unknown constructors, or because the test uses bare+-- sentinel atoms as RHS of @=@ (where @quote/1@ no longer strips,+-- per the spec). Warnings emitted by these tests are part of what+-- they exercise, not a failure mode.+--+-- @nonexhaustive_color@ and @nonexhaustive_nested@ deliberately define+-- functions that do not cover every constructor of a declared algebraic+-- type, so they emit the exhaustiveness warning (YCHR-20103) on purpose.+expectsWarnings :: Set String+expectsWarnings =+  Set.fromList+    [ "arity_overload",+      "nonexhaustive_color",+      "nonexhaustive_nested",+      "bare_atom_canonicalization",+      "bare_vs_qualified",+      "bare_vs_qualified_swapped",+      "comments_and_whitespace",+      "comparisons",+      "copy_term_sharing",+      "cross_module_function_leak",+      "false_guard",+      "function_reference_dispatch",+      "graph_test",+      "hnf_compound_head",+      "hnf_list_head",+      "hnf_literal_in_head",+      "hnf_repeated_var_across_partners",+      "hnf_repeated_var_within_head",+      "hnf_wildcard_in_head",+      "lambda_curried_adder",+      "quoted_constraint_name",+      "short_alias_collision",+      "term_variables",+      "type_export_constructor_allowlist",+      "type_export_constructor_empty",+      "type_import_constructor_narrowing",+      "type_predicates",+      "typecheck_polymorphic_constraint",+      "typecheck_qualified_in_head",+      "unicode_atoms_strings",+      "unifiable",+      -- The lambda-calculus object language (var/lam/app/lit_int/add) is+      -- host-supplied opaque data matched structurally in rule heads, so+      -- it is intentionally left undeclared and warns as YCHR-20101.+      "stlc"+    ]++data Case+  = Positive String FilePath FilePath+  | Negative String FilePath+  | -- | Compilation and program-level type-checking succeed, but running+    -- the goal must throw an error whose displayed message contains the+    -- given error code. Encoded by colocating @<basename>.goal@ and+    -- @<basename>.error@ in the same test directory.+    GoalNegative String FilePath FilePath++data TestSpec = TestSpec+  { testName :: String,+    chrFiles :: [FilePath],+    cases :: [Case]+  }++tests :: IO TestTree+tests = do+  let root = "test/golden"+  entries <- sort <$> listDirectory root+  dirs <- filterM (doesDirectoryExist . (root </>)) entries+  trees <- mapM (makeGoldenTest root) dirs+  pure (testGroup "Golden" trees)++makeGoldenTest :: FilePath -> String -> IO TestTree+makeGoldenTest root name = do+  let dir = root </> name+  files <- sort <$> listDirectory dir+  let chrs = [dir </> f | f <- files, takeExtension f == ".chr"]+      goals = [f | f <- files, takeExtension f == ".goal"]+      expecteds = [f | f <- files, takeExtension f == ".expected"]+      errors = [f | f <- files, takeExtension f == ".error"]+  pure $ case validate dir name chrs goals expecteds errors of+    Left msg -> testCase name (assertFailure msg)+    Right spec -> testGroup spec.testName (map (makeCase spec) spec.cases)++validate ::+  FilePath ->+  String ->+  [FilePath] ->+  [FilePath] ->+  [FilePath] ->+  [FilePath] ->+  Either String TestSpec+validate dir name chrs goals expecteds errors+  | null chrs =+      Left ("No .chr files in " ++ dir)+  | null goals && null errors =+      Left ("No .goal or .error files in " ++ dir)+  | not (null goals) && not (null errors) = do+      -- Mixed-mode directory: each .goal must be paired with either a+      -- .expected (positive) or a .error (goal-negative). A bare .error+      -- (with no matching .goal) in the same directory is rejected+      -- because we'd otherwise have to disambiguate it from a regular+      -- compilation-negative case.+      let goalNames = sort (map dropExtension goals)+          expectedNames = map dropExtension expecteds+          errorNames = map dropExtension errors+          (positiveMatched, unmatchedAfterExpected) =+            partition (`elem` expectedNames) goalNames+          (goalNegMatched, orphanGoals) =+            partition (`elem` errorNames) unmatchedAfterExpected+          orphanExpecteds = filter (`notElem` goalNames) expectedNames+          orphanErrors = filter (`notElem` goalNames) errorNames+      case (orphanGoals, orphanExpecteds, orphanErrors) of+        ([], [], []) ->+          let pcases =+                [ Positive c (dir </> c <.> "goal") (dir </> c <.> "expected")+                | c <- positiveMatched+                ]+              gncases =+                [ GoalNegative c (dir </> c <.> "goal") (dir </> c <.> "error")+                | c <- goalNegMatched+                ]+           in Right (TestSpec name chrs (sortCases (pcases ++ gncases)))+        (gs, es, ers) ->+          Left+            ( "Orphan files in "+                ++ dir+                ++ ":"+                ++ concatMap (("\n  missing .expected or .error for " ++) . (<.> "goal")) gs+                ++ concatMap (("\n  missing .goal for " ++) . (<.> "expected")) es+                ++ concatMap+                  ( ("\n  bare .error not paired with a .goal in mixed dir for " ++)+                      . (<.> "error")+                  )+                  ers+            )+  | not (null errors) =+      let ecases =+            [ Negative (dropExtension e) (dir </> e)+            | e <- sort errors+            ]+       in Right (TestSpec name chrs ecases)+  | otherwise = do+      let goalNames = sort (map dropExtension goals)+          expectedNames = sort (map dropExtension expecteds)+          (matched, orphanGoals) =+            partition (`elem` expectedNames) goalNames+          orphanExpecteds = filter (`notElem` goalNames) expectedNames+      case (orphanGoals, orphanExpecteds) of+        ([], []) ->+          let pcases =+                [ Positive c (dir </> c <.> "goal") (dir </> c <.> "expected")+                | c <- matched+                ]+           in Right (TestSpec name chrs pcases)+        (gs, es) ->+          Left+            ( "Orphan files in "+                ++ dir+                ++ ":"+                ++ concatMap (("\n  missing .expected for " ++) . (<.> "goal")) gs+                ++ concatMap (("\n  missing .goal for " ++) . (<.> "expected")) es+            )++sortCases :: [Case] -> [Case]+sortCases = sortOn caseName+  where+    caseName (Positive n _ _) = n+    caseName (Negative n _) = n+    caseName (GoalNegative n _ _) = n++makeCase :: TestSpec -> Case -> TestTree+makeCase spec c = case c of+  Positive cname gf ef -> testCase cname (runPositive spec gf ef)+  Negative cname ef -> testCase cname (runNegative spec ef)+  GoalNegative cname gf ef -> testCase cname (runGoalNegative spec gf ef)++runPositive :: TestSpec -> FilePath -> FilePath -> IO ()+runPositive spec goalFile expectedFile = do+  (prog, ws) <-+    compileFiles False spec.chrFiles+      >>= either (assertFailure . show) pure+  checkWarnings spec "compile" ws+  typeErrors <- typeCheckProgram prog.desugaredProgram+  case typeErrors of+    [] -> pure ()+    errs ->+      assertFailure+        ("Type errors in " ++ spec.testName ++ ":\n" ++ unlines (map displayMsg errs))+  query <- TIO.readFile goalFile+  expected <- readFile expectedFile+  (constraint, goalWs) <- prepareGoal prog (T.strip query)+  checkWarnings spec "goal" goalWs+  bindings <- runPreparedGoal prog (baseHostCallRegistry <> metaHostCallRegistry) constraint+  prettyBindings bindings @?= expected++-- | Compile + program-typecheck must succeed; running the goal must throw+-- an 'Error' whose displayed message contains every non-empty line of+-- the '.error' file (each line is an independent substring assertion).+-- The first line is conventionally the @YCHR-NNNNN@ code, but the code+-- alone is often too generic — @YCHR-60001@ covers every runtime error,+-- so a typo could satisfy the assertion accidentally. Subsequent lines+-- pin a phrase from the actual error text to anchor the test against+-- the intended failure path. Any other outcome (success, non-'Error'+-- exception, missing substring) fails the test.+runGoalNegative :: TestSpec -> FilePath -> FilePath -> IO ()+runGoalNegative spec goalFile errorFile = do+  (prog, ws) <-+    compileFiles False spec.chrFiles+      >>= either (assertFailure . show) pure+  checkWarnings spec "compile" ws+  typeErrors <- typeCheckProgram prog.desugaredProgram+  case typeErrors of+    [] -> pure ()+    errs ->+      assertFailure+        ("Type errors in " ++ spec.testName ++ ":\n" ++ unlines (map displayMsg errs))+  query <- TIO.readFile goalFile+  expectedSubstrings <- nonEmptyLines <$> readFile errorFile+  (constraint, goalWs) <- prepareGoal prog (T.strip query)+  checkWarnings spec "goal" goalWs+  outcome <-+    try @SomeException $+      runPreparedGoal+        prog+        ( baseHostCallRegistry+            <> metaHostCallRegistry+        )+        constraint+  case outcome of+    Right _ ->+      assertFailure+        ( "Expected goal to fail with "+            ++ show expectedSubstrings+            ++ " but it succeeded"+        )+    Left exc -> case fromException exc of+      Just (err :: Error) -> do+        let msg = displayMsg err+        traverse_+          ( \sub ->+              assertBool+                ("Expected substring " ++ show sub ++ " in:\n" ++ msg)+                (sub `isInfixOf` msg)+          )+          expectedSubstrings+      Nothing ->+        assertFailure+          ( "Expected an Error matching "+              ++ show expectedSubstrings+              ++ " but got: "+              ++ show exc+          )+  where+    trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace+    nonEmptyLines = filter (not . null) . map trim . lines++runNegative :: TestSpec -> FilePath -> IO ()+runNegative spec errorFile = do+  result <- compileFiles False spec.chrFiles+  expectedSubstrings <- nonEmptyLines <$> readFile errorFile+  case result of+    Left err -> assertAllPresent (displayMsg err) expectedSubstrings+    Right (prog, _ws) -> do+      typeErrors <- typeCheckProgram prog.desugaredProgram+      case typeErrors of+        [] -> assertFailure "Expected compilation or type checking to fail, but it succeeded"+        errs -> assertAllPresent (unlines (map displayMsg errs)) expectedSubstrings+  where+    trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace+    nonEmptyLines = filter (not . null) . map trim . lines+    assertAllPresent msg =+      traverse_+        ( \sub ->+            assertBool+              ("Expected substring " ++ show sub ++ " in:\n" ++ msg)+              (sub `isInfixOf` msg)+        )++-- | Assert no warnings unless the test is on the allowlist. The+-- @phase@ label distinguishes compile-time warnings from goal-time+-- ones in the failure message.+checkWarnings :: TestSpec -> String -> [Warning] -> IO ()+checkWarnings spec phase ws+  | Set.member spec.testName expectsWarnings = pure ()+  | null ws = pure ()+  | otherwise =+      assertFailure+        ( spec.testName+            ++ ": "+            ++ phase+            ++ ": unexpected warnings\n"+            ++ unlines (map displayMsg ws)+        )
+ test/YCHR/MetaTest.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.MetaTest (tests) where++import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase)+import YCHR.Internal.Compile.Names (vmName)+import YCHR.Internal.Compile.Pipeline (CompiledProgram (..))+import YCHR.Internal.Meta (metaHostCallRegistry, valueToTerm)+import YCHR.Internal.Runtime.Interpreter+  ( HostCallFn (..),+    HostCallRegistry,+    baseHostCallRegistry,+  )+import YCHR.Internal.Runtime.Monad (Chr, initSessionEnv, runChr)+import YCHR.Internal.Runtime.Types (Value (..))+import YCHR.Internal.Runtime.Var (deref, equal)+import YCHR.Internal.Types (Term (..))+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM (Name (..))+import YCHR.Run (compileModules, runProgramWithQuery)++tests :: TestTree+tests =+  testGroup+    "YCHR.Internal.Meta"+    [ readTermTests,+      vmNameRoundTripTests+    ]++hostCalls :: HostCallRegistry+hostCalls = baseHostCallRegistry <> metaHostCallRegistry++runChrBase :: Chr a -> IO a+runChrBase action = do+  env <- initSessionEnv [] [] Map.empty baseHostCallRegistry Map.empty Map.empty Set.empty+  runChr action env++-- | Invoke the read_term_from_string host call directly and return the Value.+readTerm :: Text -> IO Value+readTerm s = case Map.lookup (Name "read_term_from_string") metaHostCallRegistry of+  Nothing -> assertFailure "read_term_from_string not found in registry"+  Just (HostCallFn f) -> runChrBase (f [VText s])++compileOrFail :: [(FilePath, Text)] -> IO CompiledProgram+compileOrFail inputs = case compileModules False inputs of+  Left err -> assertFailure $ show err+  Right (cp, _) -> pure cp++readTermTests :: TestTree+readTermTests =+  testGroup+    "read_term_from_string"+    [ testCase "integer" $ do+        v <- readTerm "42"+        case v of+          VInt 42 -> pure ()+          _ -> assertFailure "expected VInt 42",+      testCase "negative integer" $ do+        v <- readTerm "-7"+        case v of+          VInt (-7) -> pure ()+          _ -> assertFailure "expected VInt (-7)",+      testCase "atom" $ do+        v <- readTerm "hello"+        case v of+          VAtom "hello" -> pure ()+          _ -> assertFailure "expected VAtom hello",+      testCase "quoted atom" $ do+        v <- readTerm "'hello world'"+        case v of+          VAtom "hello world" -> pure ()+          _ -> assertFailure "expected VAtom 'hello world'",+      testCase "string" $ do+        v <- readTerm "\"hello\""+        case v of+          VText "hello" -> pure ()+          _ -> assertFailure "expected VText hello",+      testCase "wildcard" $ do+        v <- readTerm "_"+        case v of+          VWildcard -> pure ()+          _ -> assertFailure "expected VWildcard",+      testCase "compound term" $ do+        v <- readTerm "f(1, hello)"+        case v of+          VTerm "f" [VInt 1, VAtom "hello"] -> pure ()+          _ -> assertFailure "unexpected result for f(1, hello)",+      testCase "nested compound term" $ do+        v <- readTerm "f(g(1), h(2, 3))"+        case v of+          VTerm "f" [VTerm "g" [VInt 1], VTerm "h" [VInt 2, VInt 3]] -> pure ()+          _ -> assertFailure "unexpected result for f(g(1), h(2, 3))",+      testCase "variable produces a fresh unbound var" $ do+        v <- readTerm "X"+        v' <- runChrBase (deref v)+        case v' of+          VVar _ -> pure ()+          _ -> assertFailure "expected unbound variable",+      testCase "same variable name maps to same var" $ do+        v <- readTerm "f(X, X)"+        eq <- runChrBase $ case v of+          VTerm "f" [a, b] -> equal a b+          _ -> pure False+        assertBool "both X args should be the same variable" eq,+      testCase "different variable names map to different vars" $ do+        v <- readTerm "f(X, Y)"+        eq <- runChrBase $ case v of+          VTerm "f" [a, b] -> equal a b+          _ -> pure True+        assertBool "X and Y should be different variables" (not eq),+      testCase "list syntax" $ do+        v <- readTerm "[1, 2, 3]"+        case v of+          VTerm "." [VInt 1, VTerm "." [VInt 2, VTerm "." [VInt 3, VAtom "[]"]]] -> pure ()+          _ -> assertFailure "unexpected result for [1, 2, 3]",+      testCase "infix operator <=> parses as compound term" $ do+        v <- readTerm "a <=> b"+        case v of+          VTerm "<=>" [VAtom "a", VAtom "b"] -> pure ()+          _ -> assertFailure "unexpected result for a <=> b",+      testCase "infix operator = parses as compound term" $ do+        v <- readTerm "a = b"+        case v of+          VTerm "=" [VAtom "a", VAtom "b"] -> pure ()+          _ -> assertFailure "unexpected result for a = b",+      endToEndReadTermTest+    ]++endToEndReadTermTest :: TestTree+endToEndReadTermTest =+  testCase "end-to-end: read_term_from_string in CHR query" $ do+    let src =+          ":- module(m, [check/2]).\n\+          \:- chr_constraint check/2.\n\+          \\n\+          \check(X, X) <=> true.\n"+    prog <- compileOrFail [("m.chr", src)]+    bindings <-+      runProgramWithQuery+        prog+        hostCalls+        "T is host:read_term_from_string(\"f(1, hello)\"), check(T, f(1, hello))."+    case Map.lookup "T" bindings of+      Just+        ( CompoundTerm+            (Types.Unqualified "f")+            [IntTerm 1, CompoundTerm (Types.Unqualified "hello") []]+          ) -> pure ()+      other -> assertFailure $ "Expected T = f(1, hello), got: " ++ show other++-- | Property: 'YCHR.Internal.Meta.valueToTerm' (run on a 'VAtom' whose payload+-- comes from 'YCHR.Internal.Compile.Names.vmName') recovers the original+-- 'Types.Name' as a qualified or unqualified 'CompoundTerm'. This+-- pins the injectivity of the mangling pair @encodeText@\/@%%u@+-- escape ↔ @decodeMangled@\/@decodeEscapes@.+vmNameRoundTripTests :: TestTree+vmNameRoundTripTests =+  testGroup+    "vmName round-trip"+    [ roundTrip "ASCII qualified" (Types.Qualified "mymodule" "foo"),+      roundTrip "non-ASCII base" (Types.Qualified "m" "naïve"),+      roundTrip "non-ASCII module" (Types.Qualified "naïve" "foo"),+      roundTrip "non-ASCII both" (Types.Qualified "café" "naïve"),+      -- Previously broken: base whose encoded form follows a non-ASCII+      -- escape with literal "u<hex>" chars, which the old "__u<HEX>__"+      -- decoder mis-split.+      roundTrip "uffï base" (Types.Qualified "mymodule" "uffï"),+      -- Previously broken: module ending in non-ASCII + literal+      -- "u<hex>". With the old encoding this collided with another+      -- (m, n) pair; the new "%%u<6 hex>" encoding is injective.+      roundTrip "fooáue module" (Types.Qualified "fooáue" "b"),+      -- Base that LOOKS like a stale "__u<HEX>__" escape but is just+      -- ASCII content past the separator.+      roundTrip "uaafoo base" (Types.Qualified "mymodule" "uaafoo"),+      -- 0-arity 'Unqualified' atoms go through 'VAtom' too.+      roundTripUnqualified "ASCII unqualified" "foo",+      roundTripUnqualified "unicode unqualified" "naïve"+    ]+  where+    roundTrip label name = testCase label $ do+      let mangled = (vmName name).unName+      t <- runChrBase (valueToTerm Map.empty (VAtom mangled))+      case t of+        CompoundTerm n [] | n == name -> pure ()+        other ->+          assertFailure $+            "Round-trip failed for "+              ++ show name+              ++ "\n  mangled = "+              ++ show mangled+              ++ "\n  got     = "+              ++ show other+    roundTripUnqualified label n = testCase label $ do+      let mangled = (vmName (Types.Unqualified n)).unName+      t <- runChrBase (valueToTerm Map.empty (VAtom mangled))+      case t of+        CompoundTerm (Types.Unqualified n') [] | n' == n -> pure ()+        other ->+          assertFailure $+            "Round-trip failed for unqualified "+              ++ show n+              ++ "\n  mangled = "+              ++ show mangled+              ++ "\n  got     = "+              ++ show other
+ test/YCHR/PExprRoundtripTest.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.PExprRoundtripTest (tests) where++import Data.Text (Text)+import Data.Text qualified as Text+import Hedgehog (Gen, Property, annotate, failure, forAll, property, (===))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Hedgehog (testProperty)+import YCHR.Internal.Loc (Ann (..), noAnn)+import YCHR.Internal.PExpr++-- ---------------------------------------------------------------------------+-- Operator table+-- ---------------------------------------------------------------------------++-- | A representative operator table for testing.+testOps :: OpTable+testOps =+  mkOpTable+    [ (200, [(Yfx, "*"), (Yfx, "/")]),+      (300, [(Yfx, "+"), (Yfx, "-")]),+      (500, [(Fx, "~")]),+      (700, [(Xfx, "is")])+    ]++-- | Operator table covering every fixity kind, including postfix.+--+-- '**' (Yf) is chosen as a symbol token disjoint from '*' under+-- the parser's greedy longest-match rule, so 'X * Y' and 'X **'+-- remain unambiguous.+fullOps :: OpTable+fullOps =+  mkOpTable+    [ (200, [(Yfx, "*"), (Yfx, "/")]),+      (300, [(Yfx, "+"), (Yfx, "-")]),+      (500, [(Fx, "~")]),+      (700, [(Xfx, "is")]),+      (250, [(Xf, "!"), (Yf, "**")])+    ]++-- ---------------------------------------------------------------------------+-- Generators+-- ---------------------------------------------------------------------------++-- | Generate a safe unquoted atom: lowercase-starting alphanumeric, not a+-- word operator, and no double underscore.+genSafeAtom :: Gen Text+genSafeAtom = Gen.filter isOk $ do+  c <- Gen.lower+  rest <- Gen.list (Range.linear 0 5) (Gen.choice [Gen.alphaNum, pure '_'])+  pure (Text.pack (c : rest))+  where+    isOk s =+      s `notElem` wordOps+        && not ("__" `Text.isInfixOf` s)+    wordOps = [name | (_, ty, name) <- opTableEntries testOps, not (isSymOp ty name)]+    isSymOp ty name+      | isPrefix ty || isPostfix ty = True+      | otherwise = Text.all (`elem` (":=<>+-*/#@^~!&?" :: [Char])) name++-- | Generate atoms including cases that require quoting.+genAtom :: Gen Text+genAtom =+  Gen.choice+    [ genSafeAtom,+      pure "",+      -- Atom with embedded quote+      do+        s <- genSafeAtom+        pure (s <> "'s"),+      -- Uppercase-starting atom (needs quoting)+      do+        c <- Gen.upper+        rest <- Gen.list (Range.linear 0 4) Gen.alphaNum+        pure (Text.pack (c : rest))+    ]++-- | Generate a variable name.+genVar :: Gen Text+genVar = do+  c <- Gen.upper+  rest <- Gen.list (Range.linear 0 4) (Gen.choice [Gen.alphaNum, pure '_'])+  pure (Text.pack (c : rest))++-- | Generate a Double whose Haskell 'show' does not use scientific+-- notation (so the parser, which only accepts @digit+ '.' digit+@,+-- can roundtrip it).  Discards values whose show contains an 'e'/'E';+-- with magnitudes mostly in [1, 1000] the rejection rate is negligible.+genFloat :: Gen Double+genFloat = Gen.filter showsDecimal $ do+  whole <- Gen.int (Range.linearFrom 0 (-1000) 1000)+  fracLen <- Gen.int (Range.linear 1 6)+  fracDigits <- Gen.list (Range.singleton fracLen) (Gen.element ['0' .. '9'])+  pure (read (show whole ++ "." ++ fracDigits) :: Double)+  where+    showsDecimal d =+      let s = show d+       in 'e' `notElem` s && 'E' `notElem` s++-- | Build a lambda PExpr from a sub-generator: up to three params and a+-- body, both drawn from @sub@.  The resulting shape is what the+-- pretty-printer emits as @fun(...) -> ... end@ and what 'lambdaP'+-- recognises on parse.+genLambda :: Gen PExpr -> Gen PExpr+genLambda sub = do+  paramCount <- Gen.int (Range.linear 0 3)+  params <- Gen.list (Range.singleton paramCount) sub+  body <- sub+  pure+    ( Compound+        "->"+        [ noAnn (Compound "fun" (map noAnn params)),+          noAnn body+        ]+    )++-- | Generate a string literal body.+genStringContent :: Gen Text+genStringContent =+  Text.pack+    <$> Gen.list+      (Range.linear 0 10)+      ( Gen.choice+          [ Gen.alphaNum,+            Gen.element [' ', '"', '\\', '\n', '\t']+          ]+      )++-- | Generate a non-operator PExpr (no operators in structure).+genPExpr :: Gen PExpr+genPExpr =+  Gen.recursive+    Gen.choice+    -- Base cases+    [ Var <$> genVar,+      Int <$> Gen.integral (Range.linear (-1000) 1000),+      Float <$> genFloat,+      Atom <$> genAtom,+      Str <$> genStringContent,+      pure Wildcard,+      pure (Atom "[]")+    ]+    -- Recursive cases+    [ -- Compound with safe atom functor+      Gen.subtermM genPExpr $ \t -> do+        f <- genSafeAtom+        pure (Compound f [noAnn t]),+      Gen.subtermM2 genPExpr genPExpr $ \t1 t2 -> do+        f <- genSafeAtom+        pure (Compound f [noAnn t1, noAnn t2]),+      -- Zero-arg compound+      do+        f <- genSafeAtom+        pure (Compound f []),+      -- List (2-3 elements)+      do+        elems <- Gen.list (Range.linear 1 3) genPExpr+        let nil = Atom "[]"+        pure (foldr (\h t -> Compound "." [noAnn h, noAnn t]) nil elems),+      -- Head|Tail list+      Gen.subtermM2 genPExpr genPExpr $ \h t ->+        pure (Compound "." [noAnn h, noAnn t]),+      -- Lambda+      genLambda genPExpr+    ]++-- | Generate a PExpr that may contain operator-shaped compounds.+genPExprWithOps :: Gen PExpr+genPExprWithOps =+  Gen.recursive+    Gen.choice+    -- Base cases (same as genPExpr)+    [ Var <$> genVar,+      Int <$> Gen.integral (Range.linear (-1000) 1000),+      Float <$> genFloat,+      Atom <$> genAtom,+      Str <$> genStringContent,+      pure Wildcard,+      pure (Atom "[]")+    ]+    -- Recursive cases: base + operator expressions+    [ Gen.subtermM genPExprWithOps $ \t -> do+        f <- genSafeAtom+        pure (Compound f [noAnn t]),+      Gen.subtermM2 genPExprWithOps genPExprWithOps $ \t1 t2 -> do+        f <- genSafeAtom+        pure (Compound f [noAnn t1, noAnn t2]),+      -- Infix operator+      Gen.subtermM2 genPExprWithOps genPExprWithOps $ \l r -> do+        op <- Gen.element ["+", "-", "*", "/", "is"]+        pure (Compound op [noAnn l, noAnn r]),+      -- Prefix operator+      Gen.subtermM genPExprWithOps $ \x ->+        pure (Compound "~" [noAnn x]),+      -- List+      do+        elems <- Gen.list (Range.linear 1 3) genPExprWithOps+        pure (foldr (\h t -> Compound "." [noAnn h, noAnn t]) (Atom "[]") elems),+      -- Lambda+      genLambda genPExprWithOps+    ]++-- | Generate a PExpr covering the full grammar: operator expressions,+-- postfix ops, lambdas, lists, floats, and the base atoms/vars/strings.+genPExprFull :: Gen PExpr+genPExprFull =+  Gen.recursive+    Gen.choice+    [ Var <$> genVar,+      Int <$> Gen.integral (Range.linear (-1000) 1000),+      Float <$> genFloat,+      Atom <$> genAtom,+      Str <$> genStringContent,+      pure Wildcard,+      pure (Atom "[]")+    ]+    [ Gen.subtermM genPExprFull $ \t -> do+        f <- genSafeAtom+        pure (Compound f [noAnn t]),+      Gen.subtermM2 genPExprFull genPExprFull $ \t1 t2 -> do+        f <- genSafeAtom+        pure (Compound f [noAnn t1, noAnn t2]),+      Gen.subtermM2 genPExprFull genPExprFull $ \l r -> do+        op <- Gen.element ["+", "-", "*", "/", "is"]+        pure (Compound op [noAnn l, noAnn r]),+      Gen.subtermM genPExprFull $ \x ->+        pure (Compound "~" [noAnn x]),+      -- Xf postfix+      Gen.subtermM genPExprFull $ \x ->+        pure (Compound "!" [noAnn x]),+      -- Yf postfix+      Gen.subtermM genPExprFull $ \x ->+        pure (Compound "**" [noAnn x]),+      do+        elems <- Gen.list (Range.linear 1 3) genPExprFull+        pure (foldr (\h t -> Compound "." [noAnn h, noAnn t]) (Atom "[]") elems),+      genLambda genPExprFull+    ]++-- ---------------------------------------------------------------------------+-- Stripping+-- ---------------------------------------------------------------------------++-- | Strip source locations for structural comparison.+strip :: Ann PExpr -> PExpr+strip (Ann t _) = case t of+  Compound f args -> Compound f (map (noAnn . strip) args)+  other -> other++-- ---------------------------------------------------------------------------+-- Properties+-- ---------------------------------------------------------------------------++prop_roundtrip :: OpTable -> Gen PExpr -> Property+prop_roundtrip ops gen = property $ do+  expr <- forAll gen+  let src = prettyPExpr ops expr+  annotate src+  case parseTerms ops "<roundtrip>" (Text.pack (src ++ ".")) of+    Left err -> annotate (show err) >> failure+    Right [ann] -> strip ann === expr+    Right ts -> annotate ("expected 1 term, got " ++ show (length ts)) >> failure++-- ---------------------------------------------------------------------------+-- Test tree+-- ---------------------------------------------------------------------------++tests :: TestTree+tests =+  testGroup+    "YCHR.Internal.PExpr.Roundtrip"+    [ testProperty "roundtrip without operators" (prop_roundtrip emptyOps genPExpr),+      testProperty "roundtrip with operators" (prop_roundtrip testOps genPExprWithOps),+      testProperty "roundtrip with full grammar" (prop_roundtrip fullOps genPExprFull)+    ]+  where+    emptyOps = mkOpTable []
+ test/YCHR/PExprTest.hs view
@@ -0,0 +1,1248 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.PExprTest (tests) where++import Data.Either (isLeft)+import Data.List (sort)+import Data.Map.Strict qualified as Map+import Data.Maybe (isJust, isNothing)+import Data.Text (Text)+import Data.Text qualified as T+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import Text.Parsec (ParseError)+import YCHR.Internal.Loc (Ann (..), SourceLoc (..), noAnn)+import YCHR.Internal.PExpr++tests :: TestTree+tests =+  testGroup+    "YCHR.Internal.PExpr"+    [ atomTests,+      variableTests,+      wildcardTests,+      intTests,+      floatTests,+      stringTests,+      stringEdgeTests,+      quotedAtomEdgeTests,+      compoundTests,+      listTests,+      operatorTests,+      maxPrecTests,+      dualRoleTests,+      postfixTests,+      prefixChainingTests,+      lambdaTests,+      symbolOpTokenTests,+      precedenceBoundaryTests,+      dotTerminationTests,+      commentTests,+      errorTests,+      opTypePredicateTests,+      mergeOpsTests,+      opTableEntriesTests,+      singleTermApiTests,+      renderAtomTests,+      prettyTests,+      floatAndPostfixPrettyTests,+      roundtripTests+    ]++-- | Parse with no operators.+p :: Text -> Either (ParseError) [Ann PExpr]+p = parseTerms emptyOps ""++-- | Parse with standard arithmetic operators.+pOps :: Text -> Either (ParseError) [Ann PExpr]+pOps = parseTerms testOps ""++-- | An empty operator table.+emptyOps :: OpTable+emptyOps = mkOpTable []++-- | A small operator table for testing.+testOps :: OpTable+testOps =+  mkOpTable+    [ (200, [(Yfx, "*")]),+      (300, [(Yfx, "+"), (Yfx, "-")]),+      (700, [(Xfx, "is")]),+      (500, [(Fx, "~")])+    ]++-- | Strip source locations from a term for structural comparison.+strip :: Ann PExpr -> PExpr+strip (Ann t _) = case t of+  Compound f args -> Compound f (map (noAnn . strip) args)+  other -> other++-- | Strip all terms in a parse result.+stripAll :: Either e [Ann PExpr] -> Either e [PExpr]+stripAll = fmap (map strip)++-- ---------------------------------------------------------------------------+-- Atoms+-- ---------------------------------------------------------------------------++atomTests :: TestTree+atomTests =+  testGroup+    "atoms"+    [ testCase "unquoted atom" $+        stripAll (p "foo.") @?= Right [Atom "foo"],+      testCase "single-quoted atom" $+        stripAll (p "'Hello World'.") @?= Right [Atom "Hello World"],+      testCase "quoted atom with escape" $+        stripAll (p "'it''s'.") @?= Right [Atom "it's"],+      testCase "quoted atom with backslash escape" $+        stripAll (p "'line\\none'.") @?= Right [Atom "line\none"],+      testCase "double underscore rejected" $+        assertBool "should fail" (isLeft (p "foo__bar.")),+      testCase "%%u rejected as infix in quoted atom" $+        assertBool "should fail" (isLeft (p "'foo%%ubar'.")),+      testCase "%%u rejected as prefix in quoted atom" $+        assertBool "should fail" (isLeft (p "'%%ufoo'.")),+      testCase "%%u rejected as suffix in quoted atom" $+        assertBool "should fail" (isLeft (p "'foo%%u'.")),+      testCase "%% alone is allowed in quoted atom" $+        stripAll (p "'foo%%bar'.") @?= Right [Atom "foo%%bar"]+    ]++-- ---------------------------------------------------------------------------+-- Variables+-- ---------------------------------------------------------------------------++variableTests :: TestTree+variableTests =+  testGroup+    "variables"+    [ testCase "simple variable" $+        stripAll (p "X.") @?= Right [Var "X"],+      testCase "multi-char variable" $+        stripAll (p "Foo.") @?= Right [Var "Foo"],+      testCase "variable with digits" $+        stripAll (p "Bar1.") @?= Right [Var "Bar1"],+      testCase "variable with underscore" $+        stripAll (p "X_1.") @?= Right [Var "X_1"]+    ]++-- ---------------------------------------------------------------------------+-- Wildcards+-- ---------------------------------------------------------------------------++wildcardTests :: TestTree+wildcardTests =+  testGroup+    "wildcards"+    [ testCase "wildcard" $+        stripAll (p "_.") @?= Right [Wildcard]+    ]++-- ---------------------------------------------------------------------------+-- Integers+-- ---------------------------------------------------------------------------++intTests :: TestTree+intTests =+  testGroup+    "integers"+    [ testCase "positive integer" $+        stripAll (p "42.") @?= Right [Int 42],+      testCase "negative integer" $+        stripAll (p "-7.") @?= Right [Int (-7)],+      testCase "zero" $+        stripAll (p "0.") @?= Right [Int 0]+    ]++-- ---------------------------------------------------------------------------+-- Strings+-- ---------------------------------------------------------------------------++stringTests :: TestTree+stringTests =+  testGroup+    "strings"+    [ testCase "simple string" $+        stripAll (p "\"hello\".") @?= Right [Str "hello"],+      testCase "string with escape" $+        stripAll (p "\"line\\none\".") @?= Right [Str "line\none"],+      testCase "string with embedded quote" $+        stripAll (p "\"say \\\"hi\\\"\".") @?= Right [Str "say \"hi\""]+    ]++-- ---------------------------------------------------------------------------+-- Compounds+-- ---------------------------------------------------------------------------++compoundTests :: TestTree+compoundTests =+  testGroup+    "compounds"+    [ testCase "compound with args" $+        stripAll (p "f(X, Y).")+          @?= Right [Compound "f" [noAnn (Var "X"), noAnn (Var "Y")]],+      testCase "nested compound" $+        stripAll (p "f(g(a)).")+          @?= Right [Compound "f" [noAnn (Compound "g" [noAnn (Atom "a")])]],+      testCase "nullary compound" $+        stripAll (p "f.") @?= Right [Atom "f"],+      testCase "zero-arg compound" $+        stripAll (p "f().")+          @?= Right [Compound "f" []]+    ]++-- ---------------------------------------------------------------------------+-- Lists+-- ---------------------------------------------------------------------------++listTests :: TestTree+listTests =+  testGroup+    "lists"+    [ testCase "empty list" $+        stripAll (p "[].")+          @?= Right [Atom "[]"],+      testCase "simple list" $+        stripAll (p "[a, b, c].")+          @?= Right+            [ Compound+                "."+                [ noAnn (Atom "a"),+                  noAnn+                    ( Compound+                        "."+                        [ noAnn (Atom "b"),+                          noAnn (Compound "." [noAnn (Atom "c"), noAnn (Atom "[]")])+                        ]+                    )+                ]+            ],+      testCase "head|tail list" $+        stripAll (p "[H|T].")+          @?= Right+            [Compound "." [noAnn (Var "H"), noAnn (Var "T")]],+      testCase "multi head|tail" $+        stripAll (p "[a, b|T].")+          @?= Right+            [ Compound+                "."+                [ noAnn (Atom "a"),+                  noAnn (Compound "." [noAnn (Atom "b"), noAnn (Var "T")])+                ]+            ]+    ]++-- ---------------------------------------------------------------------------+-- Operators+-- ---------------------------------------------------------------------------++operatorTests :: TestTree+operatorTests =+  testGroup+    "operators"+    [ testCase "infix operator" $+        stripAll (pOps "X + Y.")+          @?= Right [Compound "+" [noAnn (Var "X"), noAnn (Var "Y")]],+      testCase "precedence: * binds tighter than +" $+        stripAll (pOps "X + Y * Z.")+          @?= Right+            [ Compound+                "+"+                [ noAnn (Var "X"),+                  noAnn (Compound "*" [noAnn (Var "Y"), noAnn (Var "Z")])+                ]+            ],+      testCase "prefix operator" $+        stripAll (pOps "~ X.")+          @?= Right [Compound "~" [noAnn (Var "X")]],+      testCase "word operator" $+        stripAll (pOps "X is Y.")+          @?= Right [Compound "is" [noAnn (Var "X"), noAnn (Var "Y")]],+      testCase "infix word operator allowed as atom" $+        stripAll (pOps "is.") @?= Right [Atom "is"],+      testCase "infix word operator as functor" $+        stripAll (pOps "is(X, Y).")+          @?= Right [Compound "is" [noAnn (Var "X"), noAnn (Var "Y")]],+      testCase "prefix word operator rejected as atom" $+        let ops = mkOpTable [(500, [(Fx, "pre")])]+         in assertBool "should fail" (isLeft (parseTerms ops "" "pre.")),+      testCase "prefix word operator allowed as functor" $+        let ops = mkOpTable [(500, [(Fx, "pre")])]+         in stripAll (parseTerms ops "" "pre(X).")+              @?= Right [Compound "pre" [noAnn (Var "X")]]+    ]++-- ---------------------------------------------------------------------------+-- Max-precedence tests (comma and pipe as operators)+-- ---------------------------------------------------------------------------++-- | Operator table with comma and pipe as operators.+commaOps :: OpTable+commaOps =+  mkOpTable+    [ (200, [(Yfx, "*")]),+      (300, [(Yfx, "+")]),+      (700, [(Xfx, "=")]),+      (1000, [(Xfy, ",")]),+      (1100, [(Xfy, "|")])+    ]++-- | Parse with comma/pipe operators.+pComma :: Text -> Either (ParseError) [Ann PExpr]+pComma = parseTerms commaOps ""++maxPrecTests :: TestTree+maxPrecTests =+  testGroup+    "max-precedence"+    [ testCase "comma as operator at top level" $+        stripAll (pComma "a, b.")+          @?= Right [Compound "," [noAnn (Atom "a"), noAnn (Atom "b")]],+      testCase "comma suppressed in compound args" $+        stripAll (pComma "f(a, b).")+          @?= Right [Compound "f" [noAnn (Atom "a"), noAnn (Atom "b")]],+      testCase "pipe as operator at top level" $+        stripAll (pComma "a | b.")+          @?= Right [Compound "|" [noAnn (Atom "a"), noAnn (Atom "b")]],+      testCase "pipe suppressed in list tail" $+        stripAll (pComma "[a | T].")+          @?= Right [Compound "." [noAnn (Atom "a"), noAnn (Var "T")]],+      testCase "comma suppressed in list elements" $+        stripAll (pComma "[a, b].")+          @?= Right+            [ Compound+                "."+                [ noAnn (Atom "a"),+                  noAnn (Compound "." [noAnn (Atom "b"), noAnn (Atom "[]")])+                ]+            ],+      testCase "precedence: + binds tighter than comma" $+        stripAll (pComma "a + b, c.")+          @?= Right+            [ Compound+                ","+                [ noAnn (Compound "+" [noAnn (Atom "a"), noAnn (Atom "b")]),+                  noAnn (Atom "c")+                ]+            ],+      testCase "comma is right-associative" $+        stripAll (pComma "a, b, c.")+          @?= Right+            [ Compound+                ","+                [ noAnn (Atom "a"),+                  noAnn (Compound "," [noAnn (Atom "b"), noAnn (Atom "c")])+                ]+            ],+      testCase "pipe binds looser than comma" $+        stripAll (pComma "a, b | c.")+          @?= Right+            [ Compound+                "|"+                [ noAnn (Compound "," [noAnn (Atom "a"), noAnn (Atom "b")]),+                  noAnn (Atom "c")+                ]+            ],+      testCase "non-associative operator rejects chaining" $+        assertBool "should fail" (isLeft (pComma "a = b = c.")),+      testCase "parenthesized comma in compound arg" $+        stripAll (pComma "f((a, b)).")+          @?= Right [Compound "f" [noAnn (Compound "," [noAnn (Atom "a"), noAnn (Atom "b")])]],+      testCase "comma roundtrip" $+        roundtrip commaOps "comma" (Compound "," [noAnn (Atom "a"), noAnn (Atom "b")]),+      testCase "comma in compound arg roundtrip" $+        roundtrip commaOps "comma in arg" $+          Compound "f" [noAnn (Compound "," [noAnn (Atom "a"), noAnn (Atom "b")])]+    ]++-- ---------------------------------------------------------------------------+-- Dual-role operator tests+-- ---------------------------------------------------------------------------++-- | Operator table with - as both prefix (fy 200) and infix (yfx 500).+dualOps :: OpTable+dualOps =+  mkOpTable+    [ (200, [(Fy, "-")]),+      (500, [(Yfx, "-")]),+      (300, [(Yfx, "+")]),+      (200, [(Yfx, "*")])+    ]++-- | Parse with dual-role operators.+pDual :: Text -> Either (ParseError) [Ann PExpr]+pDual = parseTerms dualOps ""++dualRoleTests :: TestTree+dualRoleTests =+  testGroup+    "dual-role operators"+    [ testCase "prefix minus" $+        stripAll (pDual "- X.")+          @?= Right [Compound "-" [noAnn (Var "X")]],+      testCase "infix minus" $+        stripAll (pDual "X - Y.")+          @?= Right [Compound "-" [noAnn (Var "X"), noAnn (Var "Y")]],+      testCase "prefix and infix combined" $+        stripAll (pDual "X - - Y.")+          @?= Right+            [ Compound+                "-"+                [ noAnn (Var "X"),+                  noAnn (Compound "-" [noAnn (Var "Y")])+                ]+            ],+      testCase "negative integer literal preserved" $+        stripAll (pDual "-7.")+          @?= Right [Int (-7)]+    ]++-- ---------------------------------------------------------------------------+-- Dot termination+-- ---------------------------------------------------------------------------++dotTerminationTests :: TestTree+dotTerminationTests =+  testGroup+    "dot termination"+    [ testCase "multiple terms" $+        stripAll (p "f(X). g(Y).")+          @?= Right+            [ Compound "f" [noAnn (Var "X")],+              Compound "g" [noAnn (Var "Y")]+            ],+      testCase "empty input" $+        stripAll (p "") @?= Right []+    ]++-- ---------------------------------------------------------------------------+-- Comments+-- ---------------------------------------------------------------------------++commentTests :: TestTree+commentTests =+  testGroup+    "comments"+    [ testCase "line comment" $+        stripAll (p "% this is a comment\nfoo.")+          @?= Right [Atom "foo"],+      testCase "comment between terms" $+        stripAll (p "a.\n% comment\nb.")+          @?= Right [Atom "a", Atom "b"]+    ]++-- ---------------------------------------------------------------------------+-- Error cases+-- ---------------------------------------------------------------------------++errorTests :: TestTree+errorTests =+  testGroup+    "errors"+    [ testCase "unterminated term" $+        assertBool "should fail" (isLeft (p "foo"))+    ]++-- ---------------------------------------------------------------------------+-- Pretty-printing+-- ---------------------------------------------------------------------------++-- | Pretty-print with no operators.+pp :: PExpr -> String+pp = prettyPExpr emptyOps++-- | Pretty-print with test operators.+ppOps :: PExpr -> String+ppOps = prettyPExpr testOps++prettyTests :: TestTree+prettyTests =+  testGroup+    "pretty-printing"+    [ testCase "atom" $+        pp (Atom "foo") @?= "foo",+      testCase "quoted atom (uppercase)" $+        pp (Atom "Foo") @?= "'Foo'",+      testCase "quoted atom (space)" $+        pp (Atom "hello world") @?= "'hello world'",+      testCase "quoted atom (embedded quote)" $+        pp (Atom "it's") @?= "'it''s'",+      testCase "quoted atom (empty)" $+        pp (Atom "") @?= "''",+      testCase "quoted atom (word operator)" $+        ppOps (Atom "is") @?= "'is'",+      testCase "variable" $+        pp (Var "X") @?= "X",+      testCase "wildcard" $+        pp Wildcard @?= "_",+      testCase "positive integer" $+        pp (Int 42) @?= "42",+      testCase "negative integer" $+        pp (Int (-7)) @?= "(-7)",+      testCase "string" $+        pp (Str "hello") @?= "\"hello\"",+      testCase "string with escapes" $+        pp (Str "say \"hi\"\n") @?= "\"say \\\"hi\\\"\\n\"",+      testCase "compound" $+        pp (Compound "f" [noAnn (Var "X"), noAnn (Var "Y")]) @?= "f(X, Y)",+      testCase "compound quoted functor" $+        pp (Compound "Hello" [noAnn (Var "X")]) @?= "'Hello'(X)",+      testCase "zero-arg compound" $+        pp (Compound "f" []) @?= "f()",+      testCase "empty list" $+        pp (Atom "[]") @?= "[]",+      testCase "list" $+        pp+          ( Compound+              "."+              [ noAnn (Atom "a"),+                noAnn+                  ( Compound+                      "."+                      [ noAnn (Atom "b"),+                        noAnn (Atom "[]")+                      ]+                  )+              ]+          )+          @?= "[a, b]",+      testCase "list with tail" $+        pp (Compound "." [noAnn (Atom "a"), noAnn (Var "T")])+          @?= "[a | T]",+      testCase "infix operator" $+        ppOps (Compound "+" [noAnn (Var "X"), noAnn (Var "Y")])+          @?= "X + Y",+      testCase "operator precedence (no parens needed)" $+        ppOps+          ( Compound+              "+"+              [ noAnn (Var "X"),+                noAnn+                  ( Compound+                      "*"+                      [ noAnn (Var "Y"),+                        noAnn (Var "Z")+                      ]+                  )+              ]+          )+          @?= "X + Y * Z",+      testCase "operator precedence (parens needed)" $+        ppOps+          ( Compound+              "*"+              [ noAnn (Compound "+" [noAnn (Var "X"), noAnn (Var "Y")]),+                noAnn (Var "Z")+              ]+          )+          @?= "(X + Y) * Z",+      testCase "left associativity (no parens)" $+        ppOps+          ( Compound+              "+"+              [ noAnn (Compound "+" [noAnn (Var "X"), noAnn (Var "Y")]),+                noAnn (Var "Z")+              ]+          )+          @?= "X + Y + Z",+      testCase "left associativity (parens on right)" $+        ppOps+          ( Compound+              "+"+              [ noAnn (Var "X"),+                noAnn+                  ( Compound+                      "+"+                      [ noAnn (Var "Y"),+                        noAnn (Var "Z")+                      ]+                  )+              ]+          )+          @?= "X + (Y + Z)",+      testCase "prefix operator" $+        ppOps (Compound "~" [noAnn (Var "X")])+          @?= "~ X",+      testCase "word operator" $+        ppOps (Compound "is" [noAnn (Var "X"), noAnn (Var "Y")])+          @?= "X is Y"+    ]++-- ---------------------------------------------------------------------------+-- Floats+-- ---------------------------------------------------------------------------++floatTests :: TestTree+floatTests =+  testGroup+    "floats"+    [ testCase "positive float" $+        stripAll (p "3.14.") @?= Right [Float 3.14],+      testCase "zero float" $+        stripAll (p "0.0.") @?= Right [Float 0.0],+      testCase "negative float" $+        stripAll (p "-2.5.") @?= Right [Float (-2.5)],+      testCase "many fractional digits" $+        stripAll (p "100.001.") @?= Right [Float 100.001],+      testCase "trailing zeros preserved as float" $+        stripAll (p "1.000.") @?= Right [Float 1.0],+      testCase "integer followed by dot terminator (not float)" $+        -- "3." is Int 3 with the dot acting as terminator (float needs+        -- at least one digit after '.').+        stripAll (p "3.") @?= Right [Int 3],+      testCase "float inside compound argument" $+        stripAll (p "f(1.5).") @?= Right [Compound "f" [noAnn (Float 1.5)]],+      testCase "float inside operator expression" $+        stripAll (pOps "1.5 + 2.5.")+          @?= Right [Compound "+" [noAnn (Float 1.5), noAnn (Float 2.5)]]+    ]++-- ---------------------------------------------------------------------------+-- String edge cases+-- ---------------------------------------------------------------------------++stringEdgeTests :: TestTree+stringEdgeTests =+  testGroup+    "string edge cases"+    [ testCase "empty string" $+        stripAll (p "\"\".") @?= Right [Str ""],+      testCase "tab escape" $+        stripAll (p "\"x\\ty\".") @?= Right [Str "x\ty"],+      testCase "newline escape" $+        stripAll (p "\"x\\ny\".") @?= Right [Str "x\ny"],+      testCase "backslash escape" $+        stripAll (p "\"x\\\\y\".") @?= Right [Str "x\\y"],+      testCase "double-quote escape" $+        stripAll (p "\"\\\"\".") @?= Right [Str "\""],+      testCase "unknown escape passes through (catch-all)" $+        -- '\a' is not a recognised escape; the catch-all anyChar yields 'a'.+        stripAll (p "\"\\a\".") @?= Right [Str "a"]+    ]++-- ---------------------------------------------------------------------------+-- Quoted-atom edge cases+-- ---------------------------------------------------------------------------++quotedAtomEdgeTests :: TestTree+quotedAtomEdgeTests =+  testGroup+    "quoted-atom edge cases"+    [ testCase "empty quoted atom" $+        stripAll (p "''.") @?= Right [Atom ""],+      testCase "tab escape" $+        stripAll (p "'a\\tb'.") @?= Right [Atom "a\tb"],+      testCase "newline escape" $+        stripAll (p "'a\\nb'.") @?= Right [Atom "a\nb"],+      testCase "backslash escape" $+        stripAll (p "'a\\\\b'.") @?= Right [Atom "a\\b"],+      testCase "apostrophe via backslash escape" $+        stripAll (p "'a\\'b'.") @?= Right [Atom "a'b"],+      testCase "apostrophe via doubled-quote form" $+        stripAll (p "'don''t'.") @?= Right [Atom "don't"],+      testCase "unknown escape passes through (catch-all)" $+        -- '\a' isn't a recognised escape; the catch-all anyChar yields 'a'.+        stripAll (p "'\\a'.") @?= Right [Atom "a"]+    ]++-- ---------------------------------------------------------------------------+-- Postfix operators+-- ---------------------------------------------------------------------------++-- | Operator table with postfix operators.+postfixOps :: OpTable+postfixOps =+  mkOpTable+    [ (300, [(Yfx, "+")]),+      (200, [(Xf, "!")]),+      (200, [(Yf, "++")])+    ]++pPostfix :: Text -> Either ParseError [Ann PExpr]+pPostfix = parseTerms postfixOps ""++postfixTests :: TestTree+postfixTests =+  testGroup+    "postfix operators"+    [ testCase "Xf postfix" $+        stripAll (pPostfix "X !.")+          @?= Right [Compound "!" [noAnn (Var "X")]],+      testCase "Yf postfix" $+        stripAll (pPostfix "X ++.")+          @?= Right [Compound "++" [noAnn (Var "X")]],+      testCase "Yf postfix chains" $+        stripAll (pPostfix "X ++ ++.")+          @?= Right+            [Compound "++" [noAnn (Compound "++" [noAnn (Var "X")])]],+      testCase "Xf postfix does not chain" $+        -- After consuming the first '!', the led-loop will not consume a+        -- second '!' because Xf requires the left operand to have strictly+        -- lower fixity than the operator.+        assertBool "should fail" (isLeft (pPostfix "X ! !.")),+      testCase "postfix combined with infix" $+        -- Postfix '!' (fix 200) binds tighter than infix '+' (fix 300).+        stripAll (pPostfix "X + Y !.")+          @?= Right+            [ Compound+                "+"+                [ noAnn (Var "X"),+                  noAnn (Compound "!" [noAnn (Var "Y")])+                ]+            ]+    ]++-- ---------------------------------------------------------------------------+-- Prefix chaining+-- ---------------------------------------------------------------------------++-- | Operator table mixing Fx (non-chaining) and Fy (chaining) prefix ops.+prefixChainOps :: OpTable+prefixChainOps =+  mkOpTable+    [ (200, [(Fy, "-")]),+      (500, [(Fx, "neg")])+    ]++pPrefixChain :: Text -> Either ParseError [Ann PExpr]+pPrefixChain = parseTerms prefixChainOps ""++prefixChainingTests :: TestTree+prefixChainingTests =+  testGroup+    "prefix chaining"+    [ testCase "Fy chains" $+        stripAll (pPrefixChain "- - X.")+          @?= Right+            [Compound "-" [noAnn (Compound "-" [noAnn (Var "X")])]],+      testCase "Fx does not chain" $+        -- 'neg' is Fx at 500; its operand parses at 499, where 'neg'+        -- (fixity 500) is no longer a legal prefix.  The whole parse+        -- fails.+        assertBool "should fail" (isLeft (pPrefixChain "neg neg X.")),+      testCase "Fx single use is fine" $+        stripAll (pPrefixChain "neg X.")+          @?= Right [Compound "neg" [noAnn (Var "X")]],+      testCase "prefix op at insufficient context (in compound arg)" $+        -- 'neg' at fixity 500 fits comfortably inside maxArgPrec=999.+        -- Lift its fixity above maxArgPrec to exercise the "not a prefix+        -- operator in this context" failure path.+        let hi = mkOpTable [(1100, [(Fx, "high")])]+         in assertBool "should fail" (isLeft (parseTerms hi "" "f(high X)."))+    ]++-- ---------------------------------------------------------------------------+-- Lambdas+-- ---------------------------------------------------------------------------++lambdaTests :: TestTree+lambdaTests =+  testGroup+    "lambdas"+    [ testCase "zero-arg lambda" $+        stripAll (p "fun() -> 42 end.")+          @?= Right [Compound "->" [noAnn (Compound "fun" []), noAnn (Int 42)]],+      testCase "one-arg lambda" $+        stripAll (p "fun(X) -> X end.")+          @?= Right+            [Compound "->" [noAnn (Compound "fun" [noAnn (Var "X")]), noAnn (Var "X")]],+      testCase "multi-arg lambda with operator body" $+        stripAll (pOps "fun(X, Y) -> X + Y end.")+          @?= Right+            [ Compound+                "->"+                [ noAnn (Compound "fun" [noAnn (Var "X"), noAnn (Var "Y")]),+                  noAnn (Compound "+" [noAnn (Var "X"), noAnn (Var "Y")])+                ]+            ],+      testCase "lambda body parses at maxPrec (comma as operator)" $+        stripAll (pComma "fun(X) -> X, X end.")+          @?= Right+            [ Compound+                "->"+                [ noAnn (Compound "fun" [noAnn (Var "X")]),+                  noAnn (Compound "," [noAnn (Var "X"), noAnn (Var "X")])+                ]+            ],+      testCase "lambda inside compound arg without parens" $+        stripAll (p "f(fun(X) -> X end, Y).")+          @?= Right+            [ Compound+                "f"+                [ noAnn+                    ( Compound+                        "->"+                        [ noAnn (Compound "fun" [noAnn (Var "X")]),+                          noAnn (Var "X")+                        ]+                    ),+                  noAnn (Var "Y")+                ]+            ],+      testCase "nested lambda" $+        stripAll (p "fun(X) -> fun(Y) -> Y end end.")+          @?= Right+            [ Compound+                "->"+                [ noAnn (Compound "fun" [noAnn (Var "X")]),+                  noAnn+                    ( Compound+                        "->"+                        [ noAnn (Compound "fun" [noAnn (Var "Y")]),+                          noAnn (Var "Y")+                        ]+                    )+                ]+            ],+      testCase "'fun' followed by identifier char is not a lambda keyword" $+        -- 'funky' is just an atom; lambdaP must not consume the 'fun'.+        stripAll (p "funky.") @?= Right [Atom "funky"],+      testCase "'end' followed by identifier char is not the lambda terminator" $+        -- 'endure' is parsed as a body atom; the real 'end' terminates the+        -- lambda after it.+        stripAll (p "fun(X) -> endure end.")+          @?= Right+            [ Compound+                "->"+                [ noAnn (Compound "fun" [noAnn (Var "X")]),+                  noAnn (Atom "endure")+                ]+            ]+    ]++-- ---------------------------------------------------------------------------+-- Symbol-operator tokenization+-- ---------------------------------------------------------------------------++-- | Operator table exercising symbol-op greedy matching.+greedyOps :: OpTable+greedyOps =+  mkOpTable+    [ (300, [(Yfx, "+")]),+      (200, [(Yfx, "++")])+    ]++pGreedy :: Text -> Either ParseError [Ann PExpr]+pGreedy = parseTerms greedyOps ""++symbolOpTokenTests :: TestTree+symbolOpTokenTests =+  testGroup+    "symbol operator tokenization"+    [ testCase "greedy match prefers '++' over '+ +'" $+        stripAll (pGreedy "X ++ Y.")+          @?= Right [Compound "++" [noAnn (Var "X"), noAnn (Var "Y")]],+      testCase "single '+' still works alongside '++'" $+        stripAll (pGreedy "X + Y.")+          @?= Right [Compound "+" [noAnn (Var "X"), noAnn (Var "Y")]],+      testCase "unknown symbol sequence fails" $+        -- '?' is a symbolChar but '??' is not declared as an operator.+        assertBool "should fail" (isLeft (pGreedy "X ?? Y.")),+      testCase "symbol operator usable as functor via quoting" $+        stripAll (pGreedy "'+'(X, Y).")+          @?= Right [Compound "+" [noAnn (Var "X"), noAnn (Var "Y")]]+    ]++-- ---------------------------------------------------------------------------+-- Precedence boundaries+-- ---------------------------------------------------------------------------++precedenceBoundaryTests :: TestTree+precedenceBoundaryTests =+  testGroup+    "precedence boundaries"+    [ testCase "operator at fixity 999 works inside compound" $+        -- maxArgPrec = 999; an op at exactly 999 is consumed inside f(...).+        let ops = mkOpTable [(999, [(Xfy, "@")])]+         in stripAll (parseTerms ops "" "f(a @ b).")+              @?= Right+                [ Compound+                    "f"+                    [noAnn (Compound "@" [noAnn (Atom "a"), noAnn (Atom "b")])]+                ],+      testCase "operator at fixity 1000 suppressed inside compound" $+        -- An op at 1000 (just above maxArgPrec) is not consumed inside f(...);+        -- it acts as a separator-like token causing a parse failure on the+        -- malformed argument list.+        let ops = mkOpTable [(1000, [(Xfy, "@")])]+         in assertBool "should fail" (isLeft (parseTerms ops "" "f(a @ b).")),+      testCase "operator at fixity 1000 works at top level" $+        let ops = mkOpTable [(1000, [(Xfy, "@")])]+         in stripAll (parseTerms ops "" "a @ b.")+              @?= Right [Compound "@" [noAnn (Atom "a"), noAnn (Atom "b")]],+      testCase "operator at fixity 1200 works at top level (maxPrec)" $+        let ops = mkOpTable [(1200, [(Xfx, ":-")])]+         in stripAll (parseTerms ops "" "a :- b.")+              @?= Right [Compound ":-" [noAnn (Atom "a"), noAnn (Atom "b")]]+    ]++-- ---------------------------------------------------------------------------+-- OpType predicates+-- ---------------------------------------------------------------------------++opTypePredicateTests :: TestTree+opTypePredicateTests =+  testGroup+    "opType predicates"+    [ testCase "isInfix" $ do+        isInfix Xfx @?= True+        isInfix Xfy @?= True+        isInfix Yfx @?= True+        isInfix Fx @?= False+        isInfix Fy @?= False+        isInfix Xf @?= False+        isInfix Yf @?= False,+      testCase "isPrefix" $ do+        isPrefix Fx @?= True+        isPrefix Fy @?= True+        isPrefix Xfx @?= False+        isPrefix Xfy @?= False+        isPrefix Yfx @?= False+        isPrefix Xf @?= False+        isPrefix Yf @?= False,+      testCase "isPostfix" $ do+        isPostfix Xf @?= True+        isPostfix Yf @?= True+        isPostfix Xfx @?= False+        isPostfix Xfy @?= False+        isPostfix Yfx @?= False+        isPostfix Fx @?= False+        isPostfix Fy @?= False+    ]++-- ---------------------------------------------------------------------------+-- mergeOps+-- ---------------------------------------------------------------------------++mergeOpsTests :: TestTree+mergeOpsTests =+  testGroup+    "mergeOps"+    [ testCase "adds new operator usable by parser" $+        case mergeOps emptyOps [(500, Yfx, "++")] of+          Left n -> assertFailure ("unexpected conflict: " ++ T.unpack n)+          Right merged ->+            stripAll (parseTerms merged "" "X ++ Y.")+              @?= Right [Compound "++" [noAnn (Var "X"), noAnn (Var "Y")]],+      testCase "identical re-declaration is a no-op" $+        let base = mkOpTable [(500, [(Yfx, "**")])]+         in case mergeOps base [(500, Yfx, "**")] of+              Left n -> assertFailure ("unexpected conflict: " ++ T.unpack n)+              Right merged ->+                length [() | (_, _, "**") <- opTableEntries merged] @?= 1,+      testCase "redeclaring an op from base does not duplicate" $+        let base = mkOpTable [(400, [(Yfx, "/")])]+         in case mergeOps base [(400, Yfx, "/")] of+              Left n -> assertFailure ("unexpected conflict: " ++ T.unpack n)+              Right merged ->+                length [() | (_, _, "/") <- opTableEntries merged] @?= 1,+      testCase "repeated entries within decls do not duplicate" $+        case mergeOps emptyOps [(500, Yfx, "++"), (500, Yfx, "++")] of+          Left n -> assertFailure ("unexpected conflict: " ++ T.unpack n)+          Right merged ->+            length [() | (_, _, "++") <- opTableEntries merged] @?= 1,+      testCase "prefix conflict (different fixity) returns Left" $+        let base = mkOpTable [(500, [(Fx, "foo")])]+         in case mergeOps base [(600, Fx, "foo")] of+              Left n -> n @?= "foo"+              Right _ -> assertFailure "expected conflict",+      testCase "prefix conflict (different type) returns Left" $+        let base = mkOpTable [(500, [(Fx, "foo")])]+         in case mergeOps base [(500, Fy, "foo")] of+              Left n -> n @?= "foo"+              Right _ -> assertFailure "expected conflict",+      testCase "infix conflict returns Left" $+        let base = mkOpTable [(500, [(Yfx, "@")])]+         in case mergeOps base [(600, Yfx, "@")] of+              Left n -> n @?= "@"+              Right _ -> assertFailure "expected conflict",+      testCase "dual-role allowed: prefix added when infix exists" $+        let base = mkOpTable [(500, [(Yfx, "-")])]+         in case mergeOps base [(200, Fy, "-")] of+              Left n -> assertFailure ("unexpected conflict: " ++ T.unpack n)+              Right merged -> do+                Map.lookup "-" merged.prefixByName @?= Just (200, Fy)+                Map.lookup "-" merged.infixByName @?= Just (500, Yfx),+      testCase "postfix declarations populate infixByName" $+        case mergeOps emptyOps [(200, Xf, "!")] of+          Left n -> assertFailure ("unexpected conflict: " ++ T.unpack n)+          Right merged -> Map.lookup "!" merged.infixByName @?= Just (200, Xf),+      testCase "non-symbolic op extends wordOpSet" $+        case mergeOps emptyOps [(700, Xfx, "is")] of+          Left n -> assertFailure ("unexpected conflict: " ++ T.unpack n)+          Right merged ->+            assertBool "is should be in wordOpSet" $+              "is" `elem` [name | (_, _, name) <- opTableEntries merged]+    ]++-- ---------------------------------------------------------------------------+-- opTableEntries+-- ---------------------------------------------------------------------------++opTableEntriesTests :: TestTree+opTableEntriesTests =+  testGroup+    "opTableEntries"+    [ testCase "roundtrip mkOpTable -> opTableEntries" $+        let entries =+              [ (200, Yfx, "*"),+                (300, Yfx, "+"),+                (500, Fx, "neg"),+                (200, Xf, "!"),+                (700, Xfx, "is")+              ]+            grouped =+              [ (200, [(Yfx, "*"), (Xf, "!")]),+                (300, [(Yfx, "+")]),+                (500, [(Fx, "neg")]),+                (700, [(Xfx, "is")])+              ]+            table = mkOpTable grouped+            -- OpType lacks Ord, so compare via Show as a stable key.+            key (fix, ty, name) = (fix, show ty, name)+         in sort (map key (opTableEntries table)) @?= sort (map key entries)+    ]++-- ---------------------------------------------------------------------------+-- Single-term API (parseTermNoDot, parseFirstTerm, parseLeadingTerms)+-- ---------------------------------------------------------------------------++singleTermApiTests :: TestTree+singleTermApiTests =+  testGroup+    "single-term APIs"+    [ testCase "parseTermNoDot accepts a bare term" $+        case parseTermNoDot emptyOps "" "f(X)" of+          Left err -> assertFailure (show err)+          Right ann -> strip ann @?= Compound "f" [noAnn (Var "X")],+      testCase "parseTermNoDot rejects trailing dot" $+        assertBool "should fail" (isLeft (parseTermNoDot emptyOps "" "foo.")),+      testCase "parseFirstTerm on empty input is Nothing" $+        case parseFirstTerm emptyOps "" "" of+          Left err -> assertFailure (show err)+          Right m -> assertBool "should be Nothing" (isNothing m),+      testCase "parseFirstTerm returns first term, ignores rest" $+        case parseFirstTerm emptyOps "" "foo. bar. baz." of+          Left err -> assertFailure (show err)+          Right (Just ann) -> strip ann @?= Atom "foo"+          Right Nothing -> assertFailure "expected Just foo",+      testCase "parseFirstTerm with no dot returns Nothing" $+        -- No dot anywhere means no complete term — the inner try backtracks.+        case parseFirstTerm emptyOps "" "foo bar" of+          Left err -> assertFailure (show err)+          Right m -> assertBool "should be Nothing" (isNothing m),+      testCase "parseLeadingTerms: all parse" $+        case parseLeadingTerms emptyOps "" "foo. bar." of+          Left err -> assertFailure (show err)+          Right (terms, mLoc) -> do+            map strip terms @?= [Atom "foo", Atom "bar"]+            assertBool "no remainder expected" (isNothing mLoc),+      testCase "parseLeadingTerms: partial parse leaves remainder" $+        case parseLeadingTerms emptyOps "" "foo. ???" of+          Left err -> assertFailure (show err)+          Right (terms, mLoc) -> do+            map strip terms @?= [Atom "foo"]+            assertBool "remainder expected" (isJust mLoc),+      testCase "parseLeadingTerms: failure at start yields empty list" $+        case parseLeadingTerms emptyOps "" "???" of+          Left err -> assertFailure (show err)+          Right (terms, mLoc) -> do+            map strip terms @?= []+            assertBool "remainder expected" (isJust mLoc),+      testCase "parseLeadingTerms: empty input yields empty list, no remainder" $+        case parseLeadingTerms emptyOps "" "" of+          Left err -> assertFailure (show err)+          Right (terms, mLoc) -> do+            terms @?= []+            assertBool "no remainder expected" (isNothing mLoc),+      testCase "parseLeadingTerms: remainder location is after the consumed prefix" $+        case parseLeadingTerms emptyOps "<src>" "foo.\n???" of+          Left err -> assertFailure (show err)+          Right (_, Just loc) -> do+            -- The remainder starts on line 2 (after the newline following 'foo.').+            loc.line @?= 2+            loc.file @?= "<src>"+          Right (_, Nothing) -> assertFailure "expected remainder location"+    ]++-- ---------------------------------------------------------------------------+-- renderAtom+-- ---------------------------------------------------------------------------++renderAtomTests :: TestTree+renderAtomTests =+  testGroup+    "renderAtom"+    [ testCase "plain lowercase unquoted" $+        renderAtom mempty "foo" @?= "foo",+      testCase "uppercase start quoted" $+        renderAtom mempty "Foo" @?= "'Foo'",+      testCase "empty atom quoted" $+        renderAtom mempty "" @?= "''",+      testCase "embedded apostrophe doubled inside quotes" $+        renderAtom mempty "it's" @?= "'it''s'",+      testCase "word operator must be quoted" $+        -- 'is' is a word operator in testOps; it must be quoted to disambiguate.+        renderAtom testOps.wordOpSet "is" @?= "'is'",+      testCase "double underscore forces quoting" $+        renderAtom mempty "foo__bar" @?= "'foo__bar'",+      testCase "symbol-only name forces quoting" $+        renderAtom mempty "+" @?= "'+'"+    ]++-- ---------------------------------------------------------------------------+-- Float and postfix pretty-printing+-- ---------------------------------------------------------------------------++floatAndPostfixPrettyTests :: TestTree+floatAndPostfixPrettyTests =+  testGroup+    "pretty-printing: floats and postfix"+    [ testCase "positive float" $+        pp (Float 3.14) @?= "3.14",+      testCase "negative float wraps in parens" $+        pp (Float (-2.5)) @?= "(-2.5)",+      testCase "whole-valued float keeps '.0'" $+        pp (Float 1.0) @?= "1.0",+      testCase "zero float" $+        pp (Float 0.0) @?= "0.0",+      testCase "Xf postfix" $+        prettyPExpr postfixOps (Compound "!" [noAnn (Var "X")])+          @?= "X !",+      testCase "Yf postfix chains without parens" $+        prettyPExpr+          postfixOps+          (Compound "++" [noAnn (Compound "++" [noAnn (Var "X")])])+          @?= "X ++ ++",+      testCase "Fy prefix chains without parens" $+        prettyPExpr+          prefixChainOps+          (Compound "-" [noAnn (Compound "-" [noAnn (Var "X")])])+          @?= "- - X",+      testCase "lambda pretty-prints with intercalated params" $+        pp+          ( Compound+              "->"+              [ noAnn (Compound "fun" [noAnn (Var "X"), noAnn (Var "Y")]),+                noAnn (Var "X")+              ]+          )+          @?= "fun(X, Y) -> X end"+    ]++-- ---------------------------------------------------------------------------+-- Roundtrip tests+-- ---------------------------------------------------------------------------++-- | Assert that pretty-printing and re-parsing a single term produces the+-- same term (modulo source locations).+roundtrip :: OpTable -> String -> PExpr -> IO ()+roundtrip ops label expr = do+  let src = prettyPExpr ops expr+      input = T.pack (src ++ ".")+  case parseTerms ops "<roundtrip>" input of+    Left err -> assertFailure (label ++ ": parse failed on: " ++ show src ++ "\n" ++ show err)+    Right [ann] -> strip ann @?= expr+    Right ts -> assertFailure (label ++ ": expected 1 term, got " ++ show (length ts))++roundtripTests :: TestTree+roundtripTests =+  testGroup+    "roundtrip (parse . pretty = id)"+    [ testCase "atom" $ roundtrip emptyOps "atom" (Atom "foo"),+      testCase "quoted atom" $ roundtrip emptyOps "quoted atom" (Atom "Hello World"),+      testCase "atom with quote" $ roundtrip emptyOps "atom with quote" (Atom "it's"),+      testCase "empty atom" $ roundtrip emptyOps "empty atom" (Atom ""),+      testCase "variable" $ roundtrip emptyOps "variable" (Var "X"),+      testCase "wildcard" $ roundtrip emptyOps "wildcard" Wildcard,+      testCase "positive int" $ roundtrip emptyOps "positive int" (Int 42),+      testCase "negative int" $ roundtrip emptyOps "negative int" (Int (-7)),+      testCase "zero" $ roundtrip emptyOps "zero" (Int 0),+      testCase "string" $ roundtrip emptyOps "string" (Str "hello"),+      testCase "string with escapes" $+        roundtrip emptyOps "string escapes" (Str "say \"hi\"\n\\"),+      testCase "compound" $+        roundtrip emptyOps "compound" (Compound "f" [noAnn (Var "X"), noAnn (Atom "a")]),+      testCase "nested compound" $+        roundtrip emptyOps "nested" (Compound "f" [noAnn (Compound "g" [noAnn (Atom "a")])]),+      testCase "zero-arg compound" $+        roundtrip emptyOps "zero-arg" (Compound "f" []),+      testCase "list" $+        roundtrip emptyOps "list" $+          Compound+            "."+            [ noAnn (Atom "a"),+              noAnn+                ( Compound+                    "."+                    [ noAnn (Atom "b"),+                      noAnn (Atom "[]")+                    ]+                )+            ],+      testCase "list with tail" $+        roundtrip emptyOps "list with tail" $+          Compound "." [noAnn (Atom "a"), noAnn (Var "T")],+      testCase "infix operator" $+        roundtrip testOps "infix" (Compound "+" [noAnn (Var "X"), noAnn (Var "Y")]),+      testCase "nested operators" $+        roundtrip testOps "nested ops" $+          Compound+            "+"+            [ noAnn (Var "X"),+              noAnn+                ( Compound+                    "*"+                    [ noAnn (Var "Y"),+                      noAnn (Var "Z")+                    ]+                )+            ],+      testCase "parens needed" $+        roundtrip testOps "parens" $+          Compound+            "*"+            [ noAnn (Compound "+" [noAnn (Var "X"), noAnn (Var "Y")]),+              noAnn (Var "Z")+            ],+      testCase "left assoc" $+        roundtrip testOps "left assoc" $+          Compound+            "+"+            [ noAnn (Compound "+" [noAnn (Var "X"), noAnn (Var "Y")]),+              noAnn (Var "Z")+            ],+      testCase "right grouping" $+        roundtrip testOps "right grouping" $+          Compound+            "+"+            [ noAnn (Var "X"),+              noAnn+                ( Compound+                    "+"+                    [ noAnn (Var "Y"),+                      noAnn (Var "Z")+                    ]+                )+            ],+      testCase "prefix operator" $+        roundtrip testOps "prefix" (Compound "~" [noAnn (Var "X")]),+      testCase "word operator" $+        roundtrip testOps "word op" (Compound "is" [noAnn (Var "X"), noAnn (Var "Y")]),+      testCase "quoted functor" $+        roundtrip emptyOps "quoted functor" (Compound "Hello" [noAnn (Var "X")]),+      testCase "word op as 3-arg functor" $+        roundtrip+          testOps+          "word op 3-arg"+          ( Compound+              "is"+              [ noAnn (Var "X"),+                noAnn (Var "Y"),+                noAnn (Var "Z")+              ]+          ),+      testCase "empty list" $+        roundtrip emptyOps "empty list" (Atom "[]")+    ]
+ test/YCHR/ParserTest.hs view
@@ -0,0 +1,930 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.ParserTest (tests) where++import Data.Either (isLeft)+import Data.Text (Text)+import Data.Text qualified as Text+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import Text.Parsec (ParseError)+import YCHR.Internal.Parsed+import YCHR.Internal.Parser+  ( ModuleHeader (..),+    ParseValidationError (..),+    builtinOps,+    collectModuleHeader,+    mergeOps,+    parseModule,+    parseModuleWith,+  )++tests :: TestTree+tests =+  testGroup+    "YCHR.Internal.Parser"+    [ directiveTests,+      termTests,+      negativeIntTests,+      floatLiteralTests,+      operatorTests,+      ruleTests,+      typeTests,+      moduleTests,+      commentTests,+      errorTests,+      firstPassTests+    ]++-- | Parse a source string with no filename.+p :: Text -> Either (ParseError) Module+p src = fst <$> parseModule "" src++-- | Parse and return only the validation errors, with each error's+-- variant extracted (location/origin discarded).+pErrs :: Text -> Either (ParseError) [ParseValidationError]+pErrs src = map (.node) . snd <$> parseModule "" src++-- | Strip source locations from a Rule for structural comparison.+stripRuleLoc :: Rule -> Rule+stripRuleLoc r =+  r+    { name = fmap (noAnn . (.node)) r.name,+      head = noAnnP r.head.node,+      guard = noAnnP r.guard.node,+      body = noAnnP r.body.node+    }++-- | Strip source locations from a Module for structural comparison.+stripModLoc :: Module -> Module+stripModLoc m =+  m+    { nameLoc = dummyLoc,+      imports = map (noAnnP . (.node)) m.imports,+      decls = map (noAnn . (.node)) m.decls,+      typeDecls = map (noAnn . (.node)) m.typeDecls,+      rules = map stripRuleLoc m.rules,+      equations = map (noAnnP . (.node)) m.equations,+      exports = fmap (noAnnP . (.node)) m.exports+    }++-- ---------------------------------------------------------------------------+-- Directives+-- ---------------------------------------------------------------------------++directiveTests :: TestTree+directiveTests =+  testGroup+    "directives"+    [ testCase "module name" $+        (.name) <$> p ":- module(order, [])." @?= Right "order",+      testCase "module name with export list" $+        (.name) <$> p ":- module(order, [leq/2, foo/1])." @?= Right "order",+      testCase "duplicate module header is rejected" $ do+        -- The first header wins; each subsequent ':- module(...)' yields+        -- one DuplicateModuleHeader error carrying its own name.+        (.name) <$> p ":- module(a).\n:- module(b).\n:- chr_constraint c/0."+          @?= Right "a"+        pErrs ":- module(a).\n:- module(b).\n:- chr_constraint c/0."+          @?= Right [DuplicateModuleHeader "b"],+      testCase "three module headers report two duplicates" $+        pErrs ":- module(a).\n:- module(b).\n:- module(c)."+          @?= Right [DuplicateModuleHeader "b", DuplicateModuleHeader "c"],+      testCase "empty export list" $+        fmap (.node) . (.exports) <$> p ":- module(order, [])." @?= Right (Just []),+      testCase "export list parsed correctly" $+        fmap (.node) . (.exports) <$> p ":- module(order, [leq/2, foo/1])."+          @?= Right+            ( Just+                [ ConstraintDecl "leq" 2 Nothing Nothing,+                  ConstraintDecl "foo" 1 Nothing Nothing+                ]+            ),+      testCase "use_module" $+        (map (.node) . (.imports))+          <$> p ":- use_module(stdlib)."+          @?= Right [ModuleImport "stdlib" Nothing],+      testCase "multiple use_module" $+        (map (.node) . (.imports))+          <$> p ":- use_module(stdlib).\n:- use_module(lists)."+          @?= Right [ModuleImport "stdlib" Nothing, ModuleImport "lists" Nothing],+      testCase "use_module library" $+        (map (.node) . (.imports))+          <$> p ":- use_module(library(mylib))."+          @?= Right [LibraryImport "mylib" Nothing],+      testCase "use_module with import list" $+        (map (.node) . (.imports)) <$> p ":- use_module(order, [leq/2])."+          @?= Right [ModuleImport "order" (Just [ConstraintDecl "leq" 2 Nothing Nothing])],+      testCase "use_module library with import list" $+        (map (.node) . (.imports))+          <$> p ":- use_module(library(mylib), [foo/1, type(tree/0)])."+          @?= Right+            [ LibraryImport+                "mylib"+                ( Just+                    [ ConstraintDecl "foo" 1 Nothing Nothing,+                      TypeExportDecl "tree" 0 Nothing+                    ]+                )+            ],+      testCase "chr_constraint single" $+        (map (.node) . (.decls)) <$> p ":- chr_constraint leq/2."+          @?= Right [ConstraintDecl "leq" 2 Nothing Nothing],+      testCase "chr_constraint multiple in one directive" $+        (map (.node) . (.decls)) <$> p ":- chr_constraint fib/2, upto/1."+          @?= Right+            [ ConstraintDecl "fib" 2 Nothing Nothing,+              ConstraintDecl "upto" 1 Nothing Nothing+            ],+      testCase "chr_constraint zero arity" $+        (map (.node) . (.decls)) <$> p ":- chr_constraint fire/0."+          @?= Right [ConstraintDecl "fire" 0 Nothing Nothing],+      testCase "type export in export list" $+        fmap (.node) . (.exports) <$> p ":- module(m, [type(tree/0), leq/2])."+          @?= Right+            ( Just+                [TypeExportDecl "tree" 0 Nothing, ConstraintDecl "leq" 2 Nothing Nothing]+            ),+      testCase "parameterized type export" $+        fmap (.node) . (.exports) <$> p ":- module(m, [type(list/1)])."+          @?= Right (Just [TypeExportDecl "list" 1 Nothing]),+      testCase "type export with constructor allowlist" $+        fmap (.node) . (.exports)+          <$> p ":- module(m, [type(foo/0, [bar, baz])])."+          @?= Right (Just [TypeExportDecl "foo" 0 (Just ["bar", "baz"])]),+      testCase "type export with empty constructor list" $+        fmap (.node) . (.exports)+          <$> p ":- module(m, [type(foo/0, [])])."+          @?= Right (Just [TypeExportDecl "foo" 0 (Just [])]),+      testCase "non-list constructor argument is rejected" $ do+        fmap (.node) . (.exports)+          <$> p ":- module(m, [type(foo/0, oops)])."+          @?= Right (Just [])+        pErrs ":- module(m, [type(foo/0, oops)])."+          @?= Right [MalformedExportItem],+      testCase "non-atom in constructor list is rejected" $ do+        -- One non-atom element (Node is a variable) drops the whole+        -- TypeExportDecl and emits one MalformedExportItem per bad+        -- element.+        fmap (.node) . (.exports)+          <$> p ":- module(m, [type(foo/0, [bar, Node])])."+          @?= Right (Just [])+        pErrs ":- module(m, [type(foo/0, [bar, Node])])."+          @?= Right [MalformedExportItem],+      testCase "multiple bad elements report multiple errors" $+        pErrs ":- module(m, [type(foo/0, [X, Y])])."+          @?= Right [MalformedExportItem, MalformedExportItem],+      testCase "unknown directive is skipped" $+        (map (.node) . (.decls)) <$> p ":- mystery_directive(foo).\n:- chr_constraint leq/2."+          @?= Right [ConstraintDecl "leq" 2 Nothing Nothing],+      testCase "chr_constraint typed" $+        (map (.node) . (.decls)) <$> p ":- chr_constraint leq(int, int)."+          @?= Right+            [ ConstraintDecl+                "leq"+                2+                ( Just+                    [ TypeCon (Unqualified "int") [],+                      TypeCon (Unqualified "int") []+                    ]+                )+                Nothing+            ],+      testCase "chr_constraint typed with type variables" $+        (map (.node) . (.decls)) <$> p ":- chr_constraint foo(list(T), T)."+          @?= Right+            [ ConstraintDecl+                "foo"+                2+                (Just [TypeCon (Unqualified "list") [TypeVar "T"], TypeVar "T"])+                Nothing+            ],+      testCase "chr_constraint typed zero arity" $+        (map (.node) . (.decls)) <$> p ":- chr_constraint fire()."+          @?= Right [ConstraintDecl "fire" 0 (Just []) Nothing],+      testCase "function typed" $+        (map (.node) . (.decls)) <$> p ":- function factorial(int) -> int."+          @?= Right+            [ FunctionDecl+                "factorial"+                1+                (Just [TypeCon (Unqualified "int") []])+                (Just (TypeCon (Unqualified "int") []))+                False+                DKFunction+                Nothing+            ],+      testCase "function typed multiple args" $+        (map (.node) . (.decls)) <$> p ":- function add(int, int) -> int."+          @?= Right+            [ FunctionDecl+                "add"+                2+                (Just [TypeCon (Unqualified "int") [], TypeCon (Unqualified "int") []])+                (Just (TypeCon (Unqualified "int") []))+                False+                DKFunction+                Nothing+            ],+      testCase "function untyped" $+        (map (.node) . (.decls)) <$> p ":- function foo/2."+          @?= Right [FunctionDecl "foo" 2 Nothing Nothing False DKFunction Nothing]+    ]++-- ---------------------------------------------------------------------------+-- Terms (tested via rule bodies)+-- ---------------------------------------------------------------------------++termTests :: TestTree+termTests =+  testGroup+    "terms"+    [ testCase "variable in body" $+        bodyOf "c(X) <=> X." >>= (@?= [VarTerm "X"]),+      testCase "wildcard in head" $+        headOf "c(_) <=> true."+          >>= (@?= Simplification [Constraint (Unqualified "c") [Wildcard]]),+      testCase "underscore-prefixed variable in body" $+        bodyOf "c(X) <=> _X." >>= (@?= [VarTerm "_X"]),+      testCase "underscore-prefixed variable in head" $+        headOf "c(_X) <=> true."+          >>= (@?= Simplification [Constraint (Unqualified "c") [VarTerm "_X"]]),+      testCase "underscore-prefixed variable as list tail" $+        bodyOf "c <=> f([H | _Tail])."+          >>= ( @?=+                  [ CompoundTerm+                      (Unqualified "f")+                      [CompoundTerm (Unqualified ".") [VarTerm "H", VarTerm "_Tail"]]+                  ]+              ),+      testCase "double-underscore variable" $+        bodyOf "c <=> __Foo." >>= (@?= [VarTerm "__Foo"]),+      testCase "integer in body" $+        bodyOf "c <=> f(1)."+          >>= (@?= [CompoundTerm (Unqualified "f") [IntTerm 1]]),+      testCase "bare atom in body" $+        bodyOf "c <=> true." >>= (@?= [CompoundTerm (Unqualified "true") []]),+      testCase "compound term in body" $+        bodyOf "c(X) <=> f(X, a)."+          >>= ( @?=+                  [ CompoundTerm+                      (Unqualified "f")+                      [VarTerm "X", CompoundTerm (Unqualified "a") []]+                  ]+              ),+      testCase "quoted atom as functor" $+        bodyOf "c <=> 'hello'."+          >>= (@?= [CompoundTerm (Unqualified "hello") []]),+      testCase "quoted atom with space" $+        bodyOf "c <=> 'hello world'."+          >>= (@?= [CompoundTerm (Unqualified "hello world") []]),+      testCase "empty quoted atom" $+        bodyOf "c <=> ''."+          >>= (@?= [CompoundTerm (Unqualified "") []]),+      testCase "quoted atom with '' escape (ISO Prolog)" $+        bodyOf "c <=> 'it''s'."+          >>= (@?= [CompoundTerm (Unqualified "it's") []]),+      testCase "quoted atom with \\' escape (SWI-Prolog)" $+        bodyOf "c <=> 'a\\'b'."+          >>= (@?= [CompoundTerm (Unqualified "a'b") []]),+      testCase "quoted atom with \\\\ escape" $+        bodyOf "c <=> 'back\\\\slash'."+          >>= (@?= [CompoundTerm (Unqualified "back\\slash") []]),+      testCase "zero-arity compound via quoted atom" $+        bodyOf "c <=> 'foo'(X, 1)."+          >>= (@?= [CompoundTerm (Unqualified "foo") [VarTerm "X", IntTerm 1]]),+      testCase "nested compound" $+        bodyOf "c <=> f(g(X))."+          >>= ( @?=+                  [ CompoundTerm+                      (Unqualified "f")+                      [ CompoundTerm+                          (Unqualified "g")+                          [ VarTerm+                              "X"+                          ]+                      ]+                  ]+              )+    ]++-- ---------------------------------------------------------------------------+-- Negative integer literals+-- ---------------------------------------------------------------------------++negativeIntTests :: TestTree+negativeIntTests =+  testGroup+    "negative integer literals"+    [ testCase "negative literal as standalone term" $+        bodyOf "c <=> f(-5)."+          >>= (@?= [CompoundTerm (Unqualified "f") [IntTerm (-5)]]),+      testCase "negative literal as constraint argument" $+        headOf "c(-3, X) <=> true."+          >>= (@?= Simplification [Constraint (Unqualified "c") [IntTerm (-3), VarTerm "X"]]),+      testCase "negative literal in guard" $+        guardOf "r @ c(X) <=> host:'>='(X, -1) | true."+          >>= (@?= [CompoundTerm (Qualified "host" ">=") [VarTerm "X", IntTerm (-1)]]),+      testCase "negative zero" $+        bodyOf "c <=> f(-0)."+          >>= (@?= [CompoundTerm (Unqualified "f") [IntTerm 0]])+    ]++-- ---------------------------------------------------------------------------+-- Float literals+-- ---------------------------------------------------------------------------++floatLiteralTests :: TestTree+floatLiteralTests =+  testGroup+    "float literals"+    [ testCase "positive float in body" $+        bodyOf "c <=> f(3.14)."+          >>= (@?= [CompoundTerm (Unqualified "f") [FloatTerm 3.14]]),+      testCase "negative float in body" $+        bodyOf "c <=> f(-2.5)."+          >>= (@?= [CompoundTerm (Unqualified "f") [FloatTerm (-2.5)]]),+      testCase "float in constraint argument" $+        headOf "c(1.5, X) <=> true."+          >>= ( @?=+                  Simplification+                    [Constraint (Unqualified "c") [FloatTerm 1.5, VarTerm "X"]]+              ),+      testCase "zero float" $+        bodyOf "c <=> f(0.0)."+          >>= (@?= [CompoundTerm (Unqualified "f") [FloatTerm 0.0]])+    ]++-- ---------------------------------------------------------------------------+-- Operator expressions+-- ---------------------------------------------------------------------------++operatorTests :: TestTree+operatorTests =+  testGroup+    "operator expressions"+    [ testCase "unification operator" $+        bodyOf "c <=> X = Y."+          >>= (@?= [CompoundTerm (Unqualified "=") [VarTerm "X", VarTerm "Y"]]),+      testCase "is operator with arithmetic" $+        bodyOf "c <=> N is host:'+'(X, 1)."+          >>= ( @?=+                  [ CompoundTerm+                      (Unqualified "is")+                      [ VarTerm "N",+                        CompoundTerm+                          (Qualified "host" "+")+                          [ VarTerm "X",+                            IntTerm 1+                          ]+                      ]+                  ]+              ),+      testCase "qualified name in term" $+        bodyOf "c <=> host:print(X)."+          >>= (@?= [CompoundTerm (Qualified "host" "print") [VarTerm "X"]]),+      testCase "zero-arity qualified name" $+        bodyOf "c <=> host:done."+          >>= (@?= [CompoundTerm (Qualified "host" "done") []]),+      testCase "is operator used as functor" $+        bodyOf "c <=> is(X, Y)."+          >>= (@?= [CompoundTerm (Unqualified "is") [VarTerm "X", VarTerm "Y"]]),+      testCase "= operator used as functor" $+        bodyOf "c <=> '='(X, Y)."+          >>= (@?= [CompoundTerm (Unqualified "=") [VarTerm "X", VarTerm "Y"]]),+      testCase "is with comparison RHS (no parens needed)" $+        bodyOfWithLt "c <=> B is 1 < 2."+          >>= ( @?=+                  [ CompoundTerm+                      (Unqualified "is")+                      [ VarTerm "B",+                        CompoundTerm+                          (Unqualified "<")+                          [IntTerm 1, IntTerm 2]+                      ]+                  ]+              ),+      testCase "= with comparison RHS (no parens needed)" $+        bodyOfWithLt "c <=> T = X < Y."+          >>= ( @?=+                  [ CompoundTerm+                      (Unqualified "=")+                      [ VarTerm "T",+                        CompoundTerm+                          (Unqualified "<")+                          [VarTerm "X", VarTerm "Y"]+                      ]+                  ]+              )+    ]++-- ---------------------------------------------------------------------------+-- Rules+-- ---------------------------------------------------------------------------++ruleTests :: TestTree+ruleTests =+  testGroup+    "rules"+    [ testCase "named simplification" $+        (map stripRuleLoc . (.rules)) <$> p "refl @ leq(X, X) <=> true."+          @?= Right+            [ Rule+                (Just (noAnn "refl"))+                ( noAnnP+                    ( Simplification+                        [ Constraint+                            (Unqualified "leq")+                            [ VarTerm "X",+                              VarTerm "X"+                            ]+                        ]+                    )+                )+                (noAnnP [])+                (noAnnP [CompoundTerm (Unqualified "true") []])+            ],+      testCase "unnamed simplification" $+        (map stripRuleLoc . (.rules)) <$> p "leq(X, X) <=> true."+          @?= Right+            [ Rule+                Nothing+                ( noAnnP+                    ( Simplification+                        [ Constraint+                            (Unqualified "leq")+                            [ VarTerm "X",+                              VarTerm "X"+                            ]+                        ]+                    )+                )+                (noAnnP [])+                (noAnnP [CompoundTerm (Unqualified "true") []])+            ],+      testCase "propagation" $+        (map stripRuleLoc . (.rules)) <$> p "trans @ leq(X, Y), leq(Y, Z) ==> leq(X, Z)."+          @?= Right+            [ Rule+                (Just (noAnn "trans"))+                ( noAnnP+                    ( Propagation+                        [ Constraint (Unqualified "leq") [VarTerm "X", VarTerm "Y"],+                          Constraint (Unqualified "leq") [VarTerm "Y", VarTerm "Z"]+                        ]+                    )+                )+                (noAnnP [])+                (noAnnP [CompoundTerm (Unqualified "leq") [VarTerm "X", VarTerm "Z"]])+            ],+      testCase "simpagation" $+        (map stripRuleLoc . (.rules)) <$> p "s @ kept \\ removed <=> body."+          @?= Right+            [ Rule+                (Just (noAnn "s"))+                ( noAnnP+                    ( Simpagation+                        [Constraint (Unqualified "kept") []]+                        [Constraint (Unqualified "removed") []]+                    )+                )+                (noAnnP [])+                (noAnnP [CompoundTerm (Unqualified "body") []])+            ],+      testCase "rule with guard" $+        (map stripRuleLoc . (.rules)) <$> p "r @ c(X, Y) <=> g(X) | b(Y)."+          @?= Right+            [ Rule+                (Just (noAnn "r"))+                ( noAnnP+                    ( Simplification+                        [ Constraint+                            (Unqualified "c")+                            [ VarTerm "X",+                              VarTerm "Y"+                            ]+                        ]+                    )+                )+                (noAnnP [CompoundTerm (Unqualified "g") [VarTerm "X"]])+                (noAnnP [CompoundTerm (Unqualified "b") [VarTerm "Y"]])+            ],+      testCase "multiple body goals" $+        bodyOf "c <=> a, b, c2."+          >>= ( @?=+                  [ CompoundTerm (Unqualified "a") [],+                    CompoundTerm (Unqualified "b") [],+                    CompoundTerm (Unqualified "c2") []+                  ]+              ),+      testCase "zero-arity constraint in head" $+        headOf "fire <=> true."+          >>= (@?= Simplification [Constraint (Unqualified "fire") []])+    ]++-- ---------------------------------------------------------------------------+-- Type declarations+-- ---------------------------------------------------------------------------++typeTests :: TestTree+typeTests =+  testGroup+    "type declarations"+    [ testCase "simple enum type" $+        typeDefsOf ":- chr_type color ---> red ; green ; blue."+          >>= ( @?=+                  [ algebraicTD+                      (Unqualified "color")+                      []+                      [ DataConstructor (Unqualified "red") [],+                        DataConstructor (Unqualified "green") [],+                        DataConstructor (Unqualified "blue") []+                      ]+                      dummyLoc+                  ]+              ),+      testCase "type with constructor args" $+        typeDefsOf ":- chr_type tree ---> empty ; leaf(int) ; branch(tree, tree)."+          >>= ( @?=+                  [ algebraicTD+                      (Unqualified "tree")+                      []+                      [ DataConstructor (Unqualified "empty") [],+                        DataConstructor (Unqualified "leaf") [TypeCon (Unqualified "int") []],+                        DataConstructor+                          (Unqualified "branch")+                          [ TypeCon+                              (Unqualified "tree")+                              [],+                            TypeCon (Unqualified "tree") []+                          ]+                      ]+                      dummyLoc+                  ]+              ),+      testCase "parameterized type" $+        typeDefsOf ":- chr_type pair(A, B) ---> pair(A, B)."+          >>= ( @?=+                  [ algebraicTD+                      (Unqualified "pair")+                      ["A", "B"]+                      [ DataConstructor (Unqualified "pair") [TypeVar "A", TypeVar "B"]+                      ]+                      dummyLoc+                  ]+              ),+      testCase "list type with list sugar" $+        typeDefsOf ":- chr_type list(T) ---> [] ; [T | list(T)]."+          >>= ( @?=+                  [ algebraicTD+                      (Unqualified "list")+                      ["T"]+                      [ DataConstructor (Unqualified "[]") [],+                        DataConstructor+                          (Unqualified ".")+                          [ TypeVar "T",+                            TypeCon (Unqualified "list") [TypeVar "T"]+                          ]+                      ]+                      dummyLoc+                  ]+              ),+      testCase "type with nested type args" $+        typeDefsOf ":- chr_type nested ---> wrap(pair(int, int))."+          >>= ( @?=+                  [ algebraicTD+                      (Unqualified "nested")+                      []+                      [ DataConstructor+                          (Unqualified "wrap")+                          [ TypeCon+                              (Unqualified "pair")+                              [TypeCon (Unqualified "int") [], TypeCon (Unqualified "int") []]+                          ]+                      ]+                      dummyLoc+                  ]+              ),+      testCase "type decl doesn't affect constraint decls" $+        case p ":- chr_type t ---> a.\n:- chr_constraint c/1." of+          Left err -> assertFailure (show err)+          Right m -> do+            map (.node) m.decls @?= [ConstraintDecl "c" 1 Nothing Nothing]+            map (normalizeTypeDefLoc . (.node)) m.typeDecls+              @?= [ algebraicTD+                      (Unqualified "t")+                      []+                      [DataConstructor (Unqualified "a") []]+                      dummyLoc+                  ],+      testCase "multiple type decls" $+        typeDefsOf ":- chr_type a ---> x.\n:- chr_type b ---> y."+          >>= ( @?=+                  [ algebraicTD+                      (Unqualified "a")+                      []+                      [DataConstructor (Unqualified "x") []]+                      dummyLoc,+                    algebraicTD+                      (Unqualified "b")+                      []+                      [DataConstructor (Unqualified "y") []]+                      dummyLoc+                  ]+              ),+      testCase "opaque type with a parameter" $+        typeDefsOf ":- opaque_type set(X)."+          >>= ( @?=+                  [TypeDefinition (Unqualified "set") ["X"] Opaque dummyLoc]+              ),+      testCase "opaque type with no parameters" $+        typeDefsOf ":- opaque_type handle."+          >>= ( @?=+                  [TypeDefinition (Unqualified "handle") [] Opaque dummyLoc]+              ),+      testCase "opaque type with a constructor body is rejected" $+        pErrs ":- opaque_type set(X) ---> mk(X)."+          @?= Right [OpaqueTypeHasConstructors],+      testCase "opaque type exported with the shared type(...) form" $+        fmap (.node) . (.exports) <$> p ":- module(m, [type(set/1)])."+          @?= Right (Just [TypeExportDecl "set" 1 Nothing])+    ]++-- ---------------------------------------------------------------------------+-- Full module+-- ---------------------------------------------------------------------------++moduleTests :: TestTree+moduleTests =+  testGroup+    "full module"+    [ testCase "leq module" $+        stripModLoc <$> p leqSource+          @?= Right+            ( Module+                { name = "order",+                  nameLoc = dummyLoc,+                  imports = [],+                  decls = [noAnn (ConstraintDecl "leq" 2 Nothing Nothing)],+                  extensionTypes = [],+                  typeDecls = [],+                  rules =+                    [ Rule+                        (Just (noAnn "refl"))+                        ( noAnnP+                            ( Simplification+                                [ Constraint+                                    (Unqualified "leq")+                                    [VarTerm "X", VarTerm "X"]+                                ]+                            )+                        )+                        (noAnnP [])+                        (noAnnP [CompoundTerm (Unqualified "true") []]),+                      Rule+                        (Just (noAnn "antisymmetry"))+                        ( noAnnP+                            ( Simplification+                                [ Constraint+                                    (Unqualified "leq")+                                    [VarTerm "X", VarTerm "Y"],+                                  Constraint+                                    (Unqualified "leq")+                                    [VarTerm "Y", VarTerm "X"]+                                ]+                            )+                        )+                        (noAnnP [])+                        ( noAnnP+                            [ CompoundTerm+                                (Unqualified "leq")+                                [VarTerm "X", VarTerm "Y"]+                            ]+                        ),+                      Rule+                        (Just (noAnn "trans"))+                        ( noAnnP+                            ( Propagation+                                [ Constraint+                                    (Unqualified "leq")+                                    [VarTerm "X", VarTerm "Y"],+                                  Constraint+                                    (Unqualified "leq")+                                    [VarTerm "Y", VarTerm "Z"]+                                ]+                            )+                        )+                        (noAnnP [])+                        ( noAnnP+                            [ CompoundTerm+                                (Unqualified "leq")+                                [VarTerm "X", VarTerm "Z"]+                            ]+                        )+                    ],+                  equations = [],+                  extensions = [],+                  classExtensions = [],+                  exports = Just (noAnnP [])+                }+            ),+      testCase "no module directive gives default name" $+        (.name) <$> p ":- chr_constraint foo/1.\nfoo(X) <=> true."+          @?= Right "<no_module>",+      testCase "module/1 sets name and leaves exports unset" $+        case p ":- module(foo).\n:- chr_constraint c/1.\nc(X) <=> true." of+          Right m -> do+            m.name @?= "foo"+            m.exports @?= Nothing+          Left e -> assertFailure (show e)+    ]++leqSource :: Text+leqSource =+  Text.unlines+    [ ":- module(order, []).",+      ":- chr_constraint leq/2.",+      "",+      "refl @ leq(X, X) <=> true.",+      "antisymmetry @ leq(X, Y), leq(Y, X) <=> leq(X, Y).",+      "trans @ leq(X, Y), leq(Y, Z) ==> leq(X, Z)."+    ]++-- ---------------------------------------------------------------------------+-- Comments+-- ---------------------------------------------------------------------------++commentTests :: TestTree+commentTests =+  testGroup+    "comments"+    [ testCase "line comment before rule" $+        (map stripRuleLoc . (.rules)) <$> p "% a comment\nfoo <=> bar."+          @?= Right+            [ Rule+                Nothing+                ( noAnnP+                    ( Simplification+                        [ Constraint+                            (Unqualified "foo")+                            []+                        ]+                    )+                )+                (noAnnP [])+                (noAnnP [CompoundTerm (Unqualified "bar") []])+            ],+      testCase "inline comment after rule" $+        (map stripRuleLoc . (.rules)) <$> p "foo <=> bar. % comment"+          @?= Right+            [ Rule+                Nothing+                ( noAnnP+                    ( Simplification+                        [ Constraint+                            (Unqualified "foo")+                            []+                        ]+                    )+                )+                (noAnnP [])+                (noAnnP [CompoundTerm (Unqualified "bar") []])+            ],+      testCase "only comments parses to empty module" $+        (.rules) <$> p "% just a comment\n% another"+          @?= Right []+    ]++-- ---------------------------------------------------------------------------+-- Errors+-- ---------------------------------------------------------------------------++errorTests :: TestTree+errorTests =+  testGroup+    "errors"+    [ testCase "missing dot returns Left" $+        assertBool "expected parse failure" (isLeft (p "foo <=> bar")),+      testCase "invalid character returns Left" $+        assertBool "expected parse failure" (isLeft (p "!foo <=> bar.")),+      testCase "double underscore in unquoted atom is rejected" $+        assertBool "expected parse failure" (isLeft (p "foo__bar <=> true.")),+      testCase "double underscore in quoted atom is rejected" $+        assertBool "expected parse failure" (isLeft (p "'foo__bar' <=> true.")),+      testCase "double underscore in module name is rejected" $+        assertBool "expected parse failure" (isLeft (p ":- module(my__mod, []).")),+      testCase "single underscore in atom is allowed" $+        assertBool "expected parse success" (not (isLeft (p "foo_bar <=> true.")))+    ]++-- ---------------------------------------------------------------------------+-- First-pass module-header collector+-- ---------------------------------------------------------------------------++-- | Helper: collect operators from a module header.+ops :: Text -> Either (ParseError) [OpDecl]+ops src = (.exportOps) <$> collectModuleHeader "" src++-- | Helper: collect imports from a module header.+hdrImports :: Text -> Either (ParseError) [Import]+hdrImports src = map (.node) . (.headerImports) <$> collectModuleHeader "" src++firstPassTests :: TestTree+firstPassTests =+  testGroup+    "first-pass module-header collector"+    [ testCase "extracts operators from export list" $+        ops ":- module(m, [op(500, yfx, '+')])." @?= Right [OpDecl 500 Yfx "+"],+      testCase "skips name/arity entries" $+        ops ":- module(m, [leq/2, op(700, xfx, '<')])." @?= Right [OpDecl 700 Xfx "<"],+      testCase "skips type exports" $+        ops ":- module(m, [type(bool/0), op(500, yfx, '+')])." @?= Right [OpDecl 500 Yfx "+"],+      testCase "type export among many entries" $+        ops ":- module(m, [leq/2, type(tree/0), op(400, yfx, '*'), type(list/1)])."+          @?= Right+            [OpDecl 400 Yfx "*"],+      testCase "no module directive returns empty exports" $+        ops ":- chr_constraint leq/2." @?= Right [],+      testCase "empty export list returns empty" $+        ops ":- module(m, [])." @?= Right [],+      testCase "collects use_module imports right after the module directive" $+        hdrImports ":- module(m, []). :- use_module(foo). :- use_module(library(bar))."+          @?= Right [ModuleImport "foo" Nothing, LibraryImport "bar" Nothing],+      testCase "stops collecting imports at the first non-import directive" $+        hdrImports+          ( ":- module(m, []). :- use_module(foo). "+              <> ":- chr_constraint c/1. :- use_module(bar)."+          )+          @?= Right [ModuleImport "foo" Nothing],+      testCase "import lists with op() entries parse" $+        hdrImports ":- module(m, []). :- use_module(foo, [op(700, xfx, '<-')])."+          @?= Right [ModuleImport "foo" (Just [OperatorDecl (OpDecl 700 Xfx "<-")])],+      testCase "skips fun name/arity entries" $+        ops ":- module(m, [fun double/1, op(500, yfx, '+')])." @?= Right [OpDecl 500 Yfx "+"],+      testCase "fun name/arity and name/arity coexist in export list" $+        ops ":- module(m, [leq/2, fun double/1, op(700, xfx, '<')])."+          @?= Right+            [ OpDecl+                700+                Xfx+                "<"+            ]+    ]++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++typeDefsOf :: Text -> IO [TypeDefinition]+typeDefsOf src = case p src of+  Left err -> assertFailure (show err)+  Right m -> pure (map (normalizeTypeDefLoc . (.node)) m.typeDecls)++-- | Build an algebraic type definition positionally (the constructors+-- are wrapped in the 'Algebraic' 'TypeKind').+algebraicTD :: Name -> [Text] -> [DataConstructor] -> SourceLoc -> TypeDefinition+algebraicTD n vs cs loc = TypeDefinition n vs (Algebraic cs) loc++-- | Strip the source location from a parsed 'TypeDefinition' so test+-- expected values can omit line/column numbers.+normalizeTypeDefLoc :: TypeDefinition -> TypeDefinition+normalizeTypeDefLoc td =+  TypeDefinition+    { name = td.name,+      typeVars = td.typeVars,+      kind = td.kind,+      loc = dummyLoc+    }++bodyOf :: Text -> IO [Term]+bodyOf src = case p src of+  Left err -> assertFailure (show err)+  Right m -> case m.rules of+    [] -> assertFailure "expected at least one rule, got none"+    (r : _) -> pure r.body.node++-- | Like 'bodyOf', but parses with @<@ added as a 700 xfx operator so+-- precedence interactions between @is@\/@=@ and a comparison can be tested+-- without pulling in the whole prelude.+bodyOfWithLt :: Text -> IO [Term]+bodyOfWithLt src = case mergeOps builtinOps [OpDecl 700 Xfx "<"] of+  Left e -> assertFailure ("mergeOps failed: " <> Text.unpack e)+  Right table -> case fst <$> parseModuleWith table "" src of+    Left err -> assertFailure (show err)+    Right m -> case m.rules of+      [] -> assertFailure "expected at least one rule, got none"+      (r : _) -> pure r.body.node++headOf :: Text -> IO Head+headOf src = case p src of+  Left err -> assertFailure (show err)+  Right m -> case m.rules of+    [] -> assertFailure "expected at least one rule, got none"+    (r : _) -> pure r.head.node++guardOf :: Text -> IO [Term]+guardOf src = case p src of+  Left err -> assertFailure (show err)+  Right m -> case m.rules of+    [] -> assertFailure "expected at least one rule, got none"+    (r : _) -> pure r.guard.node
+ test/YCHR/PrettyTest.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.PrettyTest (tests) where++import Data.Map.Strict qualified as Map+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import YCHR.Internal.Pretty (prettyBindings, prettyQueryResult, prettyTerm, renderAtom)+import YCHR.Internal.Types (Name (..), Term (..))++tests :: TestTree+tests =+  testGroup+    "YCHR.Internal.Pretty"+    [ basicTests,+      renderAtomTests,+      listRenderingTests,+      closureUnwrapTests,+      bindingsTests+    ]++basicTests :: TestTree+basicTests =+  testGroup+    "prettyTerm basics"+    [ testCase "IntTerm" $+        prettyTerm (IntTerm 42) @?= "42",+      testCase "AtomTerm" $+        prettyTerm (CompoundTerm (Unqualified "foo") []) @?= "foo",+      testCase "VarTerm renders its name" $+        prettyTerm (VarTerm "X") @?= "X",+      testCase "Wildcard" $+        prettyTerm Wildcard @?= "_",+      testCase "CompoundTerm unqualified" $+        prettyTerm+          ( CompoundTerm+              (Unqualified "f")+              [IntTerm 1, CompoundTerm (Unqualified "a") []]+          )+          @?= "f(1, a)",+      testCase "CompoundTerm qualified" $+        prettyTerm (CompoundTerm (Qualified "m" "f") [IntTerm 1])+          @?= "m:f(1)",+      testCase "nested compound" $+        prettyTerm+          ( CompoundTerm+              (Unqualified "f")+              [CompoundTerm (Unqualified "g") [IntTerm 0]]+          )+          @?= "f(g(0))",+      -- Negative integers render with parentheses so e.g. binding output+      -- like @R = (-2)@ parses back as a single term rather than a+      -- subtraction expression. (Verified by an existing golden test,+      -- but pinned here at the unit level too.)+      testCase "negative integer is parenthesized" $+        prettyTerm (IntTerm (-2)) @?= "(-2)",+      testCase "negative float is parenthesized" $+        prettyTerm (FloatTerm (-1.5)) @?= "(-1.5)",+      testCase "TextTerm renders with surrounding quotes" $+        prettyTerm (TextTerm "hello") @?= "\"hello\"",+      testCase "TextTerm escapes embedded quotes/backslashes/newlines" $+        prettyTerm (TextTerm "a\"b\\c\n") @?= "\"a\\\"b\\\\c\\n\""+    ]++renderAtomTests :: TestTree+renderAtomTests =+  testGroup+    "renderAtom quoting"+    [ testCase "lowercase identifier stays bare" $+        renderAtom "foo" @?= "foo",+      testCase "lowercase with digits and underscore stays bare" $+        renderAtom "foo_bar2" @?= "foo_bar2",+      testCase "empty atom is quoted" $+        renderAtom "" @?= "''",+      testCase "uppercase-first is quoted" $+        renderAtom "Foo" @?= "'Foo'",+      testCase "leading underscore is quoted" $+        renderAtom "_foo" @?= "'_foo'",+      testCase "atom with embedded space is quoted" $+        renderAtom "hello world" @?= "'hello world'",+      testCase "atom with apostrophe is quoted, apostrophe doubled" $+        renderAtom "hello's" @?= "'hello''s'",+      testCase "word operator 'is' is quoted (would otherwise parse as op)" $+        renderAtom "is" @?= "'is'",+      -- The flattened-qualified marker '__' triggers quoting so that+      -- internal names like @prelude__.@ don't accidentally render as+      -- bare atoms that the parser would re-tokenize.+      testCase "atom containing '__' is quoted" $+        renderAtom "foo__bar" @?= "'foo__bar'"+    ]++listRenderingTests :: TestTree+listRenderingTests =+  testGroup+    "list canonicalization"+    [ testCase "canonical nil renders as []" $+        prettyTerm (CompoundTerm (Unqualified "prelude__[]") []) @?= "[]",+      testCase "single-element list" $+        prettyTerm (cons (IntTerm 1) nil) @?= "[1]",+      testCase "proper multi-element list" $+        prettyTerm (cons (IntTerm 1) (cons (IntTerm 2) (cons (IntTerm 3) nil)))+          @?= "[1, 2, 3]",+      testCase "nested lists" $+        prettyTerm+          ( cons+              (IntTerm 1)+              ( cons+                  (cons (IntTerm 2) (cons (IntTerm 3) nil))+                  nil+              )+          )+          @?= "[1, [2, 3]]",+      testCase "improper list with variable tail" $+        prettyTerm (cons (IntTerm 1) (VarTerm "T")) @?= "[1 | T]",+      testCase "improper list with atom tail" $+        prettyTerm (cons (IntTerm 1) (CompoundTerm (Unqualified "foo") [])) @?= "[1 | foo]"+    ]+  where+    nil = CompoundTerm (Unqualified "prelude__[]") []+    cons h t = CompoundTerm (Unqualified "prelude__.") [h, t]++closureUnwrapTests :: TestTree+closureUnwrapTests =+  testGroup+    "closure unwrapping"+    [ -- A closure value is a compound @__closure(name, sourceForm, ...captures)@.+      -- prettyTerm should show the user-visible source form, not the+      -- internal closure functor.+      testCase "closure renders its source form" $+        let source =+              CompoundTerm+                (Unqualified "->")+                [ CompoundTerm (Unqualified "fun") [CompoundTerm (Unqualified "X") []],+                  CompoundTerm (Unqualified "+") [CompoundTerm (Unqualified "X") [], IntTerm 1]+                ]+            closure =+              CompoundTerm+                (Unqualified "__closure")+                [CompoundTerm (Unqualified "__lambda_0") [], source]+         in prettyTerm closure @?= "fun(X) -> X + 1 end",+      -- 'unquoteToPExpr' turns atoms whose name looks like a variable+      -- (uppercase-first or leading underscore) back into variables —+      -- that's how a captured variable reference inside a closure body+      -- gets rendered as a variable rather than a quoted atom.+      testCase "closure body atoms that look like vars render as vars" $+        let source =+              CompoundTerm+                (Unqualified "->")+                [ CompoundTerm (Unqualified "fun") [CompoundTerm (Unqualified "X") []],+                  CompoundTerm (Unqualified "X") []+                ]+            closure =+              CompoundTerm+                (Unqualified "__closure")+                [CompoundTerm (Unqualified "__lambda_1") [], source]+         in prettyTerm closure @?= "fun(X) -> X end"+    ]++bindingsTests :: TestTree+bindingsTests =+  testGroup+    "binding-map formatting"+    [ testCase "prettyBindings sorted with trailing newline" $+        prettyBindings (Map.fromList [("R", IntTerm 55), ("X", Wildcard)])+          @?= "R = 55\nX = _\n",+      testCase "prettyBindings empty" $+        prettyBindings Map.empty @?= "",+      testCase "prettyQueryResult empty map is empty string" $+        prettyQueryResult Map.empty @?= "",+      -- Underscored names are internal/wildcard; filtering them out+      -- can leave the visible set empty even when the raw map is not.+      testCase "prettyQueryResult all-underscore map is empty string" $+        prettyQueryResult (Map.fromList [("_X", IntTerm 1), ("_Y", Wildcard)])+          @?= "",+      testCase "prettyQueryResult single binding ends with dot+newline" $+        prettyQueryResult (Map.fromList [("R", IntTerm 7)])+          @?= "R = 7.\n",+      testCase "prettyQueryResult multi-binding uses comma between, dot at end" $+        prettyQueryResult+          ( Map.fromList+              [ ("X", IntTerm 1),+                ("Y", CompoundTerm (Unqualified "ok") []),+                ("Z", Wildcard)+              ]+          )+          @?= "X = 1,\nY = ok,\nZ = _.\n",+      testCase "prettyQueryResult filters underscored names from a mixed map" $+        prettyQueryResult+          ( Map.fromList+              [ ("R", IntTerm 42),+                ("_internal", CompoundTerm (Unqualified "hidden") [])+              ]+          )+          @?= "R = 42.\n"+    ]
+ test/YCHR/RenameTest.hs view
@@ -0,0 +1,1373 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.RenameTest (tests) where++import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+-- Brings 'CollectedModule''s field labels into scope (qualified) so that+-- record-dot access on renamer outputs (e.g. @renamed.rules@) resolves+-- via HasField, without their unqualified names clashing with the+-- identically-named 'Module' labels used in parsed-module record updates.++import YCHR.DSL+import YCHR.Internal.Collect (rewriteImports)+import YCHR.Internal.Collected (CollectedModule)+import YCHR.Internal.Collected qualified as C+import YCHR.Internal.Diagnostic (Diagnostic (..), noDiag)+import YCHR.Internal.PExpr (PExpr (Atom))+import YCHR.Internal.Parsed+import YCHR.Internal.Rename+  ( RenameError (..),+    RenameInputs (..),+    RenameWarning (..),+    defaultRenameInputs,+  )+import YCHR.Internal.Rename qualified as Rn++-- | Test-local wrapper that forwards to 'Rn.renameProgram' with empty+-- rename inputs (no operator-export map and no trailing-loc map). It+-- also runs 'rewriteImports' so tests can build plain parsed 'Module's+-- with the DSL while the renamer consumes 'CollectedModule's (as it+-- does in the real pipeline). The module-list-only signature keeps+-- existing tests concise.+renameProgram ::+  [Module] ->+  Either+    [Diagnostic RenameError]+    ( [CollectedModule],+      [Diagnostic RenameWarning]+    )+renameProgram = Rn.renameProgram defaultRenameInputs . rewriteImports++-- | Build an algebraic type definition positionally (the constructors+-- are wrapped in the 'Algebraic' 'TypeKind').+algebraicTD :: Name -> [Text] -> [DataConstructor] -> SourceLoc -> TypeDefinition+algebraicTD n vs cs loc = TypeDefinition n vs (Algebraic cs) loc++tests :: TestTree+tests =+  testGroup+    "Rename"+    [ sameModuleTests,+      importedTests,+      ambiguousTests,+      ambiguousDataConTests,+      unknownTests,+      alreadyQualifiedTests,+      goalClassificationTests,+      headTypeTests,+      multiModuleTests,+      reservedSymbolTests,+      exportTests,+      warningTests,+      importListTests+    ]++-- | Rename a single-module program and return the single renamed rule.+singleRule :: Module -> IO Rule+singleRule m = do+  renamed <- case renameProgram [m] of+    Right ([r], _) -> return r+    Right (mods, _) -> assertFailure $ "expected 1 renamed module, got " ++ show (length mods)+    Left errs -> assertFailure $ "unexpected errors: " ++ show errs+  case renamed.rules of+    [rule] -> return rule+    rules -> assertFailure $ "expected 1 rule, got " ++ show (length rules)++--------------------------------------------------------------------------------+-- same-module: constraints declared in the current module get its qualifier+--------------------------------------------------------------------------------++sameModuleTests :: TestTree+sameModuleTests =+  testGroup+    "same-module"+    [ testCase "head constraint qualified with own module" $ do+        let m =+              module' "M"+                `declaring` ["leq" // 2]+                `defining` [[term "leq" [var "X", var "Y"]] <=> [atom "true"]]+        rule <- singleRule m+        rule.head.node+          @?= Simplification [Constraint (Qualified "M" "leq") [VarTerm "X", VarTerm "Y"]],+      testCase "zero-arity constraint" $ do+        let m =+              module' "M"+                `declaring` ["done" // 0]+                `defining` [[term "done" []] <=> [atom "true"]]+        rule <- singleRule m+        rule.head.node+          @?= Simplification [Constraint (Qualified "M" "done") []],+      testCase "body goal in own module" $ do+        let m =+              module' "M"+                `declaring` ["leq" // 2]+                `defining` [ [term "leq" [var "X", var "Y"]]+                               ==> [term "leq" [var "X", var "Z"]]+                           ]+        rule <- singleRule m+        rule.body.node+          @?= [CompoundTerm (Qualified "M" "leq") [VarTerm "X", VarTerm "Z"]]+    ]++--------------------------------------------------------------------------------+-- imported: constraints from imported modules get the declaring module's qualifier+--------------------------------------------------------------------------------++importedTests :: TestTree+importedTests =+  testGroup+    "imported"+    [ testCase "head and body via import" $ do+        let modOrder = module' "Order" `declaring` ["leq" // 2]+            modLogic =+              module' "Logic"+                `importing` ["Order"]+                `defining` [ [term "leq" [var "X", var "Y"], term "leq" [var "Y", var "Z"]]+                               ==> [term "leq" [var "X", var "Z"]]+                           ]+        (_, renamedLogic) <- case renameProgram [modOrder, modLogic] of+          Right ([a, b], _) -> return (a, b)+          Right (mods, _) -> assertFailure $ "expected 2 modules, got " ++ show (length mods)+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs+        rule <- case renamedLogic.rules of+          [r] -> return r+          rules -> assertFailure $ "expected 1 rule, got " ++ show (length rules)+        (rule.head.node, rule.body.node)+          @?= ( Propagation+                  [ Constraint (Qualified "Order" "leq") [VarTerm "X", VarTerm "Y"],+                    Constraint (Qualified "Order" "leq") [VarTerm "Y", VarTerm "Z"]+                  ],+                [CompoundTerm (Qualified "Order" "leq") [VarTerm "X", VarTerm "Z"]]+              ),+      testCase "imports are not transitive" $ do+        -- A declares leq/2; B imports A; C imports B (not A)+        -- C cannot see leq/2 because A is not in C's visible set+        let modA = module' "A" `declaring` ["leq" // 2]+            modB = module' "B" `importing` ["A"]+            modC =+              module' "C"+                `importing` ["B"]+                `defining` [[term "leq" [var "X", var "Y"]] <=> [atom "true"]]+        renameProgram [modA, modB, modC]+          @?= Left [noDiag (AnnP (UnknownName "leq" 2) dummyLoc (Atom ""))]+    ]++--------------------------------------------------------------------------------+-- ambiguous: multiple visible providers -> AmbiguousName error+--------------------------------------------------------------------------------++ambiguousTests :: TestTree+ambiguousTests =+  testGroup+    "ambiguous"+    [ testCase "own + imported both declare same name" $ do+        let modA = module' "A" `declaring` ["leq" // 2]+            modB =+              module' "B"+                `importing` ["A"]+                `declaring` ["leq" // 2]+                `defining` [[term "leq" [var "X", var "Y"]] <=> [atom "true"]]+        renameProgram [modA, modB]+          @?= Left [noDiag (AnnP (AmbiguousName "leq" 2 ["B", "A"]) dummyLoc (Atom ""))],+      testCase "two imports declare same name" $ do+        let modA = module' "A" `declaring` ["leq" // 2]+            modB = module' "B" `declaring` ["leq" // 2]+            modC =+              module' "C"+                `importing` ["A", "B"]+                `defining` [[term "leq" [var "X", var "Y"]] <=> [atom "true"]]+        case renameProgram [modA, modB, modC] of+          Left [Diagnostic _ (AnnP (AmbiguousName "leq" 2 _) _ _)] -> pure ()+          other -> assertFailure $ "expected AmbiguousName error, got " ++ show other,+      testCase "ambiguous function used as a body-tell constraint argument" $ do+        -- The bare 'f(1)' lands in 'NoResolve' (demoted from the+        -- 'ResolveTop' parent 'c(...)'). Previously this was the silent+        -- 'otherwise -> pure ()' branch — 'Resolve.termToExpr' would+        -- fall through to 'CtorExpr' with no diagnostic at any stage.+        -- The renamer now mirrors 'resolveName''s multi-provider arm+        -- so the user gets the same YCHR-20001 diagnostic they would+        -- in a guard or 'is'-RHS position.+        let modA = module' "A" `declaring` [function "f" 1]+            modB = module' "B" `declaring` [function "f" 1]+            modC =+              module' "C"+                `importing` ["A", "B"]+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [term "c" [term "f" [int 1]]]+                           ]+        case renameProgram [modA, modB, modC] of+          Left [Diagnostic _ (AnnP (AmbiguousName "f" 1 _) _ _)] -> pure ()+          other -> assertFailure $ "expected AmbiguousName error, got " ++ show other,+      testCase "ambiguous function on '=' operand" $ do+        -- '=' no longer has a special arm that routed operands to+        -- 'ResolveAll' (the lambda workaround). Operands inherit+        -- 'NoResolve' from the 'ResolveTop' body, so the multi-provider+        -- check has to live in 'NoResolve' itself; this case locks in+        -- that the diagnostic that the workaround used to surface still+        -- fires under the uniform path.+        let modA = module' "A" `declaring` [function "f" 1]+            modB = module' "B" `declaring` [function "f" 1]+            modC =+              module' "C"+                `importing` ["A", "B"]+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [var "R" .=. term "f" [int 1]]+                           ]+        case renameProgram [modA, modB, modC] of+          Left [Diagnostic _ (AnnP (AmbiguousName "f" 1 _) _ _)] -> pure ()+          other -> assertFailure $ "expected AmbiguousName error, got " ++ show other,+      testCase "ambiguous compound nested inside a head-pattern argument" $ do+        -- The constraint functor itself (the outer 'c') resolves via+        -- 'renameCon' → 'resolveName ResolveTop', which has always+        -- diagnosed multi-provider. The compound /inside/ the head arg+        -- ('f(X)' below) is renamed in 'NoResolve' via 'renameTerm';+        -- previously that arm silently accepted multi-provider names.+        -- The 'NoResolve' multi-provider arm now diagnoses it.+        let modA = module' "A" `declaring` [function "f" 1]+            modB = module' "B" `declaring` [function "f" 1]+            modC =+              module' "C"+                `importing` ["A", "B"]+                `declaring` ["c" // 1]+                `defining` [ [term "c" [term "f" [var "X"]]]+                               <=> [atom "true"]+                           ]+        case renameProgram [modA, modB, modC] of+          Left [Diagnostic _ (AnnP (AmbiguousName "f" 1 _) _ _)] -> pure ()+          other -> assertFailure $ "expected AmbiguousName error, got " ++ show other,+      testCase "ambiguous compound in a function-equation pattern" $ do+        -- 'renameEquation' renames the equation's argument patterns in+        -- 'NoResolve'. A multi-provider name used as a pattern functor+        -- there has the same downstream gap (silent 'CtorExpr' fall-+        -- through) as in body-tell args; lock the diagnostic in.+        let modA = module' "A" `declaring` [function "f" 1]+            modB = module' "B" `declaring` [function "f" 1]+            modC =+              ( module' "C"+                  `importing` ["A", "B"]+                  `declaring` [function "g" 1]+              )+                `withEquations` [equation "g" [term "f" [var "X"]] [] (var "X")]+        case renameProgram [modA, modB, modC] of+          Left [Diagnostic _ (AnnP (AmbiguousName "f" 1 _) _ _)] -> pure ()+          other -> assertFailure $ "expected AmbiguousName error, got " ++ show other,+      testCase "ambiguous zero-arity atom in 'NoResolve' position" $ do+        -- Companion to the compound cases for the 'AtomTerm' arm.+        -- A bare 'f' inside a tell-side constraint argument lands in+        -- 'NoResolve'; if two modules export 'f/0' as a function, the+        -- atom arm now emits 'AmbiguousName' instead of silently+        -- producing an 'AtomTerm' that 'Resolve.termToExpr' can't+        -- disambiguate.+        let modA = module' "A" `declaring` [function "f" 0]+            modB = module' "B" `declaring` [function "f" 0]+            modC =+              module' "C"+                `importing` ["A", "B"]+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [term "c" [atom "f"]]+                           ]+        case renameProgram [modA, modB, modC] of+          Left [Diagnostic _ (AnnP (AmbiguousName "f" 0 _) _ _)] -> pure ()+          other -> assertFailure $ "expected AmbiguousName error, got " ++ show other+    ]++--------------------------------------------------------------------------------+-- ambiguous data constructors: multiple visible providers ->+-- AmbiguousDataConstructor (YCHR-20012). Parallel to 'ambiguousTests'+-- but for the constructor namespace, which carries no arity (data+-- constructors are not arity-overloadable).+--------------------------------------------------------------------------------++ambiguousDataConTests :: TestTree+ambiguousDataConTests =+  testGroup+    "ambiguous data constructor"+    [ testCase "two imports both export a nullary constructor 'foo'" $ do+        let modA = modWithCtor "A" "foo" []+            modB = modWithCtor "B" "foo" []+            modC =+              ( module' "C"+                  `importing` ["A", "B"]+                  `declaring` ["r" // 1]+                  `defining` [[term "r" [var "R"]] <=> [var "R" .=. atom "foo"]]+              )+        case renameProgram [modA, modB, modC] of+          Left [Diagnostic _ (AnnP (AmbiguousDataConstructor "foo" _) _ _)] ->+            pure ()+          other ->+            assertFailure $+              "expected AmbiguousDataConstructor error, got " ++ show other,+      testCase "two imports both export a unary constructor 'foo'" $ do+        let modA = modWithCtor "A" "foo" [TypeCon (Unqualified "int") []]+            modB = modWithCtor "B" "foo" [TypeCon (Unqualified "int") []]+            modC =+              ( module' "C"+                  `importing` ["A", "B"]+                  `declaring` ["r" // 1]+                  `defining` [ [term "r" [var "R"]]+                                 <=> [var "R" .=. term "foo" [IntTerm 42]]+                             ]+              )+        case renameProgram [modA, modB, modC] of+          Left [Diagnostic _ (AnnP (AmbiguousDataConstructor "foo" _) _ _)] ->+            pure ()+          other ->+            assertFailure $+              "expected AmbiguousDataConstructor error, got " ++ show other+    ]+  where+    -- Empty module that declares a single type @t/0@ with one+    -- constructor @ctor@ at the given argument shape.+    modWithCtor modName ctor argTypes =+      (module' modName)+        { typeDecls =+            [ noAnn+                ( algebraicTD+                    (Unqualified "t")+                    []+                    [DataConstructor (Unqualified ctor) argTypes]+                    dummyLoc+                )+            ]+        }++--------------------------------------------------------------------------------+-- unknown: no visible provider -> UnknownName error+--------------------------------------------------------------------------------++unknownTests :: TestTree+unknownTests =+  testGroup+    "unknown"+    [ testCase "undeclared constraint" $ do+        let m =+              module' "M"+                `defining` [[term "foo" [var "X"]] <=> [atom "true"]]+        renameProgram [m]+          @?= Left [noDiag (AnnP (UnknownName "foo" 1) dummyLoc (Atom ""))],+      testCase "wrong arity" $ do+        -- leq/3 is declared but leq/2 is used: key ("leq",2) absent in env+        let m =+              module' "M"+                `declaring` ["leq" // 3]+                `defining` [[term "leq" [var "X", var "Y"]] <=> [atom "true"]]+        renameProgram [m]+          @?= Left [noDiag (AnnP (UnknownName "leq" 2) dummyLoc (Atom ""))],+      testCase "host call in body" $ do+        let m =+              module' "M"+                `declaring` ["c" // 0]+                `defining` [[term "c" []] <=> [hostCall "some_host_func" [var "X"]]]+        rule <- singleRule m+        rule.body.node+          @?= [CompoundTerm (Qualified "host" "some_host_func") [VarTerm "X"]]+    ]++--------------------------------------------------------------------------------+-- already-qualified: Qualified names pass through resolveName unchanged+--------------------------------------------------------------------------------++alreadyQualifiedTests :: TestTree+alreadyQualifiedTests =+  testGroup+    "already-qualified"+    [ testCase "pre-qualified head constraint passes through unchanged" $ do+        let modOrder = module' "Order" `declaring` ["leq" // 2]+            modM =+              module' "M"+                `importing` ["Order"]+                `defining` [[qterm "Order" "leq" [var "X", var "Y"]] <=> [atom "true"]]+        (_, renamedM) <- case renameProgram [modOrder, modM] of+          Right ([a, b], _) -> return (a, b)+          Right (mods, _) -> assertFailure $ "expected 2 modules, got " ++ show (length mods)+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs+        rule <- case renamedM.rules of+          [r] -> return r+          rules -> assertFailure $ "expected 1 rule, got " ++ show (length rules)+        rule.head.node+          @?= Simplification [Constraint (Qualified "Order" "leq") [VarTerm "X", VarTerm "Y"]],+      testCase "pre-qualified reference to non-existent module produces error" $ do+        -- Module 'Order' does not exist anywhere in the program.+        let m =+              module' "M"+                `defining` [[qterm "Order" "leq" [var "X", var "Y"]] <=> [atom "true"]]+        renameProgram [m]+          @?= Left [noDiag (AnnP (UnknownModule "Order") dummyLoc (Atom ""))],+      testCase "pre-qualified survives ambiguity" $ do+        -- Two visible providers, but the constraint is already Qualified+        let modA = module' "A" `declaring` ["leq" // 2]+            modB = module' "B" `declaring` ["leq" // 2]+            modC =+              module' "C"+                `importing` ["A", "B"]+                `defining` [[qterm "A" "leq" [var "X", var "Y"]] <=> [atom "true"]]+        renamedC <- case renameProgram [modA, modB, modC] of+          Right ([_, _, c], _) -> return c+          Right (mods, _) -> assertFailure $ "expected 3 modules, got " ++ show (length mods)+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs+        rule <- case renamedC.rules of+          [r] -> return r+          rules -> assertFailure $ "expected 1 rule, got " ++ show (length rules)+        rule.head.node+          @?= Simplification [Constraint (Qualified "A" "leq") [VarTerm "X", VarTerm "Y"]],+      testCase "pre-qualified reference to non-imported module is rejected" $ do+        -- A declares leq/2 but B does not import A; the qualification+        -- must not silently bypass the visibility rules.+        let modA = module' "A" `declaring` ["leq" // 2]+            modB =+              module' "B"+                `defining` [[qterm "A" "leq" [var "X", var "Y"]] <=> [atom "true"]]+        renameProgram [modA, modB]+          @?= Left [noDiag (AnnP (ModuleNotImported "A" "leq" 2) dummyLoc (Atom ""))],+      testCase "pre-qualified reference to non-exported name is rejected" $ do+        -- A declares leq/2 and gt/2 but only exports leq/2. B imports A+        -- and tries to reach gt/2 via qualification; still hidden.+        let modA =+              module' "A"+                `declaring` ["leq" // 2, "gt" // 2]+                `exporting` ["leq" // 2]+            modB =+              module' "B"+                `importing` ["A"]+                `defining` [[qterm "A" "gt" [var "X", var "Y"]] <=> [atom "true"]]+        renameProgram [modA, modB]+          @?= Left [noDiag (AnnP (NotExportedByModule "A" "gt" 2) dummyLoc (Atom ""))]+    ]++--------------------------------------------------------------------------------+-- goal-classification: isGoal controls whether compound terms are resolved+--------------------------------------------------------------------------------++goalClassificationTests :: TestTree+goalClassificationTests =+  testGroup+    "goal-classification"+    [ testCase "guard functor IS resolved" $ do+        -- Guards use ResolveAll, so compound terms are looked up+        let m =+              module' "M"+                `declaring` ["leq" // 2]+                `defining` [ ([term "leq" [var "X", var "Y"]] <=> [atom "true"])+                               |- [term "leq" [var "X", var "Y"]]+                           ]+        rule <- singleRule m+        rule.guard.node+          @?= [CompoundTerm (Qualified "M" "leq") [VarTerm "X", VarTerm "Y"]],+      testCase "body functor IS resolved" $ do+        -- Body uses isGoal = True, so compound terms are looked up+        let m =+              module' "M"+                `declaring` ["leq" // 2]+                `defining` [ [term "leq" [var "X", var "Y"]]+                               ==> [term "leq" [var "X", var "Z"]]+                           ]+        rule <- singleRule m+        rule.body.node+          @?= [CompoundTerm (Qualified "M" "leq") [VarTerm "X", VarTerm "Z"]],+      testCase "nested arg of head NOT resolved" $ do+        -- Head args use isGoal = False: inner functor stays Unqualified+        let m =+              module' "M"+                `declaring` ["wrap" // 1, "inner" // 1]+                `defining` [[term "wrap" [term "inner" [var "X"]]] <=> [atom "true"]]+        rule <- singleRule m+        rule.head.node+          @?= Simplification+            [ Constraint+                (Qualified "M" "wrap")+                [CompoundTerm (Unqualified "inner") [VarTerm "X"]]+            ],+      testCase "nested arg of body goal NOT resolved" $ do+        -- Outer functor is resolved (isGoal = True), inner is not (args use isGoal = False)+        let m =+              module' "M"+                `declaring` ["c" // 0, "leq" // 1, "pair" // 1]+                `defining` [[term "c" []] ==> [term "leq" [term "pair" [var "X"]]]]+        rule <- singleRule m+        rule.body.node+          @?= [ CompoundTerm+                  (Qualified "M" "leq")+                  [ CompoundTerm+                      (Unqualified "pair")+                      [ VarTerm+                          "X"+                      ]+                  ]+              ],+      testCase "unknown functor in guard stays Unqualified (data constructor)" $ do+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ ([term "c" [var "X"]] <=> [atom "true"])+                               |- [term "." [var "H", var "T"]]+                           ]+        rule <- singleRule m+        rule.guard.node+          @?= [CompoundTerm (Unqualified ".") [VarTerm "H", VarTerm "T"]],+      testCase "unknown functor in is RHS stays Unqualified (data constructor)" $ do+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [var "R" `is` term "pair" [var "X", int 1]]+                           ]+        rule <- singleRule m+        rule.body.node+          @?= [ CompoundTerm+                  (Unqualified "is")+                  [VarTerm "R", CompoundTerm (Unqualified "pair") [VarTerm "X", IntTerm 1]]+              ],+      testCase "non-compound terms in guard untouched" $ do+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ ([term "c" [var "X"]] <=> [atom "true"])+                               |- [var "X", atom "zero", IntTerm 42]+                           ]+        rule <- singleRule m+        rule.guard.node+          @?= [VarTerm "X", CompoundTerm (Unqualified "zero") [], IntTerm 42],+      testCase "non-compound terms in body untouched" $ do+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [[term "c" [var "X"]] <=> [var "X", atom "zero", IntTerm 42]]+        rule <- singleRule m+        rule.body.node+          @?= [VarTerm "X", CompoundTerm (Unqualified "zero") [], IntTerm 42],+      testCase "zero-arity atom in body promoted to constraint" $ do+        let m =+              module' "M"+                `declaring` ["c" // 1, "done" // 0]+                `defining` [[term "c" [var "X"]] <=> [atom "done"]]+        rule <- singleRule m+        rule.body.node+          @?= [CompoundTerm (Qualified "M" "done") []],+      testCase "zero-arity atom in guard promoted to constraint" $ do+        let m =+              module' "M"+                `declaring` ["c" // 1, "ready" // 0]+                `defining` [ ([term "c" [var "X"]] <=> [atom "true"])+                               |- [atom "ready"]+                           ]+        rule <- singleRule m+        rule.guard.node+          @?= [CompoundTerm (Qualified "M" "ready") []],+      testCase "undeclared atom in body stays as AtomTerm" $ do+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [[term "c" [var "X"]] <=> [atom "hello"]]+        rule <- singleRule m+        rule.body.node+          @?= [CompoundTerm (Unqualified "hello") []],+      testCase "undeclared atom in guard stays as AtomTerm" $ do+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ ([term "c" [var "X"]] <=> [atom "true"])+                               |- [atom "hello"]+                           ]+        rule <- singleRule m+        rule.guard.node+          @?= [CompoundTerm (Unqualified "hello") []],+      testCase "zero-arity atom in head arg stays as AtomTerm (NoResolve)" $ do+        let m =+              module' "M"+                `declaring` ["c" // 1, "done" // 0]+                `defining` [[term "c" [atom "done"]] <=> [atom "true"]]+        rule <- singleRule m+        rule.head.node+          @?= Simplification+            [ Constraint+                (Qualified "M" "c")+                [CompoundTerm (Unqualified "done") []]+            ]+    ]++--------------------------------------------------------------------------------+-- head-types: all three Head constructors are renamed+--------------------------------------------------------------------------------++headTypeTests :: TestTree+headTypeTests =+  testGroup+    "head-types"+    [ testCase "Propagation" $ do+        let m =+              module' "M"+                `declaring` ["leq" // 2]+                `defining` [[term "leq" [var "X", var "Y"]] ==> [atom "true"]]+        rule <- singleRule m+        rule.head.node+          @?= Propagation [Constraint (Qualified "M" "leq") [VarTerm "X", VarTerm "Y"]],+      testCase "Simpagation kept and removed both renamed" $ do+        let m =+              module' "M"+                `declaring` ["leq" // 2, "gt" // 2]+                `defining` [ [term "leq" [var "X", var "Y"]]+                               \\ [term "gt" [var "X", var "Y"]]+                               <=> [atom "true"]+                           ]+        rule <- singleRule m+        rule.head.node+          @?= Simpagation+            [Constraint (Qualified "M" "leq") [VarTerm "X", VarTerm "Y"]]+            [Constraint (Qualified "M" "gt") [VarTerm "X", VarTerm "Y"]]+    ]++--------------------------------------------------------------------------------+-- multi-module: whole-program behavior and edge cases+--------------------------------------------------------------------------------++multiModuleTests :: TestTree+multiModuleTests =+  testGroup+    "multi-module"+    [ testCase "full two-module program" $ do+        let modOrder =+              module' "Order"+                `declaring` ["leq" // 2]+                `defining` ["refl" @: ([term "leq" [var "X", var "X"]] <=> [atom "true"])]+            modLogic =+              module' "Logic"+                `importing` ["Order"]+                `defining` [ "trans"+                               @: ( [ term "leq" [var "X", var "Y"],+                                      term "leq" [var "Y", var "Z"]+                                    ]+                                      ==> [term "leq" [var "X", var "Z"]]+                                  )+                           ]+        (renamedOrder, renamedLogic) <- case renameProgram [modOrder, modLogic] of+          Right ([a, b], _) -> return (a, b)+          Right (mods, _) -> assertFailure $ "expected 2 modules, got " ++ show (length mods)+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs+        (renamedOrder.rules, renamedLogic.rules)+          @?= ( [ Rule+                    (Just (noAnn "refl"))+                    ( noAnnP+                        ( Simplification+                            [ Constraint+                                (Qualified "Order" "leq")+                                [ VarTerm "X",+                                  VarTerm "X"+                                ]+                            ]+                        )+                    )+                    (noAnnP [])+                    (noAnnP [CompoundTerm (Unqualified "true") []])+                ],+                [ Rule+                    (Just (noAnn "trans"))+                    ( noAnnP+                        ( Propagation+                            [ Constraint (Qualified "Order" "leq") [VarTerm "X", VarTerm "Y"],+                              Constraint (Qualified "Order" "leq") [VarTerm "Y", VarTerm "Z"]+                            ]+                        )+                    )+                    (noAnnP [])+                    ( noAnnP+                        [ CompoundTerm+                            (Qualified "Order" "leq")+                            [ VarTerm "X",+                              VarTerm "Z"+                            ]+                        ]+                    )+                ]+              ),+      testCase "empty program" $+        renameProgram [] @?= Right ([], []),+      testCase "module with no rules" $+        -- A module with no rules or equations renames to itself (modulo+        -- the import-collapse that 'rewriteImports' performs), so the+        -- expected output is just the collected form of the input.+        let m = module' "M" `declaring` ["leq" // 2]+         in renameProgram [m] @?= Right (rewriteImports [m], []),+      testCase "rule name preserved" $ do+        let m =+              module' "M"+                `declaring` ["c" // 0]+                `defining` ["my_rule" @: ([term "c" []] <=> [atom "true"])]+        rule <- singleRule m+        fmap (.node) rule.name @?= Just "my_rule"+    ]++--------------------------------------------------------------------------------+-- reserved-symbols: =, ==, <- in body position remain Unqualified without error+--------------------------------------------------------------------------------++reservedSymbolTests :: TestTree+reservedSymbolTests =+  testGroup+    "reserved-symbols"+    [ testCase "= in body stays Unqualified" $ do+        let m =+              module' "M"+                `declaring` ["c" // 0]+                `defining` [[term "c" []] <=> [term "=" [var "X", var "Y"]]]+        rule <- singleRule m+        rule.body.node+          @?= [CompoundTerm (Unqualified "=") [VarTerm "X", VarTerm "Y"]],+      testCase "host:f in body stays Qualified host" $ do+        let m =+              module' "M"+                `declaring` ["c" // 0]+                `defining` [[term "c" []] <=> [hostCall "print" [var "X"]]]+        rule <- singleRule m+        rule.body.node+          @?= [CompoundTerm (Qualified "host" "print") [VarTerm "X"]]+    ]++--------------------------------------------------------------------------------+-- exports: export list controls visibility to importers+--------------------------------------------------------------------------------++exportTests :: TestTree+exportTests =+  testGroup+    "exports"+    [ testCase "exported constraint is visible to importer" $ do+        -- A exports leq/2; B imports A and uses leq in head+        let modA =+              module' "A"+                `declaring` ["leq" // 2]+                `exporting` ["leq" // 2]+            modB =+              module' "B"+                `importing` ["A"]+                `defining` [[term "leq" [var "X", var "Y"]] <=> [atom "true"]]+        (_, renamedB) <- case renameProgram [modA, modB] of+          Right ([a, b], _) -> return (a, b)+          Right (mods, _) -> assertFailure $ "expected 2 modules, got " ++ show (length mods)+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs+        rule <- case renamedB.rules of+          [r] -> return r+          rules -> assertFailure $ "expected 1 rule, got " ++ show (length rules)+        rule.head.node+          @?= Simplification [Constraint (Qualified "A" "leq") [VarTerm "X", VarTerm "Y"]],+      testCase "non-exported constraint is hidden from importer" $ do+        -- A declares leq/2 and gt/2 but only exports leq/2; B can't see gt/2+        let modA =+              module' "A"+                `declaring` ["leq" // 2, "gt" // 2]+                `exporting` ["leq" // 2]+            modB =+              module' "B"+                `importing` ["A"]+                `defining` [[term "gt" [var "X", var "Y"]] <=> [atom "true"]]+        renameProgram [modA, modB]+          @?= Left [noDiag (AnnP (UnknownName "gt" 2) dummyLoc (Atom ""))],+      testCase "empty export list hides all constraints from importer" $ do+        -- A exports nothing; B cannot see leq/2+        let modA =+              module' "A"+                `declaring` ["leq" // 2]+                `exporting` []+            modB =+              module' "B"+                `importing` ["A"]+                `defining` [[term "leq" [var "X", var "Y"]] <=> [atom "true"]]+        renameProgram [modA, modB]+          @?= Left [noDiag (AnnP (UnknownName "leq" 2) dummyLoc (Atom ""))],+      testCase "export restriction does not affect own-module use" $ do+        -- A exports only leq/2, but still uses gt/2 in its own rules+        let modA =+              module' "A"+                `declaring` ["leq" // 2, "gt" // 2]+                `exporting` ["leq" // 2]+                `defining` [[term "gt" [var "X", var "Y"]] <=> [atom "true"]]+        rule <- singleRule modA+        rule.head.node+          @?= Simplification [Constraint (Qualified "A" "gt") [VarTerm "X", VarTerm "Y"]],+      testCase "no module directive exports all constraints" $ do+        -- A has modExports = Nothing (no directive); B can see all of A's constraints+        let modA = module' "A" `declaring` ["leq" // 2]+            modB =+              module' "B"+                `importing` ["A"]+                `defining` [[term "leq" [var "X", var "Y"]] <=> [atom "true"]]+        (_, renamedB) <- case renameProgram [modA, modB] of+          Right ([a, b], _) -> return (a, b)+          Right (mods, _) -> assertFailure $ "expected 2 modules, got " ++ show (length mods)+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs+        rule <- case renamedB.rules of+          [r] -> return r+          rules -> assertFailure $ "expected 1 rule, got " ++ show (length rules)+        rule.head.node+          @?= Simplification [Constraint (Qualified "A" "leq") [VarTerm "X", VarTerm "Y"]],+      testCase "exporting undeclared name produces error" $ do+        let m = module' "M" `exporting` ["foo" // 1]+        renameProgram [m]+          @?= Left+            [ noDiag+                ( AnnP+                    (UnknownExport "M" "foo" 1)+                    dummyLoc+                    ( Atom+                        ""+                    )+                )+            ],+      testCase "exporting declared constraint is fine" $ do+        let m =+              module' "M"+                `declaring` ["foo" // 1]+                `exporting` ["foo" // 1]+        case renameProgram [m] of+          Right _ -> pure ()+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs+    ]++-- ---------------------------------------------------------------------------+-- Warnings+-- ---------------------------------------------------------------------------++-- | Rename a program and return the warnings (failing on errors).+warningsOf :: [Module] -> IO [Diagnostic RenameWarning]+warningsOf mods = case renameProgram mods of+  Right (_, ws) -> pure ws+  Left errs -> assertFailure $ "unexpected errors: " ++ show errs++warningTests :: TestTree+warningTests =+  testGroup+    "warnings"+    [ testCase "undeclared data constructor in guard" $ do+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [[term "c" [var "X"]] <=> [atom "true"] |- [term "foo" [var "X"]]]+        ws <- warningsOf [m]+        ws @?= [noDiag (AnnP (UndeclaredDataConstructor "foo") dummyLoc (Atom ""))],+      testCase "declared data constructor produces no warning" $ do+        let m =+              ( module' "M"+                  `declaring` ["c" // 1]+                  `defining` [ [term "c" [var "X"]]+                                 <=> [ atom+                                         "true"+                                     ]+                                 |- [term "foo" [var "X"]]+                             ]+              )+                { typeDecls =+                    [ noAnn+                        ( algebraicTD+                            (Unqualified "t")+                            []+                            [ DataConstructor+                                (Unqualified "foo")+                                [TypeCon (Unqualified "int") []]+                            ]+                            dummyLoc+                        )+                    ]+                }+        ws <- warningsOf [m]+        ws @?= [],+      testCase "declared function in tell-side argument position produces no warning" $ do+        -- Regression: a bare compound like 'f(X)' appearing as an argument+        -- to a tell-side constraint is renamed in 'NoResolve' mode but+        -- must not be warned as a data constructor when 'f' is a visible+        -- function -- 'Resolve.termToExpr' will later canonicalize it to+        -- a 'CallExpr' for tell-time evaluation.+        let m =+              module' "M"+                `declaring` ["c" // 1, function "f" 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [atom "true"]+                               |- [term "c" [term "f" [var "X"]]]+                           ]+        ws <- warningsOf [m]+        ws @?= [],+      testCase "data constructor arity mismatch" $ do+        let m =+              ( module' "M"+                  `declaring` ["c" // 1]+                  `defining` [ [term "c" [var "X"]]+                                 <=> [ atom+                                         "true"+                                     ]+                                 |- [term "foo" [var "X", var "X"]]+                             ]+              )+                { typeDecls =+                    [ noAnn+                        ( algebraicTD+                            (Unqualified "t")+                            []+                            [ DataConstructor+                                (Unqualified "foo")+                                [TypeCon (Unqualified "int") []]+                            ]+                            dummyLoc+                        )+                    ]+                }+        ws <- warningsOf [m]+        ws @?= [noDiag (AnnP (DataConstructorArityMismatch "foo" 2) dummyLoc (Atom ""))],+      testCase "no warning for reserved symbols" $ do+        let m =+              module' "M"+                `declaring` ["c" // 2]+                `defining` [[term "c" [var "X", var "Y"]] <=> [var "X" .=. var "Y"]]+        ws <- warningsOf [m]+        ws @?= [],+      testCase "warns on unknown data constructor in NoResolve mode (head arguments)" $ do+        -- Per the user's "warn everywhere" choice, the renamer now emits+        -- 'UndeclaredDataConstructor' for unknown atoms/compounds in head+        -- pattern position too (previously only resolving contexts warned).+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [[term "c" [term "unknown" [var "X"]]] <=> [atom "true"]]+        ws <- warningsOf [m]+        ws @?= [noDiag (AnnP (UndeclaredDataConstructor "unknown") dummyLoc (Atom ""))],+      testCase "no warning inside quote(...) quoting in body position" $ do+        -- Regression for the BUGS.md case 'store(quote(plus(X, 3)))': the+        -- quote/1 quoting form should keep its argument opaque, so neither+        -- 'quote' itself nor any undeclared functor inside should produce+        -- an 'UndeclaredDataConstructor' warning.+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [term "c" [quote (term "plus" [var "X", int 3])]]+                           ]+        ws <- warningsOf [m]+        ws @?= [],+      testCase "no warning inside quote(...) quoting in guard position" $ do+        -- The quoting form must also stay opaque in expression-position+        -- contexts (guards, is-RHS), where the surrounding mode is+        -- 'ResolveAll' rather than 'NoResolve'.+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [atom "true"]+                               |- [quote (term "plus" [var "X", int 3])]+                           ]+        ws <- warningsOf [m]+        ws @?= [],+      testCase "no warning inside nested quote(quote(...)) quoting" $ do+        -- Quoting nests: the inner 'quote(...)' must also fire the+        -- special case (childMode propagates 'NoResolveQuoted'), so no+        -- warning is emitted for the inner functor either.+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [ term+                                       "c"+                                       [quote (quote (term "plus" [var "X", int 3]))]+                                   ]+                           ]+        ws <- warningsOf [m]+        ws @?= [],+      testCase "syntactic forms stay literal inside quote(...) quoting" $ do+        -- 'is', lambdas, and 'fun name/arity' references are interpreted+        -- only outside @quote/1@. Inside a quoted body they must remain+        -- literal compound terms — no warning for their undeclared inner+        -- functors either.+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [ term+                                       "c"+                                       [quote (term "is" [var "X", term "foo" [int 1]])]+                                   ]+                           ]+        ws <- warningsOf [m]+        ws @?= [],+      testCase "lambda passed directly as a tell-side constraint argument is not warned" $ do+        -- Regression for BUGS.md "Spurious 'Undeclared data constructor'+        -- warnings for 'fun' and '->'". A lambda is a first-class value;+        -- its synthetic '->' and 'fun' functors are surface syntax, not+        -- data constructors. Previously the renamer demoted the+        -- constraint's argument to 'NoResolve', the lambda arm's+        -- 'isResolving' guard failed, and the synthetic functors leaked+        -- through to 'warnUnknownDataCon'. The lambda body is a bare+        -- variable so the test isolates the surface-syntax bug without+        -- pulling in prelude functions that this minimal DSL module+        -- doesn't import.+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [term "c" [lambda [var "Y"] (var "Y")]]+                           ]+        ws <- warningsOf [m]+        ws @?= [],+      testCase "lambda bound via '=' then passed is not warned" $ do+        -- The bind-then-pass form ('F = fun(...) -> ... end, c(F)') was+        -- the documented workaround for the lambda bug. Now that the+        -- lambda arm fires in every non-quoted mode, the workaround on+        -- '=' itself was removed; this case verifies the bind-then-pass+        -- form still produces no spurious warnings under the simplified+        -- pipeline.+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [ var "F" .=. lambda [var "Y"] (var "Y"),+                                     term "c" [var "F"]+                                   ]+                           ]+        ws <- warningsOf [m]+        ws @?= [],+      testCase "function reference passed directly as constraint argument is not warned" $ do+        -- Same structural bug as the lambda case, on the @fun name/arity@+        -- arm: a funref is a first-class value, not data. Previously+        -- 'c(fun f/1)' would emit a spurious 'UndeclaredDataConstructor+        -- "fun"' under 'NoResolve'.+        let m =+              module' "M"+                `declaring` ["c" // 1, function "f" 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [term "c" [funRef "f" 1]]+                           ]+        ws <- warningsOf [m]+        ws @?= [],+      testCase "lambda inside quote(...) stays opaque" $ do+        -- Negative companion to the lambda fix: 'quote(fun(X) -> X end)'+        -- must NOT be recognized as a lambda (the user has explicitly+        -- opted into raw compound shape). The relaxed lambda guard+        -- skips 'NoResolveQuoted' for exactly this reason; this case+        -- locks that contract in.+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [term "c" [quote (lambda [var "Y"] (var "Y"))]]+                           ]+        ws <- warningsOf [m]+        ws @?= [],+      testCase "funref inside quote(...) stays opaque" $ do+        -- Funref counterpart to the lambda-inside-quote/1 case. The+        -- relaxed funref guard ('mode /= NoResolveQuoted') means a+        -- funref outside 'quote/1' resolves; inside 'quote/1' it must+        -- remain a literal compound. 'f' is *not* declared as a+        -- function in this module, so if the funref arm fired+        -- 'resolveName' would emit an UnknownName error and the+        -- compile would fail — the program rename-succeeds only+        -- because the funref arm correctly skips 'NoResolveQuoted'.+        let m =+              module' "M"+                `declaring` ["c" // 1]+                `defining` [ [term "c" [var "X"]]+                               <=> [term "c" [quote (funRef "f" 1)]]+                           ]+        ws <- warningsOf [m]+        ws @?= [],+      testCase "exporting undeclared type produces error" $ do+        let m = (module' "M") {exports = Just (noAnnP [TypeExportDecl "tree" 0 Nothing])}+        renameProgram [m]+          @?= Left+            [ noDiag+                ( AnnP+                    (UnknownExport "M" "tree" 0)+                    dummyLoc+                    ( Atom+                        ""+                    )+                )+            ],+      testCase "exporting declared type is fine" $ do+        let m =+              (module' "M")+                { typeDecls =+                    [ noAnn+                        ( algebraicTD+                            (Unqualified "tree")+                            []+                            [ DataConstructor+                                (Unqualified "empty")+                                []+                            ]+                            dummyLoc+                        )+                    ],+                  exports = Just (noAnnP [TypeExportDecl "tree" 0 Nothing])+                }+        case renameProgram [m] of+          Right _ -> pure ()+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs,+      testCase "type definition names are qualified after renaming" $ do+        let m =+              (module' "M")+                { typeDecls =+                    [ noAnn+                        ( algebraicTD+                            (Unqualified "tree")+                            []+                            [ DataConstructor+                                (Unqualified "leaf")+                                [TypeCon (Unqualified "int") []]+                            ]+                            dummyLoc+                        )+                    ]+                }+        case renameProgram [m] of+          Right ([renamed], _) -> case renamed.typeDecls of+            [Ann td _] -> do+              td.name @?= Qualified "M" "tree"+              case typeConstructors td of+                [dc] -> dc.conName @?= Qualified "M" "leaf"+                dcs -> assertFailure $ "expected 1 constructor, got " ++ show (length dcs)+            tds -> assertFailure $ "expected 1 type decl, got " ++ show (length tds)+          Right (mods, _) -> assertFailure $ "expected 1 module, got " ++ show (length mods)+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs,+      testCase "type references resolved across modules" $ do+        let modA =+              (module' "A")+                { typeDecls =+                    [ noAnn+                        ( algebraicTD+                            (Unqualified "color")+                            []+                            [ DataConstructor+                                (Unqualified "red")+                                []+                            ]+                            dummyLoc+                        )+                    ]+                }+            modB =+              (module' "B" `importing` ["A"])+                { typeDecls =+                    [ noAnn+                        ( algebraicTD+                            (Unqualified "widget")+                            []+                            [ DataConstructor+                                (Unqualified "w")+                                [ TypeCon+                                    (Unqualified "color")+                                    []+                                ]+                            ]+                            dummyLoc+                        )+                    ]+                }+        case renameProgram [modA, modB] of+          Right ([_, renamedB], _) -> case renamedB.typeDecls of+            [Ann td _] -> case typeConstructors td of+              [dc] -> case dc.conArgs of+                [TypeCon colorName []] -> colorName @?= Qualified "A" "color"+                args -> assertFailure $ "unexpected constructor args: " ++ show args+              dcs -> assertFailure $ "expected 1 constructor, got " ++ show (length dcs)+            tds -> assertFailure $ "expected 1 type decl, got " ++ show (length tds)+          Right (mods, _) -> assertFailure $ "expected 2 modules, got " ++ show (length mods)+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs+    ]++--------------------------------------------------------------------------------+-- import lists: use_module/2 restricts visibility+--------------------------------------------------------------------------------++importListTests :: TestTree+importListTests =+  testGroup+    "import lists"+    [ testCase "name in import list is visible" $ do+        let modOrder =+              module' "Order"+                `declaring` ["leq" // 2, "geq" // 2]+                `exporting` ["leq" // 2, "geq" // 2]+            modLogic =+              (module' "Logic")+                { imports =+                    [ noAnnP+                        ( ModuleImport+                            "Order"+                            ( Just+                                [ ConstraintDecl+                                    "leq"+                                    2+                                    Nothing+                                    Nothing+                                ]+                            )+                        )+                    ]+                }+                `defining` [[term "leq" [var "X", var "Y"]] <=> [atom "true"]]+        case renameProgram [modOrder, modLogic] of+          Right ([_, renamedLogic], _) -> case renamedLogic.rules of+            [rule] ->+              rule.head.node+                @?= Simplification+                  [ Constraint+                      (Qualified "Order" "leq")+                      [ VarTerm "X",+                        VarTerm "Y"+                      ]+                  ]+            rules -> assertFailure $ "expected 1 rule, got " ++ show (length rules)+          Right (mods, _) -> assertFailure $ "expected 2 modules, got " ++ show (length mods)+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs,+      testCase "name NOT in import list is not resolved" $ do+        let modOrder =+              module' "Order"+                `declaring` ["leq" // 2, "geq" // 2]+                `exporting` ["leq" // 2, "geq" // 2]+            modLogic =+              (module' "Logic")+                { imports =+                    [ noAnnP+                        ( ModuleImport+                            "Order"+                            ( Just+                                [ ConstraintDecl+                                    "geq"+                                    2+                                    Nothing+                                    Nothing+                                ]+                            )+                        )+                    ]+                }+                `defining` [[term "leq" [var "X", var "Y"]] <=> [atom "true"]]+        renameProgram [modOrder, modLogic]+          @?= Left [noDiag (AnnP (UnknownName "leq" 2) dummyLoc (Atom ""))],+      testCase "error for import list item not exported" $ do+        let modOrder =+              module' "Order"+                `declaring` ["leq" // 2]+                `exporting` ["leq" // 2]+            modLogic =+              (module' "Logic")+                { imports =+                    [ noAnnP+                        ( ModuleImport+                            "Order"+                            ( Just+                                [ ConstraintDecl+                                    "nonexistent"+                                    1+                                    Nothing+                                    Nothing+                                ]+                            )+                        )+                    ]+                }+        renameProgram [modOrder, modLogic]+          @?= Left [noDiag (AnnP (UnknownImport "Order" "nonexistent" 1) dummyLoc (Atom ""))],+      testCase "operator in import list is accepted when source module exports it" $ do+        let modOrder =+              module' "Order"+                `declaring` ["leq" // 2]+                `exporting` ["leq" // 2]+            modLogic =+              (module' "Logic")+                { imports =+                    [ noAnnP+                        ( ModuleImport+                            "Order"+                            ( Just+                                [ OperatorDecl+                                    ( OpDecl+                                        700+                                        Xfx+                                        "==="+                                    )+                                ]+                            )+                        )+                    ]+                }+            inputs =+              defaultRenameInputs+                { operatorExports = Map.fromList [("Order", [OpDecl 700 Xfx "==="])]+                }+        case Rn.renameProgram inputs (rewriteImports [modOrder, modLogic]) of+          Right _ -> pure ()+          Left errs -> assertFailure $ "unexpected errors: " ++ show errs,+      testCase "operator in import list is rejected when source module does not export it" $ do+        let modOrder =+              module' "Order"+                `declaring` ["leq" // 2]+                `exporting` ["leq" // 2]+            modLogic =+              (module' "Logic")+                { imports =+                    [ noAnnP+                        ( ModuleImport+                            "Order"+                            ( Just+                                [ OperatorDecl+                                    ( OpDecl+                                        700+                                        Xfx+                                        "==="+                                    )+                                ]+                            )+                        )+                    ]+                }+        renameProgram [modOrder, modLogic]+          @?= Left [noDiag (AnnP (UnknownOperatorImport "Order" "===") dummyLoc (Atom ""))],+      testCase "use_module after non-import directive is reported as out-of-order" $ do+        let modOrder =+              module' "Order"+                `declaring` ["leq" // 2]+                `exporting` ["leq" // 2]+            -- Synthesise an import located after the recorded trailingLoc.+            misplacedLoc = SourceLoc "test.chr" 10 1+            modLogic =+              (module' "Logic")+                { imports = [AnnP (ModuleImport "Order" Nothing) misplacedLoc (Atom "")]+                }+            inputs =+              defaultRenameInputs+                { trailingLoc = Map.fromList [("Logic", Just (SourceLoc "test.chr" 5 1))]+                }+        case Rn.renameProgram inputs (rewriteImports [modOrder, modLogic]) of+          Left errs ->+            any+              ( \(Diagnostic _ (AnnP e _ _)) -> case e of+                  UseModuleOutOfOrder "Order" -> True+                  _ -> False+              )+              errs+              @?= True+          Right _ -> assertFailure "expected UseModuleOutOfOrder error",+      testCase "import of unknown type with constructor list reports one UnknownImport" $ do+        -- Regression: `type(missing/0, [c1, c2])` against a module that+        -- doesn't declare `missing` used to fire one UnknownImport plus+        -- one UnknownExportedConstructor per listed constructor.+        let modLib =+              module' "Lib"+                `declaring` ["leq" // 2]+                `exporting` ["leq" // 2]+            modUser =+              (module' "User")+                { imports =+                    [ noAnnP+                        ( ModuleImport+                            "Lib"+                            (Just [TypeExportDecl "missing" 0 (Just ["c1", "c2"])])+                        )+                    ]+                }+        renameProgram [modLib, modUser]+          @?= Left+            [noDiag (AnnP (UnknownImport "Lib" "missing" 0) dummyLoc (Atom ""))]+    ]
+ test/YCHR/RoundtripTest.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Roundtrip property tests: prettyTermSrc / prettyConstraintSrc are+-- right-inverses of the parser.+module YCHR.RoundtripTest (tests) where++import Data.List (intercalate)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Hedgehog+  ( Gen,+    Property,+    annotate,+    assert,+    evalIO,+    failure,+    forAll,+    forAllWith,+    property,+    (===),+  )+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import Test.Tasty.Hedgehog (testProperty)+import YCHR.Internal.Parsed qualified as P+import YCHR.Internal.Parser (parseConstraint, parseRule, parseTerm)+import YCHR.Internal.Pretty (prettyConstraintSrc, prettyRuleSrc, prettyTermSrc)+import YCHR.Internal.Runtime.Monad (Chr, initSessionEnv, runChr)+import YCHR.Internal.Runtime.Registry (HostCallFn (..), baseHostCallRegistry, valueList)+import YCHR.Internal.Runtime.Types (Value (..))+import YCHR.Internal.Types (Constraint (..), Name (..), Term (..))+import YCHR.Internal.VM qualified as VM++-- ---------------------------------------------------------------------------+-- Generators+-- ---------------------------------------------------------------------------++-- | Generate a safe unquoted atom: lowercase-starting alphanumeric,+-- not a reserved word or infix operator name.+genSafeAtom :: Gen Text+genSafeAtom = Gen.filter isOk $ do+  c <- Gen.lower+  rest <- Gen.list (Range.linear 0 5) Gen.alphaNum+  pure (Text.pack (c : rest))+  where+    forbidden = ["is", "true", "false"] :: [Text]+    isOk s = s `notElem` forbidden && not (Text.null s)++-- | Generate atoms for use as 'AtomTerm' values, including cases that+-- require quoting (empty, uppercase-starting, embedded single quote).+genAtom :: Gen Text+genAtom =+  Gen.choice+    [ genSafeAtom,+      pure "",+      do+        s <- genSafeAtom+        pure (s <> "'s"),+      do+        c <- Gen.upper+        rest <- Gen.list (Range.linear 0 4) Gen.alphaNum+        pure (Text.pack (c : rest))+    ]++-- | Generate content for a 'TextTerm' (double-quoted string).+-- Includes plain text, embedded double quotes, backslashes, and escape chars.+genStringContent :: Gen Text+genStringContent =+  Text.pack+    <$> Gen.list+      (Range.linear 0 10)+      ( Gen.choice+          [ Gen.alphaNum,+            Gen.element [' ', '"', '\\', '\n', '\t']+          ]+      )++-- | Generate a valid variable name (uppercase-starting).+genVarName :: Gen Text+genVarName = do+  c <- Gen.upper+  rest <- Gen.list (Range.linear 0 4) (Gen.choice [Gen.alphaNum, pure '_'])+  pure (Text.pack (c : rest))++-- | Generate an arbitrary 'Term'. Compound terms use safe atom functors only+-- (no infix operators, no qualified names) so that 'prettyTermSrc' produces+-- output that parses back through 'termP'.+genTerm :: Gen Term+genTerm =+  Gen.recursive+    Gen.choice+    -- Base cases+    [ VarTerm <$> genVarName,+      IntTerm <$> Gen.integral (Range.linear (-1000) 1000),+      (\s -> CompoundTerm (Unqualified s) []) <$> genAtom,+      TextTerm <$> genStringContent,+      pure Wildcard+    ]+    -- Recursive cases (arity 1 and 2)+    [ Gen.subtermM genTerm $ \t -> do+        f <- genSafeAtom+        pure (CompoundTerm (Unqualified f) [t]),+      Gen.subtermM2 genTerm genTerm $ \t1 t2 -> do+        f <- genSafeAtom+        pure (CompoundTerm (Unqualified f) [t1, t2])+    ]++-- | Generate a constraint name (unqualified or qualified).+genConstraintName :: Gen Name+genConstraintName =+  Gen.choice+    [ Unqualified <$> genSafeAtom,+      Qualified <$> genSafeAtom <*> genSafeAtom+    ]++-- | Generate an arbitrary 'Constraint'.+genConstraint :: Gen Constraint+genConstraint = do+  name <- genConstraintName+  args <- Gen.list (Range.linear 0 3) genTerm+  pure (Constraint name args)++-- | Generate a parsed 'P.Head'.+genHead :: Gen P.Head+genHead =+  Gen.choice+    [ P.Simplification <$> Gen.list (Range.linear 1 3) genConstraint,+      P.Propagation <$> Gen.list (Range.linear 1 3) genConstraint,+      P.Simpagation+        <$> Gen.list (Range.linear 1 2) genConstraint+        <*> Gen.list (Range.linear 1 2) genConstraint+    ]++-- | Generate a parsed 'P.Rule'.+genRule :: Gen P.Rule+genRule = do+  name <- Gen.maybe (P.noAnn <$> genSafeAtom)+  hd <- genHead+  guard_ <- Gen.list (Range.linear 0 2) genTerm+  body_ <- Gen.list (Range.linear 1 3) genTerm+  pure+    P.Rule+      { name = name,+        head = P.noAnnP hd,+        guard = P.noAnnP guard_,+        body = P.noAnnP body_+      }++-- | Strip source locations from a parsed 'P.Rule' so we can compare+-- structurally (the parser produces real locations, generators use 'noAnn').+stripRuleAnn :: P.Rule -> P.Rule+stripRuleAnn r =+  P.Rule+    { name = P.noAnn . (.node) <$> r.name,+      head = P.noAnnP r.head.node,+      guard = P.noAnnP r.guard.node,+      body = P.noAnnP r.body.node+    }++-- ---------------------------------------------------------------------------+-- Properties+-- ---------------------------------------------------------------------------++prop_termRoundtrip :: Property+prop_termRoundtrip = property $ do+  t <- forAll genTerm+  let src = prettyTermSrc t+  case parseTerm "<roundtrip>" (Text.pack src) of+    Left err -> annotate (show err) >> failure+    Right t' -> t' === t++prop_constraintRoundtrip :: Property+prop_constraintRoundtrip = property $ do+  c <- forAll genConstraint+  let src = prettyConstraintSrc c+  case parseConstraint "<roundtrip>" (Text.pack src) of+    Left err -> annotate (show err) >> failure+    Right (Left validErr) -> annotate (show validErr) >> failure+    Right (Right c') -> c' === c++prop_ruleRoundtrip :: Property+prop_ruleRoundtrip = property $ do+  r <- forAll genRule+  let src = prettyRuleSrc r+  annotate src+  case parseRule "<roundtrip>" (Text.pack src) of+    Left err -> annotate (show err) >> failure+    Right (_, validErrs@(_ : _)) -> annotate (show validErrs) >> failure+    Right (Nothing, _) -> annotate "parser returned no rule" >> failure+    Right (Just r', []) -> stripRuleAnn r' === r++-- ---------------------------------------------------------------------------+-- =.. roundtrip+-- ---------------------------------------------------------------------------++-- | Generate a runtime 'Value' compound term (including arity 0).+-- The arity-0 base case is 'VAtom', matching the runtime collapse+-- enforced by 'YCHR.Internal.Compile.compileTerm'.+genCompoundValue :: Gen Value+genCompoundValue =+  Gen.recursive+    Gen.choice+    -- Base: arity-0 compound terms (canonical form is 'VAtom').+    [ VAtom <$> genSafeAtom+    ]+    -- Recursive: arity 1–3+    [ Gen.subtermM genLeafOrCompound $ \t -> do+        f <- genSafeAtom+        pure (VTerm f [t]),+      Gen.subtermM2 genLeafOrCompound genLeafOrCompound $ \t1 t2 -> do+        f <- genSafeAtom+        pure (VTerm f [t1, t2]),+      do+        f <- genSafeAtom+        args <- Gen.list (Range.linear 1 3) genLeafOrCompound+        pure (VTerm f args)+    ]+  where+    genLeafOrCompound =+      Gen.recursive+        Gen.choice+        [ VInt <$> Gen.integral (Range.linear (-100) 100),+          VAtom <$> genSafeAtom,+          VBool <$> Gen.bool+        ]+        [ genCompoundValue+        ]++-- | Structural equality for ground 'Value's (no 'VVar').+groundEq :: Value -> Value -> Bool+groundEq (VInt a) (VInt b) = a == b+groundEq (VAtom a) (VAtom b) = a == b+groundEq (VText a) (VText b) = a == b+groundEq (VBool a) (VBool b) = a == b+groundEq VWildcard VWildcard = True+groundEq (VTerm f1 as1) (VTerm f2 as2) =+  f1 == f2 && length as1 == length as2 && and (zipWith groundEq as1 as2)+groundEq _ _ = False++-- | Show a ground 'Value' for test diagnostics.+showGroundValue :: Value -> String+showGroundValue (VInt n) = "VInt " ++ show n+showGroundValue (VFloat n) = "VFloat " ++ show n+showGroundValue (VAtom a) = "VAtom " ++ show a+showGroundValue (VText t) = "VText " ++ show t+showGroundValue (VBool b) = "VBool " ++ show b+showGroundValue VWildcard = "VWildcard"+showGroundValue (VTerm f args) =+  "VTerm " ++ show f ++ " [" ++ intercalate ", " (map showGroundValue args) ++ "]"+showGroundValue (VVar _) = "VVar <opaque>"++-- | Look up a host call by name, failing if not found.+lookupHostCall :: VM.Name -> HostCallFn+lookupHostCall name = case Map.lookup name baseHostCallRegistry of+  Just hc -> hc+  Nothing -> error $ "host call not found: " ++ show name++runChrEmpty :: Chr a -> IO a+runChrEmpty action = do+  env <- initSessionEnv [] [] Map.empty Map.empty Map.empty Map.empty Set.empty+  runChr action env++prop_compoundToListRoundtrip :: Property+prop_compoundToListRoundtrip = property $ do+  term <- forAllWith showGroundValue genCompoundValue+  let HostCallFn toList = lookupHostCall "compound_to_list"+      HostCallFn fromList = lookupHostCall "list_to_compound"+  list <- evalIO (runChrEmpty (toList [term]))+  term' <- evalIO (runChrEmpty (fromList [list]))+  annotate (showGroundValue term)+  annotate (showGroundValue term')+  assert (groundEq term term')++prop_listToCompoundRoundtrip :: Property+prop_listToCompoundRoundtrip = property $ do+  f <- forAll genSafeAtom+  args <-+    forAllWith (show . map showGroundValue) $+      Gen.list (Range.linear 0 3) $+        Gen.choice [VInt <$> Gen.integral (Range.linear 0 100), VAtom <$> genSafeAtom]+  let list = valueList (VAtom f : args)+  let HostCallFn fromList = lookupHostCall "list_to_compound"+      HostCallFn toList = lookupHostCall "compound_to_list"+  compound <- evalIO (runChrEmpty (fromList [list]))+  list' <- evalIO (runChrEmpty (toList [compound]))+  annotate (showGroundValue list)+  annotate (showGroundValue list')+  assert (groundEq list list')++-- ---------------------------------------------------------------------------+-- Fixed-case roundtrips+-- ---------------------------------------------------------------------------+--+-- The Hedgehog rule generator above avoids infix operators in functors+-- and emits only safe-atom heads (see 'genTerm' / 'genHead'), so it+-- never produces a named simpagation, never threads a guard through a+-- propagation rule, etc. The fixed cases below exercise those+-- structural shapes head-on.+--+-- Arithmetic and comparison operators come from @library(prelude)@,+-- not 'builtinOps', so 'parseRule' can't re-ingest @+@/@<@/@==@ in+-- isolation. Pretty-printing of those is covered indirectly by the+-- ~120 golden tests that print arithmetic and comparison results.+--+-- The check is: parse → pretty → parse, and assert (a) both parses+-- succeed without parse-validation errors and (b) the pretty output+-- is a fixed point (rule1 and rule2 print to the same source). That+-- pins both the pretty-printer being a valid inverse of the parser+-- and the rendering being canonical for these shapes.++assertRuleRoundtrips :: Text -> IO ()+assertRuleRoundtrips src = case parseRule "<roundtrip>" src of+  Left err -> assertFailure ("parse failed on input:\n" ++ Text.unpack src ++ "\n" ++ show err)+  Right (_, validErrs@(_ : _)) ->+    assertFailure ("parse validation errors on input:\n" ++ show validErrs)+  Right (Nothing, _) ->+    assertFailure ("parser returned no rule for input:\n" ++ Text.unpack src)+  Right (Just rule1, []) -> do+    let pretty1 = prettyRuleSrc rule1+    case parseRule "<roundtrip>" (Text.pack pretty1) of+      Left err ->+        assertFailure ("re-parse failed on pretty output:\n" ++ pretty1 ++ "\n" ++ show err)+      Right (_, validErrs@(_ : _)) ->+        assertFailure ("re-parse validation errors on pretty output:\n" ++ show validErrs)+      Right (Nothing, _) ->+        assertFailure ("re-parse produced no rule on pretty output:\n" ++ pretty1)+      Right (Just rule2, []) -> prettyRuleSrc rule2 @?= pretty1++fixedRuleCases :: TestTree+fixedRuleCases =+  testGroup+    "rule fixed cases"+    [ testCase "named simpagation" $+        assertRuleRoundtrips "subsumes @ leq(X, Y) \\ leq(X, Y) <=> true.",+      testCase "named simpagation with guard (unification ask)" $+        assertRuleRoundtrips "subsumes @ leq(X, Y) \\ leq(X, Z) <=> Y = Z | true.",+      testCase "named propagation" $+        assertRuleRoundtrips "trans @ leq(X, Y), leq(Y, Z) ==> leq(X, Z).",+      testCase "named propagation with multi-atom body" $+        assertRuleRoundtrips+          "mul @ pair(X, Y), pair(Y, Z) ==> pair(X, Z), seen(Y).",+      testCase "simplification with multi-atom guard and body" $+        assertRuleRoundtrips+          "merge(X, Y, Z) <=> X = a, Y = b | step(X), step(Y), step(Z).",+      -- Multi-arg constraints with mixed argument kinds are syntactically+      -- distinctive: head separator, comma-arg lists, and the propagation+      -- arrow all interact.+      testCase "propagation with zero-arity head and body atoms" $+        assertRuleRoundtrips "go @ start, go ==> done."+    ]++-- ---------------------------------------------------------------------------+-- Test tree+-- ---------------------------------------------------------------------------++tests :: TestTree+tests =+  testGroup+    "YCHR.Roundtrip"+    [ testProperty "term roundtrip (parse . prettyTermSrc = id)" prop_termRoundtrip,+      testProperty+        "constraint roundtrip (parse . prettyConstraintSrc = id)"+        prop_constraintRoundtrip,+      testProperty "rule roundtrip (parse . prettyRuleSrc = id)" prop_ruleRoundtrip,+      fixedRuleCases,+      testProperty+        "compound_to_list roundtrip (list_to_compound . compound_to_list = id)"+        prop_compoundToListRoundtrip,+      testProperty+        "list_to_compound roundtrip (compound_to_list . list_to_compound = id)"+        prop_listToCompoundRoundtrip+    ]
+ test/YCHR/RunTest.hs view
@@ -0,0 +1,614 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.RunTest (tests) where++import Control.Exception (SomeException, fromException, try)+import Data.Foldable (toList)+import Data.List (isInfixOf)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import YCHR.Internal.Compile.Pipeline (CompiledProgram (..))+import YCHR.Internal.Display (displayMsg)+import YCHR.Internal.Runtime.Interpreter (HostCallFn (..), HostCallRegistry)+import YCHR.Internal.Runtime.Store (getStoreSnapshot, isSuspAlive)+import YCHR.Internal.Types+  ( Constraint (..),+    ConstraintType,+    Identifier (..),+    Name (..),+    QualifiedConstraint (..),+    QualifiedName (..),+    Term (..),+    lookupSymbol,+  )+import YCHR.Internal.VM qualified as VM+import YCHR.Run+  ( Chr,+    Error (..),+    GoalRejection (..),+    Value (..),+    compileModules,+    equal,+    newVar,+    resolveQueryConstraint,+    runProgramWithGoal,+    runProgramWithQuery,+    tellConstraint,+    toSessionInput,+    withCHR,+  )++tests :: TestTree+tests =+  testGroup+    "YCHR.Run"+    [ leqTests,+      fibTests,+      visibilityTests,+      queryErrorTests,+      queryBodyTests,+      guardErrorTests,+      unicodeTests,+      arityOverloadTests+    ]++-- ---------------------------------------------------------------------------+-- Shared helpers+-- ---------------------------------------------------------------------------++compileOrFail :: [(FilePath, Text)] -> IO CompiledProgram+compileOrFail inputs = case compileModules False inputs of+  Left err -> assertFailure $ show err+  Right (cp, _) -> pure cp++countAlive :: VM.ConstraintType -> Chr Int+countAlive cType = do+  snapshot <- getStoreSnapshot cType+  alives <- traverse isSuspAlive (toList snapshot)+  pure (length (filter id alives))++-- ---------------------------------------------------------------------------+-- LEQ surface source+-- ---------------------------------------------------------------------------++leqSource :: Text+leqSource =+  ":- module(order, [leq/2]).\n\+  \:- chr_constraint leq/2.\n\+  \\n\+  \reflexivity @ leq(X, X) <=> true.\n\+  \antisymmetry @ leq(X, Y), leq(Y, X) <=> X = Y.\n\+  \idempotence @ leq(X, Y) \\ leq(X, Y) <=> true.\n\+  \transitivity @ leq(X, Y), leq(Y, Z) ==> leq(X, Z).\n"++lookupType :: CompiledProgram -> Identifier -> ConstraintType+lookupType prog ident =+  case lookupSymbol ident prog.symbolTable of+    Just ct -> ct+    Nothing -> error $ "constraint type not found: " ++ show ident++leqHostCalls :: HostCallRegistry+leqHostCalls = Map.empty++leqTests :: TestTree+leqTests =+  testGroup+    "LEQ handler (from surface language)"+    [ testCase "reflexivity: leq(3, 3) fires, store empty" $ do+        prog <- compileOrFail [("order.chr", leqSource)]+        let leqType = lookupType prog (Identifier (Qualified "order" "leq") 2)+        n <- withCHR (toSessionInput prog) leqHostCalls $ do+          tellConstraint (Unqualified "leq") [VInt 3, VInt 3]+          countAlive leqType+        n @?= 0,+      testCase "no rule fires: leq(1, 2) stays" $ do+        prog <- compileOrFail [("order.chr", leqSource)]+        let leqType = lookupType prog (Identifier (Qualified "order" "leq") 2)+        n <- withCHR (toSessionInput prog) leqHostCalls $ do+          tellConstraint (Unqualified "leq") [VInt 1, VInt 2]+          countAlive leqType+        n @?= 1,+      testCase "antisymmetry: leq(X, Y), leq(Y, X) unifies X=Y, store empty" $ do+        prog <- compileOrFail [("order.chr", leqSource)]+        let leqType = lookupType prog (Identifier (Qualified "order" "leq") 2)+        (n, areEqual) <- withCHR (toSessionInput prog) leqHostCalls $ do+          x <- newVar+          y <- newVar+          tellConstraint (Unqualified "leq") [x, y]+          tellConstraint (Unqualified "leq") [y, x]+          n <- countAlive leqType+          eq <- equal x y+          pure (n, eq)+        n @?= 0+        assertBool "X and Y should be unified" areEqual,+      testCase "transitivity: leq(1,2), leq(2,3) produces leq(1,3)" $ do+        prog <- compileOrFail [("order.chr", leqSource)]+        let leqType = lookupType prog (Identifier (Qualified "order" "leq") 2)+        n <- withCHR (toSessionInput prog) leqHostCalls $ do+          tellConstraint (Unqualified "leq") [VInt 1, VInt 2]+          tellConstraint (Unqualified "leq") [VInt 2, VInt 3]+          countAlive leqType+        n @?= 3,+      testCase "idempotence: leq(1,2), leq(1,2) removes duplicate" $ do+        prog <- compileOrFail [("order.chr", leqSource)]+        let leqType = lookupType prog (Identifier (Qualified "order" "leq") 2)+        n <- withCHR (toSessionInput prog) leqHostCalls $ do+          tellConstraint (Unqualified "leq") [VInt 1, VInt 2]+          tellConstraint (Unqualified "leq") [VInt 1, VInt 2]+          countAlive leqType+        n @?= 1,+      testCase "full cycle: leq(a,b), leq(b,c), leq(c,a) — all removed, all unified" $ do+        prog <- compileOrFail [("order.chr", leqSource)]+        let leqType = lookupType prog (Identifier (Qualified "order" "leq") 2)+        (n, eqAB, eqBC) <- withCHR (toSessionInput prog) leqHostCalls $ do+          a <- newVar+          b <- newVar+          c <- newVar+          tellConstraint (Unqualified "leq") [a, b]+          tellConstraint (Unqualified "leq") [b, c]+          tellConstraint (Unqualified "leq") [c, a]+          n <- countAlive leqType+          eqAB <- equal a b+          eqBC <- equal b c+          pure (n, eqAB, eqBC)+        n @?= 0+        assertBool "a and b should be unified" eqAB+        assertBool "b and c should be unified" eqBC+    ]++-- ---------------------------------------------------------------------------+-- Fibonacci surface source+-- ---------------------------------------------------------------------------++fibSource :: Text+fibSource =+  ":- module(fib, [fib/2]).\n\+  \:- chr_constraint fib/2.\n\+  \\n\+  \base0 @ fib(0, R) <=> R = 0.\n\+  \base1 @ fib(1, R) <=> R = 1.\n\+  \rec @ fib(N, R) <=> N1 is host:'-'(N, 1), N2 is host:'-'(N, 2), \+  \fib(N1, R1), fib(N2, R2), Tmp is host:'+'(R1, R2), R = Tmp.\n"++extractIntArgs :: String -> [Value] -> (Integer, Integer)+extractIntArgs _ [VInt a, VInt b] = (a, b)+extractIntArgs context vals =+  error $+    context ++ ": expected 2 Int arguments, got " ++ show (length vals)++fibHostCalls :: HostCallRegistry+fibHostCalls =+  Map.fromList+    [ ( VM.Name "+",+        HostCallFn $ \args ->+          let (a, b) = extractIntArgs "+" args in pure (VInt (a + b))+      ),+      ( VM.Name "-",+        HostCallFn $ \args ->+          let (a, b) = extractIntArgs "-" args in pure (VInt (a - b))+      )+    ]++fibTests :: TestTree+fibTests =+  testGroup+    "Fibonacci (from surface language)"+    [ testCase "fib 10 = 55" $ do+        prog <- compileOrFail [("fib.chr", fibSource)]+        bindings <- runProgramWithGoal prog fibHostCalls "fib:fib(10, R)"+        Map.lookup "R" bindings @?= Just (IntTerm 55)+    ]++-- ---------------------------------------------------------------------------+-- Query visibility+-- ---------------------------------------------------------------------------++hiddenSource :: Text+hiddenSource =+  ":- module(secret, []).\n\+  \:- chr_constraint hidden/1.\n\+  \\n\+  \hidden(X) <=> true.\n"++exportedSource :: Text+exportedSource =+  ":- module(pub, [visible/1]).\n\+  \:- chr_constraint visible/1.\n\+  \:- chr_constraint internal/1.\n\+  \\n\+  \visible(X) <=> true.\n\+  \internal(X) <=> true.\n"++ambiguousSourceA :: Text+ambiguousSourceA =+  ":- module(modA, [foo/1]).\n\+  \:- chr_constraint foo/1.\n\+  \\n\+  \foo(X) <=> true.\n"++ambiguousSourceB :: Text+ambiguousSourceB =+  ":- module(modB, [foo/1]).\n\+  \:- chr_constraint foo/1.\n\+  \\n\+  \foo(X) <=> true.\n"++isLeft :: Either a b -> Bool+isLeft (Left _) = True+isLeft _ = False++visibilityTests :: TestTree+visibilityTests =+  testGroup+    "Query visibility"+    [ testCase "unqualified resolves to unique exported constraint" $ do+        cp <- compileOrFail [("pub.chr", exportedSource)]+        let q = Constraint (Unqualified "visible") [VarTerm "X"]+        case resolveQueryConstraint cp q of+          Right (QualifiedConstraint (QualifiedName "pub" "visible") _) -> pure ()+          other ->+            assertFailure $+              "Expected Right (Qualified pub visible), got: " ++ show other,+      testCase "unqualified hidden constraint fails" $ do+        cp <- compileOrFail [("secret.chr", hiddenSource)]+        let q = Constraint (Unqualified "hidden") [VarTerm "X"]+        assertBool "Should fail for hidden constraint" (isLeft (resolveQueryConstraint cp q)),+      testCase "qualified exported constraint succeeds" $ do+        cp <- compileOrFail [("pub.chr", exportedSource)]+        let q = Constraint (Qualified "pub" "visible") [VarTerm "X"]+        case resolveQueryConstraint cp q of+          Right _ -> pure ()+          Left err -> assertFailure $ "Should succeed: " ++ show err,+      testCase "qualified hidden constraint fails" $ do+        cp <- compileOrFail [("secret.chr", hiddenSource)]+        let q = Constraint (Qualified "secret" "hidden") [VarTerm "X"]+        assertBool+          "Should fail for hidden qualified constraint"+          ( isLeft+              (resolveQueryConstraint cp q)+          ),+      testCase "qualified non-exported internal constraint fails" $ do+        cp <- compileOrFail [("pub.chr", exportedSource)]+        let q = Constraint (Qualified "pub" "internal") [VarTerm "X"]+        assertBool+          "Should fail for non-exported constraint"+          ( isLeft+              ( resolveQueryConstraint+                  cp+                  q+              )+          ),+      testCase "ambiguous unqualified name fails" $ do+        cp <-+          compileOrFail+            [ ("a.chr", ambiguousSourceA),+              ("b.chr", ambiguousSourceB)+            ]+        let q = Constraint (Unqualified "foo") [VarTerm "X"]+        assertBool+          "Should fail for ambiguous constraint"+          ( isLeft+              ( resolveQueryConstraint+                  cp+                  q+              )+          ),+      testCase "ambiguous name resolved with qualification" $ do+        cp <-+          compileOrFail+            [ ("a.chr", ambiguousSourceA),+              ("b.chr", ambiguousSourceB)+            ]+        let q = Constraint (Qualified "modA" "foo") [VarTerm "X"]+        case resolveQueryConstraint cp q of+          Right _ -> pure ()+          Left err -> assertFailure $ "Should succeed with qualification: " ++ show err+    ]++-- ---------------------------------------------------------------------------+-- Query-time error paths+-- ---------------------------------------------------------------------------+--+-- 'visibilityTests' above already covers the @Left@/@Right@ split for+-- 'resolveQueryConstraint'. The cases below pin the /rejection variant/+-- for each failure mode (since the user-visible rendering is built by+-- the 'Display' instance on @GoalNotAConstraint@), plus one end-to-end+-- check on the displayed message.++leftRejection :: Either GoalRejection b -> IO GoalRejection+leftRejection (Left r) = pure r+leftRejection (Right _) = assertFailure "expected Left, got Right"++queryErrorTests :: TestTree+queryErrorTests =+  testGroup+    "Query errors"+    [ testCase "unknown unqualified constraint → NoSuchConstraint" $ do+        cp <- compileOrFail [("pub.chr", exportedSource)]+        let q = Constraint (Unqualified "nope") [VarTerm "X"]+        r <- leftRejection (resolveQueryConstraint cp q)+        case r of+          NoSuchConstraint -> pure ()+          other -> assertFailure $ "expected NoSuchConstraint, got: " ++ show other,+      testCase "unknown qualified constraint → ConstraintNotExported" $ do+        cp <- compileOrFail [("pub.chr", exportedSource)]+        let q = Constraint (Qualified "pub" "internal") [VarTerm "X"]+        r <- leftRejection (resolveQueryConstraint cp q)+        case r of+          ConstraintNotExported (QualifiedName "pub" "internal") -> pure ()+          other ->+            assertFailure $+              "expected ConstraintNotExported pub:internal, got: " ++ show other,+      testCase "ambiguous unqualified → AmbiguousConstraint lists modules" $ do+        cp <-+          compileOrFail+            [ ("a.chr", ambiguousSourceA),+              ("b.chr", ambiguousSourceB)+            ]+        let q = Constraint (Unqualified "foo") [VarTerm "X"]+        r <- leftRejection (resolveQueryConstraint cp q)+        case r of+          AmbiguousConstraint ms -> do+            assertBool ("expected 'modA' in: " ++ show ms) ("modA" `elem` ms)+            assertBool ("expected 'modB' in: " ++ show ms) ("modB" `elem` ms)+          other -> assertFailure $ "expected AmbiguousConstraint, got: " ++ show other,+      testCase "displayMsg renders YCHR-20013 with REPL hint" $ do+        let q = Constraint (Unqualified "nope") [VarTerm "X"]+            rendered = displayMsg (GoalNotAConstraint q NoSuchConstraint)+        assertBool ("expected 'YCHR-20013' in: " ++ rendered) $+          "YCHR-20013" `isInfixOf` rendered+        assertBool ("expected 'nope/1' in: " ++ rendered) $+          "nope/1" `isInfixOf` rendered+        assertBool ("expected REPL hint in: " ++ rendered) $+          "ychr repl" `isInfixOf` rendered,+      testCase "runProgramWithGoal: malformed goal throws ParseError" $ do+        cp <- compileOrFail [("pub.chr", exportedSource)]+        outcome <-+          try @SomeException+            (runProgramWithGoal cp Map.empty "this is not a valid goal")+        case outcome of+          Left exc -> case fromException exc :: Maybe Error of+            Just (ParseError _ _) -> pure ()+            Just other ->+              assertFailure $+                "expected ParseError, got Error:\n" ++ displayMsg other+            Nothing ->+              assertFailure $+                "expected ParseError, got non-Error exception: " ++ show exc+          Right _ -> assertFailure "expected exception, got success",+      testCase "runProgramWithGoal: undeclared constraint → GoalNotAConstraint" $ do+        cp <- compileOrFail [("pub.chr", exportedSource)]+        outcome <-+          try @SomeException (runProgramWithGoal cp Map.empty "nope(X)")+        case outcome of+          Left exc -> case fromException exc :: Maybe Error of+            Just (GoalNotAConstraint _ NoSuchConstraint) -> pure ()+            Just other ->+              assertFailure $+                "expected GoalNotAConstraint NoSuchConstraint, got Error:\n"+                  ++ displayMsg other+            Nothing ->+              assertFailure $+                "expected Error, got non-Error exception: " ++ show exc+          Right _ ->+            assertFailure "expected an exception for unknown constraint",+      testCase "runProgramWithQuery: parse error in one goal aborts the whole query" $ do+        cp <- compileOrFail [("pub.chr", exportedSource)]+        outcome <-+          try @SomeException+            (runProgramWithQuery cp Map.empty "visible(X), !!bogus!!.")+        case outcome of+          Left exc -> case fromException exc :: Maybe Error of+            Just (ParseError _ _) -> pure ()+            Just other ->+              assertFailure $+                "expected ParseError, got Error:\n" ++ displayMsg other+            Nothing ->+              assertFailure $+                "expected ParseError, got non-Error exception: " ++ show exc+          Right _ -> assertFailure "expected exception, got success"+    ]++-- ---------------------------------------------------------------------------+-- Non-ASCII constraint names+-- ---------------------------------------------------------------------------++unicodeSource :: Text+unicodeSource =+  ":- module(uni, ['\xe9cho'/1]).\n\+  \:- chr_constraint '\xe9cho'/1.\n\+  \\n\+  \'\xe9cho'(X) <=> X = done.\n"++unicodeTests :: TestTree+unicodeTests =+  testGroup+    "Non-ASCII constraint names"+    [ testCase "constraint with non-ASCII name compiles and runs" $ do+        prog <- compileOrFail [("uni.chr", unicodeSource)]+        bindings <- runProgramWithGoal prog Map.empty "uni:'\xe9cho'(R)"+        Map.lookup "R" bindings @?= Just (CompoundTerm (Unqualified "done") [])+    ]++-- ---------------------------------------------------------------------------+-- Arity overloading+-- ---------------------------------------------------------------------------++arityOverloadSource :: Text+arityOverloadSource =+  ":- module(m, [foo/1, foo/2]).\n\+  \:- chr_constraint foo/1, foo/2.\n\+  \\n\+  \foo(X) <=> X = one.\n\+  \foo(X, Y) <=> X = two, Y = args.\n"++arityOverloadTests :: TestTree+arityOverloadTests =+  testGroup+    "Arity overloading"+    [ testCase "foo/1 and foo/2 are distinct constraints" $ do+        prog <- compileOrFail [("m.chr", arityOverloadSource)]+        bindings1 <- runProgramWithGoal prog Map.empty "m:foo(R)"+        Map.lookup "R" bindings1 @?= Just (CompoundTerm (Unqualified "one") []),+      testCase "foo/2 fires its own rule" $ do+        prog <- compileOrFail [("m.chr", arityOverloadSource)]+        bindings2 <- runProgramWithGoal prog Map.empty "m:foo(R1, R2)"+        Map.lookup "R1" bindings2 @?= Just (CompoundTerm (Unqualified "two") [])+        Map.lookup "R2" bindings2 @?= Just (CompoundTerm (Unqualified "args") [])+    ]++-- ---------------------------------------------------------------------------+-- Multi-goal query body forms+-- ---------------------------------------------------------------------------+--+-- Most existing 'RunTest' cases exercise queries shaped like a single+-- @tell@ — they hit 'D.BodyTell' and the simple expression shapes inside+-- it, but leave the other 'executeBodyGoal' arms in 'YCHR.Run' (BodyTrue,+-- BodyUnify standalone, BodyHostStmt, BodyCall, BodyApply) and the+-- 'evalNestedExpr' shapes for ApplyExpr / FunRefExpr untouched. The cases+-- below pin each of those arms through the public 'runProgramWithQuery'+-- entry point, and pin the user-visible error messages for the runtime+-- unification-failure and unknown-host-function paths.+--+-- All cases assert on the final bindings or on the thrown exception —+-- no store/history introspection.++qbodySource :: Text+qbodySource =+  ":- module(qbody, [keep/1, fun triple/1]).\n\+  \:- chr_constraint keep/1.\n\+  \:- function triple/1.\n\+  \triple(X) -> host:'*'(X, 3).\n\+  \keep(_) <=> true.\n"++qbodyHostCalls :: HostCallRegistry+qbodyHostCalls =+  Map.fromList+    [ ( VM.Name "+",+        HostCallFn $ \args ->+          let (a, b) = extractIntArgs "+" args in pure (VInt (a + b))+      ),+      ( VM.Name "*",+        HostCallFn $ \args ->+          let (a, b) = extractIntArgs "*" args in pure (VInt (a * b))+      )+    ]++expectErrorContaining :: String -> IO a -> IO ()+expectErrorContaining needle act = do+  outcome <- try @SomeException act+  case outcome of+    Left exc ->+      assertBool+        ("expected exception message to contain " ++ show needle ++ ", got: " ++ show exc)+        (needle `isInfixOf` show exc)+    Right _ ->+      assertFailure ("expected exception containing " ++ show needle ++ ", got success")++queryBodyTests :: TestTree+queryBodyTests =+  testGroup+    "Query body forms"+    [ testCase "BodyTrue: 'true, R = 1' binds R" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        bindings <- runProgramWithQuery prog qbodyHostCalls "true, R = 1."+        Map.lookup "R" bindings @?= Just (IntTerm 1),+      testCase "BodyUnify chain: X = 1, Y = X, R = Y" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        bindings <- runProgramWithQuery prog qbodyHostCalls "X = 1, Y = X, R = Y."+        Map.lookup "R" bindings @?= Just (IntTerm 1),+      testCase "BodyUnify failure: 1 = 2 raises 'unification failure'" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        expectErrorContaining "unification failure" $+          runProgramWithQuery prog qbodyHostCalls "1 = 2.",+      testCase "BodyIs re-bind with matching value succeeds" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        bindings <- runProgramWithQuery prog qbodyHostCalls "R is 1, R is 1."+        Map.lookup "R" bindings @?= Just (IntTerm 1),+      testCase "BodyIs re-bind with conflicting value raises 'unification failure'" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        expectErrorContaining "unification failure" $+          runProgramWithQuery prog qbodyHostCalls "R is 1, R is 2.",+      testCase "BodyHostStmt: host:'+'(1, 2) as statement runs and is discarded" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        bindings <-+          runProgramWithQuery prog qbodyHostCalls "host:'+'(1, 2), R = ok."+        Map.lookup "R" bindings @?= Just (CompoundTerm (Unqualified "ok") []),+      testCase "BodyCall: triple(5) as statement runs and is discarded" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        bindings <- runProgramWithQuery prog qbodyHostCalls "triple(5), R = ok."+        Map.lookup "R" bindings @?= Just (CompoundTerm (Unqualified "ok") []),+      testCase "BodyApply: '$call'(F, X) as statement runs and is discarded" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        bindings <-+          runProgramWithQuery+            prog+            qbodyHostCalls+            "F = fun(X) -> X end, '$call'(F, 1), R = ok."+        Map.lookup "R" bindings @?= Just (CompoundTerm (Unqualified "ok") []),+      testCase "ApplyExpr in is: R is '$call'(fun triple/1, 4)" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        bindings <-+          runProgramWithQuery+            prog+            qbodyHostCalls+            "R is '$call'(fun triple/1, 4)."+        Map.lookup "R" bindings @?= Just (IntTerm 12),+      testCase "unknown host function raises 'Unknown host function'" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        expectErrorContaining "Unknown host function" $+          runProgramWithQuery prog qbodyHostCalls "R is host:nope(1).",+      testCase "BodyUnify with FloatExpr RHS binds R to FloatTerm" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        bindings <- runProgramWithQuery prog qbodyHostCalls "R = 1.5."+        Map.lookup "R" bindings @?= Just (FloatTerm 1.5),+      testCase "BodyUnify with TextExpr RHS binds R to TextTerm" $ do+        prog <- compileOrFail [("qbody.chr", qbodySource)]+        bindings <- runProgramWithQuery prog qbodyHostCalls "R = \"hello\"."+        Map.lookup "R" bindings @?= Just (TextTerm "hello")+    ]++-- ---------------------------------------------------------------------------+-- Guard runtime errors+-- ---------------------------------------------------------------------------+--+-- A guard expression that evaluates to a non-boolean is a runtime error. It+-- must render as a user-facing YCHR-60001 anchored at the rule's source+-- location (like other runtime errors), without leaking the internal VM+-- construct 'BFromVal'. Regression test for a fixed BUGS.md entry: the rule+-- frame is now pushed at occurrence-procedure entry so it is live during+-- guard evaluation.++guardNonBoolSource :: Text+guardNonBoolSource =+  ":- module(guardbug, [p/1]).\n\+  \:- chr_constraint p/1, q/0.\n\+  \:- function add1/1.\n\+  \add1(X) -> host:'+'(X, 1).\n\+  \p(X) <=> add1(X) | q.\n"++guardErrorTests :: TestTree+guardErrorTests =+  testGroup+    "Guard runtime errors"+    [ testCase "guard evaluating to a non-boolean renders a located YCHR-60001" $ do+        prog <- compileOrFail [("guardbug.chr", guardNonBoolSource)]+        outcome <-+          try @SomeException (runProgramWithGoal prog fibHostCalls "guardbug:p(1)")+        case outcome of+          Right _ -> assertFailure "expected a runtime error, got bindings"+          Left exc -> case fromException exc :: Maybe Error of+            Nothing -> assertFailure ("expected a YCHR Error, got: " ++ show exc)+            Just err -> do+              let rendered = displayMsg err+              assertBool ("expected YCHR-60001 in: " ++ rendered) $+                "YCHR-60001" `isInfixOf` rendered+              assertBool ("expected guard message in: " ++ rendered) $+                "guard did not evaluate to a boolean" `isInfixOf` rendered+              assertBool ("expected rule source location in: " ++ rendered) $+                "guardbug.chr:5:" `isInfixOf` rendered+              assertBool ("internal name BFromVal must not leak in: " ++ rendered) $+                not ("BFromVal" `isInfixOf` rendered)+    ]
+ test/YCHR/Runtime/HistoryTest.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.Runtime.HistoryTest (tests) where++import Control.Monad.IO.Class (liftIO)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import YCHR.Internal.Runtime.History+import YCHR.Internal.Runtime.Monad (Chr, initSessionEnv, runChr)+import YCHR.Internal.Runtime.Types (SuspensionId (..))+import YCHR.Internal.VM (RuleId (..))++tests :: TestTree+tests =+  testGroup+    "YCHR.Internal.Runtime.History"+    [ emptyTests,+      addTests,+      distinctionTests,+      miscTests+    ]++runHistoryEnv :: Chr a -> IO a+runHistoryEnv action = do+  env <- initSessionEnv [] [] Map.empty Map.empty Map.empty Map.empty Set.empty+  runChr action env++emptyTests :: TestTree+emptyTests =+  testGroup+    "empty history"+    [ testCase "notInHistory returns True" $ do+        r <- runHistoryEnv $ notInHistory (RuleId 1) [SuspensionId 0]+        r @?= True+    ]++addTests :: TestTree+addTests =+  testGroup+    "addHistory"+    [ testCase "same entry -> notInHistory returns False" $ do+        r <- runHistoryEnv $ do+          addHistory (RuleId 1) [SuspensionId 0, SuspensionId 1]+          notInHistory (RuleId 1) [SuspensionId 0, SuspensionId 1]+        r @?= False,+      testCase "duplicate addHistory is idempotent" $ do+        r <- runHistoryEnv $ do+          addHistory (RuleId 1) [SuspensionId 0]+          addHistory (RuleId 1) [SuspensionId 0]+          notInHistory (RuleId 1) [SuspensionId 0]+        r @?= False+    ]++distinctionTests :: TestTree+distinctionTests =+  testGroup+    "distinctness"+    [ testCase "different rule name -> True" $ do+        r <- runHistoryEnv $ do+          addHistory (RuleId 1) [SuspensionId 0]+          notInHistory (RuleId 2) [SuspensionId 0]+        r @?= True,+      testCase "different IDs -> True" $ do+        r <- runHistoryEnv $ do+          addHistory (RuleId 1) [SuspensionId 0]+          notInHistory (RuleId 1) [SuspensionId 1]+        r @?= True,+      testCase "different ID order -> True" $ do+        r <- runHistoryEnv $ do+          addHistory (RuleId 1) [SuspensionId 0, SuspensionId 1]+          notInHistory (RuleId 1) [SuspensionId 1, SuspensionId 0]+        r @?= True+    ]++miscTests :: TestTree+miscTests =+  testGroup+    "misc"+    [ testCase "multiple independent entries" $ do+        runHistoryEnv $ do+          addHistory (RuleId 1) [SuspensionId 0]+          addHistory (RuleId 2) [SuspensionId 1]+          r1 <- notInHistory (RuleId 1) [SuspensionId 0]+          r2 <- notInHistory (RuleId 2) [SuspensionId 1]+          r3 <- notInHistory (RuleId 1) [SuspensionId 1]+          liftIO $ r1 @?= False+          liftIO $ r2 @?= False+          liftIO $ r3 @?= True,+      testCase "empty ID list works" $ do+        runHistoryEnv $ do+          r1 <- notInHistory (RuleId 1) []+          liftIO $ r1 @?= True+          addHistory (RuleId 1) []+          r2 <- notInHistory (RuleId 1) []+          liftIO $ r2 @?= False+    ]
+ test/YCHR/Runtime/InterpreterTest.hs view
@@ -0,0 +1,1021 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.Runtime.InterpreterTest (tests) where++import Control.Exception (try)+import Control.Monad.IO.Class (liftIO)+import Data.Foldable (toList)+import Data.List (isInfixOf)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import YCHR.Internal.Runtime.Error (RuntimeErrorThrown (..))+import YCHR.Internal.Runtime.Interpreter+  ( HostCallFn (..),+    HostCallRegistry,+    baseHostCallRegistry,+    bindParams,+    callProc,+    interpret,+  )+import YCHR.Internal.Runtime.Monad (Chr, initSessionEnv, runChr)+import YCHR.Internal.Runtime.Store (getStoreSnapshot, isSuspAlive)+import YCHR.Internal.Runtime.Types (CallVal (..), SuspensionId (..), Value (..))+import YCHR.Internal.Runtime.Var (equal, newVar, unify)+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM++tests :: TestTree+tests =+  testGroup+    "YCHR.Internal.Runtime.Interpreter"+    [ leqTests,+      evalDeepTests,+      typePredicateTests,+      univTests,+      bindParamsTests,+      errorPathTests+    ]++-- ---------------------------------------------------------------------------+-- Session helpers+-- ---------------------------------------------------------------------------++-- | Run a Chr action with an empty session (no procedures, no types,+-- no host calls). Useful for tests that exercise primitives that only+-- need 'Unify' / store / queue, where the session is set up just to+-- give them a place to live.+runChrEmpty :: Chr a -> IO a+runChrEmpty action = do+  env <- initSessionEnv [] [] Map.empty Map.empty Map.empty Map.empty Set.empty+  runChr action env++-- | Like 'runChrEmpty' but with the base host-call registry available.+runChrBase :: Chr a -> IO a+runChrBase action = do+  env <- initSessionEnv [] [] Map.empty baseHostCallRegistry Map.empty Map.empty Set.empty+  runChr action env++-- | Run a Chr action against the LEQ session.+runChrLeq :: Chr a -> IO a+runChrLeq action = do+  env <-+    initSessionEnv+      [Types.Unqualified "leq"]+      []+      leqProcMap+      Map.empty+      Map.empty+      Map.empty+      Set.empty+  runChr action env++-- ---------------------------------------------------------------------------+-- Runtime-error trigger tests+-- ---------------------------------------------------------------------------++-- | Run a single-procedure VM program and expect a 'RuntimeErrorThrown'.+expectRuntimeError :: Program -> Name -> [Value] -> IO String+expectRuntimeError prog entry args = do+  outcome <- try @RuntimeErrorThrown (interpret prog Map.empty entry args)+  case outcome of+    Left (RuntimeErrorThrown msg _stack) -> pure msg+    Right _ -> assertFailure "expected RuntimeErrorThrown, got a value"++singleProc :: Name -> [Name] -> [Stmt] -> Program+singleProc procName params body =+  Program+    { numTypes = 0,+      typeNames = [],+      numRules = 0,+      ruleNames = [],+      procedures = [mkProc procName params body],+      evaluables = []+    }++-- | Build a 'Procedure' with a placeholder 'procKind'. The kind tag+-- isn't observable by the interpreter tests (they exercise call /+-- store / unify behaviour, not tracing), so a single neutral+-- 'PKReactivateDispatch' keeps the test fixtures terse.+mkProc :: Name -> [Name] -> [Stmt] -> Procedure+mkProc n ps body =+  Procedure+    { name = n,+      params = ps,+      body = body,+      procKind = PKReactivateDispatch+    }++errorPathTests :: TestTree+errorPathTests =+  testGroup+    "runtime error paths"+    [ testCase "BFromVal on a non-bool value reports a guard error" $ do+        let prog =+              singleProc+                "p"+                []+                [ BoolExprStmt (BFromVal (Lit (IntLit 42))),+                  Return (Lit (BoolLit False))+                ]+        msg <- expectRuntimeError prog "p" []+        assertBool ("expected 'guard did not evaluate to a boolean' in: " ++ msg) $+          "guard did not evaluate to a boolean" `isInfixOf` msg,+      testCase "Break with a label no enclosing Foreach catches escapes" $ do+        let prog =+              singleProc+                "p"+                []+                [Break (Label "missing"), Return (Lit (BoolLit False))]+        msg <- expectRuntimeError prog "p" []+        assertBool ("expected 'uncaught Break' in: " ++ msg) $+          "uncaught Break" `isInfixOf` msg+        assertBool ("expected label 'missing' in: " ++ msg) $+          "missing" `isInfixOf` msg,+      testCase "Continue with a label no enclosing Foreach catches escapes" $ do+        let prog =+              singleProc+                "p"+                []+                [Continue (Label "nope"), Return (Lit (BoolLit False))]+        msg <- expectRuntimeError prog "p" []+        assertBool ("expected 'uncaught Continue' in: " ++ msg) $+          "uncaught Continue" `isInfixOf` msg+        assertBool ("expected label 'nope' in: " ++ msg) $+          "nope" `isInfixOf` msg,+      testCase "CallExpr targeting an unknown procedure errors with its name" $ do+        let prog =+              singleProc+                "p"+                []+                [ ExprStmt (CallExpr "no_such_proc" []),+                  Return (Lit (BoolLit False))+                ]+        msg <- expectRuntimeError prog "p" []+        assertBool ("expected 'unknown procedure' in: " ++ msg) $+          "unknown procedure" `isInfixOf` msg+        assertBool ("expected the missing name in: " ++ msg) $+          "no_such_proc" `isInfixOf` msg,+      testCase "evaluating an unbound named variable errors with its name" $ do+        let prog =+              singleProc+                "p"+                []+                [Return (Var "missing")]+        msg <- expectRuntimeError prog "p" []+        assertBool ("expected 'unbound variable' in: " ++ msg) $+          "unbound variable" `isInfixOf` msg+        assertBool ("expected the missing name in: " ++ msg) $+          "missing" `isInfixOf` msg,+      testCase "EvalDeep of an unbound fresh variable returns the variable itself" $ do+        let prog =+              singleProc+                "p"+                []+                [ LetVal "v" NewVar,+                  Return (EvalDeep (Var "v"))+                ]+        result <- interpret prog Map.empty "p" []+        case result of+          VVar _ -> pure ()+          _ -> assertFailure "expected VVar, got something else"+    ]++bindParamsTests :: TestTree+bindParamsTests =+  testGroup+    "bindParams"+    [ testCase "matching arity returns Right" $+        case bindParams "p" ["x", "y"] [CVal (VInt 1), CVal (VInt 2)] of+          Right _ -> pure ()+          Left msg -> assertFailure ("expected Right, got Left: " ++ msg),+      testCase "too few args returns Left with proc name" $+        case bindParams "myProc" ["x", "y"] [CVal (VInt 1)] of+          Left msg -> do+            assertBool ("missing arity-mismatch text in: " ++ msg) $+              "arity mismatch" `isInfixOf` msg+            assertBool ("missing proc name in: " ++ msg) $+              "myProc" `isInfixOf` msg+          Right _ -> assertFailure "expected Left",+      testCase "too many args returns Left" $+        case bindParams "p" ["x"] [CVal (VInt 1), CVal (VInt 2)] of+          Left msg ->+            assertBool ("missing arity-mismatch text in: " ++ msg) $+              "arity mismatch" `isInfixOf` msg+          Right _ -> assertFailure "expected Left",+      testCase "mixed-kind args bind by tag" $+        case bindParams "p" ["v", "i"] [CVal (VInt 7), CId (SuspensionId 3)] of+          Right _ -> pure ()+          Left msg -> assertFailure ("expected Right, got Left: " ++ msg)+    ]++-- ---------------------------------------------------------------------------+-- LEQ VM program+-- ---------------------------------------------------------------------------++leqType :: ConstraintType+leqType = ConstraintType 0++leqProgram :: Program+leqProgram =+  Program+    { numTypes = 1,+      typeNames = [Types.Unqualified "leq"],+      numRules = 1,+      ruleNames = ["transitivity"],+      evaluables = [],+      procedures =+        [ tellLeq,+          activateLeq,+          occurrenceLeq1,+          occurrenceLeq2,+          occurrenceLeq3,+          occurrenceLeq4,+          occurrenceLeq5,+          occurrenceLeq6,+          occurrenceLeq7,+          reactivateDispatch+        ]+    }++leqProcMap :: Map.Map Name Procedure+leqProcMap =+  Map.fromList [(p.name, p) | p <- leqProgram.procedures]++tellLeq :: Procedure+tellLeq =+  mkProc+    "tell_leq2"+    ["X", "Y"]+    [ LetId "id" (CreateConstraint leqType [Var "X", Var "Y"]),+      Store (IdVar "id"),+      ExprStmt (CallExpr "activate_leq2" [AId (IdVar "id")])+    ]++activateLeq :: Procedure+activateLeq =+  mkProc+    "activate_leq2"+    ["susp"]+    [ LetId "id" (IdVar "susp"),+      LetVal "X" (FieldArg (IdVar "susp") (ArgIndex 0)),+      LetVal "Y" (FieldArg (IdVar "susp") (ArgIndex 1)),+      LetVal "d" (CallExpr "occurrence_leq2_1" occCallArgs),+      If (BFromVal (Var "d")) [Return (Lit (BoolLit True))] [],+      LetVal "d" (CallExpr "occurrence_leq2_2" occCallArgs),+      If (BFromVal (Var "d")) [Return (Lit (BoolLit True))] [],+      LetVal "d" (CallExpr "occurrence_leq2_3" occCallArgs),+      If (BFromVal (Var "d")) [Return (Lit (BoolLit True))] [],+      LetVal "d" (CallExpr "occurrence_leq2_4" occCallArgs),+      If (BFromVal (Var "d")) [Return (Lit (BoolLit True))] [],+      LetVal "d" (CallExpr "occurrence_leq2_5" occCallArgs),+      If (BFromVal (Var "d")) [Return (Lit (BoolLit True))] [],+      LetVal "d" (CallExpr "occurrence_leq2_6" occCallArgs),+      If (BFromVal (Var "d")) [Return (Lit (BoolLit True))] [],+      LetVal "d" (CallExpr "occurrence_leq2_7" occCallArgs),+      If (BFromVal (Var "d")) [Return (Lit (BoolLit True))] [],+      Return (Lit (BoolLit False))+    ]+  where+    occCallArgs = [AId (IdVar "id"), AVal (Var "X"), AVal (Var "Y")]++occurrenceLeq1 :: Procedure+occurrenceLeq1 =+  mkProc+    "occurrence_leq2_1"+    ["id", "X", "Y"]+    [ If+        (BEqual (Var "X") (Var "Y"))+        [ Kill (IdVar "id"),+          Return (Lit (BoolLit True))+        ]+        [],+      Return (Lit (BoolLit False))+    ]++occurrenceLeq2 :: Procedure+occurrenceLeq2 =+  mkProc+    "occurrence_leq2_2"+    ["id", "X", "Y"]+    [ Foreach+        "L1"+        leqType+        "susp"+        []+        [ LetId "pId" (IdVar "susp"),+          LetVal "pA0" (FieldArg (IdVar "susp") (ArgIndex 0)),+          LetVal "pA1" (FieldArg (IdVar "susp") (ArgIndex 1)),+          If+            (BAnd (BAlive (IdVar "id")) (BAlive (IdVar "pId")))+            [ If+                (BNot (BIdEqual (IdVar "pId") (IdVar "id")))+                [ If+                    ( BAnd+                        (BEqual (Var "pA0") (Var "Y"))+                        (BEqual (Var "pA1") (Var "X"))+                    )+                    [ Kill (IdVar "pId"),+                      Kill (IdVar "id"),+                      BoolExprStmt (BUnify (Var "pA0") (Var "pA1")),+                      DrainReactivationQueue+                        "rs"+                        [ExprStmt (CallExpr "reactivate_dispatch" [AId (IdVar "rs")])],+                      Return (Lit (BoolLit True))+                    ]+                    []+                ]+                []+            ]+            []+        ],+      Return (Lit (BoolLit False))+    ]++occurrenceLeq3 :: Procedure+occurrenceLeq3 =+  mkProc+    "occurrence_leq2_3"+    ["id", "X", "Y"]+    [ Foreach+        "L1"+        leqType+        "susp"+        []+        [ LetId "pId" (IdVar "susp"),+          LetVal "pA0" (FieldArg (IdVar "susp") (ArgIndex 0)),+          LetVal "pA1" (FieldArg (IdVar "susp") (ArgIndex 1)),+          If+            (BAnd (BAlive (IdVar "id")) (BAlive (IdVar "pId")))+            [ If+                (BNot (BIdEqual (IdVar "pId") (IdVar "id")))+                [ If+                    ( BAnd+                        (BEqual (Var "X") (Var "pA1"))+                        (BEqual (Var "Y") (Var "pA0"))+                    )+                    [ Kill (IdVar "pId"),+                      Kill (IdVar "id"),+                      BoolExprStmt (BUnify (Var "X") (Var "Y")),+                      DrainReactivationQueue+                        "rs"+                        [ExprStmt (CallExpr "reactivate_dispatch" [AId (IdVar "rs")])],+                      Return (Lit (BoolLit True))+                    ]+                    []+                ]+                []+            ]+            []+        ],+      Return (Lit (BoolLit False))+    ]++occurrenceLeq4 :: Procedure+occurrenceLeq4 =+  mkProc+    "occurrence_leq2_4"+    ["id", "X", "Y"]+    [ Foreach+        "L1"+        leqType+        "susp"+        []+        [ LetId "pId" (IdVar "susp"),+          LetVal "pA0" (FieldArg (IdVar "susp") (ArgIndex 0)),+          LetVal "pA1" (FieldArg (IdVar "susp") (ArgIndex 1)),+          If+            (BAnd (BAlive (IdVar "id")) (BAlive (IdVar "pId")))+            [ If+                (BNot (BIdEqual (IdVar "pId") (IdVar "id")))+                [ If+                    ( BAnd+                        (BEqual (Var "pA0") (Var "X"))+                        (BEqual (Var "pA1") (Var "Y"))+                    )+                    [ Kill (IdVar "id"),+                      Return (Lit (BoolLit True))+                    ]+                    []+                ]+                []+            ]+            []+        ],+      Return (Lit (BoolLit False))+    ]++occurrenceLeq5 :: Procedure+occurrenceLeq5 =+  mkProc+    "occurrence_leq2_5"+    ["id", "X", "Y"]+    [ Foreach+        "L1"+        leqType+        "susp"+        []+        [ LetId "pId" (IdVar "susp"),+          LetVal "pA0" (FieldArg (IdVar "susp") (ArgIndex 0)),+          LetVal "pA1" (FieldArg (IdVar "susp") (ArgIndex 1)),+          If+            (BAnd (BAlive (IdVar "id")) (BAlive (IdVar "pId")))+            [ If+                (BNot (BIdEqual (IdVar "pId") (IdVar "id")))+                [ If+                    ( BAnd+                        (BEqual (Var "X") (Var "pA0"))+                        (BEqual (Var "Y") (Var "pA1"))+                    )+                    [Kill (IdVar "pId")]+                    []+                ]+                []+            ]+            []+        ],+      Return (Lit (BoolLit False))+    ]++occurrenceLeq6 :: Procedure+occurrenceLeq6 =+  mkProc+    "occurrence_leq2_6"+    ["id", "X", "Y"]+    [ Foreach+        "L1"+        leqType+        "susp"+        []+        [ LetId "pId" (IdVar "susp"),+          LetVal "pA0" (FieldArg (IdVar "susp") (ArgIndex 0)),+          LetVal "pA1" (FieldArg (IdVar "susp") (ArgIndex 1)),+          If+            (BAnd (BAlive (IdVar "id")) (BAlive (IdVar "pId")))+            [ If+                (BNot (BIdEqual (IdVar "pId") (IdVar "id")))+                [ If+                    (BEqual (Var "pA1") (Var "X"))+                    [ If+                        (BNotInHistory (RuleId 0) [IdVar "pId", IdVar "id"])+                        [ AddHistory (RuleId 0) [IdVar "pId", IdVar "id"],+                          ExprStmt+                            ( CallExpr+                                "tell_leq2"+                                [AVal (Var "pA0"), AVal (Var "Y")]+                            ),+                          If+                            (BNot (BAlive (IdVar "id")))+                            [Return (Lit (BoolLit True))]+                            []+                        ]+                        []+                    ]+                    []+                ]+                []+            ]+            []+        ],+      Return (Lit (BoolLit False))+    ]++occurrenceLeq7 :: Procedure+occurrenceLeq7 =+  mkProc+    "occurrence_leq2_7"+    ["id", "X", "Y"]+    [ Foreach+        "L1"+        leqType+        "susp"+        []+        [ LetId "pId" (IdVar "susp"),+          LetVal "pA0" (FieldArg (IdVar "susp") (ArgIndex 0)),+          LetVal "pA1" (FieldArg (IdVar "susp") (ArgIndex 1)),+          If+            (BAnd (BAlive (IdVar "id")) (BAlive (IdVar "pId")))+            [ If+                (BNot (BIdEqual (IdVar "pId") (IdVar "id")))+                [ If+                    (BEqual (Var "pA0") (Var "Y"))+                    [ If+                        (BNotInHistory (RuleId 0) [IdVar "id", IdVar "pId"])+                        [ AddHistory (RuleId 0) [IdVar "id", IdVar "pId"],+                          ExprStmt+                            ( CallExpr+                                "tell_leq2"+                                [AVal (Var "X"), AVal (Var "pA1")]+                            ),+                          If+                            (BNot (BAlive (IdVar "id")))+                            [Return (Lit (BoolLit True))]+                            []+                        ]+                        []+                    ]+                    []+                ]+                []+            ]+            []+        ],+      Return (Lit (BoolLit False))+    ]++reactivateDispatch :: Procedure+reactivateDispatch =+  mkProc+    "reactivate_dispatch"+    ["susp"]+    [ If+        (BIsConstraintType (IdVar "susp") leqType)+        [ExprStmt (CallExpr "activate_leq2" [AId (IdVar "susp")])]+        []+    ]++-- ---------------------------------------------------------------------------+-- Test helpers+-- ---------------------------------------------------------------------------++countAlive :: ConstraintType -> Chr Int+countAlive cType = do+  snapshot <- getStoreSnapshot cType+  alives <- traverse isSuspAlive (toList snapshot)+  pure (length (filter id alives))++callTellLeq :: Value -> Value -> Chr Value+callTellLeq x y =+  callProc "tell_leq2" [CVal x, CVal y]++-- ---------------------------------------------------------------------------+-- Tests+-- ---------------------------------------------------------------------------++leqTests :: TestTree+leqTests =+  testGroup+    "LEQ handler"+    [ testCase "reflexivity: leq(3, 3) fires, store empty" $ do+        n <- runChrLeq $ do+          _ <- callTellLeq (VInt 3) (VInt 3)+          countAlive leqType+        n @?= 0,+      testCase "no rule fires: leq(1, 2) stays" $ do+        n <- runChrLeq $ do+          _ <- callTellLeq (VInt 1) (VInt 2)+          countAlive leqType+        n @?= 1,+      testCase "antisymmetry: leq(X, Y), leq(Y, X) unifies X=Y, store empty" $ do+        (n, areEqual) <- runChrLeq $ do+          x <- newVar+          y <- newVar+          _ <- callTellLeq x y+          _ <- callTellLeq y x+          n <- countAlive leqType+          eq <- equal x y+          pure (n, eq)+        n @?= 0+        assertBool "X and Y should be unified" areEqual,+      testCase "transitivity: leq(1,2), leq(2,3) produces leq(1,3)" $ do+        n <- runChrLeq $ do+          _ <- callTellLeq (VInt 1) (VInt 2)+          _ <- callTellLeq (VInt 2) (VInt 3)+          countAlive leqType+        n @?= 3,+      testCase "idempotence: leq(1,2), leq(1,2) removes duplicate" $ do+        n <- runChrLeq $ do+          _ <- callTellLeq (VInt 1) (VInt 2)+          _ <- callTellLeq (VInt 1) (VInt 2)+          countAlive leqType+        n @?= 1,+      testCase "full cycle: leq(a,b), leq(b,c), leq(c,a) — all removed, all unified" $ do+        (n, eqAB, eqBC) <- runChrLeq $ do+          a <- newVar+          b <- newVar+          c <- newVar+          _ <- callTellLeq a b+          _ <- callTellLeq b c+          _ <- callTellLeq c a+          n <- countAlive leqType+          eqAB <- equal a b+          eqBC <- equal b c+          pure (n, eqAB, eqBC)+        n @?= 0+        assertBool "a and b should be unified" eqAB+        assertBool "b and c should be unified" eqBC+    ]++-- ---------------------------------------------------------------------------+-- EvalDeep tests+-- ---------------------------------------------------------------------------++arithCalls :: HostCallRegistry+arithCalls =+  Map.fromList+    [ ( "+",+        HostCallFn $ \args -> case args of+          [VInt a, VInt b] -> pure (VInt (a + b))+          _ -> liftIO (assertFailure "unexpected args to +")+      ),+      ( "*",+        HostCallFn $ \args -> case args of+          [VInt a, VInt b] -> pure (VInt (a * b))+          _ -> liftIO (assertFailure "unexpected args to *")+      )+    ]++makeCalcProc :: ValExpr -> Program+makeCalcProc body =+  Program+    { numTypes = 0,+      typeNames = [],+      numRules = 0,+      ruleNames = [],+      evaluables = [],+      procedures =+        [ mkProc+            "calc"+            ["x"]+            [ LetVal "y" (EvalDeep body),+              Return (Var "y")+            ]+        ]+    }++runCalc :: ValExpr -> Value -> IO Value+runCalc body x = interpret (makeCalcProc body) arithCalls "calc" [x]++expectInt :: Value -> IO Integer+expectInt (VInt n) = pure n+expectInt _ = assertFailure "expected VInt _"++evalDeepTests :: TestTree+evalDeepTests =+  testGroup+    "EvalDeep"+    [ testCase "flat: +(2, 3) = 5" $ do+        result <- runCalc (HostCall "+" [Lit (IntLit 2), Lit (IntLit 3)]) (VInt 0)+        expectInt result >>= (@?= 5),+      testCase "variable: x + 1, x=5 = 6" $ do+        result <- runCalc (HostCall "+" [Var "x", Lit (IntLit 1)]) (VInt 5)+        expectInt result >>= (@?= 6),+      testCase "nested: 2 * (x + 3), x=4 = 14" $ do+        result <-+          runCalc+            ( HostCall+                "*"+                [ Lit (IntLit 2),+                  HostCall+                    "+"+                    [ Var "x",+                      Lit (IntLit 3)+                    ]+                ]+            )+            (VInt 4)+        expectInt result >>= (@?= 14),+      testCase "literal passthrough: 42 = 42" $ do+        result <- runCalc (Lit (IntLit 42)) (VInt 0)+        expectInt result >>= (@?= 42)+    ]++-- ---------------------------------------------------------------------------+-- Type predicate tests+-- ---------------------------------------------------------------------------++-- | Call a base host call by name on a single Value, returning the result.+callBaseHC :: Name -> Value -> IO Value+callBaseHC name v = case Map.lookup name baseHostCallRegistry of+  Nothing -> assertFailure $ "host call not found: " ++ show name+  Just (HostCallFn f) -> runChrBase (f [v])++-- | Call a single-argument predicate, expecting a Bool.+callTypePred :: Name -> Value -> IO Bool+callTypePred name v = do+  result <- callBaseHC name v+  case result of+    VBool b -> pure b+    _ -> assertFailure $ show name ++ ": expected Bool result"++-- | Lookup a HostCallFn from the base registry, calling 'assertFailure'+-- if not found.+findBaseHC :: Name -> IO HostCallFn+findBaseHC name = case Map.lookup name baseHostCallRegistry of+  Nothing -> assertFailure $ "host call not found: " ++ show name+  Just fn -> pure fn++-- | Call 'term_variables' on a value, returning the resulting list value.+callTermVars :: Value -> IO Value+callTermVars v = do+  HostCallFn f <- findBaseHC (Name "term_variables")+  runChrBase (f [v])++-- | Variant inside a 'Chr' computation that already has a session set up.+callTermVarsChr :: Value -> Chr Value+callTermVarsChr v = case Map.lookup (Name "term_variables") baseHostCallRegistry of+  Nothing -> error "term_variables not found in registry"+  Just (HostCallFn f) -> f [v]++typePredicateTests :: TestTree+typePredicateTests =+  testGroup+    "Type predicates"+    [ testCase "integer: true for VInt" $ do+        b <- callTypePred "integer" (VInt 42)+        assertBool "expected true" b,+      testCase "integer: false for VAtom" $ do+        b <- callTypePred "integer" (VAtom "hello")+        assertBool "expected false" (not b),+      testCase "atom: true for VAtom" $ do+        b <- callTypePred "atom" (VAtom "hello")+        assertBool "expected true" b,+      testCase "atom: false for VInt" $ do+        b <- callTypePred "atom" (VInt 1)+        assertBool "expected false" (not b),+      testCase "boolean: true for VBool" $ do+        b <- callTypePred "boolean" (VBool True)+        assertBool "expected true" b,+      testCase "boolean: false for VAtom" $ do+        b <- callTypePred "boolean" (VAtom "true")+        assertBool "expected false" (not b),+      testCase "string: true for VText" $ do+        b <- callTypePred "string" (VText "hello")+        assertBool "expected true" b,+      testCase "string: false for VAtom" $ do+        b <- callTypePred "string" (VAtom "hello")+        assertBool "expected false" (not b),+      testCase "var: true for unbound variable" $ do+        b <- runChrBase $ do+          v <- newVar+          HostCallFn f <- case Map.lookup (Name "var") baseHostCallRegistry of+            Just hc -> pure hc+            Nothing -> error "var not found"+          result <- f [v]+          case result of+            VBool b' -> pure b'+            _ -> pure False+        assertBool "expected true" b,+      testCase "var: false for bound variable" $ do+        b <- runChrBase $ do+          v <- newVar+          _ <- unify v (VInt 42)+          HostCallFn f <- case Map.lookup (Name "var") baseHostCallRegistry of+            Just hc -> pure hc+            Nothing -> error "var not found"+          result <- f [v]+          case result of+            VBool b' -> pure b'+            _ -> pure False+        assertBool "expected false" (not b),+      testCase "var: false for ground value" $ do+        b <- callTypePred "var" (VInt 42)+        assertBool "expected false" (not b),+      testCase "nonvar: false for unbound variable" $ do+        b <- runChrBase $ do+          v <- newVar+          HostCallFn f <- case Map.lookup (Name "nonvar") baseHostCallRegistry of+            Just hc -> pure hc+            Nothing -> error "nonvar not found"+          result <- f [v]+          case result of+            VBool b' -> pure b'+            _ -> pure False+        assertBool "expected false" (not b),+      testCase "nonvar: true for bound variable" $ do+        b <- runChrBase $ do+          v <- newVar+          _ <- unify v (VInt 42)+          HostCallFn f <- case Map.lookup (Name "nonvar") baseHostCallRegistry of+            Just hc -> pure hc+            Nothing -> error "nonvar not found"+          result <- f [v]+          case result of+            VBool b' -> pure b'+            _ -> pure False+        assertBool "expected true" b,+      testCase "nonvar: true for ground value" $ do+        b <- callTypePred "nonvar" (VInt 42)+        assertBool "expected true" b,+      testCase "ground: true for integer" $ do+        b <- callTypePred "ground" (VInt 42)+        assertBool "expected true" b,+      testCase "ground: true for atom" $ do+        b <- callTypePred "ground" (VAtom "hello")+        assertBool "expected true" b,+      testCase "ground: true for ground compound" $ do+        b <- callTypePred "ground" (VTerm "f" [VInt 1, VAtom "hello"])+        assertBool "expected true" b,+      testCase "ground: false for unbound variable" $ do+        b <- runChrBase $ do+          v <- newVar+          HostCallFn f <- case Map.lookup (Name "ground") baseHostCallRegistry of+            Just hc -> pure hc+            Nothing -> error "ground not found"+          result <- f [v]+          case result of+            VBool b' -> pure b'+            _ -> pure True+        assertBool "expected false" (not b),+      testCase "ground: false for compound with unbound var" $ do+        b <- runChrBase $ do+          v <- newVar+          HostCallFn f <- case Map.lookup (Name "ground") baseHostCallRegistry of+            Just hc -> pure hc+            Nothing -> error "ground not found"+          result <- f [VTerm "f" [VInt 1, v]]+          case result of+            VBool b' -> pure b'+            _ -> pure True+        assertBool "expected false" (not b),+      testCase "ground: true for compound with bound var" $ do+        b <- runChrBase $ do+          v <- newVar+          _ <- unify v (VInt 2)+          HostCallFn f <- case Map.lookup (Name "ground") baseHostCallRegistry of+            Just hc -> pure hc+            Nothing -> error "ground not found"+          result <- f [VTerm "f" [VInt 1, v]]+          case result of+            VBool b' -> pure b'+            _ -> pure True+        assertBool "expected true" b,+      testCase "ground: false for wildcard" $ do+        b <- callTypePred "ground" VWildcard+        assertBool "expected false" (not b),+      testCase "term_variables: ground term yields empty list" $ do+        result <- callTermVars (VTerm "f" [VInt 1, VAtom "hello"])+        case result of+          VAtom "prelude__[]" -> pure ()+          _ -> assertFailure "expected empty list",+      testCase "term_variables: integer yields empty list" $ do+        result <- callTermVars (VInt 42)+        case result of+          VAtom "prelude__[]" -> pure ()+          _ -> assertFailure "expected empty list",+      testCase "term_variables: unbound var yields singleton list" $ do+        (isSingleton, sameVar) <- runChrBase $ do+          v <- newVar+          result <- callTermVarsChr v+          case result of+            VTerm "prelude__." [x, VAtom "prelude__[]"] -> do+              eq <- equal x v+              pure (True, eq)+            _ -> pure (False, False)+        assertBool "expected singleton list" isSingleton+        assertBool "list element should be same variable" sameVar,+      testCase "term_variables: duplicate var appears once" $ do+        (len, sameVar) <- runChrBase $ do+          v <- newVar+          result <- callTermVarsChr (VTerm "f" [v, v])+          case result of+            VTerm "prelude__." [x, VAtom "prelude__[]"] -> do+              eq <- equal x v+              pure (1 :: Int, eq)+            _ -> pure (0, False)+        len @?= 1+        assertBool "list element should be same variable" sameVar,+      testCase "term_variables: two distinct vars in order" $ do+        (len, eq1, eq2) <- runChrBase $ do+          x <- newVar+          y <- newVar+          result <- callTermVarsChr (VTerm "f" [x, y])+          case result of+            VTerm "prelude__." [a, VTerm "prelude__." [b, VAtom "prelude__[]"]] -> do+              e1 <- equal a x+              e2 <- equal b y+              pure (2 :: Int, e1, e2)+            _ -> pure (0, False, False)+        len @?= 2+        assertBool "first element should be X" eq1+        assertBool "second element should be Y" eq2,+      testCase "term_variables: wildcard produces fresh var" $ do+        result <- runChrBase $ callTermVarsChr VWildcard+        case result of+          VTerm "prelude__." [_, VAtom "prelude__[]"] -> pure ()+          _ -> assertFailure "expected singleton list",+      testCase "term_variables: nested compound" $ do+        (len, eq1, eq2) <- runChrBase $ do+          x <- newVar+          y <- newVar+          result <- callTermVarsChr (VTerm "f" [VTerm "g" [x, VInt 1], y])+          case result of+            VTerm "prelude__." [a, VTerm "prelude__." [b, VAtom "prelude__[]"]] -> do+              e1 <- equal a x+              e2 <- equal b y+              pure (2 :: Int, e1, e2)+            _ -> pure (0, False, False)+        len @?= 2+        assertBool "first element should be X" eq1+        assertBool "second element should be Y" eq2,+      testCase "unifiable: true for two equal integers" $ do+        b <- callUnifiable (VInt 1) (VInt 1)+        assertBool "expected true" b,+      testCase "unifiable: false for distinct integers" $ do+        b <- callUnifiable (VInt 1) (VInt 2)+        assertBool "expected false" (not b)+    ]+  where+    callUnifiable a b = case Map.lookup (Name "unifiable") baseHostCallRegistry of+      Nothing -> assertFailure "unifiable not found in registry"+      Just (HostCallFn f) -> do+        result <- runChrEmpty (f [a, b])+        case result of+          VBool b' -> pure b'+          _ -> assertFailure "unifiable: expected Bool result"++-- ---------------------------------------------------------------------------+-- =.. (univ) tests+-- ---------------------------------------------------------------------------++callHostCall1 :: Name -> Value -> IO Value+callHostCall1 name v = case Map.lookup name baseHostCallRegistry of+  Nothing -> assertFailure $ "host call not found: " ++ show name+  Just (HostCallFn f) -> runChrEmpty (f [v])++univTests :: TestTree+univTests =+  testGroup+    "compound_to_list / list_to_compound"+    [ testCase "compound_to_list: f(1, 2) -> [f, 1, 2]" $ do+        result <- callHostCall1 "compound_to_list" (VTerm "f" [VInt 1, VInt 2])+        case result of+          VTerm+            "prelude__."+            [ VAtom "f",+              VTerm+                "prelude__."+                [ VInt 1,+                  VTerm "prelude__." [VInt 2, VAtom "prelude__[]"]+                  ]+              ] -> pure ()+          _ -> assertFailure "unexpected result",+      testCase "compound_to_list: g(hello) -> [g, hello]" $ do+        result <- callHostCall1 "compound_to_list" (VTerm "g" [VAtom "hello"])+        case result of+          VTerm+            "prelude__."+            [ VAtom "g",+              VTerm+                "prelude__."+                [ VAtom "hello",+                  VAtom "prelude__[]"+                  ]+              ] -> pure ()+          _ -> assertFailure "unexpected result",+      testCase "compound_to_list: foo() -> [foo]" $ do+        result <- callHostCall1 "compound_to_list" (VTerm "foo" [])+        case result of+          VTerm "prelude__." [VAtom "foo", VAtom "prelude__[]"] -> pure ()+          _ -> assertFailure "unexpected result",+      testCase "compound_to_list: f(g(1), 2) -> [f, g(1), 2]" $ do+        result <- callHostCall1 "compound_to_list" (VTerm "f" [VTerm "g" [VInt 1], VInt 2])+        case result of+          VTerm+            "prelude__."+            [ VAtom "f",+              VTerm+                "prelude__."+                [ VTerm "g" [VInt 1],+                  VTerm "prelude__." [VInt 2, VAtom "prelude__[]"]+                  ]+              ] -> pure ()+          _ -> assertFailure "unexpected result",+      testCase "list_to_compound: [f, 1, 2] -> f(1, 2)" $ do+        let list =+              VTerm+                "prelude__."+                [ VAtom "f",+                  VTerm+                    "prelude__."+                    [ VInt 1,+                      VTerm "prelude__." [VInt 2, VAtom "prelude__[]"]+                    ]+                ]+        result <- callHostCall1 "list_to_compound" list+        case result of+          VTerm "f" [VInt 1, VInt 2] -> pure ()+          _ -> assertFailure "unexpected result",+      testCase "list_to_compound: [foo] -> foo (atom)" $ do+        let list = VTerm "prelude__." [VAtom "foo", VAtom "prelude__[]"]+        result <- callHostCall1 "list_to_compound" list+        case result of+          VAtom "foo" -> pure ()+          _ -> assertFailure "unexpected result",+      testCase "list_to_compound: [g, hello] -> g(hello)" $ do+        let list =+              VTerm+                "prelude__."+                [ VAtom "g",+                  VTerm+                    "prelude__."+                    [ VAtom "hello",+                      VAtom "prelude__[]"+                    ]+                ]+        result <- callHostCall1 "list_to_compound" list+        case result of+          VTerm "g" [VAtom "hello"] -> pure ()+          _ -> assertFailure "unexpected result"+    ]
+ test/YCHR/Runtime/ReactivationTest.hs view
@@ -0,0 +1,109 @@+module YCHR.Runtime.ReactivationTest (tests) where++import Control.Monad.IO.Class (liftIO)+import Data.IORef+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import YCHR.Internal.Runtime.Monad (Chr, initSessionEnv, runChr)+import YCHR.Internal.Runtime.Reactivation+import YCHR.Internal.Runtime.Types (SuspensionId (..))++tests :: TestTree+tests =+  testGroup+    "YCHR.Internal.Runtime.Reactivation"+    [ emptyTests,+      orderTests,+      reentrancyTests,+      miscTests+    ]++runReactEnv :: Chr a -> IO a+runReactEnv action = do+  env <- initSessionEnv [] [] Map.empty Map.empty Map.empty Map.empty Set.empty+  runChr action env++-- | Drain the queue, collecting all IDs in order.+drainCollect :: Chr [SuspensionId]+drainCollect = do+  ref <- liftIO $ newIORef []+  drainQueue $ \sid -> liftIO $ modifyIORef' ref (sid :)+  liftIO $ reverse <$> readIORef ref++emptyTests :: TestTree+emptyTests =+  testGroup+    "empty queue"+    [ testCase "drain on empty does nothing" $ do+        ids <- runReactEnv drainCollect+        ids @?= []+    ]++orderTests :: TestTree+orderTests =+  testGroup+    "FIFO order"+    [ testCase "single enqueue preserves order" $ do+        ids <- runReactEnv $ do+          enqueue [SuspensionId 0, SuspensionId 1]+          drainCollect+        ids @?= [SuspensionId 0, SuspensionId 1],+      testCase "multiple enqueues preserve combined order" $ do+        ids <- runReactEnv $ do+          enqueue [SuspensionId 0, SuspensionId 1]+          enqueue [SuspensionId 2, SuspensionId 3]+          drainCollect+        ids @?= [SuspensionId 0, SuspensionId 1, SuspensionId 2, SuspensionId 3],+      testCase "empty list enqueue is a no-op" $ do+        ids <- runReactEnv $ do+          enqueue []+          drainCollect+        ids @?= []+    ]++reentrancyTests :: TestTree+reentrancyTests =+  testGroup+    "reentrancy"+    [ testCase "callback enqueues more IDs" $ do+        ids <- runReactEnv $ do+          ref <- liftIO $ newIORef []+          enqueue [SuspensionId 0]+          drainQueue $ \sid -> do+            liftIO $ modifyIORef' ref (sid :)+            case sid of+              SuspensionId 0 -> enqueue [SuspensionId 10, SuspensionId 11]+              _ -> pure ()+          liftIO $ reverse <$> readIORef ref+        ids @?= [SuspensionId 0, SuspensionId 10, SuspensionId 11],+      testCase "deep reentrancy (N < 3 -> enqueue N+1)" $ do+        ids <- runReactEnv $ do+          ref <- liftIO $ newIORef []+          enqueue [SuspensionId 0]+          drainQueue $ \sid@(SuspensionId n) -> do+            liftIO $ modifyIORef' ref (sid :)+            if n < 3+              then enqueue [SuspensionId (n + 1)]+              else pure ()+          liftIO $ reverse <$> readIORef ref+        ids @?= [SuspensionId 0, SuspensionId 1, SuspensionId 2, SuspensionId 3]+    ]++miscTests :: TestTree+miscTests =+  testGroup+    "misc"+    [ testCase "queue empty after drain" $ do+        ids <- runReactEnv $ do+          enqueue [SuspensionId 0, SuspensionId 1]+          _ <- drainCollect+          drainCollect+        ids @?= [],+      testCase "duplicates preserved" $ do+        ids <- runReactEnv $ do+          enqueue [SuspensionId 5, SuspensionId 5]+          drainCollect+        ids @?= [SuspensionId 5, SuspensionId 5]+    ]
+ test/YCHR/Runtime/StoreTest.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.Runtime.StoreTest (tests) where++import Control.Monad.IO.Class (liftIO)+import Data.Foldable (toList)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import YCHR.Internal.Runtime.Monad (Chr, initSessionEnv, runChr)+import YCHR.Internal.Runtime.Store+import YCHR.Internal.Runtime.Types (SuspensionId (..), Value (..))+import YCHR.Internal.Runtime.Var (equal, newVar, unify)+import YCHR.Internal.Types (ConstraintType (..), Name (..))++tests :: TestTree+tests =+  testGroup+    "YCHR.Internal.Runtime.Store"+    [ createTests,+      storeTests,+      killTests,+      fieldTests,+      iterationTests,+      observerTests+    ]++-- | A 100-slot session is large enough for every test in this module+-- (which use ConstraintType 0/1 and occasionally check ConstraintType 99).+runStoreEnv :: Chr a -> IO a+runStoreEnv action = do+  env <-+    initSessionEnv+      (replicate 100 (Unqualified ""))+      []+      Map.empty+      Map.empty+      Map.empty+      Map.empty+      Set.empty+  runChr action env++-- | Run an action and pair the result with the observer IDs accumulated+-- by the final 'unify' (or an empty list if no 'unify' happened).+runStoreObservers :: Chr [SuspensionId] -> IO [SuspensionId]+runStoreObservers = runStoreEnv++countAlive :: [Suspension] -> Chr Int+countAlive [] = pure 0+countAlive (s : ss) = do+  a <- isSuspAlive s+  rest <- countAlive ss+  pure $ (if a then 1 else 0) + rest++createTests :: TestTree+createTests =+  testGroup+    "createConstraint"+    [ testCase "returns distinct IDs" $ do+        runStoreEnv $ do+          id1 <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          id2 <- createConstraint (ConstraintType 0) [VInt 3, VInt 4]+          liftIO $ assertBool "IDs should differ" (not (idEqual id1 id2)),+      testCase "constraint is alive before storing" $ do+        runStoreEnv $ do+          sid <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          alive <- aliveConstraint sid+          liftIO $ alive @?= True+    ]++storeTests :: TestTree+storeTests =+  testGroup+    "storeConstraint"+    [ testCase "appears in snapshot" $ do+        runStoreEnv $ do+          sid <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          storeConstraint sid+          snap <- getStoreSnapshot (ConstraintType 0)+          liftIO $ length snap @?= 1,+      testCase "multiple same type" $ do+        runStoreEnv $ do+          s1 <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          s2 <- createConstraint (ConstraintType 0) [VInt 3, VInt 4]+          storeConstraint s1+          storeConstraint s2+          snap <- getStoreSnapshot (ConstraintType 0)+          liftIO $ length snap @?= 2,+      testCase "different types" $ do+        runStoreEnv $ do+          s1 <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          s2 <- createConstraint (ConstraintType 1) [VInt 5]+          storeConstraint s1+          storeConstraint s2+          snapLeq <- getStoreSnapshot (ConstraintType 0)+          snapGcd <- getStoreSnapshot (ConstraintType 1)+          liftIO $ length snapLeq @?= 1+          liftIO $ length snapGcd @?= 1,+      testCase "empty snapshot for unknown type" $ do+        runStoreEnv $ do+          snap <- getStoreSnapshot (ConstraintType 99)+          liftIO $ length snap @?= 0+    ]++killTests :: TestTree+killTests =+  testGroup+    "killConstraint"+    [ testCase "alive becomes False" $ do+        runStoreEnv $ do+          sid <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          storeConstraint sid+          killConstraint sid+          alive <- aliveConstraint sid+          liftIO $ alive @?= False,+      testCase "still in snapshot after kill" $ do+        runStoreEnv $ do+          sid <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          storeConstraint sid+          killConstraint sid+          snap <- getStoreSnapshot (ConstraintType 0)+          liftIO $ length snap @?= 1,+      testCase "doesn't affect other constraints" $ do+        runStoreEnv $ do+          s1 <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          s2 <- createConstraint (ConstraintType 0) [VInt 3, VInt 4]+          storeConstraint s1+          storeConstraint s2+          killConstraint s1+          a1 <- aliveConstraint s1+          a2 <- aliveConstraint s2+          liftIO $ a1 @?= False+          liftIO $ a2 @?= True+    ]++fieldTests :: TestTree+fieldTests =+  testGroup+    "fields"+    [ testCase "getConstraintArg" $ do+        runStoreEnv $ do+          sid <- createConstraint (ConstraintType 0) [VInt 10, VAtom "x"]+          a0 <- getConstraintArg sid 0+          a1 <- getConstraintArg sid 1+          liftIO $ case a0 of VInt 10 -> pure (); _ -> assertBool "arg 0" False+          liftIO $ case a1 of VAtom "x" -> pure (); _ -> assertBool "arg 1" False,+      testCase "getConstraintType" $ do+        runStoreEnv $ do+          sid <- createConstraint (ConstraintType 1) [VInt 5]+          t <- getConstraintType sid+          liftIO $ t @?= ConstraintType 1,+      testCase "idEqual same" $ do+        runStoreEnv $ do+          sid <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          liftIO $ assertBool "same id" (idEqual sid sid),+      testCase "idEqual different" $ do+        runStoreEnv $ do+          s1 <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          s2 <- createConstraint (ConstraintType 0) [VInt 3, VInt 4]+          liftIO $ assertBool "different id" (not (idEqual s1 s2)),+      testCase "isConstraintType true" $ do+        runStoreEnv $ do+          sid <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          r <- isConstraintType sid (ConstraintType 0)+          liftIO $ r @?= True,+      testCase "isConstraintType false" $ do+        runStoreEnv $ do+          sid <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          r <- isConstraintType sid (ConstraintType 1)+          liftIO $ r @?= False+    ]++iterationTests :: TestTree+iterationTests =+  testGroup+    "iteration"+    [ testCase "skip dead in snapshot" $ do+        runStoreEnv $ do+          s1 <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          s2 <- createConstraint (ConstraintType 0) [VInt 3, VInt 4]+          storeConstraint s1+          storeConstraint s2+          killConstraint s1+          snap <- getStoreSnapshot (ConstraintType 0)+          alive <- countAlive (toList snap)+          liftIO $ alive @?= 1,+      testCase "new constraints invisible to captured snapshot" $ do+        runStoreEnv $ do+          s1 <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          storeConstraint s1+          snap <- getStoreSnapshot (ConstraintType 0)+          s2 <- createConstraint (ConstraintType 0) [VInt 3, VInt 4]+          storeConstraint s2+          liftIO $ length snap @?= 1+          snap2 <- getStoreSnapshot (ConstraintType 0)+          liftIO $ length snap2 @?= 2,+      testCase "kill visible during iteration via isSuspAlive" $ do+        runStoreEnv $ do+          s1 <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          s2 <- createConstraint (ConstraintType 0) [VInt 3, VInt 4]+          storeConstraint s1+          storeConstraint s2+          snap <- getStoreSnapshot (ConstraintType 0)+          killConstraint s1+          (susp1, susp2) <- liftIO $ case toList snap of+            (s1' : s2' : _) -> pure (s1', s2')+            _ -> assertFailure "expected at least 2 suspensions in store"+          a1 <- isSuspAlive susp1+          a2 <- isSuspAlive susp2+          liftIO $ a1 @?= False+          liftIO $ a2 @?= True,+      testCase "filter by argument equality" $ do+        runStoreEnv $ do+          s1 <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          s2 <- createConstraint (ConstraintType 0) [VInt 3, VInt 4]+          s3 <- createConstraint (ConstraintType 0) [VInt 1, VInt 5]+          storeConstraint s1+          storeConstraint s2+          storeConstraint s3+          snap <- getStoreSnapshot (ConstraintType 0)+          let susps = toList snap+          matches <- filterByArg 0 (VInt 1) susps+          liftIO $ length matches @?= 2,+      testCase "suspArg pure access" $ do+        runStoreEnv $ do+          sid <- createConstraint (ConstraintType 0) [VInt 10, VAtom "y"]+          storeConstraint sid+          snap <- getStoreSnapshot (ConstraintType 0)+          s <- liftIO $ case toList snap of+            (s : _) -> pure s+            [] -> assertFailure "expected at least 1 suspension in store"+          liftIO $ case suspArg s 0 of VInt 10 -> pure (); _ -> assertBool "arg 0" False+          liftIO $ case suspArg s 1 of VAtom "y" -> pure (); _ -> assertBool "arg 1" False+    ]+  where+    filterByArg :: Int -> Value -> [Suspension] -> Chr [Suspension]+    filterByArg _ _ [] = pure []+    filterByArg idx val (s : ss) = do+      alive <- isSuspAlive s+      if alive+        then do+          eq <- equal (suspArg s idx) val+          rest <- filterByArg idx val ss+          pure $ if eq then s : rest else rest+        else filterByArg idx val ss++observerTests :: TestTree+observerTests =+  testGroup+    "observer registration"+    [ testCase "unifying a constraint's var arg emits SuspensionId" $ do+        obs <- runStoreObservers $ do+          x <- newVar+          sid <- createConstraint (ConstraintType 0) [x, VInt 2]+          storeConstraint sid+          (_, o) <- unify x (VInt 1)+          pure o+        assertBool+          "should contain the suspension id"+          (SuspensionId 0 `elem` obs),+      testCase "ground args produce no observer" $ do+        runStoreEnv $ do+          sid <- createConstraint (ConstraintType 0) [VInt 1, VInt 2]+          storeConstraint sid+          pure (),+      testCase "multiple constraints on same variable" $ do+        obs <- runStoreObservers $ do+          x <- newVar+          s1 <- createConstraint (ConstraintType 0) [x, VInt 2]+          s2 <- createConstraint (ConstraintType 1) [x]+          storeConstraint s1+          storeConstraint s2+          (_, o) <- unify x (VInt 1)+          pure o+        assertBool "should contain s1" (SuspensionId 0 `elem` obs)+        assertBool "should contain s2" (SuspensionId 1 `elem` obs),+      testCase "var nested in a compound arg emits SuspensionId" $ do+        obs <- runStoreObservers $ do+          x <- newVar+          -- The var is nested two levels deep inside compound+          -- arguments, not a bare top-level argument. Reactivation+          -- must still observe it (ωr Reactivate).+          sid <-+            createConstraint+              (ConstraintType 0)+              [VTerm "pair" [VTerm "box" [x], VInt 2]]+          storeConstraint sid+          (_, o) <- unify x (VInt 1)+          pure o+        assertBool+          "should contain the suspension id"+          (SuspensionId 0 `elem` obs)+    ]
+ test/YCHR/Runtime/VarTest.hs view
@@ -0,0 +1,535 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.Runtime.VarTest (tests) where++import Control.Monad.IO.Class (liftIO)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))+import YCHR.Internal.Runtime.Monad (Chr, initSessionEnv, runChr)+import YCHR.Internal.Runtime.Types (SuspensionId (..), Value (..))+import YCHR.Internal.Runtime.Var+  ( addObserver,+    deref,+    equal,+    getArg,+    getVarId,+    makeTerm,+    matchTerm,+    newVar,+    unifiable,+    unify,+  )++tests :: TestTree+tests =+  testGroup+    "YCHR.Internal.Runtime.Var"+    [ unifyTests,+      unifiableTests,+      unifiableRollbackTests,+      equalTests,+      observerTests,+      derefTests,+      termTests,+      wildcardTests+    ]++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++runVarEnv :: Chr a -> IO a+runVarEnv action = do+  env <- initSessionEnv [] [] Map.empty Map.empty Map.empty Map.empty Set.empty+  runChr action env++-- | Run an action and also return the observers gathered by the final 'unify'.+runWithUnify ::+  (Value -> Value -> Chr (Bool, [SuspensionId])) ->+  Value ->+  Value ->+  IO (Bool, [SuspensionId])+runWithUnify u a b = runVarEnv (u a b)++-- | Assert that unification succeeds (discards observers).+assertUnifySuccess :: Value -> Value -> Chr ()+assertUnifySuccess a b = do+  (ok, _) <- unify a b+  liftIO $ assertBool "unify should succeed" ok++-- | Assert that unification fails (discards observers).+assertUnifyFailure :: Value -> Value -> Chr ()+assertUnifyFailure a b = do+  (ok, _) <- unify a b+  liftIO $ assertBool "unify should fail" (not ok)++-- | Assert that a value dereferences to a given Integer.+assertDerefInt :: Value -> Integer -> Chr ()+assertDerefInt v expected = do+  d <- deref v+  liftIO $ case d of+    VInt n -> n @?= expected+    _ -> assertBool ("expected VInt " ++ show expected) False++unifyTests :: TestTree+unifyTests =+  testGroup+    "unify"+    [ testCase "Var = Int" $ do+        runVarEnv $ do+          x <- newVar+          assertUnifySuccess x (VInt 42)+          assertDerefInt x 42,+      testCase "Var = Var, then bind" $ do+        runVarEnv $ do+          x <- newVar+          y <- newVar+          assertUnifySuccess x y+          assertUnifySuccess y (VInt 7)+          assertDerefInt x 7+          assertDerefInt y 7,+      testCase "Var = same Var (no-op)" $ do+        (ok, obs) <- runVarEnv $ do+          x <- newVar+          unify x x+        assertBool "same var unify succeeds" ok+        obs @?= [],+      testCase "Int = Int (same)" $ do+        (ok, _) <- runWithUnify unify (VInt 5) (VInt 5)+        assertBool "same ints unify" ok,+      testCase "Int = Int (different)" $ do+        runVarEnv $ assertUnifyFailure (VInt 1) (VInt 2),+      testCase "Atom = Atom (same)" $ do+        (ok, _) <- runWithUnify unify (VAtom "foo") (VAtom "foo")+        assertBool "same atoms unify" ok,+      testCase "Atom = Atom (different)" $ do+        runVarEnv $ assertUnifyFailure (VAtom "foo") (VAtom "bar"),+      testCase "Bool = Bool (same)" $ do+        (ok, _) <- runWithUnify unify (VBool True) (VBool True)+        assertBool "same bools unify" ok,+      testCase "Bool = Bool (different)" $ do+        runVarEnv $ assertUnifyFailure (VBool True) (VBool False),+      testCase "Term = Term (matching functor/arity)" $ do+        runVarEnv $ do+          x <- newVar+          y <- newVar+          let t1 = makeTerm "f" [x, VInt 1]+              t2 = makeTerm "f" [VInt 2, y]+          assertUnifySuccess t1 t2+          assertDerefInt x 2+          assertDerefInt y 1,+      testCase "Term = Term (different functor)" $ do+        runVarEnv $ assertUnifyFailure (makeTerm "f" [VInt 1]) (makeTerm "g" [VInt 1]),+      testCase "Term = Term (different arity)" $ do+        runVarEnv $+          assertUnifyFailure+            (makeTerm "f" [VInt 1])+            (makeTerm "f" [VInt 1, VInt 2]),+      testCase "Nested terms: f(X, g(1)) = f(2, g(Y))" $ do+        runVarEnv $ do+          x <- newVar+          y <- newVar+          let t1 = makeTerm "f" [x, makeTerm "g" [VInt 1]]+              t2 = makeTerm "f" [VInt 2, makeTerm "g" [y]]+          assertUnifySuccess t1 t2+          assertDerefInt x 2+          assertDerefInt y 1,+      testCase "Binding chain: X→Y→Z→42" $ do+        runVarEnv $ do+          x <- newVar+          y <- newVar+          z <- newVar+          assertUnifySuccess x y+          assertUnifySuccess y z+          assertUnifySuccess z (VInt 42)+          assertDerefInt x 42,+      testCase "Int = Atom (type mismatch)" $ do+        runVarEnv $ assertUnifyFailure (VInt 1) (VAtom "one"),+      testCase "Already-bound var: unify with same value succeeds" $ do+        runVarEnv $ do+          x <- newVar+          assertUnifySuccess x (VInt 1)+          assertUnifySuccess x (VInt 1)+          assertDerefInt x 1,+      testCase "Already-bound var: unify with different value fails" $ do+        runVarEnv $ do+          x <- newVar+          assertUnifySuccess x (VInt 1)+          assertUnifyFailure x (VInt 2)+    ]++assertUnifiable :: Value -> Value -> Bool -> Chr ()+assertUnifiable a b expected = do+  r <- unifiable a b+  liftIO $ r @?= expected++unifiableTests :: TestTree+unifiableTests =+  testGroup+    "unifiable"+    [ testCase "Int = Int (same)" $ runVarEnv $ assertUnifiable (VInt 1) (VInt 1) True,+      testCase "Int = Int (different)" $+        runVarEnv $+          assertUnifiable (VInt 1) (VInt 2) False,+      testCase "Atom = Atom (same)" $+        runVarEnv $+          assertUnifiable (VAtom "a") (VAtom "a") True,+      testCase "Atom = Atom (different)" $+        runVarEnv $+          assertUnifiable (VAtom "a") (VAtom "b") False,+      testCase "Bool = Bool (same)" $+        runVarEnv $+          assertUnifiable (VBool True) (VBool True) True,+      testCase "Bool = Bool (different)" $+        runVarEnv $+          assertUnifiable (VBool True) (VBool False) False,+      testCase "Text = Text (same)" $+        runVarEnv $+          assertUnifiable (VText "x") (VText "x") True,+      testCase "Text = Text (different)" $+        runVarEnv $+          assertUnifiable (VText "x") (VText "y") False,+      testCase "Same unbound var" $ runVarEnv $ do+        x <- newVar+        assertUnifiable x x True,+      testCase "Two distinct unbound vars" $ runVarEnv $ do+        x <- newVar+        y <- newVar+        assertUnifiable x y True,+      testCase "Unbound var vs ground" $ runVarEnv $ do+        x <- newVar+        assertUnifiable x (VInt 42) True,+      testCase "Ground vs unbound var" $ runVarEnv $ do+        x <- newVar+        assertUnifiable (VInt 42) x True,+      testCase "Wildcard vs ground" $+        runVarEnv $+          assertUnifiable VWildcard (VInt 7) True,+      testCase "Wildcard vs unbound var" $ runVarEnv $ do+        x <- newVar+        assertUnifiable VWildcard x True,+      testCase "Wildcard vs compound" $+        runVarEnv $+          assertUnifiable VWildcard (makeTerm "f" [VInt 1, VInt 2]) True,+      testCase "Compound: matching ground args" $+        runVarEnv $+          assertUnifiable (makeTerm "f" [VInt 1, VInt 2]) (makeTerm "f" [VInt 1, VInt 2]) True,+      testCase "Compound: mismatched functor" $+        runVarEnv $+          assertUnifiable (makeTerm "f" [VInt 1]) (makeTerm "g" [VInt 1]) False,+      testCase "Compound: mismatched arity" $+        runVarEnv $+          assertUnifiable (makeTerm "f" [VInt 1]) (makeTerm "f" [VInt 1, VInt 2]) False,+      testCase "Compound with var arg: f(1, X) = f(1, 2)" $ runVarEnv $ do+        x <- newVar+        assertUnifiable (makeTerm "f" [VInt 1, x]) (makeTerm "f" [VInt 1, VInt 2]) True,+      testCase "Compound nested failure: f(X, 1) = f(2, 3)" $ runVarEnv $ do+        x <- newVar+        assertUnifiable (makeTerm "f" [x, VInt 1]) (makeTerm "f" [VInt 2, VInt 3]) False,+      testCase "Transitively unifiable: f(X, X) = f(1, 1)" $ runVarEnv $ do+        x <- newVar+        assertUnifiable (makeTerm "f" [x, x]) (makeTerm "f" [VInt 1, VInt 1]) True,+      testCase "Transitively non-unifiable: f(X, X) = f(1, 2)" $ runVarEnv $ do+        x <- newVar+        assertUnifiable (makeTerm "f" [x, x]) (makeTerm "f" [VInt 1, VInt 2]) False,+      testCase "Type mismatch: Int vs Atom" $+        runVarEnv $+          assertUnifiable (VInt 1) (VAtom "a") False,+      testCase "Chained bind then unifiable ground" $ runVarEnv $ do+        x <- newVar+        y <- newVar+        _ <- unify x y+        r <- unifiable x (VInt 1)+        liftIO $ r @?= True+    ]++assertUnifiableNoMutation :: [Value] -> Value -> Value -> Bool -> Chr ()+assertUnifiableNoMutation vars a b expected = do+  before <- traverse getVarId vars+  r <- unifiable a b+  liftIO $ r @?= expected+  after <- traverse getVarId vars+  liftIO $ before @?= after++unifiableRollbackTests :: TestTree+unifiableRollbackTests =+  testGroup+    "unifiable rollback"+    [ testCase "Var-Var success: both stay unbound" $ runVarEnv $ do+        x <- newVar+        y <- newVar+        assertUnifiableNoMutation [x, y] x y True,+      testCase "Var-NonVar success: var stays unbound" $ runVarEnv $ do+        x <- newVar+        assertUnifiableNoMutation [x] x (VInt 42) True,+      testCase "NonVar-Var success (symmetric): var stays unbound" $ runVarEnv $ do+        x <- newVar+        assertUnifiableNoMutation [x] (VInt 42) x True,+      testCase "Bind then fail inside compound: var rolls back" $ runVarEnv $ do+        x <- newVar+        assertUnifiableNoMutation+          [x]+          (makeTerm "f" [x, VInt 1])+          (makeTerm "f" [VInt 2, VInt 3])+          False,+      testCase "Double-bind failure: f(X,X) vs f(1,2) rolls X back" $ runVarEnv $ do+        x <- newVar+        assertUnifiableNoMutation+          [x]+          (makeTerm "f" [x, x])+          (makeTerm "f" [VInt 1, VInt 2])+          False,+      testCase "Success inside deeper compound: all vars stay unbound" $ runVarEnv $ do+        x <- newVar+        y <- newVar+        assertUnifiableNoMutation+          [x, y]+          (makeTerm "f" [x, y])+          (makeTerm "f" [VInt 1, VInt 2])+          True,+      testCase "Failure with multiple rolled-back bindings" $ runVarEnv $ do+        x <- newVar+        y <- newVar+        assertUnifiableNoMutation+          [x, y]+          (makeTerm "f" [x, y, VInt 1])+          (makeTerm "f" [VInt 1, VInt 2, VInt 9])+          False,+      testCase "Pre-bound var stays bound after failing unifiable" $ runVarEnv $ do+        x <- newVar+        _ <- unify x (VInt 7)+        r <- unifiable x (VInt 8)+        liftIO $ r @?= False+        mid <- getVarId x+        liftIO $ mid @?= Nothing+        eq <- equal x (VInt 7)+        liftIO $ eq @?= True+    ]++equalTests :: TestTree+equalTests =+  testGroup+    "equal"+    [ testCase "Same unbound var" $ do+        runVarEnv $ do+          x <- newVar+          r <- equal x x+          liftIO $ r @?= True,+      testCase "Distinct unbound vars" $ do+        runVarEnv $ do+          x <- newVar+          y <- newVar+          r <- equal x y+          liftIO $ r @?= False,+      testCase "Unbound var vs ground" $ do+        runVarEnv $ do+          x <- newVar+          r <- equal x (VInt 1)+          liftIO $ r @?= False,+      testCase "Ground vs unbound var" $ do+        runVarEnv $ do+          x <- newVar+          r <- equal (VInt 1) x+          liftIO $ r @?= False,+      testCase "Same int" $ do+        r <- runVarEnv $ equal (VInt 42) (VInt 42)+        r @?= True,+      testCase "Different int" $ do+        r <- runVarEnv $ equal (VInt 1) (VInt 2)+        r @?= False,+      testCase "Same atom" $ do+        r <- runVarEnv $ equal (VAtom "x") (VAtom "x")+        r @?= True,+      testCase "Same term structure" $ do+        r <-+          runVarEnv $+            equal+              (makeTerm "f" [VInt 1, VAtom "a"])+              (makeTerm "f" [VInt 1, VAtom "a"])+        r @?= True,+      testCase "Different term structure" $ do+        r <- runVarEnv $ equal (makeTerm "f" [VInt 1]) (makeTerm "f" [VInt 2])+        r @?= False,+      testCase "After unification: var bound to int" $ do+        runVarEnv $ do+          x <- newVar+          _ <- unify x (VInt 5)+          r <- equal x (VInt 5)+          liftIO $ r @?= True,+      testCase "Two vars bound to same value" $ do+        runVarEnv $ do+          x <- newVar+          y <- newVar+          _ <- unify x (VInt 3)+          _ <- unify y (VInt 3)+          r <- equal x y+          liftIO $ r @?= True,+      testCase "Var bound to var, both equal after binding" $ do+        runVarEnv $ do+          x <- newVar+          y <- newVar+          _ <- unify x y+          _ <- unify y (VAtom "hello")+          r <- equal x (VAtom "hello")+          liftIO $ r @?= True+    ]++observerTests :: TestTree+observerTests =+  testGroup+    "observers"+    [ testCase "No observers: unify returns empty list" $ do+        obs <- runVarEnv $ do+          x <- newVar+          (_, obs) <- unify x (VInt 1)+          pure obs+        obs @?= [],+      testCase "Single observer returned on bind" $ do+        (ok, obs) <- runVarEnv $ do+          x <- newVar+          addObserver (SuspensionId 10) x+          unify x (VInt 1)+        assertBool "unify succeeds" ok+        obs @?= [SuspensionId 10],+      testCase "Multiple observers all returned" $ do+        (ok, obs) <- runVarEnv $ do+          x <- newVar+          addObserver (SuspensionId 1) x+          addObserver (SuspensionId 2) x+          addObserver (SuspensionId 3) x+          unify x (VInt 1)+        assertBool "unify succeeds" ok+        length obs @?= 3,+      testCase "Var-Var merge: observers from bound var collected" $ do+        (ok, obs) <- runVarEnv $ do+          x <- newVar+          y <- newVar+          addObserver (SuspensionId 1) x+          addObserver (SuspensionId 2) y+          unify x y+        assertBool "unify succeeds" ok+        obs @?= [SuspensionId 1],+      testCase "addObserver on ground value is no-op" $ do+        runVarEnv $ do+          addObserver (SuspensionId 99) (VInt 42)+          pure ()+    ]++derefTests :: TestTree+derefTests =+  testGroup+    "deref"+    [ testCase "Unbound var derefs to itself" $ do+        runVarEnv $ do+          x <- newVar+          d <- deref x+          r <- equal d x+          liftIO $ r @?= True,+      testCase "Ground value derefs to itself" $ do+        d <- runVarEnv $ deref (VInt 99)+        case d of+          VInt 99 -> pure ()+          _ -> assertBool "expected VInt 99" False,+      testCase "Single binding: var→int" $ do+        runVarEnv $ do+          x <- newVar+          _ <- unify x (VInt 10)+          assertDerefInt x 10,+      testCase "Chain: var→var→var→int" $ do+        runVarEnv $ do+          x <- newVar+          y <- newVar+          z <- newVar+          _ <- unify x y+          _ <- unify y z+          _ <- unify z (VInt 100)+          assertDerefInt x 100+          assertDerefInt y 100+          assertDerefInt z 100+    ]++termTests :: TestTree+termTests =+  testGroup+    "terms"+    [ testCase "makeTerm constructs VTerm" $ do+        let t = makeTerm "f" [VInt 1, VAtom "a"]+        case t of+          VTerm "f" [VInt 1, VAtom "a"] -> pure ()+          _ -> assertBool "expected VTerm f [1, a]" False,+      testCase "matchTerm: correct functor/arity" $ do+        r <- runVarEnv $ matchTerm (makeTerm "f" [VInt 1, VInt 2]) "f" 2+        r @?= True,+      testCase "matchTerm: wrong functor" $ do+        r <- runVarEnv $ matchTerm (makeTerm "f" [VInt 1]) "g" 1+        r @?= False,+      testCase "matchTerm: wrong arity" $ do+        r <- runVarEnv $ matchTerm (makeTerm "f" [VInt 1]) "f" 2+        r @?= False,+      testCase "matchTerm: non-term" $ do+        r <- runVarEnv $ matchTerm (VInt 42) "f" 0+        r @?= False,+      testCase "matchTerm through var" $ do+        runVarEnv $ do+          x <- newVar+          _ <- unify x (makeTerm "g" [VInt 1, VInt 2, VInt 3])+          r <- matchTerm x "g" 3+          liftIO $ r @?= True,+      testCase "getArg: correct index" $ do+        let t = makeTerm "f" [VInt 10, VAtom "b", VInt 30]+        (a0, a1, a2) <- runVarEnv $ do+          a0 <- getArg t 0+          a1 <- getArg t 1+          a2 <- getArg t 2+          pure (a0, a1, a2)+        case a0 of VInt 10 -> pure (); _ -> assertBool "arg 0" False+        case a1 of VAtom "b" -> pure (); _ -> assertBool "arg 1" False+        case a2 of VInt 30 -> pure (); _ -> assertBool "arg 2" False,+      testCase "getArg through var" $ do+        runVarEnv $ do+          x <- newVar+          _ <- unify x (makeTerm "h" [VInt 5])+          a <- getArg x 0+          liftIO $ case a of+            VInt 5 -> pure ()+            _ -> assertBool "expected VInt 5" False+    ]++wildcardTests :: TestTree+wildcardTests =+  testGroup+    "wildcard"+    [ testCase "Wildcard unifies with Int" $ do+        (ok, _) <- runVarEnv $ unify VWildcard (VInt 42)+        ok @?= True,+      testCase "Int unifies with Wildcard" $ do+        (ok, _) <- runVarEnv $ unify (VInt 42) VWildcard+        ok @?= True,+      testCase "Wildcard unifies with Wildcard" $ do+        (ok, _) <- runVarEnv $ unify VWildcard VWildcard+        ok @?= True,+      testCase "Wildcard unifies with unbound Var" $ do+        runVarEnv $ do+          x <- newVar+          (ok, _) <- unify VWildcard x+          liftIO $ ok @?= True,+      testCase "Wildcard does not bind Var" $ do+        runVarEnv $ do+          x <- newVar+          _ <- unify VWildcard x+          d <- deref x+          liftIO $ case d of+            VVar _ -> pure ()+            _ -> assertBool "var should remain unbound" False,+      testCase "Wildcard equal to Int is False" $ do+        r <- runVarEnv $ equal VWildcard (VInt 42)+        r @?= False,+      testCase "Int equal to Wildcard is False" $ do+        r <- runVarEnv $ equal (VInt 42) VWildcard+        r @?= False,+      testCase "Wildcard equal to Wildcard is False" $ do+        r <- runVarEnv $ equal VWildcard VWildcard+        r @?= False+    ]
+ test/YCHR/VM/SExprTest.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE OverloadedStrings #-}++module YCHR.VM.SExprTest (tests) where++import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))+import YCHR.Internal.Types qualified as Types+import YCHR.Internal.VM+import YCHR.Internal.VM.SExpr (VMProgram (..), deserialize, serialize)++tests :: TestTree+tests =+  testGroup+    "VM.SExpr"+    [ testGroup "roundtrip" roundtripTests,+      testGroup "format" formatTests+    ]++-- ---------------------------------------------------------------------------+-- Roundtrip: serialize then deserialize = identity+-- ---------------------------------------------------------------------------++roundtripTests :: [TestTree]+roundtripTests =+  [ testCase "empty program" $ roundtrip (Program 0 [] 0 [] [] []),+    testCase "single empty procedure" $+      roundtrip (Program 1 [Types.Unqualified "foo"] 0 [] [mkProcedure "foo" [] []] []),+    testCase "procedure with params" $+      roundtrip+        ( Program+            1+            [Types.Unqualified "leq"]+            0+            []+            [mkProcedure "tell_leq2" ["X", "Y"] []]+            []+        ),+    testCase "let-val statement" $+      roundtrip (mkProg [LetVal "x" (Lit (IntLit 42))]),+    testCase "let-id statement" $+      roundtrip (mkProg [LetId "id" (CreateConstraint (ConstraintType 0) [Lit (IntLit 1)])]),+    testCase "assign-val statement" $+      roundtrip (mkProg [AssignVal "x" (Lit (BoolLit True))]),+    testCase "assign-id statement" $+      roundtrip (mkProg [AssignId "id" (IdVar "other")]),+    testCase "if statement" $+      roundtrip+        ( mkProg+            [ If+                (BFromVal (Var "x"))+                [Return (Lit (BoolLit True))]+                [ Return+                    ( Lit+                        ( BoolLit+                            False+                        )+                    )+                ]+            ]+        ),+    testCase "foreach statement" $+      roundtrip+        ( mkProg+            [ Foreach+                "L1"+                (ConstraintType 0)+                "susp"+                [(ArgIndex 0, Var "x"), (ArgIndex 1, Lit (IntLit 3))]+                [ExprStmt (FieldType (IdVar "susp"))]+            ]+        ),+    testCase "foreach with empty conditions" $+      roundtrip+        ( mkProg+            [ Foreach+                "L2"+                (ConstraintType 1)+                "s"+                []+                [ExprStmt (FieldType (IdVar "s"))]+            ]+        ),+    testCase "continue and break" $+      roundtrip (mkProg [Continue "L1", Break "L2"]),+    testCase "store and kill" $+      roundtrip (mkProg [Store (IdVar "id"), Kill (IdVar "id")]),+    testCase "add-history" $+      roundtrip (mkProg [AddHistory (RuleId 0) [IdVar "id1", IdVar "id2"]]),+    testCase "drain-reactivation-queue" $+      roundtrip+        ( mkProg+            [ DrainReactivationQueue+                "rs"+                [ExprStmt (CallExpr "reactivate_dispatch" [AId (IdVar "rs")])]+            ]+        ),+    testCase "all expression types" $+      roundtrip+        ( mkProg+            [ LetVal "a" (Var "x"),+              LetVal "b" (Lit (IntLit 42)),+              LetVal "b2" (Lit (FloatLit 3.14)),+              LetVal "c" (Lit (AtomLit "foo")),+              LetVal "d" (Lit (TextLit "hello world")),+              LetVal "e" (Lit (BoolLit True)),+              LetVal "f" (Lit (BoolLit False)),+              LetVal "g" (Lit WildcardLit),+              LetVal "h" (CallExpr "proc" [AVal (Var "a"), AVal (Var "b")]),+              LetVal "i" (HostCall "+" [Var "a", Var "b"]),+              LetVal "j" (EvalDeep (Var "expr")),+              LetVal "n" NewVar,+              LetVal "o" (MakeTerm "f" [Var "a", Var "b"]),+              LetVal "q" (GetArg (Var "x") 0),+              LetId "r" (CreateConstraint (ConstraintType 0) [Var "a"]),+              LetId "y" (IdVar "s"),+              LetVal "z" (FieldArg (IdVar "s") (ArgIndex 0)),+              LetVal "z2" (FieldType (IdVar "s")),+              -- Boolean-position expressions exercised through If/BoolExprStmt.+              If (BLit True) [] [],+              If (BNot (BLit False)) [] [],+              If (BAnd (BLit True) (BLit False)) [] [],+              If (BOr (BLit True) (BLit False)) [] [],+              If (BMatchTerm (Var "x") "f" 2) [] [],+              If (BEqual (Var "a") (Var "b")) [] [],+              If (BIdEqual (IdVar "id1") (IdVar "id2")) [] [],+              If (BAlive (IdVar "id")) [] [],+              If (BIsConstraintType (IdVar "s") (ConstraintType 1)) [] [],+              If (BNotInHistory (RuleId 0) [IdVar "id1", IdVar "id2"]) [] [],+              BoolExprStmt (BUnify (Var "a") (Var "b")),+              If (BFromVal (Var "a")) [] [],+              If (BEvalDeep (BLit True)) [] []+            ]+        ),+    testCase "call-expr with zero args" $+      roundtrip (mkProg [ExprStmt (CallExpr "noop" [])]),+    testCase "make-term with zero args" $+      roundtrip (mkProg [LetVal "x" (MakeTerm "nil" [])]),+    testCase "negative integer" $+      roundtrip (mkProg [LetVal "x" (Lit (IntLit (-5)))]),+    testCase "string with special characters" $+      roundtrip (mkProg [LetVal "x" (Lit (TextLit "hello\nworld\t\"quoted\""))]),+    testCase "multi-procedure program" $+      roundtrip+        ( Program+            2+            [Types.Unqualified "a", Types.Unqualified "b"]+            0+            []+            [ mkProcedure+                "tell_a1"+                ["X"]+                [ LetId+                    "id"+                    ( CreateConstraint+                        (ConstraintType 0)+                        [ Var+                            "X"+                        ]+                    ),+                  Store (IdVar "id"),+                  ExprStmt (CallExpr "activate_a1" [AId (IdVar "id")])+                ],+              mkProcedure+                "activate_a1"+                ["susp"]+                [ LetId "id" (IdVar "susp"),+                  LetVal "X" (FieldArg (IdVar "susp") (ArgIndex 0)),+                  Return (Lit (BoolLit False))+                ],+              mkProcedure+                "reactivate_dispatch"+                ["susp"]+                [ If+                    ( BIsConstraintType+                        (IdVar "susp")+                        (ConstraintType 0)+                    )+                    [ExprStmt (CallExpr "activate_a1" [AId (IdVar "susp")])]+                    []+                ]+            ]+            []+        )+  ]++-- | Assert that serializing then deserializing produces the original value.+roundtrip :: Program -> IO ()+roundtrip prog = do+  let vmp = mkVMProg prog+      text = serialize vmp+  case deserialize text of+    Left e ->+      assertBool+        ( "deserialization failed: "+            <> T.unpack e+            <> "\n\nserialized:\n"+            <> T.unpack text+        )+        False+    Right vmp' -> vmp' @?= vmp++-- ---------------------------------------------------------------------------+-- Format: check that serialized output looks right+-- ---------------------------------------------------------------------------++formatTests :: [TestTree]+formatTests =+  [ testCase "var serialization" $+      assertContains+        (serializeProg (mkProg [ExprStmt (Var "x")]))+        ( "(program 0 (type-names) 0 (rule-names) (evaluables) "+            <> "(procedure \"p\" () (reactivate-dispatch) "+            <> "(expr-stmt (var \"x\"))))"+        ),+    testCase "literals inline without wrapper" $ do+      assertContains (serializeProg (mkProg [LetVal "x" (Lit (BoolLit True))])) "true"+      assertContains (serializeProg (mkProg [LetVal "x" (Lit (BoolLit False))])) "false"+      assertContains (serializeProg (mkProg [LetVal "x" (Lit WildcardLit)])) "wildcard"+      assertContains (serializeProg (mkProg [LetVal "x" (Lit (IntLit 7))])) "(int 7)"+      assertContains+        (serializeProg (mkProg [LetVal "x" (Lit (AtomLit "foo"))]))+        "(atom \"foo\")",+    testCase "new-var is a bare atom" $+      assertContains (serializeProg (mkProg [LetVal "x" NewVar])) "new-var",+    testCase "exports and symbol table roundtrip" $+      let vmp =+            VMProgram+              { program =+                  Program+                    2+                    [Types.Qualified "M" "leq", Types.Unqualified "gcd"]+                    0+                    []+                    []+                    [],+                exportedSet =+                  Set.fromList+                    [ Types.QualifiedIdentifier "M" "leq" 2,+                      Types.QualifiedIdentifier "M" "gcd" 1+                    ],+                symbolTable =+                  Types.mkSymbolTable+                    [ ( Types.Identifier+                          ( Types.Qualified+                              "M"+                              "leq"+                          )+                          2,+                        Types.ConstraintType 0+                      ),+                      (Types.Identifier (Types.Unqualified "gcd") 1, Types.ConstraintType 1)+                    ]+              }+          text = serialize vmp+       in case deserialize text of+            Left e -> assertBool ("deserialization failed: " <> T.unpack e) False+            Right vmp' -> vmp' @?= vmp+  ]++serializeProg :: Program -> Text+serializeProg = serialize . mkVMProg++-- ---------------------------------------------------------------------------+-- Helpers+-- ---------------------------------------------------------------------------++-- | Build a minimal program with one procedure containing the given body.+mkProg :: [Stmt] -> Program+mkProg body = Program 0 [] 0 [] [mkProcedure "p" [] body] []++-- | Build a 'Procedure' with a placeholder 'procKind'. The kind tag+-- doesn't affect serialization round-tripping or the format tests'+-- assertions, so a single neutral value (with no payload) keeps the+-- fixtures concise.+mkProcedure :: Name -> [Name] -> [Stmt] -> Procedure+mkProcedure n ps body =+  Procedure+    { name = n,+      params = ps,+      body = body,+      procKind = PKReactivateDispatch+    }++-- | Wrap a Program into a VMProgram with empty metadata.+mkVMProg :: Program -> VMProgram+mkVMProg prog =+  VMProgram+    { program = prog,+      exportedSet = Set.empty,+      symbolTable = Types.mkSymbolTable []+    }++assertContains :: Text -> Text -> IO ()+assertContains haystack needle =+  assertBool+    ("expected " <> show needle <> " in:\n" <> T.unpack haystack)+    (needle `T.isInfixOf` haystack)
+ test/golden/alias_print/alias_print.chr view
@@ -0,0 +1,6 @@+:- module(alias_print, [alias2/2, alias3/3]).+:- chr_constraint alias2/2.+:- chr_constraint alias3/3.++unify2 @ alias2(X, Y) <=> X = Y.+unify3 @ alias3(X, Y, Z) <=> X = Y, Y = Z.
+ test/golden/alias_print/pair.expected view
@@ -0,0 +1,2 @@+A = B+B = A
+ test/golden/alias_print/pair.goal view
@@ -0,0 +1,1 @@+alias_print:alias2(A, B)
+ test/golden/alias_print/triple.expected view
@@ -0,0 +1,3 @@+A = B+B = C+C = A
+ test/golden/alias_print/triple.goal view
@@ -0,0 +1,1 @@+alias_print:alias3(A, B, C)
+ test/golden/ambiguous_unqualified_constructor/m1.chr view
@@ -0,0 +1,2 @@+:- module(m1).+:- chr_type t ---> foo ; bar.
+ test/golden/ambiguous_unqualified_constructor/m2.chr view
@@ -0,0 +1,2 @@+:- module(m2).+:- chr_type t ---> foo ; baz.
+ test/golden/ambiguous_unqualified_constructor/m3.chr view
@@ -0,0 +1,11 @@+:- module(m3).+:- use_module(m1).+:- use_module(m2).+:- chr_constraint r/1.++% Bug repro from dev-docs/BUGS.md: both m1 and m2 export a data+% constructor named `foo`. An unqualified use must be rejected+% with YCHR-20012, parallel to YCHR-20001 in the function/constraint+% namespace. The user should qualify the constructor (`m1:foo` or+% `m2:foo`) to disambiguate.+r(R) <=> R = foo.
+ test/golden/ambiguous_unqualified_constructor/m3.error view
@@ -0,0 +1,1 @@+YCHR-20012
+ test/golden/append_test/append_test.chr view
@@ -0,0 +1,7 @@+:- module(append_test, [go/3]).++:- use_module(library(lists)).++:- chr_constraint go/3.++go(Xs, Ys, R) <=> R is append(Xs, Ys).
+ test/golden/append_test/append_test.expected view
@@ -0,0 +1,1 @@+R = [1, 2, 3, 4, 5]
+ test/golden/append_test/append_test.goal view
@@ -0,0 +1,1 @@+append_test:go([1, 2], [3, 4, 5], R)
+ test/golden/arith_bignum/arith_bignum.chr view
@@ -0,0 +1,8 @@+:- module(arith_bignum, [t/2, type(tags/0)]).+:- use_module(prelude).+:- chr_constraint t/2.+:- chr_type tags ---> overflow_64 ; mul_above_2_64 ; neg_overflow.++t(overflow_64, R)    <=> R is 9223372036854775807 + 1.+t(mul_above_2_64, R) <=> R is 1000000000000 * 1000000000000.+t(neg_overflow, R)   <=> R is (-9223372036854775808) - 1.
+ test/golden/arith_bignum/mul_above_2_64.expected view
@@ -0,0 +1,1 @@+R = 1000000000000000000000000
+ test/golden/arith_bignum/mul_above_2_64.goal view
@@ -0,0 +1,1 @@+arith_bignum:t(mul_above_2_64, R)
+ test/golden/arith_bignum/neg_overflow.expected view
@@ -0,0 +1,1 @@+R = (-9223372036854775809)
+ test/golden/arith_bignum/neg_overflow.goal view
@@ -0,0 +1,1 @@+arith_bignum:t(neg_overflow, R)
+ test/golden/arith_bignum/overflow_64.expected view
@@ -0,0 +1,1 @@+R = 9223372036854775808
+ test/golden/arith_bignum/overflow_64.goal view
@@ -0,0 +1,1 @@+arith_bignum:t(overflow_64, R)
+ test/golden/arith_float/add_neg.expected view
@@ -0,0 +1,1 @@+R = (-1.0)
+ test/golden/arith_float/add_neg.goal view
@@ -0,0 +1,1 @@+arith_float:t(add_neg, R)
+ test/golden/arith_float/add_pos.expected view
@@ -0,0 +1,1 @@+R = 3.75
+ test/golden/arith_float/add_pos.goal view
@@ -0,0 +1,1 @@+arith_float:t(add_pos, R)
+ test/golden/arith_float/add_zero.expected view
@@ -0,0 +1,1 @@+R = 3.5
+ test/golden/arith_float/add_zero.goal view
@@ -0,0 +1,1 @@+arith_float:t(add_zero, R)
+ test/golden/arith_float/arith_float.chr view
@@ -0,0 +1,19 @@+:- module(arith_float, [t/2, type(tags/0)]).+:- use_module(prelude).+:- chr_constraint t/2.+:- chr_type tags ---> add_pos ; add_zero ; add_neg ; sub_pos ; sub_neg ; mul ; mul_neg ; mul_zero ; div_basic ; div_whole ; div_neg ; small ; large ; neg_zero_add.++t(add_pos, R)      <=> R is 1.5 + 2.25.+t(add_zero, R)     <=> R is 0.0 + 3.5.+t(add_neg, R)      <=> R is 1.5 + (-2.5).+t(sub_pos, R)      <=> R is 5.5 - 1.25.+t(sub_neg, R)      <=> R is 1.0 - 5.0.+t(mul, R)          <=> R is 2.5 * 4.0.+t(mul_neg, R)      <=> R is 2.5 * (-2.0).+t(mul_zero, R)     <=> R is 3.14 * 0.0.+t(div_basic, R)    <=> R is 10.0 / 4.0.+t(div_whole, R)    <=> R is 8.0 / 2.0.+t(div_neg, R)      <=> R is 10.0 / (-4.0).+t(small, R)        <=> R is 1.0 / 1000000.0.+t(large, R)        <=> R is 100000.0 * 100000.0.+t(neg_zero_add, R) <=> R is (-0.0) + 0.0.
+ test/golden/arith_float/div_basic.expected view
@@ -0,0 +1,1 @@+R = 2.5
+ test/golden/arith_float/div_basic.goal view
@@ -0,0 +1,1 @@+arith_float:t(div_basic, R)
+ test/golden/arith_float/div_neg.expected view
@@ -0,0 +1,1 @@+R = (-2.5)
+ test/golden/arith_float/div_neg.goal view
@@ -0,0 +1,1 @@+arith_float:t(div_neg, R)
+ test/golden/arith_float/div_whole.expected view
@@ -0,0 +1,1 @@+R = 4.0
+ test/golden/arith_float/div_whole.goal view
@@ -0,0 +1,1 @@+arith_float:t(div_whole, R)
+ test/golden/arith_float/large.expected view
@@ -0,0 +1,1 @@+R = 1.0e10
+ test/golden/arith_float/large.goal view
@@ -0,0 +1,1 @@+arith_float:t(large, R)
+ test/golden/arith_float/mul.expected view
@@ -0,0 +1,1 @@+R = 10.0
+ test/golden/arith_float/mul.goal view
@@ -0,0 +1,1 @@+arith_float:t(mul, R)
+ test/golden/arith_float/mul_neg.expected view
@@ -0,0 +1,1 @@+R = (-5.0)
+ test/golden/arith_float/mul_neg.goal view
@@ -0,0 +1,1 @@+arith_float:t(mul_neg, R)
+ test/golden/arith_float/mul_zero.expected view
@@ -0,0 +1,1 @@+R = 0.0
+ test/golden/arith_float/mul_zero.goal view
@@ -0,0 +1,1 @@+arith_float:t(mul_zero, R)
+ test/golden/arith_float/neg_zero_add.expected view
@@ -0,0 +1,1 @@+R = 0.0
+ test/golden/arith_float/neg_zero_add.goal view
@@ -0,0 +1,1 @@+arith_float:t(neg_zero_add, R)
+ test/golden/arith_float/small.expected view
@@ -0,0 +1,1 @@+R = 1.0e-6
+ test/golden/arith_float/small.goal view
@@ -0,0 +1,1 @@+arith_float:t(small, R)
+ test/golden/arith_float/sub_neg.expected view
@@ -0,0 +1,1 @@+R = (-4.0)
+ test/golden/arith_float/sub_neg.goal view
@@ -0,0 +1,1 @@+arith_float:t(sub_neg, R)
+ test/golden/arith_float/sub_pos.expected view
@@ -0,0 +1,1 @@+R = 4.25
+ test/golden/arith_float/sub_pos.goal view
@@ -0,0 +1,1 @@+arith_float:t(sub_pos, R)
+ test/golden/arith_int/add_neg.expected view
@@ -0,0 +1,1 @@+R = (-2)
+ test/golden/arith_int/add_neg.goal view
@@ -0,0 +1,1 @@+arith_int:t(add_neg, R)
+ test/golden/arith_int/add_pos.expected view
@@ -0,0 +1,1 @@+R = 8
+ test/golden/arith_int/add_pos.goal view
@@ -0,0 +1,1 @@+arith_int:t(add_pos, R)
+ test/golden/arith_int/add_zero.expected view
@@ -0,0 +1,1 @@+R = 7
+ test/golden/arith_int/add_zero.goal view
@@ -0,0 +1,1 @@+arith_int:t(add_zero, R)
+ test/golden/arith_int/arith_int.chr view
@@ -0,0 +1,28 @@+:- module(arith_int, [t/2, type(tags/0)]).+:- use_module(prelude).+:- chr_constraint t/2.+:- chr_type tags ---> add_pos ; add_zero ; add_neg ; sub_pos ; sub_neg ; mul_pos ; mul_neg ; mul_zero ; div_pos ; div_neg_num ; div_neg_den ; div_both_neg ; div_exact ; mod_pos ; mod_zero ; mod_neg_num ; mod_neg_den ; rem_pos ; rem_zero ; rem_neg_num ; rem_neg_den ; rem_both_neg ; big.++t(add_pos, R)      <=> R is 3 + 5.+t(add_zero, R)     <=> R is 7 + 0.+t(add_neg, R)      <=> R is 3 + (-5).+t(sub_pos, R)      <=> R is 10 - 4.+t(sub_neg, R)      <=> R is 4 - 10.+t(mul_pos, R)      <=> R is 6 * 7.+t(mul_neg, R)      <=> R is 6 * (-7).+t(mul_zero, R)     <=> R is 6 * 0.+t(div_pos, R)      <=> R is 20 div 3.+t(div_neg_num, R)  <=> R is (-20) div 3.+t(div_neg_den, R)  <=> R is 20 div (-3).+t(div_both_neg, R) <=> R is (-20) div (-3).+t(div_exact, R)    <=> R is 21 div 3.+t(mod_pos, R)      <=> R is 20 mod 3.+t(mod_zero, R)     <=> R is 21 mod 3.+t(mod_neg_num, R)  <=> R is (-20) mod 3.+t(mod_neg_den, R)  <=> R is 20 mod (-3).+t(rem_pos, R)      <=> R is 20 rem 3.+t(rem_zero, R)     <=> R is 21 rem 3.+t(rem_neg_num, R)  <=> R is (-20) rem 3.+t(rem_neg_den, R)  <=> R is 20 rem (-3).+t(rem_both_neg, R) <=> R is (-20) rem (-3).+t(big, R)          <=> R is 1000000 * 1000000.
+ test/golden/arith_int/big.expected view
@@ -0,0 +1,1 @@+R = 1000000000000
+ test/golden/arith_int/big.goal view
@@ -0,0 +1,1 @@+arith_int:t(big, R)
+ test/golden/arith_int/div_both_neg.expected view
@@ -0,0 +1,1 @@+R = 6
+ test/golden/arith_int/div_both_neg.goal view
@@ -0,0 +1,1 @@+arith_int:t(div_both_neg, R)
+ test/golden/arith_int/div_exact.expected view
@@ -0,0 +1,1 @@+R = 7
+ test/golden/arith_int/div_exact.goal view
@@ -0,0 +1,1 @@+arith_int:t(div_exact, R)
+ test/golden/arith_int/div_neg_den.expected view
@@ -0,0 +1,1 @@+R = (-7)
+ test/golden/arith_int/div_neg_den.goal view
@@ -0,0 +1,1 @@+arith_int:t(div_neg_den, R)
+ test/golden/arith_int/div_neg_num.expected view
@@ -0,0 +1,1 @@+R = (-7)
+ test/golden/arith_int/div_neg_num.goal view
@@ -0,0 +1,1 @@+arith_int:t(div_neg_num, R)
+ test/golden/arith_int/div_pos.expected view
@@ -0,0 +1,1 @@+R = 6
+ test/golden/arith_int/div_pos.goal view
@@ -0,0 +1,1 @@+arith_int:t(div_pos, R)
+ test/golden/arith_int/mod_neg_den.expected view
@@ -0,0 +1,1 @@+R = (-1)
+ test/golden/arith_int/mod_neg_den.goal view
@@ -0,0 +1,1 @@+arith_int:t(mod_neg_den, R)
+ test/golden/arith_int/mod_neg_num.expected view
@@ -0,0 +1,1 @@+R = 1
+ test/golden/arith_int/mod_neg_num.goal view
@@ -0,0 +1,1 @@+arith_int:t(mod_neg_num, R)
+ test/golden/arith_int/mod_pos.expected view
@@ -0,0 +1,1 @@+R = 2
+ test/golden/arith_int/mod_pos.goal view
@@ -0,0 +1,1 @@+arith_int:t(mod_pos, R)
+ test/golden/arith_int/mod_zero.expected view
@@ -0,0 +1,1 @@+R = 0
+ test/golden/arith_int/mod_zero.goal view
@@ -0,0 +1,1 @@+arith_int:t(mod_zero, R)
+ test/golden/arith_int/mul_neg.expected view
@@ -0,0 +1,1 @@+R = (-42)
+ test/golden/arith_int/mul_neg.goal view
@@ -0,0 +1,1 @@+arith_int:t(mul_neg, R)
+ test/golden/arith_int/mul_pos.expected view
@@ -0,0 +1,1 @@+R = 42
+ test/golden/arith_int/mul_pos.goal view
@@ -0,0 +1,1 @@+arith_int:t(mul_pos, R)
+ test/golden/arith_int/mul_zero.expected view
@@ -0,0 +1,1 @@+R = 0
+ test/golden/arith_int/mul_zero.goal view
@@ -0,0 +1,1 @@+arith_int:t(mul_zero, R)
+ test/golden/arith_int/rem_both_neg.expected view
@@ -0,0 +1,1 @@+R = (-2)
+ test/golden/arith_int/rem_both_neg.goal view
@@ -0,0 +1,1 @@+arith_int:t(rem_both_neg, R)
+ test/golden/arith_int/rem_neg_den.expected view
@@ -0,0 +1,1 @@+R = 2
+ test/golden/arith_int/rem_neg_den.goal view
@@ -0,0 +1,1 @@+arith_int:t(rem_neg_den, R)
+ test/golden/arith_int/rem_neg_num.expected view
@@ -0,0 +1,1 @@+R = (-2)
+ test/golden/arith_int/rem_neg_num.goal view
@@ -0,0 +1,1 @@+arith_int:t(rem_neg_num, R)
+ test/golden/arith_int/rem_pos.expected view
@@ -0,0 +1,1 @@+R = 2
+ test/golden/arith_int/rem_pos.goal view
@@ -0,0 +1,1 @@+arith_int:t(rem_pos, R)
+ test/golden/arith_int/rem_zero.expected view
@@ -0,0 +1,1 @@+R = 0
+ test/golden/arith_int/rem_zero.goal view
@@ -0,0 +1,1 @@+arith_int:t(rem_zero, R)
+ test/golden/arith_int/sub_neg.expected view
@@ -0,0 +1,1 @@+R = (-6)
+ test/golden/arith_int/sub_neg.goal view
@@ -0,0 +1,1 @@+arith_int:t(sub_neg, R)
+ test/golden/arith_int/sub_pos.expected view
@@ -0,0 +1,1 @@+R = 6
+ test/golden/arith_int/sub_pos.goal view
@@ -0,0 +1,1 @@+arith_int:t(sub_pos, R)
+ test/golden/arith_int_float_mismatch/arith_int_float_mismatch.chr view
@@ -0,0 +1,5 @@+:- module(arith_int_float_mismatch, [t/1]).+:- use_module(prelude).+:- chr_constraint t/1.++t(R) <=> R is 1 + 1.0.
+ test/golden/arith_int_float_mismatch/arith_int_float_mismatch.error view
@@ -0,0 +1,1 @@+YCHR-60006
+ test/golden/arity_overload/arity_overload.chr view
@@ -0,0 +1,6 @@+:- module(arity_overload, [test/2]).+:- chr_constraint foo/1, foo/2, test/2.++foo(X) <=> X = one.+foo(X, Y) <=> X = two, Y = args.+test(R1, R2) <=> foo(R1), foo(R2, _).
+ test/golden/arity_overload/arity_overload.expected view
@@ -0,0 +1,2 @@+R1 = one+R2 = two
+ test/golden/arity_overload/arity_overload.goal view
@@ -0,0 +1,1 @@+arity_overload:test(R1, R2)
+ test/golden/bare_atom_canonicalization/a_modA.chr view
@@ -0,0 +1,3 @@+:- module(modA, [type(col/0)]).++:- chr_type col ---> shared ; only_in_a.
+ test/golden/bare_atom_canonicalization/a_qualified.expected view
@@ -0,0 +1,1 @@+R = a
+ test/golden/bare_atom_canonicalization/a_qualified.goal view
@@ -0,0 +1,1 @@+bacmain:tag(modA:only_in_a, R)
+ test/golden/bare_atom_canonicalization/a_unique.expected view
@@ -0,0 +1,1 @@+R = a
+ test/golden/bare_atom_canonicalization/a_unique.goal view
@@ -0,0 +1,1 @@+bacmain:tag(only_in_a, R)
+ test/golden/bare_atom_canonicalization/b_box.expected view
@@ -0,0 +1,1 @@+R = b
+ test/golden/bare_atom_canonicalization/b_box.goal view
@@ -0,0 +1,1 @@+bacmain:tag(box, R)
+ test/golden/bare_atom_canonicalization/b_modB.chr view
@@ -0,0 +1,3 @@+:- module(modB, [type(shape/0)]).++:- chr_type shape ---> only_in_b ; box.
+ test/golden/bare_atom_canonicalization/b_qualified.expected view
@@ -0,0 +1,1 @@+R = b
+ test/golden/bare_atom_canonicalization/b_qualified.goal view
@@ -0,0 +1,1 @@+bacmain:tag(modB:only_in_b, R)
+ test/golden/bare_atom_canonicalization/b_unique.expected view
@@ -0,0 +1,1 @@+R = b
+ test/golden/bare_atom_canonicalization/b_unique.goal view
@@ -0,0 +1,1 @@+bacmain:tag(only_in_b, R)
+ test/golden/bare_atom_canonicalization/c_main.chr view
@@ -0,0 +1,12 @@+:- module(bacmain, [tag/2]).+:- use_module(modA).+:- use_module(modB).+:- chr_constraint tag/2.++% Atoms unique to a single module canonicalize to that module's+% qualified form. Atoms shared between modules stay unqualified+% (since the renamer can't pick a unique source).+tag(only_in_a, R) <=> R = a.+tag(only_in_b, R) <=> R = b.+tag(box, R)       <=> R = b.+tag(_, R)         <=> R = other.
+ test/golden/bare_atom_canonicalization/other.expected view
@@ -0,0 +1,1 @@+R = other
+ test/golden/bare_atom_canonicalization/other.goal view
@@ -0,0 +1,1 @@+bacmain:tag(unknown_atom, R)
+ test/golden/bare_vs_qualified/bare_vs_qualified.chr view
@@ -0,0 +1,11 @@+:- module(bare_vs_qualified, [c/2, type(col/0)]).++% Verifies that a head pattern using the bare form of a declared+% constructor matches a goal that uses the qualified form (and vice+% versa). Both must produce the same runtime atom under the+% canonicalization implemented by the renamer.+:- chr_type col ---> red ; green.++:- chr_constraint c(col, any).++c(red, R) <=> R = ok.
+ test/golden/bare_vs_qualified/bare_vs_qualified.expected view
@@ -0,0 +1,1 @@+R = ok
+ test/golden/bare_vs_qualified/bare_vs_qualified.goal view
@@ -0,0 +1,1 @@+bare_vs_qualified:c(bare_vs_qualified:red, R)
+ test/golden/bare_vs_qualified_swapped/bare_vs_qualified_swapped.chr view
@@ -0,0 +1,9 @@+:- module(bare_vs_qualified_swapped, [c/2, type(col/0)]).++% Mirror of bare_vs_qualified: the head uses the qualified form, the+% goal uses the bare form. Same canonicalization, same runtime atom.+:- chr_type col ---> red ; green.++:- chr_constraint c(col, any).++c(bare_vs_qualified_swapped:red, R) <=> R = ok.
+ test/golden/bare_vs_qualified_swapped/bare_vs_qualified_swapped.expected view
@@ -0,0 +1,1 @@+R = ok
+ test/golden/bare_vs_qualified_swapped/bare_vs_qualified_swapped.goal view
@@ -0,0 +1,1 @@+bare_vs_qualified_swapped:c(red, R)
+ test/golden/bcd/bcd.chr view
@@ -0,0 +1,12 @@+:- module(bcd, [result/1]).++:- chr_constraint a/0, b/0, c/0, d/0, bcd/1, result/1.++a ==> b.+a, b ==> c.+a <=> true.+a, b ==> d.++bcd(R), b, c, d <=> R = "bcd".++result(R) <=> a, bcd(R).
+ test/golden/bcd/bcd.expected view
@@ -0,0 +1,1 @@+R = "bcd"
+ test/golden/bcd/bcd.goal view
@@ -0,0 +1,1 @@+bcd:result(R)
+ test/golden/body_unify_fresh/basic.expected view
@@ -0,0 +1,1 @@+R = 10
+ test/golden/body_unify_fresh/basic.goal view
@@ -0,0 +1,1 @@+buf:test(R)
+ test/golden/body_unify_fresh/body_unify_fresh.chr view
@@ -0,0 +1,12 @@+:- module(buf, [test/1, test2/1, test3/2]).+:- chr_constraint test/1, test2/1, test3/2.+:- chr_type pair_t(A, B) ---> pair(A, B).++% Basic: introduce Y via =, then use it (the repro from BUGS.md)+test(R) <=> Y = 10, R = Y.++% Two fresh vars unified, then one bound+test2(R) <=> X = Y, Y = 20, R = X.++% Fresh vars inside compound terms+test3(R1, R2) <=> pair(X, Y) = pair(1, 2), R1 = X, R2 = Y.
+ test/golden/body_unify_fresh/compound.expected view
@@ -0,0 +1,2 @@+R1 = 1+R2 = 2
+ test/golden/body_unify_fresh/compound.goal view
@@ -0,0 +1,1 @@+buf:test3(R1, R2)
+ test/golden/body_unify_fresh/two_vars.expected view
@@ -0,0 +1,1 @@+R = 20
+ test/golden/body_unify_fresh/two_vars.goal view
@@ -0,0 +1,1 @@+buf:test2(R)
+ test/golden/bounded_constraint_unbound_variable/bounded_constraint_unbound_variable.chr view
@@ -0,0 +1,14 @@+:- module(bounded_constraint_unbound_variable, [result/1]).+:- use_module(library(prelude)).++:- function (gt(int, int) -> bool).+gt(X, Y) -> X > Y.++% Forbidden: U is mentioned in the constraint's requiring clause but+% has no occurrence in the primary signature. This exercises the+% 'conBounds' branch of checkBoundedDeclarations — existing tests only+% cover the 'funcBounds' branch.+:- chr_constraint pick(T, T) requiring gt(U, U) -> bool.+:- chr_constraint result(int).++pick(_, _), result(_) <=> true.
+ test/golden/bounded_constraint_unbound_variable/bounded_constraint_unbound_variable.error view
@@ -0,0 +1,1 @@+YCHR-16008
+ test/golden/bounded_constraint_unknown_function/bounded_constraint_unknown_function.chr view
@@ -0,0 +1,11 @@+:- module(bounded_constraint_unknown_function, [result/1]).+:- use_module(library(prelude)).++% 'cmp/2' is a constraint, not a function. The renamer accepts the name+% in the requiring clause (constraints and functions share the symbol+% namespace), but the resolver detects that the bound's target is not a+% function. Exercises the constraint-bounds side of checkBoundedDeclarations.+:- chr_constraint pick(T, T) requiring cmp(T, T) -> bool.+:- chr_constraint result(int), cmp(any, any).++pick(_, _), result(_) <=> true.
+ test/golden/bounded_constraint_unknown_function/bounded_constraint_unknown_function.error view
@@ -0,0 +1,1 @@+YCHR-16009
+ test/golden/bounded_constraint_unknown_function_undeclared/bounded_constraint_unknown_function_undeclared.chr view
@@ -0,0 +1,9 @@+:- module(q).++% Constraint-side mirror of bounded_unknown_function_undeclared: the+% 'requiring' clause on a ':- chr_constraint' references a name that+% is not declared as anything in scope. The renamer cannot qualify+% it; the resolver emits unknown_bound_function (YCHR-16009).+:- chr_constraint pick(T, T) requiring nonexistent(T) -> T.++pick(_, _) <=> true.
+ test/golden/bounded_constraint_unknown_function_undeclared/bounded_constraint_unknown_function_undeclared.error view
@@ -0,0 +1,1 @@+YCHR-16009
+ test/golden/bounded_cycle/bounded_cycle.chr view
@@ -0,0 +1,12 @@+:- module(bounded_cycle, [result/1]).+:- use_module(library(prelude)).++:- chr_constraint result(int).++:- function f(T) -> T requiring g(T) -> T.+:- function g(T) -> T requiring f(T) -> T.++f(X) -> X.+g(X) -> X.++result(R) <=> R is f(1).
+ test/golden/bounded_cycle/bounded_cycle.error view
@@ -0,0 +1,1 @@+YCHR-16010
+ test/golden/bounded_cycle_cross_module/a.chr view
@@ -0,0 +1,7 @@+:- module(a, [f/1]).+:- use_module(library(prelude)).+:- use_module(b, [g/1]).++% Module a's 'f' requires module b's 'g'.+:- function f(T) -> T requiring g(T) -> T.+f(X) -> X.
+ test/golden/bounded_cycle_cross_module/b.chr view
@@ -0,0 +1,8 @@+:- module(b, [g/1]).+:- use_module(library(prelude)).+:- use_module(a, [f/1]).++% Module b's 'g' requires module a's 'f'. Together with a.chr this+% forms a cross-module bound cycle.+:- function g(T) -> T requiring f(T) -> T.+g(X) -> X.
+ test/golden/bounded_cycle_cross_module/bounded_cycle_cross_module.error view
@@ -0,0 +1,1 @@+YCHR-16010
+ test/golden/bounded_cycle_self_loop/bounded_cycle_self_loop.chr view
@@ -0,0 +1,12 @@+:- module(bounded_cycle_self_loop, [result/1]).+:- use_module(library(prelude)).++:- chr_constraint result(int).++% Forbidden: 'f' requires itself. Single-vertex self-loop exercises the+% 'qn elem path' branch in dfs when qn == the current vertex (path+% length 1). The cycle graph must be acyclic.+:- function f(T) -> T requiring f(T) -> T.+f(X) -> X.++result(R) <=> R is f(1).
+ test/golden/bounded_cycle_self_loop/bounded_cycle_self_loop.error view
@@ -0,0 +1,1 @@+YCHR-16010
+ test/golden/bounded_cycle_three_nodes/bounded_cycle_three_nodes.chr view
@@ -0,0 +1,17 @@+:- module(bounded_cycle_three_nodes, [result/1]).+:- use_module(library(prelude)).++:- chr_constraint result(int).++% Forbidden: f -> g -> h -> f. The cycle is longer than two nodes,+% exercising the cycle reconstruction path in dfs ('qn : reverse+% (takeWhile (/= qn) path) ++ [qn]') with a non-trivial 'path' length.+:- function f(T) -> T requiring g(T) -> T.+:- function g(T) -> T requiring h(T) -> T.+:- function h(T) -> T requiring f(T) -> T.++f(X) -> X.+g(X) -> X.+h(X) -> X.++result(R) <=> R is f(1).
+ test/golden/bounded_cycle_three_nodes/bounded_cycle_three_nodes.error view
@@ -0,0 +1,1 @@+YCHR-16010
+ test/golden/bounded_extend_function/bounded_extend_function.chr view
@@ -0,0 +1,18 @@+:- module(bounded_extend_function, [result/1]).+:- use_module(library(prelude)).++:- chr_constraint result(int).++:- class (gt(int, int) -> bool), (gt(float, float) -> bool).+gt(X, Y) -> X > Y.++% Bounded open function with one initial equation.+:- open_function pick(T, T) -> T requiring gt(T, T) -> bool.+pick(X, _) | gt(X, X) -> X.++% Extension: a new equation for the bounded open function. Allowed+% because :- extend_function is permitted on bounded open functions;+% the new equation type-checks under the same ambient bound.+:- extend_function pick(_, Y) -> Y.++result(R) <=> R is pick(3, 5).
+ test/golden/bounded_extend_function/bounded_extend_function.expected view
@@ -0,0 +1,1 @@+R = 5
+ test/golden/bounded_extend_function/bounded_extend_function.goal view
@@ -0,0 +1,1 @@+result(R)
+ test/golden/bounded_extend_type/bounded_extend_type.chr view
@@ -0,0 +1,16 @@+:- module(bounded_extend_type, [result/1]).+:- use_module(library(prelude)).++:- chr_constraint result(int).++:- function (gt(int, int) -> bool).+gt(X, Y) -> X > Y.++% Bounded open function.+:- open_function pick(T, T) -> T requiring gt(T, T) -> bool.+pick(X, _) -> X.++% Forbidden: extend_class_type on a bounded open function.+:- extend_class_type (pick(float, float) -> float).++result(R) <=> R is pick(1, 2).
+ test/golden/bounded_extend_type/bounded_extend_type.error view
@@ -0,0 +1,1 @@+YCHR-16007
+ test/golden/bounded_max_int/bounded_max_int.chr view
@@ -0,0 +1,15 @@+:- module(bounded_max_int, [result/1]).+:- use_module(library(prelude)).++:- chr_constraint result(int).++:- class (gt(int, int) -> bool), (gt(float, float) -> bool).+gt(X, Y) | integer(X), integer(Y) -> X > Y.+gt(X, Y) -> X > Y.++:- function pick_max(T, T) -> T requiring gt(T, T) -> bool.++pick_max(X, Y) | gt(X, Y) -> X.+pick_max(_, Y) -> Y.++result(R) <=> R is pick_max(3, 4).
+ test/golden/bounded_max_int/bounded_max_int.expected view
@@ -0,0 +1,1 @@+R = 4
+ test/golden/bounded_max_int/bounded_max_int.goal view
@@ -0,0 +1,1 @@+result(R)
+ test/golden/bounded_requiring_on_class/bounded_requiring_on_class.chr view
@@ -0,0 +1,18 @@+:- module(bounded_requiring_on_class, [result/1]).+:- use_module(library(prelude)).++:- chr_constraint result(int).++:- class (gt(int, int) -> bool), (gt(float, float) -> bool).+gt(X, Y) -> X > Y.++% Forbidden: requiring on :- class. Bounded polymorphism is reserved+% for :- function / :- open_function. The parser rejects this as+% RequiringOnClass (YCHR-15005).+:- class+    (pick(int, int) -> int requiring gt(int, int) -> bool),+    (pick(float, float) -> float).++pick(X, _) -> X.++result(R) <=> R is pick(1, 2).
+ test/golden/bounded_requiring_on_class/bounded_requiring_on_class.error view
@@ -0,0 +1,1 @@+YCHR-15005
+ test/golden/bounded_sorted_constraint/bounded_sorted_constraint.chr view
@@ -0,0 +1,17 @@+:- module(bounded_sorted_constraint, [check_int/1, check_float/1]).+:- use_module(library(prelude)).++:- class (lt(int, int) -> bool), (lt(float, float) -> bool).+lt(X, Y) -> X < Y.++% Bounded constraint: sorted is parametric in the element type, with a+% required ordering operation on that type.+:- chr_constraint sorted(list(T)) requiring lt(T, T) -> bool.+:- chr_constraint check_int(int), check_float(int).++sorted([]) <=> true.+sorted([_]) <=> true.+sorted([X, Y | Rest]) <=> lt(X, Y) | sorted([Y | Rest]).++check_int(_) <=> sorted([1, 2, 3]).+check_float(_) <=> sorted([1.0, 2.0, 3.0]).
+ test/golden/bounded_sorted_constraint/bounded_sorted_constraint.expected view
+ test/golden/bounded_sorted_constraint/bounded_sorted_constraint.goal view
@@ -0,0 +1,1 @@+check_int(0)
+ test/golden/bounded_unbound_variable/bounded_unbound_variable.chr view
@@ -0,0 +1,14 @@+:- module(bounded_unbound_variable, [result/1]).+:- use_module(library(prelude)).++:- chr_constraint result(int).++:- function (gt(int, int) -> bool).+gt(X, Y) -> X > Y.++% U is not bound by the primary signature.+:- function pick(T, T) -> T requiring gt(U, U) -> bool.++pick(X, _) -> X.++result(R) <=> R is pick(1, 2).
+ test/golden/bounded_unbound_variable/bounded_unbound_variable.error view
@@ -0,0 +1,1 @@+YCHR-16008
+ test/golden/bounded_unknown_function/bounded_unknown_function.chr view
@@ -0,0 +1,14 @@+:- module(bounded_unknown_function, [result/1]).+:- use_module(library(prelude)).++% A constraint, not a function. The renamer accepts the name in the+% requiring clause (constraints and functions share the symbol+% namespace), but the resolver detects that the bound's target is+% not a function and emits unknown_bound_function.+:- chr_constraint result(any), foo(int, int).++:- function pick(T, T) -> T requiring foo(T, T) -> bool.++pick(X, _) -> X.++result(R) <=> R is pick(1, 2).
+ test/golden/bounded_unknown_function/bounded_unknown_function.error view
@@ -0,0 +1,1 @@+YCHR-16009
+ test/golden/bounded_unknown_function_undeclared/bounded_unknown_function_undeclared.chr view
@@ -0,0 +1,9 @@+:- module(q).++% A 'requiring' clause references a name that is not declared as+% anything in scope. The renamer cannot qualify it; the resolver+% emits the dedicated unknown_bound_function diagnostic+% (YCHR-16009) — not the generic YCHR-20002.+:- function foo(T) -> T requiring nonexistent(T) -> T.++foo(X) -> X.
+ test/golden/bounded_unknown_function_undeclared/bounded_unknown_function_undeclared.error view
@@ -0,0 +1,1 @@+YCHR-16009
+ test/golden/bounded_unresolved_arg/bounded_unresolved_arg.chr view
@@ -0,0 +1,15 @@+:- module(bounded_unresolved_arg, [result/2]).+:- use_module(library(prelude)).++:- chr_constraint result(any, any).++:- class (gt(int, int) -> bool), (gt(float, float) -> bool).+gt(X, Y) -> X > Y.++:- function pick(T, T) -> T requiring gt(T, T) -> bool.+pick(X, _) -> X.++% Polymorphic use: X is unconstrained at the call site, so the bound's+% substitution stays partial and discharges silently per the gradual+% guarantee. Type-check should accept this with no errors.+result(X, R) <=> R is pick(X, X).
+ test/golden/bounded_unresolved_arg/bounded_unresolved_arg.expected view
@@ -0,0 +1,1 @@+R = 7
+ test/golden/bounded_unresolved_arg/bounded_unresolved_arg.goal view
@@ -0,0 +1,1 @@+result(7, R)
+ test/golden/bounded_unsatisfied_string/bounded_unsatisfied_string.chr view
@@ -0,0 +1,16 @@+:- module(bounded_unsatisfied_string, [result/1]).+:- use_module(library(prelude)).++:- chr_constraint result(any).++% Only int and float overloads — no string variant.+:- class (gt(int, int) -> bool), (gt(float, float) -> bool).+gt(X, Y) -> X > Y.++:- function pick_max(T, T) -> T requiring gt(T, T) -> bool.++pick_max(X, Y) | gt(X, Y) -> X.+pick_max(_, Y) -> Y.++% Bound unsatisfied: there is no gt(string, string) -> bool.+result(R) <=> R is pick_max("a", "b").
+ test/golden/bounded_unsatisfied_string/bounded_unsatisfied_string.error view
@@ -0,0 +1,1 @@+YCHR-60012
+ test/golden/class_single_sig/class_single_sig.chr view
@@ -0,0 +1,9 @@+:- module(class_single_sig, [result/1]).+:- chr_constraint result(any).++% A :- class with a single signature is allowed — verbose, but legal.+% Idiomatic single-signature code still uses :- function.+:- class (sz(int) -> int).+sz(N) -> N.++result(R) <=> R is sz(7).
+ test/golden/class_single_sig/class_single_sig.expected view
@@ -0,0 +1,1 @@+R = 7
+ test/golden/class_single_sig/class_single_sig.goal view
@@ -0,0 +1,1 @@+result(R)
+ test/golden/class_with_requiring/class_with_requiring.chr view
@@ -0,0 +1,16 @@+:- module(class_with_requiring, [result/1]).+:- use_module(library(prelude)).++:- chr_constraint result(int).++:- class (gt(int, int) -> bool).+gt(X, Y) -> X > Y.++% Forbidden: requiring is reserved for :- function / :- open_function.+% Producing a :- class with a requiring clause is rejected as+% RequiringOnClass (YCHR-15005).+:- class pick(T, T) -> T requiring gt(T, T) -> bool.++pick(X, _) -> X.++result(R) <=> R is pick(1, 2).
+ test/golden/class_with_requiring/class_with_requiring.error view
@@ -0,0 +1,1 @@+YCHR-15005
+ test/golden/comments_and_whitespace/after_blank.expected view
@@ -0,0 +1,1 @@+R = wrapped
+ test/golden/comments_and_whitespace/after_blank.goal view
@@ -0,0 +1,1 @@+cw:t(after_blank, R)
+ test/golden/comments_and_whitespace/comments_and_whitespace.chr view
@@ -0,0 +1,33 @@+% Top-level comment before module declaration.+:- module(cw, [t/2, type(tags/0)]).+:- use_module(prelude). % Trailing comment after directive.++% Comment between directives.++:- chr_constraint t/2.+:- chr_type tags ---> simple ; after_blank ; many_blanks ; deep_calc.++% Comment between rules.+t(simple, R) <=> R = ok.   % Mid-line trailing comment.++t(after_blank,+  R) <=>          % Comment in mid-rule.+    R = wrapped.  % Comment between body items.++% Multi-paragraph block.+%+% Each line starts with %.+%++t(many_blanks, R) <=>+++    R = blanks_ok.++t(deep_calc, R) <=>+    % Comment inside a body.+    A is 2,+    % Another inside.+    B is 3,+    R is A + B.+% Trailing comment at EOF; no newline before it intentionally absent.
+ test/golden/comments_and_whitespace/deep_calc.expected view
@@ -0,0 +1,1 @@+R = 5
+ test/golden/comments_and_whitespace/deep_calc.goal view
@@ -0,0 +1,1 @@+cw:t(deep_calc, R)
+ test/golden/comments_and_whitespace/many_blanks.expected view
@@ -0,0 +1,1 @@+R = blanks_ok
+ test/golden/comments_and_whitespace/many_blanks.goal view
@@ -0,0 +1,1 @@+cw:t(many_blanks, R)
+ test/golden/comments_and_whitespace/simple.expected view
@@ -0,0 +1,1 @@+R = ok
+ test/golden/comments_and_whitespace/simple.goal view
@@ -0,0 +1,1 @@+cw:t(simple, R)
+ test/golden/comparisons/atom_eq.expected view
@@ -0,0 +1,1 @@+R = yes
+ test/golden/comparisons/atom_eq.goal view
@@ -0,0 +1,1 @@+comparisons:t(atom_eq, R)
+ test/golden/comparisons/atom_neq.expected view
@@ -0,0 +1,1 @@+R = no
+ test/golden/comparisons/atom_neq.goal view
@@ -0,0 +1,1 @@+comparisons:t(atom_neq, R)
+ test/golden/comparisons/comparisons.chr view
@@ -0,0 +1,48 @@+:- module(comparisons, [t/2, type(tags/0)]).+:- use_module(prelude).+:- chr_constraint t/2.+:- chr_type tags ---> int_lt ; int_gt ; int_le_eq ; int_le_lt ; int_ge_eq ; int_eq_yes ; int_eq_no ; flt_lt ; flt_eq ; atom_eq ; atom_neq ; term_eq ; term_neq.++% Integer comparisons. Each rule is dispatched on the tag and a numeric+% comparison guard; the binding tells us which clause matched.+t(int_lt, R)     <=> 3 < 5  | R = lt.+t(int_lt, R)     <=> R = ge.++t(int_gt, R)     <=> 5 > 3  | R = gt.+t(int_gt, R)     <=> R = le.++t(int_le_eq, R)  <=> 4 =< 4 | R = le.+t(int_le_eq, R)  <=> R = gt.++t(int_le_lt, R)  <=> 3 =< 4 | R = le.+t(int_le_lt, R)  <=> R = gt.++t(int_ge_eq, R)  <=> 4 >= 4 | R = ge.+t(int_ge_eq, R)  <=> R = lt.++t(int_eq_yes, R) <=> 7 == 7 | R = yes.+t(int_eq_yes, R) <=> R = no.++t(int_eq_no, R)  <=> 7 == 8 | R = yes.+t(int_eq_no, R)  <=> R = no.++% Float comparisons.+t(flt_lt, R)     <=> 1.5 < 2.5 | R = lt.+t(flt_lt, R)     <=> R = ge.++t(flt_eq, R)     <=> 1.5 == 1.5 | R = yes.+t(flt_eq, R)     <=> R = no.++% Atom equality (==).+t(atom_eq, R)    <=> quote(foo) == quote(foo) | R = yes.+t(atom_eq, R)    <=> R = no.++t(atom_neq, R)   <=> quote(foo) == quote(bar) | R = yes.+t(atom_neq, R)   <=> R = no.++% Term equality (==): structural.+t(term_eq, R)    <=> quote(p(1,2)) == quote(p(1,2)) | R = yes.+t(term_eq, R)    <=> R = no.++t(term_neq, R)   <=> quote(p(1,2)) == quote(p(1,3)) | R = yes.+t(term_neq, R)   <=> R = no.
+ test/golden/comparisons/flt_eq.expected view
@@ -0,0 +1,1 @@+R = yes
+ test/golden/comparisons/flt_eq.goal view
@@ -0,0 +1,1 @@+comparisons:t(flt_eq, R)
+ test/golden/comparisons/flt_lt.expected view
@@ -0,0 +1,1 @@+R = lt
+ test/golden/comparisons/flt_lt.goal view
@@ -0,0 +1,1 @@+comparisons:t(flt_lt, R)
+ test/golden/comparisons/int_eq_no.expected view
@@ -0,0 +1,1 @@+R = no
+ test/golden/comparisons/int_eq_no.goal view
@@ -0,0 +1,1 @@+comparisons:t(int_eq_no, R)
+ test/golden/comparisons/int_eq_yes.expected view
@@ -0,0 +1,1 @@+R = yes
+ test/golden/comparisons/int_eq_yes.goal view
@@ -0,0 +1,1 @@+comparisons:t(int_eq_yes, R)
+ test/golden/comparisons/int_ge_eq.expected view
@@ -0,0 +1,1 @@+R = ge
+ test/golden/comparisons/int_ge_eq.goal view
@@ -0,0 +1,1 @@+comparisons:t(int_ge_eq, R)
+ test/golden/comparisons/int_gt.expected view
@@ -0,0 +1,1 @@+R = gt
+ test/golden/comparisons/int_gt.goal view
@@ -0,0 +1,1 @@+comparisons:t(int_gt, R)
+ test/golden/comparisons/int_le_eq.expected view
@@ -0,0 +1,1 @@+R = le
+ test/golden/comparisons/int_le_eq.goal view
@@ -0,0 +1,1 @@+comparisons:t(int_le_eq, R)
+ test/golden/comparisons/int_le_lt.expected view
@@ -0,0 +1,1 @@+R = le
+ test/golden/comparisons/int_le_lt.goal view
@@ -0,0 +1,1 @@+comparisons:t(int_le_lt, R)
+ test/golden/comparisons/int_lt.expected view
@@ -0,0 +1,1 @@+R = lt
+ test/golden/comparisons/int_lt.goal view
@@ -0,0 +1,1 @@+comparisons:t(int_lt, R)
+ test/golden/comparisons/term_eq.expected view
@@ -0,0 +1,1 @@+R = yes
+ test/golden/comparisons/term_eq.goal view
@@ -0,0 +1,1 @@+comparisons:t(term_eq, R)
+ test/golden/comparisons/term_neq.expected view
@@ -0,0 +1,1 @@+R = no
+ test/golden/comparisons/term_neq.goal view
@@ -0,0 +1,1 @@+comparisons:t(term_neq, R)
+ test/golden/compound_list_test/compound_list_test.chr view
@@ -0,0 +1,7 @@+:- module(compound_list_test, [roundtrip/2]).++:- chr_constraint roundtrip/2.++roundtrip(T, R) <=>+    L is compound_to_list(T),+    R is list_to_compound(L).
+ test/golden/compound_list_test/compound_list_test.expected view
@@ -0,0 +1,1 @@+R = f(1, g(2), 3)
+ test/golden/compound_list_test/compound_list_test.goal view
@@ -0,0 +1,1 @@+compound_list_test:roundtrip(quote(f(1, g(2), 3)), R)
+ test/golden/compound_term_inspection/atom0.expected view
@@ -0,0 +1,1 @@+R = sym
+ test/golden/compound_term_inspection/atom0.goal view
@@ -0,0 +1,1 @@+compound_term_inspection:atom0(R)
+ test/golden/compound_term_inspection/c2l.expected view
@@ -0,0 +1,1 @@+R = [f, 1, 2]
+ test/golden/compound_term_inspection/c2l.goal view
@@ -0,0 +1,1 @@+compound_term_inspection:c2l(R)
+ test/golden/compound_term_inspection/compound_term_inspection.chr view
@@ -0,0 +1,20 @@+:- module(compound_term_inspection, [c2l/1, l2c/1, roundtrip/1, atom0/1, nested/1]).+:- use_module(prelude).+:- chr_constraint c2l/1, l2c/1, roundtrip/1, atom0/1, nested/1.++% compound_to_list: f(1, 2) → [f, 1, 2].+c2l(R) <=> R is compound_to_list(quote(f(1, 2))).++% list_to_compound: [g, a, b] → g(a, b).+l2c(R) <=> R is list_to_compound(quote([g, a, b])).++% Round-trip: c → list → c.+roundtrip(R) <=>+    L is compound_to_list(quote(p(1, foo, bar))),+    R is list_to_compound(L).++% Zero-arg atom: list_to_compound([sym]) → sym (atom).+atom0(R) <=> R is list_to_compound(quote([sym])).++% Nested compound: structure preserved.+nested(R) <=> R is compound_to_list(quote(outer(inner(1, 2), 3))).
+ test/golden/compound_term_inspection/l2c.expected view
@@ -0,0 +1,1 @@+R = g(a, b)
+ test/golden/compound_term_inspection/l2c.goal view
@@ -0,0 +1,1 @@+compound_term_inspection:l2c(R)
+ test/golden/compound_term_inspection/nested.expected view
@@ -0,0 +1,1 @@+R = [outer, inner(1, 2), 3]
+ test/golden/compound_term_inspection/nested.goal view
@@ -0,0 +1,1 @@+compound_term_inspection:nested(R)
+ test/golden/compound_term_inspection/roundtrip.expected view
@@ -0,0 +1,1 @@+R = p(1, foo, bar)
+ test/golden/compound_term_inspection/roundtrip.goal view
@@ -0,0 +1,1 @@+compound_term_inspection:roundtrip(R)
+ test/golden/cons_test/cons_test.chr view
@@ -0,0 +1,7 @@+:- module(cons_test, [go/3]).++:- use_module(library(lists)).++:- chr_constraint go/3.++go(X, Xs, R) <=> R is cons(X, Xs).
+ test/golden/cons_test/cons_test.expected view
@@ -0,0 +1,1 @@+R = [1, 2, 3]
+ test/golden/cons_test/cons_test.goal view
@@ -0,0 +1,1 @@+cons_test:go(1, [2, 3], R)
+ test/golden/constraint_function_collision/constraint_function_collision.chr view
@@ -0,0 +1,11 @@+:- module(constraint_function_collision, [go/0]).+:- chr_constraint go, foo(any).++% Forbidden: 'foo/1' is declared as both :- chr_constraint and :- function+% in the same module. Constraints and functions share the symbol+% namespace, so the collision is ambiguous regardless of whether 'foo'+% is ever referenced. No equation or rule head touches 'foo', so this+% test isolates the collision check from YCHR-16001 / YCHR-16002.+:- function foo/1.++go <=> true.
+ test/golden/constraint_function_collision/constraint_function_collision.error view
@@ -0,0 +1,1 @@+YCHR-16016
+ test/golden/constraint_function_collision_dedup/constraint_function_collision_dedup.chr view
@@ -0,0 +1,12 @@+:- module(constraint_function_collision_dedup, [go/0]).+:- chr_constraint go, foo(any).++% Same constraint colliding with multiple function-side declarations.+% The collision check must emit exactly one diagnostic per+% (module, name, arity), not one per function-side declaration —+% otherwise the user gets duplicate complaints about the same root+% cause.+:- function foo/1.+:- class (foo(int) -> int).++go <=> true.
+ test/golden/constraint_function_collision_dedup/constraint_function_collision_dedup.error view
@@ -0,0 +1,1 @@+YCHR-16016
+ test/golden/constraint_has_equations/constraint_has_equations.chr view
@@ -0,0 +1,9 @@+:- module(constraint_has_equations, [result/1]).+:- chr_constraint result(any), foo(any).++% Forbidden: 'foo/1' is declared as a CHR constraint but has a function+% equation. Constraint names cannot define equations; either remove the+% equation or redeclare 'foo' as ':- function'.+foo(X) -> X.++result(R) <=> R is foo(1).
+ test/golden/constraint_has_equations/constraint_has_equations.error view
@@ -0,0 +1,1 @@+YCHR-16001
+ test/golden/constraint_has_equations_dedup/constraint_has_equations_dedup.chr view
@@ -0,0 +1,11 @@+:- module(constraint_has_equations_dedup, [result/1]).+:- chr_constraint result(any), foo(any).++% Three equations for the same constraint name. The check should emit+% exactly one diagnostic (the first offending equation) rather than+% flooding the user with one diagnostic per equation.+foo(1) -> a.+foo(2) -> b.+foo(3) -> c.++result(R) <=> R is foo(1).
+ test/golden/constraint_has_equations_dedup/constraint_has_equations_dedup.error view
@@ -0,0 +1,1 @@+YCHR-16001
+ test/golden/copy_term_fn/copy_term_fn.chr view
@@ -0,0 +1,6 @@+:- module(copy_term_fn, [test/2]).++:- chr_constraint test/2.++test(X, R) <=>+    R is copy_term(quote(foo(1, X))).
+ test/golden/copy_term_fn/copy_term_fn.expected view
@@ -0,0 +1,1 @@+R = foo(1, hello)
+ test/golden/copy_term_fn/copy_term_fn.goal view
@@ -0,0 +1,1 @@+copy_term_fn:test(quote(hello), R)
+ test/golden/copy_term_sharing/copy_term_sharing.chr view
@@ -0,0 +1,23 @@+:- module(copy_term_sharing, [shared/2, non_shared/3, ground_copy/1, nested_copy/1]).+:- use_module(prelude).+:- chr_constraint shared/2, non_shared/3, ground_copy/1, nested_copy/1.++% Sharing: the copy of f(X, X) is f(Y, Y) with Y shared. Binding the+% copy's first arg to 1 must propagate to its second arg via R.+shared(X, R) <=>+    C is copy_term(quote(f(X, X))),+    C = f(1, R).++% Non-sharing: the copy of f(X, Y) is f(Y1, Y2) with distinct vars.+% Binding only the first arg of the copy leaves R unbound.+non_shared(X, Y, R) <=>+    C is copy_term(quote(f(X, Y))),+    C = f(1, R).++% Ground term copy: structure preserved verbatim.+ground_copy(R) <=>+    R is copy_term(quote(p(1, foo, [a, b]))).++% Nested ground copy.+nested_copy(R) <=>+    R is copy_term(quote(t1(t2(t3(42))))).
+ test/golden/copy_term_sharing/ground.expected view
@@ -0,0 +1,1 @@+R = p(1, foo, [a, b])
+ test/golden/copy_term_sharing/ground.goal view
@@ -0,0 +1,1 @@+copy_term_sharing:ground_copy(R)
+ test/golden/copy_term_sharing/nested_ground.expected view
@@ -0,0 +1,1 @@+R = t1(t2(t3(42)))
+ test/golden/copy_term_sharing/nested_ground.goal view
@@ -0,0 +1,1 @@+copy_term_sharing:nested_copy(R)
+ test/golden/copy_term_sharing/non_shared.expected view
@@ -0,0 +1,3 @@+R = _+X = _+Y = _
+ test/golden/copy_term_sharing/non_shared.goal view
@@ -0,0 +1,1 @@+copy_term_sharing:non_shared(X, Y, R)
+ test/golden/copy_term_sharing/shared.expected view
@@ -0,0 +1,2 @@+R = 1+X = _
+ test/golden/copy_term_sharing/shared.goal view
@@ -0,0 +1,1 @@+copy_term_sharing:shared(X, R)
+ test/golden/cross_module_function_leak/app.chr view
@@ -0,0 +1,10 @@+:- module(app, [run/2]).+:- use_module(library(prelude)).+% Note: does NOT use_module(maths). Before the fix, Resolve.termToExpr+% silently canonicalized 'add(X, 1)' to a call into maths:add via a+% program-wide function-set lookup that ignored imports. Post-fix the+% unqualified compound stays a data constructor.++:- chr_constraint run/2.++run(X, R) <=> R = add(X, 1).
+ test/golden/cross_module_function_leak/leak.expected view
@@ -0,0 +1,1 @@+R = add(5, 1)
+ test/golden/cross_module_function_leak/leak.goal view
@@ -0,0 +1,1 @@+app:run(5, R)
+ test/golden/cross_module_function_leak/maths.chr view
@@ -0,0 +1,5 @@+:- module(maths, [add/2]).+:- use_module(library(prelude)).++:- function add/2.+add(X, Y) -> X + Y.
+ test/golden/cross_module_import/lib.chr view
@@ -0,0 +1,5 @@+:- module(cross_lib, [double/2]).++:- chr_constraint double/2.++double(X, R) <=> R is X * 2.
+ test/golden/cross_module_import/main.chr view
@@ -0,0 +1,6 @@+:- module(cross_main, [quadruple/2]).+:- use_module(cross_lib, [double/2]).++:- chr_constraint quadruple/2.++quadruple(X, R) <=> double(X, Y), double(Y, R).
+ test/golden/cross_module_import/main.expected view
@@ -0,0 +1,1 @@+R = 28
+ test/golden/cross_module_import/main.goal view
@@ -0,0 +1,1 @@+cross_main:quadruple(7, R)
+ test/golden/cross_module_missing_export/lib.chr view
@@ -0,0 +1,5 @@+:- module(cross_lib_partial, [keep/1]).++:- chr_constraint keep/1.++keep(_) <=> true.
+ test/golden/cross_module_missing_export/main.chr view
@@ -0,0 +1,6 @@+:- module(cross_main_missing, [go/0]).+:- use_module(cross_lib_partial, [missing/1]).++:- chr_constraint go/0.++go <=> missing(1).
+ test/golden/cross_module_missing_export/main.error view
@@ -0,0 +1,1 @@+YCHR-20005
+ test/golden/discontiguous_equations/discontiguous_equations.chr view
@@ -0,0 +1,5 @@+:- function f/1.+f(0) -> 1.+:- chr_constraint foo/1.+foo(X) <=> true.+f(N) -> N.
+ test/golden/discontiguous_equations/discontiguous_equations.error view
@@ -0,0 +1,1 @@+YCHR-15001
+ test/golden/discontiguous_function_decls/discontiguous_function_decls.chr view
@@ -0,0 +1,6 @@+:- function f/1.+:- chr_constraint foo/1.+:- function (f(int) -> int).++f(N) -> N.+foo(X) <=> true.
+ test/golden/discontiguous_function_decls/discontiguous_function_decls.error view
@@ -0,0 +1,1 @@+YCHR-15004
+ test/golden/duplicate_module_header/duplicate_module_header.chr view
@@ -0,0 +1,4 @@+:- module(mm1).+:- module(mm2).+:- chr_constraint c/0.+c <=> true.
+ test/golden/duplicate_module_header/duplicate_module_header.error view
@@ -0,0 +1,1 @@+YCHR-15015
+ test/golden/empty_lambda_params/empty_lambda_params.chr view
@@ -0,0 +1,2 @@+:- chr_constraint test/1.+test(R) <=> R = fun() -> 42 end.
+ test/golden/empty_lambda_params/empty_lambda_params.error view
@@ -0,0 +1,1 @@+YCHR-16018
+ test/golden/eq_polymorphic/eq_polymorphic.chr view
@@ -0,0 +1,9 @@+:- module(eq_polymorphic, [result/2, type(tags/0)]).+:- use_module(library(prelude)).++:- chr_constraint result(any, any).+:- chr_type tags ---> test1 ; test2.++% == should work on any pair of same-type values+result(test1, R) <=> R is (1 == 2).+result(test2, R) <=> R is ("a" == "a").
+ test/golden/eq_polymorphic/eq_polymorphic.expected view
@@ -0,0 +1,1 @@+R = false
+ test/golden/eq_polymorphic/eq_polymorphic.goal view
@@ -0,0 +1,1 @@+result(test1, R)
+ test/golden/eval_deep_term/box.expected view
@@ -0,0 +1,1 @@+R = wrap(42)
+ test/golden/eval_deep_term/box.goal view
@@ -0,0 +1,1 @@+eval_deep_term:box(42, R)
+ test/golden/eval_deep_term/eval_deep_term.chr view
@@ -0,0 +1,6 @@+:- module(eval_deep_term, [box/2, nested/2]).+:- chr_constraint box/2, nested/2.++box(In, Out) <=> Out is quote(wrap(In)).++nested(In, Out) <=> Out is quote(outer(middle(In))).
+ test/golden/eval_deep_term/nested.expected view
@@ -0,0 +1,1 @@+R = outer(middle(7))
+ test/golden/eval_deep_term/nested.goal view
@@ -0,0 +1,1 @@+eval_deep_term:nested(7, R)
+ test/golden/evaluated_tell_args/body_arith.expected view
@@ -0,0 +1,1 @@+R = 15
+ test/golden/evaluated_tell_args/body_arith.goal view
@@ -0,0 +1,1 @@+evaluated_tell_args:via_body(5, R)
+ test/golden/evaluated_tell_args/evaluated_tell_args.chr view
@@ -0,0 +1,29 @@+:- module(evaluated_tell_args, [direct/2, via_body/2, quoted/2, plus/2, type(pair_t/0)]).+:- use_module(prelude).++:- chr_type pair_t ---> pair(any, any).++:- function plus/2.+plus(X, Y) -> X + Y.++:- chr_constraint+    direct/2,+    via_body/2,+    relay/2,+    quoted/2.++% A goal of the form 'direct(EXPR, R)' tests that EXPR is evaluated+% before the constraint is told. R is unified with the (evaluated)+% first argument.+direct(N, R) <=> R = N.++% A goal of the form 'via_body(EXPR, R)' tests that EXPR is evaluated+% before the rule body's tell. The body retells 'relay(EXPR + 10, R)';+% the relay rule then unifies R with the (evaluated) value.+via_body(N, R) <=> relay(N + 10, R).+relay(X, R)    <=> R = X.++% 'quoted(EXPR, R)' uses quote/1 to opt out of evaluation: EXPR stays as+% a data term. This pins the existing quoting escape hatch and ensures+% the opt-out keeps working after the semantic change.+quoted(N, R) <=> R = N.
+ test/golden/evaluated_tell_args/goal_arith.expected view
@@ -0,0 +1,1 @@+R = 3
+ test/golden/evaluated_tell_args/goal_arith.goal view
@@ -0,0 +1,1 @@+evaluated_tell_args:direct(2 + 1, R)
+ test/golden/evaluated_tell_args/goal_function_call.expected view
@@ -0,0 +1,1 @@+R = 5
+ test/golden/evaluated_tell_args/goal_function_call.goal view
@@ -0,0 +1,1 @@+evaluated_tell_args:direct(plus(2, 3), R)
+ test/golden/evaluated_tell_args/nested_in_ctor.expected view
@@ -0,0 +1,1 @@+R = evaluated_tell_args:pair(5, 4)
+ test/golden/evaluated_tell_args/nested_in_ctor.goal view
@@ -0,0 +1,1 @@+evaluated_tell_args:direct(pair(plus(2, 3), 4), R)
+ test/golden/evaluated_tell_args/quoted.expected view
@@ -0,0 +1,1 @@+R = plus(2, 3)
+ test/golden/evaluated_tell_args/quoted.goal view
@@ -0,0 +1,1 @@+evaluated_tell_args:quoted(quote(plus(2, 3)), R)
+ test/golden/evaluated_tell_args_unbound/evaluated_tell_args_unbound.chr view
@@ -0,0 +1,6 @@+:- module(evaluated_tell_args_unbound, [direct/2]).+:- use_module(prelude).++:- chr_constraint direct/2.++direct(_, _) <=> true.
+ test/golden/evaluated_tell_args_unbound/unbound.error view
@@ -0,0 +1,1 @@+YCHR-60001
+ test/golden/evaluated_tell_args_unbound/unbound.goal view
@@ -0,0 +1,1 @@+evaluated_tell_args_unbound:direct(Y + 1, R)
+ test/golden/exhaustive_color/exhaustive_color.chr view
@@ -0,0 +1,8 @@+:- module(exhaustive_color, [classify/1]).+:- chr_type color ---> red ; green ; blue.+:- chr_constraint classify/1.+:- function rank(color) -> int.+rank(red) -> 1.+rank(green) -> 2.+rank(blue) -> 3.+classify(R) <=> R is rank(green).
+ test/golden/exhaustive_color/exhaustive_color.expected view
@@ -0,0 +1,1 @@+R = 2
+ test/golden/exhaustive_color/exhaustive_color.goal view
@@ -0,0 +1,1 @@+exhaustive_color:classify(R)
+ test/golden/extend_class_on_open_function/a_owner.chr view
@@ -0,0 +1,3 @@+:- module(owner, [f/1]).+:- open_function (f(int) -> int).+f(X) -> X.
+ test/golden/extend_class_on_open_function/b_ext.chr view
@@ -0,0 +1,6 @@+:- module(ext, []).+:- use_module(owner, [f/1]).++% Forbidden: extend_class targets an :- open_function. Use+% :- extend_function for equation extensions on :- open_function.+:- extend_class f(2) -> 2.
+ test/golden/extend_class_on_open_function/extend_class_on_open_function.error view
@@ -0,0 +1,1 @@+YCHR-16014
+ test/golden/extend_class_type_on_open_function/a_owner.chr view
@@ -0,0 +1,3 @@+:- module(owner, [f/1]).+:- open_function (f(int) -> int).+f(X) -> X.
+ test/golden/extend_class_type_on_open_function/b_ext.chr view
@@ -0,0 +1,6 @@+:- module(ext, []).+:- use_module(owner, [f/1]).++% Forbidden: extend_class_type targets an :- open_function. Type+% extensions are only meaningful against :- open_class.+:- extend_class_type (f(string) -> string).
+ test/golden/extend_class_type_on_open_function/extend_class_type_on_open_function.error view
file too large to diff
+ test/golden/extend_closed_function/a_owner.chr view
file too large to diff
+ test/golden/extend_closed_function/b_ext.chr view
file too large to diff
+ test/golden/extend_closed_function/extend_closed_function.error view
file too large to diff
+ test/golden/extend_closed_function_body/a_owner.chr view
file too large to diff
+ test/golden/extend_closed_function_body/b_ext.chr view
file too large to diff
+ test/golden/extend_closed_function_body/extend_closed_function_body.error view
file too large to diff
+ test/golden/extend_function_multi_extender/a_owner.chr view
file too large to diff
+ test/golden/extend_function_multi_extender/atom.expected view
file too large to diff
+ test/golden/extend_function_multi_extender/atom.goal view
file too large to diff
+ test/golden/extend_function_multi_extender/b_strings.chr view
file too large to diff
+ test/golden/extend_function_multi_extender/c_atoms.chr view
file too large to diff
+ test/golden/extend_function_multi_extender/int.expected view
file too large to diff
+ test/golden/extend_function_multi_extender/int.goal view
file too large to diff
+ test/golden/extend_function_multi_extender/string.expected view
file too large to diff
+ test/golden/extend_function_multi_extender/string.goal view
file too large to diff
+ test/golden/extend_function_on_open_class/a_owner.chr view
file too large to diff
+ test/golden/extend_function_on_open_class/b_ext.chr view
file too large to diff
+ test/golden/extend_function_on_open_class/extend_function_on_open_class.error view
file too large to diff
+ test/golden/extend_function_type_basic/a_owner.chr view
file too large to diff
+ test/golden/extend_function_type_basic/b_ext.chr view
file too large to diff
+ test/golden/extend_function_type_basic/dog.expected view
file too large to diff
+ test/golden/extend_function_type_basic/dog.goal view
file too large to diff
+ test/golden/extend_function_type_basic/other.expected view
file too large to diff
+ test/golden/extend_function_type_basic/other.goal view
file too large to diff
+ test/golden/extend_function_type_basic/red.expected view
file too large to diff
+ test/golden/extend_function_type_basic/red.goal view
file too large to diff
+ test/golden/extend_function_type_signature/a_owner.chr view
file too large to diff
+ test/golden/extend_function_type_signature/b_ext.chr view
file too large to diff
+ test/golden/extend_function_type_signature/int.expected view
file too large to diff
+ test/golden/extend_function_type_signature/int.goal view
file too large to diff
+ test/golden/extend_function_type_signature/string.expected view
file too large to diff
+ test/golden/extend_function_type_signature/string.goal view
file too large to diff
+ test/golden/extend_unknown_function/extend_unknown_function.chr view
file too large to diff
+ test/golden/extend_unknown_function/extend_unknown_function.error view
file too large to diff
+ test/golden/false_guard/false_guard.chr view
file too large to diff
+ test/golden/false_guard/false_guard.expected view
file too large to diff
+ test/golden/false_guard/false_guard.goal view
file too large to diff
+ test/golden/fib/fib.chr view
file too large to diff
+ test/golden/fib/fib.expected view
file too large to diff
+ test/golden/fib/fib.goal view
file too large to diff
+ test/golden/fib/fib_small.expected view
file too large to diff
+ test/golden/fib/fib_small.goal view
file too large to diff
+ test/golden/float_basic/float_basic.chr view
file too large to diff
+ test/golden/float_basic/float_basic.expected view
file too large to diff
+ test/golden/float_basic/float_basic.goal view
file too large to diff
+ test/golden/float_type_error/float_type_error.chr view
file too large to diff
+ test/golden/float_type_error/float_type_error.error view
file too large to diff
+ test/golden/function_basic/function_basic.chr view
file too large to diff
+ test/golden/function_basic/function_basic.expected view
file too large to diff
+ test/golden/function_basic/function_basic.goal view
file too large to diff
+ test/golden/function_body_host_sequence/function_body_host_sequence.chr view
file too large to diff
+ test/golden/function_body_host_sequence/function_body_host_sequence.expected view
file too large to diff
+ test/golden/function_body_host_sequence/function_body_host_sequence.goal view
file too large to diff
+ test/golden/function_body_invalid_unify/function_body_invalid_unify.chr view
file too large to diff
+ test/golden/function_body_invalid_unify/function_body_invalid_unify.error view
file too large to diff
+ test/golden/function_body_is_shadow/function_body_is_shadow.chr view
file too large to diff
+ test/golden/function_body_is_shadow/function_body_is_shadow.expected view
file too large to diff
+ test/golden/function_body_is_shadow/function_body_is_shadow.goal view
file too large to diff
+ test/golden/function_body_nonvar_is/function_body_nonvar_is.chr view
file too large to diff
+ test/golden/function_body_nonvar_is/function_body_nonvar_is.error view
file too large to diff
+ test/golden/function_body_sequence/function_body_sequence.chr view
file too large to diff
+ test/golden/function_body_sequence/function_body_sequence.expected view
file too large to diff
+ test/golden/function_body_sequence/function_body_sequence.goal view
file too large to diff
+ test/golden/function_fib/function_fib.chr view
file too large to diff
+ test/golden/function_fib/function_fib.expected view
file too large to diff
+ test/golden/function_fib/function_fib.goal view
file too large to diff
+ test/golden/function_guard/function_guard.chr view
file too large to diff
+ test/golden/function_guard/function_guard.expected view
file too large to diff
+ test/golden/function_guard/function_guard.goal view
file too large to diff
+ test/golden/function_in_rule_head_dedup/function_in_rule_head_dedup.chr view
file too large to diff
+ test/golden/function_in_rule_head_dedup/function_in_rule_head_dedup.error view
file too large to diff
+ test/golden/function_in_rule_head_propagation/function_in_rule_head_propagation.chr view
file too large to diff
+ test/golden/function_in_rule_head_propagation/function_in_rule_head_propagation.error view
file too large to diff
+ test/golden/function_in_rule_head_simpagation/function_in_rule_head_simpagation.chr view
file too large to diff
+ test/golden/function_in_rule_head_simpagation/function_in_rule_head_simpagation.error view
file too large to diff
+ test/golden/function_in_rule_head_simplification/function_in_rule_head_simplification.chr view
file too large to diff
+ test/golden/function_in_rule_head_simplification/function_in_rule_head_simplification.error view
file too large to diff
+ test/golden/function_multi_sig_untyped_allowed/function_multi_sig_untyped_allowed.chr view
file too large to diff
+ test/golden/function_multi_sig_untyped_allowed/function_multi_sig_untyped_allowed.expected view
file too large to diff
+ test/golden/function_multi_sig_untyped_allowed/function_multi_sig_untyped_allowed.goal view
file too large to diff
+ test/golden/function_overload_arity/function_overload_arity.chr view
file too large to diff
+ test/golden/function_overload_arity/function_overload_arity.expected view
file too large to diff
+ test/golden/function_overload_arity/function_overload_arity.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/c_empty.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/c_empty.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/c_many.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/c_many.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/c_one.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/c_one.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/c_three.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/c_three.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/c_two.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/c_two.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/d_other.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/d_other.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/d_pair.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/d_pair.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/d_zero_first.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/d_zero_first.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/d_zero_second.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/d_zero_second.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/f_answer.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/f_answer.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/f_one.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/f_one.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/f_other.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/f_other.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/f_zero.expected view
file too large to diff
+ test/golden/function_pattern_dispatch/f_zero.goal view
file too large to diff
+ test/golden/function_pattern_dispatch/function_pattern_dispatch.chr view
file too large to diff
+ test/golden/function_recursive/function_recursive.chr view
file too large to diff
+ test/golden/function_recursive/function_recursive.expected view
file too large to diff
+ test/golden/function_recursive/function_recursive.goal view
file too large to diff
+ test/golden/function_reference_dispatch/binary.expected view
file too large to diff
+ test/golden/function_reference_dispatch/binary.goal view
file too large to diff
+ test/golden/function_reference_dispatch/function_reference_dispatch.chr view
file too large to diff
+ test/golden/function_reference_dispatch/identity.expected view
file too large to diff
+ test/golden/function_reference_dispatch/identity.goal view
file too large to diff
+ test/golden/function_reference_dispatch/mixed.expected view
file too large to diff
+ test/golden/function_reference_dispatch/mixed.goal view
file too large to diff
+ test/golden/function_reference_dispatch/unary.expected view
file too large to diff
+ test/golden/function_reference_dispatch/unary.goal view
file too large to diff
+ test/golden/function_reference_dispatch/via_var.expected view
file too large to diff
+ test/golden/function_reference_dispatch/via_var.goal view
file too large to diff
+ test/golden/function_with_multi_sig/function_with_multi_sig.chr view
file too large to diff
+ test/golden/function_with_multi_sig/function_with_multi_sig.error view
file too large to diff
+ test/golden/function_with_three_sigs/function_with_three_sigs.chr view
file too large to diff
+ test/golden/function_with_three_sigs/function_with_three_sigs.error view
file too large to diff
+ test/golden/funref_bounded_satisfied/funref_bounded_satisfied.chr view
file too large to diff
+ test/golden/funref_bounded_satisfied/funref_bounded_satisfied.expected view
file too large to diff
+ test/golden/funref_bounded_satisfied/funref_bounded_satisfied.goal view
file too large to diff
+ test/golden/funref_bounded_unsatisfied/funref_bounded_unsatisfied.chr view
file too large to diff
+ test/golden/funref_bounded_unsatisfied/funref_bounded_unsatisfied.error view
file too large to diff
+ test/golden/funref_unknown_name/funref_unknown_name.chr view
file too large to diff
+ test/golden/funref_unknown_name/funref_unknown_name.error view
file too large to diff
+ test/golden/goal_not_a_constraint/bare_atom.error view
file too large to diff
+ test/golden/goal_not_a_constraint/bare_atom.goal view
file too large to diff
+ test/golden/goal_not_a_constraint/expression.error view
file too large to diff
+ test/golden/goal_not_a_constraint/expression.goal view
file too large to diff
+ test/golden/goal_not_a_constraint/function_call.error view
file too large to diff
+ test/golden/goal_not_a_constraint/function_call.goal view
file too large to diff
+ test/golden/goal_not_a_constraint/literal_int.error view
file too large to diff
+ test/golden/goal_not_a_constraint/literal_int.goal view
file too large to diff
+ test/golden/goal_not_a_constraint/literal_string.error view
file too large to diff
+ test/golden/goal_not_a_constraint/literal_string.goal view
file too large to diff
+ test/golden/goal_not_a_constraint/program.chr view
file too large to diff
+ test/golden/graph_test/graph_test.chr view
file too large to diff
+ test/golden/graph_test/graph_test.expected view
file too large to diff
+ test/golden/graph_test/graph_test.goal view
file too large to diff
+ test/golden/guard/guard.chr view
file too large to diff
+ test/golden/guard/guard.expected view
file too large to diff
+ test/golden/guard/guard.goal view
file too large to diff
+ test/golden/hnf_compound_head/deep.expected view
file too large to diff
+ test/golden/hnf_compound_head/deep.goal view
file too large to diff
+ test/golden/hnf_compound_head/hnf_compound_head.chr view
file too large to diff
+ test/golden/hnf_compound_head/mismatch_f.expected view
file too large to diff
+ test/golden/hnf_compound_head/mismatch_f.goal view
file too large to diff
+ test/golden/hnf_compound_head/mismatch_g.expected view
file too large to diff
+ test/golden/hnf_compound_head/mismatch_g.goal view
file too large to diff
+ test/golden/hnf_compound_head/mismatch_other.expected view
file too large to diff
+ test/golden/hnf_compound_head/mismatch_other.goal view
file too large to diff
+ test/golden/hnf_compound_head/pair.expected view
file too large to diff
+ test/golden/hnf_compound_head/pair.goal view
file too large to diff
+ test/golden/hnf_compound_head/pair_atom.expected view
file too large to diff
+ test/golden/hnf_compound_head/pair_atom.goal view
file too large to diff
+ test/golden/hnf_compound_head/pair_no_match.expected view
file too large to diff
+ test/golden/hnf_compound_head/pair_no_match.goal view
file too large to diff
+ test/golden/hnf_compound_head/tri.expected view
file too large to diff
+ test/golden/hnf_compound_head/tri.goal view
file too large to diff
+ test/golden/hnf_compound_head/tri_no_match.expected view
file too large to diff
+ test/golden/hnf_compound_head/tri_no_match.goal view
file too large to diff
+ test/golden/hnf_list_head/first_basic.expected view
file too large to diff
+ test/golden/hnf_list_head/first_basic.goal view
file too large to diff
+ test/golden/hnf_list_head/first_empty.expected view
file too large to diff
+ test/golden/hnf_list_head/first_empty.goal view
file too large to diff
+ test/golden/hnf_list_head/fixed_long.expected view
file too large to diff
+ test/golden/hnf_list_head/fixed_long.goal view
file too large to diff
+ test/golden/hnf_list_head/fixed_match.expected view
file too large to diff
+ test/golden/hnf_list_head/fixed_match.goal view
file too large to diff
+ test/golden/hnf_list_head/fixed_short.expected view
file too large to diff
+ test/golden/hnf_list_head/fixed_short.goal view
file too large to diff
+ test/golden/hnf_list_head/fixed_wrong.expected view
file too large to diff
+ test/golden/hnf_list_head/fixed_wrong.goal view
file too large to diff
+ test/golden/hnf_list_head/hnf_list_head.chr view
file too large to diff
+ test/golden/hnf_list_head/kind_atom.expected view
file too large to diff
+ test/golden/hnf_list_head/kind_atom.goal view
file too large to diff
+ test/golden/hnf_list_head/kind_cons.expected view
file too large to diff
+ test/golden/hnf_list_head/kind_cons.goal view
file too large to diff
+ test/golden/hnf_list_head/kind_empty.expected view
file too large to diff
+ test/golden/hnf_list_head/kind_empty.goal view
file too large to diff
+ test/golden/hnf_list_head/rest_basic.expected view
file too large to diff
+ test/golden/hnf_list_head/rest_basic.goal view
file too large to diff
+ test/golden/hnf_list_head/rest_empty.expected view
file too large to diff
+ test/golden/hnf_list_head/rest_empty.goal view
file too large to diff
+ test/golden/hnf_list_head/rest_singleton.expected view
file too large to diff
+ test/golden/hnf_list_head/rest_singleton.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/atom_foo.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/atom_foo.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/atom_other.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/atom_other.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/empty_list.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/empty_list.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/float_15.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/float_15.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/float_other.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/float_other.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/float_zero.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/float_zero.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/hnf_literal_in_head.chr view
file too large to diff
+ test/golden/hnf_literal_in_head/int_42.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/int_42.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/int_other.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/int_other.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/int_zero.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/int_zero.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/pair_ab.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/pair_ab.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/pair_other.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/pair_other.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/string_hi.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/string_hi.goal view
file too large to diff
+ test/golden/hnf_literal_in_head/string_other.expected view
file too large to diff
+ test/golden/hnf_literal_in_head/string_other.goal view
file too large to diff
+ test/golden/hnf_repeated_var_across_partners/find_a.expected view
file too large to diff
+ test/golden/hnf_repeated_var_across_partners/find_a.goal view
file too large to diff
+ test/golden/hnf_repeated_var_across_partners/find_b.expected view
file too large to diff
+ test/golden/hnf_repeated_var_across_partners/find_b.goal view
file too large to diff
+ test/golden/hnf_repeated_var_across_partners/find_c.expected view
file too large to diff
+ test/golden/hnf_repeated_var_across_partners/find_c.goal view
file too large to diff
+ test/golden/hnf_repeated_var_across_partners/hnf_repeated_var_across_partners.chr view
file too large to diff
+ test/golden/hnf_repeated_var_across_partners/pair_ab.expected view
file too large to diff
+ test/golden/hnf_repeated_var_across_partners/pair_ab.goal view
file too large to diff
+ test/golden/hnf_repeated_var_across_partners/pair_cb.expected view
file too large to diff
+ test/golden/hnf_repeated_var_across_partners/pair_cb.goal view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_atom_diff.expected view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_atom_diff.goal view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_atom_same.expected view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_atom_same.goal view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_int_diff.expected view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_int_diff.goal view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_int_same.expected view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_int_same.goal view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_term_diff.expected view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_term_diff.goal view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_term_same.expected view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/eq_term_same.goal view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/hnf_repeated_var_within_head.chr view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/three_all_diff.expected view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/three_all_diff.goal view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/three_all_eq.expected view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/three_all_eq.goal view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/three_first2.expected view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/three_first2.goal view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/three_last2.expected view
file too large to diff
+ test/golden/hnf_repeated_var_within_head/three_last2.goal view
file too large to diff
+ test/golden/hnf_wildcard_in_head/hnf_wildcard_in_head.chr view
file too large to diff
+ test/golden/hnf_wildcard_in_head/mid.expected view
file too large to diff
+ test/golden/hnf_wildcard_in_head/mid.goal view
file too large to diff
+ test/golden/hnf_wildcard_in_head/mid_terms.expected view
file too large to diff
+ test/golden/hnf_wildcard_in_head/mid_terms.goal view
file too large to diff
+ test/golden/hnf_wildcard_in_head/peek_atom.expected view
file too large to diff
+ test/golden/hnf_wildcard_in_head/peek_atom.goal view
file too large to diff
+ test/golden/hnf_wildcard_in_head/peek_int.expected view
file too large to diff
+ test/golden/hnf_wildcard_in_head/peek_int.goal view
file too large to diff
+ test/golden/hnf_wildcard_in_head/peek_term.expected view
file too large to diff
+ test/golden/hnf_wildcard_in_head/peek_term.goal view
file too large to diff
+ test/golden/hnf_wildcard_in_head/two_basic.expected view
file too large to diff
+ test/golden/hnf_wildcard_in_head/two_basic.goal view
file too large to diff
+ test/golden/hnf_wildcard_in_head/two_terms.expected view
file too large to diff
+ test/golden/hnf_wildcard_in_head/two_terms.goal view
file too large to diff
+ test/golden/import_list/dup_lib.chr view
file too large to diff
+ test/golden/import_list/import_list.chr view
file too large to diff
+ test/golden/import_list/import_list.expected view
file too large to diff
+ test/golden/import_list/import_list.goal view
file too large to diff
+ test/golden/import_list_library/import_list_library.chr view
file too large to diff
+ test/golden/import_list_library/import_list_library.expected view
file too large to diff
+ test/golden/import_list_library/import_list_library.goal view
file too large to diff
+ test/golden/import_list_library_restricted/import_list_library_restricted.chr view
file too large to diff
+ test/golden/import_list_library_restricted/import_list_library_restricted.error view
file too large to diff
+ test/golden/import_list_operator/import_list_operator.chr view
file too large to diff
+ test/golden/import_list_operator/import_list_operator.error view
file too large to diff
+ test/golden/import_list_restricted/dup_lib.chr view
file too large to diff
+ test/golden/import_list_restricted/import_list_restricted.chr view
file too large to diff
+ test/golden/import_list_restricted/import_list_restricted.error view
file too large to diff
+ test/golden/import_list_unknown/import_list_unknown.chr view
file too large to diff
+ test/golden/import_list_unknown/import_list_unknown.error view
file too large to diff
+ test/golden/int_arg_no_warn/int_arg_no_warn.chr view
file too large to diff
+ test/golden/int_arg_no_warn/int_arg_no_warn.expected view
file too large to diff
+ test/golden/int_arg_no_warn/int_arg_no_warn.goal view
file too large to diff
+ test/golden/int_float_conversion/f2i_neg.expected view
file too large to diff
+ test/golden/int_float_conversion/f2i_neg.goal view
file too large to diff
+ test/golden/int_float_conversion/f2i_pos.expected view
file too large to diff
+ test/golden/int_float_conversion/f2i_pos.goal view
file too large to diff
+ test/golden/int_float_conversion/f2i_pos_zero.expected view
file too large to diff
+ test/golden/int_float_conversion/f2i_pos_zero.goal view
file too large to diff
+ test/golden/int_float_conversion/f2i_whole.expected view
file too large to diff
+ test/golden/int_float_conversion/f2i_whole.goal view
file too large to diff
+ test/golden/int_float_conversion/i2f_big.expected view
file too large to diff
+ test/golden/int_float_conversion/i2f_big.goal view
file too large to diff
+ test/golden/int_float_conversion/i2f_neg.expected view
file too large to diff
+ test/golden/int_float_conversion/i2f_neg.goal view
file too large to diff
+ test/golden/int_float_conversion/i2f_pos.expected view
file too large to diff
+ test/golden/int_float_conversion/i2f_pos.goal view
file too large to diff
+ test/golden/int_float_conversion/i2f_zero.expected view
file too large to diff
+ test/golden/int_float_conversion/i2f_zero.goal view
file too large to diff
+ test/golden/int_float_conversion/int_float_conversion.chr view
file too large to diff
+ test/golden/int_float_conversion/rt_float.expected view
file too large to diff
+ test/golden/int_float_conversion/rt_float.goal view
file too large to diff
+ test/golden/int_float_conversion/rt_int.expected view
file too large to diff
+ test/golden/int_float_conversion/rt_int.goal view
file too large to diff
+ test/golden/invalid_lambda_param/invalid_lambda_param.chr view
file too large to diff
+ test/golden/invalid_lambda_param/invalid_lambda_param.error view
file too large to diff
+ test/golden/is_deref_compound/arith.expected view
file too large to diff
+ test/golden/is_deref_compound/arith.goal view
file too large to diff
+ test/golden/is_deref_compound/bare_quoted.expected view
file too large to diff
+ test/golden/is_deref_compound/bare_quoted.goal view
file too large to diff
+ test/golden/is_deref_compound/is_deref_compound.chr view
file too large to diff
+ test/golden/is_deref_compound/user_function.expected view
file too large to diff
+ test/golden/is_deref_compound/user_function.goal view
file too large to diff
+ test/golden/is_non_evaluable_error/is_non_evaluable_error.chr view
file too large to diff
+ test/golden/is_non_evaluable_error/non_evaluable.error view
file too large to diff
+ test/golden/is_non_evaluable_error/non_evaluable.goal view
file too large to diff
+ test/golden/is_var_propagates_type/is_var_propagates_type.chr view
file too large to diff
+ test/golden/is_var_propagates_type/is_var_propagates_type.error view
file too large to diff
+ test/golden/is_with_complex_rhs/is_with_complex_rhs.chr view
file too large to diff
+ test/golden/is_with_complex_rhs/lambda_arith.expected view
file too large to diff
+ test/golden/is_with_complex_rhs/lambda_arith.goal view
file too large to diff
+ test/golden/is_with_complex_rhs/lambda_call.expected view
file too large to diff
+ test/golden/is_with_complex_rhs/lambda_call.goal view
file too large to diff
+ test/golden/is_with_complex_rhs/max_basic.expected view
file too large to diff
+ test/golden/is_with_complex_rhs/max_basic.goal view
file too large to diff
+ test/golden/is_with_complex_rhs/min_basic.expected view
file too large to diff
+ test/golden/is_with_complex_rhs/min_basic.goal view
file too large to diff
+ test/golden/is_with_complex_rhs/mixed.expected view
file too large to diff
+ test/golden/is_with_complex_rhs/mixed.goal view
file too large to diff
+ test/golden/is_with_complex_rhs/nested_fns.expected view
file too large to diff
+ test/golden/is_with_complex_rhs/nested_fns.goal view
file too large to diff
+ test/golden/is_with_complex_rhs/parens.expected view
file too large to diff
+ test/golden/is_with_complex_rhs/parens.goal view
file too large to diff
+ test/golden/is_with_complex_rhs/three_deep.expected view
file too large to diff
+ test/golden/is_with_complex_rhs/three_deep.goal view
file too large to diff
+ test/golden/lambda_body_capture_rebind/lambda_body_capture_rebind.chr view
file too large to diff
+ test/golden/lambda_body_capture_rebind/lambda_body_capture_rebind.expected view
file too large to diff
+ test/golden/lambda_body_capture_rebind/lambda_body_capture_rebind.goal view
file too large to diff
+ test/golden/lambda_body_invalid_unify/lambda_body_invalid_unify.chr view
file too large to diff
+ test/golden/lambda_body_invalid_unify/lambda_body_invalid_unify.error view
file too large to diff
+ test/golden/lambda_body_sequence/lambda_body_sequence.chr view
file too large to diff
+ test/golden/lambda_body_sequence/lambda_body_sequence.expected view
file too large to diff
+ test/golden/lambda_body_sequence/lambda_body_sequence.goal view
file too large to diff
+ test/golden/lambda_curried_adder/both.expected view
file too large to diff
+ test/golden/lambda_curried_adder/both.goal view
file too large to diff
+ test/golden/lambda_curried_adder/lambda_curried_adder.chr view
file too large to diff
+ test/golden/lambda_curried_adder/reuse.expected view
file too large to diff
+ test/golden/lambda_curried_adder/reuse.goal view
file too large to diff
+ test/golden/lambda_curried_adder/twice_then_add.expected view
file too large to diff
+ test/golden/lambda_curried_adder/twice_then_add.goal view
file too large to diff
+ test/golden/lambda_hnf_capture/lambda_hnf_capture.chr view
file too large to diff
+ test/golden/lambda_hnf_capture/lambda_hnf_capture.expected view
file too large to diff
+ test/golden/lambda_hnf_capture/lambda_hnf_capture.goal view
file too large to diff
+ test/golden/lambda_test/lambda_test.chr view
file too large to diff
+ test/golden/lambda_test/lambda_test.expected view
file too large to diff
+ test/golden/lambda_test/lambda_test.goal view
file too large to diff
+ test/golden/lambda_through_constraint_store/lambda_through_constraint_store.chr view
file too large to diff
+ test/golden/lambda_through_constraint_store/run_100.expected view
file too large to diff
+ test/golden/lambda_through_constraint_store/run_100.goal view
file too large to diff
+ test/golden/lambda_through_constraint_store/run_5.expected view
file too large to diff
+ test/golden/lambda_through_constraint_store/run_5.goal view
file too large to diff
+ test/golden/lambda_unify/lambda_unify.chr view
file too large to diff
+ test/golden/lambda_unify/result.expected view
file too large to diff
+ test/golden/lambda_unify/result.goal view
file too large to diff
+ test/golden/length_test/length_test.chr view
file too large to diff
+ test/golden/length_test/length_test.expected view
file too large to diff
+ test/golden/length_test/length_test.goal view
file too large to diff
+ test/golden/leq/leq.chr view
file too large to diff
+ test/golden/leq/leq.expected view
file too large to diff
+ test/golden/leq/leq.goal view
file too large to diff
+ test/golden/leq_closure/leq_closure.chr view
file too large to diff
+ test/golden/leq_closure/leq_closure.expected view
file too large to diff
+ test/golden/leq_closure/leq_closure.goal view
file too large to diff
+ test/golden/leq_closure/sample.expected view
file too large to diff
+ test/golden/leq_closure/sample.goal view
file too large to diff
+ test/golden/list_test/list_test.chr view
file too large to diff
+ test/golden/list_test/list_test.expected view
file too large to diff
+ test/golden/list_test/list_test.goal view
file too large to diff
+ test/golden/malformed_constraint/malformed_constraint.chr view
file too large to diff
+ test/golden/malformed_constraint/malformed_constraint.error view
file too large to diff
+ test/golden/malformed_import/malformed_import.chr view
file too large to diff
+ test/golden/malformed_import/malformed_import.error view
file too large to diff
+ test/golden/mixed_function_class/mixed_function_class.chr view
file too large to diff
+ test/golden/mixed_function_class/mixed_function_class.error view
file too large to diff
+ test/golden/mixed_function_open_class/mixed_function_open_class.chr view
file too large to diff
+ test/golden/mixed_function_open_class/mixed_function_open_class.error view
file too large to diff
+ test/golden/mixed_open_function_class/mixed_open_function_class.chr view
file too large to diff
+ test/golden/mixed_open_function_class/mixed_open_function_class.error view
file too large to diff
+ test/golden/module_export_unknown_arity/module_export_unknown_arity.chr view
file too large to diff
+ test/golden/module_export_unknown_arity/module_export_unknown_arity.error view
file too large to diff
+ test/golden/module_short_form/lib.chr view
file too large to diff
+ test/golden/module_short_form/main.chr view
file too large to diff
+ test/golden/module_short_form/main.expected view
file too large to diff
+ test/golden/module_short_form/main.goal view
file too large to diff
+ test/golden/negation/arg_false.expected view
file too large to diff
+ test/golden/negation/arg_false.goal view
file too large to diff
+ test/golden/negation/arg_true.expected view
file too large to diff
+ test/golden/negation/arg_true.goal view
file too large to diff
+ test/golden/negation/eq_ints.expected view
file too large to diff
+ test/golden/negation/eq_ints.goal view
file too large to diff
+ test/golden/negation/guard_neg.expected view
file too large to diff
+ test/golden/negation/guard_neg.goal view
file too large to diff
+ test/golden/negation/lit_false.expected view
file too large to diff
+ test/golden/negation/lit_false.goal view
file too large to diff
+ test/golden/negation/lit_true.expected view
file too large to diff
+ test/golden/negation/lit_true.goal view
file too large to diff
+ test/golden/negation/negation.chr view
file too large to diff
+ test/golden/negation/neq_ints.expected view
file too large to diff
+ test/golden/negation/neq_ints.goal view
file too large to diff
+ test/golden/negation/not_unifiable.expected view
file too large to diff
+ test/golden/negation/not_unifiable.goal view
file too large to diff
+ test/golden/negative_number_literals/arith_flt.expected view
file too large to diff
+ test/golden/negative_number_literals/arith_flt.goal view
file too large to diff
+ test/golden/negative_number_literals/arith_int.expected view
file too large to diff
+ test/golden/negative_number_literals/arith_int.goal view
file too large to diff
+ test/golden/negative_number_literals/diff.expected view
file too large to diff
+ test/golden/negative_number_literals/diff.goal view
file too large to diff
+ test/golden/negative_number_literals/neg_float.expected view
file too large to diff
+ test/golden/negative_number_literals/neg_float.goal view
file too large to diff
+ test/golden/negative_number_literals/neg_int.expected view
file too large to diff
+ test/golden/negative_number_literals/neg_int.goal view
file too large to diff
+ test/golden/negative_number_literals/neg_negint.expected view
file too large to diff
+ test/golden/negative_number_literals/neg_negint.goal view
file too large to diff
+ test/golden/negative_number_literals/neg_pos.expected view
file too large to diff
+ test/golden/negative_number_literals/neg_pos.goal view
file too large to diff
+ test/golden/negative_number_literals/negative_number_literals.chr view
file too large to diff
+ test/golden/nested_function_eval/nested_function_eval.chr view
file too large to diff
+ test/golden/nested_function_eval/nested_function_eval.expected view
file too large to diff
+ test/golden/nested_function_eval/nested_function_eval.goal view
file too large to diff
+ test/golden/non_boolean_guard/non_boolean_guard.chr view
file too large to diff
+ test/golden/non_boolean_guard/non_boolean_guard.error view
file too large to diff
+ test/golden/nonexhaustive_color/nonexhaustive_color.chr view
file too large to diff
+ test/golden/nonexhaustive_color/nonexhaustive_color.expected view
file too large to diff
+ test/golden/nonexhaustive_color/nonexhaustive_color.goal view
file too large to diff
+ test/golden/nonexhaustive_nested/nonexhaustive_nested.chr view
file too large to diff
+ test/golden/nonexhaustive_nested/nonexhaustive_nested.expected view
file too large to diff
+ test/golden/nonexhaustive_nested/nonexhaustive_nested.goal view
file too large to diff
+ test/golden/opaque_type_basic/opaque_basic.chr view
file too large to diff
+ test/golden/opaque_type_basic/opaque_basic.expected view
file too large to diff
+ test/golden/opaque_type_basic/opaque_basic.goal view
file too large to diff
+ test/golden/opaque_type_cross_module/main.chr view
file too large to diff
+ test/golden/opaque_type_cross_module/run.expected view
file too large to diff
+ test/golden/opaque_type_cross_module/run.goal view
file too large to diff
+ test/golden/opaque_type_cross_module/sets.chr view
file too large to diff
+ test/golden/opaque_type_name_arity/app.chr view
file too large to diff
+ test/golden/opaque_type_name_arity/lib.chr view
file too large to diff
+ test/golden/opaque_type_name_arity/run.expected view
file too large to diff
+ test/golden/opaque_type_name_arity/run.goal view
file too large to diff
+ test/golden/opaque_type_phantom_param/phantom.chr view
file too large to diff
+ test/golden/opaque_type_phantom_param/phantom.expected view
file too large to diff
+ test/golden/opaque_type_phantom_param/phantom.goal view
file too large to diff
+ test/golden/opaque_type_with_constructors/with_constructors.chr view
file too large to diff
+ test/golden/opaque_type_with_constructors/with_constructors.error view
file too large to diff
+ test/golden/opaque_type_wrong_use/wrong_use.chr view
file too large to diff
+ test/golden/opaque_type_wrong_use/wrong_use.error view
file too large to diff
+ test/golden/open_class_basic/a_owner.chr view
file too large to diff
+ test/golden/open_class_basic/b_ext.chr view
file too large to diff
+ test/golden/open_class_basic/int.expected view
file too large to diff
+ test/golden/open_class_basic/int.goal view
file too large to diff
+ test/golden/open_class_basic/string.expected view
file too large to diff
+ test/golden/open_class_basic/string.goal view
file too large to diff
+ test/golden/open_function/open_function.chr view
file too large to diff
+ test/golden/open_function/open_function.expected view
file too large to diff
+ test/golden/open_function/open_function.goal view
file too large to diff
+ test/golden/open_function_extensions_interleaved/a_owner.chr view
file too large to diff
+ test/golden/open_function_extensions_interleaved/one.expected view
file too large to diff
+ test/golden/open_function_extensions_interleaved/one.goal view
file too large to diff
+ test/golden/open_function_extensions_interleaved/zero.expected view
file too large to diff
+ test/golden/open_function_extensions_interleaved/zero.goal view
file too large to diff
+ test/golden/open_function_multi_module/a_main.chr view
file too large to diff
+ test/golden/open_function_multi_module/b_extra.chr view
file too large to diff
+ test/golden/open_function_multi_module/blue.expected view
file too large to diff
+ test/golden/open_function_multi_module/blue.goal view
file too large to diff
+ test/golden/open_function_multi_module/cat.expected view
file too large to diff
+ test/golden/open_function_multi_module/cat.goal view
file too large to diff
+ test/golden/open_function_multi_module/dog.expected view
file too large to diff
+ test/golden/open_function_multi_module/dog.goal view
file too large to diff
+ test/golden/open_function_multi_module/other.expected view
file too large to diff
+ test/golden/open_function_multi_module/other.goal view
file too large to diff
+ test/golden/open_function_multi_module/red.expected view
file too large to diff
+ test/golden/open_function_multi_module/red.goal view
file too large to diff
+ test/golden/open_function_no_warn/open_function_no_warn.chr view
file too large to diff
+ test/golden/open_function_no_warn/open_function_no_warn.expected view
file too large to diff
+ test/golden/open_function_no_warn/open_function_no_warn.goal view
file too large to diff
+ test/golden/operator_export_import/a_lib.chr view
file too large to diff
+ test/golden/operator_export_import/b_main.chr view
file too large to diff
+ test/golden/operator_export_import/basic.expected view
file too large to diff
+ test/golden/operator_export_import/basic.goal view
file too large to diff
+ test/golden/operator_export_import/chained.expected view
file too large to diff
+ test/golden/operator_export_import/chained.goal view
file too large to diff
+ test/golden/operator_export_import/zero.expected view
file too large to diff
+ test/golden/operator_export_import/zero.goal view
file too large to diff
+ test/golden/orphan_equation_in_declaring_module/orphan_equation_in_declaring_module.chr view
file too large to diff
+ test/golden/orphan_equation_in_declaring_module/orphan_equation_in_declaring_module.expected view
file too large to diff
+ test/golden/orphan_equation_in_declaring_module/orphan_equation_in_declaring_module.goal view
file too large to diff
+ test/golden/orphan_function_equation/a_owner.chr view
file too large to diff
+ test/golden/orphan_function_equation/b_ext.chr view
file too large to diff
+ test/golden/orphan_function_equation/orphan_function_equation.error view
file too large to diff
+ test/golden/overload_basic/overload_basic.chr view
file too large to diff
+ test/golden/overload_basic/overload_basic.expected view
file too large to diff
+ test/golden/overload_basic/overload_basic.goal view
file too large to diff
+ test/golden/overload_mismatch/overload_mismatch.chr view
file too large to diff
+ test/golden/overload_mismatch/overload_mismatch.error view
file too large to diff
+ test/golden/overload_return_propagation/overload_return_propagation.chr view
file too large to diff
+ test/golden/overload_return_propagation/overload_return_propagation.error view
file too large to diff
+ test/golden/parse_error/parse_error.chr view
file too large to diff
+ test/golden/parse_error/parse_error.error view
file too large to diff
+ test/golden/passive_symmetry/passive_symmetry.chr view
file too large to diff
+ test/golden/passive_symmetry/passive_symmetry.expected view
file too large to diff
+ test/golden/passive_symmetry/passive_symmetry.goal view
file too large to diff
+ test/golden/polymorphic_bounded_overload/polymorphic_bounded_overload.chr view
file too large to diff
+ test/golden/polymorphic_bounded_overload/polymorphic_bounded_overload.expected view
file too large to diff
+ test/golden/polymorphic_bounded_overload/polymorphic_bounded_overload.goal view
file too large to diff
+ test/golden/polymorphic_constraint_cross_occurrence/polymorphic_constraint_cross_occurrence.chr view
file too large to diff
+ test/golden/polymorphic_constraint_cross_occurrence/polymorphic_constraint_cross_occurrence.expected view
file too large to diff
+ test/golden/polymorphic_constraint_cross_occurrence/polymorphic_constraint_cross_occurrence.goal view
file too large to diff
+ test/golden/polymorphic_unbounded_overload/polymorphic_unbounded_overload.chr view
file too large to diff
+ test/golden/polymorphic_unbounded_overload/polymorphic_unbounded_overload.error view
file too large to diff
+ test/golden/qualified_constraint_in_body/a_lib.chr view
file too large to diff
+ test/golden/qualified_constraint_in_body/b_main.chr view
file too large to diff
+ test/golden/qualified_constraint_in_body/qualified.expected view
file too large to diff
+ test/golden/qualified_constraint_in_body/qualified.goal view
file too large to diff
+ test/golden/qualified_constraint_in_body/qualified_zero.expected view
file too large to diff
+ test/golden/qualified_constraint_in_body/qualified_zero.goal view
file too large to diff
+ test/golden/qualified_constraint_in_body/unqualified.expected view
file too large to diff
+ test/golden/qualified_constraint_in_body/unqualified.goal view
file too large to diff
+ test/golden/qualified_constructor_with_args/qualified_constructor_with_args.chr view
file too large to diff
+ test/golden/qualified_constructor_with_args/qualified_constructor_with_args.expected view
file too large to diff
+ test/golden/qualified_constructor_with_args/qualified_constructor_with_args.goal view
file too large to diff
+ test/golden/qualified_module_not_imported/README.md view
file too large to diff
+ test/golden/qualified_module_not_imported/moda.chr view
file too large to diff
+ test/golden/qualified_module_not_imported/modb.chr view
file too large to diff
+ test/golden/qualified_module_not_imported/modc.chr view
file too large to diff
+ test/golden/qualified_module_not_imported/modc.error view
file too large to diff
+ test/golden/qualified_non_exported_constructor/palette.chr view
file too large to diff
+ test/golden/qualified_non_exported_constructor/user.chr view
file too large to diff
+ test/golden/qualified_non_exported_constructor/user.error view
file too large to diff
+ test/golden/qualified_non_exported_function/qne_lib.chr view
file too large to diff
+ test/golden/qualified_non_exported_function/qne_main.chr view
file too large to diff
+ test/golden/qualified_non_exported_function/qne_main.error view
file too large to diff
+ test/golden/qualified_unicode_collision/m.chr view
file too large to diff
+ test/golden/qualified_unicode_collision/m.expected view
file too large to diff
+ test/golden/qualified_unicode_collision/m.goal view
file too large to diff
+ test/golden/qualified_unicode_ctor/m.chr view
file too large to diff
+ test/golden/qualified_unicode_ctor/naive.expected view
file too large to diff
+ test/golden/qualified_unicode_ctor/naive.goal view
file too large to diff
+ test/golden/qualified_unicode_ctor/pound_foo.expected view
file too large to diff
+ test/golden/qualified_unicode_ctor/pound_foo.goal view
file too large to diff
+ test/golden/qualified_unicode_ctor/uaafoo.expected view
file too large to diff
+ test/golden/qualified_unicode_ctor/uaafoo.goal view
file too large to diff
+ test/golden/qualified_unicode_ctor/uffi.expected view
file too large to diff
+ test/golden/qualified_unicode_ctor/uffi.goal view
file too large to diff
+ test/golden/qualified_unicode_ctor/urgent.expected view
file too large to diff
+ test/golden/qualified_unicode_ctor/urgent.goal view
file too large to diff
+ test/golden/qualified_unicode_module/m.chr view
file too large to diff
+ test/golden/qualified_unicode_module/m.expected view
file too large to diff
+ test/golden/qualified_unicode_module/m.goal view
file too large to diff
+ test/golden/qualified_unknown_module/README.md view
file too large to diff
+ test/golden/qualified_unknown_module/main.chr view
file too large to diff
+ test/golden/qualified_unknown_module/main.error view
file too large to diff
+ test/golden/quote_in_unify/flat.expected view
file too large to diff
+ test/golden/quote_in_unify/flat.goal view
file too large to diff
+ test/golden/quote_in_unify/nested.expected view
file too large to diff
+ test/golden/quote_in_unify/nested.goal view
file too large to diff
+ test/golden/quote_in_unify/quote_in_unify.chr view
file too large to diff
+ test/golden/quoted_constraint_name/quoted.chr view
file too large to diff
+ test/golden/quoted_constraint_name/quoted.expected view
file too large to diff
+ test/golden/quoted_constraint_name/quoted.goal view
file too large to diff
+ test/golden/quoting/quoting.chr view
file too large to diff
+ test/golden/quoting/quoting.expected view
file too large to diff
+ test/golden/quoting/quoting.goal view
file too large to diff
+ test/golden/quoting_around_call/quoting_around_call.chr view
file too large to diff
+ test/golden/quoting_around_call/quoting_around_call.expected view
file too large to diff
+ test/golden/quoting_around_call/quoting_around_call.goal view
file too large to diff
+ test/golden/reactivation_nested_var/bare.expected view
file too large to diff
+ test/golden/reactivation_nested_var/bare.goal view
file too large to diff
+ test/golden/reactivation_nested_var/nested.expected view
file too large to diff
+ test/golden/reactivation_nested_var/nested.goal view
file too large to diff
+ test/golden/reactivation_nested_var/reactivation_nested_var.chr view
file too large to diff
+ test/golden/read_term_test/read_term_test.chr view
file too large to diff
+ test/golden/read_term_test/read_term_test.expected view
file too large to diff
+ test/golden/read_term_test/read_term_test.goal view
file too large to diff
+ test/golden/reserved_host_module/reserved_host_module.chr view
file too large to diff
+ test/golden/reserved_host_module/reserved_host_module.error view
file too large to diff
+ test/golden/reserved_quote_constraint/reserved_quote_constraint.chr view
file too large to diff
+ test/golden/reserved_quote_constraint/reserved_quote_constraint.error view
file too large to diff
+ test/golden/reserved_quote_function/reserved_quote_function.chr view
file too large to diff
+ test/golden/reserved_quote_function/reserved_quote_function.error view
file too large to diff
+ test/golden/runtime_error_arith_type/atom_in_arith.error view
file too large to diff
+ test/golden/runtime_error_arith_type/atom_in_arith.goal view
file too large to diff
+ test/golden/runtime_error_arith_type/runtime_error_arith_type.chr view
file too large to diff
+ test/golden/runtime_error_call_stack/nested_fn_error.error view
file too large to diff
+ test/golden/runtime_error_call_stack/nested_fn_error.goal view
file too large to diff
+ test/golden/runtime_error_call_stack/runtime_error_call_stack.chr view
file too large to diff
+ test/golden/runtime_error_int_div_zero/div_zero.error view
file too large to diff
+ test/golden/runtime_error_int_div_zero/div_zero.goal view
file too large to diff
+ test/golden/runtime_error_int_div_zero/mod_zero.error view
file too large to diff
+ test/golden/runtime_error_int_div_zero/mod_zero.goal view
file too large to diff
+ test/golden/runtime_error_int_div_zero/runtime_error_int_div_zero.chr view
file too large to diff
+ test/golden/runtime_error_string_arity/int_to_string_length.error view
file too large to diff
+ test/golden/runtime_error_string_arity/int_to_string_length.goal view
file too large to diff
+ test/golden/runtime_error_string_arity/runtime_error_string_arity.chr view
file too large to diff
+ test/golden/short_alias_collision/from_a.expected view
file too large to diff
+ test/golden/short_alias_collision/from_a.goal view
file too large to diff
+ test/golden/short_alias_collision/from_b.expected view
file too large to diff
+ test/golden/short_alias_collision/from_b.goal view
file too large to diff
+ test/golden/short_alias_collision/mod_a.chr view
file too large to diff
+ test/golden/short_alias_collision/mod_b.chr view
file too large to diff
+ test/golden/stdlib_test/stdlib_test.chr view
file too large to diff
+ test/golden/stdlib_test/stdlib_test.expected view
file too large to diff
+ test/golden/stdlib_test/stdlib_test.goal view
file too large to diff
+ test/golden/stlc/apply.expected view
file too large to diff
+ test/golden/stlc/apply.goal view
file too large to diff
+ test/golden/stlc/const.expected view
file too large to diff
+ test/golden/stlc/const.goal view
file too large to diff
+ test/golden/stlc/identity.expected view
file too large to diff
+ test/golden/stlc/identity.goal view
file too large to diff
+ test/golden/stlc/infinite.expected view
file too large to diff
+ test/golden/stlc/infinite.goal view
file too large to diff
+ test/golden/stlc/mismatch.expected view
file too large to diff
+ test/golden/stlc/mismatch.goal view
file too large to diff
+ test/golden/stlc/mono.expected view
file too large to diff
+ test/golden/stlc/mono.goal view
file too large to diff
+ test/golden/stlc/stlc.chr view
file too large to diff
+ test/golden/stlc/twice.expected view
file too large to diff
+ test/golden/stlc/twice.goal view
file too large to diff
+ test/golden/stlc/unbound.expected view
file too large to diff
+ test/golden/stlc/unbound.goal view
file too large to diff
+ test/golden/string_length_test/string_length_test.chr view
file too large to diff
+ test/golden/string_length_test/string_length_test.expected view
file too large to diff
+ test/golden/string_length_test/string_length_test.goal view
file too large to diff
+ test/golden/string_lower_test/string_lower_test.chr view
file too large to diff
+ test/golden/string_lower_test/string_lower_test.expected view
file too large to diff
+ test/golden/string_lower_test/string_lower_test.goal view
file too large to diff
+ test/golden/string_upper_test/string_upper_test.chr view
file too large to diff
+ test/golden/string_upper_test/string_upper_test.expected view
file too large to diff
+ test/golden/string_upper_test/string_upper_test.goal view
file too large to diff
+ test/golden/strings/concat_basic.expected view
file too large to diff
+ test/golden/strings/concat_basic.goal view
file too large to diff
+ test/golden/strings/concat_both.expected view
file too large to diff
+ test/golden/strings/concat_both.goal view
file too large to diff
+ test/golden/strings/concat_empty_l.expected view
file too large to diff
+ test/golden/strings/concat_empty_l.goal view
file too large to diff
+ test/golden/strings/concat_empty_r.expected view
file too large to diff
+ test/golden/strings/concat_empty_r.goal view
file too large to diff
+ test/golden/strings/len_basic.expected view
file too large to diff
+ test/golden/strings/len_basic.goal view
file too large to diff
+ test/golden/strings/len_short.expected view
file too large to diff
+ test/golden/strings/len_short.goal view
file too large to diff
+ test/golden/strings/len_unicode.expected view
file too large to diff
+ test/golden/strings/len_unicode.goal view
file too large to diff
+ test/golden/strings/len_zero.expected view
file too large to diff
+ test/golden/strings/len_zero.goal view
file too large to diff
+ test/golden/strings/lower_basic.expected view
file too large to diff
+ test/golden/strings/lower_basic.goal view
file too large to diff
+ test/golden/strings/lower_empty.expected view
file too large to diff
+ test/golden/strings/lower_empty.goal view
file too large to diff
+ test/golden/strings/lower_mixed.expected view
file too large to diff
+ test/golden/strings/lower_mixed.goal view
file too large to diff
+ test/golden/strings/strings.chr view
file too large to diff
+ test/golden/strings/upper_already.expected view
file too large to diff
+ test/golden/strings/upper_already.goal view
file too large to diff
+ test/golden/strings/upper_basic.expected view
file too large to diff
+ test/golden/strings/upper_basic.goal view
file too large to diff
+ test/golden/strings/upper_empty.expected view
file too large to diff
+ test/golden/strings/upper_empty.goal view
file too large to diff
+ test/golden/strings/upper_unicode.expected view
file too large to diff
+ test/golden/strings/upper_unicode.goal view
file too large to diff
+ test/golden/strings_test/strings_test.chr view
file too large to diff
+ test/golden/strings_test/strings_test.expected view
file too large to diff
+ test/golden/strings_test/strings_test.goal view
file too large to diff
+ test/golden/sum_list_test/sum_list_test.chr view
file too large to diff
+ test/golden/sum_list_test/sum_list_test.expected view
file too large to diff
+ test/golden/sum_list_test/sum_list_test.goal view
file too large to diff
+ test/golden/tail_test/tail_test.chr view
file too large to diff
+ test/golden/tail_test/tail_test.expected view
file too large to diff
+ test/golden/tail_test/tail_test.goal view
file too large to diff
+ test/golden/term_variables/empty.expected view
file too large to diff
+ test/golden/term_variables/empty.goal view
file too large to diff
+ test/golden/term_variables/multi.expected view
file too large to diff
+ test/golden/term_variables/multi.goal view
file too large to diff
+ test/golden/term_variables/nested.expected view
file too large to diff
+ test/golden/term_variables/nested.goal view
file too large to diff
+ test/golden/term_variables/one.expected view
file too large to diff
+ test/golden/term_variables/one.goal view
file too large to diff
+ test/golden/term_variables/repeated.expected view
file too large to diff
+ test/golden/term_variables/repeated.goal view
file too large to diff
+ test/golden/term_variables/term_variables.chr view
file too large to diff
+ test/golden/type_export_constructor_allowlist/a_lib.chr view
file too large to diff
+ test/golden/type_export_constructor_allowlist/b_main.chr view
file too large to diff
+ test/golden/type_export_constructor_allowlist/green.expected view
file too large to diff
+ test/golden/type_export_constructor_allowlist/green.goal view
file too large to diff
+ test/golden/type_export_constructor_allowlist/red.expected view
file too large to diff
+ test/golden/type_export_constructor_allowlist/red.goal view
file too large to diff
+ test/golden/type_export_constructor_empty/a_lib.chr view
file too large to diff
+ test/golden/type_export_constructor_empty/b_main.chr view
file too large to diff
+ test/golden/type_export_constructor_empty/red.expected view
file too large to diff
+ test/golden/type_export_constructor_empty/red.goal view
file too large to diff
+ test/golden/type_export_constructor_unknown/lib.chr view
file too large to diff
+ test/golden/type_export_constructor_unknown/lib.error view
file too large to diff
+ test/golden/type_import_constructor_narrowing/a_lib.chr view
file too large to diff
+ test/golden/type_import_constructor_narrowing/b_main.chr view
file too large to diff
+ test/golden/type_import_constructor_narrowing/green.expected view
file too large to diff
+ test/golden/type_import_constructor_narrowing/green.goal view
file too large to diff
+ test/golden/type_import_constructor_narrowing/red.expected view
file too large to diff
+ test/golden/type_import_constructor_narrowing/red.goal view
file too large to diff
+ test/golden/type_import_constructor_undeclared/a_lib.chr view
file too large to diff
+ test/golden/type_import_constructor_undeclared/b_main.chr view
file too large to diff
+ test/golden/type_import_constructor_undeclared/b_main.error view
file too large to diff
+ test/golden/type_import_constructor_unknown/a_lib.chr view
file too large to diff
+ test/golden/type_import_constructor_unknown/b_main.chr view
file too large to diff
+ test/golden/type_import_constructor_unknown/b_main.error view
file too large to diff
+ test/golden/type_predicates/atm_no.expected view
file too large to diff
+ test/golden/type_predicates/atm_no.goal view
file too large to diff
+ test/golden/type_predicates/atm_yes.expected view
file too large to diff
+ test/golden/type_predicates/atm_yes.goal view
file too large to diff
+ test/golden/type_predicates/boo_no.expected view
file too large to diff
+ test/golden/type_predicates/boo_no.goal view
file too large to diff
+ test/golden/type_predicates/boo_yes.expected view
file too large to diff
+ test/golden/type_predicates/boo_yes.goal view
file too large to diff
+ test/golden/type_predicates/flt_no.expected view
file too large to diff
+ test/golden/type_predicates/flt_no.goal view
file too large to diff
+ test/golden/type_predicates/flt_yes.expected view
file too large to diff
+ test/golden/type_predicates/flt_yes.goal view
file too large to diff
+ test/golden/type_predicates/grd_no.expected view
file too large to diff
+ test/golden/type_predicates/grd_no.goal view
file too large to diff
+ test/golden/type_predicates/grd_yes.expected view
file too large to diff
+ test/golden/type_predicates/grd_yes.goal view
file too large to diff
+ test/golden/type_predicates/int_no.expected view
file too large to diff
+ test/golden/type_predicates/int_no.goal view
file too large to diff
+ test/golden/type_predicates/int_yes.expected view
file too large to diff
+ test/golden/type_predicates/int_yes.goal view
file too large to diff
+ test/golden/type_predicates/nvr_no.expected view
file too large to diff
+ test/golden/type_predicates/nvr_no.goal view
file too large to diff
+ test/golden/type_predicates/nvr_yes.expected view
file too large to diff
+ test/golden/type_predicates/nvr_yes.goal view
file too large to diff
+ test/golden/type_predicates/str_no.expected view
file too large to diff
+ test/golden/type_predicates/str_no.goal view
file too large to diff
+ test/golden/type_predicates/str_yes.expected view
file too large to diff
+ test/golden/type_predicates/str_yes.goal view
file too large to diff
+ test/golden/type_predicates/type_predicates.chr view
file too large to diff
+ test/golden/type_predicates/vr_no.expected view
file too large to diff
+ test/golden/type_predicates/vr_no.goal view
file too large to diff
+ test/golden/type_predicates/vr_yes.expected view
file too large to diff
+ test/golden/type_predicates/vr_yes.goal view
file too large to diff
+ test/golden/typecheck_algebraic/typecheck_algebraic.chr view
file too large to diff
+ test/golden/typecheck_algebraic/typecheck_algebraic.expected view
file too large to diff
+ test/golden/typecheck_algebraic/typecheck_algebraic.goal view
file too large to diff
+ test/golden/typecheck_any_absorb/typecheck_any_absorb.chr view
file too large to diff
+ test/golden/typecheck_any_absorb/typecheck_any_absorb.expected view
file too large to diff
+ test/golden/typecheck_any_absorb/typecheck_any_absorb.goal view
file too large to diff
+ test/golden/typecheck_conflict/typecheck_conflict.chr view
file too large to diff
+ test/golden/typecheck_conflict/typecheck_conflict.error view
file too large to diff
+ test/golden/typecheck_constructor_arity/typecheck_constructor_arity.chr view
file too large to diff
+ test/golden/typecheck_constructor_arity/typecheck_constructor_arity.error view
file too large to diff
+ test/golden/typecheck_constructor_arity_head/typecheck_constructor_arity_head.chr view
file too large to diff
+ test/golden/typecheck_constructor_arity_head/typecheck_constructor_arity_head.error view
file too large to diff
+ test/golden/typecheck_constructor_in_lambda_body/run_7.expected view
file too large to diff
+ test/golden/typecheck_constructor_in_lambda_body/run_7.goal view
file too large to diff
+ test/golden/typecheck_constructor_in_lambda_body/run_zero.expected view
file too large to diff
+ test/golden/typecheck_constructor_in_lambda_body/run_zero.goal view
file too large to diff
+ test/golden/typecheck_constructor_in_lambda_body/typecheck_constructor_in_lambda_body.chr view
file too large to diff
+ test/golden/typecheck_duplicate_constructor/typecheck_duplicate_constructor.chr view
file too large to diff
+ test/golden/typecheck_duplicate_constructor/typecheck_duplicate_constructor.error view
file too large to diff
+ test/golden/typecheck_fun_conflict/typecheck_fun_conflict.chr view
file too large to diff
+ test/golden/typecheck_fun_conflict/typecheck_fun_conflict.error view
file too large to diff
+ test/golden/typecheck_function/typecheck_function.chr view
file too large to diff
+ test/golden/typecheck_function/typecheck_function.expected view
file too large to diff
+ test/golden/typecheck_function/typecheck_function.goal view
file too large to diff
+ test/golden/typecheck_function_returns_lambda/run_100.expected view
file too large to diff
+ test/golden/typecheck_function_returns_lambda/run_100.goal view
file too large to diff
+ test/golden/typecheck_function_returns_lambda/run_5.expected view
file too large to diff
+ test/golden/typecheck_function_returns_lambda/run_5.goal view
file too large to diff
+ test/golden/typecheck_function_returns_lambda/typecheck_function_returns_lambda.chr view
file too large to diff
+ test/golden/typecheck_funref_arity/typecheck_funref_arity.chr view
file too large to diff
+ test/golden/typecheck_funref_arity/typecheck_funref_arity.error view
file too large to diff
+ test/golden/typecheck_funref_conflict/typecheck_funref_conflict.chr view
file too large to diff
+ test/golden/typecheck_funref_conflict/typecheck_funref_conflict.error view
file too large to diff
+ test/golden/typecheck_goal_arg_type/ok_arg.expected view
file too large to diff
+ test/golden/typecheck_goal_arg_type/ok_arg.goal view
file too large to diff
+ test/golden/typecheck_goal_arg_type/typecheck_goal_arg_type.chr view
file too large to diff
+ test/golden/typecheck_goal_arg_type/wrong_arg.error view
file too large to diff
+ test/golden/typecheck_goal_arg_type/wrong_arg.goal view
file too large to diff
+ test/golden/typecheck_lambda_arity/typecheck_lambda_arity.chr view
file too large to diff
+ test/golden/typecheck_lambda_arity/typecheck_lambda_arity.error view
file too large to diff
+ test/golden/typecheck_lambda_conflict/typecheck_lambda_conflict.chr view
file too large to diff
+ test/golden/typecheck_lambda_conflict/typecheck_lambda_conflict.error view
file too large to diff
+ test/golden/typecheck_list_pattern/typecheck_list_pattern.chr view
file too large to diff
+ test/golden/typecheck_list_pattern/typecheck_list_pattern.expected view
file too large to diff
+ test/golden/typecheck_list_pattern/typecheck_list_pattern.goal view
file too large to diff
+ test/golden/typecheck_list_pattern_bad/typecheck_list_pattern_bad.chr view
file too large to diff
+ test/golden/typecheck_list_pattern_bad/typecheck_list_pattern_bad.error view
file too large to diff
+ test/golden/typecheck_open_function_consistency/a_owner.chr view
file too large to diff
+ test/golden/typecheck_open_function_consistency/b_extender.chr view
file too large to diff
+ test/golden/typecheck_open_function_consistency/typecheck_open_function_consistency.error view
file too large to diff
+ test/golden/typecheck_polymorphic_constraint/int.expected view
file too large to diff
+ test/golden/typecheck_polymorphic_constraint/int.goal view
file too large to diff
+ test/golden/typecheck_polymorphic_constraint/list.expected view
file too large to diff
+ test/golden/typecheck_polymorphic_constraint/list.goal view
file too large to diff
+ test/golden/typecheck_polymorphic_constraint/str.expected view
file too large to diff
+ test/golden/typecheck_polymorphic_constraint/str.goal view
file too large to diff
+ test/golden/typecheck_polymorphic_constraint/typecheck_polymorphic_constraint.chr view
file too large to diff
+ test/golden/typecheck_polymorphic_inconsistent/typecheck_polymorphic_inconsistent.chr view
file too large to diff
+ test/golden/typecheck_polymorphic_inconsistent/typecheck_polymorphic_inconsistent.error view
file too large to diff
+ test/golden/typecheck_qualified_in_head/typecheck_qualified_in_head.chr view
file too large to diff
+ test/golden/typecheck_qualified_in_head/typecheck_qualified_in_head.expected view
file too large to diff
+ test/golden/typecheck_qualified_in_head/typecheck_qualified_in_head.goal view
file too large to diff
+ test/golden/typecheck_qualified_in_head_bad/typecheck_qualified_in_head_bad.chr view
file too large to diff
+ test/golden/typecheck_qualified_in_head_bad/typecheck_qualified_in_head_bad.error view
file too large to diff
+ test/golden/typecheck_typed_leq/typecheck_typed_leq.chr view
file too large to diff
+ test/golden/typecheck_typed_leq/typecheck_typed_leq.expected view
file too large to diff
+ test/golden/typecheck_typed_leq/typecheck_typed_leq.goal view
file too large to diff
+ test/golden/typecheck_unbound_typevar/typecheck_unbound_typevar.chr view
file too large to diff
+ test/golden/typecheck_unbound_typevar/typecheck_unbound_typevar.error view
file too large to diff
+ test/golden/typecheck_undefined_type/typecheck_undefined_type.chr view
file too large to diff
+ test/golden/typecheck_undefined_type/typecheck_undefined_type.error view
file too large to diff
+ test/golden/underscore_var/head_use.expected view
file too large to diff
+ test/golden/underscore_var/head_use.goal view
file too large to diff
+ test/golden/underscore_var/list_tail.expected view
file too large to diff
+ test/golden/underscore_var/list_tail.goal view
file too large to diff
+ test/golden/underscore_var/trivial.expected view
file too large to diff
+ test/golden/underscore_var/trivial.goal view
file too large to diff
+ test/golden/underscore_var/underscore_var.chr view
file too large to diff
+ test/golden/unexpected_body_term/unexpected_body_term.chr view
file too large to diff
+ test/golden/unexpected_body_term/unexpected_body_term.error view
file too large to diff
+ test/golden/unicode_atoms_strings/quoted_atom.expected view
file too large to diff
+ test/golden/unicode_atoms_strings/quoted_atom.goal view
file too large to diff
+ test/golden/unicode_atoms_strings/quoted_chinese.expected view
file too large to diff
+ test/golden/unicode_atoms_strings/quoted_chinese.goal view
file too large to diff
+ test/golden/unicode_atoms_strings/quoted_unicode.expected view
file too large to diff
+ test/golden/unicode_atoms_strings/quoted_unicode.goal view
file too large to diff
+ test/golden/unicode_atoms_strings/quoted_with_space.expected view
file too large to diff
+ test/golden/unicode_atoms_strings/quoted_with_space.goal view
file too large to diff
+ test/golden/unicode_atoms_strings/string_backslash.expected view
file too large to diff
+ test/golden/unicode_atoms_strings/string_backslash.goal view
file too large to diff
+ test/golden/unicode_atoms_strings/string_emoji.expected view
file too large to diff
+ test/golden/unicode_atoms_strings/string_emoji.goal view
file too large to diff
+ test/golden/unicode_atoms_strings/string_escape_n.expected view
file too large to diff
+ test/golden/unicode_atoms_strings/string_escape_n.goal view
file too large to diff
+ test/golden/unicode_atoms_strings/string_escape_q.expected view
file too large to diff
+ test/golden/unicode_atoms_strings/string_escape_q.goal view
file too large to diff
+ test/golden/unicode_atoms_strings/string_escape_t.expected view
file too large to diff
+ test/golden/unicode_atoms_strings/string_escape_t.goal view
file too large to diff
+ test/golden/unicode_atoms_strings/string_unicode.expected view
file too large to diff
+ test/golden/unicode_atoms_strings/string_unicode.goal view
file too large to diff
+ test/golden/unicode_atoms_strings/unicode_atoms_strings.chr view
file too large to diff
+ test/golden/unicode_test/unicode_test.chr view
file too large to diff
+ test/golden/unicode_test/unicode_test.expected view
file too large to diff
+ test/golden/unicode_test/unicode_test.goal view
file too large to diff
+ test/golden/unifiable/atom_eq.expected view
file too large to diff
+ test/golden/unifiable/atom_eq.goal view
file too large to diff
+ test/golden/unifiable/atom_neq.expected view
file too large to diff
+ test/golden/unifiable/atom_neq.goal view
file too large to diff
+ test/golden/unifiable/capture.expected view
file too large to diff
+ test/golden/unifiable/capture.goal view
file too large to diff
+ test/golden/unifiable/no_bind.expected view
file too large to diff
+ test/golden/unifiable/no_bind.goal view
file too large to diff
+ test/golden/unifiable/struct_match.expected view
file too large to diff
+ test/golden/unifiable/struct_match.goal view
file too large to diff
+ test/golden/unifiable/struct_mismatch.expected view
file too large to diff
+ test/golden/unifiable/struct_mismatch.goal view
file too large to diff
+ test/golden/unifiable/unifiable.chr view
file too large to diff
+ test/golden/unifiable/var_atom.expected view
file too large to diff
+ test/golden/unifiable/var_atom.goal view
file too large to diff
+ test/golden/unknown_constraint/unknown_constraint.chr view
file too large to diff
+ test/golden/unknown_constraint/unknown_constraint.error view
file too large to diff
+ test/golden/unknown_export/unknown_export.chr view
file too large to diff
+ test/golden/unknown_export/unknown_export.error view
file too large to diff
+ test/golden/unknown_library/unknown_library.chr view
file too large to diff
+ test/golden/unknown_library/unknown_library.error view
file too large to diff
+ test/golden/unreferenced_constraint/unreferenced_constraint.chr view
file too large to diff
+ test/golden/unreferenced_constraint/unreferenced_constraint.expected view
file too large to diff
+ test/golden/unreferenced_constraint/unreferenced_constraint.goal view
file too large to diff
+ test/golden/use_module_out_of_order/use_module_out_of_order.chr view
file too large to diff
+ test/golden/use_module_out_of_order/use_module_out_of_order.error view
file too large to diff
+ test/golden/write_store_to_list_test/write_store_to_list_test.chr view
file too large to diff
+ test/golden/write_store_to_list_test/write_store_to_list_test.expected view
file too large to diff
+ test/golden/write_store_to_list_test/write_store_to_list_test.goal view
file too large to diff
+ typechecker/typechecker.chr view
file too large to diff
+ ychr.cabal view
file too large to diff