phino 0.0.143 → 0.0.144

raw patch · 48 files changed

+3969/−766 lines, 48 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +200/−75
• benchmark/Main.hs +16/−4
• compiled/generated/Compiled.hs +514/−0
• compiled/stub/Compiled.hs +13/−0
• phino.cabal +26/−1
• src/AST.hs +77/−19
• src/Builder.hs +15/−15
• src/CLI.hs +2/−0
• src/CLI/Helpers.hs +13/−0
• src/CLI/Parsers.hs +31/−0
• src/CLI/Runners.hs +28/−5
• src/CLI/Types.hs +15/−0
• src/CST.hs +3/−3
• src/Contextualize.hs +86/−0
• src/Dataize.hs +22/−91
• src/Deps.hs +73/−8
• src/Emit.hs +791/−0
• src/Engine.hs +72/−0
• src/Evaluate.hs +27/−28
• src/Functions.hs +11/−5
• src/Inference.hs +184/−0
• src/LaTeX.hs +47/−18
• src/Matcher.hs +56/−0
• src/Morph.hs +304/−190
• src/Pool.hs +36/−0
• src/Rewriter.hs +75/−39
• src/Rule.hs +117/−58
• src/Tau.hs +28/−5
• test/ASTSpec.hs +20/−0
• test/BuilderSpec.hs +11/−88
• test/CLISpec.hs +245/−43
• test/CanonizerSpec.hs +3/−2
• test/CompiledSpec.hs +144/−0
• test/ContextualizeSpec.hs +66/−0
• test/DataizeSpec.hs +47/−11
• test/DepsSpec.hs +17/−3
• test/EmitSpec.hs +134/−0
• test/EngineSpec.hs +33/−0
• test/FilterSpec.hs +5/−4
• test/Fixtures.hs +20/−3
• test/InferenceSpec.hs +102/−0
• test/LaTeXSpec.hs +68/−16
• test/MatcherSpec.hs +21/−0
• test/MorphSpec.hs +46/−13
• test/PoolSpec.hs +35/−0
• test/RewriterSpec.hs +36/−9
• test/RuleSpec.hs +18/−8
• test/TauSpec.hs +16/−2

@@ -34,7 +34,7 @@  ```bash cabal update-cabal install --overwrite-policy=always phino-0.0.140+cabal install --overwrite-policy=always phino-0.0.143 phino --version ``` @@ -547,6 +547,12 @@ The markup spells them `<unfinished λ="L_outer"/>`, `<stall λ="L_outer"/>` and `<starved limit="4" by="dataize" at="Φ.a🌵1"/>`. +`timeout(5)  # 𝕄(…)` is where `--max-seconds=5` ran out, commented the same+way and written at the first step the deadline refused.+The run ends there, with or without `--partial`, so it is always the last line+of the protocol.+The markup spells it `<timeout limit="5" by="morph" at="…"/>`.+ Every term is 𝜑 on a single line, whatever `--output` and `--flat` say about the result of the run, so a program reading the protocol back never has to know what the run printed. The file is truncated at the beginning of every run, so@@ -983,6 +989,25 @@ [ERROR]: Evaluation did not finish before reaching the limit of firings: --max-firings=64 ``` +Both budgets count work, so a run inside both of them may still take longer+than its caller can wait, and a caller that kills it gets a protocol nobody+closed. The `--max-seconds` option stops the run by the clock instead: once+that many seconds have passed since the command started, the next step the+run is about to take, whether it fires a λ function or not, fails it with+`Evaluation did not finish before reaching the limit of seconds`, and so does+a check of `--acyclic` that is still comparing formations by then.+`--partial` does not park it, since a run out of time has no site to park and+nothing left to go on with. The protocol is closed as usual and its last line+says where the time ran out. There is no limit unless the option is given:++```bash+$ phino morph --symbolic=split.yaml --locator=Q.x --partial --max-seconds=5 \+    --protocol=split.txt --sweet --flat split.phi+[ERROR]: Evaluation did not finish before reaching the limit of seconds: --max-seconds=5+$ grep -o 'timeout.*' split.txt+timeout(5)  # 𝕄(Φ.a🌵14250)+```+ ## Morph  Dataization insists on bytes. Morphing 𝕄 asks a different question: evaluate@@ -1432,6 +1457,58 @@ stands in, and so a recursion over copies of one object stops after its first round, with the second one as written. +The walk of `--deep` takes the bindings of the formation it starts at one+after another. When they are independent entries, such as the objects of a+whole runtime listed in one formation, the `--jobs` option walks them side by+side on that many workers. Each binding gets its own memo, its own+`--max-firings` tally and its own fresh names, so what it comes to does not+depend on which worker got there first. The answers and the protocol come out+in the order of the bindings, with the symbols numbered as one walk would+number them:++```bash+$ cat plus.yaml+- λ: L_plus+  dataize:+    𝛿1: $.ρ+    𝛿2: $.x+  𝑛: Φ.num( φ ↦ ⟦ λ ⤍ 𝜎 ⟧ )+$ cat sums.phi+⟦+  num ↦ ⟦ φ ↦ ∅, plus ↦ ⟦ ρ ↦ ∅, x ↦ ∅, λ ⤍ L_plus ⟧ ⟧,+  l🌵 ↦ ⟦+    a ↦ Φ.num( φ ↦ ⟦ Δ ⤍ 01- ⟧ ).plus( x ↦ Φ.num( φ ↦ ⟦ Δ ⤍ 02- ⟧ ) ),+    b ↦ Φ.num( φ ↦ ⟦ Δ ⤍ 03- ⟧ ).plus( x ↦ Φ.num( φ ↦ ⟦ Δ ⤍ 04- ⟧ ) )+  ⟧+⟧+$ phino morph --symbolic=plus.yaml --deep --locator=Q.l🌵 --jobs=2 \+    --protocol=sums.txt --sweet --hide-rho sums.phi+⟦ a ↦ ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_plus:λ ⟧, b ↦ ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_plus:λ ⟧ ⟧+$ cat sums.txt+𝕄(Φ.l🌵)+  𝔼(L_plus)  # 𝕄(Φ.l🌵.a)+    formation(⟦ φ ↦ 01-:Δ, plus(x) ↦ L_plus:λ ⟧)  # 𝔻(Φ.a🌵1-0)+    𝛿1.1 := 01-  # 𝔻(ξ.ρ)+    formation(⟦ φ ↦ 02-:Δ, plus(x) ↦ L_plus:λ ⟧)  # 𝔻(Φ.a🌵1-1)+    𝛿2.1 := 02-  # 𝔻(ξ.x)+    𝑛.1.1 := Φ.num( φ ↦ 𝜎1:λ )  # 𝑛+    𝑛.1.2 := ⟦ φ ↦ 𝜎1:λ, plus(x) ↦ L_plus:λ ⟧  # 𝕄(𝑛.1.1)+  𝔼(L_plus)  # 𝕄(Φ.l🌵.b)+    formation(⟦ φ ↦ 03-:Δ, plus(x) ↦ L_plus:λ ⟧)  # 𝔻(Φ.a🌵2-0)+    𝛿1.2 := 03-  # 𝔻(ξ.ρ)+    formation(⟦ φ ↦ 04-:Δ, plus(x) ↦ L_plus:λ ⟧)  # 𝔻(Φ.a🌵2-1)+    𝛿2.2 := 04-  # 𝔻(ξ.x)+    𝑛.2.1 := Φ.num( φ ↦ 𝜎2:λ )  # 𝑛+    𝑛.2.2 := ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_plus:λ ⟧  # 𝕄(𝑛.2.1)+```++A fresh name a binding mints carries its place in the formation, `a🌵2-0` for+the second one, so no two bindings ever mint the same name. The workers split+the time, not the work: the slowest binding still takes as long as it did,+and the others no longer wait behind it. Without `--jobs`, or with+`--jobs=1`, the walk is the one described above, sharing one memo and one+tally across all bindings.+ ## Rewrite  You can rewrite this expression with the help of [rules](#rule-structure)@@ -1573,6 +1650,54 @@ d >> 68-65-6C-6C-6F ``` +## Compile++By default, `phino` reads its rules from YAML and interprets them at every+step. The `compile` command turns the rules into Haskell instead. Then a+second build of `phino` runs them as plain functions:++```bash+phino compile+cabal build all+```++The command writes the module `compiled/generated/Compiled.hs`, which git+ignores. It compiles the built-in rules of normalization, the+contextualization function 𝒞, and every file you pass with `--rule`. The+`--target` option writes the module somewhere else.++A build links the module in only when the Cabal flag `compiled` is on. If+there is no `cabal.project.local`, `compile` creates one that turns the flag+on. If the file already exists, `compile` leaves it alone and prints the two+lines to add to it:++```text+package phino+  flags: +compiled+```++The compiled rules take exactly the same steps as the YAML ones, so the+output and every `--sequence` stay the same. A few things are still read from+YAML at runtime:++* the rules of morphing (𝕄) and dataization (𝔻);+* a `--rule` file that changed after `compile`;+* the pattern of `match` and the `rewrite:` blocks of the `--symbolic` file.++The `explain` command also reads the rules from YAML.++`compile` refuses a rule it cannot turn into Haskell and names the reason.+For example, it refuses a rule with `having`, a `where` function other than+`contextualize` or `named`, or the conditions `matches` and `part-of`.++A binary built this way refuses to run if the built-in rules changed after+the last `compile`, since it would run rules nobody wrote. Run `compile`+again and rebuild. To test the whole suite against the compiled rules, run:++```bash+make compiled+```+ ## Explain  You can _explain_ the built-in rules by printing them in [LaTeX][latex]@@ -1860,119 +1985,119 @@ === parse/phi ===   warmup:     3 iterations   batches:    10 x 1-  total:      1235604.619 μs-  avg:        123560.462 μs-  min:        112999.536 μs-  max:        146848.289 μs-  std dev:    13523.687 μs+  total:      1094396.788 μs+  avg:        109439.679 μs+  min:        101010.304 μs+  max:        128313.535 μs+  std dev:    10811.808 μs === parse/xmir ===   warmup:     3 iterations   batches:    10 x 1-  total:      6181027.602 μs-  avg:        618102.760 μs-  min:        562545.414 μs-  max:        682531.677 μs-  std dev:    33378.489 μs+  total:      5710303.145 μs+  avg:        571030.314 μs+  min:        504770.068 μs+  max:        662347.068 μs+  std dev:    46900.536 μs === rewrite/normalize ===   warmup:     3 iterations   batches:    10 x 1-  total:      14.492 μs-  avg:        1.449 μs-  min:        1.221 μs-  max:        1.863 μs-  std dev:    0.164 μs+  total:      11.392 μs+  avg:        1.139 μs+  min:        0.970 μs+  max:        1.628 μs+  std dev:    0.177 μs === print/sweet/multiline ===   warmup:     3 iterations   batches:    10 x 1-  total:      3687452.277 μs-  avg:        368745.228 μs-  min:        340283.380 μs-  max:        395918.805 μs-  std dev:    19962.268 μs+  total:      2401437.519 μs+  avg:        240143.752 μs+  min:        213136.984 μs+  max:        272722.750 μs+  std dev:    16775.737 μs === print/sweet/flat ===   warmup:     3 iterations   batches:    10 x 1-  total:      3607637.694 μs-  avg:        360763.769 μs-  min:        340150.409 μs-  max:        401378.260 μs-  std dev:    20648.726 μs+  total:      2416626.820 μs+  avg:        241662.682 μs+  min:        233315.703 μs+  max:        254494.103 μs+  std dev:    5589.090 μs === print/salty/multiline ===   warmup:     3 iterations   batches:    10 x 1-  total:      10349170.023 μs-  avg:        1034917.002 μs-  min:        1011977.349 μs-  max:        1103222.564 μs-  std dev:    28732.304 μs+  total:      7328848.511 μs+  avg:        732884.851 μs+  min:        692672.535 μs+  max:        772742.324 μs+  std dev:    23401.078 μs === morph/symbolic/demo/e1 ===   warmup:     3 iterations   batches:    10 x 3-  total:      129778.599 μs-  avg:        4325.953 μs-  min:        4287.416 μs-  max:        4382.296 μs-  std dev:    30.864 μs+  total:      128456.280 μs+  avg:        4281.876 μs+  min:        4253.475 μs+  max:        4312.886 μs+  std dev:    20.874 μs === morph/symbolic/demo/e2 ===   warmup:     3 iterations   batches:    10 x 5-  total:      201800.582 μs-  avg:        4036.012 μs-  min:        3982.252 μs-  max:        4124.524 μs-  std dev:    43.136 μs+  total:      198825.013 μs+  avg:        3976.500 μs+  min:        3937.010 μs+  max:        4123.529 μs+  std dev:    54.483 μs === morph/symbolic/demo/e3 ===   warmup:     3 iterations   batches:    10 x 3-  total:      174129.187 μs-  avg:        5804.306 μs-  min:        5765.516 μs-  max:        5875.392 μs-  std dev:    31.510 μs+  total:      171306.263 μs+  avg:        5710.209 μs+  min:        5671.534 μs+  max:        5828.818 μs+  std dev:    45.464 μs === morph/symbolic/demo/e4 ===   warmup:     3 iterations-  batches:    10 x 5-  total:      195942.319 μs-  avg:        3918.846 μs-  min:        3416.828 μs-  max:        7676.874 μs-  std dev:    1255.938 μs+  batches:    10 x 6+  total:      214186.131 μs+  avg:        3569.769 μs+  min:        3556.854 μs+  max:        3596.001 μs+  std dev:    11.389 μs === morph/symbolic/demo/e5 ===   warmup:     3 iterations   batches:    10 x 15-  total:      184899.602 μs-  avg:        1232.664 μs-  min:        1224.459 μs-  max:        1242.434 μs-  std dev:    5.749 μs+  total:      190902.360 μs+  avg:        1272.682 μs+  min:        1266.976 μs+  max:        1276.589 μs+  std dev:    3.073 μs === morph/symbolic/native/e5 ===   warmup:     3 iterations   batches:    10 x 1-  total:      192336.003 μs-  avg:        19233.600 μs-  min:        18688.555 μs-  max:        19909.284 μs-  std dev:    427.461 μs+  total:      130864.617 μs+  avg:        13086.462 μs+  min:        12534.939 μs+  max:        13730.337 μs+  std dev:    404.303 μs === morph/symbolic/accum/0 ===   warmup:     3 iterations-  batches:    10 x 2-  total:      211409.497 μs-  avg:        10570.475 μs-  min:        10490.484 μs-  max:        10743.310 μs-  std dev:    66.154 μs+  batches:    10 x 3+  total:      217771.785 μs+  avg:        7259.060 μs+  min:        7183.014 μs+  max:        7458.925 μs+  std dev:    90.688 μs === morph/symbolic/accum/400 ===   warmup:     3 iterations   batches:    10 x 1-  total:      361054.043 μs-  avg:        36105.404 μs-  min:        35194.312 μs-  max:        41143.240 μs-  std dev:    1694.561 μs+  total:      210258.554 μs+  avg:        21025.855 μs+  min:        20666.196 μs+  max:        23018.525 μs+  std dev:    672.165 μs ```  The results were calculated in [this GHA job][benchmark-gha]-on 2026-09-27 at 05:24,+on 2026-09-29 at 12:02, on Linux with 4 CPUs.  <!-- benchmark_end -->@@ -2022,4 +2147,4 @@ [jna-native]: https://github.com/java-native-access/jna/blob/master/src/com/sun/jna/Native.java [jeo]: https://github.com/objectionary/jeo-maven-plugin [issue-1291]: https://github.com/objectionary/phino/issues/1291-[benchmark-gha]: https://github.com/objectionary/phino/actions/runs/36296915429+[benchmark-gha]: https://github.com/objectionary/phino/actions/runs/36565203496

@@ -5,16 +5,18 @@  import AST (Attribute (AtLabel), Binding (BiTau), Expression (ExFormation, ExRoot), hashExpression) import CLI.Helpers (started)+import Compiled (compiled) import Control.Exception (evaluate) import Control.Monad (replicateM, replicateM_) import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe) import Data.String (fromString) import Data.Time.Clock import Dataize (reduction) import Deps (Acyclic (Plausible, Proven), Judgment (Morphing), dontSaveEval, dontSaveStep) import Encoding (Encoding (UNICODE))+import Engine (Engine (_normal), building, stepOf, yaml) import Evaluate (evaluation, fired)-import Functions (buildTerm) import Lambdas (Lambdas, readLambdas) import Lining (LineFormat (MULTILINE, SINGLELINE)) import Margin (defaultMargin)@@ -61,7 +63,8 @@     100     False     Nothing-    buildTerm+    (building linked)+    (_normal linked)     MtDisabled     Nothing     dontSaveStep@@ -85,24 +88,33 @@     25 -- _maxCycles     (Steps 1000 0) -- _steps     Nothing -- _tally+    Nothing -- _deadline     memo -- _memo     1 -- _nesting     False -- _depthSensitive     False -- _shuffle     True -- _partial     True -- _deep+    1 -- _jobs     (Just acyclic) -- _acyclic     Morphing -- _judgment     [] -- _parked     Map.empty -- _entered     lambdas -- _symbolic-    buildTerm -- _buildTerm+    (building linked) -- _buildTerm     reduction -- _reduce     evaluation -- _evaluate     fired -- _fire     dontSaveStep -- _saveStep     dontSaveEval -- _saveEval+    linked -- _engine +-- The engine the rules run on: the one 'phino compile' wrote, where the build+-- links it in, and the one interpreting the rules of YAML otherwise, so the+-- same suite times either (#1617).+linked :: Engine+linked = fromMaybe yaml compiled+ timeAction :: IO a -> IO Double timeAction action = do   start <- getCurrentTime@@ -158,7 +170,7 @@   counters <- readLambdas "benchmark/accum.yaml"   runBench "parse/phi" (parseExpressionThrows src)   runBench "parse/xmir" (parseXMIRThrows xsrc >>= xmirToPhi)-  runBench "rewrite/normalize" (rewrite expr normalizationRules rewriteCtx)+  runBench "rewrite/normalize" (rewrite expr (map (stepOf linked) normalizationRules) rewriteCtx)   runBench     "print/sweet/multiline"     (evaluate (length (printExpression' expr (SWEET, UNICODE, MULTILINE, defaultMargin))))

@@ -0,0 +1,514 @@+-- The built-in rules of phino, and the rules of '--rule' it was given, as+-- Haskell: this module is written by 'phino compile' and a build with the+-- flag 'compiled' links it in (#1617). The next 'phino compile' writes it+-- anew, so a change belongs to the rules of YAML and not to it.+module Compiled (compiled) where++import AST+import qualified Builder as B+import qualified Contextualize as C+import qualified Deps as D+import qualified Control.Exception as E+import qualified Engine as En+import qualified Inference as In+import qualified Matcher as M+import qualified Data.Map.Strict as Map+import qualified Rewriter as R+import qualified Rule as Ru++compiled :: Maybe En.Engine+compiled =+  Just+    En.Engine+      { En._normalization = normalization+      , En._rules = steps+      , En._normal = nf+      , En._contextualize = \term context -> either E.throwIO pure (contextualize term context)+      , En._morphing = morphings+      , En._dataization = dataizations+      , En._sources = sources+      }++-- The steps of the built-in rules of normalization, in the order of the rules.+normalization :: [Ru.Step]+normalization = [stepAlpha, stepAmiss, stepCopy, stepDc, stepDca, stepDd, stepDl, stepDot, stepMiss, stepNull, stepOver, stepOvera, stepSkip, stepStay, stepStop]++-- The steps of every rule compiled, by the text of the rule.+steps :: Map.Map String Ru.Step+steps =+  Map.fromList [("Rule {name = \"alpha\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\",BiVoid !t1,BiMeta \"B2\"]) (ArAlpha \945!i1 (ExMeta \"e1\")), result = ExApplication (ExFormation [BiMeta \"B1\",BiVoid !t1,BiMeta \"B2\"]) (ArTau !t1 (ExMeta \"e1\")), when = Just (And [Eq (CmpNum (MetaIndex \"i1\")) (CmpNum (Domain (BiMeta \"B1\"))),Not (Eq (CmpAttr !t1) (CmpAttr \961))]), where_ = Nothing, having = Nothing}", stepAlpha), ("Rule {name = \"amiss\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\"]) (ArAlpha \945!i1 (ExAny (Slot \"e\" 11))), result = ExTermination, when = Just (Not (Gt (CmpNum (Domain (BiMeta \"B1\"))) (CmpNum (MetaIndex \"i1\")))), where_ = Nothing, having = Nothing}", stepAmiss), ("Rule {name = \"copy\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\",BiVoid !t1,BiMeta \"B2\"]) (ArTau !t1 (ExMeta \"k1\")), result = ExFormation [BiMeta \"B1\",BiTau !t1 (ExMeta \"k1\"),BiMeta \"B2\"], when = Nothing, where_ = Nothing, having = Nothing}", stepCopy), ("Rule {name = \"dc\", label = Nothing, description = Nothing, pattern = ExApplication ExTermination (ArTau !t (ExAny (Slot \"e\" 6))), result = ExTermination, when = Nothing, where_ = Nothing, having = Nothing}", stepDc), ("Rule {name = \"dca\", label = Nothing, description = Nothing, pattern = ExApplication ExTermination (ArAlpha \945!i (ExAny (Slot \"e\" 7))), result = ExTermination, when = Nothing, where_ = Nothing, having = Nothing}", stepDca), ("Rule {name = \"dd\", label = Nothing, description = Nothing, pattern = ExDispatch ExTermination !t, result = ExTermination, when = Nothing, where_ = Nothing, having = Nothing}", stepDd), ("Rule {name = \"dl\", label = Nothing, description = Nothing, pattern = ExFormation [BiMeta \"B1\",BiLambda (FnAny (Slot \"F\" 9)),BiMeta \"B2\"], result = ExTermination, when = Just (In [\916] [BiMeta \"B1\",BiMeta \"B2\"]), where_ = Nothing, having = Nothing}", stepDl), ("Rule {name = \"dot\", label = Nothing, description = Nothing, pattern = ExDispatch (ExFormation [BiMeta \"B1\",BiTau !t1 (ExMeta \"n1\"),BiMeta \"B2\"]) !t1, result = ExApplication (ExMeta \"e1\") (ArTau \961 (ExMeta \"e2\")), when = Just (Not (In [\916,\955] [BiMeta \"B1\",BiMeta \"B2\"])), where_ = Just [Extra {meta = ArgExpression (ExMeta \"e1\"), function = \"contextualize\", args = [ArgExpression (ExMeta \"n1\"),ArgExpression (ExFormation [BiMeta \"B1\",BiMeta \"B2\"])]},Extra {meta = ArgExpression (ExMeta \"e2\"), function = \"named\", args = [ArgExpression (ExFormation [BiMeta \"B1\",BiTau !t1 (ExMeta \"n1\"),BiMeta \"B2\"])]}], having = Nothing}", stepDot), ("Rule {name = \"miss\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\"]) (ArTau !t1 (ExAny (Slot \"e\" 10))), result = ExTermination, when = Just (And [Not (In [!t1] [BiMeta \"B1\"]),Not (Eq (CmpAttr !t1) (CmpAttr \961))]), where_ = Nothing, having = Nothing}", stepMiss), ("Rule {name = \"null\", label = Nothing, description = Nothing, pattern = ExDispatch (ExFormation [BiMeta \"B1\",BiVoid !t1,BiMeta \"B2\"]) !t1, result = ExTermination, when = Nothing, where_ = Nothing, having = Nothing}", stepNull), ("Rule {name = \"over\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\",BiTau !t1 (ExMeta \"e1\"),BiMeta \"B2\"]) (ArTau !t1 (ExMeta \"e2\")), result = ExTermination, when = Just (Not (Eq (CmpAttr !t1) (CmpAttr \961))), where_ = Nothing, having = Nothing}", stepOver), ("Rule {name = \"overa\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\",BiTau !t1 (ExMeta \"e1\"),BiMeta \"B2\"]) (ArAlpha \945!i1 (ExMeta \"e2\")), result = ExTermination, when = Just (And [Eq (CmpNum (MetaIndex \"i1\")) (CmpNum (Domain (BiMeta \"B1\"))),Not (Eq (CmpAttr !t1) (CmpAttr \961))]), where_ = Nothing, having = Nothing}", stepOvera), ("Rule {name = \"skip\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\"]) (ArTau \961 (ExMeta \"e1\")), result = ExFormation [BiMeta \"B1\"], when = Just (Not (In [\961] [BiMeta \"B1\"])), where_ = Nothing, having = Nothing}", stepSkip), ("Rule {name = \"stay\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\",BiTau \961 (ExMeta \"e1\"),BiMeta \"B2\"]) (ArTau \961 (ExMeta \"e2\")), result = ExFormation [BiMeta \"B1\",BiTau \961 (ExMeta \"e1\"),BiMeta \"B2\"], when = Nothing, where_ = Nothing, having = Nothing}", stepStay), ("Rule {name = \"stop\", label = Nothing, description = Nothing, pattern = ExDispatch (ExFormation [BiMeta \"B1\"]) !t1, result = ExTermination, when = Just (Disjoint [!t1,\966,\955] [BiMeta \"B1\"]), where_ = Nothing, having = Nothing}", stepStop)]++-- The rules of 𝕄, in the order of their files.+morphings :: [In.Inference Expression]+morphings = [In.direct morphingDead, In.direct morphingMa, In.direct morphingMaa, In.direct morphingMaad, In.direct morphingMad, In.direct morphingMd, In.direct morphingMf, In.direct morphingMg, In.direct morphingMl, In.direct morphingMphi, In.direct morphingUniverse, In.direct morphingXi]++-- The rules of 𝔻, in the order of their files.+dataizations :: [In.Inference Bytes]+dataizations = [In.direct dataizationBox, In.direct dataizationDelta, In.direct dataizationFire, In.direct dataizationNone, In.direct dataizationNorm]++-- The texts of the built-in rules of all four judgments this module is made of.+sources :: [String]+sources = ["Rule {name = \"alpha\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\",BiVoid !t1,BiMeta \"B2\"]) (ArAlpha \945!i1 (ExMeta \"e1\")), result = ExApplication (ExFormation [BiMeta \"B1\",BiVoid !t1,BiMeta \"B2\"]) (ArTau !t1 (ExMeta \"e1\")), when = Just (And [Eq (CmpNum (MetaIndex \"i1\")) (CmpNum (Domain (BiMeta \"B1\"))),Not (Eq (CmpAttr !t1) (CmpAttr \961))]), where_ = Nothing, having = Nothing}", "Rule {name = \"amiss\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\"]) (ArAlpha \945!i1 (ExAny (Slot \"e\" 11))), result = ExTermination, when = Just (Not (Gt (CmpNum (Domain (BiMeta \"B1\"))) (CmpNum (MetaIndex \"i1\")))), where_ = Nothing, having = Nothing}", "Rule {name = \"copy\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\",BiVoid !t1,BiMeta \"B2\"]) (ArTau !t1 (ExMeta \"k1\")), result = ExFormation [BiMeta \"B1\",BiTau !t1 (ExMeta \"k1\"),BiMeta \"B2\"], when = Nothing, where_ = Nothing, having = Nothing}", "Rule {name = \"dc\", label = Nothing, description = Nothing, pattern = ExApplication ExTermination (ArTau !t (ExAny (Slot \"e\" 6))), result = ExTermination, when = Nothing, where_ = Nothing, having = Nothing}", "Rule {name = \"dca\", label = Nothing, description = Nothing, pattern = ExApplication ExTermination (ArAlpha \945!i (ExAny (Slot \"e\" 7))), result = ExTermination, when = Nothing, where_ = Nothing, having = Nothing}", "Rule {name = \"dd\", label = Nothing, description = Nothing, pattern = ExDispatch ExTermination !t, result = ExTermination, when = Nothing, where_ = Nothing, having = Nothing}", "Rule {name = \"dl\", label = Nothing, description = Nothing, pattern = ExFormation [BiMeta \"B1\",BiLambda (FnAny (Slot \"F\" 9)),BiMeta \"B2\"], result = ExTermination, when = Just (In [\916] [BiMeta \"B1\",BiMeta \"B2\"]), where_ = Nothing, having = Nothing}", "Rule {name = \"dot\", label = Nothing, description = Nothing, pattern = ExDispatch (ExFormation [BiMeta \"B1\",BiTau !t1 (ExMeta \"n1\"),BiMeta \"B2\"]) !t1, result = ExApplication (ExMeta \"e1\") (ArTau \961 (ExMeta \"e2\")), when = Just (Not (In [\916,\955] [BiMeta \"B1\",BiMeta \"B2\"])), where_ = Just [Extra {meta = ArgExpression (ExMeta \"e1\"), function = \"contextualize\", args = [ArgExpression (ExMeta \"n1\"),ArgExpression (ExFormation [BiMeta \"B1\",BiMeta \"B2\"])]},Extra {meta = ArgExpression (ExMeta \"e2\"), function = \"named\", args = [ArgExpression (ExFormation [BiMeta \"B1\",BiTau !t1 (ExMeta \"n1\"),BiMeta \"B2\"])]}], having = Nothing}", "Rule {name = \"miss\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\"]) (ArTau !t1 (ExAny (Slot \"e\" 10))), result = ExTermination, when = Just (And [Not (In [!t1] [BiMeta \"B1\"]),Not (Eq (CmpAttr !t1) (CmpAttr \961))]), where_ = Nothing, having = Nothing}", "Rule {name = \"null\", label = Nothing, description = Nothing, pattern = ExDispatch (ExFormation [BiMeta \"B1\",BiVoid !t1,BiMeta \"B2\"]) !t1, result = ExTermination, when = Nothing, where_ = Nothing, having = Nothing}", "Rule {name = \"over\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\",BiTau !t1 (ExMeta \"e1\"),BiMeta \"B2\"]) (ArTau !t1 (ExMeta \"e2\")), result = ExTermination, when = Just (Not (Eq (CmpAttr !t1) (CmpAttr \961))), where_ = Nothing, having = Nothing}", "Rule {name = \"overa\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\",BiTau !t1 (ExMeta \"e1\"),BiMeta \"B2\"]) (ArAlpha \945!i1 (ExMeta \"e2\")), result = ExTermination, when = Just (And [Eq (CmpNum (MetaIndex \"i1\")) (CmpNum (Domain (BiMeta \"B1\"))),Not (Eq (CmpAttr !t1) (CmpAttr \961))]), where_ = Nothing, having = Nothing}", "Rule {name = \"skip\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\"]) (ArTau \961 (ExMeta \"e1\")), result = ExFormation [BiMeta \"B1\"], when = Just (Not (In [\961] [BiMeta \"B1\"])), where_ = Nothing, having = Nothing}", "Rule {name = \"stay\", label = Nothing, description = Nothing, pattern = ExApplication (ExFormation [BiMeta \"B1\",BiTau \961 (ExMeta \"e1\"),BiMeta \"B2\"]) (ArTau \961 (ExMeta \"e2\")), result = ExFormation [BiMeta \"B1\",BiTau \961 (ExMeta \"e1\"),BiMeta \"B2\"], when = Nothing, where_ = Nothing, having = Nothing}", "Rule {name = \"stop\", label = Nothing, description = Nothing, pattern = ExDispatch (ExFormation [BiMeta \"B1\"]) !t1, result = ExTermination, when = Just (Disjoint [!t1,\966,\955] [BiMeta \"B1\"]), where_ = Nothing, having = Nothing}", "ContextualizeRule {name = \"ca\", label = Nothing, match = ExApplication (ExMeta \"n1\") (ArTau !t1 (ExMeta \"e1\")), cmatch = ExMeta \"k1\", cresult = ExApplication (ExMeta \"n2\") (ArTau !t1 (ExMeta \"n3\")), premises = [Premise {result = \"n2\", operation = OpContextualize (ExMeta \"n1\") (ExMeta \"k1\")},Premise {result = \"n3\", operation = OpContextualize (ExMeta \"e1\") (ExMeta \"k1\")}]}", "ContextualizeRule {name = \"caa\", label = Nothing, match = ExApplication (ExMeta \"n1\") (ArAlpha \945!i1 (ExMeta \"e1\")), cmatch = ExMeta \"k1\", cresult = ExApplication (ExMeta \"n2\") (ArAlpha \945!i1 (ExMeta \"n3\")), premises = [Premise {result = \"n2\", operation = OpContextualize (ExMeta \"n1\") (ExMeta \"k1\")},Premise {result = \"n3\", operation = OpContextualize (ExMeta \"e1\") (ExMeta \"k1\")}]}", "ContextualizeRule {name = \"cd\", label = Nothing, match = ExDispatch (ExMeta \"n1\") !t1, cmatch = ExMeta \"k1\", cresult = ExDispatch (ExMeta \"n2\") !t1, premises = [Premise {result = \"n2\", operation = OpContextualize (ExMeta \"n1\") (ExMeta \"k1\")}]}", "ContextualizeRule {name = \"cf\", label = Nothing, match = ExFormation [BiMeta \"B1\"], cmatch = ExMeta \"k1\", cresult = ExFormation [BiMeta \"B1\"], premises = []}", "ContextualizeRule {name = \"cg\", label = Nothing, match = ExRoot, cmatch = ExMeta \"k1\", cresult = ExRoot, premises = []}", "ContextualizeRule {name = \"ct\", label = Nothing, match = ExTermination, cmatch = ExMeta \"k1\", cresult = ExTermination, premises = []}", "ContextualizeRule {name = \"cxi\", label = Nothing, match = ExXi, cmatch = ExMeta \"k1\", cresult = ExMeta \"k1\", premises = []}", "MorphRule {name = \"dead\", label = Nothing, match = ExTermination, ematch = ExMeta \"e1\", nresult = ExTermination, when = Nothing, premises = []}", "MorphRule {name = \"ma\", label = Nothing, match = ExApplication (ExMeta \"n1\") (ArTau !t1 (ExMeta \"k1\")), ematch = ExMeta \"e1\", nresult = ExMeta \"n4\", when = Nothing, premises = [Premise {result = \"n2\", operation = OpMorph (ExMeta \"n1\") (ExMeta \"e1\")},Premise {result = \"n3\", operation = OpNormalize (ExApplication (ExMeta \"n2\") (ArTau !t1 (ExMeta \"k1\")))},Premise {result = \"n4\", operation = OpMorph (ExMeta \"n3\") (ExMeta \"e1\")}]}", "MorphRule {name = \"maa\", label = Nothing, match = ExApplication (ExMeta \"n1\") (ArAlpha \945!i1 (ExMeta \"k1\")), ematch = ExMeta \"e1\", nresult = ExMeta \"n4\", when = Nothing, premises = [Premise {result = \"n2\", operation = OpMorph (ExMeta \"n1\") (ExMeta \"e1\")},Premise {result = \"n3\", operation = OpNormalize (ExApplication (ExMeta \"n2\") (ArAlpha \945!i1 (ExMeta \"k1\")))},Premise {result = \"n4\", operation = OpMorph (ExMeta \"n3\") (ExMeta \"e1\")}]}", "MorphRule {name = \"maad\", label = Nothing, match = ExApplication (ExAny (Slot \"n\" 0)) (ArAlpha \945!i (ExMeta \"n1\")), ematch = ExMeta \"e1\", nresult = ExMeta \"n2\", when = Just (Not (Absolute (ExMeta \"n1\"))), premises = [Premise {result = \"n2\", operation = OpMorph ExTermination (ExMeta \"e1\")}]}", "MorphRule {name = \"mad\", label = Nothing, match = ExApplication (ExAny (Slot \"n\" 0)) (ArTau !t (ExMeta \"n1\")), ematch = ExMeta \"e1\", nresult = ExMeta \"n2\", when = Just (Not (Absolute (ExMeta \"n1\"))), premises = [Premise {result = \"n2\", operation = OpMorph ExTermination (ExMeta \"e1\")}]}", "MorphRule {name = \"md\", label = Nothing, match = ExDispatch (ExMeta \"n1\") !t1, ematch = ExMeta \"e1\", nresult = ExMeta \"n4\", when = Just (Not (IsFormation (ExMeta \"n1\"))), premises = [Premise {result = \"n2\", operation = OpMorph (ExMeta \"n1\") (ExMeta \"e1\")},Premise {result = \"n3\", operation = OpNormalize (ExDispatch (ExMeta \"n2\") !t1)},Premise {result = \"n4\", operation = OpMorph (ExMeta \"n3\") (ExMeta \"e1\")}]}", "MorphRule {name = \"mf\", label = Nothing, match = ExFormation [BiMeta \"B1\"], ematch = ExMeta \"e1\", nresult = ExFormation [BiMeta \"B1\"], when = Nothing, premises = []}", "MorphRule {name = \"mg\", label = Nothing, match = ExRoot, ematch = ExRoot, nresult = ExMeta \"n1\", when = Nothing, premises = [Premise {result = \"n1\", operation = OpMorph ExTermination ExRoot}]}", "MorphRule {name = \"ml\", label = Just \"\\\\lambda\", match = ExDispatch (ExFormation [BiMeta \"B1\",BiLambda (FnMeta \"F1\"),BiMeta \"B2\"]) !t1, ematch = ExMeta \"e1\", nresult = ExMeta \"n3\", when = Nothing, premises = [Premise {result = \"n1\", operation = OpEvaluate (ExFormation [BiMeta \"B1\",BiLambda (FnMeta \"F1\"),BiMeta \"B2\"]) (ExMeta \"e1\")},Premise {result = \"n2\", operation = OpNormalize (ExDispatch (ExMeta \"n1\") !t1)},Premise {result = \"n3\", operation = OpMorph (ExMeta \"n2\") (ExMeta \"e1\")}]}", "MorphRule {name = \"mphi\", label = Just \"\\\\varphi\", match = ExDispatch (ExFormation [BiMeta \"B1\"]) !t1, ematch = ExMeta \"e1\", nresult = ExMeta \"n2\", when = Just (And [In [\966] [BiMeta \"B1\"],Disjoint [!t1,\955] [BiMeta \"B1\"]]), premises = [Premise {result = \"n1\", operation = OpNormalize (ExDispatch (ExDispatch (ExFormation [BiMeta \"B1\"]) \966) !t1)},Premise {result = \"n2\", operation = OpMorph (ExMeta \"n1\") (ExMeta \"e1\")}]}", "MorphRule {name = \"universe\", label = Just \"\\\\Phi\", match = ExRoot, ematch = ExMeta \"e1\", nresult = ExMeta \"n2\", when = Just (Not (Eq (CmpExpr (ExMeta \"e1\")) (CmpExpr ExRoot))), premises = [Premise {result = \"n1\", operation = OpNormalize (ExMeta \"e1\")},Premise {result = \"n2\", operation = OpMorph (ExMeta \"n1\") (ExMeta \"e1\")}]}", "MorphRule {name = \"xi\", label = Nothing, match = ExXi, ematch = ExMeta \"e1\", nresult = ExMeta \"n1\", when = Nothing, premises = [Premise {result = \"n1\", operation = OpMorph ExTermination (ExMeta \"e1\")}]}", "DataizeRule {name = \"box\", label = Nothing, match = ExFormation [BiMeta \"B1\",BiTau \966 (ExMeta \"e2\"),BiMeta \"B2\"], ematch = ExMeta \"e1\", dresult = BtMeta \"d1\", when = Just (Disjoint [\916,\955] [BiMeta \"B1\",BiMeta \"B2\"]), premises = [Premise {result = \"e3\", operation = OpContextualize (ExMeta \"e2\") (ExFormation [BiMeta \"B1\",BiTau \966 (ExMeta \"e2\"),BiMeta \"B2\"])},Premise {result = \"n1\", operation = OpNormalize (ExMeta \"e3\")},Premise {result = \"d1\", operation = OpDataize (ExMeta \"n1\") (ExMeta \"e1\")}]}", "DataizeRule {name = \"delta\", label = Just \"\\\\Delta\", match = ExFormation [BiMeta \"B1\",BiDelta (BtMeta \"d1\"),BiMeta \"B2\"], ematch = ExMeta \"e1\", dresult = BtMeta \"d1\", when = Nothing, premises = []}", "DataizeRule {name = \"fire\", label = Nothing, match = ExFormation [BiMeta \"B1\",BiLambda (FnMeta \"F1\"),BiMeta \"B2\"], ematch = ExMeta \"e1\", dresult = BtMeta \"d1\", when = Nothing, premises = [Premise {result = \"n1\", operation = OpEvaluate (ExFormation [BiMeta \"B1\",BiLambda (FnMeta \"F1\"),BiMeta \"B2\"]) (ExMeta \"e1\")},Premise {result = \"d1\", operation = OpDataize (ExMeta \"n1\") (ExMeta \"e1\")}]}", "DataizeRule {name = \"none\", label = Nothing, match = ExFormation [BiMeta \"B1\"], ematch = ExMeta \"e1\", dresult = BtMeta \"d1\", when = Just (Disjoint [\916,\955,\966] [BiMeta \"B1\"]), premises = [Premise {result = \"d1\", operation = OpDataize ExTermination (ExMeta \"e1\")}]}", "DataizeRule {name = \"norm\", label = Nothing, match = ExMeta \"n1\", ematch = ExMeta \"e1\", dresult = BtMeta \"d1\", when = Just (And [Not (IsFormation (ExMeta \"n1\")),Not (Eq (CmpExpr (ExMeta \"n1\")) (CmpExpr ExTermination))]), premises = [Premise {result = \"n2\", operation = OpMorph (ExMeta \"n1\") (ExMeta \"e1\")},Premise {result = \"d1\", operation = OpDataize (ExMeta \"n2\") (ExMeta \"e1\")}]}"]++-- Whether the term is a normal form: no built-in rule of normalization+-- matches anywhere inside it.+nf :: Expression -> Bool+nf =+  Ru.normalWith+    ( \term ->+        M.anywhere True (not . null . rewriteAlpha Nothing) term+          || M.anywhere True (not . null . rewriteAmiss Nothing) term+          || M.anywhere True (not . null . rewriteCopy Nothing) term+          || M.anywhere True (not . null . rewriteDc Nothing) term+          || M.anywhere True (not . null . rewriteDca Nothing) term+          || M.anywhere True (not . null . rewriteDd Nothing) term+          || M.anywhere True (not . null . rewriteDl Nothing) term+          || M.anywhere True (not . null . rewriteDot Nothing) term+          || M.anywhere True (not . null . rewriteMiss Nothing) term+          || M.anywhere True (not . null . rewriteNull Nothing) term+          || M.anywhere True (not . null . rewriteOver Nothing) term+          || M.anywhere True (not . null . rewriteOvera Nothing) term+          || M.anywhere True (not . null . rewriteSkip Nothing) term+          || M.anywhere True (not . null . rewriteStay Nothing) term+          || M.anywhere True (not . null . rewriteStop Nothing) term+    )++-- The Contextualization function 𝒞, the conclusion of the one rule matching+-- the term and the context.+contextualize :: Expression -> Expression -> Either C.ContextualizeException Expression+contextualize term context =+  C.concluded+    term+    ( concat+        [ contextualizeCa term context+        , contextualizeCaa term context+        , contextualizeCd term context+        , contextualizeCf term context+        , contextualizeCg term context+        , contextualizeCt term context+        , contextualizeCxi term context+        ]+    )++-- The rule 'alpha'.+stepAlpha :: Ru.Step+stepAlpha = R.direct "alpha" True rewriteAlpha++rewriteAlpha :: Maybe Expression -> Expression -> [Expression]+rewriteAlpha _ term =+  [ ExApplication (B.formed (concat [x5, [BiVoid x9], x8])) (ArTau x9 x3)+  | ExApplication x1 (ArAlpha x2 x3) <- [term]+  , ExFormation x4 <- [x1]+  , (x5, x6) <- M.splits x4+  , (x7 : x8) <- [x6]+  , BiVoid x9 <- [x7]+  , Alpha x10 <- [x2]+  , (x10 == (Ru.domainOf x5) && not (x9 == AtRho))+  ]++-- The rule 'amiss'.+stepAmiss :: Ru.Step+stepAmiss = R.direct "amiss" True rewriteAmiss++rewriteAmiss :: Maybe Expression -> Expression -> [Expression]+rewriteAmiss _ term =+  [ ExTermination+  | ExApplication x1 (ArAlpha x2 _) <- [term]+  , ExFormation x4 <- [x1]+  , Alpha x5 <- [x2]+  , not ((Ru.domainOf x4) > x5)+  ]++-- The rule 'copy'.+stepCopy :: Ru.Step+stepCopy = R.direct "copy" True rewriteCopy++rewriteCopy :: Maybe Expression -> Expression -> [Expression]+rewriteCopy _ term =+  [ B.formed (concat [x5, [BiTau x2 x3], x8])+  | ExApplication x1 (ArTau x2 x3) <- [term]+  , ExFormation x4 <- [x1]+  , (x5, x6) <- M.splits x4+  , (x7 : x8) <- [x6]+  , BiVoid x9 <- [x7]+  , x2 == x9+  , Ru.xiFree x3+  , Ru.normalHeld nf x3+  ]++-- The rule 'dc'.+stepDc :: Ru.Step+stepDc = R.direct "dc" True rewriteDc++rewriteDc :: Maybe Expression -> Expression -> [Expression]+rewriteDc _ term =+  [ ExTermination+  | ExApplication x1 (ArTau _ _) <- [term]+  , ExTermination <- [x1]+  ]++-- The rule 'dca'.+stepDca :: Ru.Step+stepDca = R.direct "dca" True rewriteDca++rewriteDca :: Maybe Expression -> Expression -> [Expression]+rewriteDca _ term =+  [ ExTermination+  | ExApplication x1 (ArAlpha x2 _) <- [term]+  , ExTermination <- [x1]+  , Alpha _ <- [x2]+  ]++-- The rule 'dd'.+stepDd :: Ru.Step+stepDd = R.direct "dd" True rewriteDd++rewriteDd :: Maybe Expression -> Expression -> [Expression]+rewriteDd _ term =+  [ ExTermination+  | ExDispatch x1 _ <- [term]+  , ExTermination <- [x1]+  ]++-- The rule 'dl'.+stepDl :: Ru.Step+stepDl = R.direct "dl" True rewriteDl++rewriteDl :: Maybe Expression -> Expression -> [Expression]+rewriteDl _ term =+  [ ExTermination+  | ExFormation x1 <- [term]+  , (x2, x3) <- M.splits x1+  , (x4 : x5) <- [x3]+  , BiLambda x6 <- [x4]+  , M.named x6+  , all (`Ru.presentIn` concat [x2, x5]) [AtDelta]+  ]++-- The rule 'dot'.+stepDot :: Ru.Step+stepDot = R.direct "dot" True rewriteDot++rewriteDot :: Maybe Expression -> Expression -> [Expression]+rewriteDot universe term =+  [ ExApplication e1 (ArTau AtRho e2)+  | ExDispatch x1 x2 <- [term]+  , ExFormation x3 <- [x1]+  , (x4, x5) <- M.splits x3+  , (x6 : x7) <- [x5]+  , BiTau x8 x9 <- [x6]+  , x2 == x8+  , not (all (`Ru.presentIn` concat [x4, x7]) [AtDelta, AtLambda])+  , Ru.normalHeld nf x9+  , let e1 = either E.throw id (contextualize x9 (B.formed (concat [x4, x7])))+  , let e2 = B.nameIn universe (B.formed (concat [x4, [BiTau x2 x9], x7]))+  ]++-- The rule 'miss'.+stepMiss :: Ru.Step+stepMiss = R.direct "miss" True rewriteMiss++rewriteMiss :: Maybe Expression -> Expression -> [Expression]+rewriteMiss _ term =+  [ ExTermination+  | ExApplication x1 (ArTau x2 _) <- [term]+  , ExFormation x4 <- [x1]+  , (not (all (`Ru.presentIn` concat [x4]) [x2]) && not (x2 == AtRho))+  ]++-- The rule 'null'.+stepNull :: Ru.Step+stepNull = R.direct "null" True rewriteNull++rewriteNull :: Maybe Expression -> Expression -> [Expression]+rewriteNull _ term =+  [ ExTermination+  | ExDispatch x1 x2 <- [term]+  , ExFormation x3 <- [x1]+  , (_, x5) <- M.splits x3+  , (x6 : _) <- [x5]+  , BiVoid x8 <- [x6]+  , x2 == x8+  ]++-- The rule 'over'.+stepOver :: Ru.Step+stepOver = R.direct "over" True rewriteOver++rewriteOver :: Maybe Expression -> Expression -> [Expression]+rewriteOver _ term =+  [ ExTermination+  | ExApplication x1 (ArTau x2 _) <- [term]+  , ExFormation x4 <- [x1]+  , (_, x6) <- M.splits x4+  , (x7 : _) <- [x6]+  , BiTau x9 _ <- [x7]+  , x2 == x9+  , not (x2 == AtRho)+  ]++-- The rule 'overa'.+stepOvera :: Ru.Step+stepOvera = R.direct "overa" True rewriteOvera++rewriteOvera :: Maybe Expression -> Expression -> [Expression]+rewriteOvera _ term =+  [ ExTermination+  | ExApplication x1 (ArAlpha x2 _) <- [term]+  , ExFormation x4 <- [x1]+  , (x5, x6) <- M.splits x4+  , (x7 : _) <- [x6]+  , BiTau x9 _ <- [x7]+  , Alpha x11 <- [x2]+  , (x11 == (Ru.domainOf x5) && not (x9 == AtRho))+  ]++-- The rule 'skip'.+stepSkip :: Ru.Step+stepSkip = R.direct "skip" True rewriteSkip++rewriteSkip :: Maybe Expression -> Expression -> [Expression]+rewriteSkip _ term =+  [ B.formed x4+  | ExApplication x1 (ArTau x2 _) <- [term]+  , x2 == AtRho+  , ExFormation x4 <- [x1]+  , not (all (`Ru.presentIn` concat [x4]) [AtRho])+  ]++-- The rule 'stay'.+stepStay :: Ru.Step+stepStay = R.direct "stay" True rewriteStay++rewriteStay :: Maybe Expression -> Expression -> [Expression]+rewriteStay _ term =+  [ B.formed (concat [x5, [BiTau AtRho x10], x8])+  | ExApplication x1 (ArTau x2 _) <- [term]+  , x2 == AtRho+  , ExFormation x4 <- [x1]+  , (x5, x6) <- M.splits x4+  , (x7 : x8) <- [x6]+  , BiTau x9 x10 <- [x7]+  , x9 == AtRho+  ]++-- The rule 'stop'.+stepStop :: Ru.Step+stepStop = R.direct "stop" True rewriteStop++rewriteStop :: Maybe Expression -> Expression -> [Expression]+rewriteStop _ term =+  [ ExTermination+  | ExDispatch x1 x2 <- [term]+  , ExFormation x3 <- [x1]+  , not (any (`Ru.presentIn` concat [x3]) [x2, AtPhi, AtLambda])+  ]++-- The contextualization rule 'ca'.+contextualizeCa :: Expression -> Expression -> [(String, Either C.ContextualizeException Expression)]+contextualizeCa term context =+  [ ("ca", do { n2 <- contextualize x1 context; n3 <- contextualize x3 context; pure (ExApplication n2 (ArTau x2 n3)) })+  | ExApplication x1 (ArTau x2 x3) <- [term]+  ]++-- The contextualization rule 'caa'.+contextualizeCaa :: Expression -> Expression -> [(String, Either C.ContextualizeException Expression)]+contextualizeCaa term context =+  [ ("caa", do { n2 <- contextualize x1 context; n3 <- contextualize x3 context; pure (ExApplication n2 (ArAlpha (Alpha x4) n3)) })+  | ExApplication x1 (ArAlpha x2 x3) <- [term]+  , Alpha x4 <- [x2]+  ]++-- The contextualization rule 'cd'.+contextualizeCd :: Expression -> Expression -> [(String, Either C.ContextualizeException Expression)]+contextualizeCd term context =+  [ ("cd", do { n2 <- contextualize x1 context; pure (ExDispatch n2 x2) })+  | ExDispatch x1 x2 <- [term]+  ]++-- The contextualization rule 'cf'.+contextualizeCf :: Expression -> Expression -> [(String, Either C.ContextualizeException Expression)]+contextualizeCf term _ =+  [ ("cf", Right (B.formed x1))+  | ExFormation x1 <- [term]+  ]++-- The contextualization rule 'cg'.+contextualizeCg :: Expression -> Expression -> [(String, Either C.ContextualizeException Expression)]+contextualizeCg term _ =+  [ ("cg", Right ExRoot)+  | ExRoot <- [term]+  ]++-- The contextualization rule 'ct'.+contextualizeCt :: Expression -> Expression -> [(String, Either C.ContextualizeException Expression)]+contextualizeCt term _ =+  [ ("ct", Right ExTermination)+  | ExTermination <- [term]+  ]++-- The contextualization rule 'cxi'.+contextualizeCxi :: Expression -> Expression -> [(String, Either C.ContextualizeException Expression)]+contextualizeCxi term context =+  [ ("cxi", Right context)+  | ExXi <- [term]+  ]++-- The morphing rule 'dead'.+morphingDead :: Expression -> Expression -> [In.Premises Expression]+morphingDead term _ =+  [ In.Concludes (In.Answered (D.Morphing, "dead") ExTermination)+  | ExTermination <- [term]+  ]++-- The morphing rule 'ma'.+morphingMa :: Expression -> Expression -> [In.Premises Expression]+morphingMa term universe =+  [ In.Morphs x1 universe (\n2 -> pure (In.Concludes (In.Onward (In.Normalized (D.Morphing, "ma")) (ExApplication n2 (ArTau x2 x3)) universe)))+  | ExApplication x1 (ArTau x2 x3) <- [term]+  , Ru.xiFree x3+  , Ru.normalHeld nf x1+  , Ru.normalHeld nf x3+  ]++-- The morphing rule 'maa'.+morphingMaa :: Expression -> Expression -> [In.Premises Expression]+morphingMaa term universe =+  [ In.Morphs x1 universe (\n2 -> pure (In.Concludes (In.Onward (In.Normalized (D.Morphing, "maa")) (ExApplication n2 (ArAlpha (Alpha x4) x3)) universe)))+  | ExApplication x1 (ArAlpha x2 x3) <- [term]+  , Alpha x4 <- [x2]+  , Ru.xiFree x3+  , Ru.normalHeld nf x1+  , Ru.normalHeld nf x3+  ]++-- The morphing rule 'maad'.+morphingMaad :: Expression -> Expression -> [In.Premises Expression]+morphingMaad term universe =+  [ In.Concludes (In.Onward (In.Taken (D.Morphing, "maad")) ExTermination universe)+  | ExApplication x1 (ArAlpha x2 x3) <- [term]+  , Alpha _ <- [x2]+  , not (Ru.xiFree x3)+  , Ru.normalHeld nf x1+  , Ru.normalHeld nf x3+  ]++-- The morphing rule 'mad'.+morphingMad :: Expression -> Expression -> [In.Premises Expression]+morphingMad term universe =+  [ In.Concludes (In.Onward (In.Taken (D.Morphing, "mad")) ExTermination universe)+  | ExApplication x1 (ArTau _ x3) <- [term]+  , not (Ru.xiFree x3)+  , Ru.normalHeld nf x1+  , Ru.normalHeld nf x3+  ]++-- The morphing rule 'md'.+morphingMd :: Expression -> Expression -> [In.Premises Expression]+morphingMd term universe =+  [ In.Morphs x1 universe (\n2 -> pure (In.Concludes (In.Onward (In.Normalized (D.Morphing, "md")) (ExDispatch n2 x2) universe)))+  | ExDispatch x1 x2 <- [term]+  , not (Ru.isFormation x1)+  , Ru.normalHeld nf x1+  ]++-- The morphing rule 'mf'.+morphingMf :: Expression -> Expression -> [In.Premises Expression]+morphingMf term _ =+  [ In.Concludes (In.Answered (D.Morphing, "mf") (B.formed x1))+  | ExFormation x1 <- [term]+  ]++-- The morphing rule 'mg'.+morphingMg :: Expression -> Expression -> [In.Premises Expression]+morphingMg term universe =+  [ In.Concludes (In.Onward (In.Taken (D.Morphing, "mg")) ExTermination ExRoot)+  | ExRoot <- [universe]+  , ExRoot <- [term]+  ]++-- The morphing rule 'ml'.+morphingMl :: Expression -> Expression -> [In.Premises Expression]+morphingMl term universe =+  [ In.Evaluates (B.formed (concat [x4, [BiLambda x8], x7])) universe (\n1 -> pure (In.Concludes (In.Onward (In.Normalized (D.Morphing, "ml")) (ExDispatch n1 x2) universe)))+  | ExDispatch x1 x2 <- [term]+  , ExFormation x3 <- [x1]+  , (x4, x5) <- M.splits x3+  , (x6 : x7) <- [x5]+  , BiLambda x8 <- [x6]+  , M.named x8+  ]++-- The morphing rule 'mphi'.+morphingMphi :: Expression -> Expression -> [In.Premises Expression]+morphingMphi term universe =+  [ In.Concludes (In.Onward (In.Normalized (D.Morphing, "mphi")) (ExDispatch (ExDispatch (B.formed x3) AtPhi) x2) universe)+  | ExDispatch x1 x2 <- [term]+  , ExFormation x3 <- [x1]+  , (all (`Ru.presentIn` concat [x3]) [AtPhi] && not (any (`Ru.presentIn` concat [x3]) [x2, AtLambda]))+  ]++-- The morphing rule 'universe'.+morphingUniverse :: Expression -> Expression -> [In.Premises Expression]+morphingUniverse term universe =+  [ In.Concludes (In.Onward (In.Named (D.Morphing, "universe")) universe universe)+  | ExRoot <- [term]+  , not (universe == ExRoot)+  ]++-- The morphing rule 'xi'.+morphingXi :: Expression -> Expression -> [In.Premises Expression]+morphingXi term universe =+  [ In.Concludes (In.Onward (In.Taken (D.Morphing, "xi")) ExTermination universe)+  | ExXi <- [term]+  ]++-- The dataization rule 'box'.+dataizationBox :: Expression -> Expression -> [In.Premises Bytes]+dataizationBox term universe =+  [ In.Contextualizes x7 (B.formed (concat [x2, [BiTau AtPhi x7], x5])) (\e3 -> pure (In.Concludes (In.Onward (In.Normalized (D.Contextualization, "contextualize")) e3 universe)))+  | ExFormation x1 <- [term]+  , (x2, x3) <- M.splits x1+  , (x4 : x5) <- [x3]+  , BiTau x6 x7 <- [x4]+  , x6 == AtPhi+  , not (any (`Ru.presentIn` concat [x2, x5]) [AtDelta, AtLambda])+  ]++-- The dataization rule 'delta'.+dataizationDelta :: Expression -> Expression -> [In.Premises Bytes]+dataizationDelta term _ =+  [ In.Concludes (In.Answered (D.Dataization, "delta") x6)+  | ExFormation x1 <- [term]+  , (_, x3) <- M.splits x1+  , (x4 : _) <- [x3]+  , BiDelta x6 <- [x4]+  ]++-- The dataization rule 'fire'.+dataizationFire :: Expression -> Expression -> [In.Premises Bytes]+dataizationFire term universe =+  [ In.Evaluates (B.formed (concat [x2, [BiLambda x6], x5])) universe (\n1 -> pure (In.Concludes (In.Onward (In.Taken (D.Evaluation, "evaluate")) n1 universe)))+  | ExFormation x1 <- [term]+  , (x2, x3) <- M.splits x1+  , (x4 : x5) <- [x3]+  , BiLambda x6 <- [x4]+  , M.named x6+  ]++-- The dataization rule 'none'.+dataizationNone :: Expression -> Expression -> [In.Premises Bytes]+dataizationNone term universe =+  [ In.Concludes (In.Onward (In.Taken (D.Dataization, "dataize")) ExTermination universe)+  | ExFormation x1 <- [term]+  , not (any (`Ru.presentIn` concat [x1]) [AtDelta, AtLambda, AtPhi])+  ]++-- The dataization rule 'norm'.+dataizationNorm :: Expression -> Expression -> [In.Premises Bytes]+dataizationNorm term universe =+  [ In.Concludes (In.Onward (In.Staged universe) term universe)+  | (not (Ru.isFormation term) && not (term == ExTermination))+  , Ru.normalHeld nf term+  ]+

@@ -0,0 +1,13 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- The engine 'phino compile' writes, where it has written one: this module+-- stands in its place until it does, and a build without the flag 'compiled'+-- links it in, so phino interprets its rules of YAML (#1617).+module Compiled (compiled) where++import Engine (Engine)++-- No engine was compiled.+compiled :: Maybe Engine+compiled = Nothing

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino-version: 0.0.143+version: 0.0.144 license: MIT synopsis: Command-Line Manipulator of 𝜑-Calculus Expressions description: Please see the README on GitHub at <https://github.com/objectionary/phino#readme>@@ -19,6 +19,13 @@   type: git   location: https://github.com/objectionary/phino +-- Link in the engine 'phino compile' wrote to 'compiled/generated' rather+-- than the stub in 'compiled/stub', which interprets the rules of YAML.+flag compiled+  description: Run the built-in rules as the Haskell 'phino compile' wrote+  default: True+  manual: True+ common warnings   ghc-options:     -Wall@@ -45,15 +52,20 @@     CLI.Runners     CLI.Types     CLI.Validators+    Compiled     Condition+    Contextualize     CST     Dataize     Deps+    Emit     Encoding+    Engine     Evaluate     Files     Filter     Functions+    Inference     Lambdas     Language     LaTeX@@ -68,6 +80,7 @@     Morph     Must     Parser+    Pool     Printer     Random     Regexp@@ -82,6 +95,10 @@     Yaml    hs-source-dirs: src+  if flag(compiled)+    hs-source-dirs: compiled/generated+  else+    hs-source-dirs: compiled/stub   other-modules:     Paths_phino @@ -117,6 +134,7 @@ executable phino   import: warnings   main-is: Main.hs+  ghc-options: -threaded   hs-source-dirs: app   build-depends:     base,@@ -130,6 +148,7 @@   type: exitcode-stdio-1.0   main-is: Main.hs   hs-source-dirs: test+  ghc-options: -threaded   other-modules:     AbridgeSpec     ASTSpec@@ -139,16 +158,21 @@     CLIHelpersSpec     CLISpec     CLITypesSpec+    CompiledSpec     ConditionSpec+    ContextualizeSpec     CSTSpec     DataizeSpec     DepsSpec+    EmitSpec     EncodingSpec+    EngineSpec     EvaluateSpec     FilesSpec     FilterSpec     Fixtures     FunctionsSpec+    InferenceSpec     LambdasSpec     LanguageSpec     LaTeXSpec@@ -164,6 +188,7 @@     MustSpec     ParserSpec     Paths_phino+    PoolSpec     PrinterSpec     RandomSpec     RegexpSpec

@@ -28,6 +28,7 @@   , alike   , within   , symbols+  , lifted   , denoted   , countNodes   , matchBaseObject@@ -426,6 +427,15 @@       (Just right', Just _) | right' == right -> Just (forward, backward)       _ -> Nothing +-- What one call of 'within' has found out so far: whether a term is embedded+-- in another, for every pair of terms the call has asked about, kept by the+-- digests of the two and confirmed by (==), since two terms may share a digest.+type Searched = Map.Map (Int, Int) [(Expression, Expression, Bool)]++-- A question 'within' asks, answered from what the call has found out so far+-- and handing that back with what the answer added to it.+type Search = Searched -> (Bool, Searched)+ -- Whether the first term is embedded in the second: the two have the same -- constructor, attributes, data and λ names at the top, and every term the -- first holds there is embedded in the term the second holds at the same place,@@ -437,12 +447,24 @@ -- stands for a term that holds no symbol itself, since a round holding an -- unknown where the previous one held a datum is more general than it (#1491). -- A ρ binding is never looked below, since it holds the object a term was--- taken from and not a term it grew into.+-- taken from and not a term it grew into. A call answers every pair of terms it+-- asks about once and keeps the answer, since a search that fails walks the+-- whole of the second term and the same pair is asked about again from every+-- place above it, so without the answers kept the cost grows with the number+-- of ways one term can be laid along the other (#1623). within :: Expression -> Expression -> Bool-within = coupled+within before after = fst (coupled before after Map.empty)   where-    embedded :: Expression -> Expression -> Bool-    embedded inner outer = general inner outer || coupled inner outer || any (embedded inner) (children outer)+    embedded :: Expression -> Expression -> Search+    embedded inner outer searched = case recalled inner outer searched of+      Just found -> (found, searched)+      Nothing -> remembered inner outer (some [answered (general inner outer), coupled inner outer, some (map (embedded inner) (children outer))] searched)+    recalled :: Expression -> Expression -> Searched -> Maybe Bool+    recalled inner outer searched = listToMaybe [found | (inner', outer', found) <- Map.findWithDefault [] (digests inner outer) searched, inner' == inner, outer' == outer]+    remembered :: Expression -> Expression -> (Bool, Searched) -> (Bool, Searched)+    remembered inner outer (found, searched) = (found, Map.insertWith (++) (digests inner outer) [(inner, outer, found)] searched)+    digests :: Expression -> Expression -> (Int, Int)+    digests inner outer = (hashExpression inner, hashExpression outer)     general :: Expression -> Expression -> Bool     general inner (ExFormation [BiLambda (FnSymbol _)]) = plain inner     general _ _ = False@@ -460,21 +482,33 @@     plainBinding (BiTau _ expr) = plain expr     plainBinding (BiLambda (FnSymbol _)) = False     plainBinding _ = True-    coupled :: Expression -> Expression -> Bool-    coupled (ExFormation left) (ExFormation right) = length left == length right && and (zipWith goBinding left right)-    coupled (ExApplication left arg) (ExApplication right arg') = embedded left right && goArgument arg arg'-    coupled (ExDispatch left attr) (ExDispatch right attr') = attr == attr' && embedded left right-    coupled (ExPhiMeet prefix idx left) (ExPhiMeet prefix' idx' right) = prefix == prefix' && idx == idx' && embedded left right-    coupled (ExPhiAgain prefix idx left) (ExPhiAgain prefix' idx' right) = prefix == prefix' && idx == idx' && embedded left right-    coupled left right = left == right-    goBinding :: Binding -> Binding -> Bool-    goBinding (BiTau attr left) (BiTau attr' right) = attr == attr' && embedded left right-    goBinding (BiLambda (FnSymbol _)) (BiLambda (FnSymbol _)) = True-    goBinding left right = left == right-    goArgument :: Argument -> Argument -> Bool-    goArgument (ArTau attr left) (ArTau attr' right) = attr == attr' && embedded left right-    goArgument (ArAlpha alpha left) (ArAlpha alpha' right) = alpha == alpha' && embedded left right-    goArgument _ _ = False+    coupled :: Expression -> Expression -> Search+    coupled (ExFormation left) (ExFormation right) = every (answered (length left == length right) : zipWith goBinding left right)+    coupled (ExApplication left arg) (ExApplication right arg') = every [embedded left right, goArgument arg arg']+    coupled (ExDispatch left attr) (ExDispatch right attr') = every [answered (attr == attr'), embedded left right]+    coupled (ExPhiMeet prefix idx left) (ExPhiMeet prefix' idx' right) = every [answered (prefix == prefix' && idx == idx'), embedded left right]+    coupled (ExPhiAgain prefix idx left) (ExPhiAgain prefix' idx' right) = every [answered (prefix == prefix' && idx == idx'), embedded left right]+    coupled left right = answered (left == right)+    goBinding :: Binding -> Binding -> Search+    goBinding (BiTau attr left) (BiTau attr' right) = every [answered (attr == attr'), embedded left right]+    goBinding (BiLambda (FnSymbol _)) (BiLambda (FnSymbol _)) = answered True+    goBinding left right = answered (left == right)+    goArgument :: Argument -> Argument -> Search+    goArgument (ArTau attr left) (ArTau attr' right) = every [answered (attr == attr'), embedded left right]+    goArgument (ArAlpha alpha left) (ArAlpha alpha' right) = every [answered (alpha == alpha'), embedded left right]+    goArgument _ _ = answered False+    answered :: Bool -> Search+    answered = (,)+    every :: [Search] -> Search+    every [] searched = (True, searched)+    every (search : rest) searched = case search searched of+      (True, searched') -> every rest searched'+      failed -> failed+    some :: [Search] -> Search+    some [] searched = (False, searched)+    some (search : rest) searched = case search searched of+      (False, searched') -> some rest searched'+      found -> found     children :: Expression -> [Expression]     children (ExFormation bds) = [expr | BiTau attr expr <- bds, attr /= AtRho]     children (ExApplication expr (ArTau _ arg)) = [expr, arg]@@ -506,6 +540,30 @@     goArgument :: Argument -> [Int]     goArgument (ArTau _ expr) = goExpr expr     goArgument (ArAlpha _ expr) = goExpr expr++-- The same term with every symbol above the floor raised by the offset, and+-- every other one left as it was. A run under '--jobs' morphs each binding of+-- a formation from the same state, so each of them numbers what it mints from+-- the same floor; raising what a binding minted by what the bindings before it+-- minted numbers the symbols the way one walk over all of them would have,+-- whichever worker finished first (#1534).+lifted :: Int -> Int -> Expression -> Expression+lifted floor' offset = goExpr+  where+    goExpr :: Expression -> Expression+    goExpr (ExFormation bds) = ExFormation (map goBinding bds)+    goExpr (ExApplication expr arg) = ExApplication (goExpr expr) (goArgument arg)+    goExpr (ExDispatch expr attr) = ExDispatch (goExpr expr) attr+    goExpr (ExPhiMeet prefix idx expr) = ExPhiMeet prefix idx (goExpr expr)+    goExpr (ExPhiAgain prefix idx expr) = ExPhiAgain prefix idx (goExpr expr)+    goExpr expr = expr+    goBinding :: Binding -> Binding+    goBinding (BiTau attr expr) = BiTau attr (goExpr expr)+    goBinding (BiLambda (FnSymbol idx)) | idx > floor' = BiLambda (FnSymbol (idx + offset))+    goBinding bd = bd+    goArgument :: Argument -> Argument+    goArgument (ArTau attr expr) = ArTau attr (goExpr expr)+    goArgument (ArAlpha alpha expr) = ArAlpha alpha (goExpr expr)  -- The symbol a term stands for, if its value is one at all. A term carries its -- value where the φ chain ends, so that is the only place a symbol names this

@@ -18,14 +18,15 @@   , buildBindingUnchecked   , buildBytes   , buildBytesThrows-  , contextualize+  , formed+  , nameIn   , pathOf   , BuildException (..)   ) where  import AST-import Control.Exception (Exception)+import Control.Exception (Exception, throw) import Control.Monad (zipWithM) import Data.List (find) import qualified Data.Map.Strict as Map@@ -60,19 +61,6 @@   show CouldNotBuildBinding{..} = printf "Couldn't build binding, %s\n--Binding: %s" _msg (printBinding _bd)   show CouldNotBuildBytes{..} = printf "Couldn't build bytes '%s', %s" (printBytes _bts) _msg -contextualize :: Expression -> Expression -> Expression-contextualize ExRoot _ = ExRoot-contextualize ExXi ex = ex-contextualize ExTermination _ = ExTermination-contextualize expr@(ExFormation _) _ = expr-contextualize (ExDispatch ex at) context = ExDispatch (contextualize ex context) at-contextualize (ExApplication ex arg) context =-  ExApplication (contextualize ex context) (contextualizeArg arg)-  where-    contextualizeArg (ArTau at bexpr) = ArTau at (contextualize bexpr context)-    contextualizeArg (ArAlpha al bexpr) = ArAlpha al (contextualize bexpr context)-contextualize ex _ = ex- buildAttribute :: Attribute -> Subst -> Built Attribute buildAttribute (AtMeta meta) (Subst mp) = case Map.lookup (Named meta) mp of   Just (MvAttribute attr) -> Right attr@@ -234,6 +222,18 @@     closed (ExDispatch target _) = closed target     closed _ = False pathOf _ form = form++-- The name the formation goes by in the world, where a world is known, or the+-- formation itself (see 'pathOf'), which is what the 'named' function of a+-- rule writes.+nameIn :: Maybe Expression -> Expression -> Expression+nameIn universe form = maybe form (`pathOf` form) universe++-- The formation of the bindings, which a rule 'phino compile' turned into+-- Haskell builds the way the builder builds a formation of a template: it+-- refuses one carrying an attribute twice (see 'unique').+formed :: [Binding] -> Expression+formed bds = either (throw . CouldNotBuildExpression (ExFormation bds)) id (unique (ExFormation bds))  -- The bindings of a formation, whether a meta was bound to it or it was built -- from a template, are checked here, since a substitution may bring two of

@@ -48,6 +48,7 @@     CmdExplain opts -> runExplain opts     CmdMerge opts -> runMerge opts     CmdMatch opts -> runMatch opts+    CmdCompile opts -> runCompile opts   where     prefixFirstLine :: String -> String -> String     prefixFirstLine _ "" = "Failure"@@ -68,6 +69,7 @@             CmdExplain OptsExplain{_logLevel, _logLines} -> (_logLevel, _logLines)             CmdMerge OptsMerge{_logLevel, _logLines} -> (_logLevel, _logLines)             CmdMatch OptsMatch{_logLevel, _logLines} -> (_logLevel, _logLines)+            CmdCompile OptsCompile{_logLevel, _logLines} -> (_logLevel, _logLines)        in setLogConfig level lns     checkPin :: Maybe Pin -> IO ()     checkPin Nothing = pure ()

@@ -13,6 +13,7 @@ import CLI.Validators (invalidCLIArguments) import CST (EXPRESSION) import Canonizer (canonize, canonizeExpr)+import Compiled (compiled) import Control.Exception import Control.Monad ((>=>)) import Data.Char (toLower)@@ -24,6 +25,7 @@ import qualified Data.Text as T import Deps (Evaluation (EvRun), Judgment, SaveEvalFunc, SaveStepFunc, State (..), dontSaveEval, emptyNesting, emptyProgress, emptyProtocol, endEvalXml, progressed, saveEval, saveEvalXml, saveStep) import Encoding+import Engine (Engine, fresh, yaml) import Files (ensuredFile, overwrite) import Functions (buildFunctions, execFunctions) import GHC.Clock (getMonotonicTime)@@ -335,3 +337,14 @@     logDebug (printf "The option '--target' is specified, printing to '%s'..." file)     overwrite file content     logDebug (printf "The command result was saved in '%s'" file)++-- The engine the rules run on: the one 'phino compile' wrote, where the build+-- links one in, and the one interpreting the rules of YAML otherwise. An+-- engine compiled from rules phino no longer carries is refused, since it+-- would run rules nobody wrote (#1617).+engine :: IO Engine+engine = case compiled of+  Nothing -> pure yaml+  Just linked+    | fresh linked -> logDebug "The built-in rules run compiled, as 'phino compile' wrote them" >> pure linked+    | otherwise -> throwIO StaleEngine

@@ -97,6 +97,14 @@         (long "max-firings" <> metavar "FIRINGS" <> help "Maximum number of λ functions the whole run may fire, unlimited unless given")     ) +optMaxSeconds :: Parser (Maybe Int)+optMaxSeconds =+  optional+    ( option+        (auto >>= validateIntOption (> 0) "--max-seconds must be positive")+        (long "max-seconds" <> metavar "SECONDS" <> help "Maximum number of seconds the whole run may take, unlimited unless given")+    )+ optMargin :: Parser Int optMargin =   option@@ -221,6 +229,15 @@ optDeep :: Parser Bool optDeep = switch (long "deep" <> help "Don't stop at the first formation: enter its bindings too, recursively, firing every λ function the --symbolic file answers and standing its answer in the place of what it computed, while everything else stays as it was written") +-- The bindings of the formation '--deep' starts at share nothing but the world+-- they read, so they are walked side by side on as many workers as this says+-- (see 'spread' in 'Morph', #1534).+optJobs :: Parser Int+optJobs =+  option+    (auto >>= validateIntOption (> 0) "--jobs must be positive")+    (long "jobs" <> metavar "JOBS" <> help "Number of workers the --deep walk morphs the bindings of the formation it starts at on, side by side, each with a memo, a tally and fresh names of its own" <> value 1 <> showDefault)+ -- The step budget is otherwise the only thing that ends the 𝕄 and 𝔻 recursion, -- so a λ function answering with a firing of itself, or an object dataized -- through a body that comes back to itself, runs to the limit before it fails.@@ -395,6 +412,7 @@             <*> optMaxCycles             <*> optMaxSteps             <*> optMaxFirings+            <*> optMaxSeconds             <*> optMargin             <*> optMeetPopularity             <*> optMeetLength@@ -436,12 +454,14 @@             <*> switch (long "quiet" <> help "Don't print the result of morphing")             <*> optPartial             <*> optDeep+            <*> optJobs             <*> optAcyclic             <*> optCompress             <*> optMaxDepth             <*> optMaxCycles             <*> optMaxSteps             <*> optMaxFirings+            <*> optMaxSeconds             <*> optMargin             <*> optMeetPopularity             <*> optMeetLength@@ -536,6 +556,16 @@             <*> optSeed         ) +compileParser :: Parser Command+compileParser =+  CmdCompile+    <$> ( OptsCompile+            <$> optLogLevel+            <*> optLogLines+            <*> optRule+            <*> strOption (long "target" <> short 't' <> metavar "FILE" <> value "compiled/generated/Compiled.hs" <> showDefault <> help "File to write the Haskell module to")+        )+ commandParser :: Parser Command commandParser =   hsubparser@@ -545,6 +575,7 @@         <> command "explain" (info explainParser (progDesc "Explain rules in LaTeX format"))         <> command "merge" (info mergeParser (progDesc "Merge 𝜑-expressions into single one by merging their top level formations"))         <> command "match" (info matchParser (progDesc "Match 𝜑-expression against provided pattern and build matched substitutions"))+        <> command "compile" (info compileParser (progDesc "Compile the rules into a Haskell module a build with the flag 'compiled' links in"))     )  optPin :: Parser (Maybe Pin)

@@ -12,6 +12,7 @@ import CLI.Types import CLI.Validators import Condition (parseConditionThrows)+import Control.Concurrent (rtsSupportsBoundThreads, setNumCapabilities) import Control.Exception import Control.Monad (unless, when) import Data.Foldable (traverse_)@@ -22,11 +23,12 @@ import qualified Data.Text as T import Dataize import Deps (Judgment (..))+import Emit (emitted) import Encoding+import Engine (Engine (..), building, current, stepOf) import Evaluate (evaluation, fired) import Files (overwrite) import qualified Filter as F-import Functions (buildTerm) import LaTeX (explainContextualizeRules, explainDataizeRules, explainMorphRules, explainRules) import Logger import Margin (defaultMargin)@@ -57,6 +59,7 @@   validateNoOverlap "show" included "hide" excluded   setStdGen (mkStdGen _seed)   rules <- getRules _normalize _shuffle _rules+  linked <- engine   validateBreakpoint _breakpoint rules   input <- readInput _inputFile   (expr, atoms) <- parseInputWithAtoms input _inputFormat@@ -71,7 +74,7 @@       exclude = (`F.exclude` excluded)       include = (`F.include` included)   save <- saveStepFunc _stepsDir printCtx-  (rewrittens, exceeded) <- rewrite expr rules (RewriteContext loc _maxDepth _maxCycles _depthSensitive Nothing buildTerm _must _breakpoint save)+  (rewrittens, exceeded) <- rewrite expr (map (stepOf linked) rules) (RewriteContext loc _maxDepth _maxCycles _depthSensitive Nothing (building linked) linked._normal _must _breakpoint save)   rewrittens' <- exclude <$> include (if _sequence then NE.toList rewrittens else [NE.last rewrittens])   logDebug (printf "Printing rewritten 𝜑-expression as %s" (show _outputFormat))   exprs <- printRewrittens printCtx (rewrittens', exceeded)@@ -150,6 +153,7 @@ runDataize :: OptsDataize -> IO () runDataize OptsDataize{..} = do   validateOpts+  deadline <- timed _maxSeconds   lambdas <- lambdasOf _symbolic   excluded <- validatedDispatches "hide" _hide   included <- validatedDispatches "show" _show@@ -166,6 +170,7 @@   save <- saveStepFunc _stepsDir printCtx   tally <- tallied _maxFirings   memo <- memoized _acyclic+  linked <- engine   (outcome, chain, _) <-     withEvalFunc       _protocol@@ -175,7 +180,7 @@           -- reduces what dataization demands and ends in bytes, so it is off           -- here; the cycle guard of '--acyclic' is not, since 𝔻 recurses into           -- itself and a formation it enters again is a loop of its own (#1290).-          let ctx = ReduceContext loc loc Nothing _maxDepth _maxCycles (Steps _maxSteps 0) tally memo 1 _depthSensitive _shuffle _partial False _acyclic Dataization [] Map.empty lambdas buildTerm reduction evaluation fired save record+          let ctx = ReduceContext loc loc Nothing _maxDepth _maxCycles (Steps _maxSteps 0) tally deadline memo 1 _depthSensitive _shuffle _partial False 1 _acyclic Dataization [] Map.empty lambdas (building linked) reduction evaluation fired save record linked           (universe, aiming) <- aimed _inside expr ctx           heading record printCtx Dataization aiming._locator           dataize universe (started universe) aiming@@ -243,6 +248,8 @@ runMorph :: OptsMorph -> IO () runMorph OptsMorph{..} = do   validateOpts+  deadline <- timed _maxSeconds+  when rtsSupportsBoundThreads (setNumCapabilities _jobs)   lambdas <- lambdasOf _symbolic   excluded <- validatedDispatches "hide" _hide   included <- validatedDispatches "show" _show@@ -259,12 +266,13 @@   save <- saveStepFunc _stepsDir printCtx   tally <- tallied _maxFirings   memo <- memoized _acyclic+  linked <- engine   (morphed, chain, _) <-     withEvalFunc       _protocol       printCtx       ( \record -> do-          let ctx = ReduceContext loc loc Nothing _maxDepth _maxCycles (Steps _maxSteps 0) tally memo 1 _depthSensitive _shuffle _partial _deep _acyclic Morphing [] Map.empty lambdas buildTerm reduction evaluation fired save record+          let ctx = ReduceContext loc loc Nothing _maxDepth _maxCycles (Steps _maxSteps 0) tally deadline memo 1 _depthSensitive _shuffle _partial _deep _jobs _acyclic Morphing [] Map.empty lambdas (building linked) reduction evaluation fired save record linked           (universe, aiming) <- aimed _inside expr ctx           heading record printCtx Morphing aiming._locator           morph universe (started universe) aiming@@ -285,6 +293,7 @@       validateXmirOptions _outputFormat [(_omitListing, "omit-listing"), (_omitComments, "omit-comments")] _focus       when (length _show > 1) (invalidCLIArguments "The option --show can be used only once")       when (isJust _abridged && isNothing _protocol) (invalidCLIArguments "The option --abridged requires --protocol, since only the protocol is abridged")+      when (_jobs > 1 && not _deep) (invalidCLIArguments "The option --jobs requires --deep, since only the deep walk runs on several workers")       when         (isJust _inside && _locator /= "Q")         (invalidCLIArguments "The options --inside and --locator cannot be used together, since --inside aims the run at the binding it mints")@@ -389,10 +398,24 @@       ptn <- parseExpressionThrows (fromJust _pattern)       condition <- traverse parseConditionThrows _when       traverse_ (throwIO . AnonymousMetaInCondition . T.unpack) (anonymous condition)-      substs <- matchExpressionWithRule expr (rule ptn condition) (RuleContext buildTerm Nothing)+      linked <- engine+      substs <- matchExpressionWithRule expr (rule ptn condition) (RuleContext (building linked) Nothing linked._normal)       if null substs         then throwIO EmptySubstsOnMatch         else putStrLn (P.printSubsts' substs (_sugarType, UNICODE, _flat, defaultMargin))   where     rule :: Expression -> Maybe Y.Condition -> Y.Rule     rule ptn cnd = Y.Rule "custom" Nothing Nothing ptn ExRoot cnd Nothing Nothing++runCompile :: OptsCompile -> IO ()+runCompile OptsCompile{..} = do+  custom <- getRules False False _rules+  source <- either (throwIO . CouldNotCompile) pure (emitted Y.normalizationRules custom Y.contextualizationRules Y.morphingRules Y.dataizationRules current)+  overwrite _targetFile source+  logInfo (printf "The rules were compiled into '%s'" _targetFile)+  exists <- doesFileExist "cabal.project.local"+  if exists+    then putStrLn "The file 'cabal.project.local' exists, so add these lines to it to link the compiled rules in:\npackage phino\n  flags: +compiled"+    else do+      overwrite "cabal.project.local" "package phino\n  flags: +compiled\n"+      logInfo "The file 'cabal.project.local' was written, so the next build links the compiled rules in"

@@ -45,6 +45,8 @@   | EmptySubstsOnMatch   | AnonymousMetaInCondition String   | VersionMismatch String String+  | CouldNotCompile String+  | StaleEngine   deriving (Exception)  instance Show CmdException where@@ -57,6 +59,8 @@     printf "Anonymous meta '!%s' cannot be referenced in --when, only a named one can" kind   show (VersionMismatch expected actual) =     printf "Version mismatch: --pin requires '%s', but this is phino %s" expected actual+  show (CouldNotCompile reason) = reason+  show StaleEngine = "The compiled rules are stale, since the rules of phino changed after 'phino compile', so run it again and rebuild"  data Command   = CmdRewrite OptsRewrite@@ -65,6 +69,7 @@   | CmdExplain OptsExplain   | CmdMerge OptsMerge   | CmdMatch OptsMatch+  | CmdCompile OptsCompile  data Pin = PinVersion String | PinFile FilePath @@ -106,6 +111,7 @@   , _maxCycles :: Int   , _maxSteps :: Int   , _maxFirings :: Maybe Int+  , _maxSeconds :: Maybe Int   , _margin :: Int   , _meetPopularity :: Maybe Int   , _meetLength :: Maybe Int@@ -148,12 +154,14 @@   , _quiet :: Bool   , _partial :: Bool   , _deep :: Bool+  , _jobs :: Int   , _acyclic :: Maybe Acyclic   , _compress :: Bool   , _maxDepth :: Int   , _maxCycles :: Int   , _maxSteps :: Int   , _maxFirings :: Maybe Int+  , _maxSeconds :: Maybe Int   , _margin :: Int   , _meetPopularity :: Maybe Int   , _meetLength :: Maybe Int@@ -250,4 +258,11 @@   , _when :: Maybe String   , _inputFile :: Maybe FilePath   , _seed :: Int+  }++data OptsCompile = OptsCompile+  { _logLevel :: LogLevel+  , _logLines :: Int+  , _rules :: [FilePath]+  , _targetFile :: FilePath   }

@@ -265,9 +265,9 @@  -- Like 'expressionToCST', but lays the expression out from a given base tab -- instead of column 0. Used when an expression sits on an already-indented--- line (e.g. a '\leadsto' continuation step in the LaTeX --sequence output),--- so its wrapped member lines nest one level below that line and its closing--- bracket aligns with the opening one.+-- line (e.g. a continuation step of the LaTeX --sequence output, after its+-- arrow), so its wrapped member lines nest one level below that line and its+-- closing bracket aligns with the opening one. expressionToCSTFrom :: Int -> Expression -> EXPRESSION expressionToCSTFrom tabs expr = toCST expr (tabs, EOL) 

@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE OverloadedRecordDot #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- The Contextualization function 𝒞 of the calculus, carried out by the rules+-- of 'resources/contextualization' and by nothing else, the way the other+-- judgments are carried out by theirs: 𝒞(n, c) is the conclusion of the one+-- rule whose 'match' matches the term and whose 'c-match' matches the context,+-- every premise of it a 𝒞 of a smaller term. A change to a rule is a change to+-- what runs, and 'explain --contextualize' prints the rules that fire (#1618).+-- The letters '𝑛' and '𝑘' of the rules are only names here, since the match is+-- the plain one, which demands neither a normal form nor an absolute term.+module Contextualize (concluded, contextualize, ContextualizeException (..)) where++import AST+import Builder (buildExpression)+import Control.Exception (Exception, throwIO)+import Control.Monad (foldM)+import Data.Bifunctor (first)+import Data.List (intercalate)+import qualified Data.Text as T+import Matcher (MetaValue (..), Subst, combine, matchExpression', substSingle)+import Printer (printExpression)+import Text.Printf (printf)+import qualified Yaml as Y++-- 𝒞 has no single conclusion for a term: no rule matches it, more than one+-- does, or the one that does cannot be carried out on it. It carries the term+-- and the reason, which is a clause of the sentence it is shown in.+data ContextualizeException = Uncontextualizable Expression String+  deriving (Exception)++instance Show ContextualizeException where+  show (Uncontextualizable term reason) = printf "Contextualization has no single conclusion, since %s: %s" reason (printExpression term)++-- The conclusion of the one rule that matched the term, among the names of the+-- rules that matched it beside what each of them concludes, or the failure of+-- a term no rule or more than one rule matches. Only the conclusion of the one+-- rule is ever worked out, so the other judgments of 'contextualize' and of+-- the function 'phino compile' writes for 𝒞 are never asked for (#1617).+concluded :: Expression -> [(String, Either ContextualizeException Expression)] -> Either ContextualizeException Expression+concluded _ [(_, answer)] = answer+concluded term [] = Left (Uncontextualizable term "no contextualization rule matches the term")+concluded term several = Left (Uncontextualizable term (printf "the contextualization rules %s all match the term" (intercalate ", " (map fst several))))++-- The term with every ξ outside the formations nested in it standing for the+-- context, or the failure of the term that has no single conclusion, which may+-- be a part of the term rather than the term itself.+contextualize :: Expression -> Expression -> IO Expression+contextualize expr context = either throwIO pure (contextualized expr context)+  where+    contextualized :: Expression -> Expression -> Either ContextualizeException Expression+    contextualized term around =+      concluded+        term+        [ (rule.name, foldM (premised term rule) subst rule.premises >>= built term rule rule.cresult)+        | (rule, subst) <- matching term around+        ]+    -- Every rule matching the term and the context, once for every way it+    -- matches them, so a rule matching in two ways is as ambiguous as two rules.+    matching :: Expression -> Expression -> [(Y.ContextualizeRule, Subst)]+    matching term around =+      [ (rule, subst)+      | rule <- Y.contextualizationRules+      , matched <- matchExpression' rule.match term+      , surrounding <- matchExpression' rule.cmatch around+      , Just subst <- [combine matched surrounding]+      ]+    premised :: Expression -> Y.ContextualizeRule -> Subst -> Y.Premise -> Either ContextualizeException Subst+    premised term rule subst (Y.Premise result (Y.OpContextualize inner outer)) = do+      part <- built term rule inner subst+      surrounding <- built term rule outer subst+      answer <- contextualized part surrounding+      maybe+        (Left (Uncontextualizable term (printf "the premise '%s' of the contextualization rule '%s' clashes with a binding" (T.unpack result) rule.name)))+        Right+        (combine (substSingle result (MvExpression answer)) subst)+    premised term rule _ premise =+      Left (Uncontextualizable term (printf "the premise '%s' of the contextualization rule '%s' is not a contextualization" (T.unpack premise.result) rule.name))+    built :: Expression -> Y.ContextualizeRule -> Expression -> Subst -> Either ContextualizeException Expression+    built term rule template subst =+      first+        (Uncontextualizable term . printf "the contextualization rule '%s' cannot be built, %s" rule.name)+        (buildExpression template subst)

@@ -14,23 +14,18 @@ module Dataize (dataize, dataize', reduction, Outcome (..)) where  import AST-import Builder (buildBytesThrows, buildExpressionThrows) import Control.Exception (throwIO, try)-import Control.Monad (foldM, unless)-import Data.List (find)+import Control.Monad (unless) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe (listToMaybe) import qualified Data.Text as T import Deps (Evaluation (..), Judgment (..), State (..))+import Engine (Engine (..))+import qualified Inference as In import Locator (locatedExpression)-import Matcher (Subst, matchExpression')-import Morph (Morphed, ReduceContext (..), ReduceException (..), ReductionFunc, boxed, deeper, entering, excluding, execBuildTerm, insideUniverse, leadsTo, morph', normalized, parking, producer, sidePremise, universed, verb)-import Random (shuffle)+import Morph (Morphed, ReduceContext (..), ReduceException (..), ReductionFunc, boxed, deeper, entering, inferred, insideUniverse, leadsTo, onward, parking, universed) import Rewriter (Rewritten)-import Rule (RuleContext (RuleContext), matchExpressionWithRule')-import Text.Printf (printf)-import qualified Yaml as Y  type Dataized = (Bytes, [Rewritten]) @@ -74,7 +69,8 @@ -- The Dataization function 𝔻 retrieves bytes from an expression. It is partial -- and ternary, 𝔻(n, e, s): besides the term 'n' it takes the universe 'e' ('univ'), -- which it forwards to 𝕄, and the mutable state 's', returning the bytes together--- with the new state. Its rules come from 'resources/dataization': 'delta' yields the+-- with the new state. Its rules come from 'resources/dataization', run by the+-- engine (see '_dataization' of 'Engine'): 'delta' yields the -- asset bytes and 'none' (a formation with no Δ/λ/φ) has nothing to dataize, so -- it dataizes ⊥. The terminator ⊥ signals an error and lies outside 𝔻's domain, -- so it matches no clause (there is no 'end' rule mapping it to empty bytes) and@@ -87,14 +83,15 @@ -- its 'contextualize' side-computation), and 'norm' reduces through morphing, -- splicing the morphing steps into the chain. The clauses are disjoint (see -- #902, #905), so their declaration order must not be load-bearing; when--- '_shuffle' is on (the '--shuffle' flag) the rules are shuffled before the--- 'firstMatch' walk to exercise that invariant — mirroring normalization's+-- '_shuffle' is on (the '--shuffle' flag) the rules are shuffled before+-- 'inferred' walks them to exercise that invariant — mirroring normalization's -- "apply until they stop matching". A genuinely order-independent step stays -- deterministic; a hidden overlap surfaces as a nondeterministic failure rather -- than staying silently green. -- The conclusion bytes 'dresult' are produced by a trailing 'dataize' premise; -- when its argument is bound by a 'morph' or 'normalize' premise, that step--- joins the spine, otherwise the premise is an isolated side-computation.+-- joins the spine, otherwise the premise is an isolated side-computation (see+-- 'dataizationSpine' of 'Inference'). -- Like 𝕄, every frame asks '_acyclic' whether the formation it is about to -- enter through 'box' or 'fire' is one a frame above it has already entered, -- before any rule is walked: 𝔻 recurses into itself through those two rules@@ -110,10 +107,17 @@   parking seq state $ case unknown expr of     Just idx -> manufactured idx ctx     Nothing -> do-      rules <- if ctx._shuffle then shuffle Y.dataizationRules else pure Y.dataizationRules-      matched <- firstMatch ctx rules-      case matched of-        Just (rule, subst) -> reduce ctx rule subst+      reached <- inferred expr univ state ctx ctx._engine._dataization+      case reached of+        -- Data the program itself carries stands for nothing but itself, so+        -- whichever symbol the last datum was manufactured for is forgotten+        -- here: only a run ending on a symbol leaves one behind.+        Just (In.Answered step bts, state') -> do+          seq' <- leadsTo seq step (ExBytes bts) ctx+          pure ((bts, NE.toList seq'), state'{_manufactured = Nothing})+        Just (In.Onward way built world, state') -> do+          (dataizable, state'') <- onward seq state' way built ctx+          dataize' dataizable world state'' ctx         Nothing -> throwIO (Undataizable expr state)   where     -- The context a frame opening on a formation 'box' gets into goes on@@ -140,81 +144,8 @@     -- protocol writes '𝔻(𝜎1)' where the term carries nothing but the 42.     manufactured :: Int -> ReduceContext -> IO (Dataized, State)     manufactured idx ctx = do-      seq' <- leadsTo seq "symbol" (ExBytes datum) ctx+      seq' <- leadsTo seq (Dataization, "symbol") (ExBytes datum) ctx       pure ((datum, NE.toList seq'), state{_manufactured = Just idx})-    firstMatch :: ReduceContext -> [Y.DataizeRule] -> IO (Maybe (Y.DataizeRule, Subst))-    firstMatch _ [] = pure Nothing-    firstMatch ctx (rule : rest) = do-      substs <- matchExpressionWithRule' (matchExpression' rule.ematch univ) expr (asRule rule) (RuleContext (execBuildTerm univ ctx) (Just univ))-      case substs of-        (subst : _) -> pure (Just (rule, subst))-        [] -> firstMatch ctx rest-    asRule :: Y.DataizeRule -> Y.Rule-    asRule rule = Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing-    reduce :: ReduceContext -> Y.DataizeRule -> Subst -> IO (Dataized, State)-    reduce ctx rule subst = case bytesProducer rule.dresult rule.premises of-      Nothing -> do-        (final, state') <- sides ctx rule.premises subst-        bts <- buildBytesThrows rule.dresult final-        seq' <- leadsTo seq rule.name (ExBytes bts) ctx-        -- Data the program itself carries stands for nothing but itself, so-        -- whichever symbol the last datum was manufactured for is forgotten-        -- here: only a run ending on a symbol leaves one behind.-        pure ((bts, NE.toList seq'), state'{_manufactured = Nothing})-      Just concl@(Y.Premise _ (Y.OpDataize arg universe)) -> case producer arg rule.premises of-        -- 𝔻(𝒩(e)) records the producing step (the 'box' contextualization),-        -- then normalizes its result back to a normal form before dataizing on,-        -- so 𝔻 only ever sees normal forms.-        Just normal@(Y.Premise _ (Y.OpNormalize inner)) -> do-          let side = rule.premises `excluding` [concl, normal]-          (final, state') <- sides ctx side subst-          built <- buildExpressionThrows inner final-          world <- buildExpressionThrows universe final-          labelled <- leadsTo seq (labelOf side) built ctx-          (normal', seq') <- normalized built labelled ctx-          dataize' (normal', seq') world state' ctx-        -- 𝔻(𝕄(e)) delegates to the morphing relation, in the universe the-        -- 'morph' premise names, splicing its steps into the chain before-        -- dataizing on in the one the conclusion names.-        Just morphed@(Y.Premise _ (Y.OpMorph inner scene)) -> do-          (final, state') <- sides ctx (rule.premises `excluding` [concl, morphed]) subst-          built <- buildExpressionThrows inner final-          stage <- buildExpressionThrows scene final-          ((morphed', seq'), state'') <- morph' (built, seq) stage state' ctx-          world <- buildExpressionThrows universe final-          dataize' (morphed', seq') world state'' ctx-        -- The dataize argument is produced with no 'normalize'/'morph' spine to-        -- splice: 'fire' by its 'evaluate' side-computation (𝔼 now yields a-        -- normal form itself, so no follow-up 'normalize' is needed) and 'none'-        -- by handing the literal ⊥ straight to 𝔻. The transition is labelled by-        -- the side-computation ('evaluate') when there is one, else by the-        -- conclusion's own verb ('dataize' for 𝔻(⊥)).-        _ -> do-          let side = rule.premises `excluding` [concl]-          (final, state') <- sides ctx side subst-          built <- buildExpressionThrows arg final-          world <- buildExpressionThrows universe final-          seq' <- leadsTo seq (labelOr (verb concl.operation) side) built ctx-          dataize' (built, seq') world state' ctx-      Just _ -> throwIO (userError (printf "dataization rule '%s' must conclude with a 'dataize' premise" rule.name))-    sides :: ReduceContext -> [Y.Premise] -> Subst -> IO (Subst, State)-    sides ctx premises subst = foldM (sidePremise univ ctx) (subst, state) premises-    -- A spliced dataization step is labelled by its first side-computation —-    -- 'box' by its 'contextualize', 'fire' by its 'evaluate'; with none it is blank.-    labelOf :: [Y.Premise] -> String-    labelOf (premise : _) = verb premise.operation-    labelOf [] = ""-    -- As 'labelOf', but falls back to the given label when there is no-    -- side-computation to name the step (the 'none' rule's 𝔻(⊥) premise).-    labelOr :: String -> [Y.Premise] -> String-    labelOr _ premises@(_ : _) = labelOf premises-    labelOr fallback [] = fallback---- The premise binding the given bytes meta, if any — the dataization analogue of--- 'producer' for a rule's bytes conclusion.-bytesProducer :: Bytes -> [Y.Premise] -> Maybe Y.Premise-bytesProducer (BtMeta name) = find (\premise -> premise.result == name)-bytesProducer _ = const Nothing  -- What a 'dataize' operand of a λ function is brought down with (see -- 'ReductionFunc' in 'Morph'): the operand is bound to a synthetic attribute of

@@ -76,24 +76,36 @@ dontSaveStep :: SaveStepFunc dontSaveStep = saveStep Nothing "" (\_ -> pure "") 0 --- The judgment a run of the protocol records, which is the one thing the two--- formats spell in two ways: the text format writes the letter the calculus--- writes, '𝕄(Φ.x)', and the markup names the root after it, '<morph--- at="Φ.x">', the way every record under it is named after the judgment it--- carries (#1279). A stuck site spells it the same two ways, since it too is a--- judgment asking and getting no answer (see 'EvStuck'); nothing else is--- spelled twice, since nothing else of a record is a name of the calculus.+-- A judgment of the calculus. A run of the protocol records one of two, which+-- is the one thing the two formats spell in two ways: the text format writes+-- the letter the calculus writes, '𝕄(Φ.x)', and the markup names the root+-- after it, '<morph at="Φ.x">', the way every record under it is named after+-- the judgment it carries (#1279). A stuck site spells it the same two ways,+-- since it too is a judgment asking and getting no answer (see 'EvStuck');+-- nothing else is spelled twice, since nothing else of a record is a name of+-- the calculus. A step of a '--sequence' chain is taken by any of the five,+-- which is what picks the arrow LaTeX writes the step with (#1536). data Judgment-  = -- The Morphing function 𝕄, which the 'morph' command runs.+  = -- The Normalization function 𝒩, which the 'rewrite' command runs.+    Normalization+  | -- The Morphing function 𝕄, which the 'morph' command runs.     Morphing   | -- The Dataization function 𝔻, which the 'dataize' command runs.     Dataization+  | -- The Evaluation function 𝔼, which fires a λ function.+    Evaluation+  | -- The Contextualization function 𝒞, which 'box' of 𝔻 runs over a φ body.+    Contextualization+  deriving (Eq, Show)  -- The letter the calculus writes a judgment with, which is how the text format -- opens a run of it. letter :: Judgment -> String+letter Normalization = "𝒩" letter Morphing = "𝕄" letter Dataization = "𝔻"+letter Evaluation = "𝔼"+letter Contextualization = "𝒞"  -- The element the markup opens a run of a judgment with, and closes it under, -- named after the judgment the way '<evaluate>' is named after 𝔼. A root@@ -101,8 +113,11 @@ -- firing carries the meta it bound, which is the very difference the text -- format draws between '𝔻(Φ)' at the top and '𝛿1.2 := 𝔻(…)' in a block. opened :: Judgment -> String+opened Normalization = "normalize" opened Morphing = "morph" opened Dataization = "dataize"+opened Evaluation = "evaluate"+opened Contextualization = "contextualize"  -- What '--acyclic' takes for the same formation entered again, which is how -- sure a cut is that the recursion it stops would never have stopped. 'Proven'@@ -220,6 +235,13 @@     -- the term, since the walk of 𝕄 stands at the whole formation it morphs,     -- which on a real world spells a universe on every line (#1531).     EvStarved Int Int Judgment Expression+  | -- The deadline of '--max-seconds' passing, at the depth the frame it+    -- refused would have stood at, together with the seconds the run was+    -- given, the judgment of that frame and the locator of the site it stood+    -- at. The run ends on it with or without '--partial', so it is the last+    -- line of the protocol and a run out of time reads as one and not as a+    -- crash (#1607, #1619).+    EvTimeout Int Int Judgment Expression   | -- A 'dataize' operand of the firing: the meta it bound, the term the entry     -- wrote under that meta, and the data it came down to, or the symbol that     -- data was manufactured for.@@ -298,6 +320,42 @@  type SaveEvalFunc = Evaluation -> IO () +-- The same record with every symbol it names above the floor raised by the+-- offset, the terms it carries included (see 'lifted'). A binding the+-- '--deep' walk morphs on a worker of its own under '--jobs' numbers its+-- symbols from the floor every worker starts at, and its records are+-- renumbered like this as they are written, once the bindings before it are,+-- so the protocol names a symbol the way the answer does (#1534).+renumbered :: Int -> Int -> Evaluation -> Evaluation+renumbered floor' offset = record+  where+    record :: Evaluation -> Evaluation+    record (EvFiring depth key judgment site) = EvFiring depth key judgment (term site)+    record (EvFormation depth self site) = EvFormation depth (term self) (term site)+    record (EvLooped depth judgment mode self site) = EvLooped depth judgment mode (term self) (term site)+    record (EvStuck depth key judgment self) = EvStuck depth key judgment (term self)+    record (EvStarved depth limit judgment site) = EvStarved depth limit judgment (term site)+    record (EvTimeout depth limit judgment site) = EvTimeout depth limit judgment (term site)+    record (EvData depth spelling operand value) = EvData depth spelling (term operand) (datum value)+    record (EvTerm depth spelling operand value) = EvTerm depth spelling (term operand) (term value)+    record (EvSymbolize depth spelling source value) = EvSymbolize depth spelling (term source) (term value)+    record (EvKnown depth sym bytes) = EvKnown depth (symbol sym) bytes+    record (EvJoin depth spelling pair value) = EvJoin depth spelling pair (term value)+    record (EvJoined depth fresh (one, two)) = EvJoined depth (symbol fresh) (symbol one, symbol two)+    record (EvTerminate depth condition side raising) = EvTerminate depth (fmap datum condition) side raising+    record (EvMinted depth sym operands) = EvMinted depth (symbol sym) (map datum operands)+    record (EvBuilt depth value) = EvBuilt depth (term value)+    record (EvAnswer depth value) = EvAnswer depth (term value)+    record other = other+    term :: Expression -> Expression+    term = lifted floor' offset+    symbol :: Int -> Int+    symbol idx+      | idx > floor' = idx + offset+      | otherwise = idx+    datum :: Either Int Bytes -> Either Int Bytes+    datum = either (Left . symbol) Right+ -- The names the text protocol has given to the terms it has written out, -- keyed by a cheap fixed-size digest of the term (see 'hashExpression') the -- way 'Seen' keys the formations '--acyclic' has entered. A digest collision is@@ -439,6 +497,9 @@     written (EvStarved depth limit judgment site) protocol = do       locator <- render site       pure (protocol, Just (indented depth (printf "starved(%d)  # %s(%s)" limit (letter judgment) locator)))+    written (EvTimeout depth limit judgment site) protocol = do+      locator <- render site+      pure (protocol, Just (indented depth (printf "timeout(%d)  # %s(%s)" limit (letter judgment) locator)))     written (EvData depth spelling operand value) protocol = do       datum <- spelled value       line <- commented (printf "%s := %s" (labelled protocol depth spelling) datum) Dataization operand@@ -627,6 +688,10 @@       locator <- render site       let (kept, closers) = closed depth nesting._closing       pure (nesting{_closing = kept}, closers ++ [indented depth (printf "<starved limit=\"%d\" by=\"%s\" at=\"%s\"/>" limit (opened judgment) (escapeXML locator))])+    elements (EvTimeout depth limit judgment site) nesting = do+      locator <- render site+      let (kept, closers) = closed depth nesting._closing+      pure (nesting{_closing = kept}, closers ++ [indented depth (printf "<timeout limit=\"%d\" by=\"%s\" at=\"%s\"/>" limit (opened judgment) (escapeXML locator))])     elements (EvData depth spelling _ value) nesting = do       record <- stood value       pure (nesting{_closing = kept}, closers ++ [indented depth record])

@@ -0,0 +1,791 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- The Haskell module 'phino compile' writes out of the rules of YAML: every+-- rewriting rule a function of the term it may match as a whole, answering+-- what it rewrites the term to, the normal form a test of whether any+-- built-in one matches anywhere, 𝒞 one function with an equation per rule+-- of 'resources/contextualization' (#1617), and every rule of 𝕄 and of 𝔻 a+-- function of the term and the universe it may match, answering the premises+-- it runs and the conclusion it comes to (#1628). A pattern becomes the+-- generators of a list comprehension, a meta the variable a generator binds,+-- a meta met twice a guard of equality, the 'when' of a rule a guard, a+-- function of its 'where' a binding, a premise a function of the answer it is+-- handed, and its result the constructors that build it. No substitution is+-- made and no template is filled, which is what a rule of YAML costs at every+-- step. What the module does is what the matcher, the builder and the+-- replacer do for the same rule, in the same order, so the steps a chain is+-- made of do not depend on which of the two ran; a rule the module could not+-- run that way is refused, with the reason.+module Emit (emitted) where++import AST+import Control.Monad (zipWithM)+import Data.Char (isAlphaNum, isDigit, toLower, toUpper)+import Data.List (intercalate, nub)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, isJust)+import qualified Data.Set as Set+import qualified Data.Text as T+import Deps (Judgment)+import qualified Inference as In+import Matcher (Meta (..))+import Rewriter (fast)+import Rule (redex)+import Text.Printf (printf)+import qualified Yaml as Y++-- What the emitter knows while it walks one rule: the variable every meta+-- matched so far is held in, and the number the next fresh variable takes.+data Scope = Scope (Map.Map Meta String) Int++-- A walk over one rule, which either writes a piece of Haskell or refuses the+-- rule, saying why.+newtype Emitting a = Emitting (Scope -> Either String (a, Scope))++instance Functor Emitting where+  fmap func (Emitting walk) = Emitting (fmap (\(value, scope) -> (func value, scope)) . walk)++instance Applicative Emitting where+  pure value = Emitting (\scope -> Right (value, scope))+  Emitting left <*> Emitting right = Emitting $ \scope -> do+    (func, scope') <- left scope+    (value, scope'') <- right scope'+    Right (func value, scope'')++instance Monad Emitting where+  Emitting walk >>= next = Emitting $ \scope -> do+    (value, scope') <- walk scope+    let Emitting walk' = next value+    walk' scope'++-- One qualifier of a list comprehension: a generator binding a pattern to+-- every element of a list, a guard, or a binding of a variable.+data Qual+  = Gen Pat String+  | Guard String+  | Let String String++-- A pattern a generator matches an element with.+data Pat+  = PVar String+  | PCon String [Pat]+  | PPair Pat Pat+  | PCons Pat Pat+  | PNil++-- The module of the given rules: the built-in rules of normalization, the+-- rules of '--rule', the rules of contextualization, of morphing and of+-- dataization, and the texts of the built-in rules the engine is compiled+-- from; or the reason one of the rules cannot be compiled.+emitted :: [Y.Rule] -> [Y.Rule] -> [Y.ContextualizeRule] -> [Y.MorphRule] -> [Y.DataizeRule] -> [String] -> Either String String+emitted builtin custom contextual morphs dataizes sources = do+  let rules = zip (named (map (.name) (builtin ++ custom))) (builtin ++ custom)+  functions <- mapM rewriting rules+  equations <- zipWithM contextualizing (named (map (.name) contextual)) contextual+  morphings <- zipWithM morphing (named (map (.name) morphs)) morphs+  dataizations <- zipWithM dataizing (named (map (.name) dataizes)) dataizes+  let body =+        unlines+          ( [ "compiled :: Maybe En.Engine"+            , "compiled ="+            , "  Just"+            , "    En.Engine"+            , "      { En._normalization = normalization"+            , "      , En._rules = steps"+            , "      , En._normal = nf"+            , "      , En._contextualize = \\term context -> either E.throwIO pure (contextualize term context)"+            , "      , En._morphing = morphings"+            , "      , En._dataization = dataizations"+            , "      , En._sources = sources"+            , "      }"+            , ""+            , "-- The steps of the built-in rules of normalization, in the order of the rules."+            , "normalization :: [Ru.Step]"+            , "normalization = " ++ listed (map (("step" ++) . fst) (take (length builtin) rules))+            , ""+            , "-- The steps of every rule compiled, by the text of the rule."+            , "steps :: Map.Map String Ru.Step"+            , "steps ="+            , "  Map.fromList " ++ listed [printf "(%s, step%s)" (show (show rule)) name | (name, rule) <- rules]+            , ""+            , "-- The rules of 𝕄, in the order of their files."+            , "morphings :: [In.Inference Expression]"+            , "morphings = " ++ listed (map ("In.direct morphing" ++) (named (map (.name) morphs)))+            , ""+            , "-- The rules of 𝔻, in the order of their files."+            , "dataizations :: [In.Inference Bytes]"+            , "dataizations = " ++ listed (map ("In.direct dataization" ++) (named (map (.name) dataizes)))+            , ""+            , "-- The texts of the built-in rules of all four judgments this module is made of."+            , "sources :: [String]"+            , "sources = " ++ listed (map show sources)+            , ""+            , "-- Whether the term is a normal form: no built-in rule of normalization"+            , "-- matches anywhere inside it."+            , "nf :: Expression -> Bool"+            , "nf ="+            , "  Ru.normalWith"+            , "    ( \\term ->"+            , "        " ++ intercalate "\n          || " [printf "M.anywhere %s (not . null . rewrite%s Nothing) term" (show (redex rule)) name | (name, rule) <- take (length builtin) rules]+            , "    )"+            , ""+            , "-- The Contextualization function 𝒞, the conclusion of the one rule matching"+            , "-- the term and the context."+            , "contextualize :: Expression -> Expression -> Either C.ContextualizeException Expression"+            , "contextualize term context ="+            , "  C.concluded"+            , "    term"+            , "    ( concat"+            , "        " ++ listed' 8 [printf "contextualize%s term context" name | name <- named (map (.name) contextual)]+            , "    )"+            , ""+            ]+              ++ functions+              ++ equations+              ++ morphings+              ++ dataizations+          )+  Right (header ++ imports body ++ "\n" ++ body)+  where+    header :: String+    header =+      unlines+        [ "-- The built-in rules of phino, and the rules of '--rule' it was given, as"+        , "-- Haskell: this module is written by 'phino compile' and a build with the"+        , "-- flag 'compiled' links it in (#1617). The next 'phino compile' writes it"+        , "-- anew, so a change belongs to the rules of YAML and not to it."+        , "module Compiled (compiled) where"+        , ""+        ]+    imports :: String -> String+    imports body =+      unlines+        ( "import AST"+            : [ line+              | (qualifier, line) <-+                  [ ("B.", "import qualified Builder as B")+                  , ("C.", "import qualified Contextualize as C")+                  , ("D.", "import qualified Deps as D")+                  , ("E.", "import qualified Control.Exception as E")+                  , ("En.", "import qualified Engine as En")+                  , ("In.", "import qualified Inference as In")+                  , ("M.", "import qualified Matcher as M")+                  , ("Map.", "import qualified Data.Map.Strict as Map")+                  , ("R.", "import qualified Rewriter as R")+                  , ("Ru.", "import qualified Rule as Ru")+                  , ("T.", "import qualified Data.Text as T")+                  ]+              , qualifier `elem` qualifiers body+              ]+        )+    qualifiers :: String -> [String]+    qualifiers body = [takeWhile (/= '.') word ++ "." | word <- words (map spaced body), '.' `elem` word, isUpperStart word]+    spaced :: Char -> Char+    spaced char+      | isAlphaNum char || char == '.' || char == '_' = char+      | otherwise = ' '+    isUpperStart :: String -> Bool+    isUpperStart (first : _) = first `elem` ['A' .. 'Z']+    isUpperStart [] = False++-- The names the functions of the rules go by, one per rule, told apart where+-- two rules carry the same name.+named :: [String] -> [String]+named names = zipWith unique [0 :: Int ..] (map camel names)+  where+    unique :: Int -> String -> String+    unique idx name+      | length (filter (== name) (map camel names)) > 1 = name ++ show idx+      | otherwise = name+    camel :: String -> String+    camel name = case filter isAlphaNum (concatMap upper (words (map (\char -> if isAlphaNum char then char else ' ') name))) of+      [] -> "Rule"+      word@(first : _)+        | isDigit first -> "Rule" ++ word+        | otherwise -> word+    upper :: String -> String+    upper (first : rest) = toUpper first : rest+    upper [] = []++-- The functions of one rewriting rule: its step and what it rewrites a term+-- matching it as a whole to. A normal form is asked of its '𝑛' and '𝑘' metas+-- the way the matcher asks it (see 'Ru.normalHeld'), so a term that is itself+-- a meta is no normal form under either engine.+rewriting :: (String, Y.Rule) -> Either String String+rewriting (name, rule) = do+  refused+  (quals, result) <- walked $ do+    pattern' <- matching rule.pattern "term"+    when' <- maybe (pure []) (fmap (pure . Guard) . condition) rule.when+    absolute <- mapM (fmap (\var -> Guard ("Ru.xiFree " ++ var)) . held) (prefixed "k" rule.pattern)+    normal <- mapM (fmap (\var -> Guard ("Ru.normalHeld nf " ++ var)) . held) (prefixed "n" rule.pattern ++ prefixed "k" rule.pattern)+    extras <- concat <$> mapM extended (fromMaybe [] rule.where_)+    result <- built True rule.result >>= maybe (refuse "its result names a meta its pattern does not bind") pure+    pure (pattern' ++ when' ++ absolute ++ normal ++ extras, result)+  let body = comprehension quals result+      universe = if "universe" `elem` tokens body then "universe" else "_"+  Right+    ( unlines+        [ printf "-- The rule '%s'." rule.name+        , printf "step%s :: Ru.Step" name+        , printf "step%s = R.direct %s %s rewrite%s" name (show rule.name) (show (redex rule)) name+        , ""+        , printf "rewrite%s :: Maybe Expression -> Expression -> [Expression]" name+        , printf "rewrite%s %s %s =" name universe (if "term" `elem` tokens body then "term" else "_")+        , body+        ]+    )+  where+    refused :: Either String ()+    refused+      | isJust rule.having = Left (printf "The rule '%s' cannot be compiled, since it has a 'having' condition" rule.name)+      | fast rule.pattern rule.result = Left (printf "The rule '%s' cannot be compiled, since it rewrites a formation into a formation the fast way" rule.name)+      | rooted rule.pattern = Left (printf "The rule '%s' cannot be compiled, since its pattern applies Φ to a ρ" rule.name)+      | otherwise = Right ()+    walked :: Emitting a -> Either String a+    walked (Emitting walk) = either (Left . printf "The rule '%s' cannot be compiled, since %s" rule.name) (Right . fst) (walk (Scope Map.empty 1))+    extended :: Y.Extra -> Emitting [Qual]+    extended extra = case (extra.meta, extra.function, extra.args) of+      (Y.ArgExpression (ExMeta meta), "contextualize", [Y.ArgExpression expr, Y.ArgExpression context]) -> do+        expr' <- argument expr+        context' <- argument context+        into meta (printf "either E.throw id (contextualize %s %s)" expr' context')+      (Y.ArgExpression (ExMeta meta), "named", [Y.ArgExpression expr]) -> do+        expr' <- argument expr+        into meta (printf "B.nameIn universe %s" expr')+      (_, func, _) -> refuse (printf "its 'where' calls the function '%s', which only 'contextualize' and 'named' can be" func)+    argument :: Expression -> Emitting String+    argument expr = built True expr >>= maybe (refuse "its 'where' names a meta its pattern does not bind") (pure . parens)+    into :: T.Text -> String -> Emitting [Qual]+    into meta value =+      known (Named meta) >>= \case+        Just var -> pure [Guard (printf "%s == %s" var (parens value))]+        Nothing -> do+          let var = variable (Named meta)+          bind (Named meta) var+          pure [Let var value]++-- The function of one contextualization rule: the conclusion it comes to for+-- a term and a context matching it, once for every way they match it, beside+-- its name. The letters '𝑛' and '𝑘' of these rules are only names, so no+-- normal form is asked of anything (see 'Contextualize').+contextualizing :: String -> Y.ContextualizeRule -> Either String String+contextualizing name rule = do+  (quals, result) <- walked $ do+    term <- matching rule.match "term"+    context <- matching rule.cmatch "context"+    premises <- mapM premised rule.premises+    result <- built True rule.cresult >>= maybe (refuse "its conclusion names a meta nothing binds") pure+    pure (term ++ context, conclusion premises result)+  let body = comprehension quals result+      arg var = if var `elem` tokens body then var else "_"+  Right+    ( unlines+        [ printf "-- The contextualization rule '%s'." rule.name+        , printf "contextualize%s :: Expression -> Expression -> [(String, Either C.ContextualizeException Expression)]" name+        , printf "contextualize%s %s %s =" name (arg "term") (arg "context")+        , body+        ]+    )+  where+    walked :: Emitting a -> Either String a+    walked (Emitting walk) = either (Left . printf "The contextualization rule '%s' cannot be compiled, since %s" rule.name) (Right . fst) (walk (Scope Map.empty 1))+    premised :: Y.Premise -> Emitting (String, String)+    premised (Y.Premise result (Y.OpContextualize inner outer)) = do+      inner' <- built True inner >>= maybe (refuse "a premise names a meta nothing binds") (pure . parens)+      outer' <- built True outer >>= maybe (refuse "a premise names a meta nothing binds") (pure . parens)+      var <- introduced result+      pure (var, printf "contextualize %s %s" inner' outer')+    premised premise = refuse (printf "its premise '%s' is not a contextualization" (T.unpack premise.result))+    conclusion :: [(String, String)] -> String -> String+    conclusion [] result = printf "(%s, Right %s)" (show rule.name) (parens result)+    conclusion premises result =+      printf+        "(%s, do { %s; pure %s })"+        (show rule.name)+        (intercalate "; " [printf "%s <- %s" var call | (var, call) <- premises])+        (parens result)++-- The function of one rule of 𝕄: what it comes to for a term and a universe+-- matching it, once for every way they match it (see 'inferring').+morphing :: String -> Y.MorphRule -> Either String String+morphing name rule = inferring "morphing" ("morphing" ++ name, "Expression") (Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing) rule.ematch (built True) (In.morphingSpine rule)++-- The function of one rule of 𝔻, the way 'morphing' writes one of 𝕄.+dataizing :: String -> Y.DataizeRule -> Either String String+dataizing name rule = inferring "dataization" ("dataization" ++ name, "Bytes") (Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing) rule.ematch builtBytes (In.dataizationSpine rule)++-- The function of one rule of 𝕄 or 𝔻, of the given kind, name and type of+-- answer: the premises it runs beside its spine, each a function of the answer+-- it is handed, and the conclusion it comes to, once for every way the term+-- and the universe match it, checked the way the matcher checks them — the+-- pattern of the universe against the universe first, then the pattern of the+-- rule against the term, its 'when', and its '𝑛' and '𝑘' metas (see+-- 'matchExpressionWithRule''). What the premises and the conclusion are is+-- read off the rule by 'Inference', the very way the engine of YAML reads it.+inferring :: forall value. String -> (String, String) -> Y.Rule -> Expression -> (value -> Emitting (Maybe String)) -> Either String ([Y.Premise], In.Conclusion value) -> Either String String+inferring kind (name, answer) rule ematch builder spine = do+  (sides, conclusion) <- either (Left . refusal) Right spine+  (quals, result) <- walked $ do+    universe <- matching ematch "universe"+    term <- matching rule.pattern "term"+    when' <- maybe (pure []) (fmap (pure . Guard) . condition) rule.when+    absolute <- mapM (fmap (\var -> Guard ("Ru.xiFree " ++ var)) . held) (prefixed "k" rule.pattern)+    normal <- mapM (fmap (\var -> Guard ("Ru.normalHeld nf " ++ var)) . held) (prefixed "n" rule.pattern ++ prefixed "k" rule.pattern)+    result <- premised sides conclusion+    pure (universe ++ term ++ when' ++ absolute ++ normal, result)+  let body = comprehension quals result+      arg var = if var `elem` tokens body then var else "_"+  Right+    ( unlines+        [ printf "-- The %s rule '%s'." kind rule.name+        , printf "%s :: Expression -> Expression -> [In.Premises %s]" name answer+        , printf "%s %s %s =" name (arg "term") (arg "universe")+        , body+        ]+    )+  where+    refusal :: String -> String+    refusal = printf "The %s rule '%s' cannot be compiled, since %s" kind rule.name+    walked :: Emitting a -> Either String a+    walked (Emitting walk) = either (Left . refusal) (Right . fst) (walk (Scope Map.empty 1))+    premised :: [Y.Premise] -> In.Conclusion value -> Emitting String+    premised [] conclusion = ("In.Concludes " ++) . parens <$> concluded conclusion+    premised (premise : rest) conclusion = do+      (constructor, first, second) <- case premise.operation of+        Y.OpMorph expr world -> (,,) "In.Morphs" <$> argued "a premise" expr <*> argued "a premise" world+        Y.OpEvaluate expr world -> (,,) "In.Evaluates" <$> argued "a premise" expr <*> argued "a premise" world+        Y.OpContextualize expr context -> (,,) "In.Contextualizes" <$> argued "a premise" expr <*> argued "a premise" context+        _ -> refuse (printf "its premise '%s' runs beside the spine, which only a 'morph', an 'evaluate' or a 'contextualize' can" (T.unpack premise.result))+      var <- introduced premise.result+      next <- premised rest conclusion+      pure (printf "%s %s %s (\\%s -> pure %s)" constructor first second (if var `elem` tokens next then var else "_") (parens next))+    concluded :: In.Conclusion value -> Emitting String+    concluded (In.Answered step value) = printf "In.Answered %s %s" (stepped step) . parens <$> (builder value >>= maybe (refuse "its conclusion names a meta nothing binds") pure)+    concluded (In.Onward way expr world) = printf "In.Onward %s %s %s" <$> (parens <$> wayOf way) <*> argued "its conclusion" expr <*> argued "its conclusion" world+    wayOf :: In.Way -> Emitting String+    wayOf (In.Taken step) = pure ("In.Taken " ++ stepped step)+    wayOf (In.Normalized step) = pure ("In.Normalized " ++ stepped step)+    wayOf (In.Named step) = pure ("In.Named " ++ stepped step)+    wayOf (In.Staged stage) = ("In.Staged " ++) <$> argued "its conclusion" stage+    argued :: String -> Expression -> Emitting String+    argued place expr = built True expr >>= maybe (refuse (printf "%s names a meta nothing binds" place)) (pure . parens)+    stepped :: (Judgment, String) -> String+    stepped (judgment, verb) = printf "(D.%s, %s)" (show judgment) (show verb)++-- The comprehension of the qualifiers and the result, every variable a+-- generator binds and nothing after it reads written as a wildcard and every+-- binding nothing reads dropped, so the module compiles without a warning.+comprehension :: [Qual] -> String -> String+comprehension quals result = case fst (foldr written ([], Set.fromList (tokens result)) quals) of+  [] -> "  [" ++ result ++ "]"+  first : rest -> "  [ " ++ result ++ "\n  | " ++ first ++ concatMap ("\n  , " ++) rest ++ "\n  ]"+  where+    written :: Qual -> ([String], Set.Set String) -> ([String], Set.Set String)+    written (Gen pat source) (lines', used) = ((pattern' used pat ++ " <- " ++ source) : lines', grown source used)+    written (Guard guard) (lines', used) = (guard : lines', grown guard used)+    written (Let var value) (lines', used)+      | var `Set.member` used = (("let " ++ var ++ " = " ++ value) : lines', grown value used)+      | otherwise = (lines', used)+    grown :: String -> Set.Set String -> Set.Set String+    grown text used = foldr Set.insert used (tokens text)+    pattern' :: Set.Set String -> Pat -> String+    pattern' used (PVar var)+      | var `Set.member` used = var+      | otherwise = "_"+    pattern' _ (PCon con []) = con+    pattern' used (PCon con pats) = con ++ " " ++ unwords (map (atomic used) pats)+    pattern' used (PPair left right) = "(" ++ pattern' used left ++ ", " ++ pattern' used right ++ ")"+    pattern' used (PCons first rest) = "(" ++ pattern' used first ++ " : " ++ pattern' used rest ++ ")"+    pattern' _ PNil = "[]"+    atomic :: Set.Set String -> Pat -> String+    atomic used pat@(PCon _ (_ : _)) = "(" ++ pattern' used pat ++ ")"+    atomic used pat = pattern' used pat++-- The words of a piece of Haskell, which is how the emitter tells whether a+-- variable is read after it was bound.+tokens :: String -> [String]+tokens = words . map (\char -> if isAlphaNum char || char == '_' || char == '\'' then char else ' ')++-- The generators and guards matching the pattern against the term the+-- variable holds, in the order the matcher matches it (see 'matchExpression''):+-- the attribute of a dispatch before its head, the head of an application+-- before its argument, and the bindings of a formation left to right.+matching :: Expression -> String -> Emitting [Qual]+matching (ExMeta meta) var = meta' (Named meta) var+matching (ExAny slot) var = meta' (Anon slot) var+matching ExXi var = pure [Gen (PCon "ExXi" []) (single var)]+matching ExRoot var = pure [Gen (PCon "ExRoot" []) (single var)]+matching ExTermination var = pure [Gen (PCon "ExTermination" []) (single var)]+matching (ExFormation bds) var = do+  inner <- fresh+  rest <- bindings bds inner+  pure (Gen (PCon "ExFormation" [PVar inner]) (single var) : rest)+matching (ExDispatch expr attr) var = do+  head' <- fresh+  attr' <- fresh+  attribute' <- attribute attr attr'+  expression <- matching expr head'+  pure (Gen (PCon "ExDispatch" [PVar head', PVar attr']) (single var) : attribute' ++ expression)+matching (ExApplication expr (ArTau attr arg)) var = do+  head' <- fresh+  attr' <- fresh+  arg' <- fresh+  attribute' <- attribute attr attr'+  expression <- matching expr head'+  argument <- matching arg arg'+  pure (Gen (PCon "ExApplication" [PVar head', PCon "ArTau" [PVar attr', PVar arg']]) (single var) : attribute' ++ expression ++ argument)+matching (ExApplication expr (ArAlpha alpha arg)) var = do+  head' <- fresh+  alpha' <- fresh+  arg' <- fresh+  expression <- matching expr head'+  index <- indexed alpha alpha'+  argument <- matching arg arg'+  pure (Gen (PCon "ExApplication" [PVar head', PCon "ArAlpha" [PVar alpha', PVar arg']]) (single var) : expression ++ index ++ argument)+matching expr _ = refuse (printf "its pattern holds the term '%s', which only a rule of YAML can match" (show expr))++-- The generators and guards matching the bindings of a pattern against the+-- list the variable holds, a meta binding trying every leading run of it,+-- the shortest first, and taking the whole rest where it is the last one (see+-- 'matchBindingsMeta').+bindings :: [Binding] -> String -> Emitting [Qual]+bindings [] var = pure [Gen PNil (single var)]+bindings [BiMeta meta] var = meta' (Named meta) var+bindings [BiAny _] _ = pure []+bindings (BiMeta meta : rest) var = do+  before <- fresh+  after <- fresh+  bound <- meta' (Named meta) before+  others <- bindings rest after+  pure (Gen (PPair (PVar before) (PVar after)) ("M.splits " ++ var) : bound ++ others)+bindings (BiAny _ : rest) var = do+  after <- fresh+  others <- bindings rest after+  pure (Gen (PPair (PVar "_") (PVar after)) ("M.splits " ++ var) : others)+bindings (bd : rest) var = do+  first <- fresh+  after <- fresh+  binding' <- binding bd first+  others <- bindings rest after+  pure (Gen (PCons (PVar first) (PVar after)) (single var) : binding' ++ others)++-- The generators and guards matching one binding of a pattern against the+-- binding the variable holds (see 'matchBinding').+binding :: Binding -> String -> Emitting [Qual]+binding (BiVoid attr) var = do+  attr' <- fresh+  attribute' <- attribute attr attr'+  pure (Gen (PCon "BiVoid" [PVar attr']) (single var) : attribute')+binding (BiTau attr expr) var = do+  attr' <- fresh+  expr' <- fresh+  attribute' <- attribute attr attr'+  expression <- matching expr expr'+  pure (Gen (PCon "BiTau" [PVar attr', PVar expr']) (single var) : attribute' ++ expression)+binding (BiDelta (BtMeta meta)) var = do+  data' <- fresh+  bound <- meta' (Named meta) data'+  pure (Gen (PCon "BiDelta" [PVar data']) (single var) : bound)+binding (BiDelta (BtAny _)) var = pure [Gen (PCon "BiDelta" [PVar "_"]) (single var)]+binding (BiDelta bts) var = do+  data' <- fresh+  pure [Gen (PCon "BiDelta" [PVar data']) (single var), Guard (printf "%s == %s" data' (parens (show bts)))]+binding (BiLambda (FnMeta meta)) var = do+  func <- fresh+  bound <- meta' (Named meta) func+  pure (Gen (PCon "BiLambda" [PVar func]) (single var) : Guard ("M.named " ++ func) : bound)+binding (BiLambda (FnAny _)) var = do+  func <- fresh+  pure [Gen (PCon "BiLambda" [PVar func]) (single var), Guard ("M.named " ++ func)]+binding (BiLambda (FnFresh _)) _ = refuse "its pattern asks for a fresh symbol"+binding (BiLambda func) var = do+  func' <- fresh+  literal <- function func+  pure [Gen (PCon "BiLambda" [PVar func']) (single var), Guard (printf "%s == %s" func' literal)]+binding bd _ = refuse (printf "its pattern holds the binding '%s' where a single binding stands" (show bd))++-- The guards matching an attribute of a pattern against the attribute the+-- variable holds (see 'matchAttribute').+attribute :: Attribute -> String -> Emitting [Qual]+attribute (AtMeta meta) var = meta' (Named meta) var+attribute (AtAny _) _ = pure []+attribute attr var = (\literal -> [Guard (printf "%s == %s" var literal)]) <$> attributed attr++-- The generators and guards matching an index of a pattern against the one+-- the variable holds, which a meta matches only where it is a number (see+-- 'matchAlpha').+indexed :: Alpha -> String -> Emitting [Qual]+indexed (AlMeta meta) var = do+  index <- fresh+  bound <- meta' (Named meta) index+  pure (Gen (PCon "Alpha" [PVar index]) (single var) : bound)+indexed (AlAny _) var = pure [Gen (PCon "Alpha" [PVar "_"]) (single var)]+indexed (Alpha idx) var = pure [Guard (printf "%s == Alpha %d" var idx)]++-- A meta matched against what the variable holds: bound to it the first time,+-- and asked to equal what it was bound to every time after.+meta' :: Meta -> String -> Emitting [Qual]+meta' key var =+  known key >>= \case+    Just bound -> pure [Guard (printf "%s == %s" bound var)]+    Nothing -> bind key var >> pure []++-- The metas of the pattern a normal form or an absolute term is asked of,+-- '𝑛' or '𝑘' by the prefix, in the order they are met (see 'metasWithPrefix').+prefixed :: String -> Expression -> [Meta]+prefixed prefix = nub . go+  where+    go :: Expression -> [Meta]+    go (ExMeta meta)+      | T.pack prefix `T.isPrefixOf` meta = [Named meta]+    go (ExAny slot@(Slot kind _))+      | T.pack prefix `T.isPrefixOf` kind = [Anon slot]+    go (ExFormation bds) = concat [go expr | BiTau _ expr <- bds]+    go (ExApplication expr (ArTau _ arg)) = go expr ++ go arg+    go (ExApplication expr (ArAlpha _ arg)) = go expr ++ go arg+    go (ExDispatch expr _) = go expr+    go _ = []++-- The Haskell of a condition, which holds exactly where the condition of the+-- rule does (see 'meetCondition'''): a condition naming a meta the pattern+-- does not bind never holds.+condition :: Y.Condition -> Emitting String+condition (Y.And conds) = parens . intercalate " && " <$> mapM condition conds+condition (Y.Or conds) = parens . intercalate " || " <$> mapM condition conds+condition (Y.Not cond) = ("not " ++) . parens <$> condition cond+condition (Y.In attrs bds) = present True attrs bds+condition (Y.Disjoint attrs bds) = present False attrs bds+condition (Y.Eq (Y.CmpNum left) (Y.CmpNum right)) = compared "==" <$> number left <*> number right+condition (Y.Gt (Y.CmpNum left) (Y.CmpNum right)) = compared ">" <$> number left <*> number right+condition (Y.Eq (Y.CmpAttr left) (Y.CmpAttr right)) = compared "==" <$> attr' left <*> attr' right+  where+    attr' :: Attribute -> Emitting (Maybe String)+    attr' (AtMeta meta) = known (Named meta)+    attr' (AtAny _) = pure Nothing+    attr' attr = Just <$> attributed attr+condition (Y.Eq (Y.CmpExpr left) (Y.CmpExpr right)) = compared "==" <$> built False left <*> built False right+condition (Y.Eq _ _) = pure "False"+condition (Y.Gt _ _) = pure "False"+condition (Y.NF expr) = asked "Ru.normalHeld nf" expr+condition (Y.Absolute expr) = asked "Ru.xiFree" expr+condition (Y.IsFormation (ExMeta meta)) = maybe "False" ("Ru.isFormation " ++) <$> known (Named meta)+condition (Y.IsFormation (ExFormation _)) = pure "True"+condition (Y.IsFormation _) = pure "False"+condition (Y.Matches _ _) = refuse "its condition 'matches' needs a run of dataization"+condition (Y.PartOf _ _) = refuse "its condition 'part-of' is not compiled yet"++-- A condition asking whether the attributes are present among the bindings+-- the metas hold, all of them or none of them, which never holds where an+-- attribute or a binding cannot be worked out.+present :: Bool -> [Attribute] -> [Binding] -> Emitting String+present every attrs bds = do+  attrs' <- mapM attr' attrs+  bds' <- mapM bindingsOf bds+  pure $+    if all isJust attrs' && all isJust bds'+      then (if every then id else ("not " ++) . parens) (printf "%s (`Ru.presentIn` concat %s) %s" (if every then "all" else "any") (listed (map (fromMaybe "") bds')) (listed (map (fromMaybe "") attrs')))+      else "False"+  where+    attr' :: Attribute -> Emitting (Maybe String)+    attr' (AtMeta meta) = known (Named meta)+    attr' (AtAny _) = pure Nothing+    attr' attr = Just <$> attributed attr+    bindingsOf :: Binding -> Emitting (Maybe String)+    bindingsOf (BiMeta meta) = known (Named meta)+    bindingsOf (BiAny _) = pure Nothing+    bindingsOf bd = fmap listed . sequence <$> mapM (builtBinding False) [bd]++-- A condition asking a question of the term a meta holds.+asked :: String -> Expression -> Emitting String+asked question (ExMeta meta) = maybe "False" ((question ++ " ") ++) <$> known (Named meta)+asked question (ExAny slot) = maybe "False" ((question ++ " ") ++) <$> known (Anon slot)+asked _ _ = refuse "its condition asks about a term that is no meta"++-- The comparison of the two sides, which never holds where either of them+-- cannot be worked out.+compared :: String -> Maybe String -> Maybe String -> String+compared operator (Just left) (Just right) = printf "%s %s %s" (parens left) operator (parens right)+compared _ _ _ = "False"++-- The Haskell of a number of a condition, where it can be worked out (see+-- 'numToInt').+number :: Y.Number -> Emitting (Maybe String)+number (Y.MetaIndex meta) = known (Named meta)+number (Y.Length (BiMeta meta)) = fmap ("length " ++) <$> known (Named meta)+number (Y.Domain (BiMeta meta)) = fmap ("Ru.domainOf " ++) <$> known (Named meta)+number (Y.Literal num) = pure (Just (show num))+number _ = pure Nothing++-- The Haskell building the term of a template out of the metas bound, the way+-- 'buildExpression' builds it, or nothing where a meta of it is not bound. A+-- formation is checked to carry no attribute twice where the flag says so,+-- which is what a result and a function of 'where' are built with, and a+-- condition is not.+built :: Bool -> Expression -> Emitting (Maybe String)+built _ (ExMeta meta) = known (Named meta)+built _ ExXi = pure (Just "ExXi")+built _ ExRoot = pure (Just "ExRoot")+built _ ExTermination = pure (Just "ExTermination")+built checked (ExApplication ExRoot (ArTau AtRho expr)) = fmap (const "ExRoot") <$> built checked expr+built checked (ExFormation bds) = do+  parts <- mapM part bds+  pure (formation <$> sequence parts)+  where+    part :: Binding -> Emitting (Maybe (Either String String))+    part (BiMeta meta) = fmap Left <$> known (Named meta)+    part bd = fmap Right <$> builtBinding checked bd+    formation :: [Either String String] -> String+    formation [Left var] = constructor ++ " " ++ var+    formation parts = constructor ++ " " ++ parens (joined parts)+    joined :: [Either String String] -> String+    joined parts+      | all isRight parts = listed [bd | Right bd <- parts]+      | otherwise = "concat " ++ listed (map (either id (\bd -> "[" ++ bd ++ "]")) parts)+    isRight :: Either String String -> Bool+    isRight (Right _) = True+    isRight (Left _) = False+    constructor :: String+    constructor = if checked then "B.formed" else "ExFormation"+built checked (ExDispatch expr attr) = do+  expr' <- built checked expr+  attr' <- builtAttribute attr+  pure (printf "ExDispatch %s %s" <$> fmap parens expr' <*> fmap parens attr')+built checked (ExApplication expr (ArTau attr arg)) = do+  expr' <- built checked expr+  attr' <- builtAttribute attr+  arg' <- built checked arg+  pure (printf "ExApplication %s (ArTau %s %s)" <$> fmap parens expr' <*> fmap parens attr' <*> fmap parens arg')+built checked (ExApplication expr (ArAlpha alpha arg)) = do+  expr' <- built checked expr+  alpha' <- builtAlpha alpha+  arg' <- built checked arg+  pure (printf "ExApplication %s (ArAlpha %s %s)" <$> fmap parens expr' <*> fmap parens alpha' <*> fmap parens arg')+built _ expr = refuse (printf "it builds the term '%s', which only a rule of YAML can build" (show expr))++-- The Haskell building one binding of a template (see 'built').+builtBinding :: Bool -> Binding -> Emitting (Maybe String)+builtBinding checked (BiTau attr expr) = do+  attr' <- builtAttribute attr+  expr' <- built checked expr+  pure (printf "BiTau %s %s" <$> fmap parens attr' <*> fmap parens expr')+builtBinding _ (BiVoid attr) = fmap (("BiVoid " ++) . parens) <$> builtAttribute attr+builtBinding _ (BiDelta (BtMeta meta)) = fmap ("BiDelta " ++) <$> known (Named meta)+builtBinding _ (BiDelta (BtAny _)) = pure Nothing+builtBinding _ (BiDelta bts) = pure (Just ("BiDelta " ++ parens (show bts)))+builtBinding _ (BiLambda (FnMeta meta)) = fmap ("BiLambda " ++) <$> known (Named meta)+builtBinding _ (BiLambda (FnAny _)) = pure Nothing+builtBinding _ (BiLambda (FnFresh _)) = refuse "it builds a fresh symbol"+builtBinding _ (BiLambda func) = Just . ("BiLambda " ++) . parens <$> function func+builtBinding _ bd = refuse (printf "it builds the binding '%s'" (show bd))++-- The Haskell of the data of a template (see 'buildBytes').+builtBytes :: Bytes -> Emitting (Maybe String)+builtBytes (BtMeta meta) = known (Named meta)+builtBytes (BtAny slot) = known (Anon slot)+builtBytes bts = pure (Just (parens (show bts)))++-- The Haskell of an attribute of a template (see 'buildAttribute').+builtAttribute :: Attribute -> Emitting (Maybe String)+builtAttribute (AtMeta meta) = known (Named meta)+builtAttribute (AtAny _) = pure Nothing+builtAttribute attr = Just <$> attributed attr++-- The Haskell of an index of a template (see 'buildAlpha').+builtAlpha :: Alpha -> Emitting (Maybe String)+builtAlpha (AlMeta meta) = fmap ("Alpha " ++) <$> known (Named meta)+builtAlpha (AlAny _) = pure Nothing+builtAlpha (Alpha idx) = pure (Just (printf "Alpha %d" idx))++-- The Haskell of an attribute no meta stands for.+attributed :: Attribute -> Emitting String+attributed (AtLabel label) = pure (printf "AtLabel (%s)" (texted label))+attributed AtPhi = pure "AtPhi"+attributed AtRho = pure "AtRho"+attributed AtLambda = pure "AtLambda"+attributed AtDelta = pure "AtDelta"+attributed attr = refuse (printf "it holds the attribute '%s' where a literal one stands" (show attr))++-- The Haskell of a λ function no meta stands for.+function :: Function -> Emitting String+function (Function name) = pure (printf "Function (%s)" (texted name))+function (FnSymbol idx) = pure (printf "FnSymbol %d" idx)+function func = refuse (printf "it holds the λ function '%s' where a literal one stands" (show func))++-- The Haskell of a text.+texted :: T.Text -> String+texted text = "T.pack " ++ show (T.unpack text)++-- Whether the pattern applies Φ to a ρ anywhere, which the builder turns into+-- Φ alone, so the place the matcher matched is not the term the replacer+-- looks for (see 'buildExpression').+rooted :: Expression -> Bool+rooted (ExApplication ExRoot (ArTau AtRho _)) = True+rooted (ExApplication expr (ArTau _ arg)) = rooted expr || rooted arg+rooted (ExApplication expr (ArAlpha _ arg)) = rooted expr || rooted arg+rooted (ExDispatch expr _) = rooted expr+rooted (ExFormation bds) = or [rooted expr | BiTau _ expr <- bds]+rooted _ = False++-- The variable a meta is held in where the pattern bound it.+known :: Meta -> Emitting (Maybe String)+known key = Emitting (\scope@(Scope bound _) -> Right (Map.lookup key bound, scope))++-- The variable a meta is held in, where the pattern bound it, or a refusal.+held :: Meta -> Emitting String+held key = known key >>= maybe (refuse "it asks a normal form of a meta its pattern does not bind") pure++-- Remember the variable a meta is held in.+bind :: Meta -> String -> Emitting ()+bind key var = Emitting (\(Scope bound next) -> Right ((), Scope (Map.insert key var bound) next))++-- A variable no meta and no other variable of the rule is held in.+fresh :: Emitting String+fresh = Emitting (\(Scope bound next) -> Right ("x" ++ show next, Scope bound (next + 1)))++-- The variable a premise binds its meta in, which neither the pattern nor a+-- premise before it may have bound.+introduced :: T.Text -> Emitting String+introduced result =+  known (Named result) >>= \case+    Just _ -> refuse (printf "its premise '%s' binds a meta bound already" (T.unpack result))+    Nothing -> do+      let var = variable (Named result)+      bind (Named result) var+      pure var++-- A refusal of the rule, saying why.+refuse :: String -> Emitting a+refuse reason = Emitting (const (Left reason))++-- The variable a meta a rule binds by itself is held in, named after the+-- meta where its name is a plain one.+variable :: Meta -> String+variable (Named meta) = case T.unpack meta of+  first : rest | all isDigit rest -> toLower first : rest+  name -> "m_" ++ map (\char -> if isAlphaNum char then char else '_') name+variable (Anon (Slot kind offset)) = printf "a_%s%d" (T.unpack kind) offset++-- A list of one element.+single :: String -> String+single var = "[" ++ var ++ "]"++-- The Haskell of a list of the elements.+listed :: [String] -> String+listed items = "[" ++ intercalate ", " items ++ "]"++-- The same, one element per line, indented by the given number of spaces.+listed' :: Int -> [String] -> String+listed' _ [] = "[]"+listed' indent items = "[ " ++ intercalate ("\n" ++ replicate indent ' ' ++ ", ") items ++ "\n" ++ replicate indent ' ' ++ "]"++-- The piece of Haskell in parentheses, unless it is one word.+parens :: String -> String+parens text+  | all (\char -> isAlphaNum char || char == '_' || char == '\'') text = text+  | otherwise = "(" ++ text ++ ")"

@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedRecordDot #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- What runs the built-in rules of the calculus: the rewriting steps of+-- normalization, the answer to whether a term is a normal form, the+-- Contextualization function 𝒞 and the rules of 𝕄 and 𝔻. The engine of 'yaml'+-- interprets the rules as they are written, the way phino always has; 'phino+-- compile' writes the Haskell of another one into the module 'Compiled', which+-- a build with the flag 'compiled' links in (#1617, #1628). Nothing in the library reaches for either+-- of them: the command line picks one and hands it down through the contexts,+-- the way it hands down '_buildTerm'.+module Engine (Engine (..), building, current, fresh, stepOf, yaml) where++import AST+import Contextualize (contextualize)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Deps (BuildTermFunc)+import Functions (buildTerm, contextualizing)+import Inference (Inference, dataizationOf, morphingOf)+import Rewriter (interpreted)+import Rule (Step, normal)+import qualified Yaml as Y++-- One engine of the built-in rules: the steps normalization takes, in the+-- order of the rules; the steps of any other rewriting rule it knows how to+-- take, by the text of the rule (see 'stepOf'); whether a term is a normal+-- form; 𝒞; the rules of 𝕄 and of 𝔻, in the order of their files (see+-- 'Inference'); and the texts of the built-in rules it was made from, which+-- tell whether it still runs the rules phino carries (see 'fresh').+data Engine = Engine+  { _normalization :: [Step]+  , _rules :: Map String Step+  , _normal :: Expression -> Bool+  , _contextualize :: Expression -> Expression -> IO Expression+  , _morphing :: [Inference Expression]+  , _dataization :: [Inference Bytes]+  , _sources :: [String]+  }++-- The engine interpreting the rules of YAML.+yaml :: Engine+yaml = Engine (map interpreted Y.normalizationRules) Map.empty normal contextualize (map morphingOf Y.morphingRules) (map dataizationOf Y.dataizationRules) current++-- The step the engine takes for the rewriting rule: the one it was compiled+-- to, where the engine was compiled from this very rule, and the interpreted+-- one otherwise, so a rule of '--rule' changed after 'phino compile' still+-- runs as it is written.+stepOf :: Engine -> Y.Rule -> Step+stepOf engine rule = fromMaybe (interpreted rule) (Map.lookup (show rule) engine._rules)++-- The texts of the built-in rules phino carries, of all four judgments.+current :: [String]+current =+  map show Y.normalizationRules+    ++ map show Y.contextualizationRules+    ++ map show Y.morphingRules+    ++ map show Y.dataizationRules++-- Whether the engine runs the built-in rules phino carries, and not the ones+-- it carried when the engine was compiled.+fresh :: Engine -> Bool+fresh engine = engine._sources == current++-- The term builder the functions of a rule run with, whose 'contextualize' is+-- the 𝒞 of the engine.+building :: Engine -> BuildTermFunc+building engine "contextualize" = contextualizing engine._contextualize+building _ func = buildTerm func

@@ -17,21 +17,21 @@ module Evaluate (evaluation, fired) where  import AST-import Builder (buildExpressionThrows, contextualize)+import Builder (buildExpressionThrows) import Control.Exception (throwIO, try) import Control.Monad (foldM, unless) import Data.List (partition) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromMaybe, isNothing, listToMaybe) import qualified Data.Text as T-import Deps (BuildTermMethodS, Evaluation (..), State (..), Term (..))+import Deps (Evaluation (..), State (..))+import Engine (Engine (..)) import Lambdas (Lambda (..), Meta (..), joined, matched, minted, symbolized) import Matcher (MetaValue (..), Subst, combine, substEmpty, substSingle, substSlot) import Morph (Answer, Kept (..), ReduceContext (..), ReduceException (..), Steps (..), charged, counted, deeper, enter, isLambda, lambda, morph', morphing, normalized, recalled, retained, starved, unparked) import Printer (printFunction) import Rule (RuleContext (RuleContext), matchExpressionWithRule') import Text.Printf (printf)-import Yaml (ExtraArgument (..)) import qualified Yaml as Y  -- The Evaluation function 𝔼(b, e, s): it fires the λ function of a formation@@ -57,22 +57,19 @@ -- a λ 𝔼 cannot make sense of fails — several of them, or one standing for a -- meta or a slot — since a rule naming such a binding meant something phino -- cannot work out (see 'lambda').-evaluation :: ReduceContext -> State -> BuildTermMethodS-evaluation ctx state [ArgExpression expr, ArgExpression universe] subst = do-  form <- buildExpressionThrows expr subst-  univ <- buildExpressionThrows universe subst-  case form of-    ExFormation bds-      | not (any isLambda bds) -> pure (TeExpression ExTermination, state)-      | otherwise -> case lambda bds of-          Just (func, args) -> do-            (raw, state') <- symbol func form args univ state ctx-            (normal, _) <- normalized raw ((univ, Nothing) :| []) ctx-            pure (TeExpression normal, state')-          Nothing -> case unknown bds of-            Just idx -> stuck idx form-            Nothing -> throwIO (userError "Function evaluate() expects a formation with a single λ binding naming a function")-    _ -> throwIO (userError "Function evaluate() expects a formation")+evaluation :: ReduceContext -> State -> Expression -> Expression -> IO (Expression, State)+evaluation ctx state form univ = case form of+  ExFormation bds+    | not (any isLambda bds) -> pure (ExTermination, state)+    | otherwise -> case lambda bds of+        Just (func, args) -> do+          (raw, state') <- symbol func form args univ state ctx+          (normal, _) <- normalized raw ((univ, Nothing) :| []) ctx+          pure (normal, state')+        Nothing -> case unknown bds of+          Just idx -> stuck idx form+          Nothing -> throwIO (userError "Function evaluate() expects a formation with a single λ binding naming a function")+  _ -> throwIO (userError "Function evaluate() expects a formation")   where     -- The symbol the one λ binding of a formation names, where that is what it     -- names. It is the one λ 'lambda' refuses that 𝔼 still has an answer for,@@ -89,14 +86,13 @@     -- symbol is spelled with everywhere else, so a reader joining the record to     -- the term it came from compares two strings that look alike, and it is     -- written once however many times the walk comes back to it (see '_parked').-    stuck :: Int -> Expression -> IO (Term, State)+    stuck :: Int -> Expression -> IO (Expression, State)     stuck idx form = do       unless (name `elem` ctx._parked) (ctx._saveEval (EvStuck ctx._nesting name ctx._judgment form))       throwIO (Stuck name)       where         name :: T.Text         name = T.pack (printFunction (FnSymbol idx))-evaluation _ _ _ _ = throwIO (userError "Function evaluate() requires exactly 2 expression arguments")  -- phino implements no λ function of its own. Which ones exist is a property of -- the object model being reduced, not of the calculus, so they come from the@@ -123,8 +119,9 @@ -- it again and again answers nothing, and a reader counting the 'unanswered(…)' -- lines counts the sites 𝔼 got stuck on rather than the passes the walk made -- over them (see '_parked', #1300). A firing an entry answers is charged to the--- '--max-firings' budget before it writes anything, so a run that spent the--- budget leaves no firing open in the protocol (see 'charged', #1472).+-- '--max-firings' and '--max-seconds' budgets before it writes anything, so a+-- run that spent either leaves no firing open in the protocol (see 'charged',+-- #1472, #1607). -- -- A formation the run has fired already is not fired again where '_memo' -- keeps what it answered (see 'Memo' in 'Morph'): the answer comes back as@@ -246,7 +243,8 @@     -- on and a 'join' line one side of which reaches ⊥ names it (see 'paired').     down :: ReduceContext -> (Subst, State, [Either Int Bytes]) -> (Meta, Expression) -> IO (Subst, State, [Either Int Bytes])     down ctx (bound, state', conditions) (meta, term) = do-      (value, state'') <- unparked (ctx._reduce univ ctx (operand term) state'{_manufactured = Nothing, _stuck = Nothing})+      placed <- operand term+      (value, state'') <- unparked (ctx._reduce univ ctx placed state'{_manufactured = Nothing, _stuck = Nothing})       case value of         Nothing -> throwIO (Stuck (fromMaybe func state''._stuck))         Just bytes -> do@@ -260,7 +258,8 @@     -- is how a firing hands its own unknowns on.     through :: ReduceContext -> (Subst, State) -> (Meta, Expression) -> IO (Subst, State)     through ctx (bound, state') (meta, term) = do-      (normal, state'') <- morphing univ ctx (operand term) state'+      placed <- operand term+      (normal, state'') <- morphing univ ctx placed state'       ctx._saveEval (EvTerm ctx._nesting meta._spelling term normal)       bound' <- bind meta (MvExpression normal) bound       pure (bound', state'')@@ -275,7 +274,7 @@     reshaped :: ReduceContext -> Subst -> (Meta, (Meta, [Y.Rule])) -> IO Subst     reshaped ctx bound (meta, (source, rules)) = do       term <- buildExpressionThrows (ExMeta source._name) bound-      shaped <- rewritten rules (RuleContext ctx._buildTerm Nothing) term+      shaped <- rewritten rules (RuleContext ctx._buildTerm Nothing ctx._engine._normal) term       ctx._saveEval (EvSymbolize ctx._nesting meta._spelling (ExMeta source._name) shaped)       bind meta (MvExpression shaped) bound     -- Stand the data of a term another line of the entry has bound into@@ -401,8 +400,8 @@     -- The operand an entry wrote, in the scope it is reduced in: ξ stands for     -- the formation being fired, so '$.x' is the x of it, and the calculus does     -- the reaching.-    operand :: Expression -> Expression-    operand = (`contextualize` self)+    operand :: Expression -> IO Expression+    operand term = caller._engine._contextualize term self     bind :: Meta -> MetaValue -> Subst -> IO Subst     bind meta value bound = case combine (substSingle meta._name value) bound of       Just bound' -> pure bound'

@@ -3,11 +3,12 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Functions (buildTerm, buildFunctions, execFunctions, nameOf) where+module Functions (buildTerm, buildFunctions, contextualizing, execFunctions, nameOf) where  import AST import Builder import Bytes (btsSize, btsToNum, btsToUnescapedStr, numToBts, strToBts)+import Contextualize (contextualize) import Control.Exception (throwIO) import Control.Monad (when) import qualified Data.ByteString.Char8 as B@@ -73,11 +74,16 @@     _ -> throwIO (userError (printf "Expected 8 bytes for a number, got %d" (btsSize bts)))  _contextualize :: BuildTermMethod-_contextualize [Y.ArgExpression expr, Y.ArgExpression context] subst = do+_contextualize = contextualizing contextualize++-- The 'contextualize' function of a rule, carried out by the given 𝒞: the+-- one of YAML or the one 'phino compile' wrote (#1617).+contextualizing :: (Expression -> Expression -> IO Expression) -> BuildTermMethod+contextualizing judgment [Y.ArgExpression expr, Y.ArgExpression context] subst = do   expr' <- buildExpressionThrows expr subst   context' <- buildExpressionThrows context subst-  pure (TeExpression (contextualize expr' context'))-_contextualize _ _ = throwIO (userError "Function contextualize() requires exactly 2 arguments as expression")+  TeExpression <$> judgment expr' context'+contextualizing _ _ _ = throwIO (userError "Function contextualize() requires exactly 2 arguments as expression")  -- The name the formation of the only argument goes by in the given world, or -- the formation itself where it has none (see 'pathOf'). The world is not an@@ -88,7 +94,7 @@ nameOf :: Maybe Expression -> BuildTermMethod nameOf universe [Y.ArgExpression expr] subst = do   form <- buildExpressionThrows expr subst-  pure (TeExpression (maybe form (`pathOf` form) universe))+  pure (TeExpression (nameIn universe form)) nameOf _ _ _ = throwIO (userError "Function named() requires exactly 1 argument as expression")  -- Uniqueness is the engine's job: 'freshTau' draws from the document-wide

@@ -0,0 +1,184 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- The rules of 𝕄 and 𝔻 the way a run takes them, whichever engine runs them.+-- A rule matched against a term and its universe comes to the premises it+-- runs beside its spine, in the order it lists them, each handed on to what+-- the rule builds of its answer, and to the conclusion it reaches once they+-- all ran. The engine of YAML interprets a rule into them ('morphingOf',+-- 'dataizationOf'), the one 'phino compile' writes builds them in Haskell out+-- of the very same spine ('morphingSpine', 'dataizationSpine'), and 'Morph'+-- and 'Dataize' run them, so the chain a run makes does not depend on which+-- of the two built them (#1628).+module Inference (Conclusion (..), Inference, Premises (..), Way (..), dataizationOf, dataizationSpine, direct, morphingOf, morphingSpine) where++import AST+import Builder (buildBytesThrows, buildExpressionThrows)+import Control.Exception (throwIO)+import Data.List (find)+import Data.Maybe (listToMaybe)+import qualified Data.Text as T+import Deps (Judgment (..))+import Matcher (MetaValue (..), Subst, combine, matchExpression', substSingle)+import Rule (RuleContext, matchExpressionWithRule')+import Text.Printf (printf)+import qualified Yaml as Y++-- One rule of 𝕄 or 𝔻 ready to run: what it makes of a term in a universe,+-- which is nothing where the two do not match it and the premises it runs+-- where they do, the first way they match it. The context tells its+-- conditions the world and the normal forms of the engine.+type Inference value = RuleContext -> Expression -> Expression -> IO (Maybe (Premises value))++-- The premises a rule runs beside its spine, in the order it lists them: 𝕄+-- of a term in a universe, 𝔼 of a formation in one, or 𝒞 of a term in a+-- context, each handed on to what the rule builds of its answer, and the+-- conclusion the rule comes to once they all ran.+data Premises value+  = Morphs Expression Expression (Expression -> IO (Premises value))+  | Evaluates Expression Expression (Expression -> IO (Premises value))+  | Contextualizes Expression Expression (Expression -> IO (Premises value))+  | Concludes (Conclusion value)++-- What a rule concludes with: the value it answers, which a step of the+-- label takes the chain to; or its judgment asked again, in the universe the+-- rule names, of the term it built, once that term is reached the way the+-- rule says.+data Conclusion value+  = Answered (Judgment, String) value+  | Onward Way Expression Expression+  deriving (Eq, Show)++-- How the term a judgment is asked about again is reached from the one its+-- rule built: by a step of the label; by a step of the label and 𝒩 after it;+-- the same, where the term is the universe the rule matched, which the run+-- has named already, so the step takes the chain to that world and nothing is+-- normalized (#1453); or by 𝕄 in the universe given, its steps spliced into+-- the chain.+data Way+  = Taken (Judgment, String)+  | Normalized (Judgment, String)+  | Named (Judgment, String)+  | Staged Expression+  deriving (Eq, Show)++-- What a rule of 𝕄 does once it matched, read off its premises: the ones it+-- runs beside its spine, in the order it lists them, and the conclusion it+-- comes to, the terms of both written with the metas of the rule; or why no+-- run can take it. A rule no premise produces the conclusion of answers it,+-- and a rule of any other kind is asked again of the argument of the 'morph'+-- premise producing its conclusion, normalized where a 'normalize' premise+-- produces that argument.+morphingSpine :: Y.MorphRule -> Either String ([Y.Premise], Conclusion Expression)+morphingSpine rule = case producer rule.nresult rule.premises of+  Nothing -> Right (rule.premises, Answered step rule.nresult)+  Just concl@(Y.Premise _ (Y.OpMorph arg universe)) -> case producer arg rule.premises of+    Just normal@(Y.Premise _ (Y.OpNormalize inner)) ->+      Right (rule.premises `excluding` [concl, normal], Onward ((if inner == rule.ematch then Named else Normalized) step) inner universe)+    _ -> Right (rule.premises `excluding` [concl], Onward (Taken step) arg universe)+  Just _ -> Left "it concludes with no 'morph' premise"+  where+    step :: (Judgment, String)+    step = (Morphing, rule.name)++-- What a rule of 𝔻 does once it matched, read off its premises the way+-- 'morphingSpine' reads those of 𝕄, where 'morph' may produce the argument of+-- the 'dataize' premise too. A step of 𝔻 is labelled by the first premise the+-- rule runs beside its spine — 'box' by its 'contextualize', 'fire' by its+-- 'evaluate' — and taken by the judgment that premise runs; with none it is+-- labelled blank where it normalizes and by the verb of its conclusion+-- otherwise.+dataizationSpine :: Y.DataizeRule -> Either String ([Y.Premise], Conclusion Bytes)+dataizationSpine rule = case bytesProducer rule.dresult of+  Nothing -> Right (rule.premises, Answered (Dataization, rule.name) rule.dresult)+  Just concl@(Y.Premise _ (Y.OpDataize arg universe)) -> case producer arg rule.premises of+    Just normal@(Y.Premise _ (Y.OpNormalize inner)) ->+      let side = rule.premises `excluding` [concl, normal]+       in Right (side, Onward (Normalized (labelled (Dataization, "") side)) inner universe)+    Just morphed@(Y.Premise _ (Y.OpMorph inner scene)) ->+      Right (rule.premises `excluding` [concl, morphed], Onward (Staged scene) inner universe)+    _ ->+      let side = rule.premises `excluding` [concl]+       in Right (side, Onward (Taken (labelled (label concl.operation) side)) arg universe)+  Just _ -> Left "it concludes with no 'dataize' premise"+  where+    bytesProducer :: Bytes -> Maybe Y.Premise+    bytesProducer (BtMeta name) = find (\premise -> premise.result == name) rule.premises+    bytesProducer _ = Nothing+    labelled :: (Judgment, String) -> [Y.Premise] -> (Judgment, String)+    labelled _ (premise : _) = label premise.operation+    labelled fallback [] = fallback++-- The premise binding the given expression meta, if any. The conclusion of a+-- rule and the argument of a continuation premise are looked up here to find+-- the premise that produces them.+producer :: Expression -> [Y.Premise] -> Maybe Y.Premise+producer (ExMeta name) = find (\premise -> premise.result == name)+producer _ = const Nothing++-- The premises whose result meta is not bound by any of the given ones — the+-- side-computations left once the spine premises are removed.+excluding :: [Y.Premise] -> [Y.Premise] -> [Y.Premise]+excluding premises removed = filter (\premise -> premise.result `notElem` map (.result) removed) premises++-- What a step a premise takes is labelled with in the chain: the judgment the+-- premise runs, which picks the arrow of the step in LaTeX (#1536), and its+-- verb, which names the step.+label :: Y.Operation -> (Judgment, String)+label (Y.OpMorph _ _) = (Morphing, "morph")+label (Y.OpNormalize _) = (Normalization, "normalize")+label (Y.OpEvaluate _ _) = (Evaluation, "evaluate")+label (Y.OpContextualize _ _) = (Contextualization, "contextualize")+label (Y.OpDataize _ _) = (Dataization, "dataize")++-- A rule of 𝕄 as the engine of YAML runs it (see 'interpreted').+morphingOf :: Y.MorphRule -> Inference Expression+morphingOf rule = interpreted buildExpressionThrows (Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing) rule.ematch (morphingSpine rule)++-- A rule of 𝔻 as the engine of YAML runs it (see 'interpreted').+dataizationOf :: Y.DataizeRule -> Inference Bytes+dataizationOf rule = interpreted buildBytesThrows (Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing) rule.ematch (dataizationSpine rule)++-- A rule of 𝕄 or 𝔻 the matcher matches, the pattern against the term and the+-- pattern of the universe against the universe, its 'when' and its '𝑛' and+-- '𝑘' metas checked the way those of a rewriting rule are, and the premises+-- of its spine built out of the metas the first match bound, each binding its+-- own meta to the answer it is handed. Only 𝕄, 𝔼 and 𝒞 run beside a spine.+interpreted :: forall value. (value -> Subst -> IO value) -> Y.Rule -> Expression -> Either String ([Y.Premise], Conclusion value) -> Inference value+interpreted build rule ematch spine ctx term univ = do+  matched <- matchExpressionWithRule' (matchExpression' ematch univ) term rule ctx+  case (matched, spine) of+    ([], _) -> pure Nothing+    (_, Left reason) -> refuse reason+    (subst : _, Right (sides, conclusion)) -> Just <$> premised sides conclusion subst+  where+    premised :: [Y.Premise] -> Conclusion value -> Subst -> IO (Premises value)+    premised [] conclusion subst = Concludes <$> concluded conclusion subst+    premised (premise : rest) conclusion subst = case premise.operation of+      Y.OpMorph expr universe -> do+        world <- buildExpressionThrows universe subst+        morphed <- buildExpressionThrows expr subst+        pure (Morphs morphed world next)+      Y.OpEvaluate expr universe -> Evaluates <$> buildExpressionThrows expr subst <*> buildExpressionThrows universe subst <*> pure next+      Y.OpContextualize expr context -> Contextualizes <$> buildExpressionThrows expr subst <*> buildExpressionThrows context subst <*> pure next+      _ -> refuse (printf "its premise '%s' runs beside the spine, which only a 'morph', an 'evaluate' or a 'contextualize' can" (T.unpack premise.result))+      where+        next :: Expression -> IO (Premises value)+        next answer = case combine (substSingle premise.result (MvExpression answer)) subst of+          Just subst' -> premised rest conclusion subst'+          Nothing -> throwIO (userError (printf "premise meta '%s' clashes with an existing binding" (T.unpack premise.result)))+    concluded :: Conclusion value -> Subst -> IO (Conclusion value)+    concluded (Answered step value) subst = Answered step <$> build value subst+    concluded (Onward (Staged stage) expr world) subst = Onward . Staged <$> buildExpressionThrows stage subst <*> buildExpressionThrows expr subst <*> buildExpressionThrows world subst+    concluded (Onward way expr world) subst = Onward way <$> buildExpressionThrows expr subst <*> buildExpressionThrows world subst+    refuse :: String -> IO a+    refuse reason = throwIO (userError (printf "The rule '%s' cannot be run, since %s" rule.name reason))++-- A rule of 𝕄 or 𝔻 'phino compile' turned into Haskell: a function telling+-- every way the term and the universe match it, of which a run takes the+-- first, as it takes the first match of a rule of YAML.+direct :: (Expression -> Expression -> [Premises value]) -> Inference value+direct rule _ term univ = pure (listToMaybe (rule term univ))

@@ -28,9 +28,10 @@ import Bytes (nonFiniteName) import CST import Canonizer (canonize, canonizeExpr)-import Data.List (intercalate, nub)+import Data.List (intercalate, nub, zipWith4) import Data.Maybe (isJust) import qualified Data.Text as T+import Deps (Judgment (..)) import Encoding import Lining import Locator (locatedExpression)@@ -156,33 +157,55 @@     , maybe "" (printf "\\phiExpression{%s} ") _expression     ] --- Join the rendered steps with '\leadsto'. Every step after the first carries--- the two-space '\leadsto' indent, so it is rendered from base tab 1 rather--- than 0 (via 'baseTab'); this keeps a wrapped multi-line step's members nested--- one level below its '\leadsto [[' line and its closing bracket aligned with--- that line. The first step has no '\leadsto' prefix and stays at base tab 0.+-- Join the rendered steps with the arrows of the judgments that took them, so+-- a chain mixing rules of 𝒩, 𝕄 and 𝔻 tells them apart (#1536). A step taken+-- by a rule ends with the arrow of the rule's judgment, the rule referenced in+-- its optional argument, and the step after it opens with the same arrow, bare+-- (see 'arrows'). Every step after the first carries the two-space indent+-- before its arrow, so it is rendered from base tab 1 rather than 0 (via+-- 'baseTab'); this keeps a wrapped multi-line step's members nested one level+-- below the line its arrow opens and its closing bracket aligned with that+-- line. The first step opens with no arrow and stays at base tab 0. -- Each step is prefixed with the matching entry from 'comments', which is -- either empty or a '% ...'-commented header line ending in a newline (see -- 'stepComments'), so headers stay on their own line above the equation.-body :: [String] -> [(a, Maybe String)] -> (Int -> a -> String) -> String+body :: [String] -> [(a, Maybe (Judgment, String))] -> (Int -> a -> String) -> String body comments printed toLatex =   intercalate     "\n"-    ( zipWith3-        ( \idx comment (item, maybeName) ->+    ( zipWith4+        ( \idx comment (item, rule) reached ->             let item' = toLatex (baseTab idx) item-                leadsto = if idx == 0 then item' else "  \\leadsto " ++ item'-             in comment ++ maybe leadsto (printf "%s \\leadsto_{\\nameref{r:%s}}" leadsto) maybeName+                opening = if idx == 0 then item' else printf "  %s %s" (relation reached) item'+             in comment ++ maybe opening (\(judgment, name) -> printf "%s %s[\\nameref{r:%s}]" opening (relation judgment) name) rule         )         [0 ..]         comments         printed+        (arrows (map snd printed))     )   where     baseTab :: Int -> Int     baseTab 0 = 0     baseTab _ = 1 +-- The judgment a chain stands at before each of its steps and after its last+-- one, which is that of the latest rule it took. A chain stands at 𝒩 before it+-- took any, since 'rewrite' is the only command whose chain can run out of+-- steps before its first one, and it only normalizes.+arrows :: [Maybe (Judgment, String)] -> [Judgment]+arrows = scanl (\current rule -> maybe current fst rule) Normalization++-- The arrow of the relation LaTeX writes a step taken by the judgment with.+-- These are not the '\phinoNormalize' and the rest of 'explain', which print a+-- whole judgment with its input and output.+relation :: Judgment -> String+relation Normalization = "\\phiNormalize"+relation Morphing = "\\phiMorph"+relation Dataization = "\\phiDataize"+relation Evaluation = "\\phiEvaluate"+relation Contextualization = "\\phiContextualize"+ -- LaTeX comment header lines for each step (see 'stepHeaders' in "Rewriter"), -- or empty strings when '--headers' is off. A '%' starts a LaTeX comment, so -- the header documents the '--sequence' chain without affecting the rendered@@ -194,10 +217,16 @@     then map (printf "%% %s\n") (stepHeaders rewrittens)     else map (const "") rewrittens -ending :: Bool -> LatexContext -> String-ending True ctx = printf " \\leadsto\n  \\leadsto \\dots\n\\end{%s}" (phiquation ctx)-ending False ctx = printf "{.}\n\\end{%s}" (phiquation ctx)+-- Close the equation of a chain. One that ran out of steps trails off with the+-- arrow of the judgment it stands at after its last step (see 'arrows'), and+-- one that finished ends with a period, the way a single expression does.+ending :: Bool -> Judgment -> LatexContext -> String+ending True judgment ctx = printf " %s\n  %s \\dots\n\\end{%s}" (relation judgment) (relation judgment) (phiquation ctx)+ending False _ ctx = period ctx +period :: LatexContext -> String+period ctx = printf "{.}\n\\end{%s}" (phiquation ctx)+ compressedRewrittens :: [Rewritten] -> LatexContext -> [Rewritten] compressedRewrittens rewrittens ctx@LatexContext{..} =   let (exprs, rules) = unzip rewrittens@@ -232,7 +261,7 @@     ( concat         [ preamble ctx         , body (stepComments rewrittens ctx) (canonizedRewrittens (compressedRewrittens rewrittens ctx) ctx) (\tabs expr -> renderToLatex (expressionToCSTFrom tabs expr) ctx)-        , ending exceeded ctx+        , ending exceeded (last (arrows (map snd rewrittens))) ctx         ]     ) rewrittensToLatex (rewrittens, exceeded) ctx@LatexContext{..} = do@@ -242,7 +271,7 @@     ( concat         [ preamble ctx         , body (stepComments rewrittens ctx) (zip (canonizedExpressions (compressedExpressions focused ctx) ctx) rules) (\tabs expr -> renderToLatex (expressionToCSTFrom tabs expr) ctx)-        , ending exceeded ctx+        , ending exceeded (last (arrows (map snd rewrittens))) ctx         ]     ) @@ -251,7 +280,7 @@   concat     [ preamble ctx     , renderToLatex (expressionToCST ex) ctx-    , ending False ctx+    , period ctx     ]  piped :: T.Text -> T.Text@@ -492,7 +521,7 @@ -- Render a rule's premises in order, threading the state through them. The rule -- starts in state s_1; each state-changing premise (𝕄, 𝔻, 𝔼) consumes the -- current state and yields the next (s_2, s_3, …), matching how the engine folds--- the state through the premises ('sidePremise' in 'Dataize.hs'). Returns the+-- the state through the premises ('inferred' in 'Morph.hs'). Returns the -- rendered judgments and the final state index, which the conclusion returns. premisesToLatex :: [Y.Premise] -> ([String], Int) premisesToLatex = go 1

@@ -1,3 +1,6 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -283,3 +286,56 @@     same (AtMeta _) _ = True     same (AtAny _) _ = True     same pattr tattr = pattr == tattr++-- Every place of the term a rule matches at as a whole, in the order the deep+-- matcher finds them, each beside what the rule makes of it there, once for+-- every way it matches. The rule is a function of the place alone, the way+-- 'phino compile' writes one, and it is asked about every place the deep+-- matcher looks at, told whether it matches only a redex (#1617).+sites :: forall a. Bool -> (Expression -> [a]) -> Expression -> [(Expression, a)]+sites redex rule tgt = go tgt []+  where+    go :: Expression -> [(Expression, a)] -> [(Expression, a)]+    go expr rest+      | redex && inert expr = rest+      | otherwise = map (expr,) (rule expr) ++ below expr rest+    below :: Expression -> [(Expression, a)] -> [(Expression, a)]+    below (ExFormation bds) rest = foldr inside rest bds+    below (ExDispatch expr _) rest = go expr rest+    below (ExApplication expr (ArTau _ arg)) rest = go expr (go arg rest)+    below (ExApplication expr (ArAlpha _ arg)) rest = go expr (go arg rest)+    below _ rest = rest+    inside :: Binding -> [(Expression, a)] -> [(Expression, a)]+    inside (BiTau _ expr) rest = go expr rest+    inside _ rest = rest++-- Whether a rule matches at some place of the term the deep matcher looks at,+-- told whether it matches only a redex (see 'sites').+anywhere :: Bool -> (Expression -> Bool) -> Expression -> Bool+anywhere redex rule = go+  where+    go :: Expression -> Bool+    go expr+      | redex && inert expr = False+      | otherwise = rule expr || below expr+    below :: Expression -> Bool+    below (ExFormation bds) = any inside bds+    below (ExDispatch expr _) = go expr+    below (ExApplication expr (ArTau _ arg)) = go expr || go arg+    below (ExApplication expr (ArAlpha _ arg)) = go expr || go arg+    below _ = False+    inside :: Binding -> Bool+    inside (BiTau _ expr) = go expr+    inside _ = False++-- Every way of cutting the bindings in two, the leading run first and the rest+-- second, the shortest leading run first, which is the order a meta binding+-- tries them in (see 'matchBindingsMeta').+splits :: [Binding] -> [([Binding], [Binding])]+splits = go []+  where+    go :: [Binding] -> [Binding] -> [([Binding], [Binding])]+    go before after =+      (reverse before, after) : case after of+        [] -> []+        (bd : rest) -> go (bd : before) rest

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -18,13 +19,13 @@ -- a λ function itself, which is an evaluation — are injected as '_reduce', -- '_evaluate' and '_fire' rather than imported (see 'ReductionFunc' and -- 'EvaluationFunc').-module Morph (Answer, Kept (..), ReduceContext (..), ReduceException (..), EvaluationFunc, FiringFunc, Memo (..), ReductionFunc, Morphed, Steps (..), Tally (..), boxed, charged, counted, deeper, emptyState, enter, entering, excluding, execBuildTerm, insideUniverse, isLambda, lambda, leadsTo, memoized, morph, morph', morphing, normalized, parking, producer, recalled, retained, sidePremise, starved, tallied, universed, unparked, verb) where+module Morph (Answer, Deadline (..), Kept (..), ReduceContext (..), ReduceException (..), EvaluationFunc, FiringFunc, Memo (..), ReductionFunc, Morphed, Steps (..), Tally (..), boxed, charged, counted, deeper, emptyState, enter, entering, execBuildTerm, inferred, insideUniverse, isLambda, lambda, leadsTo, memoized, morph, morph', morphing, normalized, onward, parking, recalled, retained, starved, tallied, timed, universed, unparked) where  import AST-import Builder (buildExpressionThrows, contextualize, pathOf)+import Builder (buildExpressionThrows, pathOf) import Control.Applicative ((<|>))-import Control.Exception (Exception, catch, throwIO, try)-import Control.Monad (foldM, unless, when)+import Control.Exception (Exception, SomeException, catch, evaluate, throwIO, try)+import Control.Monad (unless, when) import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) import Data.List (find, partition) import Data.List.NonEmpty (NonEmpty (..))@@ -33,18 +34,23 @@ import Data.Maybe (fromMaybe, isJust, listToMaybe) import qualified Data.Set as Set import qualified Data.Text as T-import Deps (Acyclic (..), BuildTermFunc, BuildTermMethodS, Evaluation (..), Judgment (..), SaveEvalFunc, SaveStepFunc, State (..), Term (..), dontSaveStep)+import Deps (Acyclic (..), BuildTermFunc, BuildTermMethod, Evaluation (..), Judgment (..), SaveEvalFunc, SaveStepFunc, State (..), Term (..), dontSaveStep, renumbered)+import Engine (Engine (..))+import GHC.Clock (getMonotonicTime)+import qualified Inference as In import Lambdas (Lambdas) import Locator (locatedExpression, withLocatedExpression)-import Matcher (MetaValue (..), Subst (..), combine, matchExpression', substEmpty, substSingle)+import Matcher (substEmpty) import Must (Must (..))+import Pool (pooled) import Printer (printExpression) import Random (shuffle) import Rewriter (RewriteContext (RewriteContext), Rewritten, Seen, rewrite, seenInsert)-import Rule (RuleContext (RuleContext), matchExpressionWithRule')+import Rule (RuleContext (RuleContext))+import System.Timeout (timeout)+import Tau (tausOf) import Text.Printf (printf)-import Yaml (ExtraArgument (..), normalizationRules)-import qualified Yaml as Y+import Yaml (ExtraArgument (..))  -- A term together with the derivation that reached it: what one frame of a -- judgment's spine is handed and hands on.@@ -66,8 +72,10 @@ -- 'ml' and 'fire' rules ask for through an 'evaluate' premise, and it answers -- with a normal form, so the rule that asked needs no 'normalize' after it. The -- edge is injected rather than imported, exactly as 'ReductionFunc' injects the--- 𝔻 one, and 'Evaluate' supplies its own 'evaluation' for it.-type EvaluationFunc = ReduceContext -> State -> BuildTermMethodS+-- 𝔻 one, and 'Evaluate' supplies its own 'evaluation' for it. It is handed the+-- formation to fire and the universe to fire it in, and the state goes in and+-- comes back out.+type EvaluationFunc = ReduceContext -> State -> Expression -> Expression -> IO (Expression, State)  -- How the deep walk reaches 𝔼. Like 'EvaluationFunc' it answers a normal form, -- or nothing at all where nothing fired: the walk stands that answer back into@@ -113,6 +121,21 @@   , _count :: IORef Int   } +-- How many seconds the whole run may take ('_seconds', the '--max-seconds'+-- option) and the reading of the monotonic clock it has to stop at+-- ('_until'). Like 'Tally' it bounds the whole run and not one branch, and it+-- bounds what neither count does: a run inside both of them may still take+-- longer than its caller can wait, and a caller that kills it from outside+-- leaves a protocol whose elements nobody closed (#1607). The first frame+-- the deadline refuses ends the run, so the protocol says it once. A worker+-- of '--jobs' reads the clock on its own, writes its refusal among its own+-- records and ends its binding there; gathering stops at the first binding+-- that failed, so the protocol carries that refusal and no other (#1619).+data Deadline = Deadline+  { _seconds :: Int+  , _until :: Double+  }+ -- What the firings of a run under '--acyclic=plausible' answered, by the -- formation each was fired against, kept so that a later firing of the same -- formation takes the answer instead of making it again. 𝔼 is a function of@@ -230,6 +253,9 @@   , -- How many λ functions the whole run may fire and how many it has fired     -- (see 'Tally'), or nothing where '--max-firings' asks for no such limit.     _tally :: Maybe Tally+  , -- When the whole run has to stop (see 'Deadline'), or nothing where+    -- '--max-seconds' asks for no such limit.+    _deadline :: Maybe Deadline   , -- What the firings made so far answered (see 'Memo'), kept under     -- 'Plausible' alone (see 'memoized'), or nothing under any other mode,     -- where every formation is fired as many times as it is met.@@ -239,6 +265,11 @@   , _shuffle :: Bool   , _partial :: Bool   , _deep :: Bool+  , -- How many workers the '--deep' walk morphs the bindings of the formation+    -- it starts at on, side by side, which is the '--jobs' option (see+    -- 'deepened'). One is the walk taking them one after another, the way it+    -- always has, and a worker walks what its binding holds with one.+    _jobs :: Int   , _acyclic :: Maybe Acyclic   , -- The judgment whose rule is asking 𝔼 to fire, which is what a stuck site     -- is written under: 𝔼 is reached from the 'ml' rule of morphing and from@@ -272,6 +303,9 @@   , _fire :: FiringFunc   , _saveStep :: SaveStepFunc   , _saveEval :: SaveEvalFunc+  , -- What runs the built-in rules of the calculus (see 'Engine'): the YAML+    -- interpreted, or the Haskell 'phino compile' wrote (#1617, #1628).+    _engine :: Engine   }  -- Which of the budgets a run spent, with the limit it was given: the depth@@ -279,7 +313,8 @@ -- run may make ('--max-firings', see 'Tally') or the cycles one normalization -- may take ('--max-cycles', see 'normalized'). All are the same signal to -- '_partial', which parks any as a site that never finishes, and differ only--- in what the message names.+-- in what the message names. The seconds of '--max-seconds' are none of+-- them, since a run out of time has no site to park (see 'OutOfTime'). data Budget   = Depth Int   | Firings Int@@ -287,6 +322,14 @@  data ReduceException   = OutOfSteps Budget+  | -- The deadline of '--max-seconds' passed (see 'Deadline'), with the+    -- seconds the run was given. Unlike a spent budget it is no stuck site: a+    -- run out of time is out of it wherever it stands, and parking one site+    -- only lets the run go on rewriting and walking the rest of the term for+    -- as long as that takes (#1619). So no frame attaches a derivation to it+    -- and '_partial' parks nothing on it: it ends the run with or without+    -- '_partial'.+    OutOfTime Int   | -- A λ function could not fire: the '--symbolic' file carries no entry     -- answering that name, or an operand of the entry it does carry never came     -- down to data, or the two branches it joins differ by more than a symbol,@@ -348,6 +391,8 @@   show (OutOfSteps (Cycles limit)) =     printf "Normalization did not finish before reaching the limit of cycles: --max-cycles=%d" limit   show (OutOfStepsAt budget _ _) = show (OutOfSteps budget)+  show (OutOfTime limit) =+    printf "Evaluation did not finish before reaching the limit of seconds: --max-seconds=%d" limit   show (Stuck func) = printf "No entry of --symbolic answers the λ function '%s'" (T.unpack func)   show (StuckAt func _ _) = show (Stuck func)   show (Looping term) = printf "Reduction entered a formation it is already inside: %s" (printExpression term)@@ -367,14 +412,18 @@ -- formation (see 'Kept', #1514, #1521). The protocol is told too, with the -- site the frame stood at, so a firing the budget starved no longer reads as -- one that went well (#1524), and a frame of 𝕄 standing at a whole universe--- does not spell it on every line (#1531).+-- does not spell it on every line (#1531). The clock is read here as well as+-- where a λ function fires, since a run may spend its time rewriting and+-- walking terms that fire nothing, and every such frame passes through here+-- (#1619). deeper :: ReduceContext -> IO ReduceContext-deeper ctx@ReduceContext{_steps = Steps limit spent}-  | spent >= limit = do-      starve ctx._memo-      ctx._saveEval (EvStarved ctx._nesting limit ctx._judgment ctx._site)-      throwIO (OutOfSteps (Depth limit))-  | otherwise = pure ctx{_steps = Steps limit (spent + 1)}+deeper ctx@ReduceContext{_steps = Steps limit spent} = do+  clocked ctx+  when (spent >= limit) $ do+    starve ctx._memo+    ctx._saveEval (EvStarved ctx._nesting limit ctx._judgment ctx._site)+    throwIO (OutOfSteps (Depth limit))+  pure ctx{_steps = Steps limit (spent + 1)}   where     starve :: Maybe Memo -> IO ()     starve Nothing = pure ()@@ -385,16 +434,47 @@ tallied :: Maybe Int -> IO (Maybe Tally) tallied = traverse (\cap -> Tally cap <$> newIORef 0) --- Charge one firing of a λ function to the budget of the whole run, refusing--- to fire once it is gone (see 'Tally'). 'deeper' bounds how far one branch--- descends, which stops a recursion that nests but not one that widens.+-- The deadline a run starts from where '--max-seconds' gives a limit: that+-- many seconds from now.+timed :: Maybe Int -> IO (Maybe Deadline)+timed = traverse (\cap -> Deadline cap . (+ fromIntegral cap) <$> getMonotonicTime)++-- Charge one firing of a λ function to the budgets of the whole run, refusing+-- to fire once the deadline has passed (see 'clocked') or the tally is gone+-- (see 'Tally'). 'deeper' bounds how far one branch descends, which stops a+-- recursion that nests but not one that widens, and neither count stops a run+-- that is merely slow. charged :: ReduceContext -> IO ()-charged ReduceContext{_tally = Nothing} = pure ()-charged ReduceContext{_tally = Just (Tally cap count)} = do-  fired <- readIORef count-  when (fired >= cap) (throwIO (OutOfSteps (Firings cap)))-  writeIORef count (fired + 1)+charged ctx = do+  clocked ctx+  mapM_ billed ctx._tally+  where+    billed :: Tally -> IO ()+    billed (Tally cap count) = do+      fired <- readIORef count+      when (fired >= cap) (throwIO (OutOfSteps (Firings cap)))+      writeIORef count (fired + 1) +-- Refuse to go on once the deadline of '--max-seconds' has passed (see+-- 'Deadline'), which ends the run (see 'expired').+clocked :: ReduceContext -> IO ()+clocked ctx = mapM_ clock ctx._deadline+  where+    clock :: Deadline -> IO ()+    clock (Deadline cap due) = do+      now <- getMonotonicTime+      when (now >= due) (expired ctx cap)++-- End the run out of time (see 'OutOfTime'). The refusal is told to the+-- protocol, with the judgment of the frame refused and the site it stood at,+-- at the depth its line would have stood at, so a run out of time reads as one+-- and leaves the protocol closed and whole, with the refusal as its last line+-- (#1607, #1619).+expired :: ReduceContext -> Int -> IO a+expired ctx cap = do+  ctx._saveEval (EvTimeout ctx._nesting cap ctx._judgment ctx._site)+  throwIO (OutOfTime cap)+ -- The memo a run keeps, by the mode of '--acyclic' it runs under: an empty -- one under 'Plausible', the mode the memo belongs to (see 'Memo'), and none -- under any other, where nothing is ever recalled.@@ -534,15 +614,28 @@ -- frame that knows it enters one without being a rule of 𝕄 or 𝔻: the '--deep' -- walk, which fires the λ of every formation 𝕄 leaves bare, so a recursion -- driven by the walk alone goes through no rule 'entrance' knows of (#1451).+-- The search is pure, and under 'Plausible' one comparison may take longer than+-- the whole run may, since 'within' looks for the formation entered above at+-- every depth of the one about to be entered, and on two deep terms it takes+-- more than a second even with the answers of the call kept (#1623). The+-- deadline of '--max-seconds' cuts the search while it runs, and the refusal+-- stands where the formation would have opened (#1622). enter :: Expression -> ReduceContext -> IO ReduceContext enter form ctx = maybe (pure ctx) remembered ctx._acyclic   where     remembered :: Acyclic -> IO ReduceContext-    remembered mode = case find (repeated mode form) (Map.findWithDefault [] (digest mode form) ctx._entered) of-      Just before -> do-        ctx._saveEval (EvLooped ctx._nesting ctx._judgment mode before ctx._site)-        throwIO (Looping form)-      Nothing -> pure ctx{_entered = seenInsert (digest mode form) form ctx._entered}+    remembered mode =+      awaited (find (repeated mode form) (Map.findWithDefault [] (digest mode form) ctx._entered)) >>= \case+        Just before -> do+          ctx._saveEval (EvLooped ctx._nesting ctx._judgment mode before ctx._site)+          throwIO (Looping form)+        Nothing -> pure ctx{_entered = seenInsert (digest mode form) form ctx._entered}+    awaited :: Maybe Expression -> IO (Maybe Expression)+    awaited found = case ctx._deadline of+      Nothing -> pure found+      Just (Deadline cap due) -> do+        now <- getMonotonicTime+        maybe (expired ctx cap) pure =<< timeout (ceiling (max 0 (due - now) * 1000000)) (evaluate found)     digest :: Acyclic -> Expression -> Int     digest Proven = hashShape     digest Plausible = hashSkeleton@@ -606,86 +699,35 @@ -- with the new state. The universe is matched against the rule's 'universe' -- pattern (usually the '𝑒' meta, which binds 'e' so the 'universe' rule substitutes -- it, but a rule may pin it to a literal such as 'mg' matching Φ). Its rules--- come from 'resources/morphing': the first matching rule's premises are evaluated and--- its conclusion 'nresult' is built, in the universe the concluding premise--- names, which every rule spells as the one it was matched in (#1512). The--- clauses are disjoint (see #856, #860), so their declaration order must not be+-- come from 'resources/morphing', run by the engine (see '_morphing' of+-- 'Engine'): the first matching rule's premises are evaluated and its+-- conclusion 'nresult' is built, in the universe the concluding premise names,+-- which every rule spells as the one it was matched in (#1512). The clauses+-- are disjoint (see #856, #860), so their declaration order must not be -- load-bearing; when '_shuffle' is on (the '--shuffle' flag) the rules are--- shuffled before the 'firstMatch' walk to exercise that invariant — mirroring--- normalization's "apply until they stop matching". A genuinely order-independent--- step stays deterministic; a hidden overlap surfaces as a nondeterministic--- failure rather than staying silently green.+-- shuffled before 'inferred' walks them to exercise that invariant — mirroring+-- normalization's "apply until they stop matching". A genuinely+-- order-independent step stays deterministic; a hidden overlap surfaces as a+-- nondeterministic failure rather than staying silently green. -- The 'morph' premise that produces the conclusion is the spine: when -- its argument comes from a 'normalize' premise, the rewriter runs over that -- argument and its individual steps (alpha, copy, dot, …) are spliced into the--- chain before morphing continues. Every other premise is a side-computation--- evaluated in isolation by 'sidePremise', its own steps discarded.+-- chain before morphing continues (see 'onward'). Every other premise is a+-- side-computation evaluated in isolation by 'inferred', its own steps+-- discarded. morph' :: Morphed -> Expression -> State -> ReduceContext -> IO (Morphed, State) morph' (expr, seq) univ state caller = do   ctx <- deeper =<< entering expr =<< universed univ caller{_judgment = Morphing}   parking seq state $ do-    rules <- if ctx._shuffle then shuffle Y.morphingRules else pure Y.morphingRules-    matched <- firstMatch ctx rules-    case matched of-      Just (rule, subst) -> reduce ctx rule subst-      Nothing -> throwIO (Unmorphable expr)-  where-    firstMatch :: ReduceContext -> [Y.MorphRule] -> IO (Maybe (Y.MorphRule, Subst))-    firstMatch _ [] = pure Nothing-    firstMatch ctx (rule : rest) = do-      substs <- matchExpressionWithRule' (matchExpression' rule.ematch univ) expr (asRule rule) (RuleContext (execBuildTerm univ ctx) (Just univ))-      case substs of-        (subst : _) -> pure (Just (rule, subst))-        [] -> firstMatch ctx rest-    -- Match the conclusion term and check the guard; premises are no longer the-    -- matcher's business, so 'where'/'having' stay empty and the guard lives in-    -- 'when'. Every morphing guard reads only meta-variables bound by 'match'-    -- and 'universe', so it holds before any premise runs.-    asRule :: Y.MorphRule -> Y.Rule-    asRule rule = Y.Rule rule.name Nothing Nothing rule.match ExRoot rule.when Nothing Nothing-    -- Evaluate the rule's premises and build its conclusion. A literal-    -- conclusion is terminal. Otherwise the conclusion meta is produced by a-    -- trailing 'morph' premise (the spine); if that premise's argument is itself-    -- bound by a 'normalize' premise, the normalization joins the spine and its-    -- steps splice in before morphing continues.-    reduce :: ReduceContext -> Y.MorphRule -> Subst -> IO (Morphed, State)-    reduce ctx rule subst = case producer rule.nresult rule.premises of-      Nothing -> do-        (final, state') <- sides ctx rule.premises subst-        built <- buildExpressionThrows rule.nresult final-        seq' <- leadsTo seq rule.name built ctx+    reached <- inferred expr univ state ctx ctx._engine._morphing+    case reached of+      Just (In.Answered step built, state') -> do+        seq' <- leadsTo seq step built ctx         pure ((built, seq'), state')-      Just concl@(Y.Premise _ (Y.OpMorph arg universe)) -> case producer arg rule.premises of-        Just normal@(Y.Premise _ (Y.OpNormalize inner)) -> do-          (final, state') <- sides ctx (rule.premises `excluding` [concl, normal]) subst-          built <- buildExpressionThrows inner final-          world <- buildExpressionThrows universe final-          (normal', seq') <- settle ctx rule inner built-          morph' (normal', seq') world state' ctx-        _ -> do-          (final, state') <- sides ctx (rule.premises `excluding` [concl]) subst-          built <- buildExpressionThrows arg final-          world <- buildExpressionThrows universe final-          seq' <- leadsTo seq rule.name built ctx-          morph' (built, seq') world state' ctx-      Just _ -> throwIO (userError (printf "morphing rule '%s' must conclude with a 'morph' premise" rule.name))-    sides :: ReduceContext -> [Y.Premise] -> Subst -> IO (Subst, State)-    sides ctx premises subst = foldM (sidePremise univ ctx) (subst, state) premises-    -- Bring the term a 'normalize' premise built to its normal form and splice-    -- the steps into the chain. A premise normalizing the universe itself, the-    -- meta the rule's 'universe' bound, is answered with the world the run has-    -- already named (see '_universe'), since that is the normal form of the-    -- very same program: the 'universe' rule asks for it every time 𝕄 resolves-    -- Φ, and normalizing the whole program again for each of them made every-    -- step cost the size of the world (#1453).-    settle :: ReduceContext -> Y.MorphRule -> Expression -> Expression -> IO Morphed-    settle ctx rule inner built = case ctx._universe of-      Just world | inner == rule.ematch -> do-        seq' <- leadsTo seq rule.name world ctx-        pure (world, seq')-      _ -> do-        labelled <- leadsTo seq rule.name built ctx-        normalized built labelled ctx+      Just (In.Onward way built world, state') -> do+        (morphed, state'') <- onward seq state' way built ctx+        morph' morphed world state'' ctx+      Nothing -> throwIO (Unmorphable expr)  -- Morph the expression located at '_locator' — 𝕄 asked on its own, the way -- 'dataize' asks 𝔻. The whole input expression is itself the universe Φ (the 'e'@@ -745,7 +787,7 @@       | not _deep = pure (morphed, reverse (NE.toList seq), state')       | otherwise = do           (deep, state'') <- deepened morphed universe state' walker-          seq' <- leadsTo seq "deep" deep walker+          seq' <- leadsTo seq (Morphing, "deep") deep walker           pure (deep, reverse (NE.toList seq'), state'')  -- Walk what 𝕄 answered with, entering everything it left as it was written —@@ -764,9 +806,11 @@ -- only its own parts are walked, so the calls no entry answers keep their names -- and what comes back is still the same program, reduced as far as the file -- allows. Every entry is charged to the '--max-steps' budget, which is what--- bounds the walk.+-- bounds the walk. Under '--jobs' the bindings of the formation the walk+-- starts at are walked side by side rather than one after another (see+-- 'spread'). deepened :: Expression -> Expression -> State -> ReduceContext -> IO (Expression, State)-deepened expr univ state ctx = go (Just ctx._site) Nothing ExXi expr state ctx+deepened expr univ state ctx = step (if ctx._jobs > 1 then spread else parts) (Just ctx._site) Nothing ExXi expr state ctx   where     -- A term as it was written, together with the locator naming it where one     -- does and with what its free ξ stands for: the formation the walk entered@@ -775,11 +819,17 @@     -- stands for itself and contextualization leaves the term alone, and the     -- locator is the one the whole run was aimed at.     go :: Maybe Expression -> Maybe Attribute -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State)-    go standing dispatched context term state' caller = do+    go = step parts+    -- The same, with the parts of the term walked the way the first argument+    -- walks them, which only the term the walk starts at is walked by other+    -- than 'parts'.+    step :: (Maybe Expression -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State)) -> Maybe Expression -> Maybe Attribute -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State)+    step walk standing dispatched context term state' caller = do       let here = sited standing caller       ctx' <- deeper here-      (walked, walkedState) <- parts standing context term state' here-      (answer, answered) <- ctx'._fire dispatched (contextualize walked context) univ walkedState ctx'+      (walked, walkedState) <- walk standing context term state' here+      placed <- ctx._engine._contextualize walked context+      (answer, answered) <- ctx'._fire dispatched placed univ walkedState ctx'       pure (fromMaybe walked answer, answered)     -- The context a term is walked in, aimed at the term itself where a locator     -- names it. Where none does, the aim stays where it was: a firing standing@@ -804,10 +854,6 @@     parts :: Maybe Expression -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State)     parts _ _ term@(ExFormation bds) state' _       | any abstract bds = pure (term, state')-      where-        abstract :: Binding -> Bool-        abstract (BiVoid _) = True-        abstract _ = False     parts standing _ form@(ExFormation bds) state' caller = do       (entered, state'') <- bindings standing (synonym caller._universe form) bds bds state' caller       pure (ExFormation entered, state'')@@ -819,6 +865,72 @@       (applied, state''') <- argument context arg state'' caller       pure (ExApplication entered applied, state''')     parts _ _ term state' _ = pure (term, state')+    -- Whether a binding is a void, which makes the formation holding it a+    -- method nobody applied (see 'parts').+    abstract :: Binding -> Bool+    abstract (BiVoid _) = True+    abstract _ = False+    -- The parts of the term the walk starts at, walked the way 'parts' walks+    -- them, except that the bindings of a formation are walked side by side,+    -- as many at once as '--jobs' says (#1534). Each is a root of its own: it+    -- is walked from the state the spine left, with a memo, a tally and a+    -- source of fresh names of its own and its protocol kept aside, so what+    -- it comes to depends on the binding alone and not on which worker got+    -- where first. What the workers made is gathered in the order of the+    -- bindings, and that order is what the symbols are numbered in: a binding+    -- numbers what it mints from the floor the spine left, and gathering+    -- raises that by what the bindings before it minted, in its answer and in+    -- its protocol alike, so the answer and the protocol name a symbol the way+    -- one walk over the bindings would have. The protocol of a binding is+    -- written whole once it and every binding before it are done. Which+    -- binding is entered at all is decided up front, by the walk itself, the+    -- way 'bindings' decides it.+    spread :: Maybe Expression -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State)+    spread standing _ form@(ExFormation bds) state' caller+      | not (any abstract bds) = do+          jobs <- mapM (planned (synonym caller._universe form)) (zip [1 ..] bds)+          (entered, _, state'') <- pooled caller._jobs jobs gathered ([], 0, state')+          pure (ExFormation (reverse entered), state'')+      where+        floor' :: Int+        floor' = state'._minted+        planned :: Maybe (Expression, [Attribute]) -> (Int, Binding) -> IO (IO ([Evaluation], Either SomeException (Int -> (Binding, Maybe State))))+        planned alias (idx, BiTau attr body)+          | attr /= AtRho = do+              new <- if closed body then fresh alias attr caller else pure True+              pure (if new then worker idx attr body else kept (BiTau attr body))+        planned _ (_, bd) = pure (kept bd)+        kept :: Binding -> IO ([Evaluation], Either SomeException (Int -> (Binding, Maybe State)))+        kept bd = pure ([], Right (const (bd, Nothing)))+        worker :: Int -> Attribute -> Expression -> IO ([Evaluation], Either SomeException (Int -> (Binding, Maybe State)))+        worker idx attr body = do+          buffer <- newIORef []+          tau <- tausOf idx+          tally <- tallied (fmap (\(Tally cap _) -> cap) caller._tally)+          memo <- memoized caller._acyclic+          let own = caller{_jobs = 1, _tally = tally, _memo = memo, _saveEval = modifyIORef' buffer . (:), _buildTerm = minting tau caller._buildTerm}+          outcome <- try (go (fmap (`ExDispatch` attr) standing) Nothing (scope attr bds) body state' own)+          records <- reverse <$> readIORef buffer+          pure (records, fmap (\(term, walked) offset -> (BiTau attr (lifted floor' offset term), Just (moved offset walked))) outcome)+        moved :: Int -> State -> State+        moved offset walked =+          walked+            { _minted = walked._minted + offset+            , _manufactured = fmap (\sym -> if sym > floor' then sym + offset else sym) walked._manufactured+            }+        gathered :: ([Binding], Int, State) -> ([Evaluation], Either SomeException (Int -> (Binding, Maybe State))) -> IO ([Binding], Int, State)+        gathered (done, offset, current) (records, outcome) = do+          mapM_ (caller._saveEval . renumbered floor' offset) records+          (bd, walked) <- either throwIO (pure . ($ offset)) outcome+          pure (bd : done, maybe offset (\after -> after._minted - floor') walked, fromMaybe current walked)+    spread standing context term state' caller = parts standing context term state' caller+    -- The term builder a binding walked on a worker of its own mints its+    -- fresh names with: the one of the run, except that 'random-tau' draws+    -- from the source of the binding (see 'tausOf').+    minting :: IO T.Text -> BuildTermFunc -> BuildTermFunc+    minting tau build func+      | func == "random-tau" = \args subst -> if null args then TeAttribute . AtLabel <$> tau else build func args subst+      | otherwise = build func     -- Walk the bindings of a formation left to right, threading the state     -- through them. Only what the formation itself holds is entered: ρ names     -- the object around it rather than one inside it, and a void, Δ or λ@@ -908,71 +1020,58 @@       (entered, state'') <- go Nothing Nothing context arg state' caller       pure (ArAlpha alpha entered, state'') --- The premise binding the given expression meta, if any. The conclusion of a--- morphing rule and the argument of a continuation premise are looked up here to--- find the premise that produces them.-producer :: Expression -> [Y.Premise] -> Maybe Y.Premise-producer (ExMeta name) = find (\premise -> premise.result == name)-producer _ = const Nothing---- The premises whose result meta is not bound by any of the given ones — the--- side-computations left once the spine premises are removed.-excluding :: [Y.Premise] -> [Y.Premise] -> [Y.Premise]-excluding premises removed = filter (\premise -> premise.result `notElem` map (.result) removed) premises---- Evaluate one side-computation premise — a 'morph', 'evaluate' or 'contextualize'--- of an earlier term — in isolation, binding its result meta. These never splice--- steps into the trace: 'morph' and 'evaluate' reduce on a fresh chain and discard--- it, 'contextualize' is pure. The state is threaded through: 'evaluate' (the--- 𝔼 of the 'ml' and 'fire' rules) takes the incoming state 𝑠1 and yields a--- new one 𝑠2, 'morph' propagates whatever its sub-reduction produced, and every--- other operation leaves the state untouched.-sidePremise :: Expression -> ReduceContext -> (Subst, State) -> Y.Premise -> IO (Subst, State)-sidePremise univ ctx (subst, state) premise = do-  (term, state') <- runOperation-  case combine (substSingle premise.result (metaValue term)) subst of-    Just subst' -> pure (subst', state')-    Nothing -> throwIO (userError (printf "premise meta '%s' clashes with an existing binding" (T.unpack premise.result)))+-- What the first of the rules 𝕄 or 𝔻 walks concludes with about 'expr' in+-- 'univ', once the premises it runs beside its spine have run, in the order+-- it lists them, each in isolation: a 'morph' and an 'evaluate' reduce on a+-- fresh chain and discard it, a 'contextualize' is pure, and the state is+-- threaded through, so the symbols 𝔼 mints and those of a 'morph' come back+-- to the frame that asked. Nothing where no rule matches. The conditions of a+-- rule are checked the way the matcher checks them, with the world the frame+-- reduces in and the normal forms of the engine.+inferred :: Expression -> Expression -> State -> ReduceContext -> [In.Inference value] -> IO (Maybe (In.Conclusion value, State))+inferred expr univ state ctx rules = do+  ordered <- if ctx._shuffle then shuffle rules else pure rules+  matched <- go ordered+  traverse (premised state) matched   where-    -- The 𝔼 ('evaluate') and 𝕄 ('morph') operations can change the state, so they-    -- go through their state-aware builders, each in the universe its premise-    -- names; every other operation is stateless and the incoming state is-    -- returned unchanged.-    runOperation :: IO (Term, State)-    runOperation = case premise.operation of-      Y.OpEvaluate expr universe -> ctx._evaluate ctx state [ArgExpression expr, ArgExpression universe] subst-      Y.OpMorph expr universe -> do-        world <- buildExpressionThrows universe subst-        _morph world ctx state [ArgExpression expr] subst-      operation -> do-        term <- execBuildTerm univ ctx (verb operation) (verbArgs operation) subst-        pure (term, state)-    metaValue :: Term -> MetaValue-    metaValue (TeExpression value) = MvExpression value-    metaValue (TeAttribute value) = MvAttribute value-    metaValue (TeBytes value) = MvBytes value-    metaValue (TeBindings value) = MvBindings value---- The build-term function name backing a premise operation.-verb :: Y.Operation -> String-verb (Y.OpMorph _ _) = "morph"-verb (Y.OpNormalize _) = "normalize"-verb (Y.OpEvaluate _ _) = "evaluate"-verb (Y.OpContextualize _ _) = "contextualize"-verb (Y.OpDataize _ _) = "dataize"+    go :: [In.Inference value] -> IO (Maybe (In.Premises value))+    go [] = pure Nothing+    go (rule : rest) = rule (RuleContext (execBuildTerm univ ctx) (Just univ) ctx._engine._normal) expr univ >>= maybe (go rest) (pure . Just)+    premised :: State -> In.Premises value -> IO (In.Conclusion value, State)+    premised state' (In.Concludes conclusion) = pure (conclusion, state')+    premised state' (In.Morphs term world next) = do+      (morphed, state'') <- detached term world state' ctx+      next morphed >>= premised state''+    premised state' (In.Evaluates form world next) = do+      (answer, state'') <- ctx._evaluate ctx state' form world+      next answer >>= premised state''+    premised state' (In.Contextualizes term context next) = ctx._engine._contextualize term context >>= next >>= premised state' --- The build-term arguments backing a premise operation. The universe a 'morph'--- or a 'dataize' premise names is the second argument of the judgment, not of--- the build-term function: 'sidePremise' hands it to 𝕄 itself, and the--- 'dataize' function reads data off a term and needs no universe.-verbArgs :: Y.Operation -> [ExtraArgument]-verbArgs (Y.OpMorph expr _) = [ArgExpression expr]-verbArgs (Y.OpNormalize expr) = [ArgExpression expr]-verbArgs (Y.OpEvaluate expr universe) = [ArgExpression expr, ArgExpression universe]-verbArgs (Y.OpContextualize expr context) = [ArgExpression expr, ArgExpression context]-verbArgs (Y.OpDataize expr _) = [ArgExpression expr]+-- Reach the term a rule of 𝕄 or 𝔻 asks its judgment about again from the one+-- the rule built, the way the rule says (see 'Way'): a step of the rule, the+-- same followed by 𝒩, whose steps splice into the chain, or 𝕄 in the universe+-- the rule gives, whose steps splice in too. A 'normalize' premise normalizing+-- the universe itself, the meta the rule's 'universe' bound, is answered with+-- the world the run has already named (see '_universe'), since that is the+-- normal form of the very same program: the 'universe' rule asks for it every+-- time 𝕄 resolves Φ, and normalizing the whole program again for each of them+-- made every step cost the size of the world (#1453).+onward :: NonEmpty Rewritten -> State -> In.Way -> Expression -> ReduceContext -> IO (Morphed, State)+onward seq state (In.Taken step) expr ctx = do+  seq' <- leadsTo seq step expr ctx+  pure ((expr, seq'), state)+onward seq state (In.Normalized step) expr ctx = do+  labelled <- leadsTo seq step expr ctx+  normal <- normalized expr labelled ctx+  pure (normal, state)+onward seq state (In.Named step) expr ctx = case ctx._universe of+  Just world -> onward seq state (In.Taken step) world ctx+  Nothing -> onward seq state (In.Normalized step) expr ctx+onward seq state (In.Staged stage) expr ctx = morph' (expr, seq) stage state ctx -leadsTo :: NonEmpty Rewritten -> String -> Expression -> ReduceContext -> IO (NonEmpty Rewritten)+-- Take a step of the chain: the term at its head is taken to 'expr' by the+-- rule, which is named and tagged with the judgment it belongs to (#1536).+leadsTo :: NonEmpty Rewritten -> (Judgment, String) -> Expression -> ReduceContext -> IO (NonEmpty Rewritten) leadsTo ((current, _) :| rest) rule expr ReduceContext{..} = do   updated <- withLocatedExpression _locator expr current   pure ((updated, Nothing) :| (current, Just rule) : rest)@@ -988,7 +1087,7 @@ normalized :: Expression -> NonEmpty Rewritten -> ReduceContext -> IO (Expression, NonEmpty Rewritten) normalized expr seq ctx@ReduceContext{..} = do   whole <- withLocatedExpression _locator expr (fst (NE.head seq))-  (rewrittens, exceeded) <- rewrite whole normalizationRules (rewriteContext ctx)+  (rewrittens, exceeded) <- rewrite whole _engine._normalization (rewriteContext ctx)   when exceeded (throwIO (OutOfSteps (Cycles _maxCycles)))   let (rw :| rws) = NE.reverse rewrittens       seq' = rw :| rws <> NE.tail seq@@ -999,7 +1098,7 @@     -- disabling the must-checker and breakpoints.     rewriteContext :: ReduceContext -> RewriteContext     rewriteContext ReduceContext{..} =-      RewriteContext _locator _maxDepth _maxCycles _depthSensitive _universe _buildTerm MtDisabled Nothing _saveStep+      RewriteContext _locator _maxDepth _maxCycles _depthSensitive _universe _buildTerm _engine._normal MtDisabled Nothing _saveStep  -- Name the world a run reduces in, where nothing has named it yet: the program -- in normal form, which is what Φ denotes and what 'dot' compares a dispatched@@ -1070,21 +1169,36 @@ -- 'univ'. Every other function is delegated unchanged. This is the matcher's -- condition path (guards in 'when'/'having'), which has no state to thread, so 𝔼 -- and 𝕄 run here on a fresh, empty state whose result is discarded; the--- state-threading callers in 'sidePremise' use '_evaluate' and '_morph' directly.+-- premises of a rule, which thread the state, are run by 'inferred'. execBuildTerm :: Expression -> ReduceContext -> BuildTermFunc-execBuildTerm _ ctx "evaluate" = \args subst -> fst <$> ctx._evaluate ctx emptyState args subst-execBuildTerm univ ctx "morph" = \args subst -> fst <$> _morph univ ctx emptyState args subst+execBuildTerm _ ctx "evaluate" = evaluated ctx+execBuildTerm univ ctx "morph" = _morph univ ctx execBuildTerm _ ctx func = _buildTerm ctx func +-- The Evaluation function 𝔼 exposed as a build-term function, the formation+-- and the universe built out of the substitution.+evaluated :: ReduceContext -> BuildTermMethod+evaluated ctx [ArgExpression expr, ArgExpression universe] subst = do+  form <- buildExpressionThrows expr subst+  world <- buildExpressionThrows universe subst+  TeExpression . fst <$> ctx._evaluate ctx emptyState form world+evaluated _ _ _ = throwIO (userError "Function evaluate() requires exactly 2 expression arguments")+ -- The Morphing function 𝕄 exposed as a build-term function so a rule can morph--- a sub-expression in its 'where' (the 'md' and 'ma' rules morph--- the head before re-attaching it). The step chain is discarded: the producing--- rule splices the surrounding normalization steps itself, and a stuck λ met--- on the way leaves without it (see 'unparked'). The state is threaded through--- and the new state returned alongside the morphed term.-_morph :: Expression -> ReduceContext -> State -> BuildTermMethodS-_morph univ ctx state [ArgExpression expr] subst = unparked $ do+-- a sub-expression in its 'where' (see 'detached').+_morph :: Expression -> ReduceContext -> BuildTermMethod+_morph univ ctx [ArgExpression expr] subst = do   built <- buildExpressionThrows expr subst-  ((morphed, _), state') <- morph' (built, (univ, Nothing) :| []) univ state ctx-  pure (TeExpression morphed, state')-_morph _ _ _ _ _ = throwIO (userError "Function morph() requires exactly 1 expression argument")+  TeExpression . fst <$> detached built univ emptyState ctx+_morph _ _ _ _ = throwIO (userError "Function morph() requires exactly 1 expression argument")++-- Morph 'expr' in 'univ' on a chain of its own, the way a 'morph' premise+-- beside the spine does (the 'md' and 'ma' rules morph the head before+-- re-attaching it). The step chain is discarded: the producing rule splices+-- the surrounding normalization steps itself, and a stuck λ met on the way+-- leaves without it (see 'unparked'). The state is threaded through and the+-- new state returned alongside the morphed term.+detached :: Expression -> Expression -> State -> ReduceContext -> IO (Expression, State)+detached expr univ state ctx = unparked $ do+  ((morphed, _), state') <- morph' (expr, (univ, Nothing) :| []) univ state ctx+  pure (morphed, state')

@@ -0,0 +1,36 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++-- A handful of workers taking independent actions off one list, which is+-- how the '--deep' walk under '--jobs' morphs the bindings of the formation+-- it starts at side by side (#1534). What the actions gave is folded in the+-- order they were listed and not in the order they finished, so whatever+-- the fold writes, the protocol above all, comes out the same however the+-- workers were scheduled, and it comes out as soon as an action and every+-- one before it are done rather than once the slowest of them is.+module Pool (pooled) where++import Control.Concurrent (QSem, ThreadId, forkIO, killThread, newQSem, signalQSem, waitQSem)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)+import Control.Exception (SomeException, bracket_, finally, mask, throwIO, try)+import Control.Monad (foldM)++-- Run the actions, at most as many at once as the first argument says, and+-- fold what they gave in the order they were listed. An action that threw+-- has its exception thrown once everything listed before it is folded, and+-- the actions still running are stopped then, since nobody waits for them.+pooled :: forall a b. Int -> [IO a] -> (b -> a -> IO b) -> b -> IO b+pooled width actions fold start = do+  gate <- newQSem (max 1 width)+  launched <- mapM (launch gate) actions+  foldM collected start (map snd launched) `finally` mapM_ (killThread . fst) launched+  where+    launch :: QSem -> IO a -> IO (ThreadId, MVar (Either SomeException a))+    launch gate action = do+      box <- newEmptyMVar+      thread <- mask $ \restore -> forkIO (try (restore (bracket_ (waitQSem gate) (signalQSem gate) action)) >>= putMVar box)+      pure (thread, box)+    collected :: b -> MVar (Either SomeException a) -> IO b+    collected acc box = takeMVar box >>= either throwIO (fold acc)

@@ -9,7 +9,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rewriter (Seen, rewrite, RewriteContext (..), Rewritten, Rewrittens, Rewrittens', seenInsert, seenMember, stepHeaders) where+module Rewriter (Seen, direct, fast, interpreted, rewrite, RewriteContext (..), Rewritten, Rewrittens, Rewrittens', seenInsert, seenMember, stepHeaders) where  import AST import Builder@@ -17,15 +17,14 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map-import Data.Maybe (fromMaybe) import Deps import Locator (locatedExpression, withLocatedExpression) import Logger (logDebug)-import Matcher (Subst)+import Matcher (Subst, sites) import Must (Must (..), exceedsUpperBound, inRange) import Printer (printExpression) import Replacer (ReplaceExpressionFunc, replaceExpression, replaceExpressionFast)-import Rule (RuleContext (RuleContext))+import Rule (RuleContext (RuleContext), Step (..)) import qualified Rule as R import Text.Printf (printf) import qualified Yaml as Y@@ -48,7 +47,10 @@ seenInsert :: Int -> Expression -> Seen -> Seen seenInsert digest expr = Map.insertWith (++) digest [expr] -type Rewritten = (Expression, Maybe String)+-- A step of a rewriting chain: the expression, and the rule that took it to+-- the next one, named and tagged with the judgment it belongs to, which is how+-- a chain of 𝕄 or 𝔻 mixing rules of several judgments tells them apart (#1536).+type Rewritten = (Expression, Maybe (Judgment, String))  type Rewrittens = (NonEmpty Rewritten, Bool) @@ -71,7 +73,7 @@       printf         "=== Step #%d, Rule '%s', %dt -> %dt"         step-        (fromMaybe "?" rule)+        (maybe "?" snd rule)         (countNodes before)         (countNodes current) @@ -91,6 +93,9 @@     -- names nothing.     _universe :: Maybe Expression   , _buildTerm :: BuildTermFunc+  , -- Whether a term is a normal form, which a '𝑛' or '𝑘' meta of a rule asks+    -- (see '_normal' of 'RuleContext').+    _normal :: Expression -> Bool   , _must :: Must   , _breakpoint :: Maybe String   , _saveStep :: SaveStepFunc@@ -144,21 +149,25 @@ -- You can find more details in this ticket: https://github.com/objectionary/phino/issues/321 -- If we don't meet the conditions above - just do a regular replacing tryBuildAndReplaceFast :: ToReplace -> IO Expression-tryBuildAndReplaceFast state@(expr, ExFormation _pbds@(pbd : pbds), ExFormation _rbds@(rbd : rbds), substs) =-  let pbds' = init pbds-      rbds' = init rbds-   in if startsAndEndsWithMeta _pbds-        && startsAndEndsWithMeta _rbds-        && pbd == rbd-        && last pbds == last rbds-        && not (hasMetaBindings pbds')-        && not (hasMetaBindings rbds')-        then do-          logDebug "Applying fast replacing since 'pattern' and 'result' are suitable for this..."-          buildAndReplace' (expr, ExFormation pbds', ExFormation rbds', substs) replaceExpressionFast-        else do-          logDebug "Applying regular replacing..."-          buildAndReplace' state replaceExpression+tryBuildAndReplaceFast state@(expr, ptn@(ExFormation (_ : pbds)), res@(ExFormation (_ : rbds)), substs)+  | fast ptn res = do+      logDebug "Applying fast replacing since 'pattern' and 'result' are suitable for this..."+      buildAndReplace' (expr, ExFormation (init pbds), ExFormation (init rbds), substs) replaceExpressionFast+  | otherwise = do+      logDebug "Applying regular replacing..."+      buildAndReplace' state replaceExpression+tryBuildAndReplaceFast state = buildAndReplace' state replaceExpression++-- Whether a rule of the pattern and the result is replaced the fast way (see+-- 'tryBuildAndReplaceFast').+fast :: Expression -> Expression -> Bool+fast (ExFormation _pbds@(pbd : pbds)) (ExFormation _rbds@(rbd : rbds)) =+  startsAndEndsWithMeta _pbds+    && startsAndEndsWithMeta _rbds+    && pbd == rbd+    && last pbds == last rbds+    && not (hasMetaBindings (init pbds))+    && not (hasMetaBindings (init rbds))   where     startsAndEndsWithMeta :: [Binding] -> Bool     startsAndEndsWithMeta [] = False@@ -167,21 +176,51 @@         && isMetaBinding bd         && isMetaBinding (last bds)     hasMetaBindings :: [Binding] -> Bool+    hasMetaBindings = foldl (\acc bd -> acc || isMetaBinding bd) False     isMetaBinding :: Binding -> Bool     isMetaBinding = \case       BiMeta _ -> True       BiAny _ -> True       _ -> False-    hasMetaBindings = foldl (\acc bd -> acc || isMetaBinding bd) False-tryBuildAndReplaceFast state = buildAndReplace' state replaceExpression+fast _ _ = False +-- The step a rule of YAML takes: the matcher finds every place the rule+-- matches at and the builder and the replacer rewrite them (see+-- 'tryBuildAndReplaceFast').+interpreted :: Y.Rule -> Step+interpreted rule = Step rule.name applied+  where+    applied :: RuleContext -> Expression -> IO (Maybe Expression)+    applied ctx expr =+      R.matchExpressionWithRule expr rule ctx >>= \case+        [] -> pure Nothing+        matched -> Just <$> tryBuildAndReplaceFast (expr, rule.pattern, rule.result, matched)++-- The step a rule 'phino compile' turned into Haskell takes: the rule is a+-- function telling what it rewrites a term to where the term matches it as a+-- whole, and the places it matches at are found in the order the matcher+-- finds them (see 'sites') and replaced in that order, exactly as the replacer+-- replaces those of a rule of YAML. A place inside what an earlier one was+-- rewritten to is therefore a step of its own, as it is for the matcher, and+-- the chain of steps does not depend on which of the two ran (#1617). The+-- flag says whether the rule matches only a redex (see 'R.redex').+-- The function is told the world the term stands in, where one is known,+-- which is what the 'named' function of a rule reads.+direct :: String -> Bool -> (Maybe Expression -> Expression -> [Expression]) -> Step+direct name redex rewritten = Step name applied+  where+    applied :: RuleContext -> Expression -> IO (Maybe Expression)+    applied (RuleContext _ universe _) expr = pure $ case sites redex (rewritten universe) expr of+      [] -> Nothing+      found -> Just (replaceExpression (expr, map fst found, map (const . snd) found))+ -- The function returns tuple (X, Y, Z) where -- - X is sequence of expressions; -- - Y is Set of unique expressions after each rule application. It allows to stop the rewriting if we're getting --   into loop and get back to an expression which we've already got before -- - Z is boolean flag which tells us if we reach breakpoint. If unmatched rule is equal to breakpoint rule - entire --   rewriting must be stopped and original expression must be returned-rewrite' :: RewriteState -> [Y.Rule] -> Int -> RewriteContext -> IO RewriteState+rewrite' :: RewriteState -> [Step] -> Int -> RewriteContext -> IO RewriteState rewrite' state [] _ _ = pure state rewrite' state (rule : rest) iteration ctx@RewriteContext{..} = do   state' <- _rewrite state 1@@ -191,9 +230,7 @@   where     _rewrite :: RewriteState -> Int -> IO RewriteState     _rewrite (_rewrittens@((current, _) :| _), _unique, _) _count =-      let ruleName = rule.name-          ptn = rule.pattern-          res = rule.result+      let ruleName = _name rule        in if _count - 1 == _maxDepth             then do               logDebug (printf "Max amount of rewriting cycles (%d) for rule '%s' has been reached, rewriting is stopped" _maxDepth ruleName)@@ -207,17 +244,16 @@             else do               logDebug (printf "Starting rewriting cycle for rule '%s': %d out of %d" ruleName _count _maxDepth)               expression <- locatedExpression _locator current-              R.matchExpressionWithRule expression rule (RuleContext _buildTerm _universe) >>= \case-                [] -> do+              _applied rule (RuleContext _buildTerm _universe _normal) expression >>= \case+                Nothing -> do                   logDebug (printf "Rule '%s' does not match, rewriting is stopped" ruleName)                   if _breakpoint == Just ruleName                     then do                       logDebug (printf "Rule '%s' is a breakpoint, dropping down all the previous rewritings..." ruleName)                       pure (_rewrittens, _unique, True)                     else pure (_rewrittens, _unique, False)-                matched -> do-                  logDebug (printf "Rule '%s' has been matched, applying..." ruleName)-                  expr <- tryBuildAndReplaceFast (expression, ptn, res, matched)+                Just expr -> do+                  logDebug (printf "Rule '%s' has been matched and applied" ruleName)                   if expression == expr                     then do                       logDebug (printf "Applied '%s', no changes made" ruleName)@@ -242,25 +278,25 @@         leadsTo :: Expression -> NonEmpty Rewritten         leadsTo next =           let (head', _) :| rest = _rewrittens-           in (next, Nothing) :| (head', Just rule.name) : rest+           in (next, Nothing) :| (head', Just (Normalization, _name rule)) : rest  -- Tells whether any of the rules still matches the located expression. A run -- with nothing left to rewrite after its last allowed step has finished, not -- run out of its limit, so --depth-sensitive lets it pass (#1439)-applicable :: Expression -> [Y.Rule] -> RewriteContext -> IO Bool+applicable :: Expression -> [Step] -> RewriteContext -> IO Bool applicable current rules RewriteContext{..} = do   expression <- locatedExpression _locator current   go expression rules   where-    go :: Expression -> [Y.Rule] -> IO Bool+    go :: Expression -> [Step] -> IO Bool     go _ [] = pure False     go expression (rule : rest) =-      R.matchExpressionWithRule expression rule (RuleContext _buildTerm _universe) >>= \case-        [] -> go expression rest-        _ -> pure True+      _applied rule (RuleContext _buildTerm _universe _normal) expression >>= \case+        Nothing -> go expression rest+        Just _ -> pure True  -- Rewrite the expression by provided locator from RewriteContext-rewrite :: Expression -> [Y.Rule] -> RewriteContext -> IO Rewrittens+rewrite :: Expression -> [Step] -> RewriteContext -> IO Rewrittens rewrite expr rules ctx@RewriteContext{..} = do   (rewrittens, exceeded) <- _rewrite ((expr, Nothing) :| [], Map.empty, False) 0   pure (NE.reverse rewrittens, exceeded)

@@ -6,7 +6,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rule (RuleContext (..), isNF, matchExpressionWithRule, matchExpressionWithRule', meetCondition, redex) where+module Rule (RuleContext (..), Step (..), domainOf, isFormation, isNF, matchExpressionWithRule, matchExpressionWithRule', meetCondition, normal, normalHeld, normalWith, presentIn, redex, xiFree) where  import AST import Builder@@ -27,7 +27,7 @@ import Data.Maybe (catMaybes) import qualified Data.Text as T import Deps (BuildTermFunc, BuildTermMethod, Term (..))-import Functions (nameOf)+import Functions (buildTerm, nameOf) import GHC.IO (unsafePerformIO) import Logger (logDebug) import Matcher@@ -41,35 +41,69 @@ -- functions and the world the matched term stands in, where one is known. -- A normalization rule is about a term alone, so the world stays out of its -- YAML and reaches only the functions that need it, which is 'named' writing--- 'Φ' or 'Φ.number' into a ρ instead of the object (#1318, #1460).+-- 'Φ' or 'Φ.number' into a ρ instead of the object (#1318, #1460). A '𝑛' or+-- '𝑘' meta asks whether a term is a normal form, which is a question about the+-- built-in normalization rules, so the context carries the answer the engine+-- running them gives, the YAML read at run time or the Haskell 'phino compile'+-- wrote (#1617). data RuleContext = RuleContext   { _buildTerm :: BuildTermFunc   , _universe :: Maybe Expression+  , _normal :: Expression -> Bool   } --- Returns True if given expression matches with any of given normalization rules--- Here we use unsafePerformIO because we're sure that conditions which are used--- in normalization rules doesn't throw an exception.+-- One rewriting rule ready to run: its name, which the chain, '--breakpoint'+-- and the step headers show, and what it makes of a whole term, rewriting+-- every place it matches at once. The answer is nothing where the rule+-- matches nowhere, and the term, changed or not, where it matches somewhere,+-- since the rewriter tells the two apart. A step is either a rule of YAML the+-- matcher interprets or a rule 'phino compile' turned into Haskell, and the+-- rewriter cannot tell one from the other (#1617).+data Step = Step+  { _name :: String+  , _applied :: RuleContext -> Expression -> IO (Maybe Expression)+  }++-- Whether any normalization rule applies to the term or to a place inside it:+-- its pattern, its '𝑛' and '𝑘' metas and its 'when' hold, whatever its 'where'+-- makes of them, which is what the compiled 'nf' asks too. A function of+-- 'where' may fail where the rule applies, as 'contextualize' of 'dot' fails on+-- '⟦ x ↦ 𝑒9.y ⟧.x', since no rule of 𝒞 takes a meta (#1630). Here we use+-- unsafePerformIO because we're sure that conditions which are used in+-- normalization rules do not throw an exception. matchesAnyNormalizationRule :: Expression -> RuleContext -> Bool matchesAnyNormalizationRule expr ctx = matchesAnyNormalizationRule' expr normalizationRules ctx   where     matchesAnyNormalizationRule' :: Expression -> [Y.Rule] -> RuleContext -> Bool     matchesAnyNormalizationRule' _ [] _ = False     matchesAnyNormalizationRule' expr (rule : rules) ctx =-      let matched = unsafePerformIO (matchExpressionWithRule expr rule ctx)+      let matched = unsafePerformIO (admitted (deep rule) [substEmpty] expr rule ctx)        in not (null matched) || matchesAnyNormalizationRule' expr rules ctx  -- Returns True if given expression is in the normal form isNF :: Expression -> RuleContext -> Bool-isNF ExXi _ = True-isNF ExRoot _ = True-isNF ExTermination _ = True-isNF (ExDispatch ExXi _) _ = True-isNF (ExDispatch ExRoot _) _ = True-isNF (ExDispatch ExTermination _) _ = False -- dd rule-isNF (ExApplication ExTermination _) _ = False -- dc rule-isNF (ExFormation []) _ = True-isNF (ExFormation bds) ctx = normalBindings bds || not (matchesAnyNormalizationRule (ExFormation bds) ctx)+isNF expr ctx = normalWith (`matchesAnyNormalizationRule` ctx) expr++-- Whether a term is a normal form by the rules of YAML, the answer an engine+-- that interprets them gives to a '𝑛' or '𝑘' meta (see '_normal'). The rules+-- are matched with a context of their own, since a normal form is a property+-- of the term alone.+normal :: Expression -> Bool+normal expr = isNF expr (RuleContext buildTerm Nothing normal)++-- Whether a term is a normal form, told whether some normalization rule+-- matches somewhere inside a given term. A few shapes are decided before any+-- rule is asked, since the rules themselves decide them the same way.+normalWith :: (Expression -> Bool) -> Expression -> Bool+normalWith _ ExXi = True+normalWith _ ExRoot = True+normalWith _ ExTermination = True+normalWith _ (ExDispatch ExXi _) = True+normalWith _ (ExDispatch ExRoot _) = True+normalWith _ (ExDispatch ExTermination _) = False -- dd rule+normalWith _ (ExApplication ExTermination _) = False -- dc rule+normalWith _ (ExFormation []) = True+normalWith matching (ExFormation bds) = normalBindings bds || not (matching (ExFormation bds))   where     -- Returns True if all given bindings are 100% in normal form: each one is     -- a Δ, a λ or a void, and no Δ stands beside a λ, since 'dl' turns such a@@ -87,8 +121,18 @@     lambda :: Binding -> Bool     lambda (BiLambda _) = True     lambda _ = False-isNF expr ctx = not (matchesAnyNormalizationRule expr ctx)+normalWith matching expr = not (matching expr) +-- Whether the term a '𝑛' or '𝑘' meta of a rule holds is a normal form by the+-- given test, the way the matcher tells it (see '_nf'): the matcher reads a+-- term that is itself a meta as one more meta to look up, and finds nothing+-- bound to it, so such a term is no normal form. A program holds no meta, so+-- only a term handed to a judgment by hand tells this apart.+normalHeld :: (Expression -> Bool) -> Expression -> Bool+normalHeld _ (ExMeta _) = False+normalHeld _ (ExAny _) = False+normalHeld test expr = test expr+ _or :: [Y.Condition] -> Subst -> RuleContext -> IO [Subst] _or [] _ _ = pure [] _or (cond : rest) subst ctx = do@@ -128,16 +172,22 @@   Just (MvBindings bds) -> Just (length bds)   _ -> Nothing numToInt (Y.Domain (BiMeta meta)) (Subst mp) = case M.lookup (Named meta) mp of-  Just (MvBindings bds) -> Just (length (filter notAsset bds))+  Just (MvBindings bds) -> Just (domainOf bds)   _ -> Nothing+numToInt (Y.Literal num) _ = Just num+numToInt _ _ = Nothing++-- How many of the bindings are attributes a positional argument may fill:+-- every one but Δ, λ and ρ, which is what 'domain' of a rule counts.+domainOf :: [Binding] -> Int+domainOf = length . filter notAsset   where+    notAsset :: Binding -> Bool     notAsset (BiDelta _) = False     notAsset (BiLambda _) = False     notAsset (BiVoid AtRho) = False     notAsset (BiTau AtRho _) = False     notAsset _ = True-numToInt (Y.Literal num) _ = Just num-numToInt _ _ = Nothing  _eq :: Y.Comparable -> Y.Comparable -> Subst -> RuleContext -> IO [Subst] _eq (Y.CmpNum left) (Y.CmpNum right) subst _ = case (numToInt left subst, numToInt right subst) of@@ -182,7 +232,7 @@ _nf (ExAny slot) (Subst mp) ctx = case M.lookup (Anon slot) mp of   Just (MvExpression expr) -> _nf expr (Subst mp) ctx   _ -> pure []-_nf expr subst ctx = pure [subst | isNF expr ctx]+_nf expr subst ctx = pure [subst | _normal ctx expr]  -- An expression is xi-free when it contains no ξ outside of a formation: it is -- Φ, ⊥, a formation, a dispatch with a xi-free subject, or an application with@@ -200,16 +250,17 @@   Just (MvExpression expr) -> _absolute expr (Subst mp) ctx   _ -> pure [] _absolute expr subst _ = pure [subst | xiFree expr]-  where-    xiFree :: Expression -> Bool-    xiFree (ExFormation _) = True-    xiFree ExRoot = True-    xiFree ExTermination = True-    xiFree (ExApplication e (ArTau _ te)) = xiFree e && xiFree te-    xiFree (ExApplication e (ArAlpha _ te)) = xiFree e && xiFree te-    xiFree (ExDispatch e _) = xiFree e-    xiFree _ = False +-- Whether the term holds no ξ outside of a formation (see '_absolute').+xiFree :: Expression -> Bool+xiFree (ExFormation _) = True+xiFree ExRoot = True+xiFree ExTermination = True+xiFree (ExApplication e (ArTau _ te)) = xiFree e && xiFree te+xiFree (ExApplication e (ArAlpha _ te)) = xiFree e && xiFree te+xiFree (ExDispatch e _) = xiFree e+xiFree _ = False+ -- Hold when the given expression is a formation (an abstraction ⟦…⟧). A meta -- is resolved first, so 'binding 𝑛' inspects whatever 𝑛 is bound to. _isFormation :: Expression -> Subst -> RuleContext -> IO [Subst]@@ -217,11 +268,12 @@   Just (MvExpression expr) -> _isFormation expr (Subst mp) ctx   _ -> pure [] _isFormation expr subst _ = pure [subst | isFormation expr]-  where-    isFormation :: Expression -> Bool-    isFormation (ExFormation _) = True-    isFormation _ = False +-- Whether the term is a formation (see '_isFormation').+isFormation :: Expression -> Bool+isFormation (ExFormation _) = True+isFormation _ = False+ _matches :: String -> Expression -> Subst -> RuleContext -> IO [Subst] _matches pat (ExMeta meta) (Subst mp) ctx = case M.lookup (Named meta) mp of   Just (MvExpression expr) -> _matches pat expr (Subst mp) ctx@@ -386,13 +438,15 @@ -- A rule that matches only a redex never looks inside an inert term (see -- 'redex'). matchExpressionWithRule :: Expression -> Y.Rule -> RuleContext -> IO [Subst]-matchExpressionWithRule expr rule = matchExpressionBy deep [substEmpty] expr rule-  where-    deep :: MatchExpressionFunc-    deep ptn tgt-      | reachable' (redex rule) ptn tgt = matchExpressionDeep' (redex rule) ptn tgt-      | otherwise = []+matchExpressionWithRule expr rule = matchExpressionBy (deep rule) [substEmpty] expr rule +-- The deep matcher of the rule, asked only where its pattern fits somewhere in+-- the term (see 'matchExpressionWithRule').+deep :: Y.Rule -> MatchExpressionFunc+deep rule ptn tgt+  | reachable' (redex rule) ptn tgt = matchExpressionDeep' (redex rule) ptn tgt+  | otherwise = []+ -- Whether every match of the rule its 'when' lets through stands at a place -- no 'inert' term holds, judged by the pattern and the 'when' alone, so it -- holds for a rule of phino and for a rule of the user alike. A pattern@@ -438,13 +492,31 @@ -- the seed is dropped only when the pattern binds the same name to a different -- value; rules that do not mention the name simply carry it along unused. matchExpressionBy :: MatchExpressionFunc -> [Subst] -> Expression -> Y.Rule -> RuleContext -> IO [Subst]-matchExpressionBy matcher seed expr rule ctx =+matchExpressionBy matcher seed expr rule ctx = do+  when' <- admitted matcher seed expr rule ctx+  if null when'+    then pure []+    else do+      logDebug (printf "Rule %s" rule.name)+      extended <- extraSubstitutions when' rule.where_ ctx+      if null extended+        then do+          logDebug "Substitution is empty after extending, maybe some metas are duplicated"+          pure []+        else do+          met <- meetMaybeCondition rule.having extended ctx+          when (null met) (logDebug "The 'having' condition wasn't met")+          pure met++-- The matches of the rule its pattern, its '𝑛' and '𝑘' metas and its 'when'+-- let through, before its 'where' and its 'having' are asked anything.+admitted :: MatchExpressionFunc -> [Subst] -> Expression -> Y.Rule -> RuleContext -> IO [Subst]+admitted matcher seed expr rule ctx =   let ptn = rule.pattern       matched = combineMany seed (matcher ptn expr)-      name = rule.name    in if null matched         then do-          logDebug (printf "Pattern from rule '%s' was not matched:\n%s" name (printExpression' ptn logPrintConfig))+          logDebug (printf "Pattern from rule '%s' was not matched:\n%s" rule.name (printExpression' ptn logPrintConfig))           pure []         else do           -- A '𝑘' meta-variable is absolute (𝒦 ⊆ 𝒩): check it is xi-free first@@ -458,21 +530,8 @@               pure []             else do               when' <- meetMaybeCondition rule.when inNf ctx-              if null when'-                then do-                  logDebug "The 'when' condition wasn't met"-                  pure []-                else do-                  logDebug (printf "Rule %s" name)-                  extended <- extraSubstitutions when' rule.where_ ctx-                  if null extended-                    then do-                      logDebug "Substitution is empty after extending, maybe some metas are duplicated"-                      pure []-                    else do-                      met <- meetMaybeCondition rule.having extended ctx-                      when (null met) (logDebug "The 'having' condition wasn't met")-                      pure met+              when (null when') (logDebug "The 'when' condition wasn't met")+              pure when'   where     nfMetas :: Expression -> [Expression]     nfMetas = metasWithPrefix "n"

@@ -11,10 +11,10 @@ -- cycles) never reuse one. A monotonic cursor advances past taken indices so -- minting never rescans the document. Names are sequential rather than -- random, which makes the rewritten output deterministic.-module Tau (seedTaus, freshTau) where+module Tau (seedTaus, freshTau, tausOf) where  import AST-import Data.IORef (IORef, atomicModifyIORef', newIORef, writeIORef)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text)@@ -43,13 +43,36 @@       let (minted, idx) = mint taken cursor        in ((Set.insert minted taken, idx + 1), minted) +-- A source of fresh names of its own for one entry of a run under '--jobs',+-- which morphs the bindings of a formation side by side (#1534). The names+-- carry the entry, 'a🌵7-0' for the seventh binding, so no two entries mint+-- one name and none of them mints a name the run itself does, and they are+-- counted per entry, so what an entry is named does not depend on which+-- worker got to a name first. The names the document took when the source+-- was made are skipped, the way 'freshTau' skips them.+tausOf :: Int -> IO (IO Text)+tausOf entry = do+  (taken, _) <- readIORef taus+  own <- newIORef (taken, 0)+  pure (atomicModifyIORef' own advance)+  where+    advance :: (Set Text, Int) -> ((Set Text, Int), Text)+    advance (taken, cursor) =+      let (minted, idx) = mint' (T.pack ("a🌵" <> show entry <> "-")) taken cursor+       in ((Set.insert minted taken, idx + 1), minted)+ -- Find the first index at or after the cursor whose name is still free. mint :: Set Text -> Int -> (Text, Int)-mint taken idx-  | name `Set.member` taken = mint taken (idx + 1)+mint = mint' "a🌵"++-- The same, for names spelled with the given stem.+mint' :: Text -> Set Text -> Int -> (Text, Int)+mint' stem taken idx+  | name `Set.member` taken = mint' stem taken (idx + 1)   | otherwise = (name, idx)   where-    name = "a🌵" <> T.pack (show idx)+    name :: Text+    name = stem <> T.pack (show idx)  exprLabels :: Expression -> Set Text exprLabels (ExFormation bds) = Set.unions (map bindingLabels bds)

@@ -11,9 +11,11 @@ module ASTSpec where  import AST+import Control.Exception (evaluate) import Control.Monad (forM_) import Data.List (nub, sort) import Data.Text qualified as T+import GHC.Clock (getMonotonicTime) import Test.Hspec (Spec, describe, it, shouldBe, shouldNotBe, shouldSatisfy)  spec :: Spec@@ -297,6 +299,13 @@         pair tail' = ExApplication (ExDispatch ExRoot (AtLabel "pair")) (ArTau (AtLabel "tail") tail')         call :: Int -> Expression -> Expression         call idx acc = ExFormation [BiTau (AtLabel "n") (ExFormation [BiLambda (FnSymbol idx)]), BiTau (AtLabel "acc") acc, BiLambda (Function "L_fact")]+        chain :: Int -> Expression -> Expression+        chain depth base = iterate (`ExDispatch` AtLabel "qv") base !! depth+    it "does not search a place again for a term it already failed to find there" $ do+      start <- getMonotonicTime+      _ <- evaluate (within (chain 16 ExXi) (chain 32 ExRoot))+      end <- getMonotonicTime+      end - start `shouldSatisfy` (< 1)     it "finds a round inside the next one that wraps its accumulator once more" $       within (call 3 (ExFormation [BiDelta (BtOne "2A")])) (call 8 (pair (ExFormation [BiDelta (BtOne "2A")]))) `shouldBe` True     it "does not find a call inside a smaller one nested in it" $@@ -509,3 +518,14 @@     it "does not show what a node carries besides its parts" $       show (ExApplication (ExDispatch ExXi (AtLabel "yb")) (ArAlpha (Alpha 0) (ExFormation [BiVoid AtRho])))         `shouldBe` "ExApplication (ExDispatch ExXi yb) (ArAlpha α0 (ExFormation [BiVoid ρ]))"++  describe "lifted" $ do+    it "raises every symbol above the floor by the offset" $+      symbols (lifted 4 7 (ExApplication (ExFormation [BiLambda (FnSymbol 5)]) (ArTau (AtLabel "wo") (ExFormation [BiTau AtPhi (ExFormation [BiLambda (FnSymbol 9)])]))))+        `shouldBe` [12, 16]+    it "does not raise a symbol at the floor or under it" $+      symbols (lifted 4 7 (ExDispatch (ExFormation [BiLambda (FnSymbol 4), BiTau (AtLabel "qe") (ExFormation [BiLambda (FnSymbol 2)])]) (AtLabel "ke")))+        `shouldBe` [4, 2]+    it "does not touch a term carrying no symbol" $+      lifted 0 3 (ExFormation [BiTau (AtLabel "ul") (ExDispatch ExXi (AtLabel "ha")), BiLambda (Function "L_up"), BiDelta (BtOne "1F")])+        `shouldBe` ExFormation [BiTau (AtLabel "ul") (ExDispatch ExXi (AtLabel "ha")), BiLambda (Function "L_up"), BiDelta (BtOne "1F")]

@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-}  -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com@@ -15,10 +14,7 @@ import Data.Map.Strict qualified as Map import Data.Text qualified as T import Matcher-import System.Random (randomRIO) import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, anyException, describe, it, shouldBe, shouldSatisfy, shouldThrow)-import Text.Printf (printf)-import Yaml qualified as Y  test :: (Show a, Eq a) => (a -> Subst -> Either String a) -> [(String, a, [(T.Text, MetaValue)], Either String a)] -> SpecWith (Arg Expectation) test function useCases =@@ -118,51 +114,6 @@         [substSingle "e1" (MvExpression (ExDispatch ExRoot (AtLabel "x")))]         `shouldThrow` anyException -  describe "contextualize" $-    let commonContext :: Expression-        commonContext = ExFormation [BiVoid AtRho]-     in forM_-          [ ("replaces a xi expression with the context", ExXi, commonContext, commonContext)-          , ("keeps a root expression untouched", ExRoot, commonContext, ExRoot)-          ,-            ( "keeps an empty formation untouched"-            , ExFormation [BiVoid AtRho]-            , ExFormation [BiVoid AtRho, BiVoid AtRho]-            , ExFormation [BiVoid AtRho]-            )-          ,-            ( "recurses into a dispatch application"-            , ExDispatch ExXi (AtLabel "z")-            , commonContext-            , ExDispatch commonContext (AtLabel "z")-            )-          , ("keeps a termination untouched", ExTermination, commonContext, ExTermination)-          ,-            ( "recurses into both sides of an application with a tau argument"-            , ExApplication ExXi (ArTau (AtLabel "x") ExXi)-            , commonContext-            , ExApplication commonContext (ArTau (AtLabel "x") commonContext)-            )-          ,-            ( "recurses into both sides of an application with an alpha argument"-            , ExApplication ExXi (ArAlpha (Alpha 0) ExXi)-            , commonContext-            , ExApplication commonContext (ArAlpha (Alpha 0) commonContext)-            )-          , ("leaves any other expression untouched", ExMeta "e", commonContext, ExMeta "e")-          ]-          (\(desc, expr, context, expected) -> it desc (contextualize expr context `shouldBe` expected))--  describe "contextualize against the contextualization rules" $ do-    it "contextualizes every random term as the one rule matching it concludes" $ do-      pairs <- replicateM 500 ((,) <$> term 3 <*> term 2)-      map (\(expr, context) -> conclusions expr context Y.contextualizationRules) pairs-        `shouldBe` map (\(expr, context) -> [contextualize expr context]) pairs-    it "leaves no contextualization rule unmatched by random terms" $ do-      pairs <- replicateM 500 ((,) <$> term 3 <*> term 2)-      [rule.name | rule <- Y.contextualizationRules, all (\(expr, context) -> null (conclusions expr context [rule])) pairs]-        `shouldBe` []-   describe "buildBinding: lambda and delta bindings from metas" $     forM_       [@@ -274,42 +225,14 @@         (ExFormation [BiTau (AtLabel "qwv") (ExFormation [BiVoid AtRho]), BiLambda (Function "Kzr")])         (ExFormation [BiTau (AtLabel "qwv") (ExFormation [BiVoid AtRho]), BiLambda (Function "Kzr")])         `shouldBe` ExRoot-  where-    -- A term of the calculus no deeper than the given depth, made of the six-    -- forms 𝒞 is defined over, so every contextualization rule meets some.-    term :: Int -> IO Expression-    term depth = do-      form <- randomRIO (0 :: Int, if depth > 0 then 6 else 2)-      case form of-        0 -> pure ExXi-        1 -> pure ExRoot-        2 -> pure ExTermination-        3 -> do-          attr <- attribute-          body <- term (depth - 1)-          pure (ExFormation [BiTau attr body, BiVoid AtRho])-        4 -> ExDispatch <$> term (depth - 1) <*> attribute-        5 -> ExApplication <$> term (depth - 1) <*> (ArTau <$> attribute <*> term (depth - 1))-        _ -> ExApplication <$> term (depth - 1) <*> (ArAlpha . Alpha <$> randomRIO (0, 9) <*> term (depth - 1))-    attribute :: IO Attribute-    attribute = do-      letters <- replicateM 3 (randomRIO ('a', 'z'))-      pick <- randomRIO (0 :: Int, 3)-      pure ([AtLabel (T.pack letters), AtPhi, AtLabel (T.pack (reverse letters)), AtLambda] !! pick)-    -- What the given rules conclude 𝒞(n, c) to be, one conclusion per match,-    -- reading every premise 𝒞 of a smaller term off 'contextualize' itself.-    conclusions :: Expression -> Expression -> [Y.ContextualizeRule] -> [Expression]-    conclusions expr context rules =-      [ built-      | rule <- rules-      , matched <- matchExpression' rule.match expr-      , around <- matchExpression' rule.cmatch context-      , Just subst <- [combine matched around]-      , Right built <- [foldM premised subst rule.premises >>= buildExpression rule.cresult]-      ]-    premised :: Subst -> Y.Premise -> Either String Subst-    premised subst (Y.Premise result (Y.OpContextualize expr context)) = do-      inner <- buildExpression expr subst-      outer <- buildExpression context subst-      maybe (Left (printf "premise meta '%s' clashes with a binding" (T.unpack result))) Right (combine (substSingle result (MvExpression (contextualize inner outer))) subst)-    premised _ premise = Left (printf "premise '%s' is not a contextualization" (T.unpack premise.result))+  describe "formed" $ do+    it "builds the formation of the bindings" $+      formed [BiVoid (AtLabel "qp"), BiDelta (BtOne "0C")] `shouldBe` ExFormation [BiVoid (AtLabel "qp"), BiDelta (BtOne "0C")]+    it "refuses bindings carrying one attribute twice" $+      print (formed [BiVoid (AtLabel "ee"), BiTau (AtLabel "ee") ExXi]) `shouldThrow` anyException+  describe "nameIn" $ do+    it "leaves a formation as it is where no world is known" $+      nameIn Nothing (ExFormation [BiVoid (AtLabel "vy")]) `shouldBe` ExFormation [BiVoid (AtLabel "vy")]+    it "names a formation by its path in the world" $+      nameIn (Just (ExFormation [BiTau (AtLabel "sd") (ExFormation [BiVoid (AtLabel "vy")])])) (ExFormation [BiVoid (AtLabel "vy")])+        `shouldBe` ExDispatch ExRoot (AtLabel "sd")

@@ -20,12 +20,14 @@ import Fixtures (explainPack, lambdasFile, loopingLambdas, readUtf8, withLambdasOf) import GHC.IO.Handle import Paths_phino (version)-import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, listDirectory, removeDirectoryRecursive, removeFile, removePathForcibly, setModificationTime)+import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, listDirectory, makeAbsolute, removeDirectoryRecursive, removeFile, removePathForcibly, setModificationTime, withCurrentDirectory) import System.Exit (ExitCode (ExitFailure)) import System.FilePath ((</>)) import System.IO+import System.Timeout (timeout) import Test.Hspec import Text.Printf (printf)+import Text.XML qualified as X  withStdin :: String -> IO a -> IO a withStdin input action =@@ -733,11 +735,11 @@           [ unlines               [ "\\begin{phiquation}"               , "% === Step #1"-              , "\"foo\" : |x| \\leadsto_{\\nameref{r:first}}"+              , "\"foo\" : |x| \\phiNormalize[\\nameref{r:first}]"               , "% === Step #2, Rule 'first', 23t -> 26t"-              , "  \\leadsto Q . |x| ( |y| -> \"foo\" ) \\leadsto_{\\nameref{r:second}}"+              , "  \\phiNormalize Q . |x| ( |y| -> \"foo\" ) \\phiNormalize[\\nameref{r:second}]"               , "% === Step #3, Rule 'second', 26t -> 23t"-              , "  \\leadsto \"foo\" : |x|{.}"+              , "  \\phiNormalize \"foo\" : |x|{.}"               , "\\end{phiquation}"               ]           ]@@ -757,9 +759,9 @@           ]           [ unlines               [ "\\begin{phiquation}"-              , "\"foo\" : |x| \\leadsto_{\\nameref{r:first}}"-              , "  \\leadsto Q . |x| ( |y| -> \"foo\" ) \\leadsto_{\\nameref{r:second}}"-              , "  \\leadsto \"foo\" : |x|{.}"+              , "\"foo\" : |x| \\phiNormalize[\\nameref{r:first}]"+              , "  \\phiNormalize Q . |x| ( |y| -> \"foo\" ) \\phiNormalize[\\nameref{r:second}]"+              , "  \\phiNormalize \"foo\" : |x|{.}"               , "\\end{phiquation}"               ]           ]@@ -770,12 +772,12 @@           ["rewrite", "--normalize", "--sweet", "--sequence", "--output=latex", "--flat", "--compress", "--meet-prefix=foo"]           [ unlines               [ "\\begin{phiquation}"-              , "[[ |x| -> ?, |y| -> |x| ]] ( |x| -> |42-| : D ) . |y| \\leadsto_{\\nameref{r:copy}}"-              , "  \\leadsto \\phinoMeet{foo:1}{ [[ |x| -> |42-| : D, |y| -> |x| ]] } . |y| \\leadsto_{\\nameref{r:dot}}"-              , "  \\leadsto |42-| : D : |x| . |x| ( \\phiTerminal{\\rho} -> \\phinoAgain{foo:1} ) \\leadsto_{\\nameref{r:dot}}"-              , "  \\leadsto |42-| : D ( \\phiTerminal{\\rho} -> |42-| : D : |x|, \\phiTerminal{\\rho} -> \\phinoAgain{foo:1} ) \\leadsto_{\\nameref{r:skip}}"-              , "  \\leadsto |42-| : D ( \\phiTerminal{\\rho} -> \\phinoAgain{foo:1} ) \\leadsto_{\\nameref{r:skip}}"-              , "  \\leadsto |42-| : D{.}"+              , "[[ |x| -> ?, |y| -> |x| ]] ( |x| -> |42-| : D ) . |y| \\phiNormalize[\\nameref{r:copy}]"+              , "  \\phiNormalize \\phinoMeet{foo:1}{ [[ |x| -> |42-| : D, |y| -> |x| ]] } . |y| \\phiNormalize[\\nameref{r:dot}]"+              , "  \\phiNormalize |42-| : D : |x| . |x| ( \\phiTerminal{\\rho} -> \\phinoAgain{foo:1} ) \\phiNormalize[\\nameref{r:dot}]"+              , "  \\phiNormalize |42-| : D ( \\phiTerminal{\\rho} -> |42-| : D : |x|, \\phiTerminal{\\rho} -> \\phinoAgain{foo:1} ) \\phiNormalize[\\nameref{r:skip}]"+              , "  \\phiNormalize |42-| : D ( \\phiTerminal{\\rho} -> \\phinoAgain{foo:1} ) \\phiNormalize[\\nameref{r:skip}]"+              , "  \\phiNormalize |42-| : D{.}"               , "\\end{phiquation}"               ]           ]@@ -786,12 +788,12 @@           ["rewrite", "--normalize", "--sweet", "--sequence", "--output=latex", "--flat", "--compress"]           [ unlines               [ "\\begin{phiquation}"-              , "[[ |x| -> ?, |y| -> |x| ]] ( |x| -> |42-| : D ) . |y| \\leadsto_{\\nameref{r:copy}}"-              , "  \\leadsto \\phinoMeet{1}{ [[ |x| -> |42-| : D, |y| -> |x| ]] } . |y| \\leadsto_{\\nameref{r:dot}}"-              , "  \\leadsto |42-| : D : |x| . |x| ( \\phiTerminal{\\rho} -> \\phinoAgain{1} ) \\leadsto_{\\nameref{r:dot}}"-              , "  \\leadsto |42-| : D ( \\phiTerminal{\\rho} -> |42-| : D : |x|, \\phiTerminal{\\rho} -> \\phinoAgain{1} ) \\leadsto_{\\nameref{r:skip}}"-              , "  \\leadsto |42-| : D ( \\phiTerminal{\\rho} -> \\phinoAgain{1} ) \\leadsto_{\\nameref{r:skip}}"-              , "  \\leadsto |42-| : D{.}"+              , "[[ |x| -> ?, |y| -> |x| ]] ( |x| -> |42-| : D ) . |y| \\phiNormalize[\\nameref{r:copy}]"+              , "  \\phiNormalize \\phinoMeet{1}{ [[ |x| -> |42-| : D, |y| -> |x| ]] } . |y| \\phiNormalize[\\nameref{r:dot}]"+              , "  \\phiNormalize |42-| : D : |x| . |x| ( \\phiTerminal{\\rho} -> \\phinoAgain{1} ) \\phiNormalize[\\nameref{r:dot}]"+              , "  \\phiNormalize |42-| : D ( \\phiTerminal{\\rho} -> |42-| : D : |x|, \\phiTerminal{\\rho} -> \\phinoAgain{1} ) \\phiNormalize[\\nameref{r:skip}]"+              , "  \\phiNormalize |42-| : D ( \\phiTerminal{\\rho} -> \\phinoAgain{1} ) \\phiNormalize[\\nameref{r:skip}]"+              , "  \\phiNormalize |42-| : D{.}"               , "\\end{phiquation}"               ]           ]@@ -802,9 +804,9 @@           ["rewrite", "--normalize", "--sequence", "--flat", "--compress", "--output=latex", "--sweet"]           [ unlines               [ "\\begin{phiquation}"-              , "[[ |y| -> ?, |k| -> \\phinoMeet{1}{ 42 : |t| } ]] ( |y| -> \\phinoAgain{1} ) : |x| . |i| : |ex| \\leadsto_{\\nameref{r:copy}}"-              , "  \\leadsto [[ |y| -> \\phinoAgain{1}, |k| -> \\phinoAgain{1} ]] : |x| . |i| : |ex| \\leadsto_{\\nameref{r:stop}}"-              , "  \\leadsto T : |ex|{.}"+              , "[[ |y| -> ?, |k| -> \\phinoMeet{1}{ 42 : |t| } ]] ( |y| -> \\phinoAgain{1} ) : |x| . |i| : |ex| \\phiNormalize[\\nameref{r:copy}]"+              , "  \\phiNormalize [[ |y| -> \\phinoAgain{1}, |k| -> \\phinoAgain{1} ]] : |x| . |i| : |ex| \\phiNormalize[\\nameref{r:stop}]"+              , "  \\phiNormalize T : |ex|{.}"               , "\\end{phiquation}"               ]           ]@@ -815,9 +817,9 @@           ["rewrite", "--normalize", "--sequence", "--flat", "--compress", "--output=latex", "--sweet", "--meet-popularity=70"]           [ unlines               [ "\\begin{phiquation}"-              , "[[ |y| -> ?, |k| -> 42 : |t| ]] ( |y| -> 42 : |t| ) : |x| . |i| : |ex| \\leadsto_{\\nameref{r:copy}}"-              , "  \\leadsto [[ |y| -> 42 : |t|, |k| -> 42 : |t| ]] : |x| . |i| : |ex| \\leadsto_{\\nameref{r:stop}}"-              , "  \\leadsto T : |ex|{.}"+              , "[[ |y| -> ?, |k| -> 42 : |t| ]] ( |y| -> 42 : |t| ) : |x| . |i| : |ex| \\phiNormalize[\\nameref{r:copy}]"+              , "  \\phiNormalize [[ |y| -> 42 : |t|, |k| -> 42 : |t| ]] : |x| . |i| : |ex| \\phiNormalize[\\nameref{r:stop}]"+              , "  \\phiNormalize T : |ex|{.}"               , "\\end{phiquation}"               ]           ]@@ -828,9 +830,9 @@           ["rewrite", "--normalize", "--sequence", "--flat", "--compress", "--output=latex", "--sweet", "--meet-length=32"]           [ unlines               [ "\\begin{phiquation}"-              , "[[ |y| -> ?, |k| -> 42 : |t| ]] ( |y| -> 42 : |t| ) : |x| . |i| : |ex| \\leadsto_{\\nameref{r:copy}}"-              , "  \\leadsto [[ |y| -> 42 : |t|, |k| -> 42 : |t| ]] : |x| . |i| : |ex| \\leadsto_{\\nameref{r:stop}}"-              , "  \\leadsto T : |ex|{.}"+              , "[[ |y| -> ?, |k| -> 42 : |t| ]] ( |y| -> 42 : |t| ) : |x| . |i| : |ex| \\phiNormalize[\\nameref{r:copy}]"+              , "  \\phiNormalize [[ |y| -> 42 : |t|, |k| -> 42 : |t| ]] : |x| . |i| : |ex| \\phiNormalize[\\nameref{r:stop}]"+              , "  \\phiNormalize T : |ex|{.}"               , "\\end{phiquation}"               ]           ]@@ -841,9 +843,9 @@           ["rewrite", "--normalize", "--sequence", "--flat", "--output=latex", "--sweet", "--focus=Q.ex"]           [ unlines               [ "\\begin{phiquation}"-              , "[[ |y| -> ?, |k| -> 42 : |t| ]] ( |y| -> 42 : |t| ) : |x| . |i| \\leadsto_{\\nameref{r:copy}}"-              , "  \\leadsto [[ |y| -> 42 : |t|, |k| -> 42 : |t| ]] : |x| . |i| \\leadsto_{\\nameref{r:stop}}"-              , "  \\leadsto T{.}"+              , "[[ |y| -> ?, |k| -> 42 : |t| ]] ( |y| -> 42 : |t| ) : |x| . |i| \\phiNormalize[\\nameref{r:copy}]"+              , "  \\phiNormalize [[ |y| -> 42 : |t|, |k| -> 42 : |t| ]] : |x| . |i| \\phiNormalize[\\nameref{r:stop}]"+              , "  \\phiNormalize T{.}"               , "\\end{phiquation}"               ]           ]@@ -865,9 +867,9 @@           ["rewrite", "--normalize", "--flat", "--sequence", "--output=latex", "--sweet", "--max-depth=1", "--max-cycles=1"]           [ unlines               [ "\\begin{phiquation}"-              , "[[ |x| -> |y|, |y| -> |x| ]] . |x| \\leadsto_{\\nameref{r:dot}}"-              , "  \\leadsto |x| : |y| . |y| ( \\phiTerminal{\\rho} -> [[ |x| -> |y|, |y| -> |x| ]] ) \\leadsto"-              , "  \\leadsto \\dots"+              , "[[ |x| -> |y|, |y| -> |x| ]] . |x| \\phiNormalize[\\nameref{r:dot}]"+              , "  \\phiNormalize |x| : |y| . |y| ( \\phiTerminal{\\rho} -> [[ |x| -> |y|, |y| -> |x| ]] ) \\phiNormalize"+              , "  \\phiNormalize \\dots"               , "\\end{phiquation}"               ]           ]@@ -1274,12 +1276,12 @@           [ intercalate               "\n"               [ "\\begin{phiquation}"-              , "[[ D> |01-|, |y| -> ? ]] ( |y| -> [[]] ) : |x| . |x| : @ \\leadsto_{\\nameref{r:contextualize}}"-              , "  \\leadsto [[ D> |01-|, |y| -> ? ]] ( |y| -> [[]] ) : |x| . |x| \\leadsto_{\\nameref{r:copy}}"-              , "  \\leadsto [[ D> |01-|, |y| -> [[]] ]] : |x| . |x| \\leadsto_{\\nameref{r:dot}}"-              , "  \\leadsto [[ D> |01-|, |y| -> [[]] ]] ( \\phiTerminal{\\rho} -> [[ D> |01-|, |y| -> [[]] ]] : |x| ) \\leadsto_{\\nameref{r:skip}}"-              , "  \\leadsto [[ D> |01-|, |y| -> [[]] ]] \\leadsto_{\\nameref{r:delta}}"-              , "  \\leadsto |01-|{.}"+              , "[[ D> |01-|, |y| -> ? ]] ( |y| -> [[]] ) : |x| . |x| : @ \\phiContextualize[\\nameref{r:contextualize}]"+              , "  \\phiContextualize [[ D> |01-|, |y| -> ? ]] ( |y| -> [[]] ) : |x| . |x| \\phiNormalize[\\nameref{r:copy}]"+              , "  \\phiNormalize [[ D> |01-|, |y| -> [[]] ]] : |x| . |x| \\phiNormalize[\\nameref{r:dot}]"+              , "  \\phiNormalize [[ D> |01-|, |y| -> [[]] ]] ( \\phiTerminal{\\rho} -> [[ D> |01-|, |y| -> [[]] ]] : |x| ) \\phiNormalize[\\nameref{r:skip}]"+              , "  \\phiNormalize [[ D> |01-|, |y| -> [[]] ]] \\phiDataize[\\nameref{r:delta}]"+              , "  \\phiDataize |01-|{.}"               , "\\end{phiquation}"               , "01-"               ]@@ -1291,8 +1293,8 @@           ["dataize", "--sequence", "--quiet", "--output=latex", "--flat", "--sweet"]           [ intercalate               "\n"-              [ "|01-| : D \\leadsto_{\\nameref{r:delta}}"-              , "  \\leadsto |01-|{.}"+              [ "|01-| : D \\phiDataize[\\nameref{r:delta}]"+              , "  \\phiDataize |01-|{.}"               , "\\end{phiquation}"               ]           ]@@ -1307,7 +1309,7 @@       withStdin "[[ @ -> [[ @ -> $.c.plus( 32.0 ), c -> 25.0 ]], bytes ↦ ⟦ φ ↦ ∅ ⟧, number(φ) -> [[ plus -> [[ ^ -> ?, x -> ?, L> L_number_plus ]] ]] ]]" $         testCLISucceeded           ["dataize", symbolic, "--output=latex", "--sweet", "--nonumber", "--compress", "--canonize", "--meet-prefix=dataization", "--sequence", "--flat", "--quiet", "--hide=Q.bytes", "--hide=Q.number", "--locator=Q.@", "--focus=Q.@", "--meet-length=5", "--meet-popularity=1"]-          ["\\phinoMeet{dataization:1}{ [[ @ -> |c| . |plus| ( 32 ), |c| -> 25 ]] } \\leadsto_{\\nameref{r:contextualize}}"]+          ["\\phinoMeet{dataization:1}{ [[ @ -> |c| . |plus| ( 32 ), |c| -> 25 ]] } \\phiContextualize[\\nameref{r:contextualize}]"]      it "compresses a canonized whole-expression sequence into a meet" $       withStdin "[[ @ -> [[ @ -> $.c.plus( 32.0 ), c -> 25.0 ]], bytes ↦ ⟦ φ ↦ ∅ ⟧, number(φ) -> [[ plus -> [[ ^ -> ?, x -> ?, L> L_number_plus ]] ]] ]]" $@@ -2286,6 +2288,22 @@           , "⟦ x ↦ 7, λ ⤍ L_number_plus ⟧"           ] +    it "writes every step of a LaTeX --sequence with the arrow of its judgment" $+      withStdin "[[ q -> [[ ]], k -> Q.q ]]" $+        testCLISucceeded+          ["morph", "--locator=Q.k", "--sequence", "--output=latex", "--flat", "--sweet", "--quiet"]+          [ intercalate+              "\n"+              [ "\\begin{phiquation}"+              , "[[ |q| -> [[]], |k| -> Q . |q| ]] \\phiMorph[\\nameref{r:md}]"+              , "  \\phiMorph [[ |q| -> [[]], |k| -> [[ |q| -> [[]], |k| -> Q . |q| ]] . |q| ]] \\phiNormalize[\\nameref{r:dot}]"+              , "  \\phiNormalize [[ |q| -> [[]], |k| -> [[]] ( \\phiTerminal{\\rho} -> Q ) ]] \\phiNormalize[\\nameref{r:skip}]"+              , "  \\phiNormalize [[ |q| -> [[]], |k| -> [[]] ]] \\phiMorph[\\nameref{r:mf}]"+              , "  \\phiMorph [[ |q| -> [[]], |k| -> [[]] ]]{.}"+              , "\\end{phiquation}"+              ]+          ]+     it "does not print the result with --quiet" $       withStdin "[[ D> 01- ]]" $         testCLISucceeded ["morph", "--quiet"] []@@ -2387,6 +2405,150 @@             records <- readUtf8 path             length (filter (isInfixOf "𝔼(L_split)") (lines records)) `shouldBe` 64 +    -- '--max-steps' and '--max-firings' count work, so a run inside both of+    -- them may still take longer than its caller can wait, and a caller that+    -- kills it leaves a protocol nobody can read. '--max-seconds' stops the+    -- run by the clock, writes where it stopped and closes the protocol. The+    -- ladder below doubles its firings at every rung and stays 24 rungs deep,+    -- so it spends neither budget and never ends (#1607).+    describe "--max-seconds" $ do+      let ladder = withLambdasOf (T.pack "- λ: L_split\n  morph:\n    𝑛1: ξ.n.foo\n    𝑛2: ξ.n.foo\n  𝑛: ⟦ l ↦ 𝑛1, r ↦ 𝑛2 ⟧\n")+          rungs = "⟦ " ++ intercalate ", " [printf "l%d ↦ ⟦ λ ⤍ L_split, n ↦ Φ.l%d ⟧" rung (rung + 1) | rung <- [0 .. 23 :: Int]] ++ ", l24 ↦ ⟦⟧, x ↦ Φ.l0.foo ⟧"+          bounded :: Expectation -> Expectation+          bounded check = timeout 60000000 check >>= (`shouldBe` Just ())+      it "fails with non-positive --max-seconds" $+        withStdin rungs $+          testCLIFailed ["morph", "--max-seconds=0"] ["--max-seconds must be positive"]++      it "fails once the --max-seconds budget is spent" $+        ladder $ \table ->+          bounded $+            withStdin rungs $+              testCLIFailed+                ["morph", "--symbolic=" ++ table, "--locator=Q.x", "--max-seconds=1"]+                ["[ERROR]: Evaluation did not finish before reaching the limit of seconds: --max-seconds=1"]++      it "fails dataize once the --max-seconds budget is spent" $+        ladder $ \table ->+          bounded $+            withStdin rungs $+              testCLIFailed+                ["dataize", "--symbolic=" ++ table, "--locator=Q.x", "--max-seconds=1"]+                ["[ERROR]: Evaluation did not finish before reaching the limit of seconds: --max-seconds=1"]++      -- A passed deadline is no stuck site, so '--partial' parks nothing and+      -- the run ends where the clock stopped it (#1619)+      forM_ [["--locator=Q.x", "--partial"], ["--deep", "--partial"]] $ \opts ->+        it ("fails once the --max-seconds budget is spent with " ++ unwords opts) $+          ladder $ \table ->+            bounded $+              withStdin rungs $+                testCLIFailed+                  (["morph", "--symbolic=" ++ table, "--max-seconds=1"] ++ opts)+                  ["[ERROR]: Evaluation did not finish before reaching the limit of seconds: --max-seconds=1"]++      -- Every worker of '--jobs' reads the clock and ends its binding at its+      -- own refusal, and only the records of the first binding that failed+      -- are written, so that binding has to carry the refusal itself. Where+      -- the clock stops the run is a matter of timing, an operand or a binding+      -- whose worker started late, so the site is left unchecked+      forM_ [["--locator=Q.x"], ["--locator=Q.x", "--partial"], ["--deep", "--partial"], ["--deep", "--partial", "--jobs=4"]] $ \opts ->+        it ("writes the timeout as the last line of the protocol with " ++ unwords opts) $+          ladder $ \table ->+            withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do+              hClose stream+              bounded $+                withStdin rungs $+                  testCLIFailed+                    (["morph", "--symbolic=" ++ table, "--max-seconds=1", "--protocol=" ++ path, "--quiet"] ++ opts)+                    ["--max-seconds=1"]+              records <- readUtf8 path+              dropWhile (== ' ') (last (lines records)) `shouldStartWith` "timeout(1)  # 𝕄("++      -- Only the first refusal of the deadline is written, and the run ends+      -- on it, so the markup carries one timeout and nothing after it+      it "writes the timeout once to the XML protocol of a deep run" $+        ladder $ \table ->+          withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do+            hClose stream+            bounded $+              withStdin rungs $+                testCLIFailed+                  ["morph", "--symbolic=" ++ table, "--deep", "--partial", "--max-seconds=1", "--protocol=" ++ path, "--quiet"]+                  ["--max-seconds=1"]+            records <- readUtf8 path+            length (filter (isInfixOf "<timeout limit=\"1\" by=\"morph\" at=\"") (lines records)) `shouldBe` 1++      it "closes the XML protocol of a run out of time" $+        ladder $ \table ->+          withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do+            hClose stream+            bounded $+              withStdin rungs $+                testCLIFailed+                  ["morph", "--symbolic=" ++ table, "--locator=Q.x", "--max-seconds=1", "--protocol=" ++ path, "--quiet"]+                  ["--max-seconds=1"]+            document <- X.readFile X.def path+            X.nameLocalName (X.elementName (X.documentRoot document)) `shouldBe` T.pack "morph"++    -- Every binding of the formation the walk starts at is morphed on a+    -- worker of its own, from the state the spine left, and what the workers+    -- made is written in the order of the bindings, the symbols of a later+    -- binding numbered after those of the bindings before it (#1534)+    describe "--jobs" $ do+      let twins = "[[ bytes ↦ ⟦ φ ↦ ∅ ⟧, number(φ) -> [[ plus(^, x) -> [[ L> L_number_plus ]] ]], a -> 7.plus( 5.plus( 6 ) ), b -> 7.plus( 5.plus( 6 ) ) ]]"+          recorded :: [String] -> IO [String]+          recorded extra =+            withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do+              hClose stream+              withStdin twins $+                testCLISucceeded (["morph", symbolic, "--deep", "--protocol=" ++ path, "--quiet"] ++ extra) []+              lines <$> readUtf8 path+          untaued :: String -> String+          untaued [] = []+          untaued text+            | "a🌵" `isPrefixOf` text = "a🌵" ++ untaued (dropWhile (\ch -> isDigit ch || ch == '-') (drop 2 text))+          untaued (ch : rest) = ch : untaued rest+      it "prints the answer one walk over the bindings prints" $+        withStdin twins $+          testCLISucceeded+            ["morph", symbolic, "--deep", "--acyclic=proven", "--jobs=3", "--flat", "--hide-rho", "--sweet"]+            ["a ↦ ⟦ φ ↦ 𝜎2:λ, plus(x) ↦ L_number_plus:λ ⟧, b ↦ ⟦ φ ↦ 𝜎4:λ, plus(x) ↦ L_number_plus:λ ⟧"]++      it "writes the firings of a binding after those of the bindings before it" $+        recorded ["--jobs=2"]+          >>= (`shouldBe` ["# 𝕄(Φ.a)", "# 𝕄(Φ.a)", "# 𝕄(Φ.b)", "# 𝕄(Φ.b)"]) . map (dropWhile (/= '#')) . filter (isPrefixOf "  𝔼(")++      it "numbers the symbols of the protocol the way the answer numbers them" $+        recorded ["--jobs=2"] >>= (`shouldSatisfy` elem "    𝑛.4.1 := Φ.number( φ ↦ ⟦ λ ⤍ 𝜎4 ⟧ )  # 𝑛")++      it "names what a binding mints after the binding" $+        recorded ["--jobs=2"] >>= (`shouldSatisfy` any (isInfixOf "# 𝔻(Φ.a🌵4-0)"))++      it "writes the protocol one walk writes, the names a binding mints apart" $ do+        one <- recorded ["--jobs=1"]+        many <- recorded ["--jobs=4"]+        map untaued many `shouldBe` map untaued one++      it "writes the same protocol however many workers it is given" $ do+        few <- recorded ["--jobs=2"]+        many <- recorded ["--jobs=5"]+        many `shouldBe` few++      it "keeps a memo of its own for every binding under plausible" $+        withStdin twins $+          testCLISucceeded+            ["morph", symbolic, "--deep", "--acyclic=plausible", "--jobs=2", "--flat", "--hide-rho", "--sweet"]+            ["b ↦ ⟦ φ ↦ 𝜎4:λ, plus(x) ↦ L_number_plus:λ ⟧"]++      it "fails with non-positive --jobs" $+        withStdin twins $+          testCLIFailed ["morph", "--deep", "--jobs=0"] ["--jobs must be positive"]++      it "fails with --jobs above one and no --deep" $+        withStdin twins $+          testCLIFailed ["morph", "--jobs=2"] ["The option --jobs requires --deep, since only the deep walk runs on several workers"]+     -- '--partial' parks a spent 𝕄 budget the same way it parks a stuck λ:     -- the answer is the term the walk had reached, dispatch intact (#1078)     it "parks the spent budget as a residual with --partial" $@@ -2742,6 +2904,40 @@       (secondRun, _) <- withStdout (runCLI args)       firstRun `shouldBe` secondRun +  describe "compile" $ do+    it "writes the module to the target" $+      withTempDirectory "phino-compile" $ \dir -> do+        createDirectoryIfMissing True dir+        withCurrentDirectory dir (runCLI ["compile", "--target=gen/Compiled.hs"])+        doesFileExist (dir </> "gen" </> "Compiled.hs") `shouldReturn` True+    it "writes the rules of --rule into the module" $+      withTempDirectory "phino-compile" $ \dir -> do+        createDirectoryIfMissing True dir+        simple <- makeAbsolute "test-resources/cli/rules/simple.yaml"+        withCurrentDirectory dir (runCLI ["compile", "--rule=" ++ simple, "--target=Compiled.hs"])+        readFile' (dir </> "Compiled.hs") >>= (`shouldSatisfy` ("R.direct \"foo\"" `isInfixOf`))+    it "turns the flag on in a new cabal.project.local" $+      withTempDirectory "phino-compile" $ \dir -> do+        createDirectoryIfMissing True dir+        withCurrentDirectory dir (runCLI ["compile", "--target=Compiled.hs"])+        readFile (dir </> "cabal.project.local") `shouldReturn` "package phino\n  flags: +compiled\n"+    it "prints the lines an existing cabal.project.local lacks" $+      withTempDirectory "phino-compile" $ \dir -> do+        createDirectoryIfMissing True dir+        writeFile (dir </> "cabal.project.local") "tests: True\n"+        withCurrentDirectory dir (testCLISucceeded ["compile", "--target=Compiled.hs"] ["package phino\n  flags: +compiled"])+    it "leaves an existing cabal.project.local as it is" $+      withTempDirectory "phino-compile" $ \dir -> do+        createDirectoryIfMissing True dir+        writeFile (dir </> "cabal.project.local") "tests: True\n"+        withStdout (withCurrentDirectory dir (runCLI ["compile", "--target=Compiled.hs"]))+        readFile (dir </> "cabal.project.local") `shouldReturn` "tests: True\n"+    it "refuses a rule it cannot compile" $+      withTempDirectory "phino-compile" $ \dir -> do+        createDirectoryIfMissing True dir+        writeFile (dir </> "having.yaml") "name: hv\npattern: '[[ x -> !e1, !B1 ]]'\nresult: '[[ !B1 ]]'\nhaving:\n  eq: ['!e1', 'Q']\n"+        withCurrentDirectory dir (testCLIFailed ["compile", "--rule=having.yaml", "--target=Compiled.hs"] ["The rule 'hv' cannot be compiled, since it has a 'having' condition"])+   describe "match" $ do     it "prints help" $       testCLISucceeded@@ -2824,6 +3020,12 @@         ( "VersionMismatch"         , VersionMismatch "1.2.3" "4.5.6"         , "Version mismatch: --pin requires '1.2.3', but this is phino 4.5.6"+        )+      , ("CouldNotCompile", CouldNotCompile "The rule 'q' cannot be compiled, since it is odd", "The rule 'q' cannot be compiled, since it is odd")+      ,+        ( "StaleEngine"+        , StaleEngine+        , "The compiled rules are stale, since the rules of phino changed after 'phino compile', so run it again and rebuild"         )       ]       ( \(desc, exception, expected) ->

@@ -8,6 +8,7 @@ import AST import Canonizer (canonize, canonizeExpr) import Control.Monad (forM_)+import Deps (Judgment (..)) import Test.Hspec (Spec, describe, it, shouldBe)  spec :: Spec@@ -85,8 +86,8 @@       let first = ExFormation [BiLambda (Function "X")]           second = ExFormation [BiLambda (Function "Y")]           expected = ExFormation [BiLambda (Function "Fn1")]-      canonize [(first, Just "rule-1"), (second, Just "rule-2")]-        `shouldBe` [(expected, Just "rule-1"), (expected, Just "rule-2")]+      canonize [(first, Just (Morphing, "rule-1")), (second, Just (Dataization, "rule-2"))]+        `shouldBe` [(expected, Just (Morphing, "rule-1")), (expected, Just (Dataization, "rule-2"))]      it "preserves the rule tag alongside the canonized expression" $       canonize [(ExFormation [BiLambda (Function "Foo")], Nothing)]

@@ -0,0 +1,144 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module CompiledSpec where++import AST+import Control.Exception (SomeException, evaluate, try)+import Control.Monad (filterM, (>=>))+import Data.Aeson (FromJSON)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text qualified as T+import Data.Yaml qualified as Yaml+import Dataize (dataize')+import Deps (dontSaveStep)+import Engine (Engine (..), building, fresh, stepOf, yaml)+import Files (allPathsIn)+import Fixtures (defaultReduceContext, linked, withLambdasOf)+import GHC.Generics (Generic)+import Lambdas (Lambdas, readLambdas)+import Morph (ReduceContext (..), Steps (..), emptyState, morph')+import Must (Must (MtDisabled))+import Parser (parseExpressionThrows)+import Rewriter (RewriteContext (RewriteContext), rewrite)+import System.Random (StdGen, mkStdGen, randomR)+import Test.Hspec (Spec, describe, it, shouldBe, shouldReturn)+import Yaml qualified as Y++-- The one part of a pack of 'test-resources/rewriter-packs' both engines are+-- run on here: the term it rewrites.+newtype Pack = Pack {input :: String}+  deriving (Generic, FromJSON)++spec :: Spec+spec =+  describe "compiled" $ do+    it "runs the rules phino carries" $+      fresh linked `shouldBe` True+    it "normalizes the term of every rewriter pack into the chain the rules of YAML make" $ do+      terms <- allPathsIn "test-resources/rewriter-packs" >>= mapM (Yaml.decodeFileThrow >=> parseExpressionThrows . input)+      filterM (\expr -> (/=) <$> chain linked Nothing expr <*> chain yaml Nothing expr) terms+        `shouldReturn` []+    it "normalizes random terms into the chains the rules of YAML make" $+      filterM (\seed -> (/=) <$> chain linked Nothing (term False seed) <*> chain yaml Nothing (term False seed)) [1 .. 400]+        `shouldReturn` []+    it "normalizes random terms standing in a world into the chains the rules of YAML make" $+      filterM (\seed -> (/=) <$> chain linked (Just (term False seed)) (term False seed) <*> chain yaml (Just (term False seed)) (term False seed)) [401 .. 800]+        `shouldReturn` []+    it "normalizes random terms holding metas into the chains the rules of YAML make" $+      filterM (\seed -> (/=) <$> chain linked Nothing (term True seed) <*> chain yaml Nothing (term True seed)) [801 .. 1200]+        `shouldReturn` []+    it "tells a normal form the way the rules of YAML do" $+      filter (\seed -> _normal linked (term False seed) /= _normal yaml (term False seed)) [1 .. 3000]+        `shouldBe` []+    it "tells a normal form of a term holding metas the way the rules of YAML do" $+      filter (\seed -> _normal linked (term True seed) /= _normal yaml (term True seed)) [3001 .. 6000]+        `shouldBe` []+    it "contextualizes random terms the way the rules of YAML do, failures included" $+      filterM (\seed -> (/=) <$> contextualized linked (term True seed) (term False (seed + 1)) <*> contextualized yaml (term True seed) (term False (seed + 1))) [1 .. 3000]+        `shouldReturn` []+    it "morphs an object of random programs into the chains the rules of YAML make, failures included" $+      withLambdasOf "- λ: L_q\n  𝑛: ⟦ φ ↦ ⟦ λ ⤍ 𝜎 ⟧ ⟧\n" $ \path -> do+        lambdas <- readLambdas path+        filterM (\seed -> (/=) <$> morphed lambdas linked (program seed) <*> morphed lambdas yaml (program seed)) [1 .. 400]+          `shouldReturn` []+    it "dataizes an object of random programs into the chains the rules of YAML make, failures included" $+      withLambdasOf "- λ: L_q\n  𝑛: ⟦ φ ↦ ⟦ λ ⤍ 𝜎 ⟧ ⟧\n" $ \path -> do+        lambdas <- readLambdas path+        filterM (\seed -> (/=) <$> dataized lambdas linked (program seed) <*> dataized lambdas yaml (program seed)) [1 .. 400]+          `shouldReturn` []+  where+    chain :: Engine -> Maybe Expression -> Expression -> IO (Either String String)+    chain engine universe expr =+      settled+        ( show . fst+            <$> rewrite+              expr+              (map (stepOf engine) Y.normalizationRules)+              (RewriteContext ExRoot 25 25 False universe (building engine) (_normal engine) MtDisabled Nothing dontSaveStep)+        )+    morphed :: Lambdas -> Engine -> Expression -> IO (Either String String)+    morphed lambdas engine world = settled (show . fst <$> morph' (ExDispatch ExRoot (AtLabel "x"), (world, Nothing) :| []) world emptyState (reducing lambdas engine))+    dataized :: Lambdas -> Engine -> Expression -> IO (Either String String)+    dataized lambdas engine world = settled (show . fst <$> dataize' (ExDispatch ExRoot (AtLabel "x"), (world, Nothing) :| []) world emptyState (reducing lambdas engine))+    reducing :: Lambdas -> Engine -> ReduceContext+    reducing lambdas engine = (defaultReduceContext ExRoot){_engine = engine, _buildTerm = building engine, _shuffle = False, _steps = Steps 40 0, _symbolic = lambdas}+    program :: Int -> Expression+    program seed = fst (formation False 4 (mkStdGen seed))+    contextualized :: Engine -> Expression -> Expression -> IO (Either String String)+    contextualized engine expr context = settled (show <$> _contextualize engine expr context)+    settled :: IO String -> IO (Either String String)+    settled action = either (Left . show) Right <$> (try (action >>= \text -> evaluate (length text) >> pure text) :: IO (Either SomeException String))+    term :: Bool -> Int -> Expression+    term metas seed = fst (grown metas (4 :: Int) (mkStdGen seed))+    grown :: Bool -> Int -> StdGen -> (Expression, StdGen)+    grown metas depth gen =+      let (pick, gen') = randomR (0, if depth == 0 then 3 else 9 :: Int) gen+       in case pick of+            0 -> (ExXi, gen')+            1 -> (ExRoot, gen')+            2 -> (if metas then ExMeta "e9" else ExTermination, gen')+            3 -> (ExTermination, gen')+            4 -> formation metas depth gen'+            5 -> formation metas depth gen'+            6 ->+              let (expr, gen'') = grown metas (depth - 1) gen'+                  (attr, gen''') = attribute gen''+               in (ExDispatch expr attr, gen''')+            7 ->+              let (expr, gen'') = grown metas (depth - 1) gen'+                  (attr, gen''') = attribute gen''+                  (arg, gen'''') = grown metas (depth - 1) gen'''+               in (ExApplication expr (ArTau attr arg), gen'''')+            8 ->+              let (expr, gen'') = grown metas (depth - 1) gen'+                  (idx, gen''') = randomR (0, 2) gen''+                  (arg, gen'''') = grown metas (depth - 1) gen'''+               in (ExApplication expr (ArAlpha (Alpha idx) arg), gen'''')+            _ -> formation metas depth gen'+    formation :: Bool -> Int -> StdGen -> (Expression, StdGen)+    formation metas depth gen =+      let (bds, gen') = foldr binding ([], gen) [AtLabel "x", AtLabel "y", AtRho, AtPhi, AtDelta, AtLambda]+       in (ExFormation bds, gen')+      where+        binding :: Attribute -> ([Binding], StdGen) -> ([Binding], StdGen)+        binding attr (bds, source) =+          let (pick, source') = randomR (0, 3 :: Int) source+           in case (attr, pick) of+                (_, 0) -> (bds, source')+                (AtDelta, 1) -> (BiDelta (BtOne "0A") : bds, source')+                (AtDelta, _) -> (bds, source')+                (AtLambda, 1) -> (BiLambda (Function (T.pack "L_q")) : bds, source')+                (AtLambda, _) -> (bds, source')+                (_, 1) -> (BiVoid attr : bds, source')+                _ ->+                  let (expr, source'') = grown metas (depth - 1) source'+                   in (BiTau attr expr : bds, source'')+    attribute :: StdGen -> (Attribute, StdGen)+    attribute gen =+      let (pick, gen') = randomR (0, 3 :: Int) gen+       in ([AtLabel "x", AtLabel "y", AtRho, AtPhi] !! pick, gen')

@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module ContextualizeSpec where++import AST+import Contextualize (concluded, contextualize)+import Control.Exception (SomeException)+import Control.Monad (forM_)+import Data.Either (fromRight)+import Data.List (isInfixOf)+import Test.Hspec (Spec, describe, it, shouldBe, shouldReturn, shouldSatisfy, shouldThrow)++spec :: Spec+spec = do+  describe "contextualize" $+    let commonContext :: Expression+        commonContext = ExFormation [BiVoid AtRho]+     in forM_+          [ ("replaces a xi expression with the context", ExXi, commonContext, commonContext)+          , ("keeps a root expression untouched", ExRoot, commonContext, ExRoot)+          ,+            ( "keeps an empty formation untouched"+            , ExFormation [BiVoid AtRho]+            , ExFormation [BiVoid AtRho, BiVoid AtRho]+            , ExFormation [BiVoid AtRho]+            )+          ,+            ( "recurses into a dispatch application"+            , ExDispatch ExXi (AtLabel "z")+            , commonContext+            , ExDispatch commonContext (AtLabel "z")+            )+          , ("keeps a termination untouched", ExTermination, commonContext, ExTermination)+          ,+            ( "recurses into both sides of an application with a tau argument"+            , ExApplication ExXi (ArTau (AtLabel "x") ExXi)+            , commonContext+            , ExApplication commonContext (ArTau (AtLabel "x") commonContext)+            )+          ,+            ( "recurses into both sides of an application with an alpha argument"+            , ExApplication ExXi (ArAlpha (Alpha 0) ExXi)+            , commonContext+            , ExApplication commonContext (ArAlpha (Alpha 0) commonContext)+            )+          ]+          (\(desc, expr, context, expected) -> it desc (contextualize expr context `shouldReturn` expected))+  describe "contextualize a term no rule matches" $ do+    it "refuses a meta, since no contextualization rule matches it" $+      contextualize (ExMeta "e7") (ExFormation [BiVoid AtRho])+        `shouldThrow` (\err -> "no contextualization rule matches the term: 𝑒7" `isInfixOf` show (err :: SomeException))+    it "refuses a dispatch off a meta, naming the meta rather than the dispatch" $+      contextualize (ExDispatch (ExMeta "e13") (AtLabel "kvo")) (ExFormation [BiVoid AtRho])+        `shouldThrow` (\err -> "the term: 𝑒13" `isInfixOf` show (err :: SomeException))+  describe "concluded" $ do+    it "comes to the conclusion of the one rule matching" $+      fromRight ExXi (concluded ExRoot [("cg", Right (ExDispatch ExRoot (AtLabel "bn")))]) `shouldBe` ExDispatch ExRoot (AtLabel "bn")+    it "refuses a term no rule matches" $+      either show (const "") (concluded (ExMeta "e4") [])+        `shouldSatisfy` ("no contextualization rule matches the term: 𝑒4" `isInfixOf`)+    it "refuses a term several rules match, naming them" $+      either show (const "") (concluded ExXi [("cq", Right ExXi), ("cw", Right ExRoot)])+        `shouldSatisfy` ("the contextualization rules cq, cw all match the term" `isInfixOf`)

@@ -20,10 +20,10 @@ import Data.Yaml qualified as Decode import Dataize (Outcome (..), dataize, dataize', reduction) import Deps (Judgment (..), State, dontSaveEval, dontSaveStep)+import Engine (Engine (_normal), building) import Evaluate (evaluation, fired) import Files (allPathsIn)-import Fixtures (defaultReduceContext, fixtureLambdas, loopingLambdas, primitives, recorded, withLambdas)-import Functions (buildTerm)+import Fixtures (defaultReduceContext, fixtureLambdas, linked, loopingLambdas, overdue, primitives, recorded, withLambdas) import GHC.Generics (Generic) import Lambdas (Lambdas, emptyLambdas, readLambdas) import Matcher (substEmpty)@@ -112,7 +112,7 @@   -- (#955). The dataization clauses are therefore disjoint and their order in   -- 'resources/dataization' cannot change behavior.   describe "dataization 'norm' is disjoint from the specific clauses" $ do-    let rctx = RuleContext (execBuildTerm ExRoot (defaultReduceContext ExRoot)) Nothing+    let rctx = RuleContext (execBuildTerm ExRoot (defaultReduceContext ExRoot)) Nothing (_normal linked)         dataizeRule :: String -> Yaml.DataizeRule         dataizeRule nm = fromMaybe (error ("no dataization rule named " ++ nm)) (find (\r -> r.name == nm) Yaml.dataizationRules)         asRule :: Yaml.DataizeRule -> Yaml.Rule@@ -210,7 +210,7 @@     it "fails on the step limit instead of morphing forever" $       looping $ \endless -> do         expr <- parseExpressionThrows "⟦ @ ↦ ⟦ λ ⤍ L_loop ⟧ ⟧"-        dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 25 (Steps 40 0) Nothing Nothing 1 False True False False Nothing Dataization [] Map.empty endless buildTerm reduction evaluation fired dontSaveStep dontSaveEval)+        dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 25 (Steps 40 0) Nothing Nothing Nothing 1 False True False False 1 Nothing Dataization [] Map.empty endless (building linked) reduction evaluation fired dontSaveStep dontSaveEval linked)           `shouldThrow` (\e -> "--max-steps=40" `isInfixOf` show (e :: SomeException))      -- A budget spent on a cycle is a stuck site just as a λ function that@@ -219,11 +219,21 @@     it "parks the step limit as a residual with --partial" $       looping $ \endless -> do         expr <- parseExpressionThrows "⟦ @ ↦ ⟦ λ ⤍ L_loop ⟧ ⟧"-        (outcome, _, _) <- dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 25 (Steps 40 0) Nothing Nothing 1 False True True False Nothing Dataization [] Map.empty endless buildTerm reduction evaluation fired dontSaveStep dontSaveEval)+        (outcome, _, _) <- dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 25 (Steps 40 0) Nothing Nothing Nothing 1 False True True False 1 Nothing Dataization [] Map.empty endless (building linked) reduction evaluation fired dontSaveStep dontSaveEval linked)         case outcome of           Residual _ -> pure ()           Dataized bts -> expectationFailure ("expected a residual, dataized to " ++ show bts) +  -- Unlike the step limit, a passed deadline of '--max-seconds' is no stuck+  -- site: the run is out of time wherever it stands, so '--partial' has no+  -- residual to hand back and the run fails the way it fails without it (#1619)+  describe "stops a dataization by the clock of --max-seconds" $+    it "fails a partial dataization once the deadline has passed" $ do+      expr <- parseExpressionThrows "[[ @ -> [[ D> 7E- ]] ]]"+      deadline <- overdue 29+      dataize expr emptyState (defaultReduceContext ExRoot){_deadline = Just deadline, _partial = True}+        `shouldThrow` (\e -> "--max-seconds=29" `isInfixOf` show (e :: SomeException))+   -- A λ function no entry of the '--symbolic' file answers — a name the file   -- does not carry, such as the placeholder ⟦ λ ⤍ Sym_arg_0 ⟧ standing in for a   -- data input (#1060) — fails the run. Under '_partial' the run ends on the@@ -291,12 +301,12 @@     forM_       [         ( "--max-cycles"-        , ReduceContext ExRoot ExRoot Nothing 25 0 (Steps 250 0) Nothing Nothing 1 True True False False Nothing Dataization [] Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval+        , ReduceContext ExRoot ExRoot Nothing 25 0 (Steps 250 0) Nothing Nothing Nothing 1 True True False False 1 Nothing Dataization [] Map.empty emptyLambdas (building linked) reduction evaluation fired dontSaveStep dontSaveEval linked         , "--max-cycles=0"         )       ,         ( "--max-depth"-        , ReduceContext ExRoot ExRoot Nothing 0 25 (Steps 250 0) Nothing Nothing 1 True True False False Nothing Dataization [] Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval+        , ReduceContext ExRoot ExRoot Nothing 0 25 (Steps 250 0) Nothing Nothing Nothing 1 True True False False 1 Nothing Dataization [] Map.empty emptyLambdas (building linked) reduction evaluation fired dontSaveStep dontSaveEval linked         , "--max-depth=0"         )       ]@@ -307,14 +317,14 @@       )     it "does not throw without --depth-sensitive even once --max-depth is exhausted" $ do       expr <- parseExpressionThrows boxed-      (value, _, _) <- dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 0 25 (Steps 250 0) Nothing Nothing 1 False True False False Nothing Dataization [] Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval)+      (value, _, _) <- dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 0 25 (Steps 250 0) Nothing Nothing Nothing 1 False True False False 1 Nothing Dataization [] Map.empty emptyLambdas (building linked) reduction evaluation fired dontSaveStep dontSaveEval linked)       value `shouldBe` Dataized (BtOne "00")     -- A normalization that ran out of cycles hands back a term that is not a     -- normal form, so the run names the budget even without --depth-sensitive     -- rather than going on with it (#1496)     it "throws once --max-cycles is exhausted even without --depth-sensitive" $ do       expr <- parseExpressionThrows boxed-      dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 0 (Steps 250 0) Nothing Nothing 1 False True False False Nothing Dataization [] Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval)+      dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 0 (Steps 250 0) Nothing Nothing Nothing 1 False True False False 1 Nothing Dataization [] Map.empty emptyLambdas (building linked) reduction evaluation fired dontSaveStep dontSaveEval linked)         `shouldThrow` (\e -> "--max-cycles=0" `isInfixOf` show (e :: SomeException))    describe "labels every step with a defined rule or operation" $ do@@ -334,10 +344,23 @@       expr <- parseExpressionThrows (primitives "5.plus(6)")       loc <- parseExpressionThrows "Q"       (_, chain, _) <- dataize expr emptyState (withLambdas known (defaultReduceContext loc))-      let orphans = nub [label | (_, Just label) <- chain, label `notElem` allowed, label /= "symbol"]+      let orphans = nub [label | (_, Just (_, label)) <- chain, label `notElem` allowed, label /= "symbol"]       unless         (null orphans)         (expectationFailure ("Dataization emitted step labels with no defining rule or operation: " ++ show orphans))+    it "takes the step of a firing by evaluation" $ do+      expr <- parseExpressionThrows (primitives "5.plus(6)")+      loc <- parseExpressionThrows "Q"+      (_, chain, _) <- dataize expr emptyState (withLambdas known (defaultReduceContext loc))+      map snd chain `shouldContain` [Just (Evaluation, "evaluate")]+    it "takes the step of a box by contextualization" $ do+      expr <- parseExpressionThrows "[[ @ -> [[ D> 0A- ]] ]]"+      (_, chain, _) <- dataize expr emptyState (defaultReduceContext ExRoot)+      map snd chain `shouldContain` [Just (Contextualization, "contextualize")]+    it "takes the step of a delta by dataization" $ do+      expr <- parseExpressionThrows "[[ D> 3C- ]]"+      (_, chain, _) <- dataize expr emptyState (defaultReduceContext ExRoot)+      map snd chain `shouldBe` [Just (Dataization, "delta"), Nothing]    describe "names every rule uniquely across rule sets" $     it "shares no rule name between morphing, dataization, normalization and contextualization" $ do@@ -354,7 +377,7 @@           expr <- parseExpressionThrows src           loc' <- parseExpressionThrows loc           (_, chain, _) <- dataize expr emptyState (withLambdas known (defaultReduceContext loc'))-          pure [label | (_, Just label) <- chain]+          pure [label | (_, Just (_, label)) <- chain]     -- 'evaluate' is followed straight by the 'contextualize' of the answer's     -- own 𝔻 and not by the 'ma'/'copy'/'mf' that used to reduce it on the     -- spine: 𝔼 morphs what it answers before it hands it over, so the spine is@@ -377,3 +400,16 @@     it "dataizes a located reference through the expected rules" $ do       labels <- labelsOf "Q.foo.bar" "[[ foo -> [[ bar -> [[ @ -> Q.x ]] ]], x -> [[ D> 42- ]] ]]"       labels `shouldBe` ["contextualize", "md", "dot", "skip", "mf", "delta"]+    it "takes every step of 5.plus(6) by the judgment of its rule" $ do+      expr <- parseExpressionThrows "[[ bytes ↦ ⟦ φ ↦ ∅ ⟧, number(φ) -> [[ plus(^, x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6) ]]"+      (_, chain, _) <- dataize expr emptyState (withLambdas known (defaultReduceContext ExRoot))+      [judgment | (_, Just (judgment, _)) <- chain]+        `shouldBe` [ Contextualization+                   , Morphing+                   , Normalization+                   , Normalization+                   , Morphing+                   , Evaluation+                   , Contextualization+                   , Dataization+                   ]

@@ -5,13 +5,13 @@  module DepsSpec where -import AST (Expression (ExRoot, ExXi))+import AST (Binding (BiLambda), Bytes (BtOne), Expression (ExFormation, ExRoot, ExXi), Function (FnSymbol), symbols) import Control.Exception (bracket) import Control.Monad (replicateM_, when) import Data.IORef (modifyIORef', newIORef, readIORef) import Data.List (isInfixOf) import Data.Time.Clock.POSIX (getPOSIXTime)-import Deps (Evaluation (EvFiring, EvFormation, EvRun), Judgment (Morphing), dontSaveEval, dontSaveStep, emptyProgress, progressed, saveStep)+import Deps (Evaluation (EvFiring, EvFormation, EvJoined, EvMinted, EvRun, EvTerm), Judgment (Morphing), dontSaveEval, dontSaveStep, emptyProgress, progressed, renumbered, saveStep) import Logger (LogLevel (DEBUG, ERROR, INFO), setLogConfig) import System.Directory   ( doesDirectoryExist@@ -22,7 +22,7 @@ import System.FilePath ((</>)) import System.IO (stderr) import System.IO.Silently (hCapture_, hSilence)-import Test.Hspec (Spec, after_, describe, it, shouldBe, shouldSatisfy)+import Test.Hspec (Spec, after_, describe, expectationFailure, it, shouldBe, shouldSatisfy)  withScratchDir :: (FilePath -> IO a) -> IO a withScratchDir =@@ -99,3 +99,17 @@       cursor <- newIORef (emptyProgress 0)       captured <- hCapture_ [stderr] (progressed cursor 0 (const (pure "Φ.q")) dontSaveEval (EvRun Morphing "Φ.k"))       captured `shouldBe` ""++  describe "renumbered" $ do+    it "raises the symbols a record names above the floor" $+      case renumbered 3 10 (EvMinted 2 5 [Left 4, Left 1, Right (BtOne "7C")]) of+        EvMinted _ minted operands -> (minted, operands) `shouldBe` (15, [Left 14, Left 1, Right (BtOne "7C")])+        _ -> expectationFailure "The record did not stay the record it was"+    it "raises the symbols the terms of a record carry above the floor" $+      case renumbered 1 6 (EvTerm 4 "𝑛1" (ExFormation [BiLambda (FnSymbol 1)]) (ExFormation [BiLambda (FnSymbol 2)])) of+        EvTerm _ _ operand term -> (symbols operand, symbols term) `shouldBe` ([1], [8])+        _ -> expectationFailure "The record did not stay the record it was"+    it "does not change the depth a record stands at" $+      case renumbered 0 9 (EvJoined 7 1 (2, 3)) of+        EvJoined depth fresh pair -> (depth, fresh, pair) `shouldBe` (7, 10, (11, 12))+        _ -> expectationFailure "The record did not stay the record it was"

@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module EmitSpec where++import AST+import Control.Monad (forM_)+import Data.Either (fromRight)+import Data.List (isInfixOf)+import Emit (emitted)+import Engine (current)+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)+import Yaml qualified as Y++spec :: Spec+spec = do+  describe "emitted" $ do+    it "writes the module the flag 'compiled' links in" $+      fromRight "" (emitted Y.normalizationRules [] Y.contextualizationRules Y.morphingRules Y.dataizationRules current)+        `shouldSatisfy` ("module Compiled (compiled) where" `isInfixOf`)+    it "writes a function for every built-in rule of normalization" $+      fromRight "" (emitted Y.normalizationRules [] Y.contextualizationRules Y.morphingRules Y.dataizationRules current)+        `shouldSatisfy` (\source -> all (\rule -> ("R.direct " ++ show rule.name) `isInfixOf` source) Y.normalizationRules)+    it "writes an equation for every rule of contextualization" $+      fromRight "" (emitted Y.normalizationRules [] Y.contextualizationRules Y.morphingRules Y.dataizationRules current)+        `shouldSatisfy` (\source -> all (\rule -> ("(" ++ show rule.name ++ ", ") `isInfixOf` source) Y.contextualizationRules)+    it "writes a rule of '--rule' beside the built-in ones" $+      fromRight "" (emitted [] [Y.Rule "kwpr" Nothing Nothing (ExDispatch ExXi (AtLabel "hq")) ExRoot Nothing Nothing Nothing] [] [] [] [])+        `shouldSatisfy` ("R.direct \"kwpr\" False rewriteKwpr" `isInfixOf`)+    it "imports the texts a label of a rule is spelled with" $+      fromRight "" (emitted [] [Y.Rule "lb" Nothing Nothing (ExDispatch ExXi (AtLabel "hq")) ExRoot Nothing Nothing Nothing] [] [] [] [])+        `shouldSatisfy` ("import qualified Data.Text as T" `isInfixOf`)+    it "tells two rules of the same name apart" $+      fromRight "" (emitted [] [Y.Rule "ov" Nothing Nothing ExXi ExRoot Nothing Nothing Nothing, Y.Rule "ov" Nothing Nothing ExRoot ExXi Nothing Nothing Nothing] [] [] [] [])+        `shouldSatisfy` (\source -> all (`isInfixOf` source) ["stepOv0 ::", "stepOv1 ::"])+    it "writes a function for every rule of morphing" $+      fromRight "" (emitted [] [] [] Y.morphingRules [] [])+        `shouldSatisfy` (\source -> all (\rule -> ("-- The morphing rule '" ++ rule.name ++ "'.") `isInfixOf` source) Y.morphingRules)+    it "writes a function for every rule of dataization" $+      fromRight "" (emitted [] [] [] [] Y.dataizationRules [])+        `shouldSatisfy` (\source -> all (\rule -> ("-- The dataization rule '" ++ rule.name ++ "'.") `isInfixOf` source) Y.dataizationRules)+    it "hands the engine every rule of morphing it compiled" $+      fromRight "" (emitted [] [] [] [Y.MorphRule "qp" Nothing ExXi (ExMeta "e1") ExTermination Nothing []] [] [])+        `shouldSatisfy` ("morphings = [In.direct morphingQp]" `isInfixOf`)+    it "labels the step of a morphing rule with its judgment" $+      fromRight "" (emitted [] [] [] [Y.MorphRule "vb" Nothing ExXi (ExMeta "e1") (ExMeta "n7") Nothing [Y.Premise "n7" (Y.OpMorph ExTermination (ExMeta "e1"))]] [] [])+        `shouldSatisfy` ("In.Onward (In.Taken (D.Morphing, \"vb\")) ExTermination universe" `isInfixOf`)+    it "hands the answer of a premise to what the rule builds of it" $+      fromRight "" (emitted [] [] [] [Y.MorphRule "hn" Nothing ExXi (ExMeta "e1") (ExMeta "n3") Nothing [Y.Premise "n2" (Y.OpMorph ExRoot (ExMeta "e1")), Y.Premise "n3" (Y.OpMorph (ExDispatch (ExMeta "n2") (AtLabel "rq")) (ExMeta "e1"))]] [] [])+        `shouldSatisfy` ("In.Morphs ExRoot universe (\\n2 -> pure (In.Concludes (In.Onward (In.Taken (D.Morphing, \"hn\")) (ExDispatch n2 (AtLabel (T.pack \"rq\"))) universe)))" `isInfixOf`)+    it "answers with the data a dataization rule finds" $+      fromRight "" (emitted [] [] [] [] [Y.DataizeRule "dz" Nothing (ExFormation [BiDelta (BtMeta "d1")]) (ExMeta "e1") (BtMeta "d1") Nothing []] [])+        `shouldSatisfy` ("In.Concludes (In.Answered (D.Dataization, \"dz\") x4)" `isInfixOf`)+    it "compares a meta met twice in the pattern" $+      fromRight "" (emitted [] [Y.Rule "tw" Nothing Nothing (ExApplication (ExMeta "e1") (ArTau (AtLabel "g") (ExMeta "e1"))) ExRoot Nothing Nothing Nothing] [] [] [] [])+        `shouldSatisfy` ("x1 == x3" `isInfixOf`)+    it "asks a normal form of a '𝑛' meta the way the matcher does" $+      fromRight "" (emitted [] [Y.Rule "nh" Nothing Nothing (ExDispatch (ExMeta "n4") (AtLabel "wq")) ExRoot Nothing Nothing Nothing] [] [] [] [])+        `shouldSatisfy` ("Ru.normalHeld nf x1" `isInfixOf`)+    it "asks the condition 'nf' the way the matcher does" $+      fromRight "" (emitted [] [Y.Rule "nc" Nothing Nothing (ExDispatch (ExMeta "e3") (AtLabel "jb")) ExRoot (Just (Y.NF (ExMeta "e3"))) Nothing Nothing] [] [] [] [])+        `shouldSatisfy` ("Ru.normalHeld nf x1" `isInfixOf`)+  describe "emitted refuses a rule of contextualization" $+    it "with a premise that is no contextualization" $+      emitted [] [] [Y.ContextualizeRule "cm" Nothing (ExMeta "n1") (ExMeta "k1") (ExMeta "n2") [Y.Premise "n2" (Y.OpNormalize (ExMeta "n1"))]] [] [] []+        `shouldBe` Left "The contextualization rule 'cm' cannot be compiled, since its premise 'n2' is not a contextualization"+  describe "emitted refuses a rule of morphing" $ do+    it "whose conclusion no 'morph' produces" $+      emitted [] [] [] [Y.MorphRule "hq" Nothing ExXi (ExMeta "e1") (ExMeta "n2") Nothing [Y.Premise "n2" (Y.OpNormalize ExXi)]] [] []+        `shouldBe` Left "The morphing rule 'hq' cannot be compiled, since it concludes with no 'morph' premise"+    it "running a 'normalize' beside its spine" $+      emitted [] [] [] [Y.MorphRule "gd" Nothing ExXi (ExMeta "e1") (ExMeta "n3") Nothing [Y.Premise "n2" (Y.OpNormalize ExXi), Y.Premise "n3" (Y.OpMorph ExTermination (ExMeta "e1"))]] [] []+        `shouldBe` Left "The morphing rule 'gd' cannot be compiled, since its premise 'n2' runs beside the spine, which only a 'morph', an 'evaluate' or a 'contextualize' can"+    it "whose premise binds a meta its pattern bound" $+      emitted [] [] [] [Y.MorphRule "bb" Nothing (ExMeta "n2") (ExMeta "e1") (ExMeta "n3") Nothing [Y.Premise "n2" (Y.OpMorph ExXi (ExMeta "e1")), Y.Premise "n3" (Y.OpMorph (ExMeta "n2") (ExMeta "e1"))]] [] []+        `shouldBe` Left "The morphing rule 'bb' cannot be compiled, since its premise 'n2' binds a meta bound already"+  describe "emitted refuses a rule of dataization" $+    it "whose data no 'dataize' produces" $+      emitted [] [] [] [] [Y.DataizeRule "jr" Nothing ExXi (ExMeta "e1") (BtMeta "d2") Nothing [Y.Premise "d2" (Y.OpNormalize ExXi)]] []+        `shouldBe` Left "The dataization rule 'jr' cannot be compiled, since it concludes with no 'dataize' premise"+  describe "emitted refuses" $+    forM_+      [+        ( "a rule with a 'having' condition"+        , Y.Rule "hv" Nothing Nothing ExXi ExRoot Nothing Nothing (Just (Y.NF (ExMeta "e1")))+        , "The rule 'hv' cannot be compiled, since it has a 'having' condition"+        )+      ,+        ( "a rule rewriting a formation into a formation the fast way"+        , Y.Rule "fs" Nothing Nothing (ExFormation [BiMeta "B1", BiVoid (AtLabel "x"), BiMeta "B2"]) (ExFormation [BiMeta "B1", BiVoid (AtLabel "y"), BiMeta "B2"]) Nothing Nothing Nothing+        , "The rule 'fs' cannot be compiled, since it rewrites a formation into a formation the fast way"+        )+      ,+        ( "a pattern applying Φ to a ρ"+        , Y.Rule "rt" Nothing Nothing (ExDispatch (ExApplication ExRoot (ArTau AtRho ExXi)) (AtLabel "k")) ExXi Nothing Nothing Nothing+        , "The rule 'rt' cannot be compiled, since its pattern applies Φ to a ρ"+        )+      ,+        ( "a function of 'where' other than 'contextualize' and 'named'"+        , Y.Rule "rw" Nothing Nothing ExXi (ExMeta "e1") Nothing (Just [Y.Extra (Y.ArgExpression (ExMeta "e1")) "random-tau" []]) Nothing+        , "The rule 'rw' cannot be compiled, since its 'where' calls the function 'random-tau', which only 'contextualize' and 'named' can be"+        )+      ,+        ( "a condition 'matches'"+        , Y.Rule "mt" Nothing Nothing (ExMeta "e1") ExRoot (Just (Y.Matches "^a$" (ExMeta "e1"))) Nothing Nothing+        , "The rule 'mt' cannot be compiled, since its condition 'matches' needs a run of dataization"+        )+      ,+        ( "a condition 'part-of'"+        , Y.Rule "po" Nothing Nothing (ExMeta "e1") ExRoot (Just (Y.PartOf (ExMeta "e1") (BiMeta "B1"))) Nothing Nothing+        , "The rule 'po' cannot be compiled, since its condition 'part-of' is not compiled yet"+        )+      ,+        ( "a normal form asked of a term that is no meta"+        , Y.Rule "nx" Nothing Nothing (ExMeta "e1") ExRoot (Just (Y.NF ExXi)) Nothing Nothing+        , "The rule 'nx' cannot be compiled, since its condition asks about a term that is no meta"+        )+      ,+        ( "a result naming a meta the pattern does not bind"+        , Y.Rule "ub" Nothing Nothing ExXi (ExMeta "e7") Nothing Nothing Nothing+        , "The rule 'ub' cannot be compiled, since its result names a meta its pattern does not bind"+        )+      ,+        ( "a pattern holding a fresh symbol"+        , Y.Rule "fr" Nothing Nothing (ExFormation [BiLambda (FnFresh (Slot "S" 3))]) ExRoot Nothing Nothing Nothing+        , "The rule 'fr' cannot be compiled, since its pattern asks for a fresh symbol"+        )+      ]+      ( \(desc, rule, reason) ->+          it desc (emitted [] [rule] [] [] [] [] `shouldBe` Left reason)+      )

@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module EngineSpec where++import AST+import Data.Map.Strict qualified as Map+import Deps (Term (TeExpression))+import Engine (Engine (..), building, fresh, stepOf, yaml)+import Matcher (substEmpty)+import Rule (Step (..))+import Test.Hspec (Spec, describe, it, shouldBe)+import Yaml qualified as Y++spec :: Spec+spec = do+  describe "stepOf" $ do+    it "interprets a rule the engine was not compiled from" $+      _name (stepOf yaml (Y.Rule "wnkq" Nothing Nothing ExXi ExRoot Nothing Nothing Nothing)) `shouldBe` "wnkq"+    it "takes the step the engine compiled out of the very same rule" $+      let rule = Y.Rule "prv" Nothing Nothing ExTermination ExXi Nothing Nothing Nothing+       in _name (stepOf yaml{_rules = Map.fromList [(show rule, Step "zyx8" (\_ _ -> pure Nothing))]} rule) `shouldBe` "zyx8"+  describe "fresh" $ do+    it "accepts the engine interpreting the rules phino carries" $+      fresh yaml `shouldBe` True+    it "refuses an engine compiled from other rules" $+      fresh yaml{_sources = ["Rule {name = \"gone\"}"]} `shouldBe` False+  describe "building" $+    it "hands contextualization to the engine" $ do+      TeExpression term <- building yaml{_contextualize = \_ _ -> pure (ExDispatch ExRoot (AtLabel "qo"))} "contextualize" [Y.ArgExpression ExXi, Y.ArgExpression (ExFormation [])] substEmpty+      term `shouldBe` ExDispatch ExRoot (AtLabel "qo")

@@ -15,6 +15,7 @@ import Control.Monad (forM_) import Data.Aeson import Data.Yaml qualified as Yaml+import Deps (Judgment (..)) import Files (allPathsIn) import Filter qualified as F import GHC.Generics (Generic)@@ -69,9 +70,9 @@         second' <- parseExpressionThrows "[[ x -> ?, y -> ? ]]"         fqn <- parseExpressionThrows "Q.x"         expected <- parseExpressionThrows "[[ y -> ? ]]"-        let excluded = F.exclude [(first', Just "rule-a"), (second', Just "rule-b")] [fqn]+        let excluded = F.exclude [(first', Just (Normalization, "rule-a")), (second', Just (Evaluation, "rule-b"))] [fqn]         map fst excluded `shouldBe` [expected, expected]-        map snd excluded `shouldBe` [Just "rule-a", Just "rule-b"]+        map snd excluded `shouldBe` [Just (Normalization, "rule-a"), Just (Evaluation, "rule-b")]      describe "include" $ do       forM_@@ -102,9 +103,9 @@         second' <- parseExpressionThrows "[[ x -> ?, y -> ? ]]"         fqn <- parseExpressionThrows "Q.x"         expected <- parseExpressionThrows "[[ x -> ? ]]"-        included <- F.include [(first', Just "rule-a"), (second', Just "rule-b")] [fqn]+        included <- F.include [(first', Just (Normalization, "rule-a")), (second', Just (Evaluation, "rule-b"))] [fqn]         map fst included `shouldBe` [expected, expected]-        map snd included `shouldBe` [Just "rule-a", Just "rule-b"]+        map snd included `shouldBe` [Just (Normalization, "rule-a"), Just (Evaluation, "rule-b")]        it "keeps every matching fqn, not only the first one" $ do         expr <- parseExpressionThrows "[[ x -> ?, y -> ? ]]"

@@ -12,7 +12,9 @@   , explainPack   , fixtureLambdas   , lambdasFile+  , linked   , loopingLambdas+  , overdue   , primitives   , readUtf8   , recorded@@ -26,20 +28,23 @@ import AST (Expression (ExRoot)) import CLI.Helpers (withEvalFunc) import CLI.Types (IOFormat (PHI), PrintContext (PrintCtx))+import Compiled (compiled) import Control.Exception (bracket, evaluate) import Data.Aeson (FromJSON (parseJSON), withObject, (.:)) import Data.ByteString qualified as BS import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe) import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import Data.Yaml qualified as Yaml import Dataize (reduction) import Deps (Judgment (..), SaveEvalFunc, dontSaveEval, dontSaveStep)+import Engine (Engine, building, yaml) import Evaluate (evaluation, fired)-import Functions (buildTerm)+import GHC.Clock (getMonotonicTime) import Lambdas (Lambdas, emptyLambdas, readLambdas) import Lining (LineFormat (MULTILINE))-import Morph (ReduceContext (..), Steps (..))+import Morph (Deadline (..), ReduceContext (..), Steps (..)) import Sugar (SugarType (SWEET)) import System.Directory (getTemporaryDirectory, removePathForcibly) import System.IO (Handle, IOMode (ReadMode), hClose, hGetContents, hSetEncoding, openBinaryTempFile, utf8, withFile)@@ -52,8 +57,14 @@ -- none of them: a case that needs one to answer brings the fixture file in -- through 'withLambdas'. defaultReduceContext :: Expression -> ReduceContext-defaultReduceContext loc = ReduceContext loc loc Nothing 25 25 (Steps 250 0) Nothing Nothing 1 False True False False Nothing Morphing [] Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval+defaultReduceContext loc = ReduceContext loc loc Nothing 25 25 (Steps 250 0) Nothing Nothing Nothing 1 False True False False 1 Nothing Morphing [] Map.empty emptyLambdas (building linked) reduction evaluation fired dontSaveStep dontSaveEval linked +-- The engine the rules run on in this build: the one 'phino compile' wrote,+-- where the build links it in, and the one interpreting the rules of YAML+-- otherwise, so a build with the flag 'compiled' runs every spec on it.+linked :: Engine+linked = fromMaybe yaml compiled+ -- The same context with the given λ functions registered withLambdas :: Lambdas -> ReduceContext -> ReduceContext withLambdas lambdas ctx = ctx{_symbolic = lambdas}@@ -74,6 +85,12 @@ -- end the same run before the limit does. loopingLambdas :: (FilePath -> IO a) -> IO a loopingLambdas = withLambdasOf "- λ: L_loop\n  𝑛: ⟦ λ ⤍ L_loop ⟧\n"++-- The deadline of a run given the seconds of '--max-seconds' that passed a+-- second ago, so the next reading of the clock finds the run out of time and+-- no spec has to wait for it.+overdue :: Int -> IO Deadline+overdue cap = Deadline cap . subtract 1 <$> getMonotonicTime  -- The given λ functions, as the YAML file '--symbolic' reads, in a temporary -- file removed afterwards.

@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module InferenceSpec where++import AST+import Data.List (find)+import Data.Maybe (fromMaybe, isNothing)+import Deps (Judgment (..))+import Engine (Engine (..), building, yaml)+import Inference (Conclusion (..), Premises (..), Way (..), dataizationOf, dataizationSpine, direct, morphingOf, morphingSpine)+import Rule (RuleContext (RuleContext))+import System.IO.Error (ioeGetErrorString)+import Test.Hspec (Spec, describe, it, shouldBe, shouldThrow)+import Text.Printf (printf)+import Yaml qualified as Y++spec :: Spec+spec = do+  describe "morphingSpine" $ do+    it "answers with the conclusion of a rule no premise produces" $+      morphingSpine (Y.MorphRule "qz" Nothing ExXi (ExMeta "e1") (ExDispatch ExRoot (AtLabel "wk")) Nothing [])+        `shouldBe` Right ([], Answered (Morphing, "qz") (ExDispatch ExRoot (AtLabel "wk")))+    it "names the universe the rule 'universe' normalizes" $+      snd <$> morphingSpine (morphingRule "universe") `shouldBe` Right (Onward (Named (Morphing, "universe")) (ExMeta "e1") (ExMeta "e1"))+    it "normalizes the term the rule 'ma' builds for its spine" $+      snd <$> morphingSpine (morphingRule "ma") `shouldBe` Right (Onward (Normalized (Morphing, "ma")) (ExApplication (ExMeta "n2") (ArTau (AtMeta "t1") (ExMeta "k1"))) (ExMeta "e1"))+    it "keeps the premise the rule 'ma' runs beside its spine" $+      fst <$> morphingSpine (morphingRule "ma") `shouldBe` Right [Y.Premise "n2" (Y.OpMorph (ExMeta "n1") (ExMeta "e1"))]+    it "takes a step to the term a rule hands straight to its 'morph'" $+      morphingSpine (Y.MorphRule "vb" Nothing ExXi (ExMeta "e1") (ExMeta "n7") Nothing [Y.Premise "n7" (Y.OpMorph ExTermination (ExMeta "e1"))])+        `shouldBe` Right ([], Onward (Taken (Morphing, "vb")) ExTermination (ExMeta "e1"))+    it "refuses a rule whose conclusion no 'morph' produces" $+      morphingSpine (Y.MorphRule "hq" Nothing ExXi (ExMeta "e1") (ExMeta "n2") Nothing [Y.Premise "n2" (Y.OpNormalize ExXi)])+        `shouldBe` Left "it concludes with no 'morph' premise"+  describe "dataizationSpine" $ do+    it "answers with the data the rule 'delta' finds" $+      snd <$> dataizationSpine (dataizationRule "delta") `shouldBe` Right (Answered (Dataization, "delta") (BtMeta "d1"))+    it "labels the step of the rule 'box' by its 'contextualize'" $+      snd <$> dataizationSpine (dataizationRule "box") `shouldBe` Right (Onward (Normalized (Contextualization, "contextualize")) (ExMeta "e3") (ExMeta "e1"))+    it "labels the step of the rule 'fire' by its 'evaluate'" $+      snd <$> dataizationSpine (dataizationRule "fire") `shouldBe` Right (Onward (Taken (Evaluation, "evaluate")) (ExMeta "n1") (ExMeta "e1"))+    it "labels the step of the rule 'none' by its 'dataize'" $+      snd <$> dataizationSpine (dataizationRule "none") `shouldBe` Right (Onward (Taken (Dataization, "dataize")) ExTermination (ExMeta "e1"))+    it "stages the morphing the rule 'norm' asks for" $+      snd <$> dataizationSpine (dataizationRule "norm") `shouldBe` Right (Onward (Staged (ExMeta "e1")) (ExMeta "n1") (ExMeta "e1"))+    it "labels blank a step normalizing with nothing beside it" $+      snd <$> dataizationSpine (Y.DataizeRule "pz" Nothing ExXi (ExMeta "e1") (BtMeta "d4") Nothing [Y.Premise "n5" (Y.OpNormalize ExXi), Y.Premise "d4" (Y.OpDataize (ExMeta "n5") (ExMeta "e1"))])+        `shouldBe` Right (Onward (Normalized (Dataization, "")) ExXi (ExMeta "e1"))+    it "refuses a rule whose data no 'dataize' produces" $+      dataizationSpine (Y.DataizeRule "jr" Nothing ExXi (ExMeta "e1") (BtMeta "d2") Nothing [Y.Premise "d2" (Y.OpNormalize ExXi)])+        `shouldBe` Left "it concludes with no 'dataize' premise"+  describe "morphingOf" $ do+    it "finds nothing where the rule does not match the term" $ do+      found <- morphingOf (morphingRule "mf") context ExXi (ExFormation [])+      isNothing found `shouldBe` True+    it "concludes the way the rule 'mf' answers a formation" $ do+      Just (Concludes conclusion) <- morphingOf (morphingRule "mf") context (ExFormation [BiTau (AtLabel "yk") (ExDispatch ExRoot (AtLabel "pw"))]) (ExFormation [])+      conclusion `shouldBe` Answered (Morphing, "mf") (ExFormation [BiTau (AtLabel "yk") (ExDispatch ExRoot (AtLabel "pw"))])+    it "asks the premise beside the spine of 'ma' about the head" $ do+      Just (Morphs term world _) <- morphingOf (morphingRule "ma") context (ExApplication (ExDispatch ExRoot (AtLabel "hm")) (ArTau (AtLabel "xw") (ExDispatch ExRoot (AtLabel "qv")))) (ExFormation [BiVoid (AtLabel "oj")])+      (term, world) `shouldBe` (ExDispatch ExRoot (AtLabel "hm"), ExFormation [BiVoid (AtLabel "oj")])+    it "builds the conclusion of 'ma' out of the answer its premise is handed" $ do+      Just (Morphs _ _ next) <- morphingOf (morphingRule "ma") context (ExApplication (ExDispatch ExRoot (AtLabel "hm")) (ArTau (AtLabel "xw") (ExDispatch ExRoot (AtLabel "qv")))) (ExFormation [BiVoid (AtLabel "oj")])+      Concludes conclusion <- next (ExFormation [BiVoid (AtLabel "uf")])+      conclusion `shouldBe` Onward (Normalized (Morphing, "ma")) (ExApplication (ExFormation [BiVoid (AtLabel "uf")]) (ArTau (AtLabel "xw") (ExDispatch ExRoot (AtLabel "qv")))) (ExFormation [BiVoid (AtLabel "oj")])+    it "refuses a rule running a 'normalize' beside its spine" $+      morphingOf (Y.MorphRule "gd" Nothing ExXi (ExMeta "e1") (ExMeta "n3") Nothing [Y.Premise "n2" (Y.OpNormalize ExXi), Y.Premise "n3" (Y.OpMorph ExTermination (ExMeta "e1"))]) context ExXi (ExFormation [])+        `shouldThrow` (\failure -> ioeGetErrorString failure == "The rule 'gd' cannot be run, since its premise 'n2' runs beside the spine, which only a 'morph', an 'evaluate' or a 'contextualize' can")+  describe "dataizationOf" $ do+    it "answers with the data a formation carries" $ do+      Just (Concludes conclusion) <- dataizationOf (dataizationRule "delta") context (ExFormation [BiDelta (BtMany ["3C", "7E"])]) (ExFormation [])+      conclusion `shouldBe` Answered (Dataization, "delta") (BtMany ["3C", "7E"])+    it "hands the rule 'fire' the formation to evaluate" $ do+      Just (Evaluates form world _) <- dataizationOf (dataizationRule "fire") context (ExFormation [BiLambda (Function "Kq")]) (ExFormation [BiVoid (AtLabel "rb")])+      (form, world) `shouldBe` (ExFormation [BiLambda (Function "Kq")], ExFormation [BiVoid (AtLabel "rb")])+    it "hands the rule 'box' the body to contextualize in its formation" $ do+      Just (Contextualizes body formation _) <- dataizationOf (dataizationRule "box") context (ExFormation [BiTau AtPhi (ExDispatch ExXi (AtLabel "zu"))]) (ExFormation [])+      (body, formation) `shouldBe` (ExDispatch ExXi (AtLabel "zu"), ExFormation [BiTau AtPhi (ExDispatch ExXi (AtLabel "zu"))])+  describe "direct" $ do+    it "takes the first way a compiled rule matches" $ do+      Just (Concludes conclusion) <- direct (\_ _ -> [Concludes (Answered (Morphing, "w1") ExXi), Concludes (Answered (Morphing, "w2") ExXi)]) context ExXi ExXi+      conclusion `shouldBe` Answered (Morphing, "w1") ExXi+    it "finds nothing where a compiled rule matches no way" $ do+      found <- direct (\_ _ -> [] :: [Premises Expression]) context ExXi ExXi+      isNothing found `shouldBe` True++-- The context a rule of the specs checks its conditions in: the functions of+-- the engine of YAML and no world.+context :: RuleContext+context = RuleContext (building yaml) Nothing yaml._normal++-- The built-in rule of 𝕄 of the given name.+morphingRule :: String -> Y.MorphRule+morphingRule name = fromMaybe (error (printf "no morphing rule is named '%s'" name)) (find (\rule -> rule.name == name) Y.morphingRules)++-- The built-in rule of 𝔻 of the given name.+dataizationRule :: String -> Y.DataizeRule+dataizationRule name = fromMaybe (error (printf "no dataization rule is named '%s'" name)) (find (\rule -> rule.name == name) Y.dataizationRules)

@@ -18,6 +18,7 @@ import Data.List (intercalate) import Data.Text qualified as T import Data.Yaml qualified as Yaml+import Deps (Judgment (..)) import Files (allPathsIn) import Fixtures (explainPack) import GHC.Generics (Generic)@@ -106,18 +107,18 @@         [] -> expectationFailure "meetInExpressions returned no expressions"    describe "indents wrapped continuation steps in a --sequence (#981)" $-    it "nests a wrapped step's members below its two-space \\leadsto line and aligns the closing bracket with it, rather than laying the step out from column 0" $ do+    it "nests a wrapped step's members below its two-space arrow line and aligns the closing bracket with it, rather than laying the step out from column 0" $ do       start <- parseExpressionThrows "[[ x -> Q.y ]]"       wrapped <- parseExpressionThrows "[[ a -> Q.b, c -> Q.d ]]"       let ctx = defaultLatexContext{_line = MULTILINE, _margin = 20}-      latex <- rewrittensToLatex ([(start, Just "first"), (wrapped, Just "second")], False) ctx+      latex <- rewrittensToLatex ([(start, Just (Normalization, "first")), (wrapped, Just (Normalization, "second"))], False) ctx       latex         `shouldContain` intercalate           "\n"-          [ "  \\leadsto [["+          [ "  \\phiNormalize [["           , "    |a| -> Q . |b|,"           , "    |c| -> Q . |d|"-          , "  ]] \\leadsto_{\\nameref{r:second}}"+          , "  ]] \\phiNormalize[\\nameref{r:second}]"           ]    describe "renders the 'formation' condition" $@@ -193,15 +194,66 @@       )    describe "rewrittensToLatex" $ do-    it "renders the ellipsis ending when the chain exceeded its bound" $ do+    it "trails a chain that ran out before its first step off with the arrow of normalization" $ do       step1 <- parseExpressionThrows "[[ x -> Q.y ]]"       latex <- rewrittensToLatex ([(step1, Nothing)], True) defaultLatexContext-      latex `shouldBe` "\\begin{phiquation}\nQ . |y| : |x| \\leadsto\n  \\leadsto \\dots\n\\end{phiquation}"+      latex `shouldBe` "\\begin{phiquation}\nQ . |y| : |x| \\phiNormalize\n  \\phiNormalize \\dots\n\\end{phiquation}" +    it "trails a chain that ran out of steps off with the arrow of its last step" $ do+      first <- parseExpressionThrows "[[ k -> Q.m ]]"+      second <- parseExpressionThrows "[[ k -> Q.w ]]"+      latex <- rewrittensToLatex ([(first, Just (Morphing, "mphi")), (second, Nothing)], True) defaultLatexContext+      latex+        `shouldBe` intercalate+          "\n"+          [ "\\begin{phiquation}"+          , "Q . |m| : |k| \\phiMorph[\\nameref{r:mphi}]"+          , "  \\phiMorph Q . |w| : |k| \\phiMorph"+          , "  \\phiMorph \\dots"+          , "\\end{phiquation}"+          ]++    forM_+      [ (Normalization, "\\phiNormalize")+      , (Morphing, "\\phiMorph")+      , (Dataization, "\\phiDataize")+      , (Evaluation, "\\phiEvaluate")+      , (Contextualization, "\\phiContextualize")+      ]+      ( \(judgment, arrow) ->+          it ("ends a step taken by " ++ show judgment ++ " with " ++ arrow ++ " and opens the next one with it") $ do+            first <- parseExpressionThrows "[[ q -> Q.f ]]"+            second <- parseExpressionThrows "[[ q -> Q.j ]]"+            latex <- rewrittensToLatex ([(first, Just (judgment, "tv")), (second, Nothing)], False) defaultLatexContext+            latex+              `shouldBe` intercalate+                "\n"+                [ "\\begin{phiquation}"+                , "Q . |f| : |q| " ++ arrow ++ "[\\nameref{r:tv}]"+                , "  " ++ arrow ++ " Q . |j| : |q|{.}"+                , "\\end{phiquation}"+                ]+      )++    it "opens every step with the arrow of the judgment that took the step before it" $ do+      first <- parseExpressionThrows "[[ u -> Q.g ]]"+      second <- parseExpressionThrows "[[ u -> Q.h ]]"+      third <- parseExpressionThrows "[[ D> 07- ]]"+      latex <- rewrittensToLatex ([(first, Just (Normalization, "copy")), (second, Just (Dataization, "box")), (third, Nothing)], False) defaultLatexContext+      latex+        `shouldBe` intercalate+          "\n"+          [ "\\begin{phiquation}"+          , "Q . |g| : |u| \\phiNormalize[\\nameref{r:copy}]"+          , "  \\phiNormalize Q . |h| : |u| \\phiDataize[\\nameref{r:box}]"+          , "  \\phiDataize |07-| : D{.}"+          , "\\end{phiquation}"+          ]+     it "prefixes each step with a '% === Step' header when '_headers' is set" $ do       step1 <- parseExpressionThrows "[[ x -> Q.y ]]"       step2 <- parseExpressionThrows "[[ x -> Q.z ]]"-      latex <- rewrittensToLatex ([(step1, Nothing), (step2, Just "myrule")], False) defaultLatexContext{_headers = True}+      latex <- rewrittensToLatex ([(step1, Nothing), (step2, Just (Normalization, "myrule"))], False) defaultLatexContext{_headers = True}       latex         `shouldBe` intercalate           "\n"@@ -209,7 +261,7 @@           , "% === Step #1"           , "Q . |y| : |x|"           , "% === Step #2, Rule '?', 7t -> 7t"-          , "  \\leadsto Q . |z| : |x| \\leadsto_{\\nameref{r:myrule}}{.}"+          , "  \\phiNormalize Q . |z| : |x| \\phiNormalize[\\nameref{r:myrule}]{.}"           , "\\end{phiquation}"           ] @@ -217,13 +269,13 @@       step1 <- parseExpressionThrows "[[ x -> Q.aaa.bbb.ccc.ddd ]]"       step2 <- parseExpressionThrows "[[ x -> Q.aaa.bbb.ccc.ddd.eee ]]"       focus <- parseExpressionThrows "Q.x"-      latex <- rewrittensToLatex ([(step1, Nothing), (step2, Just "r")], False) defaultLatexContext{_focus = focus}+      latex <- rewrittensToLatex ([(step1, Nothing), (step2, Just (Normalization, "r"))], False) defaultLatexContext{_focus = focus}       latex         `shouldBe` intercalate           "\n"           [ "\\begin{phiquation}"           , "Q . |aaa| . |bbb| . |ccc| . |ddd|"-          , "  \\leadsto Q . |aaa| . |bbb| . |ccc| . |ddd| . |eee| \\leadsto_{\\nameref{r:r}}{.}"+          , "  \\phiNormalize Q . |aaa| . |bbb| . |ccc| . |ddd| . |eee| \\phiNormalize[\\nameref{r:r}]{.}"           , "\\end{phiquation}"           ] @@ -233,15 +285,15 @@       step3 <- parseExpressionThrows "[[ z -> Q.a.b.c.d ]]"       latex <-         rewrittensToLatex-          ([(step1, Nothing), (step2, Just "r1"), (step3, Just "r2")], False)+          ([(step1, Nothing), (step2, Just (Normalization, "r1")), (step3, Just (Normalization, "r2"))], False)           defaultLatexContext{_compress = True, _canonize = True}       latex         `shouldBe` intercalate           "\n"           [ "\\begin{phiquation}"           , "\\phinoMeet{1}{ Q . |a| . |b| . |c| . |d| } : |x|"-          , "  \\leadsto \\phinoAgain{1} : |y| \\leadsto_{\\nameref{r:r1}}"-          , "  \\leadsto \\phinoAgain{1} : |z| \\leadsto_{\\nameref{r:r2}}{.}"+          , "  \\phiNormalize \\phinoAgain{1} : |y| \\phiNormalize[\\nameref{r:r1}]"+          , "  \\phiNormalize \\phinoAgain{1} : |z| \\phiNormalize[\\nameref{r:r2}]{.}"           , "\\end{phiquation}"           ] @@ -252,15 +304,15 @@       step3 <- parseExpressionThrows "[[ x -> [[ w -> Q.a.b.c.d ]] ]]"       latex <-         rewrittensToLatex-          ([(step1, Nothing), (step2, Just "r1"), (step3, Just "r2")], False)+          ([(step1, Nothing), (step2, Just (Normalization, "r1")), (step3, Just (Normalization, "r2"))], False)           defaultLatexContext{_focus = focus, _compress = True, _canonize = True}       latex         `shouldBe` intercalate           "\n"           [ "\\begin{phiquation}"           , "\\phinoMeet{1}{ Q . |a| . |b| . |c| . |d| : |w| }"-          , "  \\leadsto \\phinoAgain{1} \\leadsto_{\\nameref{r:r1}}"-          , "  \\leadsto \\phinoAgain{1} \\leadsto_{\\nameref{r:r2}}{.}"+          , "  \\phiNormalize \\phinoAgain{1} \\phiNormalize[\\nameref{r:r1}]"+          , "  \\phiNormalize \\phinoAgain{1} \\phiNormalize[\\nameref{r:r2}]{.}"           , "\\end{phiquation}"           ] 

@@ -628,6 +628,27 @@             , ("B2", MvBindings [BiVoid AtRho])             ]           ]+  describe "sites" $ do+    it "finds the places a rule matches at in the order the deep matcher finds them" $+      map fst (sites False (\expr -> [() | ExDispatch _ _ <- [expr]]) (ExDispatch (ExFormation [BiTau (AtLabel "wq") (ExDispatch ExXi (AtLabel "h"))]) (AtLabel "r")))+        `shouldBe` [ExDispatch (ExFormation [BiTau (AtLabel "wq") (ExDispatch ExXi (AtLabel "h"))]) (AtLabel "r"), ExDispatch ExXi (AtLabel "h")]+    it "keeps what the rule makes of a place beside it, once for every way it matches" $+      sites False (\expr -> [idx | ExXi <- [expr], idx <- [7, 3 :: Int]]) (ExApplication ExRoot (ArTau (AtLabel "u") ExXi))+        `shouldBe` [(ExXi, 7), (ExXi, 3)]+    it "never looks inside an inert term when the rule is a redex" $+      sites True (\expr -> [() | ExXi <- [expr]]) (ExFormation [BiTau (AtLabel "zk") (ExFormation [BiDelta (BtOne "1F")])])+        `shouldBe` []+  describe "anywhere" $ do+    it "tells a rule matches deep inside the term" $+      anywhere False (== ExTermination) (ExDispatch (ExApplication ExXi (ArAlpha (Alpha 2) ExTermination)) (AtLabel "y"))+        `shouldBe` True+    it "tells a rule matches nowhere in the term" $+      anywhere False (== ExTermination) (ExDispatch ExXi (AtLabel "ob"))+        `shouldBe` False+  describe "splits" $+    it "cuts the bindings in two, the shortest leading run first" $+      splits [BiVoid (AtLabel "a"), BiVoid AtRho]+        `shouldBe` [([], [BiVoid (AtLabel "a"), BiVoid AtRho]), ([BiVoid (AtLabel "a")], [BiVoid AtRho]), ([BiVoid (AtLabel "a"), BiVoid AtRho], [])]   where     -- The pattern of the 'dot' normalization rule, the one every dispatch of a     -- program is matched against: a meta binding on either side of the binding

@@ -11,7 +11,6 @@ module MorphSpec (spec) where  import AST-import Builder (buildExpressionThrows) import Control.Exception (SomeException) import Control.Monad import Data.Aeson (FromJSON)@@ -21,17 +20,21 @@ import Data.Maybe (fromMaybe) import Data.Yaml qualified as Decode import Dataize (Outcome (..), dataize)-import Deps (State, Term (TeExpression))+import Deps (Acyclic (..), Judgment (..), State, Term (TeExpression))+import Engine (Engine (_normal)) import Files (allPathsIn)-import Fixtures (defaultReduceContext, fixtureLambdas, primitives, withLambdas, withLambdasOf)+import Fixtures (defaultReduceContext, fixtureLambdas, linked, overdue, primitives, withLambdas, withLambdasOf)+import GHC.Clock (getMonotonicTime) import GHC.Generics (Generic)+import Inference (Conclusion (Answered), Premises (Concludes, Morphs), direct) import Lambdas (Lambdas, emptyLambdas, readLambdas)-import Matcher (MetaValue (MvExpression), substEmpty, substSingle)-import Morph (ReduceContext (..), emptyState, execBuildTerm, insideUniverse, morph, morph', sidePremise)+import Matcher (substEmpty)+import Morph (Deadline (..), ReduceContext (..), emptyState, enter, execBuildTerm, inferred, insideUniverse, morph, morph') import Parser (parseExpressionThrows) import Rewriter (Rewritten) import Rule (RuleContext (RuleContext), matchExpressionWithRule') import System.FilePath (makeRelative)+import System.Timeout (timeout) import Tau (seedTaus) import Test.Hspec import Yaml (ExtraArgument (..))@@ -104,7 +107,7 @@       expr <- parseExpressionThrows "[[ D> 00- ]]"       (morphed, chain, _) <- morph expr emptyState (defaultReduceContext ExRoot)       morphed `shouldBe` expr-      map snd chain `shouldBe` [Just "mf", Nothing]+      map snd chain `shouldBe` [Just (Morphing, "mf"), Nothing]       map fst chain `shouldBe` [expr, expr]      -- The 'universe' rule resolves Φ to the world in normal form, and the run@@ -195,16 +198,17 @@   -- one the frame around it was handed: here the frame is in Φ, where Φ morphs   -- to ⊥ through 'mg', while the premise names a world where Φ morphs to that   -- world through 'universe' (#1512).-  describe "sidePremise" $+  describe "inferred" $     it "morphs a premise in the universe it names, not in the one the frame is in" $ do       world <- parseExpressionThrows "[[ x -> [[ ]] ]]"-      (subst, _) <--        sidePremise+      Just (Answered _ answer, _) <-+        inferred           ExRoot+          ExRoot+          emptyState           (defaultReduceContext ExRoot)-          (substSingle "e" (MvExpression world), emptyState)-          Yaml.Premise{result = "n1", operation = Yaml.OpMorph ExRoot (ExMeta "e")}-      buildExpressionThrows (ExMeta "n1") subst `shouldReturn` world+          [direct (\_ _ -> [Morphs ExRoot world (pure . Concludes . Answered (Morphing, "premise"))])]+      answer `shouldBe` world    -- Every normal form is covered by some morphing clause (an axiom like   -- 'mf'/'dead'/'xi'/'universe'/'mg' or a recursive rule), so the "no rule@@ -292,7 +296,7 @@   -- two clauses are mutually exclusive and their order in 'resources/morphing'   -- cannot change behavior.   describe "morphing 'md' is disjoint from 'ml'" $ do-    let rctx = RuleContext (execBuildTerm ExRoot (defaultReduceContext ExRoot)) Nothing+    let rctx = RuleContext (execBuildTerm ExRoot (defaultReduceContext ExRoot)) Nothing (_normal linked)         morphRule :: String -> Yaml.MorphRule         morphRule nm = fromMaybe (error ("no morphing rule named " ++ nm)) (find (\r -> r.name == nm) Yaml.morphingRules)         asRule :: Yaml.MorphRule -> Yaml.Rule@@ -314,3 +318,32 @@           chain = ExDispatch (ExDispatch (ExDispatch base (AtLabel "a")) (AtLabel "b")) (AtLabel "c")       morph' (chain, (ExRoot, Nothing) :| []) ExRoot emptyState (defaultReduceContext ExRoot)         `shouldThrow` (\e -> "No entry of --symbolic answers the λ function 'F'" `isInfixOf` show (e :: SomeException))++  -- '--max-seconds' is read at every step of 𝕄 and not only where a λ function+  -- fires, so a run spending its time on rewriting stops on time too, and a+  -- passed deadline ends the run with or without '--partial', since a run out+  -- of time has nothing left to go on with (#1619).+  describe "stops by the clock of --max-seconds" $ do+    it "fails a morphing that fires nothing once the deadline has passed" $ do+      expr <- parseExpressionThrows "[[ k -> [[ D> 3F- ]] ]]"+      deadline <- overdue 17+      morph expr emptyState (defaultReduceContext ExRoot){_deadline = Just deadline}+        `shouldThrow` (\e -> "--max-seconds=17" `isInfixOf` show (e :: SomeException))+    it "fails a partial morphing once the deadline has passed" $ do+      expr <- parseExpressionThrows "[[ q -> [[ D> 5A- ]] ]]"+      deadline <- overdue 23+      morph expr emptyState (defaultReduceContext ExRoot){_deadline = Just deadline, _partial = True}+        `shouldThrow` (\e -> "--max-seconds=23" `isInfixOf` show (e :: SomeException))++  -- Under '--acyclic=plausible' one comparison of 'within' may take longer than+  -- the whole run may, since it looks for the formation entered above at every+  -- depth of the one about to be entered, so the clock cuts the comparison while+  -- it runs and does not wait for the next step (#1622).+  describe "stops an entrance by the clock of --max-seconds" $+    it "fails a comparison that outlasts the deadline" $ do+      due <- (+ 0.2) <$> getMonotonicTime+      let formation :: Expression -> Int -> Expression+          formation base depth = ExFormation [BiTau (AtLabel "x") (iterate (`ExDispatch` AtLabel "w") base !! depth), BiLambda (Function "L_q")]+      ctx <- enter (formation ExRoot 1300) (defaultReduceContext ExRoot){_acyclic = Just Plausible, _deadline = Just (Deadline 31 due)}+      timeout 10000000 (enter (formation ExXi 1700) ctx)+        `shouldThrow` (\e -> "--max-seconds=31" `isInfixOf` show (e :: SomeException))

@@ -0,0 +1,35 @@+-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com+-- SPDX-License-Identifier: MIT++module PoolSpec where++import Control.Concurrent (threadDelay)+import Control.Exception (ErrorCall (..), throwIO, try)+import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import Pool (pooled)+import Test.Hspec (Spec, describe, it, shouldReturn)++spec :: Spec+spec = describe "Pool" $ do+  it "folds what the actions gave in the order they were listed" $+    pooled 3 [threadDelay (pause * 1000) >> pure pause | pause <- [9, 1, 7, 2, 5]] (\acc pause -> pure (acc ++ [pause])) []+      `shouldReturn` [9, 1, 7, 2, 5 :: Int]+  it "runs no more actions at once than it was given" $ do+    running <- newIORef (0 :: Int)+    most <- newIORef (0 :: Int)+    let action :: IO ()+        action = do+          now <- atomicModifyIORef' running (\count -> (count + 1, count + 1))+          atomicModifyIORef' most (\peak -> (max peak now, ()))+          threadDelay 2000+          atomicModifyIORef' running (\count -> (count - 1, ()))+    pooled 2 (replicate 7 action) (\_ _ -> pure ()) ()+    readIORef most `shouldReturn` 2+  it "throws what an action threw once the actions before it are folded" $ do+    folded <- newIORef []+    outcome <- try (pooled 2 [pure 'x', throwIO (ErrorCall "broken"), pure 'z'] (\_ ch -> atomicModifyIORef' folded (\seen -> (seen ++ [ch], ()))) ())+    (,) outcome <$> readIORef folded `shouldReturn` (Left (ErrorCall "broken"), "x")+  it "folds nothing where it is given no action" $+    pooled 4 ([] :: [IO Int]) (\acc val -> pure (acc + val)) 42 `shouldReturn` 42+  it "folds every action where it may run one at a time" $+    pooled 1 (map pure [3, 8, 1]) (\acc val -> pure (acc * 10 + val)) 0 `shouldReturn` (381 :: Int)

@@ -9,25 +9,28 @@  module RewriterSpec where -import AST (Attribute (AtLabel), Binding (BiTau), Expression (ExDispatch, ExFormation, ExRoot, ExTermination))+import AST (Argument (ArTau), Attribute (AtLabel), Binding (BiMeta, BiTau, BiVoid), Expression (ExApplication, ExDispatch, ExFormation, ExRoot, ExTermination, ExXi)) import Control.Exception (SomeException) import Control.Monad (forM_, unless) import Data.Aeson import Data.Char (isSpace)-import Data.List (isInfixOf)+import Data.List (isInfixOf, nub) import Data.List.NonEmpty qualified as NE import Data.Yaml qualified as Yaml-import Deps (dontSaveStep)+import Deps (Judgment (..), dontSaveStep)+import Engine (Engine (_normal), building, stepOf) import Files (allPathsIn, ensuredFile)+import Fixtures (linked) import Functions (buildTerm) import GHC.Generics import Must (Must (..)) import Parser (parseExpressionThrows) import Printer (printExpression)-import Rewriter (RewriteContext (RewriteContext), rewrite)+import Rewriter (RewriteContext (RewriteContext), direct, fast, rewrite)+import Rule (RuleContext (RuleContext), Step (_applied)) import System.FilePath (makeRelative, replaceExtension, (</>)) import Tau (seedTaus)-import Test.Hspec (Spec, describe, expectationFailure, it, pending, runIO, shouldSatisfy, shouldThrow)+import Test.Hspec (Spec, describe, expectationFailure, it, pending, runIO, shouldBe, shouldReturn, shouldSatisfy, shouldThrow) import Yaml (normalizationRules) import Yaml qualified as Y @@ -112,7 +115,7 @@       ]       ( \(desc, input', (maxDepth, maxCycles, depthSensitive), expected) -> it desc $ do           expr <- parseExpressionThrows input'-          let action = rewrite expr normalizationRules (RewriteContext ExRoot maxDepth maxCycles depthSensitive Nothing buildTerm MtDisabled Nothing dontSaveStep)+          let action = rewrite expr (map (stepOf linked) normalizationRules) (RewriteContext ExRoot maxDepth maxCycles depthSensitive Nothing (building linked) (_normal linked) MtDisabled Nothing dontSaveStep)           case expected of             Left fragment -> action `shouldThrow` (\exc -> fragment `isInfixOf` show (exc :: SomeException))             Right predicate -> do@@ -140,7 +143,7 @@       ]       ( \(desc, must', expected) -> it desc $ do           expr <- parseExpressionThrows "⟦ t ↦ ⊥.a.b.c ⟧"-          let action = rewrite expr normalizationRules (RewriteContext ExRoot 1 1 False Nothing buildTerm must' Nothing dontSaveStep)+          let action = rewrite expr (map (stepOf linked) normalizationRules) (RewriteContext ExRoot 1 1 False Nothing (building linked) (_normal linked) must' Nothing dontSaveStep)           case expected of             Left fragment -> action `shouldThrow` (\exc -> fragment `isInfixOf` show (exc :: SomeException))             Right predicate -> do@@ -148,6 +151,12 @@               result `shouldSatisfy` predicate       ) +  describe "judges the steps it takes" $+    it "takes every step by normalization" $ do+      expr <- parseExpressionThrows "⟦ k ↦ ⟦ w ↦ ⟦ Δ ⤍ 1F- ⟧ ⟧.w ⟧"+      (rewrittens, _) <- rewrite expr (map (stepOf linked) normalizationRules) (RewriteContext ExRoot 25 25 False Nothing (building linked) (_normal linked) MtDisabled Nothing dontSaveStep)+      nub [judgment | (_, Just (judgment, _)) <- NE.toList rewrittens] `shouldBe` [Normalization]+   describe "rewrite packs" $ do     let resources = "test-resources/rewriter-packs"     packs <- runIO (allPathsIn resources)@@ -191,14 +200,15 @@               (rewrittens, _) <-                 rewrite                   expr-                  rules'+                  (map (stepOf linked) rules')                   ( RewriteContext                       ExRoot                       repeat'                       repeat'                       False                       Nothing-                      buildTerm+                      (building linked)+                      (_normal linked)                       must'                       Nothing                       dontSaveStep@@ -213,3 +223,20 @@                       ++ printExpression rewritten                   )       )+  describe "direct" $ do+    it "rewrites every place the function matches at" $+      _applied (direct "tx" False (\_ expr -> [ExRoot | ExXi <- [expr]])) (RuleContext buildTerm Nothing (const True)) (ExDispatch (ExApplication ExXi (ArTau (AtLabel "o") ExXi)) (AtLabel "m"))+        `shouldReturn` Just (ExDispatch (ExApplication ExRoot (ArTau (AtLabel "o") ExRoot)) (AtLabel "m"))+    it "tells it matched nowhere" $+      _applied (direct "tx" False (\_ expr -> [ExRoot | ExXi <- [expr]])) (RuleContext buildTerm Nothing (const True)) (ExDispatch ExTermination (AtLabel "m"))+        `shouldReturn` Nothing+    it "hands the world to the function" $+      _applied (direct "tw" False (\universe expr -> [world | ExXi <- [expr], Just world <- [universe]])) (RuleContext buildTerm (Just ExTermination) (const True)) ExXi+        `shouldReturn` Just ExTermination+  describe "fast" $ do+    it "holds for a formation rewritten between the same two meta bindings" $+      fast (ExFormation [BiMeta "B1", BiVoid (AtLabel "j"), BiMeta "B2"]) (ExFormation [BiMeta "B1", BiVoid (AtLabel "k"), BiMeta "B2"])+        `shouldBe` True+    it "fails for a formation rewritten into a dispatch" $+      fast (ExFormation [BiMeta "B1", BiVoid (AtLabel "j"), BiMeta "B2"]) (ExDispatch ExXi (AtLabel "k"))+        `shouldBe` False

@@ -8,18 +8,20 @@  module RuleSpec where -import AST (Argument (..), Attribute (..), Binding (..), Bytes (..), Expression (..), Function (..), inert)+import AST (Argument (..), Attribute (..), Binding (..), Bytes (..), Expression (..), Function (..), Slot (..), inert) import Builder (buildExpressionThrows) import Control.Monad import Data.Aeson import Data.Yaml qualified as Y+import Engine (Engine (_normal)) import Files (allPathsIn)+import Fixtures (linked) import Functions (buildTerm) import GHC.Generics import Matcher import Parser (parseExpressionThrows) import Printer (printSubsts)-import Rule (RuleContext (RuleContext), isNF, matchExpressionWithRule, meetCondition, redex)+import Rule (RuleContext (RuleContext), isNF, matchExpressionWithRule, meetCondition, normalHeld, redex) import System.FilePath import Test.Hspec (Spec, describe, expectationFailure, it, runIO, shouldBe, shouldReturn, shouldSatisfy) import Yaml qualified@@ -44,7 +46,7 @@           let expr = expression pack           let matched = matchExpression (pattern pack) expr           unless (matched /= []) (expectationFailure "List of matched substitutions is empty which is not expected")-          met <- meetCondition (condition pack) matched (RuleContext buildTerm Nothing)+          met <- meetCondition (condition pack) matched (RuleContext buildTerm Nothing (_normal linked))           case failure pack of             Just True ->               unless@@ -62,7 +64,7 @@                 )       )   describe "isNF determines normal form" $ do-    let ctx = RuleContext buildTerm Nothing+    let ctx = RuleContext buildTerm Nothing (_normal linked)     forM_       [ ("returns true for ExXi", ExXi, True)       , ("returns true for ExRoot", ExRoot, True)@@ -79,12 +81,13 @@       , ("returns false for formation with delta and lambda, which dl reduces", ExFormation [BiDelta (BtMany ["01"]), BiLambda (Function "Fn")], False)       , ("returns true for a formation with a tau binding whose expression is already normal", ExFormation [BiTau (AtLabel "x") ExRoot], True)       , ("returns false for a formation with a tau binding matching a normalization rule", ExFormation [BiTau (AtLabel "x") (ExDispatch ExTermination (AtLabel "y"))], False)+      , ("returns false for a dispatch whose body no rule of contextualization takes", ExDispatch (ExFormation [BiTau (AtLabel "kq") (ExDispatch (ExMeta "e5") (AtLabel "wb"))]) (AtLabel "kq"), False)       ]       (\(desc, expr, expected) -> it desc $ isNF expr ctx `shouldBe` expected)    describe "matchExpressionWithRule via a 'where' extension or a φ-marker meta" $ do     let ctx :: RuleContext-        ctx = RuleContext buildTerm Nothing+        ctx = RuleContext buildTerm Nothing (_normal linked)          joinRule :: Yaml.Rule         joinRule =@@ -181,12 +184,19 @@         world :: Expression         world = ExFormation [BiTau (AtLabel "qwj") (ExFormation [BiDelta (BtOne "7C")]), BiVoid AtRho]     it "writes Φ for the whole program the context stands in" $ do-      (mapM (buildExpressionThrows (ExMeta "e2")) =<< matchExpressionWithRule world namingRule (RuleContext buildTerm (Just world)))+      (mapM (buildExpressionThrows (ExMeta "e2")) =<< matchExpressionWithRule world namingRule (RuleContext buildTerm (Just world) (_normal linked)))         `shouldReturn` [ExRoot]     it "writes the formation itself where the context knows no universe" $ do-      (mapM (buildExpressionThrows (ExMeta "e2")) =<< matchExpressionWithRule world namingRule (RuleContext buildTerm Nothing))+      (mapM (buildExpressionThrows (ExMeta "e2")) =<< matchExpressionWithRule world namingRule (RuleContext buildTerm Nothing (_normal linked)))         `shouldReturn` [world] +  describe "normalHeld" $ do+    it "tells no meta a term holds a normal form" $+      normalHeld (const True) (ExMeta "qd") `shouldBe` False+    it "tells no slot a term holds a normal form" $+      normalHeld (const True) (ExAny (Slot "n" 7)) `shouldBe` False+    it "asks the test about a term that is no meta" $+      normalHeld (== ExDispatch ExXi (AtLabel "wv")) (ExDispatch ExXi (AtLabel "wv")) `shouldBe` True   describe "redex" $ do     it "takes every normalization rule for a redex" $       all redex Yaml.normalizationRules `shouldBe` True@@ -206,7 +216,7 @@           , "⟦ x ↦ ∅, dd ↦ ⟦ λ ⤍ L_dd, ρ ↦ ∅ ⟧, m1 ↦ ⟦ b ↦ ∅, φ ↦ ξ.ρ.dd( b ↦ ξ.b ), ρ ↦ ∅ ⟧ ⟧"           ]         context :: RuleContext-        context = RuleContext buildTerm Nothing+        context = RuleContext buildTerm Nothing (_normal linked)         matches :: Expression -> Yaml.Rule -> IO [Subst]         matches term rule = maybe pure (\cond substs -> meetCondition cond substs context) rule.when (matchExpressionDeep rule.pattern term)     it "takes every sample for inert" $ do

@@ -6,8 +6,8 @@ module TauSpec where  import AST-import Control.Monad (forM_, replicateM)-import Tau (freshTau, seedTaus)+import Control.Monad (forM_, join, replicateM)+import Tau (freshTau, seedTaus, tausOf) import Test.Hspec (Spec, describe, it, shouldBe)  spec :: Spec@@ -40,3 +40,17 @@         name <- freshTau         name `shouldBe` "a🌵1"     )+  it "mints names carrying the entry they were minted for" $ do+    seedTaus (ExFormation [])+    mint <- tausOf 7+    names <- replicateM 3 mint+    names `shouldBe` ["a🌵7-0", "a🌵7-1", "a🌵7-2"]+  it "skips the names of an entry the document already took" $ do+    seedTaus (ExFormation [BiTau (AtLabel "a🌵4-0") ExRoot, BiTau (AtLabel "a🌵4-1") ExXi])+    name <- join (tausOf 4)+    name `shouldBe` "a🌵4-2"+  it "does not move the cursor the run mints its own names with" $ do+    seedTaus (ExFormation [])+    _ <- tausOf 2 >>= \mint -> replicateM 5 mint+    name <- freshTau+    name `shouldBe` "a🌵0"