diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 "" opts.gdGoal of + Left err -> do + putStr (displayMsg (ParseError "" 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 diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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//@ 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 @/.chr@ and +-- @/.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 "" (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) diff --git a/examples/bakery.chr b/examples/bakery.chr new file mode 100644 --- /dev/null +++ b/examples/bakery.chr @@ -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. diff --git a/examples/clamp.chr b/examples/clamp.chr new file mode 100644 --- /dev/null +++ b/examples/clamp.chr @@ -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. diff --git a/examples/closures.chr b/examples/closures.chr new file mode 100644 --- /dev/null +++ b/examples/closures.chr @@ -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). diff --git a/examples/factorial.chr b/examples/factorial.chr new file mode 100644 --- /dev/null +++ b/examples/factorial.chr @@ -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). diff --git a/examples/fib.chr b/examples/fib.chr new file mode 100644 --- /dev/null +++ b/examples/fib.chr @@ -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). diff --git a/examples/gcd.chr b/examples/gcd.chr new file mode 100644 --- /dev/null +++ b/examples/gcd.chr @@ -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). diff --git a/examples/leq.chr b/examples/leq.chr new file mode 100644 --- /dev/null +++ b/examples/leq.chr @@ -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). diff --git a/examples/stlc/Embed.hs b/examples/stlc/Embed.hs new file mode 100644 --- /dev/null +++ b/examples/stlc/Embed.hs @@ -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) diff --git a/examples/stlc/Main.hs b/examples/stlc/Main.hs new file mode 100644 --- /dev/null +++ b/examples/stlc/Main.hs @@ -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(), 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 diff --git a/examples/stlc/Parser.hs b/examples/stlc/Parser.hs new file mode 100644 --- /dev/null +++ b/examples/stlc/Parser.hs @@ -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) diff --git a/examples/stlc/Syntax.hs b/examples/stlc/Syntax.hs new file mode 100644 --- /dev/null +++ b/examples/stlc/Syntax.hs @@ -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] diff --git a/examples/stlc/stlc.chr b/examples/stlc/stlc.chr new file mode 100644 --- /dev/null +++ b/examples/stlc/stlc.chr @@ -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). diff --git a/examples/traffic.chr b/examples/traffic.chr new file mode 100644 --- /dev/null +++ b/examples/traffic.chr @@ -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). diff --git a/libraries/lists.chr b/libraries/lists.chr new file mode 100644 --- /dev/null +++ b/libraries/lists.chr @@ -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). diff --git a/libraries/meta.chr b/libraries/meta.chr new file mode 100644 --- /dev/null +++ b/libraries/meta.chr @@ -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. diff --git a/libraries/prelude.chr b/libraries/prelude.chr new file mode 100644 --- /dev/null +++ b/libraries/prelude.chr @@ -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). diff --git a/libraries/strings.chr b/libraries/strings.chr new file mode 100644 --- /dev/null +++ b/libraries/strings.chr @@ -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). diff --git a/src/YCHR.hs b/src/YCHR.hs new file mode 100644 --- /dev/null +++ b/src/YCHR.hs @@ -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. diff --git a/src/YCHR/Convert.hs b/src/YCHR/Convert.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Convert.hs @@ -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 diff --git a/src/YCHR/DSL.hs b/src/YCHR/DSL.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/DSL.hs @@ -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 diff --git a/src/YCHR/Internal/Backend/Scheme.hs b/src/YCHR/Internal/Backend/Scheme.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Backend/Scheme.hs @@ -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 @@; 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 @@ — 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]) diff --git a/src/YCHR/Internal/Backend/SchemeDriver.hs b/src/YCHR/Internal/Backend/SchemeDriver.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Backend/SchemeDriver.hs @@ -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 _ = [] diff --git a/src/YCHR/Internal/Collect.hs b/src/YCHR/Internal/Collect.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Collect.hs @@ -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 diff --git a/src/YCHR/Internal/Collected.hs b/src/YCHR/Internal/Collected.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Collected.hs @@ -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 diff --git a/src/YCHR/Internal/Compile.hs b/src/YCHR/Internal/Compile.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Compile.hs @@ -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\@, 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 @'/'(, )@ +-- 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. +--------------------------------------------------------------------------- -} diff --git a/src/YCHR/Internal/Compile/Names.hs b/src/YCHR/Internal/Compile/Names.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Compile/Names.hs @@ -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\@ where @\@ 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\__@ 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" diff --git a/src/YCHR/Internal/Compile/Occurrences.hs b/src/YCHR/Internal/Compile/Occurrences.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Compile/Occurrences.hs @@ -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)) diff --git a/src/YCHR/Internal/Compile/Passive.hs b/src/YCHR/Internal/Compile/Passive.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Compile/Passive.hs @@ -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 diff --git a/src/YCHR/Internal/Compile/Pipeline.hs b/src/YCHR/Internal/Compile/Pipeline.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Compile/Pipeline.hs @@ -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 @\@ 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 diff --git a/src/YCHR/Internal/Compile/Types.hs b/src/YCHR/Internal/Compile/Types.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Compile/Types.hs @@ -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 diff --git a/src/YCHR/Internal/Constructors.hs b/src/YCHR/Internal/Constructors.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Constructors.hs @@ -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 diff --git a/src/YCHR/Internal/Desugar.hs b/src/YCHR/Internal/Desugar.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Desugar.hs @@ -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 ω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"@. +--------------------------------------------------------------------------- -} diff --git a/src/YCHR/Internal/Desugared.hs b/src/YCHR/Internal/Desugared.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Desugared.hs @@ -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) diff --git a/src/YCHR/Internal/Diagnostic.hs b/src/YCHR/Internal/Diagnostic.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Diagnostic.hs @@ -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 diff --git a/src/YCHR/Internal/Display.hs b/src/YCHR/Internal/Display.hs new file mode 100644 --- /dev/null +++ b/src/YCHR/Internal/Display.hs @@ -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 '<