diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -34,1013 +34,1433 @@ ```bash cabal update -cabal install --overwrite-policy=always phino-0.0.132 -phino --version -``` - -Or download binary from the internet using [curl](https://curl.se/) or -[wget](https://en.wikipedia.org/wiki/Wget): - -```bash -sudo curl -o /usr/local/bin/phino http://phino.objectionary.com/releases/macos-15/phino-latest -sudo chmod +x /usr/local/bin/phino -phino --version -``` - -Download paths are: - -* Ubuntu 22.04: -* Ubuntu 24.04: -* MacOS (ARM): -* MacOS (Intel): -* Windows: - -## Build - -To build `phino` from source, clone this repository: - -```bash -git clone git@github.com:objectionary/phino.git -cd phino -``` - -Then, run the following command (ensure you have [Cabal][cabal] installed): - -```bash -cabal build all -``` - -Next, run this command to install `phino` system-wide: - -```bash -sudo cp "$(cabal list-bin phino)" /usr/local/bin/phino -``` - -Verify that `phino` is installed correctly: - -```bash -$ phino --version -0.0.0 -``` - -You can ensure scripts are run with a specific version of `phino` using -the `--pin` global option. It exits with an error when the version supplied -doesn't match the installed one: - -```bash -phino --pin=0.0.0.67 dataize hello.phi -``` - -## Dataize - -Then, you dataize the expression: - -```bash -$ phino dataize hello.phi -68-65-6C-6C-6F -``` - -### Atoms - -Which Ξ» functions exist is a property of the object model being dataized, not -of the calculus, so `phino` implements none of them. They come from a JSON -registry given with `--atoms`, keyed by regular expressions over Ξ» names: - -```json -{ - "L_number_plus": { - "rt": "node", - "script": "const readline = require('readline'); ..." - } -} -``` - -The `rt` field names the interpreter the `script` is run under. Only `node` is -supported for now; a registry naming any other interpreter is refused when the -file is read, before dataization starts. - -When 𝔼 reaches a Ξ» function the registry carries, `phino` writes its `script` -to a temporary file and runs it as a POSIX process under that interpreter: - -```text -node /tmp/phino-atom-4f2a.js -``` - -An atom that is already a program needs no interpreter and no staging. Such an -entry says `exec` and gives a `path` instead of a `script`: - -```json -{ - "L_number_plus": { - "rt": "exec", - "path": "/opt/eo/atoms/number-plus" - } -} -``` - -`phino` spawns that file directly, as the executable binary it is, with no -arguments. A `path` that names no file, or a file nobody may run, is refused -where the registry is read, together with the unknown runtimes. - -Whichever way it is run, the program is talked to over `stdin` and `stdout`, -one JSON object per line, in the letters of the evaluation rule of the -[πœ‘-calculus paper](https://github.com/objectionary/calculus-paper), -𝔼(𝑏, 𝑒, 𝑠) = 𝑛, where 𝑏 is the formation, 𝑒 the universe and 𝑛 the normal -form the atom answers with: - -```text -{"𝑒": "⟦ bytes ↦ ⟦ … ⟧, number ↦ ⟦ … ⟧, Ο† ↦ … ⟧"} -{"id": 1, "Ξ»": "L_number_plus", "𝑏": "⟦ x ↦ Ξ¦.number( … ), ρ ↦ ⟦ … ⟧ ⟧"} -{"id": 1, "𝑛": "11"} -``` - -The first two lines are `phino`'s, the third is the program's. The universe Ξ¦ -goes under `𝑒`, in a line of its own, before the first request. Then comes the -request: an `id`, the Ξ» name under `Ξ»` β€” one program may be registered under -several names and branch on it β€” and, under `𝑏`, the formation being -evaluated, with its Ξ» binding removed. Both payloads are canonical πœ‘-calculus -on a single line β€” no syntax sugar, whatever `--sweet` says about the output of -the run β€” so a program never has to know about `phino`'s sugar in order to find -a datum: every byte array is spelled out as a Ξ” binding. - -The program answers with one line carrying the same `id` and, under `𝑛`, the -πœ‘-expression the atom answers with, in any syntax `phino`'s parser reads β€” -syntax sugar included, so the `11` above and the `Ξ¦.number( … )` it stands for -are the same answer. `phino` parses it back and hands it to 𝔼 as the atom's -raw result, normalizing it exactly as it normalizes anything else, so -`--evaluations`, `--partial` and `--max-steps` keep working unchanged. - -A program started for the fire is asked one request, always `id` 1, and its -`stdin` is closed behind it, so it may read its input whole or line by line, as -it pleases. It is waited for once it has answered, and a non-zero exit fails -the run. So does a reply that is not JSON, carries neither `𝑛`, nor `ask`, nor -`of` with `attr` (the next section is about the questions), answers another -`id`, or an `𝑛` that does not parse, or a program that quits without answering -β€” always with the program's own `stderr` in the message. - -Each key of the registry is a regular expression, and it must match the whole -Ξ» name, so a plain name such as `L_number_plus` means that one atom and nothing -else, while `L_number_.*` stands for every atom of `number`. When 𝔼 reaches a -Ξ» function, the keys are tried top to bottom, in the order the file lists them, -and the first one that matches is the entry fired, so a key placed above -another hides whatever the two have in common. A key that is not a regular -expression is refused where the registry is read. - -A Ξ» name no key matches has no Ξ» function at all, so 𝔼 gets stuck on it. -Without `--atoms` the registry is empty and every atom gets stuck. - -One process per fire is where a program that is slow to start β€” a JVM, say β€” -spends most of the run. An entry saying `serve` has `phino` start its program -once, on the first fire, and keep it for the rest of the run, whether it is a -`script` or a `path`. Together with a key that matches many names, this is how -one program stands for a whole object model without being spelled once per -atom: - -```json -{ - "L_bytes_eq": { - "rt": "node", - "script": "const readline = require('readline'); ..." - }, - ".*": { - "rt": "exec", - "path": "/opt/eo/atoms/resident", - "serve": true - } -} -``` - -Every Ξ» name registered on the same program, under one key or under several, -is served by the same process, so there is one of it, however many atoms it -stands for. The lines are the same: -the program reads request after request off its `stdin`, each with the next -`id`, and answers each in turn. The universe is told again only when a fire -comes with a different one; the program keeps the last one it was told. When -the run is over, whatever it ended with, `phino` closes the program's `stdin`, -which is its cue to quit, and terminates it if it has not quit within a second. - -### Reducing the operands of an atom - -An operand reaches a program as it was written: `5.plus( 6.plus( 7 ) )` fires -`L_number_plus` with `x ↦ Ξ¦.number( … ).plus( … )`, and getting a number out of -that is dataization, which is `phino`'s business and not a program's. So the -program asks, and it may ask by name. A line of its own carries an `id` it -mints and the `of` of the request being served, plus one of that receiver's -attributes under `attr`; `phino` answers with that `id` and the result under -`𝑛`, taking the value straight out of the receiver it still holds for the -request β€” neither side ever re-prints or re-parses it: - -```text -{"𝑒": "⟦ bytes ↦ ⟦ … ⟧, number ↦ ⟦ … ⟧, Ο† ↦ … ⟧"} -{"id": 1, "Ξ»": "L_number_plus", "𝑏": "⟦ x ↦ Ξ¦.number( … ).plus( … ) ⟧"} -{"id": 7, "of": 1, "attr": "ρ", "reduce": true} -{"id": 7, "𝑛": "⟦ Ξ” ‍ 40-14-00-00-00-00-00-00 ⟧", "Ξ”": "40-14-00-00-00-00-00-00"} -{"id": 8, "of": 1, "attr": "x", "reduce": true} -{"id": 8, "𝑛": "⟦ Ξ” ‍ 40-2A-00-00-00-00-00-00 ⟧", "Ξ”": "40-2A-00-00-00-00-00-00"} -{"id": 1, "𝑛": "Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ” ‍ 40-32-00-00-00-00-00-00 ⟧ ) )"} -``` - -The universe, the request and the two answers are `phino`'s; the two questions -and the last line are the program's. A question mints an `id` of its own, -which `phino` echoes, so a program may keep several of them open and still -tell the answers apart. Without `reduce` β€” or with it saying `false` β€” the -answer is the node the attribute carries, as it was written; with `"reduce": -true` it is the dataization of that node. A question about an `of` whose -request is no longer in flight, or an `attr` the receiver does not carry, -fails the fire. An `attr` bound to nothing at all does not: a void attribute -is a fact about the receiver, and the answer is `{"id": 7, "βˆ…": true}`, with -no node in it, so a program may ask whether an operand is bound. - -An `attr` may also go deeper than one name. It is a path down the receiver, -read left to right and split on the dot, which no attribute of πœ‘-calculus -carries in its own name: - -```text -{"id": 9, "of": 1, "attr": "ρ.length", "reduce": true} -{"id": 9, "𝑛": "⟦ Ξ” ‍ 40-08-00-00-00-00-00-00 ⟧", "Ξ”": "40-08-00-00-00-00-00-00"} -``` - -Every segment but the last has to name a formation or an application to go on -into, and `reduce` applies to the node the path ends at. An argument binds an -attribute the way a Ο„ binding does, so `x.if.guard` reaches the `guard` of -`x ↦ Ξ¦.bool( if ↦ ⟦ guard ↦ … ⟧ )`, and it binds it from the outside, so an -argument wins over the void it fills. A positional argument names nothing and -the walk goes past it. A segment nothing carries, or one that runs into a void -attribute, fails the fire the same way a missing `attr` does. `phino` holds the -receiver whole, so there is no depth a program has to re-parse an answer to -reach. - -What the answered node is, `phino` says next to it, because the shape of an -answer is `phino`'s knowledge and not the program's. A formation carrying a Ξ” -binding carries its byte array under `Ξ”`, and one carrying a Ξ» binding the name -of the function it is stuck on under `Ξ»`, so a program tells a datum from a -stuck atom by reading the JSON and never has to parse πœ‘. Mind the `Ξ»` there: a -line of `phino`'s is a request when it carries `𝑏` and an answer when it does -not. - -An answer that is an application rather than a formation says under `Ξ¦.` the -chain it is dispatched off Ξ¦ by: - -```text -{"id": 9, "of": 1, "attr": "x"} -{"id": 9, "𝑛": "Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ” ‍ 40-08-… ⟧ ) )", "Ξ¦.": "number"} -``` - -That name is the only place the forma of a typed literal lives, since -πœ‘-calculus types nothing nominally: `Ξ¦.true` says `true`, -`Ξ¦.tuple( length ↦ …, head ↦ …, tail ↦ … )` says `tuple`, and a chain spelled -in full says `org.eolang.number`. Dataize the same operand instead and the -forma is gone, because `Ξ”` is all that is left of a number taken apart. A -chain with an application inside it, such as `Ξ¦.number( … ).plus( … )`, -dispatches off a term `phino` would have to dataize to name, so it names no -forma and nothing is said. - -The other way to ask quotes the πœ‘-expression itself, under `ask`; `phino` -serves such a question by binding it to a fresh synthetic attribute of the -universe, normalizing it there and dataizing it β€” the same trick `--inside` -plays β€” so the answer is a byte formation and the program reads its `Ξ”`; where -an atom on the way cannot fire and `--partial` parks it, the answer is the -residual program instead. A quoted question is fine for terms the program -assembled itself; a question that quotes a receiver is not, because the -receiver carries its `ρ` and the receiver of that carries its own, all the way -to the universe: three levels of nesting turn a question of a few hundred -bytes into one of megabytes. A program kept for the run therefore gets a lean -`𝑏`, and every answer `phino` sends it is lean too: canonical πœ‘-calculus -without any ρ chain, because such a program can always ask for what the chain -holds β€” by name, cheaply, or by `ask`. - -Serving a question re-enters the evaluator, so a question may cost a fire of -the very atom that asked it. That request arrives while the question is still -open, which is why a program that asks reads on instead of waiting for one -line. The step budget of the run, `--max-steps`, bounds the nesting. - -Only a program kept for the run may ask. `phino` closes the `stdin` of a -program started for the fire behind its request, since such a program may read -its input whole before it answers, so there is nothing left to answer a -question over, and one that asks anyway fails the fire β€” which is also why the -lean `𝑏` is tied to `serve` and not to a flag of its own: a program that is -handed the whole receiver cannot ask for what it left out. - -So a `serve` entry of `L_number_plus` that has `phino` reduce its operands -reads like this: - -```js -const readline = require('readline'); -const open = new Map(); -let minted = 0; -const said = (message) => process.stdout.write(`${JSON.stringify(message)}\n`); -const number = (answer) => Buffer - .from(answer['Ξ”'].replace(/-/g, ''), 'hex') - .readDoubleBE(0); -const hex = (value) => { - const bytes = Buffer.alloc(8); - bytes.writeDoubleBE(value); - return [...bytes] - .map((octet) => octet.toString(16).toUpperCase().padStart(2, '0')) - .join('-'); -}; -function* plus(request) { - const rho = number(yield {of: request, attr: 'ρ', reduce: true}); - const x = number(yield {of: request, attr: 'x', reduce: true}); - return `Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ” ‍ ${hex(rho + x)} ⟧ ) )`; -} -const advance = (atom, id, answer) => { - const step = atom.next(answer); - if (step.done) { - said({ id, '𝑛': step.value }); - return; - } - minted += 1; - open.set(minted, { atom, id }); - said({ id: minted, ...step.value }); -}; -readline.createInterface({ input: process.stdin }).on('line', (line) => { - const message = JSON.parse(line); - if ('𝑏' in message) { - advance(plus(message.id), message.id, undefined); - } else if (open.has(message.id)) { - const waiting = open.get(message.id); - open.delete(message.id); - advance(waiting.atom, waiting.id, message); - } -}); -``` - -Every request is a coroutine there, so a question suspends the request that -asked it rather than the program: whatever `phino` says next, the answer or -another request, is served on the spot. - -A program may run a `phino` of its own instead of asking, and the `--inside` -option is how it does that: the expression it names is bound to a fresh -synthetic attribute of the input expression, which the run takes as the -universe, normalized there, and then dataized. - -```bash -$ phino dataize --atoms=atoms.json --inside='5.plus( 6 )' universe.phi -40-26-00-00-00-00-00-00 -``` - -Here `universe.phi` is the πœ‘-program the atom is being fired inside β€” the very -text the program was told under `𝑒`, which it feeds back on `stdin`. That costs -a process and a re-parse of the whole universe per operand, which is what the -`ask` line is for. - -The `--inside` option cannot be combined with `--locator`, since it aims the -run at the binding it mints itself. Both `dataize` and `morph` take `--atoms` -and `--inside`. - -### Recording what fired - -Every atom fired on the way to the bytes may be recorded in a machine-readable -protocol, with the `--evaluations` option. One firing is one line of three -tab-separated fields: the name of the Ξ» function, the formation it was applied -to, and the expression it returned: - -```bash -$ cat sum.phi -⟦ - bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, - number ↦ ⟦ Ο† ↦ βˆ…, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧, - Ο† ↦ 5.plus( 6 ) -⟧ -$ phino dataize --atoms=atoms.json --evaluations=atoms.tsv --quiet \ - --sweet --hide-rho sum.phi -$ cat -T atoms.tsv -L_number_plus^I⟦ x ↦ 6 ⟧^I11 -``` - -Records follow the syntax of the other options, such as `--sweet` and -`--hide-rho`, but always stay on one line. The file is truncated at the -beginning of every run, and `--output=phi` is the only output format it -works with, since one record must fit into one line. - -### Partial evaluation - -An atom that cannot fire fails the run: its Ξ» function is not in the registry -given with `--atoms`. This is what happens when an operation is deliberately -left unimplemented β€” a data input replaced by a placeholder formation such as -`⟦ Ξ» ‍ Sym_arg_0 ⟧`, or an operation whose answer is not known yet. With -`--partial`, dataization becomes partial evaluation instead: what the known -inputs decide is computed, the rest survives as the residual program, which is -printed in place of the bytes, and the run ends successfully: - -```bash -$ cat partial.phi -⟦ - bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, - number ↦ ⟦ - Ο† ↦ βˆ…, - plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, - times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧, - as-bool ↦ ⟦ Ξ» ‍ L_number_as_bool ⟧ - ⟧, - Ο† ↦ 2.times( 3 ).plus( 4 ).as-bool -⟧ -$ phino dataize --atoms=atoms.json --partial --sweet --hide-rho partial.phi -⟦ Ξ» ‍ L_number_as_bool ⟧ -``` - -Here `2.times( 3 ).plus( 4 )` was decided by the atoms the registry carries, so -it was computed (its result, `10`, sits in the hidden `ρ` of the residual -program), while `as-bool` names a Ξ» function no script answers for, so it stays -in place as a normal-form subterm. Each such stuck site also lands in the -`--evaluations` file, as a record with the first two fields only, since there is -no result to report: - -```bash -$ phino dataize --atoms=atoms.json --partial --evaluations=atoms.tsv --quiet \ - --sweet --hide-rho partial.phi -$ cat -T atoms.tsv -L_number_times^I⟦ x ↦ 3 ⟧^I6 -L_number_plus^I⟦ x ↦ 4 ⟧^I10 -L_number_as_bool^I⟦⟧ -``` - -Evaluation stays demand-driven, as the calculus prescribes: an argument -that nothing asked for before the run got stuck is left as it is in the -residual program, for the next iteration. - -The nested morphing and dataization recursion is bounded by the -`--max-steps` option (default `1000`): when the budget is exhausted, the run -fails with `Dataization did not finish before reaching the limit of steps`. -This guards against non-terminating terms, which used to loop forever before -the bound was introduced: - -```bash -$ phino dataize --max-steps=50 problem.phi -[ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=50 -``` - -## Morph - -Dataization insists on bytes. Morphing 𝕄 asks a different question: evaluate -as far as the object model allows, without demanding data. It resolves Ξ¦ -against the universe, peels dispatches and applications through -normalization, fires whichever atoms sit under a dispatch, and stops at the -first formation it reaches, handing that formation back untouched. The -`morph` command runs 𝕄 on its own: - -```bash -$ cat two.phi -⟦ - bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, - number ↦ ⟦ Ο† ↦ βˆ…, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧, - Ο† ↦ 5.plus( 6 ).plus( 7 ) -⟧ -$ phino dataize --atoms=atoms.json --sweet --hide-rho two.phi -40-32-00-00-00-00-00-00 -$ phino morph --atoms=atoms.json --locator=Q.Ο† --sweet --hide-rho two.phi -⟦ x ↦ 7, Ξ» ‍ L_number_plus ⟧ -``` - -The inner `5.plus( 6 )` fires, because `.plus` is dispatched on its result, -and `11` lands in the `ρ` hidden by `--hide-rho`. The outer application is -saturated but bare, so 𝕄 returns it and is finished; firing it is -dataization's job and takes `dataize` on to `18`. - -The default locator `Q` morphs the whole top formation, which 𝕄 returns -unchanged, so `--locator` is how one aims 𝕄 at a subterm, exactly as in -`dataize`. Unlike 𝔻, 𝕄 is total: where no formation is reachable the answer -is the terminator `βŠ₯`, printed rather than reported as a failed run: - -```bash -$ phino morph --locator=Q.x <<< '⟦ x ↦ ΞΎ ⟧' -βŠ₯ -``` - -The whole `dataize` option surface applies unchanged β€” `--atoms`, `--inside`, -`--sequence`, `--headers`, `--steps-dir`, `--evaluations`, `--partial`, -`--max-steps`, `--shuffle`/`--seed`, `--output`, `--focus` and the rest. - -### Deep morphing - -𝕄 stops at the first formation it reaches and hands its bindings back as they -were written, since firing a bare Ξ» is dataization's job, and `dataize` -follows the one path dataization demands and ends in bytes. What a program -holds but nothing demands β€” the argument of an atom the registry does not -serve, for one β€” is therefore reduced by neither. The `--deep` flag enters it: - -```bash -$ cat gap.phi -⟦ - bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, - number ↦ ⟦ Ο† ↦ βˆ…, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧, - bar(x) ↦ ⟦ Ξ» ‍ L_bar ⟧, - demo ↦ ⟦ foo ↦ ⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( ΞΎ.n.times( 5 ).times( 7 ) ) ⟧ ⟧ -⟧ -$ phino morph --atoms=atoms.json --inside='Q.demo.foo' \ - --sweet --hide-rho gap.phi -⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( n.times( 5 ).times( 7 ) ) ⟧ -$ phino morph --deep --atoms=atoms.json --inside='Q.demo.foo' \ - --sweet --hide-rho gap.phi -⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( 105 ) ⟧ -``` - -Every binding of the formation is entered, recursively. 𝕄 is asked about the -term standing there and, where it lands on a saturated formation whose Ξ» the -registry serves, that Ξ» is fired and 𝕄 is asked about the answer again. A term -on whose way an atom fired is replaced by the answer of the last firing, which -is the πœ‘-program the atom wrote rather than the normal form of it, so `105` -stands where the arithmetic stood. A term no atom touched stays exactly as it -was written and only its own parts are walked, so `Ξ¦.bar` keeps its name and -what comes back is still the same program, reduced as far as the registry -allows. The step joins the chain under the name `deep`, so `--sequence` shows -it, and `--max-steps` bounds the walk. - -Two things are left alone. A Ξ» the registry does not serve is not fired at -all, so `--deep` stays as total as 𝕄 itself and needs no `--partial`; an atom -that gets stuck deeper on a spine still fails the run, and `--partial` parks -it, leaving that term as it was written. A formation still holding a void -binding is not fired either: the void is an argument the program has not given -yet, so `times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧` is a method waiting to be applied, -not an application waiting to be computed. Walking the whole program therefore -folds what it can and leaves the object model as it was declared: - -```bash -$ phino morph --deep --atoms=atoms.json --sweet --hide-rho gap.phi -⟦ - bytes(Ο†) ↦ ⟦⟧, - number(Ο†) ↦ ⟦ times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧, - bar(x) ↦ ⟦ Ξ» ‍ L_bar ⟧, - demo ↦ ⟦ foo ↦ ⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( 105 ) ⟧ ⟧ -⟧ -``` - -## Rewrite - -You can rewrite this expression with the help of [rules](#rule-structure) -defined in the `my-rule.yml` YAML file (here, the `!d` is a capturing group, -similar to regular expressions): - -```yaml -name: My custom rule -pattern: Ξ” ‍ !d -result: Ξ” ‍ 62-79-65 -``` - -Then, rewrite: - -```bash -$ phino rewrite --rule=my-rule.yml hello.phi -⟦ Ο† ↦ ⟦ Ξ” ‍ 62-79-65 ⟧, t ↦ ΞΎ.k, k ↦ ⟦⟧ ⟧ -``` - -If you want to use many rules, just use `--rule` as many times as you need: - -```bash -phino rewrite --rule=rule1.yaml --rule=rule2.yaml ... -``` - -You can also use [built-in rules](resources), which are designed -to normalize expressions: - -```bash -phino rewrite --normalize hello.phi -``` - -Both flags may be combined, so that your own rules are applied -alongside the built-in ones, in a single rewriting session: - -```bash -phino rewrite --normalize --rule=my-rule.yaml hello.phi -``` - -Some rules mint fresh synthetic names via the `random-string` built-in. To -keep the output reproducible across runs, `phino` seeds the random generator -deterministically with `0` by default. Use `--seed` to pick a different seed: - -```bash -phino rewrite --seed=42 --rule=my-rule.yml hello.phi -``` - -If no input file is provided, the πœ‘-expression is taken from `stdin`: - -```bash -$ echo '⟦ Ο† ↦ ⟦ Ξ” ‍ 68-65-6C-6C-6F ⟧ ⟧' | phino rewrite --rule=my-rule.yml -⟦ Ο† ↦ ⟦ Ξ” ‍ 62-79-65 ⟧ ⟧ -``` - -You're able to pass [`XMIR`][xmir] as input. Use `--input=xmir` and `phino` -will parse given `XMIR` from file or `stdin` and convert it to `phi` AST. - -```bash -phino rewrite --rule=my-rule.yaml --input=xmir file.xmir -``` - -Also `phino` supports πœ‘-expressions in -[ASCII](https://en.wikipedia.org/wiki/ASCII) format and with -syntax sugar. The `rewrite` command also allows you to desugar the expression -and print it in canonical syntax: - -```bash -$ echo '[[ @ -> Q.io.stdout("hello") ]]' | phino rewrite -⟦ - Ο† ↦ Ξ¦.io.stdout( - Ξ±0 ↦ Ξ¦.string( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ” ‍ 68-65-6C-6C-6F, ρ ↦ βˆ… ⟧ ) ) - ), - ρ ↦ βˆ… -⟧ -``` - -## Merge - -You can merge several πœ‘-expressions into a single one by merging their -top level formations: - -```bash -$ cat bytes.phi -⟦ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧ ⟧ -$ cat number.phi -⟦ - number ↦ ⟦ - Ο† ↦ βˆ…, - plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ - ⟧ -⟧ -$ cat minus.phi -⟦ number ↦ ⟦ minus(x) ↦ ⟦ Ξ» ‍ L_number_minus ⟧ ⟧ ⟧ -$ phino merge bytes.phi number.phi minus.phi --sweet -⟦ - bytes(Ο†) ↦ ⟦⟧, - number(Ο†) ↦ ⟦ - plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, - minus(x) ↦ ⟦ Ξ» ‍ L_number_minus ⟧ - ⟧ -⟧ -``` - -## Match - -You can test the πœ‘-expression matches against the [rule](#rule-structure) -pattern. The result output contains matched substitutions: - -```bash -$ phino match --pattern='⟦ Ξ” ‍ !d, !B ⟧' hello.phi -B >> ⟦ ρ ↦ βˆ… ⟧ -d >> 68-65-6C-6C-6F -``` - -## Explain - -You can _explain_ the built-in rules by printing them in [LaTeX][latex] -format. Pass exactly one of `--normalize`, `--morph`, `--dataize` or -`--contextualize` for the rewriting, morphing (𝕄), dataization (𝔻) or -contextualization (π’ž) rules (or `--rule` for a custom rule file): - -```bash -$ phino explain --normalize -\begin{tabular}{rl} -\phinoNormalizationRule{alpha} - { [[ B_1, \tau -> ?, B_2 ]] ( \phiTerminal{\alpha_{i}} -> e ) } - { [[ B_1, \tau -> ?, B_2 ]] ( \tau -> e ) } - { $ i = \vert \overline{ B_1 } \vert $ } - { } -\phinoNormalizationRule{dc} - { T ( \tau -> e ) } - { T } - { } - { } -... -\phinoNormalizationRule{stop} - { [[ B ]] . \tau } - { T } - { $ \tau \notin B \;\text{and}\; @ \notin B \;\text{and}\; L \notin B $ } - { } -\end{tabular} -``` - -The morphing and dataization rules are printed the same way: - -```bash -$ phino explain --morph -\begin{tabular}{rl} -\phinoMorphingRule{mf} - { \mathbb{M}( [[ B ]], e ) } - { [[ B ]] } - { } - { } -... -\phinoMorphingRule{universe} - { \mathbb{M}( Q, e ) } - { \mathbb{M}( \phinoNormalize{ e }, e ) } - { $ e \not= Q $ } - { } -\end{tabular} -``` - -```bash -$ phino explain --dataize -\begin{tabular}{rl} -\phinoDataizationRule{delta} - { \phinoDataize{ [[ B_1, D> Ξ΄, B_2 ]] } } - { Ξ΄ } - { } - { } -... -\phinoDataizationRule{norm} - { \phinoDataize{ n } } - { \phinoDataize{ \mathbb{M}( n, e ) } } - { } - { } -\end{tabular} -``` - -```bash -$ phino explain --contextualize -\begin{phinoContextualizationInference} - \phinoName{cxi} - \phinoConclusion{ \phinoContextualize{ \phiTerminal{\xi} }{ k }{ k } } -\end{phinoContextualizationInference} -... -\begin{phinoContextualizationInference} - \phinoName{cd} - \phinoPremise{ \phinoContextualize{ n }{ k }{ n_1 } } - \phinoConclusion{ \phinoContextualize{ n . \tau }{ k }{ n_1 . \tau } } -\end{phinoContextualizationInference} -``` - -For more details, use `phino [COMMAND] --help` option. - -## Rule structure - -This is BNF-like yaml rule structure. Here types ended with -apostrophe, like `Attribute'` are built types from πœ‘-expression [AST](src/AST.hs) - -```bnfc -Rule: - name: String - pattern: String - result: String - when: Condition? # predicate, works with substitutions before extension - where: [Extension]? # substitution extensions - having: Condition? # predicate, works with substitutions after extension - -Condition: - = and: [Condition] # logical AND - | or: [Condition] # logical OR - | not: Condition # logical NOT - | eq: # compare two comparable objects - - Comparable - - Comparable - | in: # check if attributes exist in bindings - - Attribute' - - Binding' - | nf: Expression' # returns True if given expression in normal form - # which means that no more other normalization rules - # can be applied - | absolute: Expression' # returns True if given expression is xi-free, i.e. - # there is no ΞΎ outside of a formation: it is Ξ¦, a - # formation, a dispatch with a xi-free subject, or an - # application with a xi-free subject and argument. - # Combined with a normal-form check by the 'π‘˜'/'!k' - # meta variable, which ranges over the absolute - # expressions 𝒦 βŠ† 𝒩, used by the Rcopy rule. - | matches: # returns True if given expression after dataization - - String # matches to given regex - - Expression - | part-of: # returns True if given expression is attached to any - - Expression' # attribute in ginve bindings - - BiMeta' - | formation: # returns True if given expression is a formation - Expression' # (an abstraction βŸ¦β€¦βŸ§); used by morphing 'md' - # as 'not (formation 𝑛)', so a non-formation head is - # morphed and a formation head is left to 'ml' - | gt: # returns True if the first comparable object is - - Comparable # greater than the second one - - Comparable - | disjoint: # returns True if none of the given attributes exists - - [Attribute'] # in the given bindings - - Binding' - -Comparable: # comparable object that may be used in 'eq' condition - = Attribute' - | Number - | Expression' - -Number: # comparable number - = Integer # just regular integer - | IndexMeta' # 𝑖 (or !i), the index captured by an α𝑖 argument - | length: BiMeta' # calculate length of bindings by given meta binding - | domain: BiMeta' # calculate number of unique attributes in given - # meta binding (excluding 'assets') - -Extension: # substitutions extension used to introduce new meta variables - meta: [ExtArgument] # new introduced meta variable - function: String # name of the function - args: [ExtArgument] # arguments of the function - -ExtArgument - = Bytes' # !d - | Binding' # !B - | Expression' # !e - | Attribute' # !t -``` - -Here's list of functions that are supported for extensions: - -* `contextualize` - function of two arguments, that rewrites given expression - depending on provided context according to the contextualization - [rules](assets/contextualize.jpg) -* `random-tau` - creates attribute with random unique name. Accepts bindings, - and attributes. Ensures that created attribute is not present in list of - provided attributes and does not exist as attribute in provided bindings. -* `dataize` - dataizes given expression and returns bytes. -* `concat` - accepts bytes or dataizable expressions as arguments, - concatenates them into single sequence and convert it to expression - that can be pretty printed as human readable string: - `Ξ¦.string(Ξ¦.bytes⟦ Ξ” ‍ !d ⟧)`. -* `sed` - pattern replacer, works like unix `sed` function. - Accepts two arguments: target expression and pattern. - Pattern must start with `s/`, consists of three parts - separated by `/`, for example, this pattern `s/\\s+//g` - replaces all the spaces with empty string. To escape braces and slashes - in pattern and replacement parts - use them with `\\`, - e.g. `s/\\(.+\\)//g`. -* `random-string` - accepts dataizable expression or bytes as pattern. - Replaces `%x` and `%d` formatters with random hex numbers and - decimals accordingly. Uniqueness is guaranteed during one - execution of `phino`. -* `size` - accepts exactly one meta binding and returns size of it and - `Ξ¦.number`. -* `tau` - accepts `Ξ¦.string`, dataizes it and converts it to attribute. - If dataized string can't be converted to attribute - an error is thrown. -* `string` - accepts `Ξ¦.string` or `Ξ¦.number` or attribute and converts it - to `Ξ¦.string`. -* `number` - accepts `Ξ¦.string` and converts it `Ξ¦.number` -* `sum` - accepts list of `Ξ¦.number` or `Ξ¦.bytes` and returns sum of them as `Ξ¦.number` -* `join` - accepts list of bindings and returns list of joined bindings. Duplicated - `ρ`, `Ξ”` and `Ξ»` attributes are ignored, all other duplicated attributes are replaced - with unique attributes using `random-tau` function. - -## Meta variables - -The `phino` supports meta variables to write πœ‘-expression patterns for -capturing attributes, bindings, etc. - -This is the list of supported meta variables: - -* `!t` || `𝜏` - attribute -* `!i` || `𝑖` - the index of a positional (Ξ±) application argument, - captured by writing `α𝑖` (or `~!i`) -* `!e` || `𝑒` - any expression -* `!n` || `𝑛` - any expression that is already in normal form (behaves like - `!e`/`𝑒`, but only binds a sub-expression in NF, so no explicit - `nf:` guard is needed) -* `!k` || `π‘˜` - any expression that is absolute, i.e. xi-free and in normal - form (ranges over `𝒦 βŠ† 𝒩`); behaves like `!e`/`𝑒` but only - binds an absolute sub-expression, so no explicit `absolute:` - or `nf:` guard is needed -* `!B` || `𝐡` - list of bindings -* `!d` || `Ξ΄` - bytes in meta delta binding -* `!F` || `𝑓` - function name in meta lambda binding - -A meta variable carries a suffix, like `!B1` or `𝜏0`, to name what it -captured, so that the `result`, `when`, `where` and `having` of a rule can -read it back. - -Written bare, with no suffix at all, a meta variable is anonymous: it matches -whatever term stands in its place, every occurrence on its own, and binds no -name. Two anonymous metas of one kind are therefore two different captures, -which is what lets a pattern ask for any two attributes without inventing -names for them: - -```yaml -name: two-attributes -pattern: '⟦ 𝜏 ↦ 𝑒, 𝜏 ↦ 𝑒 ⟧' -result: '⟦ x ↦ ⟦ Ξ” ‍ 2A- ⟧ ⟧' -``` - -Spelled with suffixes, that pattern would read `⟦ 𝜏1 ↦ 𝑒1, 𝜏2 ↦ 𝑒2 ⟧` and -name four captures the result never mentions, while `⟦ 𝜏1 ↦ 𝑒1, 𝜏1 ↦ 𝑒1 ⟧` -would be rejected as a duplicated attribute. - -Nothing can refer to an anonymous meta, since it has no name to be referred to -by. Writing one outside a `pattern` (or the `match`, `e-match` and `c-match` of -an inference rule) is a mistake in the rule and is reported as the rule loads. - -A positional (Ξ±) application argument is written as `Ξ±0`, `~0` (ASCII), or -`α𝑖`/`~!i` when its index is captured by an `!i`/`𝑖` meta variable. - -Incorrect usage of meta variables in πœ‘-expression patterns leads to -parsing errors. - -## Benchmark - -To run performance benchmarks, you need [Java 8+][java] and [curl][curl]. -Maven is downloaded automatically on first run via `benchmark/mvnw`. - -The benchmark uses the compiled [`Native`][jna-native] class from -[JNA][jna] β€” a large real-world Java class β€” as its test input. -On first run, `make bench` downloads the class, disassembles it to -[XMIR][xmir] via [jeo-maven-plugin][jeo], converts it to πœ‘ using -`phino rewrite`, and caches the results in `benchmark/tmp/`. -Subsequent runs skip straight to the benchmarks. - -```bash -make bench -``` - - - -```text -=== parse/phi === - warmup: 3 iterations - batches: 10 x 1 - total: 1333129.634 ΞΌs - avg: 133312.963 ΞΌs - min: 123350.827 ΞΌs - max: 154501.079 ΞΌs - std dev: 11819.397 ΞΌs -=== parse/xmir === - warmup: 3 iterations - batches: 10 x 1 - total: 6095344.927 ΞΌs - avg: 609534.493 ΞΌs - min: 552583.460 ΞΌs - max: 644040.036 ΞΌs - std dev: 25360.610 ΞΌs -=== rewrite/normalize === - warmup: 3 iterations - batches: 10 x 1 - total: 562461.372 ΞΌs - avg: 56246.137 ΞΌs - min: 54840.174 ΞΌs - max: 57549.116 ΞΌs - std dev: 778.435 ΞΌs -=== print/sweet/multiline === - warmup: 3 iterations - batches: 10 x 1 - total: 2804710.586 ΞΌs - avg: 280471.059 ΞΌs - min: 263431.677 ΞΌs - max: 306476.931 ΞΌs - std dev: 12002.611 ΞΌs -=== print/sweet/flat === - warmup: 3 iterations - batches: 10 x 1 - total: 2784962.131 ΞΌs - avg: 278496.213 ΞΌs - min: 264622.121 ΞΌs - max: 291750.726 ΞΌs - std dev: 10124.274 ΞΌs -=== print/salty/multiline === - warmup: 3 iterations - batches: 10 x 1 - total: 9124364.174 ΞΌs - avg: 912436.417 ΞΌs - min: 892913.298 ΞΌs - max: 935173.006 ΞΌs - std dev: 15007.336 ΞΌs -``` - -The results were calculated in [this GHA job][benchmark-gha] -on 2026-09-14 at 19:01, -on Linux with 4 CPUs. - - - -## How to Contribute - -Fork repository, make changes, then send us a [pull request][guidelines]. -We will review your changes and apply them to the `master` branch shortly, -provided they don't violate our quality standards. To avoid frustration, -before sending us your pull request please make sure all your tests pass: - -```bash -make all -``` - -To generate a local coverage report for development, run: - -```bash -make coverage -``` - -To build a `phino` executable into the root of the repository, run: - -```bash -make phino -``` - -This produces an executable `phino` (or `phino.exe` on Windows) in the -project root, which you can run directly for quick local testing: - -```bash -./phino --version -``` - -You will need [GHC β‰₯ 9.6.7][GHC] and [Cabal β‰₯ 3.0 (recommended)][cabal] -or [Stack β‰₯ 3.0][stack] installed. - -[cabal]: https://www.haskell.org/cabal/ -[stack]: https://docs.haskellstack.org/en/stable/install_and_upgrade/ -[GHC]: https://www.haskell.org/ghc/ -[guidelines]: https://www.yegor256.com/2014/04/15/github-guidelines.html -[xmir]: https://news.eolang.org/2022-11-25-xmir-guide.html -[latex]: https://en.wikipedia.org/wiki/LaTeX -[java]: https://www.java.com/en/download/ -[curl]: https://curl.se/ -[jna]: https://github.com/java-native-access/jna -[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 -[benchmark-gha]: https://github.com/objectionary/phino/actions/runs/34883926782 +cabal install --overwrite-policy=always phino-0.0.133 +phino --version +``` + +Or download binary from the internet using [curl](https://curl.se/) or +[wget](https://en.wikipedia.org/wiki/Wget): + +```bash +sudo curl -o /usr/local/bin/phino http://phino.objectionary.com/releases/macos-15/phino-latest +sudo chmod +x /usr/local/bin/phino +phino --version +``` + +Download paths are: + +* Ubuntu 22.04: +* Ubuntu 24.04: +* MacOS (ARM): +* MacOS (Intel): +* Windows: + +## Build + +To build `phino` from source, clone this repository: + +```bash +git clone git@github.com:objectionary/phino.git +cd phino +``` + +Then, run the following command (ensure you have [Cabal][cabal] installed): + +```bash +cabal build all +``` + +Next, run this command to install `phino` system-wide: + +```bash +sudo cp "$(cabal list-bin phino)" /usr/local/bin/phino +``` + +Verify that `phino` is installed correctly: + +```bash +$ phino --version +0.0.0 +``` + +You can ensure scripts are run with a specific version of `phino` using +the `--pin` global option. It exits with an error when the version supplied +doesn't match the installed one: + +```bash +phino --pin=0.0.0.67 dataize hello.phi +``` + +## Dataize + +Then, you dataize the expression: + +```bash +$ phino dataize hello.phi +68-65-6C-6C-6F +``` + +### Symbolic Ξ» functions + +Which Ξ» functions exist is a property of the object model being dataized, not +of the calculus, so `phino` implements none of them. They come from a YAML file +given with `--symbolic`, one entry per Ξ» function: + +```yaml +- Ξ»: L_number_(plus|times) + dataize: + 𝛿1: $.ρ + 𝛿2: $.x + 𝑛: Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎 ⟧ ) +``` + +The `Ξ»` of an entry is the Ξ» names it answers for, as a regular expression, so +the one above stands for `L_number_plus` and `L_number_times`. Under `dataize` +stand the operands it brings down to data through 𝔻, each binding a bytes meta +`𝛿1`, `𝛿2` and so on; under `morph` the operands it reduces to a normal +form through 𝕄, each binding an expression meta `𝑛1`, `𝑛2`. Both blocks are +terms of the calculus, read against the formation being fired, so `ΞΎ` is that +formation and `$.x` its `x`, while `Ξ¦` is the universe. Every entry numbers its +own metas from `𝛿1` and `𝑛1`, and the entry is what tells two `𝛿1` apart. + +The term under `𝑛` is what the firing answers with. `phino` normalizes it +exactly as it normalizes anything else, so `--protocol`, `--partial` and +`--max-steps` work on it unchanged. It may name any meta the entry bound, +those of the two blocks below among them. + +### Standing data into unknowns + +There is a third block, `symbolize`, and it reduces nothing. It takes a term +another meta of the entry is already bound to and binds an expression meta of +its own to that same term with every datum in it standing for an unknown: + +```yaml +- Ξ»: L_fork + dataize: + 𝛿1: $.Ο† + morph: + 𝑛1: $.left + 𝑛2: $.right + symbolize: + 𝑛3: 𝑛1 + 𝑛4: 𝑛2 + 𝑛: 𝑛3 +``` + +The right-hand side of a line names a meta bound by `morph` or by a +`symbolize` line above it, and nothing else; a term nobody reduced has no data +to stand. Every `Ξ” ‍ b` binding of that term becomes a `Ξ» ‍ 𝜎k` naming a +fresh symbol, one per occurrence, so `⟦ Ξ” ‍ b ⟧` reads as `⟦ Ξ» ‍ 𝜎k ⟧` and a +literal tuple gets several. A term carrying no datum passes through as it was. + +Only the `Ο†` chain is walked. A term carries the value it stands for where +that chain ends, so a datum standing anywhere else says nothing about the term +and is left alone, the whole subtree of it. What sits under `ρ` belongs to the +object around this one, and a normal form drags the universe it was reduced +inside along under `ρ`, so a walk reaching into it would stand the data of the +whole program into unknowns to say one thing about one term. What sits under a +method is code and not data: the `-1` of a `neg ↦ ⟦ Ο† ↦ ΞΎ.ρ.times( -1 ) ⟧` +nobody has called is the body of a method, and minting a symbol for it, and for +every other literal every method of the carrier declares, would write unknowns +nobody ever reads. + +This is what lets an entry compare two branches of a fork. A literal is sugar +for `Ξ¦.number( Ξ¦.bytes( ⟦ Ξ” ‍ … ⟧ ) )`, so a branch computed from a literal +keeps a datum three levels down where a branch computed from an unknown keeps +`⟦ Ξ» ‍ 𝜎 ⟧`. A `Ξ”` against a `Ξ»` is a difference in kind and not in value, and +after the stage both branches carry `⟦ Ξ» ‍ 𝜎 ⟧` where they differ. + +### Joining the branches of a fork + +A branching Ξ» function answers neither of its branches. Which one the program +takes is decided by a value nobody worked out, so handing one of them through +would drop the branch point from the program altogether and a reader would see +the condition computed and thrown away. `join` is the fourth block, and it +reduces nothing either: it takes two metas the entry has bound already and +binds one of its own to the two terms joined into one. + +```yaml +- Ξ»: L_fork + dataize: + 𝛿1: $.Ο† + morph: + 𝑛1: $.left + 𝑛2: $.right + symbolize: + 𝑛3: 𝑛1 + 𝑛4: 𝑛2 + join: + 𝑛5: [𝑛3, 𝑛4] + 𝑛: 𝑛5 +``` + +A line names two metas bound by `morph`, by `symbolize` or by a `join` line +above it, and never three: it stands for a choice between two branches, and a +walk over three terms in parallel is no such choice. The meta it binds is one +like any other, so the answer may name it alone, as above, or stand it inside a +larger term. + +`phino` takes the two terms and requires them to match verbatim, with one +exception: where `⟦ Ξ» ‍ 𝜎A ⟧` in one meets a different `⟦ Ξ» ‍ 𝜎B ⟧` in the +other, it mints a fresh `𝜎C` and stands it there. The same symbol on both sides +stays as it is, and the same pair met again further down gets the same fresh +symbol, since it is one choice however often the two terms differ by it; two +different pairs get two fresh symbols. Two identical terms join into that same +term and nothing is minted at all. The join keeps the type by construction, +being the terms' own shape, so the file needs to know nothing about carriers. + +Only the `Ο†` chain is compared, exactly as `symbolize` stands only that chain +into unknowns: a term carries the value it stands for where its `Ο†` chain ends, +so every other binding is taken from the first branch, the whole subtree of it, +and never compared at all. The two branches of a fork reach their normal forms +in scopes of their own, so their `ρ` differ wherever the reduction left a +trace, and comparing them would refuse the join over something saying nothing +about either branch; a method is the same, its body being code nobody has +called, so two branches differing inside one are not two values. The joined +term keeps the methods and the `ρ` of the first of the two, being of its shape, +which is what lets the program go on dispatching on what the fork answered. + +A join is only ever between two expressions and a datum is never joined with +anything, which is why `symbolize` runs before it: a known symbol, one that +stage minted for a datum, is a symbol like any other here, so a literal branch +joins with a computed one and two literal branches join too. Any other +difference β€” a datum against a symbol, two different data, a binding one term +carries and the other does not β€” is no join at all, and the firing gets stuck +the way a Ξ» function no entry answers does, so `--partial` parks it rather than +aborting the run. A fork whose branches differ in structure, such as a `Ξ¦.true` +and a `Ξ¦.false` written as `Ο† ↦ ΞΎ.left` against `Ο† ↦ ΞΎ.right`, is stuck, and +bringing two such branches to one shape is the program's job and not `phino`'s. + +Every symbol a join mints is written into the protocol as a fact of its own, +so a reader ties it to the two it stands for without diffing the terms; the +section on `--protocol` below shows one. + +### Symbols + +An entry answers, it never computes. The job of these functions is symbolic +morphing: what `5.plus( 6 )` comes to is the arithmetic of the object model and +not `phino`'s, so an entry answers a term carrying a symbol standing for a +value nobody worked out, and the data its `dataize` operands came down to is +not its to read. An answer mentioning a `𝛿` is refused where the file is read. + +`𝜎` is a meta of the calculus, beside `𝑛`, `𝛿` and `𝑓`, and it stands where +a Ξ» name stands. In a term, `𝜎1` is a concrete symbol: a Ξ» function nothing +answers, which is what makes the value the term carries unknown. Firing it is +therefore the same question as firing a Ξ» name the `--symbolic` file does not +carry, and gets the same answer: 𝔼 stops there, the protocol records the site as +`?(𝜎1)`, and `--partial` leaves the term where it stands. Dispatching an +attribute off a symbol β€” `⟦ Ξ» ‍ 𝜎1 ⟧.plus( 5 )` β€” therefore taints its own +binding and nothing else; what stands beside it still computes. In an answer, a +bare `𝜎` asks for a fresh one, minted as the firing happens and numbered by the +run, so no two unknowns are ever spelled alike. Minting starts after the symbols +the program already carries, so a run over the πœ‘-program an earlier run wrote +never spells a fresh symbol like one already standing there. + +Dataizing a symbol never gets stuck. It answers a fixed datum, 42 +(`40-45-00-00-00-00-00-00`), the same one for every symbol, so 𝔻 always +answers, a `𝛿` always holds concrete data and no firing ever declines for the +lack of it: + +```bash +$ cat sum.phi +⟦ + bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, + number ↦ ⟦ Ο† ↦ βˆ…, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧, + Ο† ↦ 5.plus( 6 ) +⟧ +$ phino dataize --symbolic=atoms.yaml --sweet --hide-rho sum.phi +40-45-00-00-00-00-00-00 +``` + +### The keys of the file + +Each `Ξ»` is a regular expression, and it must match the whole Ξ» name, so a +plain name such as `L_number_plus` means that one function and nothing else, +while `L_number_.*` stands for every function of `number`. The keys are unique: +nothing tells two entries under one key apart, so a second entry under a key is +unreachable and the file is refused rather than merely redundant. + +A Ξ» name no key matches has no Ξ» function at all, so 𝔼 gets stuck on it. +Without `--symbolic` there is no entry at all and every Ξ» function gets stuck: + +```bash +$ phino dataize --sweet --hide-rho sum.phi +[ERROR]: No entry of --symbolic answers the Ξ» function 'L_number_plus' +``` + +The file is read before anything is parsed or reduced, so a key that is no +regular expression, an operand that is no meta of the kind its block binds, or +an answer the calculus cannot read fails the run up front rather than half-way +through a derivation. + +### Recording what fired + +Every Ξ» function fired on the way to the answer may be recorded in a +machine-readable protocol, with the `--protocol` option. The protocol is a +tree: the run at the top, one block per firing under it, and inside the block +the operands the firing bound and the term it answered with. + + + +```bash +$ phino dataize --symbolic=atoms.yaml --protocol=atoms.txt --quiet \ + --sweet --hide-rho sum.phi +$ cat atoms.txt +𝔻(Ξ¦) + 𝔼(L_number_plus) # 𝔻(Ξ¦) + 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ) + 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ΞΎ.x) + 𝑛.1.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) # 𝑛 + 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1) +``` + + + +`𝔻(…)` is the run and the term it was aimed at, `𝕄(…)` where the run is a +morphing, and `𝔼(…)` is one firing, named by the entry that answered it and +commented with the judgment that asked for it and the site it was fired at. +Every comment of the file is of that shape: a judgment applied to a term, which +is the intent the value beside it came from. The firings are numbered across the +whole run, in the order they open, so `𝛿1.2` is the value bound to `𝛿1` by +the second firing of the run, whichever Ξ» function that was, `𝑛1.2` the same +for a `morph` meta, and `𝑛.3.2` the answer of the third firing, so +`𝑛1.2 := 𝑛.3.2` reads "the `𝑛1` of this firing is what the third firing +answered". One firing binds a meta once and no two firings +share a number, so every one of these names stands on exactly one line of the +file and a line naming another one points at it and no other. + +An answer stands on two lines and not one. A firing answers the term its entry +wrote and `phino` morphs that term before standing it back into the program, so +`𝑛.1.1` is what the entry wrote, with the symbols this firing minted already in +it, commented with `𝑛` to name the key it was read from, and `𝑛.1.2` is the +normal form 𝕄 made of it, commented with `𝕄(𝑛.1.1)` to say where it came from. +It is the same morphing every other term goes through, and writing only its +outcome would have the formation of `number` appear in place of the three +tokens the entry wrote with nothing saying why. Whatever that morphing fires +opens its own block between the two lines, exactly where a firing an operand +took opens one, so the order the lines come in is the order the work was done +in. + +Where an operand came down to the datum a symbol stands for, the protocol writes +`𝔻(⟦ Ξ» ‍ 𝜎1 ⟧)` in place of that 42, so a reader sees that the value was +manufactured rather than read out of the program. A `𝜎` is the name of a Ξ» +function and no term of its own, so 𝔻 is applied to the formation carrying it +and never to the name alone. + +A `symbolize` line writes a line per fresh symbol it minted, ahead of the line +binding the term that carries them, and that line is a fact and no assignment: +`𝔻(⟦ Ξ» ‍ 𝜎44 ⟧) == 3F-F0-00-00-00-00-00-00` says that dataizing the formation +`𝜎44` names answers those bytes. Nothing binds bytes to a `𝜎`, since it is +neither a datum nor a term. A consumer reading the protocol back treats a +symbol with such a fact as a constant and every other symbol as an unknown. + +The line binding the term of a `symbolize` one is commented with the meta it +was told to stand, `𝑛3.1 := ⟦ Ξ» β€” πœ†8 ⟧ # 𝑛1`, and with no judgment +around it: standing the data of a term into unknowns is the file's own +operation and nothing of the calculus runs there, so the line names a meta of +the entry the way a `join` line names the two it joined. A comment carries the +letter of a judgment exactly where a judgment made the value. + +The site of a firing is a locator, written as a comment the way an operand +line writes the term it came from, under the letter of the judgment that asked +for the firing: 𝔼 is fired by the `ml` rule of morphing and by the `fire` rule +of dataization, so `𝕄(Ξ¦.demo.a.Ο†)` is a Ξ» function fired while 𝕄 was reducing +that binding and `𝔻(Ξ¦)` one fired because dataization demanded data of `Ξ¦`. +A chain such as `5.plus( 6 ).plus( 7 )` writes both: the inner call is fired +while 𝕄 reduces the head of the outer dispatch, the outer one because 𝔻 asked +for the data. The site itself is where in the program the firing +belongs: the term the run was aimed at, so `Ξ¦` for a run that was aimed at +nothing in particular, and, under `--deep`, the binding the walk had entered +when the Ξ» function fired, since that walk reduces every part of the program +in turn and one entry answers the same way wherever it is fired. A locator +names a binding and reaches no further, so a firing standing deeper inside a +term than that β€” under a dispatch, or in the argument of an application β€” is +written under the last binding the walk entered, which is the smallest part of +the program a reader can aim a run of their own at. An operand of a firing is +reduced bound to a synthetic attribute of the universe (see `--inside` below), +so a Ξ» function fired while it came down is written under that attribute and +not under the site of the firing that asked for it. + +An operand line ends in the judgment that reduced it and the term it was +reduced from, written as a comment after two spaces and `#`. The value alone +says what the meta was bound to and neither what it was bound from nor what +was done to it, so `𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ)` reads "the +`𝛿1` of this firing is the `ρ` of the formation brought down through 𝔻, and +it came down to 20", where a `morph` operand reads `𝑛1.5 := 𝑛.3.2 # 𝕄(ΞΎ.then)` +and says that the `then` of the formation reached its normal form through 𝕄. +Which of the two judgments ran is the whole difference between a line ending +in data and one ending in a term. It is the very term the entry wrote under +that meta, spelled the way the calculus reads it β€” `$` is read as `ΞΎ` β€” so a +reader never has to open the `--symbolic` file beside the protocol and match +every line by Ξ» name and meta number. + +`?(…)` is a Ξ» name no entry answers, standing where the block of its firing +would have stood. Nothing fired, so nothing opens under it. The line is +commented with the judgment that asked and the formation it was asking about, +`𝕄(⟦ Ξ» ‍ L_none ⟧)`, the way an operand line is commented with the term it was +reduced from: 𝔼 is fired by the `ml` rule of morphing and by the `fire` rule +of dataization, so the letter says where in the reduction the site stands and +the term says which object the Ξ» function that could not fire belongs to. It +is written +whether or not `--partial` goes on to park the run, since the protocol records +what 𝔼 was asked for, and a question it could not answer belongs there as much +as one it could β€” once per site and not once per attempt, since a site +`--partial` parks stays in the residue and `--deep` walks over it again: + + + +```bash +$ phino dataize --symbolic=atoms.yaml --protocol=atoms.txt --quiet \ + --sweet --hide-rho stuck.phi +[ERROR]: No entry of --symbolic answers the Ξ» function 'L_number_nope' +$ cat atoms.txt +𝔻(Ξ¦) + 𝔼(L_number_plus) # 𝕄(Ξ¦) + 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ) + 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ΞΎ.x) + 𝑛.1.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) # 𝑛 + 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, nope ↦ ⟦ Ξ» ‍ L_number_nope ⟧ ⟧ # 𝕄(𝑛.1.1) + ?(L_number_nope) # 𝔻(⟦ Ξ» ‍ L_number_nope ⟧) +``` + + + +The very same file comes back with `--partial`, where the run answers the +residue instead of failing: what `phino` could not decide is a property of the +program and not of the option that decides what to do about it. + +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 +it always holds the firings of exactly one run. + +The blocks come in the order the reduction walks the term, and that order is +not what the dependencies are read from β€” the symbols are. Take a comparison +nobody can decide, a fork branching on it, and an `atoms.yaml` of three +entries, the Ξ» functions named briefly to keep the lines below short: + +```yaml +- Ξ»: L_plus + dataize: + 𝛿1: $.ρ + 𝛿2: $.x + 𝑛: Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎 ⟧ ) +- Ξ»: L_gt + dataize: + 𝛿1: $.ρ + 𝛿2: $.x + 𝑛: Ξ¦.bool( if ↦ ⟦ Ξ» ‍ L_fork, then ↦ βˆ…, else ↦ βˆ…, Ο† ↦ ⟦ Ξ» ‍ 𝜎 ⟧ ⟧ ) +- Ξ»: L_fork + dataize: + 𝛿1: $.Ο† + morph: + 𝑛1: $.then + 𝑛2: $.else + join: + 𝑛3: [𝑛1, 𝑛2] + 𝑛: 𝑛3 +``` + + + +```bash +$ cat fork.phi +⟦ + bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, + bool ↦ ⟦ if ↦ βˆ… ⟧, + number ↦ ⟦ Ο† ↦ βˆ…, plus(x) ↦ ⟦ Ξ» ‍ L_plus ⟧, gt(x) ↦ ⟦ Ξ» ‍ L_gt ⟧ ⟧, + foo(x) ↦ ⟦ + Ο† ↦ ΞΎ.x.gt( 0 ).if( ΞΎ.x.plus( ΞΎ.x.plus( 1 ) ), ΞΎ.x.plus( ΞΎ.x ) ).plus( 5 ) + ⟧, + demo ↦ ⟦ a ↦ Ξ¦.foo( Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) ) ⟧ +⟧ +$ phino morph --deep --symbolic=atoms.yaml --locator=Q.demo.a \ + --protocol=fork.txt --quiet --sweet --hide-rho fork.phi +$ cat fork.txt +𝕄(Ξ¦.demo.a) + 𝔼(L_gt) # 𝕄(Ξ¦.demo.a.Ο†) + 𝛿1.1 := 𝔻(⟦ Ξ» ‍ 𝜎1 ⟧) # 𝔻(ΞΎ.ρ) + 𝛿2.1 := 00-00-00-00-00-00-00-00 # 𝔻(ΞΎ.x) + 𝑛.1.1 := Ξ¦.bool( if ↦ ⟦ Ξ» ‍ L_fork, then ↦ βˆ…, else ↦ βˆ…, Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ⟧ ) # 𝑛 + 𝑛.1.2 := ⟦ if ↦ ⟦ Ξ» ‍ L_fork, then ↦ βˆ…, else ↦ βˆ…, Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ⟧ ⟧ # 𝕄(𝑛.1.1) + 𝔼(L_plus) # 𝕄(Ξ¦.demo.a.Ο†) + 𝛿1.2 := 𝔻(⟦ Ξ» ‍ 𝜎1 ⟧) # 𝔻(ΞΎ.ρ) + 𝛿2.2 := 3F-F0-00-00-00-00-00-00 # 𝔻(ΞΎ.x) + 𝑛.2.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎3 ⟧ ) # 𝑛 + 𝑛.2.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎3 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_plus ⟧, gt(x) ↦ ⟦ Ξ» ‍ L_gt ⟧ ⟧ # 𝕄(𝑛.2.1) + 𝔼(L_plus) # 𝕄(Ξ¦.demo.a.Ο†) + 𝛿1.3 := 𝔻(⟦ Ξ» ‍ 𝜎1 ⟧) # 𝔻(ΞΎ.ρ) + 𝛿2.3 := 𝔻(⟦ Ξ» ‍ 𝜎3 ⟧) # 𝔻(ΞΎ.x) + 𝑛.3.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎4 ⟧ ) # 𝑛 + 𝑛.3.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎4 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_plus ⟧, gt(x) ↦ ⟦ Ξ» ‍ L_gt ⟧ ⟧ # 𝕄(𝑛.3.1) + 𝔼(L_plus) # 𝕄(Ξ¦.demo.a.Ο†) + 𝛿1.4 := 𝔻(⟦ Ξ» ‍ 𝜎1 ⟧) # 𝔻(ΞΎ.ρ) + 𝛿2.4 := 𝔻(⟦ Ξ» ‍ 𝜎1 ⟧) # 𝔻(ΞΎ.x) + 𝑛.4.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧ ) # 𝑛 + 𝑛.4.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_plus ⟧, gt(x) ↦ ⟦ Ξ» ‍ L_gt ⟧ ⟧ # 𝕄(𝑛.4.1) + 𝔼(L_fork) # 𝕄(Ξ¦.demo.a.Ο†) + 𝛿1.5 := 𝔻(⟦ Ξ» ‍ 𝜎2 ⟧) # 𝔻(ΞΎ.Ο†) + 𝑛1.5 := 𝑛.3.2 # 𝕄(ΞΎ.then) + 𝑛2.5 := 𝑛.4.2 # 𝕄(ΞΎ.else) + 𝔻(⟦ Ξ» ‍ 𝜎6 ⟧) ∈ { 𝔻(⟦ Ξ» ‍ 𝜎4 ⟧), 𝔻(⟦ Ξ» ‍ 𝜎5 ⟧) } + 𝑛3.5 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎6 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_plus ⟧, gt(x) ↦ ⟦ Ξ» ‍ L_gt ⟧ ⟧ # [𝑛1, 𝑛2] + 𝑛.5.1 := 𝑛3.5 # 𝑛 + 𝑛.5.2 := 𝑛3.5 # 𝕄(𝑛.5.1) + 𝔼(L_plus) # 𝕄(Ξ¦.demo.a.Ο†) + 𝛿1.6 := 𝔻(⟦ Ξ» ‍ 𝜎6 ⟧) # 𝔻(ΞΎ.ρ) + 𝛿2.6 := 40-14-00-00-00-00-00-00 # 𝔻(ΞΎ.x) + 𝑛.6.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎7 ⟧ ) # 𝑛 + 𝑛.6.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎7 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_plus ⟧, gt(x) ↦ ⟦ Ξ» ‍ L_gt ⟧ ⟧ # 𝕄(𝑛.6.1) +``` + + + +`𝜎3` is minted by the second firing and consumed by the third as +`𝔻(⟦ Ξ» ‍ 𝜎3 ⟧)`, and `𝜎2` by the first and consumed by the fork. `𝜎4` and +`𝜎5` are what the two branches came to, and the fork consumes both: its `join` +line makes them one term carrying `𝜎6`, which the `plus( 5 )` standing after +the fork then reads as `𝔻(⟦ Ξ» ‍ 𝜎6 ⟧)`. The line +`𝔻(⟦ Ξ» ‍ 𝜎6 ⟧) ∈ { 𝔻(⟦ Ξ» ‍ 𝜎4 ⟧), 𝔻(⟦ Ξ» ‍ 𝜎5 ⟧) }` is what ties the three +together: dataizing the formation `𝜎6` names answers what dataizing one of the +other two answers. A reader who knows the entry knows that `𝛿1` is what decides +between them and that the first of the two belongs to `then`. Nothing is +assigned to a `𝜎`, it being the name of a Ξ» function, so the fact stands on a +line of its own the way what a `symbolize` line knows does, and the line under +it binds the meta, commented with the two metas it joined. + +Were the fork to answer one of its branches instead, the value of the other +would be minted and never consumed, and `foo` would read as a program that +computes a condition, computes both branches and then drops the branch point. + +All six firings stand under `Ξ¦.demo.a.Ο†`, which is as near as a locator gets +to any of them: the walk entered the `Ο†` of the formation `Ξ¦.demo.a` morphs to, +and everything under it β€” the dispatches of the chain, the arguments of `if` β€” +stands under no attribute of any formation, so the binding the walk had entered +is what the protocol writes them under. + +A firing that happened while an operand of another was being reduced stands one +level deeper, under the firing that asked for it. Here it never happens, +because deep morphing reduces both branches where they sit as arguments of +`if`, long before the dispatch that fires the fork. + +### The protocol as XML + +The name of the file decides which of the two formats `--protocol` writes: a +name ending in `.xml` gets the same tree as markup, every other name gets the +indented text above. There is no option for it, since a caller who asks for a +file called `atoms.xml` and gets text back has been told nothing useful. Here +is the run at the top of this section again: + +```bash +$ phino dataize --symbolic=atoms.yaml --protocol=atoms.xml --quiet \ + --sweet --hide-rho sum.phi +$ cat atoms.xml + + + + 40-14-00-00-00-00-00-00 + 40-18-00-00-00-00-00-00 + 𝜎1 + Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) + ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧ + + +``` + +The root is the run itself, named after the judgment it ran β€” `` for a +𝔻, `` for a 𝕄 β€” with `locator` naming the term it was aimed at, which is +what the text format opens with as `𝔻(Ξ¦)`. `` is one firing of 𝔼, `Ξ»` +naming the entry that answered it, `id` numbering it within the run, `judgment` +naming the one that asked for the firing β€” the same word the root and a +`` carry β€” and `locator` naming the site it was fired at. The text +format writes those two as the comment of its line, `𝔻(Ξ¦)`. +`` is one meta the firing bound, `meta` naming it the same way the text +format names it, counter and all, and the element holding the value it took: a +term where the operand was reduced with 𝕄, the datum itself where a `dataize` +operand came down to data. `` inside a firing is the other thing a +`dataize` operand may come to, the datum manufactured for an unknown, and holds +the formation that unknown names rather than the 42 standing for it: a `𝜎` is +the name of a Ξ» function and no term of its own, so what 𝔻 was applied to is +`⟦ Ξ» ‍ 𝜎2 ⟧` and never `𝜎2` alone. It carries `meta` where the root carries +`locator`, the same difference the text format draws between `𝔻(Ξ¦)` at the top +and `𝛿1.2 := 𝔻(…)` in a block. The name of the element is what tells a +manufactured datum from data, the way `𝔻(…)` does in the text format, so +nothing has to be read off the presence of an attribute. `` holds the +term the firing answered with, named the same way by its own `meta`, and +`` before it holds the term the entry wrote, the one 𝕄 made that answer +of: two elements rather than two attributes of one, for the same reason +`` is no ``. + +`3F-F0-00-00-00-00-00-00` is the fact a `symbolize` +line writes about a symbol it minted, which the text format writes as +`𝔻(⟦ Ξ» ‍ 𝜎44 ⟧) == …`: the symbol stands in the attribute a reader joins +lines on and the data dataizing its formation answers are the text of the +element. It takes `symbol` and not `meta`, since the fact is about the unknown +and not about a meta the firing bound. + +`𝜎4 𝜎5` is the same kind of fact about a symbol +a `join` line minted, which the text format writes as +`𝔻(⟦ Ξ» ‍ 𝜎6 ⟧) ∈ { 𝔻(⟦ Ξ» ‍ 𝜎4 ⟧), 𝔻(⟦ Ξ» ‍ 𝜎5 ⟧) }`: the fresh symbol stands +in `symbol` and the two it was minted for are the text, in the order the line +listed the metas it joined. A line whose two terms differ at several places +writes one element per pair of symbols, and one whose terms are alike writes +none. The meta the line binds is a `` like every other meta of the +firing. + +`𝜎1` is one symbol the firing minted, one element per bare `𝜎` +the entry wrote its answer with, standing inside the block ahead of the +`` carrying them. That is the edge a reader joins on: a later +`⟦ Ξ» ‍ 𝜎2 ⟧` names the symbol the firing that +wrote `𝜎2` handed out. A firing minting two symbols writes two +elements and one minting none writes none, which no attribute on the answer +could say: a term may carry several symbols, or carry one where the value it +stands for is not a symbol at all. In the fork above, `𝔼(L_gt)` writes +`𝜎2` although `𝜎2` sits under `if` and not where the value of +the term is, while `𝔼(L_fork)` writes none at all, since the symbol it answers +with comes from a `join` line and stands in a `` of its own. + +A Ξ» name no entry answers is ``, standing where its `` +would have stood with the formation 𝔼 was fired against as its text and the +judgment that asked in its `judgment` attribute, where the text format writes +the letter of it. A firing that happened while an operand of another was being +reduced is an `` inside the one that asked, which is what the deeper +indentation means in the text. Elements are written as the run goes and +the open ones are closed when it ends, so a run that fails still leaves a +well-formed document behind: + + + +```bash +$ phino dataize --symbolic=atoms.yaml --protocol=atoms.xml --quiet \ + --sweet --hide-rho stuck.phi +[ERROR]: No entry of --symbolic answers the Ξ» function 'L_number_nope' +$ cat atoms.xml + + + + 40-14-00-00-00-00-00-00 + 40-18-00-00-00-00-00-00 + 𝜎1 + Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) + ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, nope ↦ ⟦ Ξ» ‍ L_number_nope ⟧ ⟧ + + ⟦ Ξ» ‍ L_number_nope ⟧ + +``` + + + +### Reducing a term inside a universe + +A term that is no part of the program may still be reduced against it, with the +`--inside` option: the expression it names is bound to a synthetic attribute +prepended to the input expression, which the run takes as the universe Ξ¦, +normalized there and then reduced. + +```bash +$ cat universe.phi +⟦ + bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, + number ↦ ⟦ Ο† ↦ βˆ…, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧ +⟧ +$ phino dataize --symbolic=atoms.yaml --inside='5.plus( 6 )' universe.phi +40-45-00-00-00-00-00-00 +``` + +This is the very trick `phino` plays internally to reduce the operands of a +firing, made available to whoever asks it to reduce a term the program does not +hold. The option cannot be combined with `--locator`, since it aims the run at +the binding it mints itself. Both `dataize` and `morph` take `--symbolic` and +`--inside`. + +### Partial evaluation + +A Ξ» function no entry of the `--symbolic` file answers fails the run. This is +what happens when an operation is deliberately left out β€” an input the object +model has not declared yet, or an operation whose answer is not known. With +`--partial`, dataization becomes partial evaluation instead: what the known +inputs decide is computed, the rest survives as the residual program, which is +printed in place of the bytes, and the run ends successfully: + +```bash +$ cat partial.phi +⟦ + bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, + number ↦ ⟦ + Ο† ↦ βˆ…, + plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, + times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧, + as-bool ↦ ⟦ Ξ» ‍ L_number_as_bool ⟧ + ⟧, + Ο† ↦ 2.times( 3 ).plus( 4 ).as-bool +⟧ +$ phino dataize --symbolic=atoms.yaml --sweet --hide-rho partial.phi +[ERROR]: No entry of --symbolic answers the Ξ» function 'L_number_as_bool' +$ phino dataize --symbolic=atoms.yaml --partial --sweet --hide-rho partial.phi +⟦ Ξ» ‍ L_number_as_bool ⟧ +``` + +Here `2.times( 3 ).plus( 4 )` was answered by the entries the file carries, so +it was reduced β€” the symbol it came to sits in the hidden `ρ` of the residual +program β€” while `as-bool` names a Ξ» function no entry answers, so it stays in +place as a normal-form subterm. A stuck site opens no block in the +`--protocol` file, since nothing fired there, and stands in it as `?(…)`: + + + +```bash +$ phino dataize --symbolic=atoms.yaml --partial --protocol=atoms.txt --quiet \ + --sweet --hide-rho partial.phi +$ cat atoms.txt +𝔻(Ξ¦) + 𝔼(L_number_times) # 𝕄(Ξ¦) + 𝛿1.1 := 40-00-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ) + 𝛿2.1 := 40-08-00-00-00-00-00-00 # 𝔻(ΞΎ.x) + 𝑛.1.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) # 𝑛 + 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧, as-bool ↦ ⟦ Ξ» ‍ L_number_as_bool ⟧ ⟧ # 𝕄(𝑛.1.1) + 𝔼(L_number_plus) # 𝕄(Ξ¦) + 𝛿1.2 := 𝔻(⟦ Ξ» ‍ 𝜎1 ⟧) # 𝔻(ΞΎ.ρ) + 𝛿2.2 := 40-10-00-00-00-00-00-00 # 𝔻(ΞΎ.x) + 𝑛.2.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ) # 𝑛 + 𝑛.2.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧, as-bool ↦ ⟦ Ξ» ‍ L_number_as_bool ⟧ ⟧ # 𝕄(𝑛.2.1) + ?(L_number_as_bool) # 𝔻(⟦ Ξ» ‍ L_number_as_bool ⟧) +``` + + + +Evaluation stays demand-driven, as the calculus prescribes: an argument +that nothing asked for before the run got stuck is left as it is in the +residual program, for the next iteration. + +The nested morphing and dataization recursion is bounded by the +`--max-steps` option (default `1000`): when the budget is exhausted, the run +fails with `Dataization did not finish before reaching the limit of steps`. +This guards against non-terminating terms, which used to loop forever before +the bound was introduced: + +```bash +$ phino dataize --max-steps=50 problem.phi +[ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=50 +``` + +## Morph + +Dataization insists on bytes. Morphing 𝕄 asks a different question: evaluate +as far as the object model allows, without demanding data. It resolves Ξ¦ +against the universe, peels dispatches and applications through +normalization, fires whichever Ξ» functions sit under a dispatch, and stops at +the first formation it reaches, handing that formation back untouched. The +`morph` command runs 𝕄 on its own: + +```bash +$ cat two.phi +⟦ + bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, + number ↦ ⟦ Ο† ↦ βˆ…, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧, + Ο† ↦ 5.plus( 6 ).plus( 7 ) +⟧ +$ phino dataize --symbolic=atoms.yaml --sweet --hide-rho two.phi +40-45-00-00-00-00-00-00 +$ phino morph --symbolic=atoms.yaml --locator=Q.Ο† --sweet --hide-rho two.phi +⟦ x ↦ 7, Ξ» ‍ L_number_plus ⟧ +``` + +The inner `5.plus( 6 )` fires, because `.plus` is dispatched on its result, +and the symbol it answered with lands in the `ρ` hidden by `--hide-rho`. The +outer application is saturated but bare, so 𝕄 returns it and is finished; +firing it is dataization's job and takes `dataize` on to a datum. + +The default locator `Q` morphs the whole top formation, which 𝕄 returns +unchanged, so `--locator` is how one aims 𝕄 at a subterm, exactly as in +`dataize`. Unlike 𝔻, 𝕄 is total: where no formation is reachable the answer +is the terminator `βŠ₯`, printed rather than reported as a failed run: + +```bash +$ phino morph --locator=Q.x <<< '⟦ x ↦ ΞΎ ⟧' +βŠ₯ +``` + +The whole `dataize` option surface applies unchanged β€” `--symbolic`, +`--inside`, `--sequence`, `--headers`, `--steps-dir`, `--protocol`, +`--partial`, `--max-steps`, `--shuffle`/`--seed`, `--output`, `--focus` and the +rest. + +### Deep morphing + +𝕄 stops at the first formation it reaches and hands its bindings back as they +were written, since firing a bare Ξ» is dataization's job, and `dataize` +follows the one path dataization demands and ends in bytes. What a program +holds but nothing demands β€” the argument of a Ξ» function no entry answers, for +one β€” is therefore reduced by neither. The `--deep` flag enters it: + +```bash +$ cat gap.phi +⟦ + bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, + number ↦ ⟦ Ο† ↦ βˆ…, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧, + bar(x) ↦ ⟦ Ξ» ‍ L_bar ⟧, + demo ↦ ⟦ foo ↦ ⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( ΞΎ.n.times( 5 ).times( 7 ) ) ⟧ ⟧ +⟧ +$ phino morph --symbolic=atoms.yaml --inside='Q.demo.foo' \ + --sweet --hide-rho gap.phi +⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( n.times( 5 ).times( 7 ) ) ⟧ +$ phino morph --deep --symbolic=atoms.yaml --inside='Q.demo.foo' \ + --sweet --hide-rho gap.phi +⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧ ) ⟧ +``` + +Every binding of the formation is entered, recursively. 𝕄 is asked about the +term standing there and, where it lands on a saturated formation whose Ξ» an +entry answers, that Ξ» is fired and 𝕄 is asked about the answer again. A term on +whose way a Ξ» function fired is replaced by the answer of the last firing, +morphed: an entry answering `Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎 ⟧ )` stands the formation of +`number` there, the very one the same term written in the program morphs to, so +a value that came out of a firing and a value that was written as a literal are +one shape and can be compared leaf by leaf. That costs the size of the object's +formation in the residual, which is the price of saying the same thing one way. +A term nothing fired on stays exactly as it was written and only its own parts +are walked, so `Ξ¦.bar` keeps its name and what comes back is still the same +program, reduced as far as the file allows. The step joins the chain under the +name `deep`, so `--sequence` shows it, and `--max-steps` bounds the walk. + +Two things are left alone. A Ξ» no entry answers is not fired at all, so +`--deep` stays as total as 𝕄 itself and needs no `--partial`; a Ξ» function that +gets stuck deeper on a spine still fails the run, and `--partial` parks it, +leaving that term as it was written. A firing the walk does make and cannot +finish β€” one whose operand never comes down to data, because a Ξ» nothing +answers stands in it β€” is parked by `--partial` the same way: the binding it +stood in is left as it was written, the walk enters the next one, and the +protocol shows the firing with nothing bound under it. One entry nothing can +answer therefore taints its own binding and not the whole run. A formation +still holding a void +binding is not fired either: the void is an argument the program has not given +yet, so `times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧` is a method waiting to be applied, +not an application waiting to be computed. Walking the whole program therefore +folds what it can and leaves the object model as it was declared: + +```bash +$ phino morph --deep --symbolic=atoms.yaml --sweet --hide-rho gap.phi +⟦ + bytes(Ο†) ↦ ⟦⟧, + number(Ο†) ↦ ⟦ times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧, + bar(x) ↦ ⟦ Ξ» ‍ L_bar ⟧, + demo ↦ ⟦ + foo ↦ ⟦ + n ↦ 3, + Ο† ↦ Ξ¦.bar( ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧ ) + ⟧ + ⟧ +⟧ +``` + +### Acyclic morphing + +Whether a program terminates is the object model's business, not the +calculus's, so phino prevents no recursion of its own and `--max-steps` is what +ends a run that never finishes. An entry answering with a firing of itself +therefore spends the whole budget before it fails, and what it fails on is the +limit rather than the loop: + +```bash +$ cat loop.yaml +- Ξ»: L_loop + 𝑛: ⟦ Ξ» ‍ L_loop ⟧ +$ cat loop.phi +⟦ x ↦ ⟦ Ξ» ‍ L_loop ⟧.foo ⟧ +$ phino morph --symbolic=loop.yaml --locator='Q.x' --max-steps=40 loop.phi +[ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=40 +``` + +The `--acyclic` flag makes a reduction notice. Every frame of 𝕄 and of 𝔻 +remembers the terms the frames above it are reducing, and a term that comes +back is a question only ever answered by asking it again, so the flag stops +there and parks the site the way `--partial` parks a Ξ» function that cannot +fire: the answer is the term the spine had reached, left where it stood, and +the command exits successfully. + +```bash +$ phino morph --symbolic=loop.yaml --locator='Q.x' --acyclic \ + --max-steps=40 --hide-rho loop.phi +⟦ Ξ» ‍ L_loop ⟧.foo +``` + +Each judgment keeps its own memory, since 𝕄 and 𝔻 call each other on the very +term they were asked about and that handover is no loop. A body dispatching the +object it stands in is one 𝔻 walks round on its own β€” 𝕄 stops at a formation +every round and never sees the same term twice β€” so `dataize` takes the flag +too, and so does the run of 𝔻 a Ξ» function's `dataize` operand is brought down +with: + +```bash +$ cat cyc.phi +⟦ cyc ↦ ⟦ x ↦ βˆ…, Ο† ↦ Ξ¦.cyc( ΞΎ.x ) ⟧, t ↦ Ξ¦.cyc( ⟦⟧ ) ⟧ +$ phino dataize --locator='Q.t' --acyclic --partial \ + --sweet --hide-rho --flat cyc.phi +⟦ cyc(x) ↦ ⟦ Ο† ↦ Ξ¦.cyc( x ) ⟧, t ↦ ⟦ x ↦ ⟦⟧, Ο† ↦ Ξ¦.cyc( x ) ⟧ ⟧ +``` + +𝔻 insists on bytes and a parked term carries none, so under `dataize` the flag +wants `--partial` to have something to print: the residual program, exactly the +one it prints for a Ξ» function that cannot fire. Without it the run stops on +the loop all the same, naming the term it came back to instead of running the +budget down. Under `morph` nothing is asked for: 𝕄 always has a term to answer +with, a loop 𝔻 meets under a firing parks the site the firing stands at, and +the walk of `--deep` goes on to the next binding. + +What a frame remembers is the branch from the run down to it, never everything +the run has touched, so two sibling subterms that happen to be written alike +stay two terms and only a term genuinely reached from itself is a loop. The cut +costs one lookup and fires on the turn the repeat appears, so raising +`--max-steps` from 40 to a million changes neither the answer nor the time. The +flag promises nothing about programs that loop without ever repeating a term β€” +a body that grows on every round rather than coming back still ends on the +budget. + +## Rewrite + +You can rewrite this expression with the help of [rules](#rule-structure) +defined in the `my-rule.yml` YAML file (here, the `!d` is a capturing group, +similar to regular expressions): + +```yaml +name: My custom rule +pattern: Ξ” ‍ !d +result: Ξ” ‍ 62-79-65 +``` + +Then, rewrite: + +```bash +$ phino rewrite --rule=my-rule.yml hello.phi +⟦ Ο† ↦ ⟦ Ξ” ‍ 62-79-65 ⟧, t ↦ ΞΎ.k, k ↦ ⟦⟧ ⟧ +``` + +If you want to use many rules, just use `--rule` as many times as you need: + +```bash +phino rewrite --rule=rule1.yaml --rule=rule2.yaml ... +``` + +You can also use [built-in rules](resources), which are designed +to normalize expressions: + +```bash +phino rewrite --normalize hello.phi +``` + +Both flags may be combined, so that your own rules are applied +alongside the built-in ones, in a single rewriting session: + +```bash +phino rewrite --normalize --rule=my-rule.yaml hello.phi +``` + +Some rules mint fresh synthetic names via the `random-string` built-in. To +keep the output reproducible across runs, `phino` seeds the random generator +deterministically with `0` by default. Use `--seed` to pick a different seed: + +```bash +phino rewrite --seed=42 --rule=my-rule.yml hello.phi +``` + +If no input file is provided, the πœ‘-expression is taken from `stdin`: + +```bash +$ echo '⟦ Ο† ↦ ⟦ Ξ” ‍ 68-65-6C-6C-6F ⟧ ⟧' | phino rewrite --rule=my-rule.yml +⟦ Ο† ↦ ⟦ Ξ” ‍ 62-79-65 ⟧ ⟧ +``` + +You're able to pass [`XMIR`][xmir] as input. Use `--input=xmir` and `phino` +will parse given `XMIR` from file or `stdin` and convert it to `phi` AST. + +```bash +phino rewrite --rule=my-rule.yaml --input=xmir file.xmir +``` + +Also `phino` supports πœ‘-expressions in +[ASCII](https://en.wikipedia.org/wiki/ASCII) format and with +syntax sugar. The `rewrite` command also allows you to desugar the expression +and print it in canonical syntax: + +```bash +$ echo '[[ @ -> Q.io.stdout("hello") ]]' | phino rewrite +⟦ + Ο† ↦ Ξ¦.io.stdout( + Ξ±0 ↦ Ξ¦.string( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ” ‍ 68-65-6C-6C-6F, ρ ↦ βˆ… ⟧ ) ) + ), + ρ ↦ βˆ… +⟧ +``` + +## Merge + +You can merge several πœ‘-expressions into a single one by merging their +top level formations: + +```bash +$ cat bytes.phi +⟦ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧ ⟧ +$ cat number.phi +⟦ + number ↦ ⟦ + Ο† ↦ βˆ…, + plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ + ⟧ +⟧ +$ cat minus.phi +⟦ number ↦ ⟦ minus(x) ↦ ⟦ Ξ» ‍ L_number_minus ⟧ ⟧ ⟧ +$ phino merge bytes.phi number.phi minus.phi --sweet +⟦ + bytes(Ο†) ↦ ⟦⟧, + number(Ο†) ↦ ⟦ + plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, + minus(x) ↦ ⟦ Ξ» ‍ L_number_minus ⟧ + ⟧ +⟧ +``` + +## Match + +You can test the πœ‘-expression matches against the [rule](#rule-structure) +pattern. The result output contains matched substitutions: + +```bash +$ phino match --pattern='⟦ Ξ” ‍ !d, !B ⟧' hello.phi +B >> ⟦ ρ ↦ βˆ… ⟧ +d >> 68-65-6C-6C-6F +``` + +## Explain + +You can _explain_ the built-in rules by printing them in [LaTeX][latex] +format. Pass exactly one of `--normalize`, `--morph`, `--dataize` or +`--contextualize` for the rewriting, morphing (𝕄), dataization (𝔻) or +contextualization (π’ž) rules (or `--rule` for a custom rule file): + +```bash +$ phino explain --normalize +\begin{tabular}{rl} +\phinoNormalizationRule{alpha} + { [[ B_1, \tau -> ?, B_2 ]] ( \phiTerminal{\alpha_{i}} -> e ) } + { [[ B_1, \tau -> ?, B_2 ]] ( \tau -> e ) } + { $ i = \vert \overline{ B_1 } \vert $ } + { } +\phinoNormalizationRule{dc} + { T ( \tau -> e ) } + { T } + { } + { } +... +\phinoNormalizationRule{stop} + { [[ B ]] . \tau } + { T } + { $ \tau \notin B \;\text{and}\; @ \notin B \;\text{and}\; L \notin B $ } + { } +\end{tabular} +``` + +The morphing and dataization rules are printed the same way: + +```bash +$ phino explain --morph +\begin{tabular}{rl} +\phinoMorphingRule{mf} + { \mathbb{M}( [[ B ]], e ) } + { [[ B ]] } + { } + { } +... +\phinoMorphingRule{universe} + { \mathbb{M}( Q, e ) } + { \mathbb{M}( \phinoNormalize{ e }, e ) } + { $ e \not= Q $ } + { } +\end{tabular} +``` + +```bash +$ phino explain --dataize +\begin{tabular}{rl} +\phinoDataizationRule{delta} + { \phinoDataize{ [[ B_1, D> \delta_0, B_2 ]] } } + { \delta_0 } + { } + { } +... +\phinoDataizationRule{norm} + { \phinoDataize{ n } } + { \phinoDataize{ \mathbb{M}( n, e ) } } + { } + { } +\end{tabular} +``` + +```bash +$ phino explain --contextualize +\begin{phinoContextualizationInference} + \phinoName{cxi} + \phinoConclusion{ \phinoContextualize{ \phiTerminal{\xi} }{ k }{ k } } +\end{phinoContextualizationInference} +... +\begin{phinoContextualizationInference} + \phinoName{cd} + \phinoPremise{ \phinoContextualize{ n }{ k }{ n_1 } } + \phinoConclusion{ \phinoContextualize{ n . \tau }{ k }{ n_1 . \tau } } +\end{phinoContextualizationInference} +``` + +For more details, use `phino [COMMAND] --help` option. + +## Rule structure + +This is BNF-like yaml rule structure. Here types ended with +apostrophe, like `Attribute'` are built types from πœ‘-expression [AST](src/AST.hs) + +```bnfc +Rule: + name: String + pattern: String + result: String + when: Condition? # predicate, works with substitutions before extension + where: [Extension]? # substitution extensions + having: Condition? # predicate, works with substitutions after extension + +Condition: + = and: [Condition] # logical AND + | or: [Condition] # logical OR + | not: Condition # logical NOT + | eq: # compare two comparable objects + - Comparable + - Comparable + | in: # check if attributes exist in bindings + - Attribute' + - Binding' + | nf: Expression' # returns True if given expression in normal form + # which means that no more other normalization rules + # can be applied + | absolute: Expression' # returns True if given expression is xi-free, i.e. + # there is no ΞΎ outside of a formation: it is Ξ¦, a + # formation, a dispatch with a xi-free subject, or an + # application with a xi-free subject and argument. + # Combined with a normal-form check by the 'π‘˜'/'!k' + # meta variable, which ranges over the absolute + # expressions 𝒦 βŠ† 𝒩, used by the Rcopy rule. + | matches: # returns True if given expression after dataization + - String # matches to given regex + - Expression + | part-of: # returns True if given expression is attached to any + - Expression' # attribute in ginve bindings + - BiMeta' + | formation: # returns True if given expression is a formation + Expression' # (an abstraction βŸ¦β€¦βŸ§); used by morphing 'md' + # as 'not (formation 𝑛)', so a non-formation head is + # morphed and a formation head is left to 'ml' + | gt: # returns True if the first comparable object is + - Comparable # greater than the second one + - Comparable + | disjoint: # returns True if none of the given attributes exists + - [Attribute'] # in the given bindings + - Binding' + +Comparable: # comparable object that may be used in 'eq' condition + = Attribute' + | Number + | Expression' + +Number: # comparable number + = Integer # just regular integer + | IndexMeta' # 𝑖 (or !i), the index captured by an α𝑖 argument + | length: BiMeta' # calculate length of bindings by given meta binding + | domain: BiMeta' # calculate number of unique attributes in given + # meta binding (excluding 'assets') + +Extension: # substitutions extension used to introduce new meta variables + meta: [ExtArgument] # new introduced meta variable + function: String # name of the function + args: [ExtArgument] # arguments of the function + +ExtArgument + = Bytes' # !d + | Binding' # !B + | Expression' # !e + | Attribute' # !t +``` + +Here's list of functions that are supported for extensions: + +* `contextualize` - function of two arguments, that rewrites given expression + depending on provided context according to the contextualization + [rules](assets/contextualize.jpg) +* `random-tau` - creates attribute with random unique name. Accepts bindings, + and attributes. Ensures that created attribute is not present in list of + provided attributes and does not exist as attribute in provided bindings. +* `dataize` - dataizes given expression and returns bytes. +* `concat` - accepts bytes or dataizable expressions as arguments, + concatenates them into single sequence and convert it to expression + that can be pretty printed as human readable string: + `Ξ¦.string(Ξ¦.bytes⟦ Ξ” ‍ !d ⟧)`. +* `sed` - pattern replacer, works like unix `sed` function. + Accepts two arguments: target expression and pattern. + Pattern must start with `s/`, consists of three parts + separated by `/`, for example, this pattern `s/\\s+//g` + replaces all the spaces with empty string. To escape braces and slashes + in pattern and replacement parts - use them with `\\`, + e.g. `s/\\(.+\\)//g`. +* `random-string` - accepts dataizable expression or bytes as pattern. + Replaces `%x` and `%d` formatters with random hex numbers and + decimals accordingly. Uniqueness is guaranteed during one + execution of `phino`. +* `size` - accepts exactly one meta binding and returns size of it and + `Ξ¦.number`. +* `tau` - accepts `Ξ¦.string`, dataizes it and converts it to attribute. + If dataized string can't be converted to attribute - an error is thrown. +* `string` - accepts `Ξ¦.string` or `Ξ¦.number` or attribute and converts it + to `Ξ¦.string`. +* `number` - accepts `Ξ¦.string` and converts it `Ξ¦.number` +* `sum` - accepts list of `Ξ¦.number` or `Ξ¦.bytes` and returns sum of them as `Ξ¦.number` +* `join` - accepts list of bindings and returns list of joined bindings. Duplicated + `ρ`, `Ξ”` and `Ξ»` attributes are ignored, all other duplicated attributes are replaced + with unique attributes using `random-tau` function. + +## Meta variables + +The `phino` supports meta variables to write πœ‘-expression patterns for +capturing attributes, bindings, etc. + +This is the list of supported meta variables: + +* `!t` || `𝜏` - attribute +* `!i` || `𝑖` - the index of a positional (Ξ±) application argument, + captured by writing `α𝑖` (or `~!i`) +* `!e` || `𝑒` - any expression +* `!n` || `𝑛` - any expression that is already in normal form (behaves like + `!e`/`𝑒`, but only binds a sub-expression in NF, so no explicit + `nf:` guard is needed) +* `!k` || `π‘˜` - any expression that is absolute, i.e. xi-free and in normal + form (ranges over `𝒦 βŠ† 𝒩`); behaves like `!e`/`𝑒` but only + binds an absolute sub-expression, so no explicit `absolute:` + or `nf:` guard is needed +* `!B` || `𝐡` - list of bindings +* `!d` || `𝛿` - bytes in meta delta binding +* `!F` || `𝑓` - function name in meta lambda binding +* `!S` || `𝜎` - a symbol standing where a Ξ» name stands (see + [Symbols](#symbols)). It is spelled the way a meta variable is + spelled but is a name and no capture: `𝜎1` is one concrete + symbol, which no substitution ever binds, and a bare `𝜎` in the + answer of a `--symbolic` entry asks for a fresh one + +A meta variable carries a suffix, like `!B1` or `𝜏2`, to name what it +captured, so that the `result`, `when`, `where` and `having` of a rule can +read it back. An index starts with one: a suffix of `0`, as in `!B0` or +`𝜏0`, is refused where it is written, because it is a first index spelled +wrong and no name. A positional argument keeps counting from zero, though, +since `Ξ±0` is an index of the calculus and no meta variable. + +Written bare, with no suffix at all, a meta variable is anonymous: it matches +whatever term stands in its place, every occurrence on its own, and binds no +name. Two anonymous metas of one kind are therefore two different captures, +which is what lets a pattern ask for any two attributes without inventing +names for them: + +```yaml +name: two-attributes +pattern: '⟦ 𝜏 ↦ 𝑒, 𝜏 ↦ 𝑒 ⟧' +result: '⟦ x ↦ ⟦ Ξ” ‍ 2A- ⟧ ⟧' +``` + +Spelled with suffixes, that pattern would read `⟦ 𝜏1 ↦ 𝑒1, 𝜏2 ↦ 𝑒2 ⟧` and +name four captures the result never mentions, while `⟦ 𝜏1 ↦ 𝑒1, 𝜏1 ↦ 𝑒1 ⟧` +would be rejected as a duplicated attribute. + +Nothing can refer to an anonymous meta, since it has no name to be referred to +by. Writing one outside a `pattern` (or the `match`, `e-match` and `c-match` of +an inference rule) is a mistake in the rule and is reported as the rule loads. + +A positional (Ξ±) application argument is written as `Ξ±0`, `~0` (ASCII), or +`α𝑖`/`~!i` when its index is captured by an `!i`/`𝑖` meta variable. + +Incorrect usage of meta variables in πœ‘-expression patterns leads to +parsing errors. + +## Benchmark + +To run performance benchmarks, you need [Java 8+][java] and [curl][curl]. +Maven is downloaded automatically on first run via `benchmark/mvnw`. + +The benchmark uses the compiled [`Native`][jna-native] class from +[JNA][jna] β€” a large real-world Java class β€” as its test input. +On first run, `make bench` downloads the class, disassembles it to +[XMIR][xmir] via [jeo-maven-plugin][jeo], converts it to πœ‘ using +`phino rewrite`, and caches the results in `benchmark/tmp/`. +Subsequent runs skip straight to the benchmarks. + +Besides parsing, printing and rewriting that class, the suite morphs +symbolically. `benchmark/demo.phi` is a small world whose entries name the Ξ» +functions of `benchmark/atoms.yaml`, and each entry is a case of its own, so +that a slowdown of one of them is a line of the report rather than a share of +a single total. The smallest entry β€” one Ξ» function fired against one unknown +β€” is timed twice, over the demo world alone and over the same world merged +into the class, and the two numbers say between them what the world around an +entry costs (see [#1291][issue-1291]). + +A case whose single run is measured in seconds gets fewer warmups and fewer +batches than a case measured in microseconds, since the whole suite runs +inside one job; the report says how many of each a case was given. + +```bash +make bench +``` + + + +```text +=== parse/phi === + warmup: 3 iterations + batches: 10 x 1 + total: 1785285.297 ΞΌs + avg: 178528.530 ΞΌs + min: 164868.992 ΞΌs + max: 209121.132 ΞΌs + std dev: 15515.800 ΞΌs +=== parse/xmir === + warmup: 3 iterations + batches: 10 x 1 + total: 7506298.288 ΞΌs + avg: 750629.829 ΞΌs + min: 683506.496 ΞΌs + max: 819105.157 ΞΌs + std dev: 44112.176 ΞΌs +=== rewrite/normalize === + warmup: 3 iterations + batches: 10 x 1 + total: 495636.638 ΞΌs + avg: 49563.664 ΞΌs + min: 48083.779 ΞΌs + max: 51678.568 ΞΌs + std dev: 1163.452 ΞΌs +=== print/sweet/multiline === + warmup: 3 iterations + batches: 10 x 1 + total: 4148167.742 ΞΌs + avg: 414816.774 ΞΌs + min: 390353.762 ΞΌs + max: 438468.832 ΞΌs + std dev: 15702.253 ΞΌs +=== print/sweet/flat === + warmup: 3 iterations + batches: 10 x 1 + total: 4103860.150 ΞΌs + avg: 410386.015 ΞΌs + min: 400487.779 ΞΌs + max: 422099.714 ΞΌs + std dev: 6878.840 ΞΌs +=== print/salty/multiline === + warmup: 3 iterations + batches: 10 x 1 + total: 13505706.601 ΞΌs + avg: 1350570.660 ΞΌs + min: 1323552.942 ΞΌs + max: 1388589.251 ΞΌs + std dev: 22111.111 ΞΌs +=== morph/symbolic/demo/e1 === + warmup: 3 iterations + batches: 10 x 1 + total: 16623322.804 ΞΌs + avg: 1662332.280 ΞΌs + min: 1634287.226 ΞΌs + max: 1712122.691 ΞΌs + std dev: 26925.390 ΞΌs +=== morph/symbolic/demo/e2 === + warmup: 2 iterations + batches: 4 x 1 + total: 18971323.304 ΞΌs + avg: 4742830.826 ΞΌs + min: 4710439.768 ΞΌs + max: 4785557.203 ΞΌs + std dev: 31923.645 ΞΌs +=== morph/symbolic/demo/e3 === + warmup: 3 iterations + batches: 10 x 1 + total: 9393523.305 ΞΌs + avg: 939352.330 ΞΌs + min: 926573.125 ΞΌs + max: 955737.287 ΞΌs + std dev: 9251.489 ΞΌs +=== morph/symbolic/demo/e4 === + warmup: 3 iterations + batches: 10 x 1 + total: 6172093.232 ΞΌs + avg: 617209.323 ΞΌs + min: 609699.156 ΞΌs + max: 622461.534 ΞΌs + std dev: 3958.833 ΞΌs +=== morph/symbolic/demo/e5 === + warmup: 3 iterations + batches: 10 x 1 + total: 657478.162 ΞΌs + avg: 65747.816 ΞΌs + min: 64867.966 ΞΌs + max: 66985.074 ΞΌs + std dev: 698.720 ΞΌs +=== morph/symbolic/native/e5 === + warmup: 0 iterations + batches: 1 x 1 + total: 24700300.710 ΞΌs + avg: 24700300.710 ΞΌs + min: 24700300.710 ΞΌs + max: 24700300.710 ΞΌs + std dev: 0.000 ΞΌs +``` + +The results were calculated in [this GHA job][benchmark-gha] +on 2026-09-18 at 21:12, +on Linux with 4 CPUs. + + + +## How to Contribute + +Fork repository, make changes, then send us a [pull request][guidelines]. +We will review your changes and apply them to the `master` branch shortly, +provided they don't violate our quality standards. To avoid frustration, +before sending us your pull request please make sure all your tests pass: + +```bash +make all +``` + +To generate a local coverage report for development, run: + +```bash +make coverage +``` + +To build a `phino` executable into the root of the repository, run: + +```bash +make phino +``` + +This produces an executable `phino` (or `phino.exe` on Windows) in the +project root, which you can run directly for quick local testing: + +```bash +./phino --version +``` + +You will need [GHC β‰₯ 9.6.7][GHC] and [Cabal β‰₯ 3.0 (recommended)][cabal] +or [Stack β‰₯ 3.0][stack] installed. + +[cabal]: https://www.haskell.org/cabal/ +[stack]: https://docs.haskellstack.org/en/stable/install_and_upgrade/ +[GHC]: https://www.haskell.org/ghc/ +[guidelines]: https://www.yegor256.com/2014/04/15/github-guidelines.html +[xmir]: https://news.eolang.org/2022-11-25-xmir-guide.html +[latex]: https://en.wikipedia.org/wiki/LaTeX +[java]: https://www.java.com/en/download/ +[curl]: https://curl.se/ +[jna]: https://github.com/java-native-access/jna +[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/35395119960 diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -3,20 +3,28 @@ module Main where -import AST (Expression (ExRoot)) +import AST (Expression (ExRoot), hashExpression) +import CLI.Helpers (started) import Control.Exception (evaluate) import Control.Monad (replicateM, replicateM_) +import qualified Data.Map.Strict as Map import Data.Time.Clock -import Deps (dontSaveStep) +import Dataize (reduction) +import Deps (Judgment (Morphing), dontSaveEval, dontSaveStep) import Encoding (Encoding (UNICODE)) +import Evaluate (evaluation, fired) import Functions (buildTerm) +import Lambdas (Lambdas, readLambdas) import Lining (LineFormat (MULTILINE, SINGLELINE)) import Margin (defaultMargin) +import Merge (merge) +import Morph (ReduceContext (ReduceContext), Steps (Steps), morph) import Must (Must (MtDisabled)) import Parser (parseExpressionThrows) import Printer (printExpression') import Rewriter (RewriteContext (RewriteContext), rewrite) import Sugar (SugarType (SALTY, SWEET)) +import Tau (seedTaus) import Text.Printf (printf) import XMIR (parseXMIRThrows, xmirToPhi) import Yaml (normalizationRules) @@ -30,6 +38,20 @@ targetBatchMs :: Double targetBatchMs = 20.0 +-- The wall-clock, in microseconds, one case may spend on its warmups and its +-- measured batches together. Every case that only parses, prints or rewrites +-- runs in microseconds and batches up to the window above, so ten batches of +-- it cost a fraction of a second and the budget never binds. A symbolic +-- morphing takes whole seconds per run, and inside a world the size of +-- 'native.phi' tens of them, so three warmups plus ten batches of one would +-- outlast the jobs the workflows run the suite in β€” 'regression-check' runs +-- the whole binary ten times over, once per round per side. The warmups and +-- the iterations are therefore cut to what the budget affords, never below one +-- measured batch, so an expensive case still reports the same lines as every +-- other one. +budget :: Double +budget = 30.0 * 1e6 + rewriteCtx :: RewriteContext rewriteCtx = RewriteContext @@ -37,11 +59,48 @@ 100 100 False + Nothing buildTerm MtDisabled Nothing dontSaveStep +-- The step budget, the rewriting bounds and the flags the symbolic cases morph +-- with, which are the defaults of the 'morph' command plus the three switches +-- the regression was seen under: '--deep', so a Ξ» function standing anywhere +-- inside the term is fired and not only the one on the spine; '--acyclic', so +-- a term coming back to itself parks instead of spending the whole step +-- budget; and '--partial', so a Ξ» function no entry answers parks too and the +-- run still reaches an answer to measure. Nothing is written anywhere: the +-- protocol of '--protocol' and the steps of '--steps-dir' are files, and a +-- benchmark measuring the calculus has no business measuring the disk. +symbolicCtx :: Lambdas -> Expression -> ReduceContext +symbolicCtx lambdas locator = + ReduceContext + locator -- _locator + locator -- _site + Nothing -- _universe + 25 -- _maxDepth + 25 -- _maxCycles + (Steps 1000 0) -- _steps + 1 -- _nesting + False -- _depthSensitive + False -- _shuffle + True -- _partial + True -- _deep + True -- _acyclic + Morphing -- _judgment + [] -- _parked + Map.empty -- _seen + Map.empty -- _dataized + lambdas -- _symbolic + buildTerm -- _buildTerm + reduction -- _reduce + evaluation -- _evaluate + fired -- _fire + dontSaveStep -- _saveStep + dontSaveEval -- _saveEval + timeAction :: IO a -> IO Double timeAction action = do start <- getCurrentTime @@ -56,27 +115,26 @@ end <- getCurrentTime pure (realToFrac (diffUTCTime end start) * 1e6 / fromIntegral batch) -calibrate :: IO a -> IO Int -calibrate action = do - t <- timeAction action - pure (max 1 (round (targetBatchMs * 1000.0 / t))) - stdDev :: [Double] -> Double -> Double stdDev xs avg = sqrt (sum (map (\x -> (x - avg) ^ (2 :: Int)) xs) / fromIntegral (length xs)) runBench :: String -> IO a -> IO () runBench name action = do - replicateM_ warmups action - batch <- calibrate action - times <- replicateM iterations (timeBatch batch action) + single <- timeAction action + let batch = max 1 (round (targetBatchMs * 1000.0 / single)) + afford = max 1 (floor (budget / (single * fromIntegral batch)) :: Int) + warms = max 0 (min warmups (afford `div` 3)) + iters = max 1 (min iterations (afford - warms)) + replicateM_ warms action + times <- replicateM iters (timeBatch batch action) let total = sum times * fromIntegral batch - avg = sum times / fromIntegral iterations + avg = sum times / fromIntegral iters mn = minimum times mx = maximum times sd = stdDev times avg putStrLn $ "=== " ++ name ++ " ===" - putStrLn $ printf " warmup: %d iterations" warmups - putStrLn $ printf " batches: %d x %d" iterations batch + putStrLn $ printf " warmup: %d iterations" warms + putStrLn $ printf " batches: %d x %d" iters batch putStrLn $ printf " total: %.3f ΞΌs" total putStrLn $ printf " avg: %.3f ΞΌs" avg putStrLn $ printf " min: %.3f ΞΌs" mn @@ -87,7 +145,11 @@ main = do src <- readFile "benchmark/tmp/native.phi" xsrc <- readFile "benchmark/tmp/Native.xmir" + dsrc <- readFile "benchmark/demo.phi" expr <- parseExpressionThrows src + demo <- parseExpressionThrows dsrc + merged <- merge [demo, expr] + lambdas <- readLambdas "benchmark/atoms.yaml" runBench "parse/phi" (parseExpressionThrows src) runBench "parse/xmir" (parseXMIRThrows xsrc >>= xmirToPhi) runBench "rewrite/normalize" (rewrite expr normalizationRules rewriteCtx) @@ -100,3 +162,39 @@ runBench "print/salty/multiline" (evaluate (length (printExpression' expr (SALTY, UNICODE, MULTILINE, defaultMargin)))) + mapM_ (aimed "demo" demo lambdas) entries + aimed "native" merged lambdas probe + where + -- The entries of the demo world, each one term the Ξ» functions of + -- 'benchmark/atoms.yaml' answer and each one case of the suite, so that a + -- slowdown of one of them is a line of its own rather than a share of a + -- single total. + entries :: [String] + entries = ["e1", "e2", "e3", "e4", "e5"] + -- The one entry timed inside 'native.phi' as well, whose two numbers say + -- between them what the world around an entry costs β€” the very comparison + -- nothing in the suite used to make, and the one 'number.neg' was seen to + -- lose two orders of magnitude on (#1291). It is the smallest entry of the + -- demo world, a single Ξ» function fired against one unknown, because the + -- cost measured here is the world's and not the term's: the bigger entries + -- pay the same price per firing and merely pay it more often, which inside + -- a megabyte of 'native.phi' is more than a benchmark can wait for. + probe :: String + probe = "e5" + -- One case of the symbolic suite: the entry of the demo world 𝕄 is aimed + -- at, inside the world it is aimed in. + aimed :: String -> Expression -> Lambdas -> String -> IO () + aimed label universe lambdas name = do + locator <- parseExpressionThrows ("Ξ¦.l🌡." ++ name) + runBench (printf "morph/symbolic/%s/%s" label name) (symbolic universe lambdas locator) + -- One symbolic morphing of one entry, the way the 'morph' command runs it: + -- the 𝜏-labels of the universe are scanned once, the run starts from the + -- state that world already carries and 𝕄 is aimed at the entry. The answer + -- is hashed rather than merely forced to weak head normal form, since a + -- term left as a thunk is work the benchmark asked for and did not wait + -- for. + symbolic :: Expression -> Lambdas -> Expression -> IO Int + symbolic universe lambdas locator = do + seedTaus universe + (answer, _, _) <- morph universe (started universe) (symbolicCtx lambdas locator) + pure (hashExpression answer) diff --git a/benchmark/atoms.yaml b/benchmark/atoms.yaml new file mode 100644 --- /dev/null +++ b/benchmark/atoms.yaml @@ -0,0 +1,54 @@ +# SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +# SPDX-License-Identifier: MIT +--- +# yamllint disable rule:line-length +# The Ξ» functions the symbolic cases of the benchmark fire over +# 'benchmark/demo.phi'. phino implements none of them, so without this file +# every Ξ» function that world names would get stuck and nothing would be +# measured. Every entry answers symbolically: the operands come down through 𝔻 +# or reach a normal form through 𝕄, and the term under '𝑛' carries a fresh +# symbol 𝜎 standing for the value nobody worked out. Nothing here computes, +# which is what makes the morphing symbolic and what keeps the numbers below a +# measure of phino rather than of arithmetic. + +# Arithmetic over two numbers answers a number nobody has worked out. +- Ξ»: L_number_(plus|times) + dataize: + 𝛿1: $.ρ + 𝛿2: $.x + 𝑛: Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎 ⟧ ) ) + +# Comparing two numbers answers a bool nobody has decided, carrying the fork +# below as its 'if', which is what the branching cases of the demo world then +# dispatch. +- Ξ»: L_number_gt + dataize: + 𝛿1: $.ρ + 𝛿2: $.x + 𝑛: Ξ¦.bool( if ↦ ⟦ Ξ» ‍ L_fork, left ↦ βˆ…, right ↦ βˆ…, Ο† ↦ ⟦ Ξ» ‍ 𝜎 ⟧ ⟧ ) + +# A branch answers neither of its sides: nobody has picked between the two, so +# both of them reach a normal form through 𝕄, are stood into unknowns and are +# joined into the one shape they share. +- Ξ»: L_fork + dataize: + 𝛿1: $.Ο† + morph: + 𝑛1: $.left + 𝑛2: $.right + symbolize: + 𝑛3: 𝑛1 + 𝑛4: 𝑛2 + join: + 𝑛5: [𝑛3, 𝑛4] + 𝑛: 𝑛5 + +# An entry of the demo world: its number comes down through 𝔻 and the term it +# marks reaches a normal form through 𝕄, which is the work the symbolic cases +# time. +- Ξ»: L_entry + dataize: + 𝛿1: $.n + morph: + 𝑛1: $.v.Ο† + 𝑛: 𝑛1 diff --git a/benchmark/demo.phi b/benchmark/demo.phi new file mode 100644 --- /dev/null +++ b/benchmark/demo.phi @@ -0,0 +1,26 @@ +⟦ + bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, + bool ↦ ⟦ if ↦ βˆ… ⟧, + number ↦ ⟦ + Ο† ↦ βˆ…, + plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, + times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧, + gt(x) ↦ ⟦ Ξ» ‍ L_number_gt ⟧, + neg ↦ ⟦ Ο† ↦ ΞΎ.ρ.times( -1 ) ⟧, + minus(x) ↦ ⟦ Ο† ↦ ΞΎ.ρ.plus( ΞΎ.x.neg ) ⟧ + ⟧, + demo ↦ ⟦ + gap(a, b) ↦ ⟦ Ο† ↦ ΞΎ.a.minus( ΞΎ.b ).times( ΞΎ.a.minus( ΞΎ.b ) ) ⟧, + far(p, q) ↦ ⟦ Ο† ↦ Ξ¦.demo.gap( ΞΎ.p, ΞΎ.q ).gt( 100 ) ⟧, + clamp(x, lo, hi) ↦ ⟦ Ο† ↦ ΞΎ.x.gt( ΞΎ.hi ).if( ΞΎ.hi, ΞΎ.lo.gt( ΞΎ.x ).if( ΞΎ.lo, ΞΎ.x ) ) ⟧, + twice(t) ↦ ⟦ Ο† ↦ ΞΎ.t.gt( 0 ).if( ΞΎ.t.plus( 1 ), ΞΎ.t.plus( 2 ) ).plus( ΞΎ.t.plus( 1 ) ) ⟧ + ⟧, + l🌡 ↦ ⟦ + mark(n, v) ↦ ⟦ Ξ» ‍ L_entry ⟧, + e1 ↦ Ξ¦.l🌡.mark( 1, Ξ¦.demo.gap( Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) ), Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ) ) ) ), + e2 ↦ Ξ¦.l🌡.mark( 2, Ξ¦.demo.far( Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎3 ⟧ ) ), Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎4 ⟧ ) ) ) ), + e3 ↦ Ξ¦.l🌡.mark( 3, Ξ¦.demo.clamp( Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧ ) ), Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎6 ⟧ ) ), Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎7 ⟧ ) ) ) ), + e4 ↦ Ξ¦.l🌡.mark( 4, Ξ¦.demo.twice( Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎8 ⟧ ) ) ) ), + e5 ↦ Ξ¦.l🌡.mark( 5, Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎9 ⟧ ) ).neg ) + ⟧ +⟧ diff --git a/phino.cabal b/phino.cabal --- a/phino.cabal +++ b/phino.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: phino -version: 0.0.133 +version: 0.0.134 license: MIT synopsis: Command-Line Manipulator of πœ‘-Calculus Expressions description: Please see the README on GitHub at @@ -12,7 +12,7 @@ copyright: 2025 Objectionary.com category: Language, Code Analysis build-type: Simple -extra-source-files: resources/normalize/*.yaml resources/morphing/*.yaml resources/dataization/*.yaml resources/contextualization/*.yaml +extra-source-files: resources/normalize/*.yaml resources/morphing/*.yaml resources/dataization/*.yaml resources/contextualization/*.yaml benchmark/demo.phi benchmark/atoms.yaml extra-doc-files: README.md source-repository head @@ -35,7 +35,6 @@ import: warnings exposed-modules: AST - Atoms Builder Bytes Canonizer @@ -50,9 +49,11 @@ Dataize Deps Encoding + Evaluate Files Filter Functions + Lambdas LaTeX Lining Locator @@ -60,6 +61,7 @@ Margin Matcher Merge + Metas Misc Morph Must @@ -97,7 +99,6 @@ gitrev >=1.3.1 && <1.4, megaparsec >=9.5 && <9.9, optparse-applicative >=0.18 && <0.20, - process >=1.6.17 && <1.7, random >=1.2 && <1.4, regex-pcre-builtin >=0.95.2 && <0.96, scientific >=0.3.7 && <0.4, @@ -129,7 +130,6 @@ hs-source-dirs: test other-modules: ASTSpec - AtomsSpec BuilderSpec BytesSpec CanonizerSpec @@ -141,10 +141,12 @@ DataizeSpec DepsSpec EncodingSpec + EvaluateSpec FilesSpec FilterSpec Fixtures FunctionsSpec + LambdasSpec LaTeXSpec LiningSpec LocatorSpec @@ -152,6 +154,7 @@ MarginSpec MatcherSpec MergeSpec + MetasSpec MiscSpec MorphSpec MustSpec @@ -188,7 +191,6 @@ megaparsec >=9.5 && <9.9, optparse-applicative >=0.18 && <0.20, phino, - process >=1.6.17 && <1.7, silently >=1.2.5 && <1.3, text >=2.0.2 && <2.2, time >=1.12 && <1.17, @@ -208,6 +210,7 @@ hs-source-dirs: benchmark build-depends: base >=4.18.3.0 && <5, + containers >=0.6.5 && <0.9, phino, time >=1.12 && <1.17, diff --git a/resources/contextualization/ca.yaml b/resources/contextualization/ca.yaml --- a/resources/contextualization/ca.yaml +++ b/resources/contextualization/ca.yaml @@ -2,15 +2,15 @@ # SPDX-License-Identifier: MIT --- name: ca -match: '𝑛0(𝜏0 ↦ 𝑒1)' -c-match: π‘˜0 -c-result: '𝑛1(𝜏0 ↦ 𝑛2)' +match: '𝑛1(𝜏1 ↦ 𝑒1)' +c-match: π‘˜1 +c-result: '𝑛2(𝜏1 ↦ 𝑛3)' premises: - - n-result: 𝑛1 - contextualize: - - 𝑛0 - - π‘˜0 - n-result: 𝑛2 contextualize: + - 𝑛1 + - π‘˜1 + - n-result: 𝑛3 + contextualize: - 𝑒1 - - π‘˜0 + - π‘˜1 diff --git a/resources/contextualization/caa.yaml b/resources/contextualization/caa.yaml --- a/resources/contextualization/caa.yaml +++ b/resources/contextualization/caa.yaml @@ -2,15 +2,15 @@ # SPDX-License-Identifier: MIT --- name: caa -match: '𝑛0(α𝑖0 ↦ 𝑒1)' -c-match: π‘˜0 -c-result: '𝑛1(α𝑖0 ↦ 𝑛2)' +match: '𝑛1(α𝑖1 ↦ 𝑒1)' +c-match: π‘˜1 +c-result: '𝑛2(α𝑖1 ↦ 𝑛3)' premises: - - n-result: 𝑛1 - contextualize: - - 𝑛0 - - π‘˜0 - n-result: 𝑛2 contextualize: + - 𝑛1 + - π‘˜1 + - n-result: 𝑛3 + contextualize: - 𝑒1 - - π‘˜0 + - π‘˜1 diff --git a/resources/contextualization/cd.yaml b/resources/contextualization/cd.yaml --- a/resources/contextualization/cd.yaml +++ b/resources/contextualization/cd.yaml @@ -2,11 +2,11 @@ # SPDX-License-Identifier: MIT --- name: cd -match: '𝑛0.𝜏0' -c-match: π‘˜0 -c-result: '𝑛1.𝜏0' +match: '𝑛1.𝜏1' +c-match: π‘˜1 +c-result: '𝑛2.𝜏1' premises: - - n-result: 𝑛1 + - n-result: 𝑛2 contextualize: - - 𝑛0 - - π‘˜0 + - 𝑛1 + - π‘˜1 diff --git a/resources/contextualization/cf.yaml b/resources/contextualization/cf.yaml --- a/resources/contextualization/cf.yaml +++ b/resources/contextualization/cf.yaml @@ -2,6 +2,6 @@ # SPDX-License-Identifier: MIT --- name: cf -match: ⟦𝐡0⟧ -c-match: π‘˜0 -c-result: ⟦𝐡0⟧ +match: ⟦𝐡1⟧ +c-match: π‘˜1 +c-result: ⟦𝐡1⟧ diff --git a/resources/contextualization/cg.yaml b/resources/contextualization/cg.yaml --- a/resources/contextualization/cg.yaml +++ b/resources/contextualization/cg.yaml @@ -3,5 +3,5 @@ --- name: cg match: Ξ¦ -c-match: π‘˜0 +c-match: π‘˜1 c-result: Ξ¦ diff --git a/resources/contextualization/ct.yaml b/resources/contextualization/ct.yaml --- a/resources/contextualization/ct.yaml +++ b/resources/contextualization/ct.yaml @@ -3,5 +3,5 @@ --- name: ct match: βŠ₯ -c-match: π‘˜0 +c-match: π‘˜1 c-result: βŠ₯ diff --git a/resources/contextualization/cxi.yaml b/resources/contextualization/cxi.yaml --- a/resources/contextualization/cxi.yaml +++ b/resources/contextualization/cxi.yaml @@ -3,5 +3,5 @@ --- name: cxi match: ΞΎ -c-match: π‘˜0 -c-result: π‘˜0 +c-match: π‘˜1 +c-result: π‘˜1 diff --git a/resources/dataization/box.yaml b/resources/dataization/box.yaml --- a/resources/dataization/box.yaml +++ b/resources/dataization/box.yaml @@ -2,19 +2,19 @@ # SPDX-License-Identifier: MIT --- name: box -match: ⟦𝐡1, Ο† ↦ 𝑒1, 𝐡2⟧ -e-match: 𝑒0 -d-result: Ξ΄0 +match: ⟦𝐡1, Ο† ↦ 𝑒2, 𝐡2⟧ +e-match: 𝑒1 +d-result: 𝛿1 when: disjoint: - [Ξ”, Ξ»] - [𝐡1, 𝐡2] premises: - - n-result: 𝑒2 + - n-result: 𝑒3 contextualize: - - 𝑒1 - - ⟦𝐡1, Ο† ↦ 𝑒1, 𝐡2⟧ + - 𝑒2 + - ⟦𝐡1, Ο† ↦ 𝑒2, 𝐡2⟧ - n-result: 𝑛1 - normalize: 𝑒2 - - d-result: Ξ΄0 + normalize: 𝑒3 + - d-result: 𝛿1 dataize: 𝑛1 diff --git a/resources/dataization/delta.yaml b/resources/dataization/delta.yaml --- a/resources/dataization/delta.yaml +++ b/resources/dataization/delta.yaml @@ -3,6 +3,6 @@ --- name: delta label: \Delta -match: ⟦𝐡1, Ξ” ‍ Ξ΄0, 𝐡2⟧ -e-match: 𝑒0 -d-result: Ξ΄0 +match: ⟦𝐡1, Ξ” ‍ 𝛿1, 𝐡2⟧ +e-match: 𝑒1 +d-result: 𝛿1 diff --git a/resources/dataization/fire.yaml b/resources/dataization/fire.yaml --- a/resources/dataization/fire.yaml +++ b/resources/dataization/fire.yaml @@ -2,13 +2,13 @@ # SPDX-License-Identifier: MIT --- name: fire -match: ⟦𝐡1, Ξ» ‍ 𝑓0, 𝐡2⟧ -e-match: 𝑒0 -d-result: Ξ΄0 +match: ⟦𝐡1, Ξ» ‍ 𝑓1, 𝐡2⟧ +e-match: 𝑒1 +d-result: 𝛿1 premises: - n-result: 𝑛1 evaluate: - - ⟦𝐡1, Ξ» ‍ 𝑓0, 𝐡2⟧ - - 𝑒0 - - d-result: Ξ΄0 + - ⟦𝐡1, Ξ» ‍ 𝑓1, 𝐡2⟧ + - 𝑒1 + - d-result: 𝛿1 dataize: 𝑛1 diff --git a/resources/dataization/none.yaml b/resources/dataization/none.yaml --- a/resources/dataization/none.yaml +++ b/resources/dataization/none.yaml @@ -2,13 +2,13 @@ # SPDX-License-Identifier: MIT --- name: none -match: ⟦𝐡0⟧ -e-match: 𝑒0 -d-result: Ξ΄0 +match: ⟦𝐡1⟧ +e-match: 𝑒1 +d-result: 𝛿1 when: disjoint: - [Ξ”, Ξ», Ο†] - - [𝐡0] + - [𝐡1] premises: - - d-result: Ξ΄0 + - d-result: 𝛿1 dataize: βŠ₯ diff --git a/resources/dataization/norm.yaml b/resources/dataization/norm.yaml --- a/resources/dataization/norm.yaml +++ b/resources/dataization/norm.yaml @@ -2,19 +2,19 @@ # SPDX-License-Identifier: MIT --- name: norm -match: 𝑛0 -e-match: 𝑒0 -d-result: Ξ΄0 +match: 𝑛1 +e-match: 𝑒1 +d-result: 𝛿1 when: and: - not: - formation: 𝑛0 + formation: 𝑛1 - not: eq: - - 𝑛0 + - 𝑛1 - βŠ₯ premises: - - n-result: 𝑛1 - morph: 𝑛0 - - d-result: Ξ΄0 - dataize: 𝑛1 + - n-result: 𝑛2 + morph: 𝑛1 + - d-result: 𝛿1 + dataize: 𝑛2 diff --git a/resources/morphing/dead.yaml b/resources/morphing/dead.yaml --- a/resources/morphing/dead.yaml +++ b/resources/morphing/dead.yaml @@ -3,5 +3,5 @@ --- name: dead match: βŠ₯ -e-match: 𝑒0 +e-match: 𝑒1 n-result: βŠ₯ diff --git a/resources/morphing/ma.yaml b/resources/morphing/ma.yaml --- a/resources/morphing/ma.yaml +++ b/resources/morphing/ma.yaml @@ -2,13 +2,13 @@ # SPDX-License-Identifier: MIT --- name: ma -match: '𝑛0(𝜏0 ↦ π‘˜1)' -e-match: 𝑒0 -n-result: 𝑛3 +match: '𝑛1(𝜏1 ↦ π‘˜1)' +e-match: 𝑒1 +n-result: 𝑛4 premises: - - n-result: 𝑛1 - morph: 𝑛0 - n-result: 𝑛2 - normalize: '𝑛1(𝜏0 ↦ π‘˜1)' + morph: 𝑛1 - n-result: 𝑛3 - morph: 𝑛2 + normalize: '𝑛2(𝜏1 ↦ π‘˜1)' + - n-result: 𝑛4 + morph: 𝑛3 diff --git a/resources/morphing/maa.yaml b/resources/morphing/maa.yaml --- a/resources/morphing/maa.yaml +++ b/resources/morphing/maa.yaml @@ -2,13 +2,13 @@ # SPDX-License-Identifier: MIT --- name: maa -match: '𝑛0(α𝑖0 ↦ π‘˜1)' -e-match: 𝑒0 -n-result: 𝑛3 +match: '𝑛1(α𝑖1 ↦ π‘˜1)' +e-match: 𝑒1 +n-result: 𝑛4 premises: - - n-result: 𝑛1 - morph: 𝑛0 - n-result: 𝑛2 - normalize: '𝑛1(α𝑖0 ↦ π‘˜1)' + morph: 𝑛1 - n-result: 𝑛3 - morph: 𝑛2 + normalize: '𝑛2(α𝑖1 ↦ π‘˜1)' + - n-result: 𝑛4 + morph: 𝑛3 diff --git a/resources/morphing/maad.yaml b/resources/morphing/maad.yaml --- a/resources/morphing/maad.yaml +++ b/resources/morphing/maad.yaml @@ -3,7 +3,7 @@ --- name: maad match: '𝑛(α𝑖 ↦ 𝑛1)' -e-match: 𝑒0 +e-match: 𝑒1 n-result: 𝑛2 when: not: diff --git a/resources/morphing/mad.yaml b/resources/morphing/mad.yaml --- a/resources/morphing/mad.yaml +++ b/resources/morphing/mad.yaml @@ -3,7 +3,7 @@ --- name: mad match: '𝑛(𝜏 ↦ 𝑛1)' -e-match: 𝑒0 +e-match: 𝑒1 n-result: 𝑛2 when: not: diff --git a/resources/morphing/md.yaml b/resources/morphing/md.yaml --- a/resources/morphing/md.yaml +++ b/resources/morphing/md.yaml @@ -2,16 +2,16 @@ # SPDX-License-Identifier: MIT --- name: md -match: '𝑛0.𝜏0' -e-match: 𝑒0 -n-result: 𝑛3 +match: '𝑛1.𝜏1' +e-match: 𝑒1 +n-result: 𝑛4 when: not: - formation: 𝑛0 + formation: 𝑛1 premises: - - n-result: 𝑛1 - morph: 𝑛0 - n-result: 𝑛2 - normalize: '𝑛1.𝜏0' + morph: 𝑛1 - n-result: 𝑛3 - morph: 𝑛2 + normalize: '𝑛2.𝜏1' + - n-result: 𝑛4 + morph: 𝑛3 diff --git a/resources/morphing/mf.yaml b/resources/morphing/mf.yaml --- a/resources/morphing/mf.yaml +++ b/resources/morphing/mf.yaml @@ -2,6 +2,6 @@ # SPDX-License-Identifier: MIT --- name: mf -match: ⟦𝐡0⟧ -e-match: 𝑒0 -n-result: ⟦𝐡0⟧ +match: ⟦𝐡1⟧ +e-match: 𝑒1 +n-result: ⟦𝐡1⟧ diff --git a/resources/morphing/ml.yaml b/resources/morphing/ml.yaml --- a/resources/morphing/ml.yaml +++ b/resources/morphing/ml.yaml @@ -3,15 +3,15 @@ --- name: ml label: \lambda -match: '⟦𝐡1, Ξ» ‍ 𝑓0, 𝐡2⟧.𝜏0' -e-match: 𝑒0 +match: '⟦𝐡1, Ξ» ‍ 𝑓1, 𝐡2⟧.𝜏1' +e-match: 𝑒1 n-result: 𝑛3 premises: - n-result: 𝑛1 evaluate: - - '⟦𝐡1, Ξ» ‍ 𝑓0, 𝐡2⟧' - - 𝑒0 + - '⟦𝐡1, Ξ» ‍ 𝑓1, 𝐡2⟧' + - 𝑒1 - n-result: 𝑛2 - normalize: '𝑛1.𝜏0' + normalize: '𝑛1.𝜏1' - n-result: 𝑛3 morph: 𝑛2 diff --git a/resources/morphing/mphi.yaml b/resources/morphing/mphi.yaml --- a/resources/morphing/mphi.yaml +++ b/resources/morphing/mphi.yaml @@ -3,24 +3,24 @@ --- name: mphi label: \varphi -match: ⟦𝐡0⟧.𝜏0 -e-match: 𝑒0 +match: ⟦𝐡1⟧.𝜏1 +e-match: 𝑒1 n-result: 𝑛2 when: and: - in: - Ο† - - 𝐡0 + - 𝐡1 - not: in: - - 𝜏0 - - 𝐡0 + - 𝜏1 + - 𝐡1 - not: in: - Ξ» - - 𝐡0 + - 𝐡1 premises: - n-result: 𝑛1 - normalize: ⟦𝐡0⟧.Ο†.𝜏0 + normalize: ⟦𝐡1⟧.Ο†.𝜏1 - n-result: 𝑛2 morph: 𝑛1 diff --git a/resources/morphing/universe.yaml b/resources/morphing/universe.yaml --- a/resources/morphing/universe.yaml +++ b/resources/morphing/universe.yaml @@ -4,15 +4,15 @@ name: universe label: \Phi match: Ξ¦ -e-match: 𝑒0 +e-match: 𝑒1 n-result: 𝑛2 when: not: eq: - - 𝑒0 + - 𝑒1 - Ξ¦ premises: - n-result: 𝑛1 - normalize: 𝑒0 + normalize: 𝑒1 - n-result: 𝑛2 morph: 𝑛1 diff --git a/resources/morphing/xi.yaml b/resources/morphing/xi.yaml --- a/resources/morphing/xi.yaml +++ b/resources/morphing/xi.yaml @@ -3,7 +3,7 @@ --- name: xi match: ΞΎ -e-match: 𝑒0 +e-match: 𝑒1 n-result: 𝑛1 premises: - n-result: 𝑛1 diff --git a/resources/normalize/dot.yaml b/resources/normalize/dot.yaml --- a/resources/normalize/dot.yaml +++ b/resources/normalize/dot.yaml @@ -10,11 +10,22 @@ # βŸ¦β€¦, 𝜏1 ↦ 𝑛1, β€¦βŸ§.𝜏1 term and looping forever. ρ on line 'result' still binds # the full formation, so sibling and Ο†-decoration references stay intact β€” only # the self-ΞΎ path narrows, keeping normalization (near-)total. +# The formation the dispatch stands on is the whole program here and not a part +# of it; the 'dotg' sibling writes that one, and the two together cover every +# dispatch this one covered alone. Where no universe is known β€” the 'rewrite' +# command, and 'isNF' asking about a term on its own β€” 𝑒1 binds nothing, the +# guard cannot hold, and this rule answers every dispatch as it always did. name: dot pattern: ⟦𝐡1, 𝜏1 ↦ 𝑛1, 𝐡2⟧.𝜏1 -result: 𝑒1(ρ ↦ ⟦𝐡1, 𝜏1 ↦ 𝑛1, 𝐡2⟧) +e-match: 𝑒1 +when: + not: + eq: + - ⟦𝐡1, 𝜏1 ↦ 𝑛1, 𝐡2⟧ + - 𝑒1 +result: 𝑒2(ρ ↦ ⟦𝐡1, 𝜏1 ↦ 𝑛1, 𝐡2⟧) where: - - meta: 𝑒1 + - meta: 𝑒2 function: contextualize args: - 𝑛1 diff --git a/resources/normalize/dotg.yaml b/resources/normalize/dotg.yaml new file mode 100644 --- /dev/null +++ b/resources/normalize/dotg.yaml @@ -0,0 +1,28 @@ +# SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +# SPDX-License-Identifier: MIT +--- +# The 'dot' rule where the formation dispatched on is the whole program. Ξ¦ is +# the name of that formation, so the body is decorated with the name and not +# with the program: writing the program out copies it into the term, and into +# every term that term then dispatches, so the copies compound until one term +# weighs hundreds of times what the program does (#1318). Whoever reads the ρ +# resolves Ξ¦ through the 'universe' morphing rule, which answers with the +# program in normal form β€” the very formation that would have stood here, since +# a dispatch reaches this rule only once Ξ¦ has already been resolved that way. +# Everything else is 'dot': the same pattern, the same contextualization +# context, and a guard that is the exact complement of the one there, so the +# two never both answer a dispatch and never both refuse one. +name: dotg +pattern: ⟦𝐡1, 𝜏1 ↦ 𝑛1, 𝐡2⟧.𝜏1 +e-match: 𝑒1 +when: + eq: + - ⟦𝐡1, 𝜏1 ↦ 𝑛1, 𝐡2⟧ + - 𝑒1 +result: 𝑒2(ρ ↦ Ξ¦) +where: + - meta: 𝑒2 + function: contextualize + args: + - 𝑛1 + - ⟦𝐡1, 𝐡2⟧ diff --git a/src/AST.hs b/src/AST.hs --- a/src/AST.hs +++ b/src/AST.hs @@ -12,14 +12,15 @@ import Data.Bits (xor) import Data.List (foldl') +import Data.Maybe (listToMaybe) import Data.Text (Text) import qualified Data.Text as T import GHC.Generics (Generic) --- An anonymous meta-variable, written bare β€” 𝜏, 𝐡, 𝑒, 𝑛, π‘˜, Ξ΄, 𝑓 or 𝑖 with --- no index after it. It matches whatever term stands in its place and no rule +-- An anonymous meta-variable, written bare β€” 𝜏, 𝐡, 𝑒, 𝑛, π‘˜, 𝛿, 𝑓, 𝜎 or 𝑖 +-- with no index after it. It matches whatever term stands in its place and no rule -- can name it afterwards, so it is known only by the kind it was written as --- ('t', 'B', 'e', 'n', 'k', 'd', 'F', 'i') and by the offset it was written +-- ('t', 'B', 'e', 'n', 'k', 'd', 'F', 'S', 'i') and by the offset it was written -- at, which tells it apart from every other anonymous meta of the same term. data Slot = Slot Text Int deriving (Eq, Ord, Show) @@ -86,6 +87,17 @@ = Function Text | FnMeta Text | FnAny Slot + | {- | A symbol 𝜎1 β€” a Ξ» function nothing answers, which is what makes the + value the term it stands in carries unknown. It is a name and not a + meta-variable: no substitution ever binds it and the matcher never reads + it, while 'FnMeta' 𝑓1 stands for any Ξ» name at all, a symbol included. + -} + FnSymbol Int + | {- | A symbol written bare, 𝜎, which is an answer asking for a fresh one. + The slot it was written at tells two of them apart inside one answer, so + each is minted its own name (see 'minted' in 'Lambdas'). + -} + FnFresh Slot deriving (Eq, Generic, Show, Ord) instance Show Attribute where @@ -175,6 +187,51 @@ Function t -> hashText (step h 16) t FnMeta t -> hashText (step h 29) t FnAny slot -> goSlot (step h 37) slot + FnSymbol idx -> step (step h 38) idx + FnFresh slot -> goSlot (step h 39) slot + +-- Every symbol a term carries, in the order it was written. A symbol is what +-- makes the value a term stands for unknown, and the run reads the +-- dependencies between its firings off them: a term carrying 𝜎4 is the term +-- the firing that minted 𝜎4 answered with, whatever it has been rewritten +-- into since. +symbols :: Expression -> [Int] +symbols = goExpr + where + goExpr :: Expression -> [Int] + goExpr (ExFormation bds) = concatMap goBinding bds + goExpr (ExApplication expr arg) = goExpr expr ++ goArgument arg + goExpr (ExDispatch expr _) = goExpr expr + goExpr (ExPhiMeet _ _ expr) = goExpr expr + goExpr (ExPhiAgain _ _ expr) = goExpr expr + goExpr _ = [] + goBinding :: Binding -> [Int] + goBinding (BiTau _ expr) = goExpr expr + goBinding (BiLambda (FnSymbol idx)) = [idx] + goBinding _ = [] + goArgument :: Argument -> [Int] + goArgument (ArTau _ expr) = goExpr expr + goArgument (ArAlpha _ expr) = 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 +-- term: one sitting under ρ, or inside an operand, belongs to the term it was +-- minted for and says nothing about this one. This is how a firing is read as +-- the answer of an earlier firing. +denoted :: Expression -> Maybe Int +denoted = goExpr + where + goExpr :: Expression -> Maybe Int + goExpr (ExFormation bds) = listToMaybe (concatMap goBinding bds) + goExpr (ExApplication _ (ArTau AtPhi expr)) = goExpr expr + goExpr (ExApplication expr _) = goExpr expr + goExpr (ExPhiMeet _ _ expr) = goExpr expr + goExpr (ExPhiAgain _ _ expr) = goExpr expr + goExpr _ = Nothing + goBinding :: Binding -> [Int] + goBinding (BiLambda (FnSymbol idx)) = [idx] + goBinding (BiTau AtPhi expr) = maybe [] pure (goExpr expr) + goBinding _ = [] countNodes :: Expression -> Int countNodes (ExFormation bds) = 1 + sum (map nodesInBinding bds) + length bds diff --git a/src/Atoms.hs b/src/Atoms.hs deleted file mode 100644 --- a/src/Atoms.hs +++ /dev/null @@ -1,717 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - --- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com --- SPDX-License-Identifier: MIT - --- Which Ξ» functions exist is a property of the object model being dataized, --- not of the calculus. phino therefore implements none of them: it reads a --- registry of them from a JSON file given with '--atoms' and fires each one as --- a POSIX process. Each key of the registry is a regular expression over Ξ» --- names, tried top to bottom, and the first one matching the whole name of the --- atom being fired wins; its entry names the runtime that runs a script, or --- 'exec' and the path of a file that runs on its own, and says with 'serve' --- whether the program is to be started once and kept for the run: --- --- > { --- > "L_bytes_eq": { --- > "rt": "node", --- > "script": "const readline = require('readline'); ..." --- > }, --- > "L_number_plus": { --- > "rt": "exec", --- > "path": "/opt/eo/atoms/number-plus" --- > }, --- > ".*": { --- > "rt": "exec", --- > "path": "/opt/eo/atoms/resident", --- > "serve": true --- > } --- > } --- --- Whichever way it is run, a program speaks one protocol, in the letters of the --- evaluation rule of the calculus paper, 𝔼(𝑏, 𝑒, 𝑠) = 𝑛: one JSON object per --- line, the universe under '𝑒', then a request with an 'id', the Ξ» name under --- 'Ξ»' and the formation under '𝑏', answered by a line with the same 'id' and --- the πœ‘-expression under '𝑛'. --- --- The channel carries questions as well as answers. An operand reaches a --- program unreduced, since reducing it may take the very atom being fired, so --- instead of running a phino of its own on the universe with the operand --- spliced into its text, a program writes a line of its own: an 'id' it minted --- and, under 'ask', the πœ‘-expression it wants reduced. phino reduces it by --- re-entering its own evaluator and answers with that 'id' and the reduced --- expression under '𝑛'. Only a program kept for the run may ask: the stdin of --- one started for the fire is closed behind its request, so there is nothing --- left to answer it over. --- --- A kept program may also ask by reference, naming an operand instead of --- quoting it: 'of' carries the 'id' of a request still in flight, 'attr' the --- canonical name of an attribute of the receiver that request was made of, and --- the optional 'reduce' says whether to hand the node over as it is (false, --- by default) or to dataize it the way 'ask' does. phino serves such a --- question from the formation it already holds for that request, so neither --- side ever re-prints a receiver the other side has in hand (#1165). The --- 'attr' may go deeper than one name: 'ρ.length' is a path down the receiver, --- read left to right, since phino holds the whole of it anyway (#1207). It --- walks applications as well as formations, an argument being as much a --- binding as a Ο„ inside a formation (#1212). --- --- Whichever way it was asked, an answer says what the node under '𝑛' carries, --- so that no program keeps a πœ‘ reader of its own to tell a datum from a stuck --- atom: a formation with a Ξ” binding carries its byte array under 'Ξ”', one --- with a Ξ» binding the name of the function it is stuck on under 'Ξ»'. An --- attribute bound to nothing at all is a fact about the receiver and not a --- failure of the question, so it is answered with 'βˆ…' and no node (#1206). --- An answer that is not a formation but an application says under 'Ξ¦.' the --- chain it is dispatched off Ξ¦ by β€” 'number' for 'Ξ¦.number( Ο† ↦ … )' β€” since --- πœ‘-calculus types nothing nominally and that name is the only place the --- forma of a typed literal lives (#1210). --- A line of phino's is a request when it carries '𝑏' and an answer when it --- does not, since an answer may carry a 'Ξ»' of its own. --- --- The whole πœ‘-text on the channel is the currency of programs started for one --- fire: a kept one, able to ask for whatever the text left out, is served a --- lean one β€” '𝑏' and every answer carry no ρ chain, since that chain climbs --- to Ξ¦ and, through questions quoting earlier questions, compounds the --- message by the depth of the ask (#1165). --- --- A name no key matches has no Ξ» function at all: 𝔼 gets stuck on it, exactly --- as it does for a name no one ever declared (see 'Stuck' in 'Dataize'). -module Atoms - ( Atom (..) - , AtomException (..) - , Program (..) - , ReduceFunc - , Registry - , Runtime (..) - , Session (_program) - , closeRegistry - , emptyRegistry - , fireAtom - , readRegistry - , registeredAtom - , runtimeNames - ) -where - -import AST -import Builder (contextualize) -import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_, newMVar) -import Control.Exception (Exception, catch, onException, throwIO) -import Control.Monad (foldM, unless) -import Data.Aeson (FromJSON (parseJSON), eitherDecodeStrict', object, withObject, withText, (.!=), (.:), (.:?), (.=)) -import qualified Data.Aeson as A -import Data.Aeson.Decoding (toEitherValue) -import Data.Aeson.Decoding.ByteString (bsToTokens) -import Data.Aeson.Decoding.Tokens (TkRecord (TkPair, TkRecordEnd, TkRecordErr), Tokens (TkErr, TkRecordOpen)) -import qualified Data.Aeson.Key as Key -import Data.Aeson.Types (JSONPathElement (Key), Pair, parseEither, ()) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as BSL -import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) -import qualified Data.IntMap.Strict as IM -import Data.List (find, intercalate) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8) -import Encoding (Encoding (UNICODE)) -import Lining (LineFormat (SINGLELINE)) -import Logger (logDebug) -import Margin (defaultMargin) -import Parser (parseExpression) -import Printer (printAttribute, printBytes, printExpression', printExpressionHidingRho') -import Sugar (SugarType (SALTY)) -import System.Directory (doesFileExist, executable, getPermissions, getTemporaryDirectory, removePathForcibly) -import System.Exit (ExitCode (ExitFailure, ExitSuccess)) -import System.IO (Handle, hClose, hFlush, hSetBinaryMode, openBinaryTempFile) -import System.Process (CreateProcess (std_err, std_in, std_out), ProcessHandle, StdStream (CreatePipe, UseHandle), createProcess, proc, terminateProcess, waitForProcess) -import System.Timeout (timeout) -import Text.Printf (printf) -import Text.Regex.PCRE (matchTest) -import Text.Regex.PCRE.ByteString (Regex, compUTF8, compile, execBlank) - --- The interpreter a script is run under, named after the executable itself: --- only 'node' for now. A registry naming any other runtime is rejected when it --- is read, before dataization starts, so a run never gets half-way through a --- program to discover that one of its atoms cannot be run at all. -data Runtime = RtNode - deriving stock (Eq, Ord, Show) - --- How the program of an atom is started: as a script under the interpreter of --- its runtime, which phino stages in a temporary file, or as an executable --- file, which phino runs as it is, since the object model brought its own --- binary and there is nothing to stage. -data Program - = Scripted Runtime T.Text - | Executable FilePath - deriving stock (Eq, Ord, Show) - --- One Ξ» function phino may fire: its program, either started afresh for every --- fire and gone once it has answered, or kept in a session for the run, so --- that one process answers every fire β€” which is what an entry saying 'serve' --- asks for, and what a program that is slow to start needs. -data Atom - = Transient Program - | Resident Session - deriving stock (Eq, Show) - --- A program to be kept for the run, together with the process phino has --- started of it, if it has: none until the first fire, since a run that never --- reaches the atom should not pay for it. Every entry naming the same program --- shares one session, so one process serves all the Ξ» names it is registered --- under. -data Session = Session - { _program :: Program - , _running :: MVar (Maybe Running) - } - --- Two sessions are the same when they keep the same program, whatever their --- processes are up to. -instance Eq Session where - Session left _ == Session right _ = left == right - -instance Show Session where - show (Session program _) = show program - --- A program while it runs: its streams, the file its complaints go to, the --- file its script is staged in, if it is a script, the universe it was told --- last, so it is told again only when the universe changes, how many --- requests it has been asked, which numbers the next one, and the receivers --- of the requests still in flight, which by-reference questions name instead --- of quoting (#1165). The last three are mutable, since a fire may nest: --- serving a question of the program takes an evaluator that fires atoms of --- its own, and the one it reaches may be this very program, asked again over --- these very handles while its question is still open. -data Running = Running - { _input :: Handle - , _output :: Handle - , _process :: ProcessHandle - , _complaints :: FilePath - , _staged :: Maybe FilePath - , _told :: IORef (Maybe Expression) - , _requests :: IORef Int - , _forms :: IORef (IM.IntMap Expression) - } - --- What is left of the channel to a program once its request is pushed through: --- the stdin of a program started for the fire is closed behind the request, --- since the program may read its input whole before it answers, so nothing --- more can be said to it; the stdin of one kept for the run is flushed and --- stays open, so its questions can be answered. -data Channel = Closed | Open - --- What the receiver of a request holds under an attribute a question names: --- the node bound to it, or nothing at all, since the attribute is void. A void --- one is a fact about the receiver and not a failure of the question, so a --- program may ask whether an operand is bound and be told (#1206). A bound one --- is held twice over: as it is written, which is what a question that does not --- reduce is answered with, and with its ΞΎ standing for the formation it is --- bound in, which is the only shape of it that reduces anywhere else (#1220). -data Held = Bound Expression Expression | Void - --- How phino reduces a πœ‘-expression a program asks about. Only the caller of --- 'fireAtom' can do it, since it alone holds the universe to reduce inside and --- the context to reduce under, so it hands the way down (see 'reduction' in --- 'Dataize'). -type ReduceFunc = Expression -> IO Expression - --- One entry of the registry, as the file spells it: the program and whether --- it is to be kept for the run. -data Entry = Entry Program Bool - --- Every Ξ» function phino may fire, in the order the registry file lists them: --- each key of the file, a regular expression over Ξ» names, paired with the --- atom its entry describes. A lookup tries them top to bottom and the first --- key matching the whole name wins, so one entry may stand for many atoms, --- while a plain name, being a regular expression matching itself, keeps --- meaning that one atom. -newtype Registry = Registry [(Regex, Atom)] - -data AtomException - = -- The '--atoms' file is not a JSON registry of Ξ» functions. - BrokenRegistry FilePath String - | -- The program of an atom cannot be run: the interpreter of its runtime is - -- not installed, or its executable file is missing or not executable. - NoRuntime T.Text String String - | -- The program exited with a non-zero status; the message carries its stderr. - AtomBroke T.Text Int String - | -- The program said nothing phino can use: its reply is not a JSON object, - -- carries no πœ‘-expression, answers another request, asks a question phino - -- has no channel left to answer, or the πœ‘-expression does not parse. - AtomMute T.Text String String - deriving anyclass (Exception) - -instance Show AtomException where - show (BrokenRegistry file failure) = printf "The registry of atoms '%s' cannot be read: %s" file failure - show (NoRuntime func runner failure) = - printf "Atom '%s' cannot be fired, '%s' is not runnable: %s" (T.unpack func) runner failure - show (AtomBroke func status complaint) = - printf "Atom '%s' failed with exit code %d: %s" (T.unpack func) status complaint - show (AtomMute func answer failure) = - printf "Atom '%s' returned '%s', which phino cannot use: %s" (T.unpack func) answer failure - --- The name a registry spells a runtime with. -runtimeName :: Runtime -> String -runtimeName RtNode = "node" - --- The POSIX executable the scripts of a runtime are run under. -interpreter :: Runtime -> String -interpreter RtNode = "node" - --- The extension the script of a runtime is written to disk with, so the --- interpreter recognizes the file for what it is. This is the language, not the --- runtime: 'node' loads a file only if it is named '.js'. -extension :: Runtime -> String -extension RtNode = "js" - --- Every runtime phino can run, in the order the '--atoms' help lists them. -runtimes :: [Runtime] -runtimes = [RtNode] - --- The 'rt' of an atom that is a file rather than a script: it names no --- interpreter, because the file runs on its own. -execName :: String -execName = "exec" - --- Every name the 'rt' field of a registry entry may take. -runtimeNames :: [String] -runtimeNames = map runtimeName runtimes ++ [execName] - -instance FromJSON Runtime where - parseJSON = withText "runtime" $ \name -> case find ((== T.unpack name) . runtimeName) runtimes of - Just runtime -> pure runtime - Nothing -> fail (printf "unknown runtime '%s', expected one of: %s" (T.unpack name) (intercalate ", " runtimeNames)) - -instance FromJSON Program where - parseJSON = withObject "atom" $ \entry -> do - named <- entry .: "rt" - if named == execName - then Executable <$> entry .: "path" - else Scripted <$> parseJSON (A.String (T.pack named)) <*> entry .: "script" - --- The 'serve' field is optional and off by default: a program is started for --- every fire unless the entry says otherwise. -instance FromJSON Entry where - parseJSON value = Entry <$> parseJSON value <*> withObject "atom" (\entry -> entry .:? "serve" .!= False) value - --- What a program writes back: the answer to the request it was asked, the --- πœ‘-expression under '𝑛', a question of its own, the πœ‘-expression under --- 'ask' that it needs reduced before it can answer, or a question by --- reference, naming an in-flight request under 'of' and one of the receiver's --- attributes under 'attr', with 'reduce' deciding whether the answer is the --- node as it is held or its dataization (#1165). An answer echoes the 'id' --- of the request it answers, a question mints an 'id' of its own, which phino --- echoes back. -data Said - = Answer Int T.Text - | Question Int T.Text - | Reference Int Int T.Text Bool - -instance FromJSON Said where - parseJSON = withObject "reply" $ \said -> do - number <- said .: "id" - answer <- said .:? "𝑛" - question <- said .:? "ask" - case (answer, question) of - (Just raw, _) -> pure (Answer number raw) - (Nothing, Just raw) -> pure (Question number raw) - _ -> do - request <- said .:? "of" - attr <- said .:? "attr" - reduced <- said .:? "reduce" .!= False - case (request, attr) of - (Just req, Just name) -> pure (Reference number req name reduced) - _ -> fail "there is neither '𝑛', nor 'ask', nor 'of' with 'attr' in it" - --- No Ξ» function at all: every atom gets stuck. This is what a run without --- '--atoms' fires against. -emptyRegistry :: Registry -emptyRegistry = Registry [] - --- The Ξ» function of the first key that matches the whole name, if any. -registeredAtom :: Registry -> T.Text -> Maybe Atom -registeredAtom (Registry rules) func = snd <$> find (\(pattern, _) -> matchTest pattern (encodeUtf8 func)) rules - --- Read the registry of Ξ» functions from a JSON file. A key that is no regular --- expression, an unknown runtime, a missing 'script', a 'path' that names no --- executable file or malformed JSON fails here, before any dataization starts. --- The entries that are to keep the same program are given one session between --- them, so that one resident process answers for every key it is registered --- under. -readRegistry :: FilePath -> IO Registry -readRegistry path = do - content <- BS.readFile path `catch` unreadable - entries <- either (throwIO . BrokenRegistry path) pure (listed content) - mapM_ (uncurry runnable) entries - (rules, _) <- foldM admitted ([], Map.empty) entries - logDebug (printf "Loaded %d atom(s) from '%s'" (length rules) path) - pure (Registry (reverse rules)) - where - unreadable :: IOError -> IO BS.ByteString - unreadable failure = throwIO (BrokenRegistry path (show failure)) - -- The entries of the file in the order it lists them, which is the order - -- the keys are tried in and which the object aeson would decode the file - -- to forgets, so the file is walked token by token instead. - listed :: BS.ByteString -> Either String [(T.Text, Entry)] - listed content = case bsToTokens content of - TkRecordOpen record -> paired record - TkErr failure -> Left failure - _ -> Left "the file is not a JSON object" - paired :: TkRecord BS.ByteString String -> Either String [(T.Text, Entry)] - paired (TkPair key tokens) = do - (value, rest) <- toEitherValue tokens - entry <- parseEither (\raw -> parseJSON raw Key key) value - ((Key.toText key, entry) :) <$> paired rest - paired (TkRecordEnd rest) - | BS.all (`BS.elem` " \t\r\n") rest = Right [] - | otherwise = Left "there is more in the file than the JSON object" - paired (TkRecordErr failure) = Left failure - -- The key as the regular expression it is, made to match the whole name, - -- so that a plain name means that one atom and not every name it is a - -- part of. - compiled :: T.Text -> IO Regex - compiled key = compile compUTF8 execBlank (encodeUtf8 ("^(?:" <> key <> ")$")) >>= either broken pure - where - broken :: (a, String) -> IO Regex - broken (_, failure) = throwIO (BrokenRegistry path (printf "the key '%s' is not a regular expression: %s" (T.unpack key) failure)) - -- The file of an executable atom is the only thing phino knows about it, - -- and it staged none of it, so the file is looked at here, while the - -- registry is being read, rather than half-way through a program that - -- turns out to name that atom. - runnable :: T.Text -> Entry -> IO () - runnable func (Entry (Executable file) _) = do - there <- doesFileExist file - unless there (throwIO (NoRuntime func file "there is no such file")) - allowed <- executable <$> getPermissions file - unless allowed (throwIO (NoRuntime func file "the file is not executable")) - runnable _ _ = pure () - -- Turn an entry into the atom phino fires, keyed by its pattern and, when - -- it is to keep its program, sharing a session with the entries keeping - -- the same one; the rules come out newest first. - admitted :: ([(Regex, Atom)], Map Program Session) -> (T.Text, Entry) -> IO ([(Regex, Atom)], Map Program Session) - admitted (rules, sessions) (key, Entry program serve) = do - pattern <- compiled key - (atom, kept) <- if serve then resident program sessions else pure (Transient program, sessions) - pure ((pattern, atom) : rules, kept) - resident :: Program -> Map Program Session -> IO (Atom, Map Program Session) - resident program sessions = do - session <- maybe (Session program <$> newMVar Nothing) pure (Map.lookup program sessions) - pure (Resident session, Map.insert program session sessions) - --- Stop every resident program the registry has started: its stdin is closed, --- which is its cue to quit, and a program that has not quit within a second is --- terminated. The runners call this when the run is over, whatever it ended --- with, so that no process outlives the phino that started it. -closeRegistry :: Registry -> IO () -closeRegistry (Registry rules) = mapM_ (dismissed . snd) rules - where - dismissed :: Atom -> IO () - dismissed (Resident Session{..}) = modifyMVar_ _running (maybe (pure Nothing) (\running -> Nothing <$ stopped briefly running)) - dismissed _ = pure () - --- Fire the Ξ» function 'func' by asking its program, reducing with 'reduce' --- whatever the program asks about on the way. A transient program is started --- for the fire and waited for once it has answered, so that its exit status --- has its say; a resident one is started on the first fire and stays for the --- run, whatever the fire ended with, so that 'closeRegistry' finds it. The --- session is let go of before the program is spoken to, since serving a --- question may fire the same atom again and a fire waiting for the session it --- is already inside would wait forever. Whichever way, the πœ‘-expression the --- program answers with becomes the atom's raw result, which 𝔼 normalizes --- exactly as it normalized the answer of a built-in one. -fireAtom :: T.Text -> Atom -> Expression -> Expression -> ReduceFunc -> IO Expression -fireAtom func (Transient program) form univ reduce = do - running <- started func program - answer <- asked func running form univ Closed reduce `onException` stopped patiently running - (status, complaint) <- stopped patiently running - unless (null complaint) (logDebug (printf "Atom '%s' wrote to stderr: %s" (T.unpack func) complaint)) - case status of - ExitFailure code -> throwIO (AtomBroke func code complaint) - ExitSuccess -> pure answer -fireAtom func (Resident Session{..}) form univ reduce = do - running <- modifyMVar _running (\current -> (\kept -> (Just kept, kept)) <$> maybe (started func _program) pure current) - asked func running form univ Open reduce - --- Start the program, with its input and its output on pipes and its complaints --- in a file that lives as long as the process does: a script is staged in a --- temporary file first and handed to the interpreter of its runtime, an --- executable file is run as it is. Every stream is bytes: a πœ‘ expression --- carries characters no single-byte locale can spell, so nothing is left to --- the locale. -started :: T.Text -> Program -> IO Running -started func program = do - dir <- getTemporaryDirectory - (complaints, handle) <- openBinaryTempFile dir "phino-atom-.err" - (executable, arguments, staged) <- commanded dir - logDebug (printf "Starting atom '%s' as '%s'" (T.unpack func) (unwords (executable : arguments))) - (input, output, process) <- spawned executable arguments handle `onException` discarded complaints staged - Running input output process complaints staged <$> newIORef Nothing <*> newIORef 0 <*> newIORef IM.empty - where - -- The command line the program is started with, and the file staged for - -- it, if it is a script. - commanded :: FilePath -> IO (String, [String], Maybe FilePath) - commanded dir = case program of - Executable file -> pure (file, [], Nothing) - Scripted runtime script -> do - (path, handle) <- openBinaryTempFile dir (printf "phino-atom-.%s" (extension runtime)) - BS.hPut handle (encodeUtf8 script) - hClose handle - pure (interpreter runtime, [path], Just path) - spawned :: String -> [String] -> Handle -> IO (Handle, Handle, ProcessHandle) - spawned executable arguments stderr' = do - spawn <- createProcess (proc executable arguments){std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle stderr'} `catch` missing executable - case spawn of - (Just input, Just output, _, process) -> do - hSetBinaryMode input True - hSetBinaryMode output True - pure (input, output, process) - _ -> throwIO (AtomMute func "" "the program gave phino no streams to talk over") - missing :: String -> IOError -> IO a - missing executable failure = throwIO (NoRuntime func executable (show failure)) - --- Ask the running program to fire the Ξ» function: it is told the universe, --- unless it was told already, then the request, and its lines are read back --- until it answers. A line carrying '𝑛' with the 'id' of the request is the --- answer; a line carrying 'ask' is a question of the program's own, which --- phino reduces and replies to before it goes on reading. What is left of the --- channel is the caller's: a transient program has its stdin closed behind the --- request, since it may read its input whole before it answers, a resident one --- has it flushed, since it reads on. A reply that is not JSON, carries neither --- '𝑛' nor 'ask', answers another request, or a program that hangs up fails the --- fire, with the program's stderr in the message. -asked :: T.Text -> Running -> Expression -> Expression -> Channel -> ReduceFunc -> IO Expression -asked func Running{..} form univ channel reduce = do - number <- atomicModifyIORef' _requests (\spent -> (spent + 1, spent + 1)) - modifyIORef' _forms (IM.insert number form) - told <- readIORef _told - logDebug (printf "Asking atom '%s' as request %d" (T.unpack func) number) - said (if told == Just univ then request number else universe <> request number) - writeIORef _told (Just univ) - heard number `onException` forget number - where - universe :: BS.ByteString - universe = lined (object ["𝑒" .= spelled univ]) - request :: Int -> BS.ByteString - request number = lined (object ["id" .= number, "Ξ»" .= func, "𝑏" .= spelled form]) - -- Everything phino says to a program kept for the run is spelled without - -- the ρ chain: such a program can ask for what the chain holds, by value - -- with 'ask' or by reference with 'of' and 'attr', so quoting it into - -- every message only makes the next question bigger (#1165). A program - -- started for the fire has no channel to ask over and keeps getting the - -- whole receiver, ρ and all. - spelled :: Expression -> T.Text - spelled = case channel of - Open -> lean - Closed -> rendered - lean :: Expression -> T.Text - lean expr = T.pack (printExpressionHidingRho' expr (SALTY, UNICODE, SINGLELINE, defaultMargin)) - -- The receiver of a request is of no use to the channel once the request - -- has been answered. - forget :: Int -> IO () - forget = modifyIORef' _forms . IM.delete - -- Read the program's lines until it answers the request phino asked, - -- serving every question it asks on the way. - heard :: Int -> IO Expression - heard number = do - reply <- BC.hGetLine _output `catch` hungUp - case eitherDecodeStrict' reply of - Left failure -> throwIO (AtomMute func (spoken reply) failure) - Right (Answer echoed raw) - | echoed /= number -> throwIO (AtomMute func (spoken reply) (printf "it answers request %d, while phino asked request %d" echoed number)) - | otherwise -> forget number >> either (throwIO . AtomMute func (T.unpack raw)) pure (parseExpression (T.unpack raw)) - Right (Question minted raw) -> served minted raw >> heard number - Right (Reference minted req name doReduce) -> referenced minted req name doReduce >> heard number - -- The by-reference sibling of 'served': the question names an in-flight - -- request and one attribute of its receiver, and phino answers from the - -- formation it still holds for that request, without either side - -- re-printing or re-parsing a receiver. 'reduce' says whether to dataize - -- what the attribute carries, as 'ask' does, or to hand the node over as - -- it is (#1165). The attribute may be a dotted path, since depth is the - -- only thing such a question would otherwise be missing (#1207). - referenced :: Int -> Int -> T.Text -> Bool -> IO () - referenced minted req attrName doReduce = case channel of - Closed -> throwIO (AtomMute func described "it asks phino for an attribute of a previous request, while its stdin is closed, since its entry does not say 'serve'") - Open -> do - logDebug (printf "Atom '%s' asks phino for '%s' of request %d%s as question %d" (T.unpack func) (T.unpack attrName) req (if doReduce then ", reduced," else ", as it is," :: String) minted) - held <- describe - case held of - Left failure -> throwIO (AtomMute func described failure) - Right Void -> said (lined (object ["id" .= minted, "βˆ…" .= True])) - Right (Bound written scoped) -> (if doReduce then reduce scoped else pure written) >>= said . answered minted - where - described :: String - described = printf "{'of':%d,'attr':'%s'}" req (T.unpack attrName) - describe :: IO (Either String Held) - describe = do - forms <- readIORef _forms - pure $ case IM.lookup req forms of - Nothing -> Left (printf "there is no in-flight request %d to take '%s' from" req (T.unpack attrName)) - Just form' -> case descended form' of - Nothing -> Left (printf "the receiver of request %d carries no attribute '%s'" req (T.unpack attrName)) - Just held -> Right held - -- Walk the dotted path of 'attr' down the receiver: every segment but - -- the last has to name a formation or an application to go on into, - -- and the last one is what the question is about. An attribute bound - -- to nothing at all carries nothing to descend into, so a path through - -- a void one names no attribute (#1207). - descended :: Expression -> Maybe Held - descended form' = foldM deeper (Bound form' form') (T.splitOn "." attrName) - deeper :: Held -> T.Text -> Maybe Held - deeper (Bound _ scoped) name = attributeValue name scoped - deeper Void _ = Nothing - -- An argument of an application binds an attribute the way a Ο„ - -- binding of a formation does, and it is the outer of the two, so it - -- is what the attribute is whatever the formation under it still says - -- about it. A positional argument names nothing, so the walk goes past - -- it into what the application applies to (#1212). The ΞΎ of a node - -- bound in a formation stands for that formation, so a node taken out - -- of one carries it along, the way the 'dot' rule does when it - -- dispatches the same attribute; an argument, written in the scope - -- around the application and contextualized long before a request - -- reaches this far, stands for itself (#1220). - attributeValue :: T.Text -> Expression -> Maybe Held - attributeValue name form'@(ExFormation bds) = go bds - where - go :: [Binding] -> Maybe Held - go [] = Nothing - go (BiTau attr value : rest) - | named name attr = Just (Bound value (contextualize value form')) - | otherwise = go rest - go (BiVoid attr : rest) - | named name attr = Just Void - | otherwise = go rest - go (_ : rest) = go rest - attributeValue name (ExApplication applied (ArTau attr value)) - | named name attr = Just (Bound value value) - | otherwise = attributeValue name applied - attributeValue name (ExApplication applied _) = attributeValue name applied - attributeValue _ _ = Nothing - named :: T.Text -> Attribute -> Bool - named name attr = T.pack (printAttribute attr) == name - -- Reduce the πœ‘-expression the program asks about and say it back under - -- '𝑛', with the 'id' the question minted. A program started for the fire - -- has nothing to be answered over, since phino closed its stdin behind the - -- request, so its question fails the fire instead of hanging it. - served :: Int -> T.Text -> IO () - served minted raw = case channel of - Closed -> throwIO (AtomMute func (T.unpack raw) "it asks phino to reduce an expression, while its stdin is closed, since its entry does not say 'serve'") - Open -> do - logDebug (printf "Atom '%s' asks phino to reduce '%s' as question %d" (T.unpack func) (T.unpack raw) minted) - target <- either (unreadable raw) pure (parseExpression (T.unpack raw)) - reduce target >>= said . answered minted - -- The answer to a question, as the line the program reads it off: the 'id' - -- the question minted, the node under '𝑛' and, next to it, what the node - -- carries β€” its byte array under 'Ξ”', the Ξ» name it is stuck on under 'Ξ»', - -- the chain it is dispatched off Ξ¦ by under 'Ξ¦.' β€” so that telling a datum - -- from a stuck atom, or a typed literal from either, takes no πœ‘ reader of - -- the program's own (#1206, #1210). - answered :: Int -> Expression -> BS.ByteString - answered minted answer = lined (object (["id" .= minted, "𝑛" .= spelled answer] ++ carried answer)) - where - carried :: Expression -> [Pair] - carried (ExFormation bds) = mapMaybe fact bds - carried expr = maybe [] (\forma -> ["Ξ¦." .= forma]) (dispatched expr) - fact :: Binding -> Maybe Pair - fact (BiDelta bytes) = Just ("Ξ”" .= printBytes bytes) - fact (BiLambda (Function name)) = Just ("Ξ»" .= name) - fact _ = Nothing - -- The chain the answer is dispatched off Ξ¦ by, once the arguments - -- applied to it are stripped: 'number' for 'Ξ¦.number( Ο† ↦ … )', 'true' - -- for 'Ξ¦.true', 'org.eolang.tuple' for a chain that deep. πœ‘-calculus - -- types nothing nominally, so that name is the only place the forma of - -- a typed literal lives. A chain with an application inside it, such as - -- 'Ξ¦.number( … ).plus( … )', dispatches off a term phino would have to - -- dataize to name, so it names no forma and nothing is said (#1210). - dispatched :: Expression -> Maybe T.Text - dispatched (ExApplication applied _) = dispatched applied - dispatched expr = case chain expr of - Just names@(_ : _) -> Just (T.intercalate "." names) - _ -> Nothing - chain :: Expression -> Maybe [T.Text] - chain ExRoot = Just [] - chain (ExDispatch applied attr) = (++ [T.pack (printAttribute attr)]) <$> chain applied - chain _ = Nothing - unreadable :: T.Text -> String -> IO a - unreadable raw failure = throwIO (AtomMute func (T.unpack raw) (printf "it asks phino to reduce an expression that does not parse: %s" failure)) - -- A program that has died leaves the write with nobody to drain it. The - -- failure worth reporting is the one the program made, so a broken pipe is - -- swallowed here and the read that follows finds out. - said :: BS.ByteString -> IO () - said content = (BS.hPut _input content >> pushed channel _input) `catch` unheard - -- The program closed its stdout instead of answering: if it has quit with - -- a failure, that is the failure; otherwise it went mute. - hungUp :: IOError -> IO BS.ByteString - hungUp _ = do - status <- timeout 1000000 (waitForProcess _process) - complaint <- readErrors _complaints - case status of - Just (ExitFailure code) -> throwIO (AtomBroke func code complaint) - Just ExitSuccess -> throwIO (AtomMute func "" (unwords ("the program quit without answering" : [complaint | not (null complaint)]))) - Nothing -> throwIO (AtomMute func "" (unwords ("the program closed its stdout without answering" : [complaint | not (null complaint)]))) - --- Push the request through the channel: closing the stdin of a program started --- for the fire is the cue a program reading its input whole waits for, while a --- program kept for the run reads on and needs no more than a flush. -pushed :: Channel -> Handle -> IO () -pushed Closed = hClose -pushed Open = hFlush - --- Hang up on the program: close its stdin, which is its cue to quit, wait for --- it the given way and remove the files it was given, its complaints read --- first, since they are what a failure is reported with. -stopped :: (Running -> IO ExitCode) -> Running -> IO (ExitCode, String) -stopped waited running@Running{..} = do - hClose _input `catch` unheard - status <- waited running - hClose _output `catch` unheard - complaint <- readErrors _complaints - discarded _complaints _staged - pure (status, complaint) - --- Wait for the program to quit for as long as it takes, draining whatever else --- it writes, so that a chatty one never blocks on a full pipe: a transient --- program is on its way out once it has answered, and its exit status is the --- verdict on its answer. -patiently :: Running -> IO ExitCode -patiently Running{..} = BS.hGetContents _output >> waitForProcess _process - --- Wait for the program to quit for a second, then terminate it: a resident one --- was told to quit and gets no say in the matter. -briefly :: Running -> IO ExitCode -briefly Running{..} = timeout 1000000 (waitForProcess _process) >>= maybe (terminateProcess _process >> waitForProcess _process) pure - --- Remove the files a program was given: the one its complaints went to and the --- one its script was staged in, if it was a script. -discarded :: FilePath -> Maybe FilePath -> IO () -discarded complaints staged = removePathForcibly complaints >> mapM_ removePathForcibly staged - --- Whatever the program said, decoded leniently and trimmed: the stream is the --- program's, so it may hold anything at all. -spoken :: BS.ByteString -> String -spoken = T.unpack . T.strip . decodeUtf8Lenient - --- Whatever the program complained about, read from the file its stderr goes to. -readErrors :: FilePath -> IO String -readErrors errors = spoken <$> BS.readFile errors - -unheard :: IOError -> IO () -unheard _ = pure () - --- One JSON object as one line, for the programs that read by the line. -lined :: A.Value -> BS.ByteString -lined value = BSL.toStrict (A.encode value) <> "\n" - --- An expression as canonical πœ‘-calculus on a single line β€” no syntax sugar, --- whatever '--sweet' says about the output of the run β€” so a program never has --- to know phino's sugar to find a datum: every byte array it may need is --- spelled out as a Ξ” binding. The text is what phino's own parser reads back, --- so a program may hand any part of it to another phino run (see the --- '--inside' option). -rendered :: Expression -> T.Text -rendered expr = T.pack (printExpression' expr (SALTY, UNICODE, SINGLELINE, defaultMargin)) diff --git a/src/Builder.hs b/src/Builder.hs --- a/src/Builder.hs +++ b/src/Builder.hs @@ -116,10 +116,15 @@ bts <- buildBytes bytes subst Right [BiDelta bts] buildBinding (BiLambda (FnMeta meta)) (Subst mp) = case Map.lookup (Named meta) mp of - Just (MvFunction func) -> Right [BiLambda (Function func)] + Just (MvFunction func) -> Right [BiLambda func] _ -> Left (metaMsg meta) buildBinding (BiLambda (FnAny slot)) (Subst mp) = case Map.lookup (Anon slot) mp of - Just (MvFunction func) -> Right [BiLambda (Function func)] + Just (MvFunction func) -> Right [BiLambda func] + _ -> Left (slotMsg slot) +-- A bare 𝜎 asks for a symbol nothing has answered yet, and the one minted for +-- the slot it was written at is bound the way any other anonymous meta is. +buildBinding (BiLambda (FnFresh slot)) (Subst mp) = case Map.lookup (Anon slot) mp of + Just (MvFunction func) -> Right [BiLambda func] _ -> Left (slotMsg slot) buildBinding binding _ = Right [binding] diff --git a/src/CLI/Helpers.hs b/src/CLI/Helpers.hs --- a/src/CLI/Helpers.hs +++ b/src/CLI/Helpers.hs @@ -7,31 +7,34 @@ module CLI.Helpers where import AST -import Atoms (Registry, emptyRegistry, readRegistry) import CLI.Types import CLI.Validators (invalidCLIArguments) import Canonizer (canonize) import Control.Exception import Control.Monad ((>=>)) +import Data.Char (toLower) import Data.Functor ((<&>)) import Data.IORef import Data.List (intercalate, nub) import Data.Maybe -import Deps (SaveEvalFunc, SaveStepFunc, dontSaveEval, saveEval, saveStep) +import qualified Data.Text as T +import Deps (Evaluation (EvRun), Judgment, SaveEvalFunc, SaveStepFunc, State (..), dontSaveEval, emptyNesting, emptyProtocol, endEvalXml, saveEval, saveEvalXml, saveStep) import Encoding -import Files (ensuredFile) +import Files (ensuredFile, overwrite) import Functions (execFunctions) import LaTeX (LatexContext (LatexContext), defaultMeetLength, defaultMeetPopularity, expressionToLaTeX, rewrittensToLatex) +import Lambdas (Lambdas, emptyLambdas, readLambdas, taken) import Lining (LineFormat (SINGLELINE)) import Locator (locatedExpression) import Logger -import Morph (ReduceContext, insideUniverse) +import Morph (ReduceContext, emptyState, insideUniverse) import Parser (parseExpressionThrows) import qualified Printer as P import qualified Random as R import Rewriter (Rewritten, Rewrittens', stepHeaders) +import Sugar (SugarType (SALTY)) import System.Directory (createDirectoryIfMissing) -import System.FilePath (takeDirectory) +import System.FilePath (takeDirectory, takeExtension) import System.IO (Handle, IOMode (WriteMode), getContents', hClose, hSetEncoding, openFile, utf8) import Text.Printf (printf) import XMIR (expressionToXMIR, parseXMIRThrows, printXMIR, xmirToPhi) @@ -59,24 +62,45 @@ saveStep stepsDir ioToExt render step expr pure save --- Run the action with a function recording atom firings, holding the protocol --- file open for the whole run. Opening it for writing truncates it, so that it --- always holds the firings of exactly one run: a caller reading it back never --- picks up records left over from the previous run, even when this run fires no --- atom at all. The handle is closed on the way out, failure included, so the --- last records reach the disk even when dataization gives up. Every record is --- flattened into a single line, whatever '--flat' says about the main output, --- since the file is a line-per-firing protocol. The encoding is pinned to UTF-8 --- rather than taken from the locale, since the file is read back by other --- programs. -withEvalFunc :: Maybe FilePath -> PrintContext -> (SaveEvalFunc -> IO a) -> IO a +-- Run the action with a function writing the protocol of the run, holding the +-- file open for the whole of it. Opening it for writing truncates it, so that +-- it always holds the firings of exactly one run: a caller reading it back +-- never picks up lines left over from the previous run, even when this run +-- fires nothing at all. The handle is closed on the way out, failure included, +-- so the last lines reach the disk even when the run gives up. What the +-- protocol has counted so far rides in an 'IORef' next to the handle, since it +-- is the cursor of the file and not a property of the reduction (see +-- 'Protocol'). Every term is flattened into a single line, whatever '--flat' +-- says about the main output, since the file is a tree of one-line records. The +-- encoding is pinned to UTF-8 rather than taken from the locale, since the file +-- is read back by other programs. +withEvalFunc :: forall a. Maybe FilePath -> PrintContext -> (SaveEvalFunc -> IO a) -> IO a withEvalFunc Nothing _ action = action dontSaveEval withEvalFunc (Just file) ctx action = do createDirectoryIfMissing True (takeDirectory file) - logDebug (printf "The option '--evaluations' is specified, atom firings will be recorded in '%s'" file) - bracket opened hClose $ \protocol -> - action (saveEval protocol (printExpression ctx{_line = SINGLELINE})) + logDebug (printf "The option '--protocol' is specified, every firing will be recorded in '%s' as %s" file (if markup then "XML" else "text")) + if markup then markedUp else plain where + -- Which of the two formats the file holds is decided by the name it was + -- given and by nothing else: '.xml' asks for the markup one, every other + -- name for the indented text the option has always written (#1245). There + -- is no flag for it, since a caller naming a file '.xml' and getting text + -- back has been told nothing useful. + markup :: Bool + markup = map toLower (takeExtension file) == ".xml" + -- The markup format closes on the way out what the run left open, so the + -- document is well-formed however the run ended. The closing runs before + -- the handle does, and the handle closes whether or not it succeeded. + markedUp :: IO a + markedUp = do + cursor <- newIORef emptyNesting + bracket opened (\protocol -> endEvalXml protocol cursor `finally` hClose protocol) $ \protocol -> + action (saveEvalXml protocol cursor (flattened ctx)) + plain :: IO a + plain = do + cursor <- newIORef emptyProtocol + bracket opened hClose $ \protocol -> + action (saveEval protocol cursor (flattened ctx) (salted ctx)) -- 'withFile' would do the same, except that it annotates whatever the action -- throws with the name of the file, and a dataization failure has to reach -- the user as it is @@ -87,18 +111,46 @@ pure protocol -- The Ξ» functions this run may fire. phino implements none of them, so without --- '--atoms' the registry is empty and every atom a program names gets stuck β€” --- which is exactly what '--partial' parks on. The file is read here, before --- anything is parsed or dataized, so an unknown runtime or a malformed registry --- fails the run up front rather than half-way through a derivation. -registryOf :: Maybe FilePath -> IO Registry -registryOf Nothing = do - logDebug "The option '--atoms' is not specified, no Ξ» function can be fired" - pure emptyRegistry -registryOf (Just file) = do - logDebug (printf "The option '--atoms' is specified, reading the Ξ» functions from '%s'" file) - ensuredFile file >>= readRegistry +-- '--symbolic' there are none at all and every Ξ» function a program names gets +-- stuck β€” which is exactly what '--partial' parks on. The file is read here, +-- before anything is parsed or reduced, so a key that is no regular expression +-- or an answer the calculus cannot read fails the run up front rather than +-- half-way through a derivation. +lambdasOf :: Maybe FilePath -> IO Lambdas +lambdasOf Nothing = do + logDebug "The option '--symbolic' is not specified, no Ξ» function can be fired" + pure emptyLambdas +lambdasOf (Just file) = do + logDebug (printf "The option '--symbolic' is specified, reading the Ξ» functions from '%s'" file) + ensuredFile file >>= readLambdas +-- The state a run starts from: nothing manufactured yet and every symbol the +-- program already carries counted as minted, so a fresh 𝜎 is never spelled like +-- one the input was written with (see 'taken'). +started :: Expression -> State +started expr = emptyState{_minted = taken expr} + +-- Open the protocol with the run itself β€” the judgment it runs and the term it +-- is aimed at β€” which is the line every firing of it stands under. +heading :: SaveEvalFunc -> PrintContext -> Judgment -> Expression -> IO () +heading record ctx judgment locator = + record . EvRun judgment . T.pack =<< flattened ctx locator + +-- How every term of the protocol is rendered: as πœ‘ on a single line, in the +-- sugar and the margin the run prints its own answer with. The protocol is a +-- tree of one-line πœ‘ records whatever '--output' the run was given, so a +-- program reading it back never has to know what the run printed. +flattened :: PrintContext -> Expression -> IO String +flattened ctx = pure . printPhi ctx{_line = SINGLELINE} + +-- The same, in canonical πœ‘ rather than in the sugar the run prints with. The +-- operand a protocol line names is the term an entry of the '--symbolic' file +-- wrote, and the sweet syntax writes 'ΞΎ.x' as a bare 'x', which reads as a name +-- and not as the term it is β€” so the comment that names an operand spells it +-- salty and the value beside it stays as the run spells it (#1265). +salted :: PrintContext -> Expression -> IO String +salted ctx = flattened ctx{_sugar = SALTY} + -- Aim the run at the '--inside' expression instead of at '--locator': the -- expression is bound to a synthetic attribute prepended to the input -- expression, which the run takes as the universe, and the locator becomes that @@ -229,5 +281,5 @@ putStrLn content Just file -> do logDebug (printf "The option '--target' is specified, printing to '%s'..." file) - writeFile file content + overwrite file content logDebug (printf "The command result was saved in '%s'" file) diff --git a/src/CLI/Parsers.hs b/src/CLI/Parsers.hs --- a/src/CLI/Parsers.hs +++ b/src/CLI/Parsers.hs @@ -3,7 +3,6 @@ module CLI.Parsers where -import Atoms (runtimeNames) import CLI.Types import Data.Char (toLower, toUpper) import Data.List (intercalate) @@ -204,36 +203,44 @@ optStepsDir = optional (strOption (long "steps-dir" <> metavar "FILE" <> help "Directory to save intermediate steps during rewriting/dataizing")) optPartial :: Parser Bool -optPartial = switch (long "partial" <> help "Partial evaluation: compute what the known inputs decide and, instead of failing on an atom that cannot fire (its Ξ» function is not in the --atoms registry), leave it in place and print the residual πœ‘-program") +optPartial = switch (long "partial" <> help "Partial evaluation: compute what the known inputs decide and, instead of failing on a Ξ» function that cannot fire (no entry of the --symbolic file answers it), leave it in place and print the residual πœ‘-program") -- 𝕄 stops at the first formation it reaches and hands its bindings back as -- they were written, so what a program holds but nothing demands is never -- reduced. This walks into them (see 'deepened'). optDeep :: Parser Bool -optDeep = switch (long "deep" <> help "Don't stop at the first formation: enter its bindings too, recursively, firing every Ξ» function the --atoms registry serves and standing its answer in the place of what it computed, while everything else stays as it was written") +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 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. +-- This stops it the moment it comes back (see 'unvisited'). +optAcyclic :: Parser Bool +optAcyclic = switch (long "acyclic" <> help "Stop reducing a term as soon as it comes back to one it is already reducing, instead of going round until --max-steps runs out, and leave that term in place the way --partial leaves a Ξ» function that cannot fire") + -- Which Ξ» functions this run may fire. phino implements none of them itself --- (see 'Atoms'), so without this option every atom a program names gets stuck. -optAtoms :: Parser (Maybe FilePath) -optAtoms = +-- (see 'Lambdas'), so without this option every Ξ» function a program names gets +-- stuck. +optSymbolic :: Parser (Maybe FilePath) +optSymbolic = optional ( strOption - ( long "atoms" + ( long "symbolic" <> metavar "FILE" <> help - ( printf - "Path to the JSON registry of Ξ» functions this run may fire, whose keys are regular expressions over Ξ» names, tried top to bottom, each mapped to the runtime that runs it (%s), the script or the executable it runs and, with \"serve\", whether one process of it is to serve the whole run" - (intercalate ", " runtimeNames) - ) + "Path to the YAML file of Ξ» functions this run may fire, each entry keyed by a regular expression \ + \over Ξ» names under \"Ξ»\", naming the operands it brings down to data under \"dataize\", the ones \ + \it reduces to a normal form under \"morph\" and the terms of those it stands the data of into \ + \unknowns under \"symbolize\", and answering with the term under \"𝑛\"" ) ) -- The external face of the trick phino plays internally to reduce a -- sub-expression against a universe: prepend a synthetic binding holding it to --- that universe and aim the locator at the binding. An atom script started for --- the fire needs it to reduce the parts of the formation it was given, so it --- does not have to splice them into the text of the universe by hand; one kept --- for the run asks phino over the channel it answers on instead (see 'Atoms'). +-- that universe and aim the locator at the binding. It is the same trick a Ξ» +-- function's operands are reduced with (see 'insideUniverse' in 'Morph'), made +-- available to whoever asks phino to reduce a term that is not part of the +-- program. optInside :: Parser (Maybe String) optInside = optional @@ -247,8 +254,19 @@ ) ) -optEvaluations :: Parser (Maybe FilePath) -optEvaluations = optional (strOption (long "evaluations" <> metavar "FILE" <> help "File to record every atom fired during dataizing, as one tab-separated line per firing: the Ξ» function name, its argument formation and its result (requires --output=phi)")) +optProtocol :: Parser (Maybe FilePath) +optProtocol = + optional + ( strOption + ( long "protocol" + <> metavar "FILE" + <> help + "File to record every Ξ» function fired during the run: the run at the top, one block per firing \ + \under it, and inside each block the operands it bound and the term it answered with, with a \ + \firing nested in the reduction of an operand one level deeper again. The name of the file \ + \decides the format: '.xml' writes XML, every other name writes the same tree as indented text" + ) + ) optShuffle :: Parser Bool optShuffle = switch (long "shuffle" <> help "Shuffle rules before applying") @@ -340,6 +358,7 @@ <*> optSeed <*> switch (long "quiet" <> help "Don't print the result of dataization") <*> optPartial + <*> optAcyclic <*> optCompress <*> optMaxDepth <*> optMaxCycles @@ -356,8 +375,8 @@ <*> optMeetPrefix <*> optInside <*> optStepsDir - <*> optEvaluations - <*> optAtoms + <*> optProtocol + <*> optSymbolic <*> argInputFile ) @@ -384,6 +403,7 @@ <*> switch (long "quiet" <> help "Don't print the result of morphing") <*> optPartial <*> optDeep + <*> optAcyclic <*> optCompress <*> optMaxDepth <*> optMaxCycles @@ -400,8 +420,8 @@ <*> optMeetPrefix <*> optInside <*> optStepsDir - <*> optEvaluations - <*> optAtoms + <*> optProtocol + <*> optSymbolic <*> argInputFile ) diff --git a/src/CLI/Runners.hs b/src/CLI/Runners.hs --- a/src/CLI/Runners.hs +++ b/src/CLI/Runners.hs @@ -8,7 +8,6 @@ module CLI.Runners where import AST -import Atoms (closeRegistry) import CLI.Helpers import CLI.Types import CLI.Validators @@ -18,10 +17,14 @@ import Data.Foldable (traverse_) import Data.List (intercalate) import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, isJust, isNothing) import qualified Data.Text as T import Dataize +import Deps (Judgment (..)) import Encoding +import Evaluate (evaluation, fired) +import Files (overwrite) import qualified Filter as F import Functions (buildTerm) import LaTeX (explainContextualizeRules, explainDataizeRules, explainMorphRules, explainRules) @@ -69,7 +72,7 @@ exclude = (`F.exclude` excluded) include = (`F.include` included) save <- saveStepFunc _stepsDir printCtx - (rewrittens, exceeded) <- rewrite expr rules (RewriteContext loc _maxDepth _maxCycles _depthSensitive buildTerm _must _breakpoint save) + (rewrittens, exceeded) <- rewrite expr rules (RewriteContext loc _maxDepth _maxCycles _depthSensitive Nothing buildTerm _must _breakpoint save) let 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) @@ -112,13 +115,13 @@ output target expr = case (_inPlace, target, _inputFile) of (True, _, Just file) -> do logDebug (printf "The option '--in-place' is specified, writing back to '%s'..." file) - writeFile file expr + overwrite file expr logDebug (printf "The file '%s' was modified in-place" file) (True, _, Nothing) -> error "The option --in-place requires an input file" (False, Just file, _) -> do logDebug (printf "The option '--target' is specified, printing to '%s'..." file) - writeFile file expr + overwrite file expr logDebug (printf "The command result was saved in '%s'" file) (False, Nothing, _) -> do logDebug "The option '--target' is not specified, printing to console..." @@ -147,7 +150,7 @@ runDataize :: OptsDataize -> IO () runDataize OptsDataize{..} = do validateOpts - atoms <- registryOf _atoms + lambdas <- lambdasOf _symbolic excluded <- validatedDispatches "hide" _hide included <- validatedDispatches "show" _show [loc] <- validatedDispatches "locator" [_locator] @@ -161,28 +164,30 @@ exclude = (`F.exclude` excluded) include = (`F.include` included) save <- saveStepFunc _stepsDir printCtx - (outcome, chain) <- + (outcome, chain, _) <- withEvalFunc - _evaluations + _protocol printCtx ( \record -> do -- The deep walk belongs to 𝕄 alone (the '--deep' of 'morph'), since 𝔻 - -- reduces what dataization demands and ends in bytes, so it is off here. - let ctx = ReduceContext loc _maxDepth _maxCycles (Steps _maxSteps 0) _depthSensitive _shuffle _partial False atoms buildTerm reduction save record + -- 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 term it comes back to is a loop of its own (#1290). + let ctx = ReduceContext loc loc Nothing _maxDepth _maxCycles (Steps _maxSteps 0) 1 _depthSensitive _shuffle _partial False _acyclic Dataization [] Map.empty Map.empty lambdas buildTerm reduction evaluation fired save record (universe, aiming) <- aimed _inside expr ctx - dataize universe aiming + heading record printCtx Dataization aiming._locator + dataize universe (started universe) aiming ) - `finally` closeRegistry atoms when _sequence (printRewrittens printCtx (exclude $ include chain, False) >>= putStrLn) unless _quiet (printOutcome printCtx outcome >>= putStrLn) where - -- The bytes the run reached or, when '--partial' let it end on an atom + -- The bytes the run reached or, when '--partial' let it end on a Ξ» function -- that could not fire, the residual program, rendered like a rewriting -- result: in the output format, narrowed to '--focus'. printOutcome :: PrintContext -> Outcome -> IO String printOutcome _ (Dataized bytes) = pure (P.printBytes bytes) printOutcome ctx (Residual residue) = do - logDebug "Dataization got stuck on an atom that cannot fire, printing the residual program (--partial)" + logDebug "Dataization got stuck on a Ξ» function that cannot fire, printing the residual program (--partial)" printFocused ctx residue validateOpts :: IO () validateOpts = do @@ -194,9 +199,6 @@ validateXmirOptions _outputFormat [(_omitListing, "omit-listing"), (_omitComments, "omit-comments")] _focus when (length _show > 1) (invalidCLIArguments "The option --show can be used only once") when - (isJust _evaluations && _outputFormat /= PHI) - (invalidCLIArguments "The --evaluations option can stay together with --output=phi only, since one record must fit into one line") - 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") toPrintCtx :: Expression -> PrintContext @@ -234,7 +236,7 @@ runMorph :: OptsMorph -> IO () runMorph OptsMorph{..} = do validateOpts - atoms <- registryOf _atoms + lambdas <- lambdasOf _symbolic excluded <- validatedDispatches "hide" _hide included <- validatedDispatches "show" _show [loc] <- validatedDispatches "locator" [_locator] @@ -248,16 +250,16 @@ exclude = (`F.exclude` excluded) include = (`F.include` included) save <- saveStepFunc _stepsDir printCtx - (morphed, chain) <- + (morphed, chain, _) <- withEvalFunc - _evaluations + _protocol printCtx ( \record -> do - let ctx = ReduceContext loc _maxDepth _maxCycles (Steps _maxSteps 0) _depthSensitive _shuffle _partial _deep atoms buildTerm reduction save record + let ctx = ReduceContext loc loc Nothing _maxDepth _maxCycles (Steps _maxSteps 0) 1 _depthSensitive _shuffle _partial _deep _acyclic Morphing [] Map.empty Map.empty lambdas buildTerm reduction evaluation fired save record (universe, aiming) <- aimed _inside expr ctx - morph universe aiming + heading record printCtx Morphing aiming._locator + morph universe (started universe) aiming ) - `finally` closeRegistry atoms when _sequence (printRewrittens printCtx (exclude $ include chain, False) >>= putStrLn) unless _quiet (printFocused printCtx morphed >>= putStrLn) where @@ -271,9 +273,6 @@ validateXmirOptions _outputFormat [(_omitListing, "omit-listing"), (_omitComments, "omit-comments")] _focus when (length _show > 1) (invalidCLIArguments "The option --show can be used only once") when - (isJust _evaluations && _outputFormat /= PHI) - (invalidCLIArguments "The --evaluations option can stay together with --output=phi only, since one record must fit into one line") - 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") toPrintCtx :: Expression -> PrintContext @@ -381,4 +380,4 @@ 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 + rule ptn cnd = Y.Rule "custom" Nothing Nothing ptn Nothing ExRoot cnd Nothing Nothing diff --git a/src/CLI/Types.hs b/src/CLI/Types.hs --- a/src/CLI/Types.hs +++ b/src/CLI/Types.hs @@ -96,6 +96,7 @@ , _seed :: Int , _quiet :: Bool , _partial :: Bool + , _acyclic :: Bool , _compress :: Bool , _maxDepth :: Int , _maxCycles :: Int @@ -112,8 +113,8 @@ , _meetPrefix :: Maybe String , _inside :: Maybe String , _stepsDir :: Maybe FilePath - , _evaluations :: Maybe FilePath - , _atoms :: Maybe FilePath + , _protocol :: Maybe FilePath + , _symbolic :: Maybe FilePath , _inputFile :: Maybe FilePath } @@ -141,6 +142,7 @@ , _quiet :: Bool , _partial :: Bool , _deep :: Bool + , _acyclic :: Bool , _compress :: Bool , _maxDepth :: Int , _maxCycles :: Int @@ -157,8 +159,8 @@ , _meetPrefix :: Maybe String , _inside :: Maybe String , _stepsDir :: Maybe FilePath - , _evaluations :: Maybe FilePath - , _atoms :: Maybe FilePath + , _protocol :: Maybe FilePath + , _symbolic :: Maybe FilePath , _inputFile :: Maybe FilePath } diff --git a/src/CST.hs b/src/CST.hs --- a/src/CST.hs +++ b/src/CST.hs @@ -92,10 +92,13 @@ | I' -- i | B -- 𝐡 | B' -- B - | D -- Ξ΄ + | D -- 𝛿 | D' -- \delta + | D'' -- d | F -- 𝑓 | F' -- F + | S -- 𝜎 + | S' -- S deriving (Eq, Show) data EXCLAMATION = EXCL | NO_EXCL @@ -517,6 +520,8 @@ toCST (BiLambda (Function name)) _ = PA_LAMBDA name toCST (BiLambda (FnMeta mt)) _ = PA_META_LAMBDA (META NO_EXCL F (metaTail mt)) toCST (BiLambda (FnAny _)) _ = PA_META_LAMBDA (anyMeta F) + toCST (BiLambda (FnSymbol idx)) _ = PA_META_LAMBDA (META NO_EXCL S (T.pack (show idx))) + toCST (BiLambda (FnFresh _)) _ = PA_META_LAMBDA (anyMeta S) toCST (BiMeta mt) _ = error $ "BiMeta binding " ++ T.unpack mt ++ " cannot be converted to PAIR" toCST (BiAny _) _ = error "An anonymous meta binding cannot be converted to PAIR" diff --git a/src/Dataize.hs b/src/Dataize.hs --- a/src/Dataize.hs +++ b/src/Dataize.hs @@ -14,17 +14,17 @@ module Dataize (dataize, dataize', reduction, Outcome (..)) where import AST -import Atoms (ReduceFunc) import Builder (buildBytesThrows, buildExpressionThrows) import Control.Exception (throwIO, try) import Control.Monad (foldM) import Data.List (find) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -import Deps (State) +import Data.Maybe (listToMaybe) +import Deps (Judgment (..), State (..)) import Locator (locatedExpression) import Matcher (Subst, matchExpression') -import Morph (Morphed, ReduceContext (..), ReduceException (..), deeper, emptyState, excluding, execBuildTerm, insideUniverse, leadsTo, morph', normalized, parking, producer, sidePremise, verb) +import Morph (Morphed, ReduceContext (..), ReduceException (..), ReductionFunc, deeper, excluding, execBuildTerm, insideUniverse, leadsTo, morph', normalized, parking, producer, sidePremise, universed, unvisited, verb) import Random (shuffle) import Rewriter (Rewritten) import Rule (RuleContext (RuleContext), matchExpressionWithRule') @@ -38,8 +38,8 @@ type Dataizable = Morphed -- What a run of 𝔻 ends with: the bytes it reached or, under '_partial', the --- residual program: what the known inputs decided is computed, the stuck atom --- and everything depending on it survive in place. +-- residual program: what the known inputs decided is computed, the stuck Ξ» +-- function and everything depending on it survive in place. data Outcome = Dataized Bytes | Residual Expression @@ -47,21 +47,27 @@ -- Dataize the expression located at '_locator'. The whole input expression is -- itself the universe Q (the 'e' argument) threaded through 𝔻 and 𝕄, so it is --- passed both as the located target and as the universe. An atom that cannot --- fire fails the run, unless '_partial' is on: dataization is then a partial --- evaluation, and the run ends on the residual program the spine had reached --- (see 'StuckAt'), with the stuck application parked in it as a normal-form --- subterm, and the chain of steps that led there. -dataize :: Expression -> ReduceContext -> IO (Outcome, [Rewritten]) -dataize universe ctx@ReduceContext{..} = do +-- passed both as the located target and as the universe. A Ξ» function that +-- cannot fire fails the run, unless '_partial' is on: dataization is then a +-- partial evaluation, and the run ends on the residual program the spine had +-- reached (see 'StuckAt'), with the stuck application parked in it as a +-- normal-form subterm, and the chain of steps that led there. A term '_acyclic' +-- caught coming back to itself ends the run the same way, since 𝔻 has no bytes +-- to give for a question it can only ever answer by asking again; where +-- '_partial' is off the signal travels on instead, so a 𝔻 run reducing an +-- operand of a firing leaves the loop to the 𝕄 spine around that firing, which +-- parks on it with no '_partial' asked for (see 'morph', #1290). The state 𝑠 +-- goes in and comes back out, so a 𝔻 asked inside another judgment goes on +-- minting symbols where that judgment left off. +dataize :: Expression -> State -> ReduceContext -> IO (Outcome, [Rewritten], State) +dataize universe state ctx@ReduceContext{..} = do expr <- locatedExpression _locator universe - -- Dataization starts from the empty state; the final state is not yet - -- consumed by any caller, so it is discarded here. - result <- try (dataize' (expr, (universe, Nothing) :| []) universe emptyState ctx) + result <- try (dataize' (expr, (universe, Nothing) :| []) universe state ctx) case result of - Right ((bytes, seq), _state) -> pure (Dataized bytes, reverse seq) - Left (StuckAt _ seq) | _partial -> pure (Residual (fst (NE.head seq)), reverse (NE.toList seq)) - Left (OutOfStepsAt _ seq) | _partial -> pure (Residual (fst (NE.head seq)), reverse (NE.toList seq)) + Right ((bytes, seq), state') -> pure (Dataized bytes, reverse seq, state') + Left (StuckAt func seq parked) | _partial -> pure (Residual (fst (NE.head seq)), reverse (NE.toList seq), parked{_stuck = Just func}) + Left (OutOfStepsAt _ seq parked) | _partial -> pure (Residual (fst (NE.head seq)), reverse (NE.toList seq), parked) + Left (LoopingAt _ seq parked) | _partial -> pure (Residual (fst (NE.head seq)), reverse (NE.toList seq), parked) Left failure -> throwIO (failure :: ReduceException) -- The Dataization function 𝔻 retrieves bytes from an expression. It is partial @@ -85,16 +91,40 @@ -- 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. +-- Like 𝕄, every frame asks '_acyclic' whether the term it was handed is one a +-- frame above it is already dataizing, before any rule is walked: 𝔻 recurses +-- into itself through 'box' and 'fire' without 𝕄 ever seeing the same term +-- twice, so a program cycling through dataization alone is a loop only this +-- guard ends (#1290). dataize' :: Dataizable -> Expression -> State -> ReduceContext -> IO (Dataized, State) dataize' (expr, seq) univ state caller = do - ctx <- deeper caller - parking seq $ 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 - Nothing -> throwIO (userError (unmatched expr)) + ctx <- deeper =<< unvisited expr =<< universed univ caller{_judgment = Dataization} + 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 + Nothing -> throwIO (userError (unmatched expr)) where + -- The symbol a formation carries in place of a Ξ» name, if any. Such a + -- formation is what a Ξ» function answered with where it could not work the + -- value out, so no entry of the '--symbolic' file answers it and firing it + -- would get stuck; 𝔻 therefore takes it before the rules are ever walked, + -- which also keeps 'fire' from matching what it cannot fire. + unknown :: Expression -> Maybe Int + unknown (ExFormation bds) = listToMaybe [idx | BiLambda (FnSymbol idx) <- bds] + unknown _ = Nothing + -- A symbol dataizes to a datum manufactured for it: dataizing an unknown + -- never gets stuck, and the very same 42 answers every symbol, since the + -- run is symbolic and no arithmetic of it is ever read. Which symbol the + -- datum stands for is told to the state rather than to the term, so the + -- 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 + pure ((datum, NE.toList seq'), state{_manufactured = Just idx}) -- 𝔻 is partial: the terminator βŠ₯ signals an error and lies outside its -- domain (see #955), so it matches no clause and lands here. Name it in the -- message rather than reporting the generic "no dataization rule matched", @@ -110,14 +140,17 @@ (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 + asRule rule = Y.Rule rule.name Nothing Nothing rule.match Nothing 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 - pure ((bts, NE.toList seq'), state') + -- 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)) -> 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, @@ -168,27 +201,32 @@ bytesProducer (BtMeta name) = find (\premise -> premise.result == name) bytesProducer _ = const Nothing --- What phino answers a program that asks it to reduce a πœ‘-expression (see --- 'ReduceFunc' in 'Atoms'): the expression is bound to a synthetic attribute --- of the universe and dataized there, exactly the way the '--inside' option --- does it, so the bytes come back as a Ξ” formation β€” or, where an atom on the --- way could not fire and '_partial' parked it, the node the question named, --- taken out of the residue at the synthetic attribute. The residue is the whole --- synthetic universe, and answering with it hands the program a print of the --- universe per question, thousands of bytes around the one node it asked about --- (#1167); nothing is lost by trimming it, since the rest of that residue is --- the universe the program was already told under '𝑒'. --- An operand reaches a program unreduced, since reducing it may take the very --- atom being fired, and before the channel carried questions the program had --- no way to ask: it had to splice the operand into the text of the universe --- and run a phino of its own on it (see #1160). The context is the one the --- fire descended with, so the step budget of the run bounds the nesting. -reduction :: Expression -> ReduceContext -> ReduceFunc -reduction univ ctx expr = do +-- What a 'dataize' operand of a Ξ» function is brought down with (see +-- 'ReductionFunc' in 'Morph'): the operand is bound to a synthetic attribute of +-- the universe and dataized there, exactly the way the '--inside' option does +-- it, so what comes back is the data the operand carries. Where a Ξ» function on +-- the way could not fire and '_partial' parked it, the operand never came down +-- to data at all and nothing comes back, which leaves the firing that asked for +-- it stuck. An operand reaches a firing unreduced, since reducing it may take +-- the very Ξ» function being fired, so it is reduced here, on demand, and not +-- before. The context is the one the fire descended with, so the step budget of +-- the run bounds the nesting, and the state 𝑠 goes in and comes back out, so +-- the symbols this reduction mints are counted in the same sequence as the ones +-- around it. +reduction :: ReductionFunc +reduction univ ctx expr state = do (universe, aiming) <- insideUniverse expr univ ctx - (outcome, _) <- dataize universe aiming - reduced aiming._locator outcome + (outcome, _, state') <- dataize universe state aiming + pure (reached outcome, state') where - reduced :: Expression -> Outcome -> IO Expression - reduced _ (Dataized bytes) = pure (ExFormation [BiDelta bytes]) - reduced locator (Residual residue) = locatedExpression locator residue + reached :: Outcome -> Maybe Bytes + reached (Dataized bytes) = Just bytes + reached (Residual _) = Nothing + +-- The datum every symbol dataizes to: 42 as a double, the same for all of them. +-- A symbolic run computes nothing, so what the datum is carries no meaning at +-- all; what matters is that 𝔻 of an unknown answers rather than gets stuck, so +-- a Ξ» function whose operands are unknowns still fires and still answers with +-- an unknown of its own. +datum :: Bytes +datum = BtMany ["40", "45", "00", "00", "00", "00", "00", "00"] diff --git a/src/Deps.hs b/src/Deps.hs --- a/src/Deps.hs +++ b/src/Deps.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT @@ -10,15 +13,19 @@ module Deps where import AST -import Data.List (intercalate) -import Data.Maybe (maybeToList) +import Data.IORef (IORef, readIORef, writeIORef) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) import qualified Data.Text as T +import Files (overwrite) import Logger (logDebug) import Matcher +import Printer (printBytes, printFunction) import System.Directory (createDirectoryIfMissing) import System.FilePath import System.IO (Handle, hPutStrLn) import Text.Printf (printf) +import XMIR (escapeXML, escapeXMLText) import Yaml data Term @@ -30,13 +37,21 @@ type BuildTermMethod = [ExtraArgument] -> Subst -> IO Term -- The state 𝑠 threaded through the Morphing 𝕄(n, e, s), Dataization 𝔻(n, e, s) --- and Evaluation 𝔼(b, s) functions. The calculus does not yet fix what a state --- is, so it is a plain string for now. Unlike the universe 𝑒, which is immutable --- and threaded unchanged, the state is mutable: 𝔼 takes a state 𝑠1 and returns a --- new one 𝑠2, and 𝕄/𝔻 propagate that change to their callers. Only the rules --- that fire an atom β€” 'ml' (morphing) and 'fire' (dataization) β€” can change --- the state; every other rule threads it through untouched. -type State = String +-- and Evaluation 𝔼(b, s) functions. Unlike the universe 𝑒, which is immutable +-- and threaded unchanged, the state is mutable: 𝔼 takes a state 𝑠1 and returns +-- a new one 𝑠2, and 𝕄/𝔻 propagate that change to their callers. It carries how +-- many symbols the run has minted, so the next 𝜎 an answer asks for is one no +-- term already holds, which symbol the last datum was manufactured for, +-- since every symbol dataizes to the very same 42 and only the state can tell +-- the protocol which unknown that 42 stood for, and which Ξ» function the last +-- reduction of it was parked on, since a run '--partial' parks answers a +-- residue and the name of what parked it would otherwise be lost with the +-- signal the residue was made of (#1288). +data State = State + { _minted :: Int + , _manufactured :: Maybe Int + , _stuck :: Maybe T.Text + } -- Like 'BuildTermMethod', but it also takes the incoming state and returns the -- new state alongside the term. Lives here next to 'BuildTermMethod' so the two @@ -53,36 +68,564 @@ createDirectoryIfMissing True dir let path = dir printf "%05d.%s" step ext content <- render expr - writeFile path content + overwrite path content logDebug (printf "Saved step '%d' to '%s'" step path) dontSaveStep :: SaveStepFunc dontSaveStep = saveStep Nothing "" (\_ -> pure "") 0 --- One firing of an atom, the way the Evaluation function 𝔼 sees it: the name of --- the Ξ» function, the formation it fired against with the Ξ» binding removed, and --- the term it produced. A firing that got stuck β€” the atom is unknown, or one of --- its inputs reached such an atom β€” and survived in the residual program of a --- partial evaluation (see '--partial') has no result. -data Evaluation = Evaluation - { _function :: T.Text - , _arguments :: Expression - , _result :: Maybe Expression - } +-- 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, '', 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. +data Judgment + = -- The Morphing function 𝕄, which the 'morph' command runs. + Morphing + | -- The Dataization function 𝔻, which the 'dataize' command runs. + Dataization +-- The letter the calculus writes a judgment with, which is how the text format +-- opens a run of it. +letter :: Judgment -> String +letter Morphing = "𝕄" +letter Dataization = "𝔻" + +-- The element the markup opens a run of a judgment with, and closes it under, +-- named after the judgment the way '' is named after 𝔼. A root +-- '' carries the locator the run was aimed at where one inside a +-- 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 Morphing = "morph" +opened Dataization = "dataize" + +-- One line of the protocol the '--protocol' option writes, which is a tree of +-- the firings of the Evaluation function 𝔼 rather than a list of them. The run +-- itself opens it β€” '𝕄(Q.Ο†)' for a morphing, '𝔻(Q)' for a dataization β€” and +-- under it stands one block per firing, '𝔼(L_number_plus) # 𝔻(Ξ¦.Ο†)', naming +-- the entry that answered, the judgment that asked for the firing and the site +-- of the program it was fired at (#1302, #1306). Inside a block stand the +-- operands the entry bound β€” each with the judgment that reduced it and the +-- term it was reduced from β€” whatever a 'symbolize' line of it knows about a +-- symbol it minted, the terms a 'join' line of it made one of and what it +-- knows about the symbol they were joined into, and the term it answered with, +-- one to a line, and any firing an operand took while it was being reduced, +-- one level deeper again. The answer takes two of those lines rather than one: +-- the term the entry wrote, then the normal form 𝕄 makes of it, so the +-- morphing between them is a step a reader watches happen rather than a shape a +-- term arrives in (#1298). A name no entry answers stands there as +-- '?(L_number_nope)', where the block of its firing would have been. +data Evaluation + = -- The run and the term it was aimed at. + EvRun Judgment T.Text + | -- One firing of the entry under that key, at the depth its nesting gives + -- it, together with the site it was fired at: the locator of the part of + -- the program the firing belongs to, which is the aim of the run refined by + -- the '--deep' walk as it enters a binding (see '_site' in 'Morph'). The + -- key says which entry answered and one entry answers the same way wherever + -- it is fired, so the site is the one thing telling two firings of it apart + -- by something other than the order they came in, and it is written as the + -- comment of the line the way a stuck site carries the formation it was + -- asked about (#1302). The judgment stands beside it for the reason a stuck + -- site carries one: 𝔼 is fired from the 'ml' rule of morphing and from the + -- 'fire' rule of dataization, and the comment says what was running over + -- that part of the program rather than leaving a locator to say it alone + -- (#1306). + EvFiring Int T.Text Judgment Expression + | -- A Ξ» function no entry of the '--symbolic' file answers, at the depth the + -- firing of it would have stood at, together with the judgment that asked + -- for the firing and the formation 𝔼 was fired against, as it was handed + -- it. Nothing fired, so the line stands alone and no block opens under it. + -- It is written whether or not '--partial' goes on to park the run, since + -- the protocol records what 𝔼 was asked for and a question it could not + -- answer belongs there as much as one it could β€” and the object it was + -- asked about is half of that question, so the record carries it the way + -- every other one carries the term it is about, as the comment of the line + -- in the text format and as the text of the element in the markup. The + -- judgment stands beside it because 𝔼 is fired from two places β€” the 'ml' + -- rule of morphing and the 'fire' rule of dataization β€” and which of them + -- asked is what says where in the reduction the site stands (#1300). + EvStuck Int T.Text 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. + EvData Int T.Text Expression (Either Int Bytes) + | -- A 'morph' operand of the firing: the meta it bound, the term the entry + -- wrote under that meta, and the normal form 𝕄 reached. + EvTerm Int T.Text Expression Expression + | -- A 'symbolize' line of the firing: the meta it bound, the meta of the + -- entry it was told to stand the data of, and the term that standing made + -- β€” the very term that meta is bound to, with the data of it standing for + -- unknowns. It is a binding like 'EvTerm' and differs in what the line is + -- commented with, since nothing of the calculus runs here: the line names + -- a meta the entry bound above it, the way a 'join' line names the two it + -- joined, where an operand line names the judgment that reduced it + -- (#1306). + EvSymbolize Int T.Text Expression Expression + | -- What is known about a symbol a 'symbolize' line minted: dataizing the + -- formation the symbol names answers these bytes. It is a fact about the + -- symbol and no binding of it, since a 𝜎 is the name of a Ξ» function and + -- neither a datum nor a term, so it stands on a line of its own rather + -- than beside a meta the firing bound (#1269). + EvKnown Int Int Bytes + | -- A 'join' line of the firing: the meta it bound, the two metas whose terms + -- it joined, in the order the entry wrote them, and the term they joined + -- into. It is a binding like 'EvTerm' and differs only in what the line is + -- commented with, a 'join' line naming two metas of the entry where every + -- other block names a term of the calculus (#1246). + EvJoin Int T.Text (T.Text, T.Text) Expression + | -- What is known about a symbol the join of two branches of a fork minted: + -- dataizing the formation it names answers what dataizing one of the two + -- formations the branches carried answers, and which of the two it is is + -- the very thing nobody has worked out. The two stand in the order the + -- entry listed the branches under '𝑛', so a reader who knows the entry + -- knows which of them belongs to which branch. It is a fact about the + -- symbol and no binding of it, exactly as 'EvKnown' is (#1246). + EvJoined Int Int (Int, Int) + | -- A fresh symbol the answer of the firing asked for, one record per bare 𝜎 + -- the entry wrote it with. It is a fact about the firing and no property of + -- any one term of it, since an answer may carry several symbols or none and + -- no single one of them stands for the whole of it (#1280). + EvMinted Int Int + | -- The term the entry wrote as its answer, with the symbols the firing + -- minted standing in it, before 𝕄 is asked about it. It is the first of + -- the two records an answer is written as, and it is there because the + -- answer of a firing is morphed (#1268) and a morphing nobody sees is a + -- term appearing out of nothing: whatever that morphing fires opens its + -- own block between this record and 'EvAnswer', so a reader sees the term + -- the entry wrote, the firings reducing it took, and the normal form it + -- came to, in that order (#1298). The line of it is commented with '𝑛', + -- the key the entry writes its answer under, the way an operand line + -- carries the term it was reduced from: the name on the left is minted by + -- the protocol and says nothing about where the term was read from. + EvBuilt Int Expression + | -- What the firing answered with, which is the term of 'EvBuilt' as 𝕄 + -- leaves it. It is the answer every consumer reads, since it is the term + -- the walk stands back into the program. The line of it is commented with + -- '𝕄(𝑛.4.1)', naming the line it was morphed from, since the two may stand + -- whole blocks apart and a value alone never says what it came from β€” the + -- very reason an operand line carries the term it was reduced from. + EvAnswer Int Expression + type SaveEvalFunc = Evaluation -> IO () --- Append one evaluation to the protocol as a single tab-separated line: the Ξ» --- function name, its argument formation and its result; a parked firing has no --- result, so its record stops after the second field. The expressions are --- rendered by the caller, which flattens them, so a record never spills over --- more than one line. The handle stays open for the whole run, since a run may --- fire thousands of atoms and reopening the file for each of them buys nothing. -saveEval :: Handle -> (Expression -> IO String) -> SaveEvalFunc -saveEval handle render (Evaluation func bindings outcome) = do - rendered <- mapM render (bindings : maybeToList outcome) - hPutStrLn handle (intercalate "\t" (T.unpack func : rendered)) - logDebug (printf "Saved the evaluation of '%s'" (T.unpack func)) +-- 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 terms '--acyclic' has walked. A digest collision is +-- resolved by an exact structural comparison, so the common case stays O(1) on +-- the digest while a name still stands for the very term it was given to. +-- Keying on the whole term and not on the first symbol it carries is what +-- keeps the format honest: the symbolized copy of a term carries the same +-- first symbol as the term it was made of and differs deeper down, so naming +-- the copy after the original claimed nothing was replaced on the very line +-- that replaced something (#1292). +type Named = Map.Map Int [(Expression, T.Text)] + +-- The name an earlier line gave this very term, if one did. The digest lookup +-- is fast; the (==) check runs only on a digest match, so two terms that differ +-- anywhere are two terms and neither is ever written as the other. +namedLookup :: Expression -> Named -> Maybe T.Text +namedLookup term names = lookup term (Map.findWithDefault [] (hashExpression term) names) + +-- Remember the name a line gives a term, under the digest of that term, +-- keeping the names of any term that collides with it. A term written out +-- twice takes the name of the later line, which is the line a reader counting +-- back from the next one reaches first. +namedInsert :: Expression -> T.Text -> Named -> Named +namedInsert term naming = Map.alter renamed (hashExpression term) + where + renamed :: Maybe [(Expression, T.Text)] -> Maybe [(Expression, T.Text)] + renamed entries = Just ((term, naming) : filter ((/= term) . fst) (fromMaybe [] entries)) + +-- What the protocol has counted so far: how many firings the whole run has +-- opened, which is what numbers them and so tells a line of one firing from +-- the same line of any other; the name last given to each term, which is how +-- a term already written out is named instead of written again; and which +-- firing is open at each depth, since the operands of a firing belong to the +-- firing it was when it started and not to the one another firing has made of +-- it since. The firings are numbered across the run rather than per Ξ» +-- function, so no two of them give an operand meta the same name and a name +-- the protocol points back to points at one line only (#1261). The answers are +-- numbered by that same counter and no counter of their own, since a firing +-- answers once and so the two lines of its answer are told from every other +-- pair by the firing they stand in (#1298). The order the firings come in +-- carries nothing β€” it is the order 𝕄 walks the term β€” so the symbols are what +-- the dependencies are read from: a term carrying 𝜎4 is the term the line that +-- minted 𝜎4 stood for. +data Protocol = Protocol + { _fired :: Int + , _named :: Named + , _open :: Map.Map Int Int + } + +-- The protocol before a single firing has been written. +emptyProtocol :: Protocol +emptyProtocol = Protocol 0 Map.empty Map.empty + +-- What the XML protocol has counted so far: how many firings the whole run +-- has opened, the same single counter 'Protocol' keeps since #1261, which +-- numbers the 'id' an element carries and, through '_openedAt', names a meta +-- on this firing the way the text format names it and not with the bare +-- spelling the entry's YAML gives it, an answer of it included (#1298); and +-- the elements standing open around the record being written, innermost +-- first, each with the depth it was opened at and the name it closes under. +-- The text format needs no such stack, since indentation opens and closes +-- nothing; markup does, and the depth a record carries is the only thing +-- saying which firings it stands outside of. +data Nesting = Nesting + { _fires :: Int + , _openedAt :: Map.Map Int Int + , _closing :: [(Int, String)] + } + +-- The XML protocol before a single element has been opened. +emptyNesting :: Nesting +emptyNesting = Nesting 0 Map.empty [] + +-- Append the line of one record to the protocol, indented by the depth of what +-- it reports and numbered by what the protocol has seen before it. The handle +-- stays open for the whole run, since a run may fire thousands of Ξ» functions +-- and reopening the file for each of them buys nothing; the counting rides in +-- an 'IORef' next to it, since it is the cursor of the file and not a property +-- of the reduction. Expressions are rendered by the caller, which flattens +-- them, so a line never spills over more than one. There are two renderers and +-- not one because the operand a line is commented with is spelled salty while +-- the value it took is spelled the way the run prints its own answer: the +-- sweet syntax drops the ΞΎ of 'ΞΎ.x' and leaves a bare 'x', which is the very +-- thing the comment is there to say (see 'commented'). +saveEval :: Handle -> IORef Protocol -> (Expression -> IO String) -> (Expression -> IO String) -> SaveEvalFunc +saveEval handle cursor render salted report = do + line <- atomicModify cursor (written report) + mapM_ saved line + where + -- Put one line of the protocol on the disk and say in the log what went + -- there, the indentation of it dropped, since the log is a list of what + -- happened and no tree. + saved :: String -> IO () + saved line = do + hPutStrLn handle line + logDebug (printf "Saved one line of the protocol: %s" (dropWhile (== ' ') line)) + -- The line a report is written as, where it is written as one, together + -- with what the protocol has counted once it is written. A term is looked + -- up by the first symbol it carries and, where that symbol has a name + -- already, written as that name; otherwise it is written out and the + -- symbol takes the name of this line. + -- + -- A symbol the answer of a firing minted is the one record this format + -- keeps no line for: the answer stands spelled out on the line of it, + -- symbols and all, so a reader ties a later 𝔻(⟦ Ξ» ‍ 𝜎4 ⟧) back to the + -- firing that minted 𝜎4 by reading the very term it answered with. Only + -- the markup, where a term is text and not a thing to be read, spells the + -- fact out (#1280). + written :: Evaluation -> Protocol -> IO (Protocol, Maybe String) + written (EvRun judgment locator) protocol = + pure (protocol, Just (printf "%s(%s)" (letter judgment) (T.unpack locator))) + written (EvFiring depth key judgment site) protocol = do + locator <- render site + pure + ( protocol + { _fired = firings + , _open = Map.insert depth firings protocol._open + } + , Just (indented depth (printf "𝔼(%s) # %s(%s)" (T.unpack key) (letter judgment) locator)) + ) + where + firings :: Int + firings = protocol._fired + 1 + written (EvStuck depth key judgment self) protocol = do + form <- render self + pure (protocol, Just (indented depth (printf "?(%s) # %s(%s)" (T.unpack key) (letter judgment) form))) + written (EvData depth spelling operand value) protocol = do + datum <- spelled value + line <- commented (printf "%s := %s" (labelled protocol depth spelling) datum) Dataization operand + pure (protocol, Just (indented depth line)) + where + spelled :: Either Int Bytes -> IO String + spelled (Left symbol) = printf "𝔻(%s)" <$> render (standing symbol) + spelled (Right bytes) = pure (printBytes bytes) + written (EvTerm depth spelling operand term) protocol = do + let naming = labelled protocol depth spelling + (protocol', value) <- valued protocol naming term + line <- commented (printf "%s := %s" naming value) Morphing operand + pure (protocol', Just (indented depth line)) + written (EvSymbolize depth spelling source term) protocol = do + let naming = labelled protocol depth spelling + (protocol', value) <- valued protocol naming term + line <- commented' (printf "%s := %s" naming value) source + pure (protocol', Just (indented depth line)) + written (EvKnown depth symbol bytes) protocol = do + form <- render (standing symbol) + pure (protocol, Just (indented depth (printf "𝔻(%s) == %s" form (printBytes bytes)))) + written (EvJoin depth spelling (left, right) term) protocol = do + let naming = labelled protocol depth spelling + (protocol', value) <- valued protocol naming term + pure (protocol', Just (indented depth (printf "%s := %s # [%s, %s]" naming value (T.unpack left) (T.unpack right)))) + written (EvJoined depth fresh (one, two)) protocol = do + form <- render (standing fresh) + left <- render (standing one) + right <- render (standing two) + pure (protocol, Just (indented depth (printf "𝔻(%s) ∈ { 𝔻(%s), 𝔻(%s) }" form left right))) + written (EvMinted _ _) protocol = pure (protocol, Nothing) + written (EvBuilt depth term) protocol = do + value <- borrowed protocol term + pure (protocol, Just (indented depth (printf "%s.1 := %s # %s" (labelled protocol depth answer) value (T.unpack answer)))) + written (EvAnswer depth term) protocol = do + let stem :: String + stem = labelled protocol depth answer + naming :: String + naming = printf "%s.2" stem + (protocol', value) <- valued protocol naming term + pure (protocol', Just (indented depth (printf "%s := %s # 𝕄(%s.1)" naming value stem))) + -- The value of a term, next to the name this line gives it: the name an + -- earlier line gave this very term, where one did, and the term itself + -- otherwise. Either way the term takes the name of this line, so the next + -- line holding it points back here and not further. Only a term whose + -- value is a symbol is named at all, since that is a term a firing + -- answered with and every other one is worth no less written out than + -- pointed at; the term is matched verbatim, so a term that differs from + -- the one a name stands for is written out however deep the difference + -- sits (#1292). + valued :: Protocol -> String -> Expression -> IO (Protocol, String) + valued protocol naming term = case denoted term of + Nothing -> (,) protocol <$> render term + Just _ -> do + value <- maybe (render term) (pure . T.unpack) (namedLookup term protocol._named) + pure (protocol{_named = namedInsert term (T.pack naming) protocol._named}, value) + -- The value of a term on a line that claims no name for it: the name an + -- earlier line gave this very term, where one did, and the term itself + -- otherwise. The built answer of a firing stands on such a line, since the + -- line under it holds the term 𝕄 made of that one and the two are not the + -- same term: were the first of the pair to claim the name, the second + -- would be written as the first and the morphing would be as invisible as + -- it was before it had a line at all (#1298). + borrowed :: Protocol -> Expression -> IO String + borrowed protocol term = case namedLookup term protocol._named of + Nothing -> render term + Just naming -> pure (T.unpack naming) + -- The line of an operand with the judgment that reduced it and the term it + -- was reduced from appended to it as a comment, since the value alone says + -- what the meta was bound to and neither what it was bound from nor what + -- was done to it β€” and which of the two judgments ran is the whole + -- difference between a line ending in data and one ending in a term + -- (#1306). It is the very term the entry wrote under + -- the meta, spelled the way the calculus reads it β€” '$.x' is read as 'ΞΎ.x' + -- β€” which is why it goes through 'salted' and not through the 'render' the + -- value goes through: the sweet syntax writes that same term as a bare 'x', + -- and a bare 'x' reads as a name rather than as the term it is. It is + -- flattened like everything else, so the whole line stays one line of πœ‘. + commented :: String -> Judgment -> Expression -> IO String + commented line judgment operand = printf "%s # %s(%s)" line (letter judgment) <$> salted operand + -- The same for a line no judgment made: a 'symbolize' one, which stands + -- the data of a term into unknowns and reduces nothing, so the comment + -- names the meta of the entry it was told to stand rather than a judgment + -- applied to a term of the calculus (see 'EvSymbolize'). + commented' :: String -> Expression -> IO String + commented' line source = printf "%s # %s" line <$> salted source + -- The name of an operand meta on this firing of its Ξ» function: the meta + -- the entry spells it with and which firing of the run this is, since + -- every entry numbers its own metas from 𝛿1 and 𝑛1 and only the firing + -- tells two 𝛿1 apart. The number counts the firings of the whole run and + -- not those of one Ξ» function, so the second firing of one entry and the + -- second of another never write the same name (#1261), and it is the very + -- number the XML format gives the firing in its 'id'. The answer of the + -- firing is named the same way, with a step of its own appended: a firing + -- answers once, so '𝑛.4.1' and '𝑛.4.2' are the built term and the normal + -- form of the one answer firing 4 gave (#1298). The firing a line + -- belongs to is the one opened one level above it. + labelled :: Protocol -> Int -> T.Text -> String + labelled protocol depth spelling = + printf "%s.%d" (T.unpack spelling) (fromMaybe 0 (Map.lookup (depth - 1) protocol._open)) + +-- The same protocol as XML, which is what '--protocol' writes when the file it +-- names ends in '.xml' (see 'withEvalFunc'). It carries the very facts the text +-- format carries and carries them as markup rather than as a πœ‘-term a reader +-- would have to parse back: the name of an element says what its record is and +-- the value the record carries stands as the text of the element, so the edge +-- from the firing that minted an unknown to the record that consumed it is read +-- off the markup instead of off the spelling of a term (#1245, #1257). That +-- edge is what 'minted' carries: a firing hands out one symbol per bare 𝜎 of +-- its answer and each of them stands in a record of its own, the way what is +-- known about a symbol does, since no one symbol of a term stands for the whole +-- of it and picking one would say nothing (#1280). The term itself stays as the +-- text of the element, for a reader and not for a program. +-- +-- The two lines an answer stands on are two elements, and they are told apart +-- by their names for the same reason every other pair of records is: 'built' +-- holds the term the entry wrote and 'answer' the normal form 𝕄 made of it, so +-- a consumer reading 'answer' reads what it always read and one asking what the +-- entry itself wrote has an element to ask (#1298). +-- +-- Nothing is buffered: an element is written the moment its record arrives, +-- and the ones it closes are written just before it, so a run firing thousands +-- of Ξ» functions costs no more memory than one firing a single Ξ» function and +-- the last element to reach the disk is the last one the run got to. What is +-- still open when the run ends is closed by 'endEvalXml'. +saveEvalXml :: Handle -> IORef Nesting -> (Expression -> IO String) -> SaveEvalFunc +saveEvalXml handle cursor render report = do + written <- atomicModify cursor (elements report) + mapM_ (hPutStrLn handle) written + logDebug (printf "Saved %d line(s) of the XML protocol" (length written)) + where + -- The elements a report is written as, together with what the protocol has + -- counted once they are written. A report closes every firing it stands + -- outside of before it opens or writes anything of its own. + elements :: Evaluation -> Nesting -> IO (Nesting, [String]) + elements (EvRun judgment locator) nesting = + pure + ( nesting{_closing = (0, opened judgment) : nesting._closing} + , + [ "" + , printf "<%s locator=\"%s\">" (opened judgment) (quoted locator) + ] + ) + elements (EvFiring depth key judgment site) nesting = do + locator <- render site + pure + ( nesting + { _fires = fires + , _openedAt = Map.insert depth fires nesting._openedAt + , _closing = (depth, "evaluate") : kept + } + , closers ++ [indented depth (printf "" (quoted key) fires (opened judgment) (escapeXML locator))] + ) + where + (kept, closers) = closed depth nesting._closing + fires :: Int + fires = nesting._fires + 1 + elements (EvStuck depth key judgment self) nesting = do + form <- render self + let (kept, closers) = closed depth nesting._closing + pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (quoted key) (opened judgment) (escapeXMLText form))]) + elements (EvData depth spelling _ value) nesting = do + record <- stood value + pure (nesting{_closing = kept}, closers ++ [indented depth record]) + where + (kept, closers) = closed depth nesting._closing + -- An operand of a 'dataize' line either came down to data, which is + -- the data, or to the datum manufactured for an unknown, which is the + -- formation that unknown names and never the 42 standing for it. These + -- are two different facts, so the name of the element tells them apart + -- the way 𝔻(…) does in the text format, rather than leaving a reader + -- to test which of two attributes an element carries (#1257). What 𝔻 + -- was applied to is a term either way, and the element named after the + -- judgment holds it as the text format holds it (#1278). + stood :: Either Int Bytes -> IO String + stood (Left symbol) = do + form <- render (standing symbol) + pure (printf "%s" (escapeXML (labelled nesting depth spelling)) (escapeXMLText form)) + stood (Right bytes) = pure (printf "%s" (escapeXML (labelled nesting depth spelling)) (escapeXMLText (printBytes bytes))) + elements (EvTerm depth spelling _ term) nesting = do + body <- render term + let (kept, closers) = closed depth nesting._closing + pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (escapeXML (labelled nesting depth spelling)) (escapeXMLText body))]) + -- A 'symbolize' line binds a meta to a term like every other line of a + -- firing, and the markup holds what it was bound to and not what it was + -- made from: the term an operand was reduced from is what the text format + -- comments a line with and the markup has never carried, so the two lines + -- the text now tells apart by that comment are one element here (#1306). + elements (EvSymbolize depth spelling _ term) nesting = do + body <- render term + let (kept, closers) = closed depth nesting._closing + pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (escapeXML (labelled nesting depth spelling)) (escapeXMLText body))]) + elements (EvKnown depth symbol bytes) nesting = + pure (nesting{_closing = kept}, closers ++ [indented depth known]) + where + (kept, closers) = closed depth nesting._closing + known :: String + known = printf "%s" (sigma symbol) (escapeXMLText (printBytes bytes)) + elements (EvJoin depth spelling _ term) nesting = do + body <- render term + let (kept, closers) = closed depth nesting._closing + pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (escapeXML (labelled nesting depth spelling)) (escapeXMLText body))]) + elements (EvJoined depth fresh (one, two)) nesting = + pure (nesting{_closing = kept}, closers ++ [indented depth joint]) + where + (kept, closers) = closed depth nesting._closing + joint :: String + joint = printf "%s %s" (sigma fresh) (sigma one) (sigma two) + elements (EvMinted depth symbol) nesting = + pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (sigma symbol))]) + where + (kept, closers) = closed depth nesting._closing + elements (EvBuilt depth term) nesting = do + body <- render term + let (kept, closers) = closed depth nesting._closing + naming :: String + naming = printf "%s.1" (labelled nesting depth answer) + pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (escapeXML naming) (escapeXMLText body))]) + elements (EvAnswer depth term) nesting = do + body <- render term + let (kept, closers) = closed depth nesting._closing + naming :: String + naming = printf "%s.2" (labelled nesting depth answer) + pure (nesting{_closing = kept}, closers ++ [indented depth (printf "%s" (escapeXML naming) (escapeXMLText body))]) + -- The name of an operand meta on this firing, spelled the way the text + -- protocol's own 'labelled' spells it: the meta the entry names it with + -- in the YAML, followed by which firing of the whole run this is, the + -- very number the element's own 'id' carries, since every entry numbers + -- its own metas from 𝛿1 and 𝑛1 and only the firing tells two 𝛿1 apart + -- (#1261). An answer is named the same way, with the step of the pair + -- appended (#1298). The firing a record belongs to is the one opened one + -- level above it. + labelled :: Nesting -> Int -> T.Text -> String + labelled nesting depth spelling = + printf "%s.%d" (T.unpack spelling) (fromMaybe 0 (Map.lookup (depth - 1) nesting._openedAt)) + -- The name of a symbol, spelled the way every term carrying it is spelled, + -- so a reader joining a record to a term compares two strings that look + -- alike instead of a number against a name. + sigma :: Int -> String + sigma = printFunction . FnSymbol + quoted :: T.Text -> String + quoted = escapeXML . T.unpack + +-- Close every element the run left open, innermost first, which is what makes +-- the document well-formed however the run ended. It is written on the way out +-- of 'withEvalFunc', failure included, so a run giving up half-way through a +-- derivation still leaves a file a parser can read. A run failing before it +-- opened the protocol leaves an empty file, exactly as it leaves one under the +-- text format. +endEvalXml :: Handle -> IORef Nesting -> IO () +endEvalXml handle cursor = do + nesting <- readIORef cursor + mapM_ (hPutStrLn handle) (snd (closed 0 nesting._closing)) + writeIORef cursor nesting{_closing = []} + +-- The elements a record standing at this depth closes, innermost first, +-- together with what stays open once they are written. A record belongs to the +-- firing opened above it, so one standing at the depth of an open element, or +-- shallower than it, is the first record after that element and ends it. +closed :: Int -> [(Int, String)] -> ([(Int, String)], [String]) +closed depth open = (kept, [indented level (printf "" element) | (level, element) <- shut]) + where + (shut, kept) = span ((>= depth) . fst) open + +-- Stand a line at the depth of what it reports, which is what makes both +-- protocols a tree rather than a list: two spaces per level. +indented :: Int -> String -> String +indented depth line = replicate (2 * depth) ' ' ++ line + +-- Read, change and write the cursor back in one go, which a firing nested in +-- the reduction of an operand of another needs: the outer firing is still +-- half-written when the inner one starts counting. +atomicModify :: IORef a -> (a -> IO (a, b)) -> IO b +atomicModify ref action = readIORef ref >>= action >>= \(value, made) -> writeIORef ref value >> pure made + +-- The formation a symbol names, which is what 𝔻 brought an operand down to and +-- what a 'symbolize' line knows the data of: a 𝜎 is the name of a Ξ» function +-- and no term of its own, so 𝔻 is applied to the formation carrying it and +-- never to the name alone (#1269). Both formats stand it where they report +-- what 𝔻 was applied to, since they carry the same facts and disagreeing about +-- this one would make a reader of the markup believe 𝔻 took a name (#1278). +standing :: Int -> Expression +standing symbol = ExFormation [BiLambda (FnSymbol symbol)] + +-- How the calculus spells the meta a Ξ» function writes its answer to, which is +-- the name the protocol writes the two lines of a firing's answer under. +answer :: T.Text +answer = "𝑛" dontSaveEval :: SaveEvalFunc dontSaveEval _ = pure () diff --git a/src/Encoding.hs b/src/Encoding.hs --- a/src/Encoding.hs +++ b/src/Encoding.hs @@ -64,11 +64,16 @@ toASCII PA_FORMATION{..} = PA_FORMATION (toASCII attr) (map toASCII voids) ARROW' (toASCII expr) toASCII PA_VOID{..} = PA_VOID (toASCII attr) ARROW' QUESTION toASCII PA_LAMBDA{..} = PA_LAMBDA' func - toASCII PA_DELTA{..} = PA_DELTA' bytes + toASCII PA_DELTA{..} = PA_DELTA' (toASCII bytes) + toASCII PA_META_LAMBDA{meta = META{hd = S, ..}} = PA_META_LAMBDA' (META EXCL S' rest) toASCII PA_META_LAMBDA{meta = META{..}} = PA_META_LAMBDA' (META EXCL F' rest) - toASCII PA_META_DELTA{..} = PA_META_DELTA' (META EXCL D' (rest meta)) + toASCII PA_META_DELTA{..} = PA_META_DELTA' (META EXCL D'' (rest meta)) toASCII pair = pair +instance ToASCII BYTES where + toASCII (BT_META meta) = BT_META (META EXCL D'' (rest meta)) + toASCII bts = bts + instance ToASCII ALPHA where toASCII AL_IDX{..} = AL_IDX ALPHA' idx toASCII AL_META{..} = AL_META ALPHA' (META EXCL I' (rest meta)) @@ -111,7 +116,7 @@ toASCII ARG_ATTR{..} = ARG_ATTR (toASCII attr) toASCII ARG_EXPR{..} = ARG_EXPR (toASCII expr) toASCII ARG_BINDING{..} = ARG_BINDING (toASCII binding) - toASCII bts@ARG_BYTES{} = bts + toASCII ARG_BYTES{..} = ARG_BYTES (toASCII bytes) instance ToASCII EXTRA where toASCII EXTRA{..} = EXTRA (toASCII meta) func (map toASCII args) diff --git a/src/Evaluate.hs b/src/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Evaluate.hs @@ -0,0 +1,420 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +-- The Evaluation function 𝔼 and everything a Ξ» function of the '--symbolic' +-- file needs to fire: finding the Ξ» of a formation, bringing the operands of +-- its entry down, standing the data of a term it reduced into unknowns, +-- minting the symbols its answer carries and writing the firing into the +-- protocol. 𝕄 and 𝔻 live in 'Morph' and 'Dataize', and what +-- all three share β€” the context, the budget, the signals β€” lives in 'Morph', +-- which this module imports. The edges pointing back the other way, 𝕄 asking +-- 𝔼 to fire, are injected as '_evaluate' and '_fire' rather than imported, the +-- way 'Dataize' hands 'Morph' its '_reduce' (see 'EvaluationFunc'). +module Evaluate (evaluation, fired, lambda) where + +import AST +import Builder (buildExpressionThrows, contextualize) +import Control.Exception (throwIO, try) +import Control.Monad (foldM, unless) +import Data.List (partition) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe, isNothing) +import qualified Data.Text as T +import Deps (BuildTermMethodS, Evaluation (..), State (..), Term (..)) +import Lambdas (Lambda (..), Meta (..), joined, matched, minted, symbolized) +import Matcher (MetaValue (..), Subst, combine, substEmpty, substSingle, substSlot) +import Morph (ReduceContext (..), ReduceException (..), deeper, morph', morphing, normalized, unparked) +import Printer (printFunction) +import Text.Printf (printf) +import Yaml (ExtraArgument (..)) + +-- The Evaluation function 𝔼(b, e, s): it fires the Ξ» function of a formation +-- 'b' against the global universe 'e', under the incoming state 𝑠, normalizes +-- its raw result 𝒩(e₁) = n, and returns that normal form together with the new +-- state. Normalizing here makes 𝔼's codomain 𝓝 (as its type demands), so +-- callers ('fire', 'ml') need no follow-up 'normalize' premise. The universe is +-- passed explicitly as the second argument (rather than threaded behind the +-- scenes), matching how the morphing 𝕄 and dataization 𝔻 functions carry it. +-- Every firing writes itself into the protocol the '--protocol' option keeps +-- (see 'symbol'). Firings are written in the order they start, so the Ξ» +-- function of a head reduced by 'ml' stands above the one dispatched on its +-- result; that order carries nothing, since what depends on what is read off +-- the symbols. +-- +-- A formation carrying no Ξ» binding has nothing to fire, and that is a question +-- the calculus answers rather than a malformed one: 𝔼 hands back βŠ₯, the way 𝕄 +-- does for a term nobody reduces further. Neither is a Ξ» naming a symbol: a +-- symbol is a value nobody worked out, so no entry of the '--symbolic' file +-- answers it and 𝔼 gets stuck on it exactly as it does on a Ξ» name nothing +-- answers β€” the site is written to the protocol and '_partial' parks it, rather +-- than the run ending on a term the program was entitled to hold (#1287). Only +-- 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") + 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, + -- so it is told apart here and nowhere else: a formation carrying several + -- Ξ» bindings, or one standing for a meta or a slot, is still a term phino + -- cannot work out. + unknown :: [Binding] -> Maybe Int + unknown bindings = case partition isLambda bindings of + ([BiLambda (FnSymbol idx)], _) -> Just idx + _ -> Nothing + -- Get stuck on a symbol the way 'symbol' gets stuck on a Ξ» name no entry + -- answers, and for the same reason: nothing answers either, so there is no + -- firing to make. The site is written to the protocol under the name the + -- 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 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 +-- '--symbolic' file, where each is an entry phino answers the firing with +-- itself (see 'Lambdas'). The entry is looked up by the Ξ» name and there is at +-- most one, since the keys are unique; a name no entry answers has no Ξ» +-- function to fire at all, and 𝔼 gets stuck on it β€” the one behaviour left +-- here. The formation 'self' is the one 𝔼 fired against, its Ξ» binding already +-- removed, so the entry may name the attributes of it; 'form' is that same +-- formation as 𝔼 was handed it, Ξ» binding and all, which is what the protocol +-- says a firing nothing answered was about, since a formation with its Ξ» split +-- off is no longer the term anybody asked about; the universe 'univ' is what +-- every operand of it is reduced inside. What comes back is the term the entry +-- answers with, morphed (see 'answered'). +-- +-- The firing writes itself into the protocol as it goes: the entry that +-- answered first, then each operand as it is reduced, then the answer. Whatever +-- fires inside an operand writes itself between those lines, one level deeper, +-- which is what makes the protocol a tree of firings rather than a list of +-- them. A name no entry answers writes itself too, before 𝔼 gets stuck on it, +-- so the protocol says what was asked for whether or not '_partial' goes on to +-- park the run β€” once, and not once per attempt: a site '_partial' has parked +-- is still standing in the residue the '_deep' walk goes over, so 𝔼 is fired on +-- it again and again answers nothing, and a reader counting the '?(…)' lines +-- counts the sites 𝔼 got stuck on rather than the passes the walk made over +-- them (see '_parked', #1300). +symbol :: T.Text -> Expression -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) +symbol func form self univ state caller = case matched caller._symbolic func of + Nothing -> do + unless (func `elem` caller._parked) (caller._saveEval (EvStuck caller._nesting func caller._judgment form)) + throwIO (Stuck func) + Just entry -> do + caller._saveEval (EvFiring caller._nesting func caller._judgment caller._site) + let ctx = caller{_nesting = caller._nesting + 1} + (bound, dataized) <- foldM (down ctx) (substEmpty, state) entry._dataized + (bound', morphed) <- foldM (through ctx) (bound, dataized) entry._morphed + (bound'', stood) <- foldM (masked ctx) (bound', morphed) entry._symbolized + (bound''', forked) <- foldM (paired ctx) (bound'', stood) entry._paired + answered ctx entry bound''' forked + where + -- Bring one 'dataize' operand down through 𝔻 and bind the bytes meta that + -- names it. An operand 𝔻 could not bring down to data β€” a site '_partial' + -- parked β€” leaves the firing with nothing to bind, so it gets stuck like a + -- Ξ» function no entry answers at all, and gets stuck on the very name that + -- parked the operand rather than on the Ξ» function of this firing: an entry + -- answers this one, so blaming it would name a Ξ» function the '--symbolic' + -- file carries where the one nothing answers stands one reduction deeper + -- (#1288). The name travels back in the state the parked run hands over, + -- since the signal it was made of stayed inside that run (see '_stuck'). + -- Every symbol dataizes to the very same datum, so the protocol is told + -- which unknown that datum was manufactured for rather than the datum + -- itself (see 'State'). + -- + -- The reduction runs on a universe of its own, so a signal escaping it + -- carries that universe's derivation and not the spine's; 'unparked' drops + -- it and lets the spine frame around this firing attach its own, which is + -- what keeps '--sequence' free of the synthetic attribute the operand was + -- reduced under. + down :: ReduceContext -> (Subst, State) -> (Meta, Expression) -> IO (Subst, State) + down ctx (bound, state') (meta, term) = do + (value, state'') <- unparked (ctx._reduce univ ctx (operand term) state'{_manufactured = Nothing, _stuck = Nothing}) + case value of + Nothing -> throwIO (Stuck (fromMaybe func state''._stuck)) + Just bytes -> do + ctx._saveEval (EvData ctx._nesting meta._spelling term (maybe (Right bytes) Left state''._manufactured)) + bound' <- bind meta (MvBytes bytes) bound + pure (bound', state'') + -- Reduce one 'morph' operand through 𝕄 and bind the expression meta that + -- names it. Unlike a dataized one it may stay an unknown: a term carrying a + -- symbol is a perfectly good normal form, and standing it into the answer + -- 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' + ctx._saveEval (EvTerm ctx._nesting meta._spelling term normal) + bound' <- bind meta (MvExpression normal) bound + pure (bound', state'') + -- Stand the data of a term another line of the entry has bound into + -- unknowns and bind the expression meta naming what it becomes. Nothing is + -- reduced here: what changes is that every datum of the term becomes a + -- symbol nobody worked out, so a normal form reached from a literal + -- compares with one reached from an unknown, which is what a later join of + -- two branches of a fork needs. What is known about each fresh symbol goes + -- into the protocol ahead of the line binding the term, since the term is + -- written with the symbols and the facts are what tells a constant among + -- them from an unknown. + masked :: ReduceContext -> (Subst, State) -> (Meta, Expression) -> IO (Subst, State) + masked ctx (bound, state') (meta, term) = do + reduced <- buildExpressionThrows term bound + let (stood, known, spent) = symbolized reduced state'._minted + mapM_ (ctx._saveEval . fact) known + ctx._saveEval (EvSymbolize ctx._nesting meta._spelling term stood) + bound' <- bind meta (MvExpression stood) bound + pure (bound', state'{_minted = spent}) + where + fact :: (Int, Bytes) -> Evaluation + fact (fresh, bytes) = EvKnown ctx._nesting fresh bytes + -- Join two terms other lines of the entry have bound into one and bind the + -- expression meta naming it. Nothing is reduced here either: the two are + -- required to match verbatim and every pair of symbols they differ by + -- becomes one fresh symbol (see 'joined'), which is the one term standing + -- for either of them and so the one thing a fork can answer with. Two + -- terms differing anywhere else are no join at all and the firing gets + -- stuck the way a Ξ» function no entry answers does, so '_partial' parks + -- the site rather than failing the whole run (#1246). + -- + -- What is known about each fresh symbol goes into the protocol ahead of + -- the line binding the term, the way a 'symbolize' line writes what it + -- knows, since a reader ties the join to the two values it was made from + -- by that fact alone and never by diffing the terms. + paired :: ReduceContext -> (Subst, State) -> (Meta, (Meta, Meta)) -> IO (Subst, State) + paired ctx (bound, state') (meta, (left, right)) = do + one <- branch left + two <- branch right + case joined one two state'._minted of + Nothing -> throwIO (Stuck func) + Just (term, made, spent) -> do + mapM_ (ctx._saveEval . fact) made + ctx._saveEval (EvJoin ctx._nesting meta._spelling (left._spelling, right._spelling) term) + bound' <- bind meta (MvExpression term) bound + pure (bound', state'{_minted = spent}) + where + -- The term one side of the join is bound to, which is what a meta of + -- the entry reads out of the substitution the firing has made (see + -- 'earlier' in 'Lambdas': a 'join' line names metas bound above it and + -- nothing else, so there is always one to read). + branch :: Meta -> IO Expression + branch named = buildExpressionThrows (ExMeta named._name) bound + fact :: (Int, (Int, Int)) -> Evaluation + fact (fresh, pair) = EvJoined ctx._nesting fresh pair + -- Mint the fresh symbols the answer asks for, build it and reduce it + -- through 𝕄. A bare 𝜎 stands for an unknown nobody has named yet, so each + -- one is bound to the next symbol the run has not minted, and the state + -- counts them, which is what keeps two firings from spelling two unknowns + -- alike. Each one goes into the protocol as it is handed out, ahead of the + -- answer carrying it, so a reader ties an unknown back to the firing that + -- made it without reading the term it stands in (#1280). + -- + -- The answer is morphed rather than handed back as the entry wrote it, + -- because a firing is one of the things a term can come from and every + -- other one answers a normal form: 'Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎 ⟧ )' written in + -- the program morphs to the formation of the object, so the same term + -- answered by an entry has to morph to it too. Two terms of one forma that + -- do not look alike cannot be compared leaf by leaf, and comparing them is + -- what a fork of two branches is (#1268). The residual and the answer lines + -- of the protocol grow by the size of that formation, which is the price of + -- saying the same thing one way. + -- + -- Both terms go to the protocol, the built one before 'settled' is asked + -- about it and the normal one after, so the morphing is a step of the + -- protocol and no silent change of shape: whatever 𝕄 fires on the way opens + -- its block between the two, where every other firing of an operand opens + -- its own, and the formation standing on the second line is read as what + -- the three tokens on the first came to (#1298). + answered :: ReduceContext -> Lambda -> Subst -> State -> IO (Expression, State) + answered ctx entry bound state' = do + let (fresh, spent) = minted entry._answer state'._minted + mapM_ (ctx._saveEval . EvMinted ctx._nesting) [idx | (_, FnSymbol idx) <- fresh] + symbolic <- foldM mint bound fresh + built <- buildExpressionThrows entry._answer symbolic + ctx._saveEval (EvBuilt ctx._nesting built) + (normal, state'') <- settled built univ state'{_minted = spent} ctx + ctx._saveEval (EvAnswer ctx._nesting normal) + pure (normal, state'') + mint :: Subst -> (Slot, Function) -> IO Subst + mint bound (slot, fresh) = case combine (substSlot slot (MvFunction fresh)) bound of + Just bound' -> pure bound' + Nothing -> throwIO (userError (printf "A fresh symbol of Ξ» function '%s' clashes with an existing binding" (T.unpack func))) + -- 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) + bind :: Meta -> MetaValue -> Subst -> IO Subst + bind meta value bound = case combine (substSingle meta._name value) bound of + Just bound' -> pure bound' + Nothing -> + throwIO + (userError (printf "The meta '%s' of Ξ» function '%s' clashes with an existing binding" (T.unpack meta._spelling) (T.unpack func))) + +-- Ask 𝕄 about a term and fire the Ξ» of the formation it reaches, as long as an +-- entry of the '--symbolic' file answers it, asking 𝕄 about every answer again: +-- what comes back is the answer of the last firing, or nothing at all where +-- nothing fired. This is the firing 'ml' makes without the dispatch that makes +-- 'ml' make it β€” the one 𝕄 leaves to 𝔻. A Ξ» no entry answers is left alone +-- rather than fired and got stuck on, so what phino cannot compute stays as it +-- was written with or without '_partial'; a Ξ» function that cannot fire deeper +-- on the spine still fails the run, exactly as it does under 𝕄 alone, and +-- '_partial' parks it. A formation still waiting for its arguments is left +-- alone too (see 'saturated'). A term standing as the +-- target of a dispatch is where 'ml' has its say: the Ξ» is fired only where the +-- dispatched attribute is none of the formation's own (see 'demanded'). +fired :: Maybe Attribute -> Expression -> Expression -> State -> ReduceContext -> IO (Maybe Expression, State) +fired dispatched term univ state caller = do + ctx <- deeper caller + morphed <- try (reduced ctx) + case morphed of + Right (ExFormation bds, state') + | demanded bds -> maybe (pure (Nothing, state')) (evaluated ctx state' (ExFormation bds)) (saturated bds) + Right (_, state') -> pure (Nothing, state') + Left failure -> parked state failure + where + -- Whether the dispatch the term stands under demands the Ξ» of the formation + -- 𝕄 reached. 'ml' fires that Ξ» only where the dispatched attribute is none + -- of the formation's own, since 'dot' resolves the dispatch before 'ml' is + -- ever reached, and a walk firing it first answers a formation the dispatch + -- no longer fits (#1187). A term standing anywhere else is demanded by + -- nothing and the walk fires what 'mf' left bare, as it always has. + demanded :: [Binding] -> Bool + demanded bds = not (any bound bds) + where + bound :: Binding -> Bool + bound (BiTau attr _) = Just attr == dispatched + bound _ = False + -- The term the walk was handed, as 𝕄 leaves it. The chains it drops are + -- the walk's and not the spine's, which reports one step of its own (see + -- 'morph'), so a stuck Ξ» function leaves without a derivation. + reduced :: ReduceContext -> IO (Expression, State) + reduced = settled term univ state + -- Fire the Ξ» of the formation 𝕄 reached and go on from its answer, keeping + -- the answer of the last firing. A Ξ» no entry of the '--symbolic' file + -- answers is not fired at all, which is what keeps the walk as total as 𝕄 + -- itself. The firing reports itself to '_saveEval', so the protocol and the + -- program agree on what was answered. + -- + -- A firing that cannot be made β€” an operand of the entry that never came + -- down to data, above all β€” is parked exactly as a term 𝕄 could not reduce + -- is, and for the same reason: the walk meets every Ξ» function a program + -- declares and one of them answering nothing is no failure of the run but a + -- part of it phino cannot decide. Without this the signal left the walk + -- altogether and the binding after the one it stopped on was never entered, + -- so a single entry nothing could answer ended a run over a whole object + -- model (#1288). The state it had reached goes back rather than the one the + -- walk came in with, since the firings before it are done and the symbols + -- they minted are spent. + evaluated :: ReduceContext -> State -> Expression -> (T.Text, Expression) -> IO (Maybe Expression, State) + evaluated ctx state' form (func, self) + | isNothing (matched ctx._symbolic func) = pure (Nothing, state') + | otherwise = do + made <- try (symbol func form self univ state' ctx) + case made of + Right (answer, answered) -> do + (again, reached) <- fired dispatched answer univ answered ctx + pure (Just (fromMaybe answer again), reached) + Left failure -> parked state' failure + -- A site the walk cannot reduce β€” a Ξ» function whose operands never came + -- down to data, or one the step budget ran out on β€” is left as it was + -- written and the walk goes on, which is what a partial morphing is: phino + -- stops where it cannot decide rather than failing the whole run. The state + -- the parked site had reached travels back, so the symbols it minted before + -- it stopped are never minted again; a signal carrying none of its own is + -- answered with the state the caller reached before it was raised, which is + -- the walk's state where 𝕄 was asked and the firing's where a firing was + -- made. The chain it parked on is dropped, since that chain is the walk's + -- and not the spine's. + parked :: State -> ReduceException -> IO (Maybe Expression, State) + parked _ (StuckAt _ _ reached) | caller._partial = pure (Nothing, reached) + parked _ (OutOfStepsAt _ _ reached) | caller._partial = pure (Nothing, reached) + parked reached (Stuck _) | caller._partial = pure (Nothing, reached) + parked reached (OutOfSteps _) | caller._partial = pure (Nothing, reached) + parked _ (LoopingAt _ _ reached) = pure (Nothing, reached) + parked reached (Looping _) = pure (Nothing, reached) + parked _ (StuckAt func _ _) = throwIO (Stuck func) + parked _ (OutOfStepsAt limit _ _) = throwIO (OutOfSteps limit) + parked _ failure = throwIO failure + +-- A term of the '--symbolic' file as 𝕄 leaves it: an entry's answer on its way +-- out of a firing, and the term the deep walk was handed on its way in. 𝕄 takes +-- normal forms only and a term written in an entry, or taken from the program +-- as it was written, is not necessarily one, so it is normalized against the +-- universe first, exactly as '--inside' normalizes what it is handed. It is +-- reduced against the universe itself rather than inside it: a term bound under +-- an attribute of the universe reaches a ρ naming that attribute too, and +-- neither of these two is a part of the program the way an operand of a firing +-- is. Both chains are dropped, since what happens here is the protocol's +-- business and not the spine's. +settled :: Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) +settled term univ state ctx = do + (normal, _) <- normalized term ((univ, Nothing) :| []) ctx + ((morphed, _), state') <- morph' (normal, (univ, Nothing) :| []) univ state ctx + pure (morphed, state') + +-- Split the Ξ» binding off a formation for the LAMBDA morphing rule: the name of +-- the Ξ» function to fire and the formation it fires against, the Ξ» binding +-- removed. A formation with no Ξ» binding, or with more than one, has nothing to +-- fire; neither has one carrying a symbol, which is a Ξ» name nothing answers. +-- The three are one answer here but not to 𝔼, which tells all three apart: no Ξ» +-- at all is answered with βŠ₯, a symbol gets stuck the way an unanswered name +-- does, and only the rest is a term it cannot work out (see 'evaluation'). +lambda :: [Binding] -> Maybe (T.Text, Expression) +lambda bds = case partition isLambda bds of + ([BiLambda (Function func)], rest) -> Just (func, ExFormation rest) + _ -> Nothing + +-- Whether a binding names a Ξ» function, whatever that name turns out to be. +-- 𝔼 asks this before 'lambda' does its splitting, since a formation carrying no +-- Ξ» at all is answered with βŠ₯ rather than refused (see 'evaluation'). +isLambda :: Binding -> Bool +isLambda (BiLambda _) = True +isLambda _ = False + +-- The same as 'lambda', but only for a formation that is saturated: one with +-- every binding of it filled (see 'filled'). A void is an argument the program +-- has not given yet, so such a formation is a method waiting to be applied +-- rather than an application waiting to be computed, and firing it would hand +-- the Ξ» function a βˆ… where it expects a value. 𝔻 needs no such guard, since it +-- fires only what dataization demands and nothing demands a method; the deep +-- walk meets every one a program declares β€” the method table of the object +-- model above all β€” so it asks first (see 'deepened'). +saturated :: [Binding] -> Maybe (T.Text, Expression) +saturated bds = case lambda bds of + Just (func, ExFormation rest) | all filled rest -> Just (func, ExFormation rest) + _ -> Nothing + +-- Whether a binding hands the formation something to work with. A void does +-- not: it names an argument the program has still to supply. Neither does βŠ₯: +-- the deep walk reduces a body in the scope of the formation around it, and a +-- formation standing unapplied still holds ρ ↦ βˆ…, so a ΞΎ.ρ in that body comes +-- back as βŠ₯ rather than as the object the next dispatch supplies (#1196). +filled :: Binding -> Bool +filled (BiVoid _) = False +filled (BiTau _ ExTermination) = False +filled _ = True diff --git a/src/Files.hs b/src/Files.hs --- a/src/Files.hs +++ b/src/Files.hs @@ -4,14 +4,15 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT --- This module accesses the filesystem: it ensures a file exists and --- collects every file path under a directory. -module Files (FsException (..), ensuredFile, allPathsIn) where +-- This module accesses the filesystem: it ensures a file exists, +-- collects every file path under a directory and replaces a file atomically. +module Files (FsException (..), ensuredFile, allPathsIn, overwrite) where -import Control.Exception (Exception, throwIO) -import Control.Monad (forM) -import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) -import System.FilePath (()) +import Control.Exception (Exception, onException, throwIO) +import Control.Monad (forM, when) +import System.Directory (copyPermissions, doesDirectoryExist, doesFileExist, listDirectory, removeFile, renameFile) +import System.FilePath (takeDirectory, takeFileName, ()) +import System.IO (Handle, hClose, hPutStr, hSetEncoding, openTempFileWithDefaultPermissions, utf8) import Text.Printf (printf) data FsException @@ -27,6 +28,20 @@ ensuredFile pth = do exists <- doesFileExist pth if exists then pure pth else throwIO (FileDoesNotExist pth) + +overwrite :: FilePath -> String -> IO () +overwrite file content = do + (temp, handle) <- openTempFileWithDefaultPermissions (takeDirectory file) (takeFileName file) + replace temp handle `onException` (hClose handle >> removeFile temp) + where + replace :: FilePath -> Handle -> IO () + replace temp handle = do + hSetEncoding handle utf8 + hPutStr handle content + hClose handle + exists <- doesFileExist file + when exists (copyPermissions file temp) + renameFile temp file -- Recursively collect all file paths in provided directory allPathsIn :: FilePath -> IO [FilePath] diff --git a/src/LaTeX.hs b/src/LaTeX.hs --- a/src/LaTeX.hs +++ b/src/LaTeX.hs @@ -36,6 +36,7 @@ import Locator (locatedExpression) import Margin (WithMargin, defaultMargin, withMargin) import Matcher +import Metas (lonely) import Misc import Render (Render (render)) import Replacer (replaceExpression) @@ -328,7 +329,9 @@ toLaTeX TAU = TAU' toLaTeX B = B' toLaTeX D = D' + toLaTeX D'' = D' toLaTeX F = F' + toLaTeX S = S' toLaTeX mh = mh instance ToLaTeX BYTES where @@ -579,14 +582,18 @@ let extras' = map ((`renderToLatex` defaultLatexContext) . extraToCST) extras in braced (intercalate " and " extras') +-- Every rule is bared before it is rendered: an index that tells a meta from no +-- other within the rule is dropped, so a rule naming a single expression meta +-- says 'e' and not 'e_1', the way a rule threading a single state says 's' and +-- not 's_1' (see 'conclusionStateName' and #1260). explainRules :: [Y.Rule] -> String -explainRules = intercalate "\n" . map explainRule +explainRules = intercalate "\n" . map (explainRule . lonely) explainMorphRules :: [Y.MorphRule] -> String -explainMorphRules = intercalate "\n" . map explainMorphRule +explainMorphRules = intercalate "\n" . map (explainMorphRule . lonely) explainDataizeRules :: [Y.DataizeRule] -> String -explainDataizeRules = intercalate "\n" . map explainDataizeRule +explainDataizeRules = intercalate "\n" . map (explainDataizeRule . lonely) explainContextualizeRules :: [Y.ContextualizeRule] -> String -explainContextualizeRules = intercalate "\n" . map explainContextualizeRule +explainContextualizeRules = intercalate "\n" . map (explainContextualizeRule . lonely) diff --git a/src/Lambdas.hs b/src/Lambdas.hs new file mode 100644 --- /dev/null +++ b/src/Lambdas.hs @@ -0,0 +1,528 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +-- Which Ξ» functions exist is a property of the object model being reduced, not +-- of the calculus. phino therefore implements none of them: it reads them from +-- the YAML file given with '--symbolic', where each is an entry answering the +-- firing with a term of the calculus: +-- +-- > - Ξ»: L_number_plus +-- > dataize: +-- > 𝛿1: $.ρ +-- > 𝛿2: $.x +-- > 𝑛: Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎 ⟧ ) ) +-- +-- The 'Ξ»' of an entry is a regular expression over Ξ» names, matching the whole +-- name, so a plain name means that one function while 'L_box_[0-9]+_number' +-- stands for a family of them. It is unique: the lookup answers one entry or +-- none. 'dataize' names the operands brought down through 𝔻, each binding a +-- bytes meta 𝛿1, and 'morph' the ones reduced through 𝕄, each binding an +-- expression meta 𝑛1; both are terms of the calculus, where ΞΎ stands for the +-- formation being fired, so '$.x' is its x, and Ξ¦ for the universe. The term +-- under '𝑛' is what the firing answers with, and a bare 𝜎 in it mints a fresh +-- symbol. +-- +-- 'symbolize' is the third block and reduces nothing at all. It takes a term +-- an earlier block of the very same entry has already bound and binds an +-- expression meta of its own to that term with every datum in it standing for +-- an unknown, so a normal form reached from a literal is written the way one +-- reached from an unknown is written and the two of them compare as +-- expressions (see 'symbolized'). +-- +-- 'join' is the fourth block and reduces nothing either. It takes two metas the +-- entry has bound already and binds one of its own to the two terms joined, +-- which is what a branching Ξ» function answers with: a fork stands for either +-- of its branches and no one branch stands for both, so the shape both of them +-- have, with a fresh symbol wherever they differ, is what the answer names +-- (see 'joined'). +-- +-- An entry answers, it never computes: the job of these functions is symbolic +-- morphing, so the answer carries a symbol standing for a value nobody worked +-- out, and the data its 'dataize' operands came down to is not its to read. +-- An answer mentioning a bytes meta is refused where the file is read. +-- +-- This module holds the entries and the four things reading one takes β€” the +-- lookup of a Ξ» name, the minting of the symbols an answer asks for, the +-- standing of the data of a term into unknowns and the joining of two terms +-- into one. Firing an entry is 𝔼's business and lives in 'Morph', which alone +-- holds the judgments an entry reduces its operands with. +module Lambdas + ( Lambda (..) + , LambdaException (..) + , Lambdas + , Meta (..) + , emptyLambdas + , joined + , matched + , minted + , readLambdas + , symbolized + , taken + ) +where + +import AST +import Control.Exception (Exception, throwIO) +import Control.Monad (void) +import Data.Aeson (FromJSON (parseJSON), Key, Object, withObject, (.!=), (.:), (.:?)) +import Data.List (find) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Yaml as Yaml +import Logger (logDebug) +import Parser (parseBytes, parseExpression) +import Slots (Slots (slots)) +import Text.Printf (printf) +import Text.Regex.PCRE (matchTest) +import Text.Regex.PCRE.ByteString (Regex, compUTF8, compile, execBlank) +import Yaml (referenceless) + +-- One meta an entry of the file binds: the name the file spells it with, which +-- is the name the protocol of '--protocol' reports it back under, and the name +-- a substitution keeps it under, which is the one πœ‘-calculus gives it. The two +-- differ β€” '𝑛1' against 'n1', '𝛿1' against 'd1' β€” so an entry is read through +-- the very parser a rewriting rule's pattern is read through and never +-- guesses. +data Meta = Meta + { _spelling :: Text + , _name :: Text + } + +-- One Ξ» function phino may fire, as the file spells it: the key it is +-- registered under, the operands it brings down to data, the operands it +-- reduces to a normal form, the terms of those it stands the data of into +-- unknowns, the pairs of those it joins into one term and the term it answers +-- with. +data Lambda = Lambda + { _key :: Text + , _dataized :: [(Meta, Expression)] + , _morphed :: [(Meta, Expression)] + , _symbolized :: [(Meta, Expression)] + , _paired :: [(Meta, (Meta, Meta))] + , _answer :: Expression + } + +-- Every Ξ» function phino may fire, in the order the file lists them: each key, +-- a regular expression over Ξ» names, paired with the entry it introduces. A +-- lookup walks them top to bottom and the first key matching the whole name +-- wins, so one entry may stand for a family of Ξ» functions while a plain name, +-- being a regular expression matching itself, keeps meaning that one function. +newtype Lambdas = Lambdas [(Regex, Lambda)] + +data LambdaException + = -- The '--symbolic' file is not a list of Ξ» function entries. + BrokenLambdas FilePath String + deriving anyclass (Exception) + +instance Show LambdaException where + show (BrokenLambdas file failure) = + printf "The Ξ» functions of '%s' cannot be read: %s" file failure + +instance FromJSON Lambda where + parseJSON = withObject "Lambda" $ \entry -> do + key <- entry .: "Ξ»" + lambda <- + Lambda key + <$> operands key bytesMeta entry "dataize" + <*> operands key expressionMeta entry "morph" + <*> operands key expressionMeta entry "symbolize" + <*> pairs (T.unpack key) entry + <*> entry .: "𝑛" + sigmas (T.unpack key) lambda._answer + dataless (T.unpack key) lambda._answer + earlier (T.unpack key) lambda + pure lambda + where + -- The metas one block of an entry binds, each paired with the term it is + -- reduced from, ordered by the name of the meta: a YAML mapping keeps no + -- order of its own, so numbering the metas 𝛿1, 𝛿2, … and 𝑛1, 𝑛2, … is + -- what reduces them the way they are written. + operands :: Text -> (Text -> Yaml.Parser Meta) -> Object -> Key -> Yaml.Parser [(Meta, Expression)] + operands key kind entry name = do + mapping <- entry .:? name .!= (Map.empty :: Map Text Expression) + mapM bound (Map.toAscList mapping) + where + bound :: (Text, Expression) -> Yaml.Parser (Meta, Expression) + bound (meta, term) = do + referenceless (T.unpack key) (T.unpack meta) term + kind meta >>= \named -> pure (named, term) + -- The meta a 'morph' block binds: '𝑛1' is written the way πœ‘-calculus + -- writes it and stands for the same meta a rule's 'pattern' would bind, + -- so the parser of the calculus is what reads it here too. + expressionMeta :: Text -> Yaml.Parser Meta + expressionMeta meta = case parseExpression (T.unpack meta) of + Right (ExMeta name) -> pure (Meta meta name) + _ -> fail (printf "The operand '%s' is not an expression meta, such as '𝑛1'" (T.unpack meta)) + -- The meta a 'dataize' block binds, which is a bytes meta and not an + -- expression one, since what 𝔻 answers is data and nothing else. + bytesMeta :: Text -> Yaml.Parser Meta + bytesMeta meta = case parseBytes (T.unpack meta) of + Right (BtMeta name) -> pure (Meta meta name) + _ -> fail (printf "The operand '%s' is not a bytes meta, such as '𝛿1'" (T.unpack meta)) + -- The metas a 'join' block binds, each paired with the two it joins, + -- ordered by the name of the meta the way every other block is. A line + -- joins two metas and never three: it stands for a choice between two + -- branches, and a walk over three terms in parallel is no such choice. + pairs :: String -> Object -> Yaml.Parser [(Meta, (Meta, Meta))] + pairs key entry = do + mapping <- entry .:? "join" .!= (Map.empty :: Map Text [Text]) + mapM joins (Map.toAscList mapping) + where + joins :: (Text, [Text]) -> Yaml.Parser (Meta, (Meta, Meta)) + joins (meta, [left, right]) = do + named <- expressionMeta meta + branches <- (,) <$> expressionMeta left <*> expressionMeta right + pure (named, branches) + joins (meta, _) = + fail + ( printf + "The operand '%s' of Ξ» function '%s' must join exactly two metas, such as '[𝑛1, 𝑛2]'" + (T.unpack meta) + key + ) + -- Every 'symbolize' and 'join' line reads terms the entry has bound + -- already: a 'morph' operand, a line above it in its own block or, for a + -- 'join' line, a 'symbolize' one, since nothing else of an entry is a + -- normal form yet and the blocks run in the order the entry lists them + -- here. A line naming anything else names a term nobody reduced, and the + -- file is wrong where it is read rather than half-way through a firing. + earlier :: String -> Lambda -> Yaml.Parser () + earlier key lambda = do + stood <- go (map (_name . fst) lambda._morphed) lambda._symbolized + void (goJoins stood lambda._paired) + where + go :: [Text] -> [(Meta, Expression)] -> Yaml.Parser [Text] + go reduced [] = pure reduced + go reduced ((meta, term) : rest) = case term of + ExMeta name | name `elem` reduced -> go (meta._name : reduced) rest + _ -> unbound meta + goJoins :: [Text] -> [(Meta, (Meta, Meta))] -> Yaml.Parser [Text] + goJoins reduced [] = pure reduced + goJoins reduced ((meta, (left, right)) : rest) + | all ((`elem` reduced) . _name) [left, right] = goJoins (meta._name : reduced) rest + | otherwise = unbound (if left._name `elem` reduced then right else left) + unbound :: Meta -> Yaml.Parser a + unbound meta = + fail + ( printf + "The operand '%s' of Ξ» function '%s' names no meta bound by 'morph' or by a line above it" + (T.unpack meta._spelling) + key + ) + -- A bare 𝜎 is the one anonymous meta an answer may carry, since minting + -- a fresh symbol is exactly what it asks for; every other one names a + -- match the entry never made. + sigmas :: String -> Expression -> Yaml.Parser () + sigmas key answer = case [kind | Slot kind _ <- slots answer, kind /= "S"] of + [] -> pure () + kind : _ -> fail (printf "The anonymous meta '!%s' cannot be referenced in the '𝑛' of Ξ» function '%s'" (T.unpack kind) key) + -- An entry answers a term carrying a symbol and never a value it worked + -- out, so the data its operands came down to is not its to read. + dataless :: String -> Expression -> Yaml.Parser () + dataless key answer + | computes answer = fail (printf "The '𝑛' of Ξ» function '%s' reads data, while a symbolic answer may mention nothing but 𝜎" key) + | otherwise = pure () + +-- Whether a term reads data β€” carries a bytes meta anywhere inside it β€” which +-- is what tells an answer that computes from one that merely stands for an +-- unknown. +computes :: Expression -> Bool +computes = goExpr + where + goExpr :: Expression -> Bool + goExpr (ExFormation bds) = any goBinding bds + goExpr (ExApplication expr arg) = goExpr expr || goArgument arg + goExpr (ExDispatch expr _) = goExpr expr + goExpr (ExPhiMeet _ _ expr) = goExpr expr + goExpr (ExPhiAgain _ _ expr) = goExpr expr + goExpr (ExBytes bts) = goBytes bts + goExpr _ = False + goBinding :: Binding -> Bool + goBinding (BiTau _ expr) = goExpr expr + goBinding (BiDelta bts) = goBytes bts + goBinding _ = False + goArgument :: Argument -> Bool + goArgument (ArTau _ expr) = goExpr expr + goArgument (ArAlpha _ expr) = goExpr expr + goBytes :: Bytes -> Bool + goBytes (BtMeta _) = True + goBytes (BtAny _) = True + goBytes _ = False + +-- No Ξ» function at all: every one of them gets stuck. This is what a run +-- without '--symbolic' fires against. +emptyLambdas :: Lambdas +emptyLambdas = Lambdas [] + +-- Read the Ξ» functions from a YAML file. A key that is no regular expression, +-- a key two entries share, an entry with no answer under '𝑛', an answer +-- reading data and malformed YAML all fail here, before any reduction starts, +-- so a run never gets half-way through a derivation to discover that one of +-- its Ξ» functions cannot be read at all. +readLambdas :: FilePath -> IO Lambdas +readLambdas path = do + entries <- Yaml.decodeFileEither path >>= either broken pure + mapM_ (unique entries) entries + registered <- Lambdas <$> mapM keyed entries + logDebug (printf "Loaded %d Ξ» function(s) from '%s'" (length entries) path) + pure registered + where + broken :: Yaml.ParseException -> IO [Lambda] + broken failure = throwIO (BrokenLambdas path (Yaml.prettyPrintParseException failure)) + -- Two entries under one key are one entry too many: nothing tells them + -- apart any more, so the second is unreachable and the file is wrong + -- rather than merely redundant. + unique :: [Lambda] -> Lambda -> IO () + unique entries entry + | length (filter ((== entry._key) . (._key)) entries) == 1 = pure () + | otherwise = throwIO (BrokenLambdas path (printf "the key '%s' is used by more than one entry" (T.unpack entry._key))) + -- The key as the regular expression it is, made to match the whole name, + -- so that a plain name means that one Ξ» function and not every name it is + -- a part of. + keyed :: Lambda -> IO (Regex, Lambda) + keyed entry = do + compiled <- compile compUTF8 execBlank (encodeUtf8 ("^(?:" <> entry._key <> ")$")) + either (unreadable entry._key) (\key -> pure (key, entry)) compiled + unreadable :: Text -> (a, String) -> IO b + unreadable key (_, failure) = + throwIO (BrokenLambdas path (printf "the key '%s' is not a regular expression: %s" (T.unpack key) failure)) + +-- The entry whose key matches the whole Ξ» name, if any. There is at most one: +-- the keys are unique, so a name either has a Ξ» function or has none at all. +matched :: Lambdas -> Text -> Maybe Lambda +matched (Lambdas entries) func = snd <$> find (\(key, _) -> matchTest key (encodeUtf8 func)) entries + +-- The fresh symbols an answer asks for, one per bare 𝜎 it was written with, +-- each paired with the slot that asked for it, together with the count of +-- symbols the run has minted once they are taken. Uniqueness is the state's +-- job and not the file's: the state 𝑠 threaded through 𝕄, 𝔻 and 𝔼 carries how +-- many symbols the run has minted so far, so every firing takes the next names +-- and no two unknowns are ever spelled alike. The names are sequential rather +-- than random, which keeps a symbolic run reproducible. +minted :: Expression -> Int -> ([(Slot, Function)], Int) +minted answer spent = (zip fresh [FnSymbol idx | idx <- [spent + 1 ..]], spent + length fresh) + where + fresh :: [Slot] + fresh = [slot | slot@(Slot kind _) <- slots answer, kind == "S"] + +-- What a walk standing the data of a term into unknowns carries from one +-- sub-term to the next: how many symbols the run has minted once everything +-- left of this sub-term is standing, and what is known about each symbol +-- minted along the way, the last of them first. +type Minting = (Int, [(Int, Bytes)]) + +-- The term with every datum of it standing for an unknown instead: each +-- 'Ξ” ‍ b' binding becomes a 'Ξ» ‍ 𝜎k' naming a fresh symbol, one per +-- occurrence, so '⟦ Ξ” ‍ b ⟧' reads as '⟦ Ξ» ‍ 𝜎k ⟧' and a normal form +-- reached from a literal is written the way one reached from an unknown is +-- written, the two of them comparing as expressions. It is the binding and not +-- the formation around it that changes, since a datum carries a ρ of its own +-- and so does the unknown it is put beside. A term nobody worked a value out +-- in passes through unchanged. +-- +-- Only the Ο† chain is walked. A term carries the value it stands for where +-- that chain ends, so a datum anywhere else says nothing about the term and is +-- left alone, the whole subtree of it (see 'denoted'). What sits under ρ +-- belongs to the object around this one, and a normal form drags the universe +-- it was reduced inside along under ρ, so a walk reaching into it would stand +-- the data of the whole program into unknowns to say one thing about one term. +-- What sits under a method is code and not data: the literals of +-- 'neg ↦ ⟦ Ο† ↦ ΞΎ.ρ.times( -1 ) ⟧' are the body of something nobody has called, +-- and minting a symbol per literal of every method a carrier declares would +-- write dozens of unknowns nobody reads for one value that is read (#1293). +-- +-- What is known about each fresh symbol comes back beside the term: the data +-- dataizing the formation it names answers. That is a fact about the symbol +-- and no binding of it β€” a 𝜎 is the name of a Ξ» function, neither a datum +-- nor a term β€” which is why it travels apart from the term rather than inside +-- it. The count of symbols the run has minted once they are taken comes back +-- too, uniqueness being the state's job here exactly as it is in 'minted'. +symbolized :: Expression -> Int -> (Expression, [(Int, Bytes)], Int) +symbolized term spent = case goExpr term (spent, []) of + (masked, (spent', known)) -> (masked, reverse known, spent') + where + goExpr :: Expression -> Minting -> (Expression, Minting) + goExpr (ExFormation bds) minting = + let (bds', minting') = goBindings bds minting + in (ExFormation bds', minting') + goExpr (ExApplication expr arg) minting = + let (expr', minting') = goExpr expr minting + (arg', minting'') = goArgument arg minting' + in (ExApplication expr' arg', minting'') + goExpr (ExDispatch expr attr) minting = + let (expr', minting') = goExpr expr minting + in (ExDispatch expr' attr, minting') + goExpr (ExPhiMeet prefix idx expr) minting = + let (expr', minting') = goExpr expr minting + in (ExPhiMeet prefix idx expr', minting') + goExpr (ExPhiAgain prefix idx expr) minting = + let (expr', minting') = goExpr expr minting + in (ExPhiAgain prefix idx expr', minting') + goExpr expr minting = (expr, minting) + goBindings :: [Binding] -> Minting -> ([Binding], Minting) + goBindings [] minting = ([], minting) + goBindings (bd : rest) minting = + let (bd', minting') = goBinding bd minting + (rest', minting'') = goBindings rest minting' + in (bd' : rest', minting'') + -- One binding of a formation stood into unknowns. The Ξ” of the formation + -- is its value and becomes a symbol; its Ο† is where the value of a term + -- that has no Ξ” is reached, so the walk goes on through it; every other + -- binding is carried as it was written, the whole subtree of it. + goBinding :: Binding -> Minting -> (Binding, Minting) + goBinding (BiDelta bts) (spent', known) = + (BiLambda (FnSymbol fresh), (fresh, (fresh, bts) : known)) + where + fresh :: Int + fresh = spent' + 1 + goBinding (BiTau AtPhi expr) minting = + let (expr', minting') = goExpr expr minting + in (BiTau AtPhi expr', minting') + goBinding bd minting = (bd, minting) + goArgument :: Argument -> Minting -> (Argument, Minting) + goArgument (ArTau attr expr) minting = + let (expr', minting') = goExpr expr minting + in (ArTau attr expr', minting') + goArgument (ArAlpha alpha expr) minting = + let (expr', minting') = goExpr expr minting + in (ArAlpha alpha expr', minting') + +-- What a walk joining two terms carries from one sub-term to the next: how +-- many symbols the run has minted once everything left of this sub-term is +-- joined, the fresh symbol every pair of differing symbols was given, since +-- one pair met twice is one choice and not two, and those pairs in the order +-- they were met, the last of them first. +type Joining = (Int, Map (Int, Int) Int, [(Int, (Int, Int))]) + +-- The two terms joined into the one term standing for either of them, which is +-- what a fork of two branches answers with: neither branch is the answer, the +-- value being the one nobody has picked, and the shape both of them have is. +-- The walk goes over the two in parallel and requires them to match verbatim, +-- with one exception: where a 'Ξ» ‍ 𝜎A' binding meets a different 'Ξ» ‍ 𝜎B' one +-- it mints a fresh symbol and stands it there, and the same pair met again +-- further down gets that very symbol, since the branch it came from is one +-- choice however often the two terms differ by it. Two identical branches join +-- into that same term and nothing is minted at all. Only the Ο† chain is +-- compared, exactly as 'symbolized' stands only that chain into unknowns: +-- everything else is carried from the first branch, since the value of a +-- branch is where its Ο† chain ends and what sits under ρ or under a method is +-- none of it (see 'goBinding' below). +-- +-- Any other difference β€” a datum against a symbol, two different data, a +-- binding one of them carries and the other does not β€” is no join, and nothing +-- comes back: a fork whose branches differ in structure is stuck the way a Ξ» +-- function no entry answers is, and bringing two such branches to one shape is +-- the program's business rather than phino's. This is why a datum is never +-- joined with anything and why a branch carrying one goes through 'symbolized' +-- first (#1246). +-- +-- What each fresh symbol stands for comes back beside the term, the two +-- symbols it was minted for in the order the branches were given, since +-- dataizing its formation answers what dataizing one of the two answers and +-- that is a fact about the symbol rather than a binding of it. The count of +-- symbols the run has minted once they are taken comes back too, uniqueness +-- being the state's business here exactly as it is in 'minted'. +joined :: Expression -> Expression -> Int -> Maybe (Expression, [(Int, (Int, Int))], Int) +joined left right spent = taking <$> goExpr left right (spent, Map.empty, []) + where + -- The term the walk built, with what it minted put back in the order the + -- pairs were met and the count of symbols the run has spent by then. + taking :: (Expression, Joining) -> (Expression, [(Int, (Int, Int))], Int) + taking (term, (spent', _, made)) = (term, reverse made, spent') + goExpr :: Expression -> Expression -> Joining -> Maybe (Expression, Joining) + goExpr (ExFormation one) (ExFormation two) joining = do + (bds, joining') <- goBindings one two joining + pure (ExFormation bds, joining') + goExpr (ExApplication one arg) (ExApplication two arg') joining = do + (expr, joining') <- goExpr one two joining + (applied, joining'') <- goArgument arg arg' joining' + pure (ExApplication expr applied, joining'') + goExpr (ExDispatch one attr) (ExDispatch two attr') joining + | attr == attr' = do + (expr, joining') <- goExpr one two joining + pure (ExDispatch expr attr, joining') + goExpr (ExPhiMeet prefix idx one) (ExPhiMeet prefix' idx' two) joining + | prefix == prefix' && idx == idx' = do + (expr, joining') <- goExpr one two joining + pure (ExPhiMeet prefix idx expr, joining') + goExpr (ExPhiAgain prefix idx one) (ExPhiAgain prefix' idx' two) joining + | prefix == prefix' && idx == idx' = do + (expr, joining') <- goExpr one two joining + pure (ExPhiAgain prefix idx expr, joining') + goExpr one two joining + | one == two = Just (one, joining) + | otherwise = Nothing + goBindings :: [Binding] -> [Binding] -> Joining -> Maybe ([Binding], Joining) + goBindings [] [] joining = Just ([], joining) + goBindings (one : rest) (two : rest') joining = do + (bd, joining') <- goBinding one two joining + (bds, joining'') <- goBindings rest rest' joining' + pure (bd : bds, joining'') + goBindings _ _ _ = Nothing + -- One binding of each term joined. A Ξ» binding naming a symbol is the one + -- place the two may differ, since a symbol is a value nobody worked out + -- and the two branches standing one each is exactly what a fork is. The Ο† + -- of a formation is walked into, that being where the value of the branch + -- is reached; every other binding is taken from the first branch, the whole + -- subtree of it, and never compared at all. + -- + -- That is the rule ρ has always followed, read off what a branch is rather + -- than off the attribute: what sits under ρ belongs to the object around + -- this one, and the two branches of a fork are reduced in scopes of their + -- own β€” each inside the universe its own operand was reduced in β€” so their + -- ρ differ wherever that reduction left a trace, and a walk comparing them + -- would refuse every fork whose branches 𝕄 reached by two different routes. + -- A method is the same: its body is code nobody has called, so two branches + -- differing inside one are not two values, and minting a symbol per literal + -- of every method the carrier declares writes unknowns nobody reads + -- (#1293). The shape the answer keeps is the first branch's, methods and + -- all, so the program can go on dispatching on what the fork answered. + goBinding :: Binding -> Binding -> Joining -> Maybe (Binding, Joining) + goBinding (BiLambda (FnSymbol one)) (BiLambda (FnSymbol two)) joining + | one /= two = case picked (one, two) joining of + (fresh, joining') -> Just (BiLambda (FnSymbol fresh), joining') + goBinding (BiTau AtPhi one) (BiTau AtPhi two) joining = do + (expr, joining') <- goExpr one two joining + pure (BiTau AtPhi expr, joining') + goBinding bd@(BiTau attr _) (BiTau attr' _) joining + | attr == attr' = Just (bd, joining) + goBinding one two joining + | one == two = Just (one, joining) + | otherwise = Nothing + goArgument :: Argument -> Argument -> Joining -> Maybe (Argument, Joining) + goArgument (ArTau attr one) (ArTau attr' two) joining + | attr == attr' = do + (expr, joining') <- goExpr one two joining + pure (ArTau attr expr, joining') + goArgument (ArAlpha alpha one) (ArAlpha alpha' two) joining + | alpha == alpha' = do + (expr, joining') <- goExpr one two joining + pure (ArAlpha alpha expr, joining') + goArgument one two joining + | one == two = Just (one, joining) + | otherwise = Nothing + -- The fresh symbol standing for one pair of differing symbols, and what + -- the walk carries once it is taken: a pair met before keeps the symbol it + -- was given already, and one met for the first time takes the next name + -- the run has not minted. + picked :: (Int, Int) -> Joining -> (Int, Joining) + picked pair joining@(spent', names, made) + | Just name <- Map.lookup pair names = (name, joining) + | otherwise = (fresh, (fresh, Map.insert pair fresh names, (fresh, pair) : made)) + where + fresh :: Int + fresh = spent' + 1 + +-- The last symbol a program already carries, which is where minting starts: a +-- program written by an earlier run holds symbols of its own, and a fresh one +-- must never be spelled like one of them. +taken :: Expression -> Int +taken program = maximum (0 : symbols program) diff --git a/src/Matcher.hs b/src/Matcher.hs --- a/src/Matcher.hs +++ b/src/Matcher.hs @@ -18,7 +18,7 @@ | MvIndex Int -- α𝑖 | MvBytes Bytes -- !b | MvBindings [Binding] -- !B - | MvFunction Text -- !F + | MvFunction Function -- !F | MvExpression Expression -- !e deriving (Eq, Show) @@ -81,13 +81,25 @@ | ptn == tgt = [substEmpty] | otherwise = [] +-- A Ξ» meta stands for any Ξ» name at all β€” an ordinary one and a symbol alike, +-- since a symbol is a name nothing answers and not a variable of the rule +-- language (see 'FnSymbol'). Every other pair matches only itself. matchFunction :: Function -> Function -> [Subst] -matchFunction (FnMeta meta) (Function name) = [substSingle meta (MvFunction name)] -matchFunction (FnAny slot) (Function name) = [substSlot slot (MvFunction name)] +matchFunction (FnMeta meta) tgt + | named tgt = [substSingle meta (MvFunction tgt)] +matchFunction (FnAny slot) tgt + | named tgt = [substSlot slot (MvFunction tgt)] matchFunction ptn tgt | ptn == tgt = [substEmpty] | otherwise = [] +-- Whether a Ξ» function is a name a program wrote rather than a meta-variable +-- a rule wrote. +named :: Function -> Bool +named (Function _) = True +named (FnSymbol _) = True +named _ = False + matchBinding :: Binding -> Binding -> [Subst] matchBinding (BiVoid pattr) (BiVoid tattr) = matchAttribute pattr tattr matchBinding (BiDelta (BtMeta meta)) (BiDelta tdata) = [substSingle meta (MvBytes tdata)] @@ -114,14 +126,24 @@ matchBindings _ _ = [] -- A meta binding stands for any leading run of the target bindings, so every --- way of splitting the target into that run and the rest is tried. +-- way of splitting the target into that run and the rest is tried. The rest is +-- carried down one binding at a time instead of being cut out of the target +-- anew at every index, which is what made a formation of N bindings cost N +-- walks of itself rather than one, and the run itself is put together only +-- where the pattern after it matched, so a split the pattern throws away costs +-- nothing to name. A meta binding with nothing after it takes the whole rest in +-- one step: the pattern is out of bindings, so the only split that matches is +-- the one leaving nothing behind (#1316). matchBindingsMeta :: (MetaValue -> Subst) -> [Binding] -> [Binding] -> [Subst] -matchBindingsMeta bind pbs tbs = - catMaybes - [ combine (bind (MvBindings before)) subst - | (before, after) <- [splitAt idx tbs | idx <- [0 .. length tbs]] - , subst <- matchBindings pbs after - ] +matchBindingsMeta bind [] tbs = [bind (MvBindings tbs)] +matchBindingsMeta bind pbs tbs = go [] tbs + where + go :: [Binding] -> [Binding] -> [Subst] + go before after = + catMaybes [combine (bind (MvBindings (reverse before))) subst | subst <- matchBindings pbs after] + ++ case after of + [] -> [] + (tb : rest) -> go (tb : before) rest matchExpression' :: MatchExpressionFunc matchExpression' (ExMeta meta) tgt = [substSingle meta (MvExpression tgt)] diff --git a/src/Metas.hs b/src/Metas.hs new file mode 100644 --- /dev/null +++ b/src/Metas.hs @@ -0,0 +1,129 @@ +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +-- The goal of the module is to collect the meta-variables a term was written +-- with and to drop the index from the ones that stand alone in their kind. +-- Every name starts with the sigil of the kind it belongs to -- 'e', 'n', 'k', +-- 't', 'B', 'd', 'F' or 'i' -- and carries an index after it, which is there to +-- tell one meta of a kind from another. A term naming a kind just once has +-- nothing to tell apart, so the index counts nothing and the sigil may stand +-- alone, the way an anonymous meta stands. +module Metas (Metas (..), lonely) where + +import AST +import Data.List (nub) +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Text.Read (readMaybe) + +class Metas a where + -- The names of the meta-variables the term was written with, an anonymous + -- one named by the sigil of its kind alone + metas :: a -> [Text] + + -- The term with each of the given names cut down to the sigil it starts with + bare :: [Text] -> a -> a + +-- The term with the index dropped from every name whose kind it mentions once, +-- since an index that tells a meta from no other only slows the reader down +lonely :: (Metas a) => a -> a +lonely term = bare (filter alone named) term + where + named :: [Text] + named = nub (metas term) + alone :: Text -> Bool + alone name = indexed name && length (filter (kin name) named) == 1 + kin :: Text -> Text -> Bool + kin name other = T.take 1 name == T.take 1 other + indexed :: Text -> Bool + indexed name = isJust (readMaybe (T.unpack (T.drop 1 name)) :: Maybe Int) + +-- A name stands for the meta-variable it names, so it answers with itself and +-- sheds its index when asked to +instance Metas Text where + metas name = [name] + bare names name = if name `elem` names then T.take 1 name else name + +-- An anonymous meta is known by the sigil of its kind, which is the name every +-- meta of that kind is cut down to, and there is nothing in it to shed +instance Metas Slot where + metas (Slot kind _) = [kind] + bare _ slot = slot + +instance (Metas a) => Metas [a] where + metas = concatMap metas + bare names = map (bare names) + +instance (Metas a) => Metas (Maybe a) where + metas = maybe [] metas + bare names = fmap (bare names) + +instance Metas Expression where + metas (ExMeta name) = metas name + metas (ExAny slot) = metas slot + metas (ExFormation bds) = metas bds + metas (ExApplication expr arg) = metas expr ++ metas arg + metas (ExDispatch expr attr) = metas expr ++ metas attr + metas (ExPhiMeet _ _ expr) = metas expr + metas (ExPhiAgain _ _ expr) = metas expr + metas (ExBytes bts) = metas bts + metas _ = [] + bare names (ExMeta name) = ExMeta (bare names name) + bare names (ExFormation bds) = ExFormation (bare names bds) + bare names (ExApplication expr arg) = ExApplication (bare names expr) (bare names arg) + bare names (ExDispatch expr attr) = ExDispatch (bare names expr) (bare names attr) + bare names (ExPhiMeet prefix idx expr) = ExPhiMeet prefix idx (bare names expr) + bare names (ExPhiAgain prefix idx expr) = ExPhiAgain prefix idx (bare names expr) + bare names (ExBytes bts) = ExBytes (bare names bts) + bare _ expr = expr + +instance Metas Argument where + metas (ArTau attr expr) = metas attr ++ metas expr + metas (ArAlpha alpha expr) = metas alpha ++ metas expr + bare names (ArTau attr expr) = ArTau (bare names attr) (bare names expr) + bare names (ArAlpha alpha expr) = ArAlpha (bare names alpha) (bare names expr) + +instance Metas Binding where + metas (BiTau attr expr) = metas attr ++ metas expr + metas (BiVoid attr) = metas attr + metas (BiDelta bts) = metas bts + metas (BiLambda func) = metas func + metas (BiMeta name) = metas name + metas (BiAny slot) = metas slot + bare names (BiTau attr expr) = BiTau (bare names attr) (bare names expr) + bare names (BiVoid attr) = BiVoid (bare names attr) + bare names (BiDelta bts) = BiDelta (bare names bts) + bare names (BiLambda func) = BiLambda (bare names func) + bare names (BiMeta name) = BiMeta (bare names name) + bare _ bd = bd + +instance Metas Attribute where + metas (AtMeta name) = metas name + metas (AtAny slot) = metas slot + metas _ = [] + bare names (AtMeta name) = AtMeta (bare names name) + bare _ attr = attr + +instance Metas Alpha where + metas (AlMeta name) = metas name + metas (AlAny slot) = metas slot + metas _ = [] + bare names (AlMeta name) = AlMeta (bare names name) + bare _ alpha = alpha + +instance Metas Bytes where + metas (BtMeta name) = metas name + metas (BtAny slot) = metas slot + metas _ = [] + bare names (BtMeta name) = BtMeta (bare names name) + bare _ bts = bts + +-- A symbol 𝜎1 is a name and not a meta-variable, so nothing counts it among +-- the metas and nothing sheds the index that tells one symbol from another +instance Metas Function where + metas (FnMeta name) = metas name + metas (FnAny slot) = metas slot + metas _ = [] + bare names (FnMeta name) = FnMeta (bare names name) + bare _ func = func diff --git a/src/Morph.hs b/src/Morph.hs --- a/src/Morph.hs +++ b/src/Morph.hs @@ -12,28 +12,31 @@ -- The Morphing function 𝕄 and the machinery every reduction of the calculus is -- threaded with: the context, the step budget, the signals a stuck run raises --- and the plumbing that reads a rule's premises. 𝔻 lives in 'Dataize', which --- imports this module; the one edge pointing back β€” an atom asking phino to --- reduce an operand, which is a dataization β€” is injected as '_reduce' rather --- than imported (see 'ReductionFunc'). -module Morph (ReduceContext (..), ReduceException (..), ReductionFunc, Morphed, Steps (..), deeper, emptyState, excluding, execBuildTerm, insideUniverse, leadsTo, morph, morph', normalized, parking, producer, sidePremise, verb) where +-- and the plumbing that reads a rule's premises. 𝔻 lives in 'Dataize' and 𝔼 in +-- 'Evaluate', both of which import this module; the edges pointing back β€” the +-- 'dataize' operand of a Ξ» function, which is a dataization, and the firing of +-- a Ξ» function itself, which is an evaluation β€” are injected as '_reduce', +-- '_evaluate' and '_fire' rather than imported (see 'ReductionFunc' and +-- 'EvaluationFunc'). +module Morph (ReduceContext (..), ReduceException (..), EvaluationFunc, FiringFunc, ReductionFunc, Morphed, Steps (..), deeper, emptyState, excluding, execBuildTerm, insideUniverse, leadsTo, morph, morph', morphing, normalized, parking, producer, sidePremise, universed, unparked, unvisited, verb) where import AST -import Atoms (ReduceFunc, Registry, fireAtom, registeredAtom) import Builder (buildExpressionThrows, contextualize) import Control.Exception (Exception, catch, throwIO, try) -import Control.Monad (foldM, when) -import Data.List (find, partition) +import Control.Monad (foldM) +import Data.List (find) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import qualified Data.Text as T -import Deps (BuildTermFunc, BuildTermMethodS, Evaluation (..), SaveEvalFunc, SaveStepFunc, State, Term (..)) +import Deps (BuildTermFunc, BuildTermMethodS, Judgment (..), SaveEvalFunc, SaveStepFunc, State (..), Term (..), dontSaveStep) +import Lambdas (Lambdas) import Locator (locatedExpression, withLocatedExpression) import Matcher (MetaValue (..), Subst (..), combine, matchExpression', substEmpty, substSingle) import Must (Must (..)) +import Printer (printExpression) import Random (shuffle) -import Rewriter (RewriteContext (RewriteContext), Rewritten, rewrite) +import Rewriter (RewriteContext (RewriteContext), Rewritten, Seen, rewrite, seenInsert, seenMember) import Rule (RuleContext (RuleContext), matchExpressionWithRule') import Text.Printf (printf) import Yaml (ExtraArgument (..), normalizationRules) @@ -43,23 +46,43 @@ -- judgment's spine is handed and hands on. type Morphed = (Expression, NonEmpty Rewritten) --- How the morphing side reaches back to the dataization one. An atom may ask --- phino to reduce an operand of its own (see 'ReduceFunc' in 'Atoms'), and the --- answer is a whole run of 𝔻 β€” a judgment 𝕄 has no business knowing about, --- since 'Dataize' imports 'Morph' and not the other way round. The reduction is --- therefore injected into the context, the way 'Deps' injects '_buildTerm', and --- 'Dataize' supplies its own 'reduction' for it. -type ReductionFunc = Expression -> ReduceContext -> ReduceFunc +-- How the morphing side reaches back to the dataization one. A Ξ» function +-- brings its 'dataize' operands down through 𝔻, and that is a whole run of a +-- judgment 𝕄 has no business knowing about, since 'Dataize' imports 'Morph' +-- and not the other way round. The reduction is therefore injected into the +-- context, the way 'Deps' injects '_buildTerm', and 'Dataize' supplies its own +-- 'reduction' for it. What comes back is data or nothing at all, since an +-- operand 𝔻 could not bring down to bytes leaves the firing that asked for it +-- with nothing to bind. The state 𝑠 goes in and comes back out, so the symbols +-- a nested run mints are counted in the same sequence as the ones around it. +type ReductionFunc = Expression -> ReduceContext -> Expression -> State -> IO (Maybe Bytes, State) --- The initial, empty state a run of 𝕄 or 𝔻 starts from. The 'State' type itself --- lives in 'Deps' next to 'BuildTermMethod'. +-- How 𝕄 reaches the Evaluation function 𝔼, which lives in 'Evaluate' and +-- imports this module for the machinery every judgment shares. 𝔼 is what the +-- '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 + +-- 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 +-- the program, and what a firing stands there has to look like what the program +-- itself would have morphed to, or the two cannot be compared (#1268). The +-- first argument is the attribute the term stands dispatched under, which is +-- what tells a Ξ» the dispatch demands from one it does not. +type FiringFunc = Maybe Attribute -> Expression -> Expression -> State -> ReduceContext -> IO (Maybe Expression, State) + +-- The initial, empty state a run of 𝕄 or 𝔻 starts from: nothing minted and +-- nothing manufactured yet. The 'State' type itself lives in 'Deps' next to +-- 'BuildTermMethod'. emptyState :: State -emptyState = "" +emptyState = State 0 Nothing Nothing -- How many steps of the 𝕄/𝔻 recursion one branch of a derivation may take -- ('_limit', the '--max-steps' option) and how many the branch reaching this -- point has already taken ('_spent'). 𝕄 and 𝔻 recurse into each other, into the --- premises of their own rules and into the atoms they fire, so a budget local to +-- premises of their own rules and into the Ξ» functions they fire, so a budget local to -- one of those chains is reset by the next nested call and bounds nothing (see -- #1052). This one rides in the context that every such path β€” the spine, the -- side-premises, '_dataize' and '_morph' β€” already carries, so a nested call @@ -75,52 +98,126 @@ -- The context every reduction of the calculus is threaded with β€” 𝕄 here and 𝔻 in -- 'Dataize' β€” carrying the configuration plus the step budget spent so far. Nothing global is fixed here: the universe (the second argument 'e' of -- 𝕄(n, e, s) and 𝔻(n, e, s)) is a plain expression threaded as an argument to --- 'dataize'', 'morph'' and on to the atoms, and the state 's' is threaded the same +-- 'dataize'', 'morph'' and on to the Ξ» functions, and the state 's' is threaded the same -- way (see 'State'). The working expression needed for normalization is taken -- from the head of the step chain, so no separate wrapper type is threaded -- around. data ReduceContext = ReduceContext { _locator :: Expression + , -- Where in the universe the term being reduced stands, which is what a + -- firing of 𝔼 is written under: the protocol names the entry that answered + -- and this names the part of the program the answer belongs to, since one + -- entry answers the same way wherever it is fired and only the site tells + -- two firings of it apart (#1302). It starts as the aim of the run itself + -- ('_locator', the '--locator' option, or the binding '--inside' mints) and + -- the '--deep' walk refines it as it enters a binding, so a Ξ» fired inside + -- an object is written under the locator of that object. It is refined no + -- further than a locator reaches: the head of a dispatch and the argument + -- of an application stand under no attribute of any formation, so a firing + -- there is written under the nearest binding the walk entered, which is + -- where the term it fired against stands. It is kept apart from '_locator' + -- because that one is where a derivation is spliced back into the working + -- expression ('leadsTo', 'normalized'), and the walk reduces terms no + -- locator of the universe aims at. + _site :: Expression + , -- The world this run reduces in, as Ξ¦ denotes it: the program in normal + -- form. Normalization is handed it so that 'dot', dispatching off a + -- formation, can tell the whole program from a part of it and decorate the + -- body with the name Ξ¦ rather than with the program itself; writing the + -- program out would copy it into the term, and into every term that term + -- then dispatches, until the copies weigh hundreds of times what the + -- program does (#1318). Nothing until a run works it out ('universed'), + -- once, and every frame below inherits what the first one named. + _universe :: Maybe Expression , _maxDepth :: Int , _maxCycles :: Int , _steps :: Steps + , _nesting :: Int , _depthSensitive :: Bool , _shuffle :: Bool , _partial :: Bool , _deep :: Bool - , _atoms :: Registry + , _acyclic :: Bool + , -- 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 + -- the 'fire' rule of dataization, and a reader of the protocol is told + -- which of the two asked the question nothing answered. Every frame of 𝕄 + -- names itself here and every frame of 𝔻 does the same, so what a firing + -- reads is the judgment of the frame it was fired from and never of one + -- above it (#1300). + _judgment :: Judgment + , -- The Ξ» functions this run has already got stuck on and written a '?(…)' + -- to the protocol for. A parked site stays in the residue exactly as it was + -- written, so the '_deep' walk over that residue reaches it again and 𝕄 + -- fires 𝔼 on it once more, only to find out what the spine already found + -- out; the site is one and the protocol records it once, so the firings + -- after the first write nothing (see 'symbol' in 'Evaluate', #1300). + _parked :: [T.Text] + , -- The terms the 𝕄 frames above this one are reducing, which is what + -- '_acyclic' answers "have I been here before" with (see 'unvisited'). + _seen :: Seen + , -- The same for 𝔻: the terms the 𝔻 frames above this one are dataizing. The + -- two judgments keep one store each because they ask each other about the + -- very term they were asked about β€” the 'norm' rule hands 𝕄 what 𝔻 was + -- given β€” so a single store shared by both would read that handover as a + -- repeat and park every term 𝔻 morphs (#1290). + _dataized :: Seen + , _symbolic :: Lambdas , _buildTerm :: BuildTermFunc , _reduce :: ReductionFunc + , _evaluate :: EvaluationFunc + , _fire :: FiringFunc , _saveStep :: SaveStepFunc , _saveEval :: SaveEvalFunc } data ReduceException = OutOfSteps Int - | -- An atom could not fire: the '--atoms' registry carries no Ξ» function of - -- that name, so there is nothing to run. The name is that of the atom 𝔼 + | -- 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, + -- so there is nothing to answer with. The name is that of the function 𝔼 -- actually failed on, which for a chain of dispatches is the innermost one, - -- since 'ml' reduces a head before the atom above it fires. + -- since 'ml' reduces a head before the function above it fires. Stuck T.Text | -- A 'Stuck' caught by a frame of the 𝕄/𝔻 spine, together with the - -- derivation that frame had reached (see 'parking'). The head of the chain - -- is the working expression with the stuck application left intact and - -- everything reduced before it already in place: the residual program that - -- '_partial' turns into the 'Residual' outcome. - StuckAt T.Text (NonEmpty Rewritten) + -- derivation and the state that frame had reached (see 'parking'). The head + -- of the chain is the working expression with the stuck application left + -- intact and everything reduced before it already in place: the residual + -- program that '_partial' turns into the 'Residual' outcome. The state + -- travels with it, so the symbols a parked run minted are never minted + -- again. + StuckAt T.Text (NonEmpty Rewritten) State | -- An 'OutOfSteps' caught by a spine frame, carrying that frame's derivation - -- just like 'StuckAt': a term that never reduces is a stuck site too, so - -- '_partial' parks it and hands back the residual instead of failing hard - -- (#1078) - OutOfStepsAt Int (NonEmpty Rewritten) + -- and state just like 'StuckAt': a term that never reduces is a stuck site + -- too, so '_partial' parks it and hands back the residual instead of + -- failing hard (#1078) + OutOfStepsAt Int (NonEmpty Rewritten) State + | -- A judgment was asked to reduce a term a frame above it is already + -- reducing, which it can only ever answer by asking again. 𝕄 and 𝔻 both + -- raise it, each over the terms of its own spine (see 'unvisited'), and + -- neither names itself in the message, since a run that meets the signal + -- meets it through whichever of the two came back. Raised under '_acyclic' + -- alone, so the signal itself is the permission to park on it: a run that + -- never asked for the guard never sees it. + Looping Expression + | -- A 'Looping' caught by a frame of the 𝕄 or 𝔻 spine, carrying that frame's + -- derivation and state the way 'StuckAt' does. The guard runs as a frame + -- opens, before that frame parks anything, so the frame attaching the chain + -- is the one the repeat was reached from and the head of the chain is its + -- working expression β€” the term that came back left exactly where it stood, + -- the way an exhausted budget stops on the last step it could afford. + LoopingAt Expression (NonEmpty Rewritten) State deriving anyclass (Exception) instance Show ReduceException where show (OutOfSteps limit) = printf "Dataization did not finish before reaching the limit of steps: --max-steps=%d" limit - show (OutOfStepsAt limit _) = show (OutOfSteps limit) - show (Stuck func) = printf "Atom '%s' does not exist" (T.unpack func) - show (StuckAt func _) = show (Stuck func) + show (OutOfStepsAt limit _ _) = show (OutOfSteps 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 came back to a term it is already reducing: %s" (printExpression term) + show (LoopingAt term _ _) = show (Looping term) -- Charge one step of the 𝕄/𝔻 recursion to the budget, refusing to descend once -- it is gone. '--max-cycles' and '--max-depth' bound only the normalization run @@ -134,63 +231,29 @@ | spent >= limit = throwIO (OutOfSteps limit) | otherwise = pure ctx{_steps = Steps limit (spent + 1)} --- Split the Ξ» binding off a formation for the LAMBDA morphing rule: the name of --- the atom to fire and the formation it fires against, the Ξ» binding removed β€” --- the two things 𝔼 reports besides the result. A formation with no Ξ» binding, --- or with more than one, has nothing to fire. -lambda :: [Binding] -> Maybe (T.Text, Expression) -lambda bds = case partition isLambda bds of - ([BiLambda (Function func)], rest) -> Just (func, ExFormation rest) - _ -> Nothing - where - isLambda :: Binding -> Bool - isLambda (BiLambda _) = True - isLambda _ = False - --- The same as 'lambda', but only for a formation that is saturated: one with --- every binding of it filled (see 'filled'). A void is an argument the program --- has not given yet, so such a formation is a method waiting to be applied --- rather than an application waiting to be computed, and firing it would hand --- the atom a βˆ… where it expects a value. 𝔻 needs no such guard, since it --- fires only what dataization demands and nothing demands a method; the deep --- walk meets every one a program declares β€” the method table of the object --- model above all β€” so it asks first (see 'deepened'). -saturated :: [Binding] -> Maybe (T.Text, Expression) -saturated bds = case lambda bds of - Just (func, ExFormation rest) | all filled rest -> Just (func, ExFormation rest) - _ -> Nothing - --- Whether a binding hands the formation something to work with. A void does --- not: it names an argument the program has still to supply. Neither does βŠ₯: --- the deep walk reduces a body in the scope of the formation around it, and a --- formation standing unapplied still holds ρ ↦ βˆ…, so a ΞΎ.ρ in that body comes --- back as βŠ₯ rather than as the object the next dispatch supplies (#1196). -filled :: Binding -> Bool -filled (BiVoid _) = False -filled (BiTau _ ExTermination) = False -filled _ = True - --- Run one frame of the 𝕄/𝔻 spine, attaching its derivation to a stuck atom or --- an exhausted budget escaping it. 'Stuck' is raised deep inside an atom, which --- knows nothing about the chain, so the innermost spine frame it reaches is the --- one to record where the derivation stopped: the head of that frame's chain is --- the working expression with the stuck application intact and everything --- reduced before it already in place. The same holds for 'OutOfSteps': a term --- cycling through the universe is no more a failure of the chain than a missing --- atom is, and under '_partial' it deserves the same parked residual (#1078). --- Outer frames see the '…At' signals and let them pass, since their chains are --- prefixes of that one; a side-computation running on a chain of its own strips --- the chain off again (see 'unparked') before the signal reaches the spine. -parking :: NonEmpty Rewritten -> IO a -> IO a -parking seq action = action `catch` rethrow +-- Run one frame of the 𝕄/𝔻 spine, attaching its derivation and its state to a +-- stuck Ξ» function or an exhausted budget escaping it. 'Stuck' is raised deep +-- inside a firing, which knows nothing about the chain, so the innermost spine +-- frame it reaches is the one to record where the derivation stopped: the head +-- of that frame's chain is the working expression with the stuck application +-- intact and everything reduced before it already in place. The same holds for +-- 'OutOfSteps': a term cycling through the universe is no more a failure of the +-- chain than a missing Ξ» function is, and under '_partial' it deserves the same +-- parked residual (#1078). Outer frames see the '…At' signals and let them +-- pass, since their chains are prefixes of that one; a side-computation running +-- on a chain of its own strips the chain off again (see 'unparked') before the +-- signal reaches the spine. +parking :: NonEmpty Rewritten -> State -> IO a -> IO a +parking seq state action = action `catch` rethrow where rethrow :: ReduceException -> IO a - rethrow (Stuck func) = throwIO (StuckAt func seq) - rethrow (OutOfSteps limit) = throwIO (OutOfStepsAt limit seq) + rethrow (Stuck func) = throwIO (StuckAt func seq state) + rethrow (OutOfSteps limit) = throwIO (OutOfStepsAt limit seq state) + rethrow (Looping term) = throwIO (LoopingAt term seq state) rethrow failure = throwIO failure --- Strip the derivation off a stuck atom escaping a side-computation that ran --- on a chain of its own β€” an atom dataizing its input through '_dataize', or a +-- Strip the derivation off a stuck Ξ» function escaping a side-computation that +-- ran on a chain of its own β€” a firing reducing an operand of its own, or a -- 'morph' premise through '_morph'. That chain is not the spine's, so it is -- dropped and the spine frame around the side-computation attaches its own -- (see 'parking'). @@ -198,10 +261,39 @@ unparked action = action `catch` rethrow where rethrow :: ReduceException -> IO a - rethrow (StuckAt func _) = throwIO (Stuck func) - rethrow (OutOfStepsAt limit _) = throwIO (OutOfSteps limit) + rethrow (StuckAt func _ _) = throwIO (Stuck func) + rethrow (OutOfStepsAt limit _ _) = throwIO (OutOfSteps limit) + rethrow (LoopingAt term _ _) = throwIO (Looping term) rethrow failure = throwIO failure +-- The terms the frames above this one are reducing, which is what '_acyclic' +-- answers "have I been here before" with. The context travels down the +-- recursion and never back up, exactly as the step budget does, so what it +-- carries is the branch from the run to this frame and not everything the run +-- has ever touched: two sibling subterms that happen to be equal are two terms, +-- while a term reached from itself is a loop. The store is the one the rewriter +-- detects its own loops with, a digest map resolving a collision by an exact +-- comparison (see 'Seen'). +-- Which store is read is the judgment of the frame asking ('_judgment', which +-- the caller has already named): 𝕄 and 𝔻 recurse into each other and a term 𝔻 +-- hands 𝕄 is the term 𝔻 was given, so one store for the two would make every +-- 'norm' rule a loop. Each judgment therefore remembers its own branch, and a +-- run that comes back to a term through either of them is parked (#1290). +unvisited :: Expression -> ReduceContext -> IO ReduceContext +unvisited term ctx + | not ctx._acyclic = pure ctx + | seenMember digest term (store ctx._judgment) = throwIO (Looping term) + | otherwise = pure (remembered ctx._judgment) + where + digest :: Int + digest = hashExpression term + store :: Judgment -> Seen + store Morphing = ctx._seen + store Dataization = ctx._dataized + remembered :: Judgment -> ReduceContext + remembered Morphing = ctx{_seen = seenInsert digest term ctx._seen} + remembered Dataization = ctx{_dataized = seenInsert digest term ctx._dataized} + -- The Morphing function 𝕄 maps normal forms to formations. It is ternary, -- 𝕄(n, e, s): besides the term 'n' it takes the universe 'e' ('univ') β€” a plain -- expression β€” and the mutable state 's', returning the morphed term together @@ -223,8 +315,8 @@ -- evaluated in isolation by 'sidePremise', its own steps discarded. morph' :: Morphed -> Expression -> State -> ReduceContext -> IO (Morphed, State) morph' (expr, seq) univ state caller = do - ctx <- deeper caller - parking seq $ do + ctx <- deeper =<< unvisited 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 @@ -243,7 +335,7 @@ -- 'when'. Every morphing guard reads only meta-variables bound by 'match' -- and 'e-match', 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 + asRule rule = Y.Rule rule.name Nothing Nothing rule.match Nothing 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 @@ -280,96 +372,128 @@ -- subterm. Unlike 𝔻, 𝕄 is total: it stops at the first formation it reaches -- ('mf') and never demands bytes, and where no formation is reachable it answers -- with the terminator βŠ₯ ('dead', 'xi', 'mg', 'mad', 'maad') rather than failing. --- Only the atoms 'ml' fires can still get stuck, and '_partial' parks them just --- as it does under 𝔻: the answer is then the residual subterm the spine had --- reached, taken from '_locator' of its working expression. Stopping at the --- first formation leaves everything that formation holds as it was written, --- which is what '_deep' walks into before the answer is handed back (see --- 'deepened'). -morph :: Expression -> ReduceContext -> IO (Expression, [Rewritten]) -morph universe ctx@ReduceContext{..} = do +-- Only the Ξ» functions 'ml' fires can still get stuck, and '_partial' parks +-- them just as it does under 𝔻: the answer is then the residual subterm the +-- spine had reached, taken from '_locator' of its working expression. Stopping +-- at the first formation leaves everything that formation holds as it was +-- written, which is what '_deep' walks into before the answer is handed back +-- (see 'deepened'). The state 𝑠 goes in and comes back out, so a 𝕄 asked +-- inside another judgment goes on minting symbols where that judgment left off. +morph :: Expression -> State -> ReduceContext -> IO (Expression, [Rewritten], State) +morph universe state ctx@ReduceContext{..} = do expr <- locatedExpression _locator universe - result <- try (morph' (expr, (universe, Nothing) :| []) universe emptyState ctx) + result <- try (morph' (expr, (universe, Nothing) :| []) universe state ctx) case result of - Right ((morphed, seq), state) -> walked morphed seq state - Left (StuckAt _ seq) | _partial -> do + Right ((morphed, seq), state') -> walked walking morphed seq state' + Left (StuckAt func seq parked) | _partial -> do residue <- locatedExpression _locator (fst (NE.head seq)) - walked residue seq emptyState - Left (OutOfStepsAt _ seq) | _partial -> do + walked (marked func) residue seq parked{_stuck = Just func} + Left (OutOfStepsAt _ seq parked) | _partial -> do residue <- locatedExpression _locator (fst (NE.head seq)) - walked residue seq emptyState + walked walking residue seq parked + -- Unlike the two above, this one takes no '_partial' guard: a 'LoopingAt' + -- exists only where '_acyclic' put it, so asking for the guard is already + -- asking to be parked on what it finds. + Left (LoopingAt _ seq parked) -> do + residue <- locatedExpression _locator (fst (NE.head seq)) + walked walking residue seq parked Left failure -> throwIO (failure :: ReduceException) where + -- The context the walk runs with: the one this run was given, named after + -- 𝕄, since the walk is 𝕄's own and a Ξ» function it fires is fired by no + -- other judgment, whichever one asked for this run (see '_judgment'). + walking :: ReduceContext + walking = ctx{_judgment = Morphing} + -- The same, plus the Ξ» function the spine got stuck on. The site is still + -- standing in the residue, so the walk asks 𝕄 about it again and 𝔼 gets + -- stuck on it again; the protocol has the site already and the second + -- firing writes nothing (see '_parked', #1300). + marked :: T.Text -> ReduceContext + marked func = walking{_parked = func : _parked} -- The answer 𝕄 reached, walked by '_deep' before it is handed back (see -- 'deepened'), and the chain that led to both. The walk joins the chain as -- one step named 'deep', so '--sequence' ends on the term the command - -- prints. Morphing starts from the empty state and the state the walk ends - -- on goes the way 𝕄's own goes: no caller consumes it yet. - walked :: Expression -> NonEmpty Rewritten -> State -> IO (Expression, [Rewritten]) - walked morphed seq state - | not _deep = pure (morphed, reverse (NE.toList seq)) + -- prints. + walked :: ReduceContext -> Expression -> NonEmpty Rewritten -> State -> IO (Expression, [Rewritten], State) + walked walker morphed seq state' + | not _deep = pure (morphed, reverse (NE.toList seq), state') | otherwise = do - (deep, _) <- deepened morphed universe state ctx - seq' <- leadsTo seq "deep" deep ctx - pure (deep, reverse (NE.toList seq')) + (deep, state'') <- deepened morphed universe state' walker + seq' <- leadsTo seq "deep" deep walker + pure (deep, reverse (NE.toList seq'), state'') -- Walk what 𝕄 answered with, entering everything it left as it was written β€” -- the mechanism behind '--deep' ('_deep'). 𝕄 navigates a term to the first -- formation it reaches and 'mf' hands that formation back with its bindings -- untouched, since firing a bare Ξ» is 𝔻's business; 𝔻 in turn follows the one -- path dataization demands and ends in bytes. A part of a program that nothing --- demands β€” the argument of an atom that cannot fire, for one β€” is therefore --- reduced by neither, and the object structure is lost to the one that does --- reduce it (#1124). This walk demands nothing either. It asks 𝕄 about every --- sub-expression and, where 𝕄 lands on a formation whose Ξ» the registry --- serves, fires it and asks 𝕄 about the answer again (see 'fired'). A --- sub-expression on whose way an atom fired is replaced by the answer of the --- last firing; where none fired it stays as it was written and only its own --- parts are walked, so the calls the registry does not serve keep their names --- and what comes back is still the same program, reduced as far as the --- registry allows. Every entry is charged to the '--max-steps' budget, which --- is what bounds the walk. +-- demands β€” the argument of a Ξ» function that cannot fire, for one β€” is +-- therefore reduced by neither, and the object structure is lost to the one +-- that does reduce it (#1124). This walk demands nothing either. It asks 𝕄 +-- about every sub-expression and, where 𝕄 lands on a formation whose Ξ» the +-- '--symbolic' file answers, fires it and asks 𝕄 about the answer again (see +-- '_fire', which 'Evaluate' answers with its own 'fired'). A sub-expression on +-- whose way a Ξ» function fired is replaced by the +-- answer of the last firing; where none fired it stays as it was written and +-- 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. deepened :: Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) -deepened expr univ = go Nothing ExXi expr +deepened expr univ state ctx = go (Just ctx._site) Nothing ExXi expr state ctx where - -- A term as it was written, together with what its free ΞΎ stands for: the - -- formation the walk entered it from, without the binding it came from, - -- exactly the context the 'dot' rule hands a dispatched body. At the top - -- there is no such formation, so ΞΎ stands for itself and contextualization - -- leaves the term alone. - go :: Maybe Attribute -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) - go dispatched context term state' caller = do - ctx' <- deeper caller - (walked, walkedState) <- parts context term state' caller - answer <- fired dispatched (contextualize walked context) univ walkedState ctx' - maybe (pure (walked, walkedState)) pure answer + -- 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 + -- it from, without the binding it came from, exactly the context the 'dot' + -- rule hands a dispatched body. At the top there is no such formation, so ΞΎ + -- 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 + 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' + 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 + -- deeper in a term than a locator reaches belongs to the last binding the + -- walk entered, and saying that is saying where it is (see '_site'). + sited :: Maybe Expression -> ReduceContext -> ReduceContext + sited Nothing caller = caller + sited (Just loc) caller = caller{_site = loc} -- The parts of a term nothing fired on, walked one by one and put back - -- where they were, so the term keeps the shape it was written in. - parts :: Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) - parts _ (ExFormation bds) state' caller = do - (entered, state'') <- bindings bds bds state' caller + -- where they were, so the term keeps the shape it was written in. Only a + -- binding of a formation carries the locator further: the head of a + -- dispatch and both sides of an application stand under no attribute, so + -- what they hold is entered with no locator of its own. + parts :: Maybe Expression -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) + parts standing _ (ExFormation bds) state' caller = do + (entered, state'') <- bindings standing bds bds state' caller pure (ExFormation entered, state'') - parts context (ExDispatch target attr) state' caller = do - (entered, state'') <- go (Just attr) context target state' caller + parts _ context (ExDispatch target attr) state' caller = do + (entered, state'') <- go Nothing (Just attr) context target state' caller pure (ExDispatch entered attr, state'') - parts context (ExApplication target arg) state' caller = do - (entered, state'') <- go Nothing context target state' caller + parts _ context (ExApplication target arg) state' caller = do + (entered, state'') <- go Nothing Nothing context target state' caller (applied, state''') <- argument context arg state'' caller pure (ExApplication entered applied, state''') - parts _ term state' _ = pure (term, state') + parts _ _ term state' _ = pure (term, state') -- 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 Ξ» - -- binding carries no term to walk at all. - bindings :: [Binding] -> [Binding] -> State -> ReduceContext -> IO ([Binding], State) - bindings _ [] state' _ = pure ([], state') - bindings whole (BiTau attr body : rest) state' caller + -- binding carries no term to walk at all. A body of a formation the walk + -- can name is named by that locator and the attribute it is bound to, which + -- is the very locator '--locator' would aim a run of its own at. + bindings :: Maybe Expression -> [Binding] -> [Binding] -> State -> ReduceContext -> IO ([Binding], State) + bindings _ _ [] state' _ = pure ([], state') + bindings standing whole (BiTau attr body : rest) state' caller | attr /= AtRho = do - (entered, state'') <- go Nothing (scope attr whole) body state' caller - (others, state''') <- bindings whole rest state'' caller + (entered, state'') <- go (fmap (`ExDispatch` attr) standing) Nothing (scope attr whole) body state' caller + (others, state''') <- bindings standing whole rest state'' caller pure (BiTau attr entered : others, state''') - bindings whole (bd : rest) state' caller = do - (others, state'') <- bindings whole rest state' caller + bindings standing whole (bd : rest) state' caller = do + (others, state'') <- bindings standing whole rest state' caller pure (bd : others, state'') -- The context a binding's body is entered in: the formation without that -- binding, the very context 'dot' contextualizes a dispatched body in, so @@ -384,75 +508,12 @@ -- applies is walked by the caller and the argument it binds is walked here. argument :: Expression -> Argument -> State -> ReduceContext -> IO (Argument, State) argument context (ArTau attr arg) state' caller = do - (entered, state'') <- go Nothing context arg state' caller + (entered, state'') <- go Nothing Nothing context arg state' caller pure (ArTau attr entered, state'') argument context (ArAlpha alpha arg) state' caller = do - (entered, state'') <- go Nothing context arg state' caller + (entered, state'') <- go Nothing Nothing context arg state' caller pure (ArAlpha alpha entered, state'') --- Ask 𝕄 about a term and fire the Ξ» of the formation it reaches, as long as --- the registry serves it, asking 𝕄 about every answer again: what comes back --- is the answer of the last firing, or nothing at all where no atom fired. This --- is the firing 'ml' makes without the dispatch that makes 'ml' make it β€” the --- one 𝕄 leaves to 𝔻 β€” except in what it hands back: the atom's raw answer, not --- the normal form 𝔼 makes of it, since the deep walk stands that answer back --- into the program, where a normal form would spell the whole object out in --- place of the name the program called it by. A Ξ» the registry does not carry --- is left alone rather than fired and got stuck on, so what phino cannot --- compute stays as it was written with or without '_partial'; an atom that --- cannot fire deeper on the spine still fails the run, exactly as it does --- under 𝕄 alone, and '_partial' parks it. A formation still waiting for its --- arguments is left alone too (see 'saturated'). A term standing as the target --- of a dispatch is where 'ml' has its say: the Ξ» is fired only where the --- dispatched attribute is none of the formation's own (see 'demanded'). -fired :: Maybe Attribute -> Expression -> Expression -> State -> ReduceContext -> IO (Maybe (Expression, State)) -fired dispatched term univ state caller = do - ctx <- deeper caller - morphed <- try (reduced ctx) - case morphed of - Right (ExFormation bds, state') - | demanded bds -> maybe (pure Nothing) (evaluated ctx state') (saturated bds) - Right _ -> pure Nothing - Left failure -> parked failure - where - -- Whether the dispatch the term stands under demands the Ξ» of the formation - -- 𝕄 reached. 'ml' fires that Ξ» only where the dispatched attribute is none - -- of the formation's own, since 'dot' resolves the dispatch before 'ml' is - -- ever reached, and a walk firing it first answers a formation the dispatch - -- no longer fits (#1187). A term standing anywhere else is demanded by - -- nothing and the walk fires what 'mf' left bare, as it always has. - demanded :: [Binding] -> Bool - demanded bds = not (any bound bds) - where - bound :: Binding -> Bool - bound (BiTau attr _) = Just attr == dispatched - bound _ = False - -- 𝕄 takes normal forms only and a term taken from the program as it was - -- written is not necessarily one, so it is normalized against the universe - -- first, exactly as '--inside' normalizes what it is handed. Both chains - -- are dropped: the walk is not the spine and reports one step of its own - -- (see 'morph'), so a stuck atom leaves without a derivation ('unparked'). - reduced :: ReduceContext -> IO (Expression, State) - reduced ctx = unparked $ do - (normal, _) <- normalized term ((univ, Nothing) :| []) ctx - ((morphed, _), state') <- morph' (normal, (univ, Nothing) :| []) univ state ctx - pure (morphed, state') - -- Fire the Ξ» of the formation 𝕄 reached and go on from its answer, keeping - -- the answer of the last firing. The firing is reported to '_saveEval' like - -- every other one, with the term the caller is given, so the protocol and - -- the program agree on what the atom answered. - evaluated :: ReduceContext -> State -> (T.Text, Expression) -> IO (Maybe (Expression, State)) - evaluated ctx state' (func, self) = case registeredAtom ctx._atoms func of - Nothing -> pure Nothing - Just registered -> do - answer <- fireAtom func registered self univ (ctx._reduce univ ctx) - ctx._saveEval (Evaluation func self (Just answer)) - again <- fired dispatched answer univ state' ctx - pure (Just (fromMaybe (answer, state') again)) - parked :: ReduceException -> IO (Maybe a) - parked (Stuck _) | caller._partial = pure Nothing - parked failure = throwIO failure - -- 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. @@ -484,7 +545,7 @@ -- and the incoming state is returned unchanged. runOperation :: IO (Term, State) runOperation = case premise.operation of - Y.OpEvaluate expr universe -> _evaluate ctx state [ArgExpression expr, ArgExpression universe] subst + Y.OpEvaluate expr universe -> ctx._evaluate ctx state [ArgExpression expr, ArgExpression universe] subst Y.OpMorph expr -> _morph univ ctx state [ArgExpression expr] subst operation -> do term <- execBuildTerm univ ctx (verb operation) (verbArgs operation) subst @@ -534,48 +595,72 @@ -- disabling the must-checker and breakpoints. rewriteContext :: ReduceContext -> RewriteContext rewriteContext ReduceContext{..} = - RewriteContext _locator _maxDepth _maxCycles _depthSensitive _buildTerm MtDisabled Nothing _saveStep + RewriteContext _locator _maxDepth _maxCycles _depthSensitive _universe _buildTerm 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 +-- formation against before it writes 'ρ ↦ Ξ¦' (see '_universe'). Every frame of +-- 𝕄 and of 𝔻 asks, and only the first one of a run answers, since the context +-- travels down the recursion and what it names travels with it. The walk that +-- works it out is itself given no world, so it folds nothing while it is +-- deciding what the world is. +universed :: Expression -> ReduceContext -> IO ReduceContext +universed _ ctx@ReduceContext{_universe = Just _} = pure ctx +universed univ ctx = do + (normal, _) <- normalized univ ((univ, Nothing) :| []) ctx{_locator = ExRoot, _saveStep = dontSaveStep} + pure ctx{_universe = Just normal} + -- Bind 'expr' to a synthetic attribute of the universe and reduce it to a -- normal form there, handing back the extended universe together with the -- locator that aims at the binding. This is the trick phino has always played --- to reduce a sub-expression that is not part of the program β€” an atom's --- operand, while the atoms still lived in the binary β€” and it is now the --- contract of the '--inside' option, so an atom script asking phino to reduce --- a part of the formation it was given does not have to splice it into the text +-- to reduce a sub-expression that is not part of the program β€” the operand a +-- Ξ» function names under 'dataize' or 'morph', above all β€” and it is also +-- the contract of the '--inside' option, so a caller asking phino to reduce a +-- part of the formation it was given does not have to splice it into the text -- of the universe by hand. 𝔻 and 𝕄 accept normal forms only and an expression -- handed in from outside is not necessarily one (a dispatch off a formation, -- '⟦ x ↦ 6, ρ ↦ 5 ⟧.x', is not), so it is normalized against the extended -- universe before either judgment sees it. The context comes back aimed at that -- binding, so the caller hands the extended universe and the context it got --- straight to 'dataize' or 'morph'. +-- straight to 'dataize' or 'morph'. The site every firing is written under +-- moves with the aim, so a Ξ» function fired while such a term is being reduced +-- is written under the synthetic binding it was bound to and not under whatever +-- the run around it was aimed at (see '_site'). insideUniverse :: Expression -> Expression -> ReduceContext -> IO (Expression, ReduceContext) insideUniverse expr univ ctx@ReduceContext{_buildTerm = buildTerm} = case univ of ExFormation bds -> do (TeAttribute attr) <- buildTerm "random-tau" [] substEmpty - let aiming = ctx{_locator = ExDispatch ExRoot attr} + let aiming = ctx{_locator = ExDispatch ExRoot attr, _site = ExDispatch ExRoot attr} synthetic = ExFormation (BiTau attr expr : bds) (normal, _) <- normalized expr ((synthetic, Nothing) :| []) aiming - pure (ExFormation (BiTau attr normal : bds), aiming) + pure (ExFormation (BiTau attr normal : bds), aiming{_universe = extended attr normal}) _ -> throwIO (userError "Can't reduce an expression inside a universe which is not a formation") + where + -- What Ξ¦ denotes inside the extended universe. Normalization works binding + -- by binding, so the normal form of the extension is the normal form of + -- the universe with the already-normalized term bound in front of it, and + -- no second walk of the world is needed to name it (see '_universe'). A + -- run that has not named its world yet leaves it unnamed here too, and the + -- frame below works it out. + extended :: Attribute -> Expression -> Maybe Expression + extended attr normal = case ctx._universe of + Just (ExFormation bds) -> Just (ExFormation (BiTau attr normal : bds)) + _ -> Nothing --- phino implements no Ξ» function of its own. Which atoms exist is a property of --- the object model being dataized, not of the calculus, so they come from the --- '--atoms' registry and run as external scripts (see 'Atoms'). A name the --- registry does not carry has no Ξ» function to fire at all, and 𝔼 gets stuck on --- it β€” the one behaviour left here. The script is handed the formation 'self' --- (its Ξ» binding already removed, so it may dispatch on it) and the universe --- 'univ'; the state 𝑠 is not part of that contract yet, so it is threaded --- through untouched. -atom :: T.Text -> Expression -> Expression -> State -> ReduceContext -> IO (Expression, State) -atom func self univ state ctx = case registeredAtom ctx._atoms func of - Nothing -> throwIO (Stuck func) - Just registered -> do - raw <- fireAtom func registered self univ (ctx._reduce univ ctx) - pure (raw, state) +-- Morph a term that is not part of the program, the way 'reduction' in +-- 'Dataize' dataizes one: bound to a synthetic attribute of the universe and +-- reduced there (see 'insideUniverse'), since 𝕄 takes normal forms only and an +-- operand taken out of a formation as it was written is not necessarily one. +-- This is what a 'morph' operand of a Ξ» function is reduced with, and the +-- dataizing sibling of it reaches 'Dataize' through '_reduce'. +morphing :: Expression -> ReduceContext -> Expression -> State -> IO (Expression, State) +morphing univ ctx expr state = do + (universe, aiming) <- insideUniverse expr univ ctx + (morphed, _, state') <- morph universe state aiming + pure (morphed, state') -- Augment the injected, context-free term builder with the dataization and --- morphing operations that need the universe: 'evaluate' applies an atom and +-- morphing operations that need the universe: 'evaluate' fires a Ξ» function and -- 'morph' morphs a sub-expression. 𝔼 ('evaluate') takes the universe as an -- explicit second expression argument, while 𝕄 ('morph') is handed the threaded -- 'univ'. Every other function is delegated unchanged. This is the matcher's @@ -583,51 +668,14 @@ -- and 𝕄 run here on a fresh, empty state whose result is discarded; the -- state-threading callers in 'sidePremise' use '_evaluate' and '_morph' directly. execBuildTerm :: Expression -> ReduceContext -> BuildTermFunc -execBuildTerm _ ctx "evaluate" = \args subst -> fst <$> _evaluate ctx emptyState args subst +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 func = _buildTerm ctx func --- The Evaluation function 𝔼(b, e, s): it fires the Ξ» atom of a formation 'b' --- against the global universe 'e', under the incoming state 𝑠, normalizes the --- atom's raw result 𝒩(e₁) = n, and returns that normal form together with the --- new state. Normalizing here makes 𝔼's codomain 𝓝 (as its type demands), so --- callers ('fire', 'ml') need no follow-up 'normalize' premise. The universe is --- passed explicitly as the second argument (rather than threaded behind the --- scenes), matching how the morphing 𝕄 and dataization 𝔻 functions carry it. --- Every firing is reported to '_saveEval', which the '--evaluations' option --- turns into one record per line. The reported result is the normal form 𝔼 --- returns, never the atom's raw answer, so the protocol and the caller see the --- same term. Firings are reported in the order they complete, so the atom of a --- head reduced by 'ml' is reported before the one dispatched on its result. A --- firing that gets stuck is reported too, with no result, when the run is a --- partial evaluation rather than a failure ('_partial'): the site is what the --- caller wants to learn then. The report is made before the signal goes on to --- the spine, where 'parking' attaches the derivation to it. -_evaluate :: ReduceContext -> State -> BuildTermMethodS -_evaluate ctx state [ArgExpression expr, ArgExpression universe] subst = do - form <- buildExpressionThrows expr subst - univ <- buildExpressionThrows universe subst - case form of - ExFormation bds -> case lambda bds of - Just (func, args) -> do - (raw, state') <- atom func args univ state ctx `catch` parked func args - (normal, _) <- normalized raw ((univ, Nothing) :| []) ctx - ctx._saveEval (Evaluation func args (Just normal)) - pure (TeExpression normal, state') - Nothing -> throwIO (userError "Function evaluate() expects a formation with a Ξ» binding") - _ -> throwIO (userError "Function evaluate() expects a formation") - where - parked :: T.Text -> Expression -> ReduceException -> IO a - parked func args failure@(Stuck _) = do - when ctx._partial (ctx._saveEval (Evaluation func args Nothing)) - throwIO failure - parked _ _ failure = throwIO failure -_evaluate _ _ _ _ = 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 atom met +-- 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 diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -24,7 +24,7 @@ import AST import Bytes (nonFiniteBts, nonFiniteOf, numToBts, strToBts) import Control.Exception (Exception) -import Control.Monad (guard) +import Control.Monad (guard, when) import Data.Char (isAsciiLower, isDigit) import Data.Scientific (toRealFloat) import qualified Data.Text as T @@ -36,6 +36,7 @@ import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Text.Printf (printf) +import Text.Read (readMaybe) type Parser = Parsec Void String @@ -126,7 +127,9 @@ -- suffix tells the two kinds apart: with one the variable is named and a rule -- may reference it from its result, without one it is an anonymous slot -- pinned to the offset it starts at, unique within the parsed term. Named --- variables are packed to Text once here; all AST meta fields are Text. +-- variables are packed to Text once here; all AST meta fields are Text. A +-- suffix of '0' is no name but a first index written wrong: every index of the +-- calculus starts with one, so the whole term is refused where it stands. metaVar :: Char -> String -> Parser (Either Slot T.Text) metaVar ch uni = do offset <- getOffset @@ -135,12 +138,28 @@ [ char '!' >> char ch >> metaSuffix , string uni >> metaSuffix ] + when + (suf == "0") + (fail (printf "the meta variable '!%c0' is indexed with zero, while indexes start with one" ch)) return ( if null suf then Left (Slot (T.singleton ch) offset) else Right (T.pack (ch : suf)) ) +-- A symbol standing where a Ξ» name stands: 𝜎1, a name nothing answers, or a +-- bare 𝜎, which asks for a fresh one. It is spelled the way every meta of the +-- calculus is spelled, indexed or not, so 'metaVar' reads it, but what comes +-- back is a name and not a meta-variable: an index becomes the symbol it +-- numbers and a bare one the slot that tells it apart from its siblings. +sigma :: Parser Function +sigma = metaVar 'S' "𝜎" >>= either (pure . FnFresh) numbered + where + numbered :: T.Text -> Parser Function + numbered named = case readMaybe (T.unpack (T.drop 1 named)) of + Just idx -> pure (FnSymbol idx) + Nothing -> fail (printf "the symbol '%s' is numbered by something that is not an integer" (T.unpack named)) + byte :: Parser String byte = do f <- hexDigitChar >>= upperHex @@ -161,7 +180,7 @@ bytes = lexeme ( choice - [ either BtAny BtMeta <$> metaVar 'd' "Ξ΄" + [ either BtAny BtMeta <$> metaVar 'd' "𝛿" , symbol "--" >> return BtEmpty , try $ do first <- byte @@ -314,7 +333,7 @@ , try metaBinding , do _ <- try lambda - BiLambda <$> choice [Function . T.pack <$> function, either FnAny FnMeta <$> metaVar 'F' "𝑓"] + BiLambda <$> choice [Function . T.pack <$> function, try (either FnAny FnMeta <$> metaVar 'F' "𝑓"), sigma] , do attr <- attribute choice diff --git a/src/Printer.hs b/src/Printer.hs --- a/src/Printer.hs +++ b/src/Printer.hs @@ -12,6 +12,7 @@ , printAlpha , printBinding , printBytes + , printFunction , printExtraArg , printSubsts , printSubsts' @@ -84,6 +85,18 @@ printBytes :: Bytes -> String printBytes bts = T.unpack $ render (toCST bts (0, NO_EOL) :: BYTES) +-- The Ξ» function alone, without the binding that carries it: the name of an +-- ordinary one, the 𝜎 of a symbol, the sigil of a rule's meta. It is read off +-- the binding's own CST, so the spelling stays where every other spelling of +-- the calculus lives. +printFunction :: Function -> String +printFunction fun = T.unpack (spelled (toCST (BiLambda fun) (0, NO_EOL) :: PAIR)) + where + spelled :: PAIR -> T.Text + spelled (PA_LAMBDA name) = render name + spelled (PA_META_LAMBDA sigil) = render sigil + spelled whole = render whole + printExtraArg' :: ExtraArgument -> PrintConfig -> String printExtraArg' (ArgAttribute att) (_, encoding, _, _) = printAttribute' att encoding printExtraArg' (ArgBinding bd) config = printBinding' bd config @@ -99,7 +112,7 @@ printMetaValue (MvExpression ex) config = printExpression' ex config printMetaValue (MvBytes bts) _ = printBytes bts printMetaValue (MvBindings bds) config = printExpression' (ExFormation bds) config -printMetaValue (MvFunction fun) _ = T.unpack fun +printMetaValue (MvFunction fun) _ = printFunction fun -- An anonymous slot is reported under the bare sigil it was written with, -- just as a named meta is reported under its name. Two slots of one kind diff --git a/src/Render.hs b/src/Render.hs --- a/src/Render.hs +++ b/src/Render.hs @@ -128,10 +128,13 @@ render I' = "i" render B = "𝐡" render B' = "B" - render D = "Ξ΄" + render D = "𝛿" render D' = "\\delta" + render D'' = "d" render F = "𝑓" render F' = "F" + render S = "𝜎" + render S' = "S" instance Render META where render META{..} = render excl <> render hd <> render rest diff --git a/src/Rewriter.hs b/src/Rewriter.hs --- a/src/Rewriter.hs +++ b/src/Rewriter.hs @@ -9,7 +9,7 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rewriter (rewrite, RewriteContext (..), Rewritten, Rewrittens, Rewrittens', stepHeaders) where +module Rewriter (Seen, rewrite, RewriteContext (..), Rewritten, Rewrittens, Rewrittens', seenInsert, seenMember, stepHeaders) where import AST import Builder @@ -83,6 +83,14 @@ , _maxDepth :: Int , _maxCycles :: Int , _depthSensitive :: Bool + , -- The world the rewritten term stands in, where one is known. A rule + -- carrying an 'e-match' is matched against it and reads what it binds + -- there, which is how 'dot' tells the formation it dispatched from the + -- whole program and writes 'ρ ↦ Ξ¦' rather than the program itself + -- (#1318). Normalization inside 𝕄 and 𝔻 knows the universe and names it + -- here; the 'rewrite' command rewrites a term with no world around it and + -- names nothing. + _universe :: Maybe Expression , _buildTerm :: BuildTermFunc , _must :: Must , _breakpoint :: Maybe String @@ -196,7 +204,7 @@ 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) >>= \case + R.matchExpressionWithRuleIn _universe expression rule (RuleContext _buildTerm) >>= \case [] -> do logDebug (printf "Rule '%s' does not match, rewriting is stopped" ruleName) if _breakpoint == Just ruleName diff --git a/src/Rule.hs b/src/Rule.hs --- a/src/Rule.hs +++ b/src/Rule.hs @@ -6,13 +6,14 @@ -- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com -- SPDX-License-Identifier: MIT -module Rule (RuleContext (..), isNF, matchExpressionWithRule, matchExpressionWithRule', meetCondition) where +module Rule (RuleContext (..), isNF, matchExpressionWithRule, matchExpressionWithRule', matchExpressionWithRuleIn, meetCondition) where import AST import Builder ( buildAttribute , buildBinding , buildBindingThrows + , buildExpression , buildExpressionThrows ) import Bytes (btsToUnescapedStr) @@ -149,19 +150,15 @@ Just (MvAttribute found) -> attr == found _ -> False compareAttrs left right _ = right == left -_eq (Y.CmpExpr left) (Y.CmpExpr right) subst _ = pure [subst | compareExprs left right subst] - where - compareExprs :: Expression -> Expression -> Subst -> Bool - compareExprs (ExMeta left) (ExMeta right) (Subst mp) = case (M.lookup (Named left) mp, M.lookup (Named right) mp) of - (Just (MvExpression left'), Just (MvExpression right')) -> compareExprs left' right' (Subst mp) - _ -> False - compareExprs expr (ExMeta meta) (Subst mp) = case M.lookup (Named meta) mp of - Just (MvExpression found) -> expr == found - _ -> False - compareExprs (ExMeta meta) expr (Subst mp) = case M.lookup (Named meta) mp of - Just (MvExpression found) -> expr == found - _ -> False - compareExprs left right _ = left == right +-- Both sides are built under the substitution before they are compared, so a +-- side written as a whole term β€” '⟦𝐡1, 𝜏1 ↦ 𝑛1, 𝐡2⟧' and not merely a meta +-- standing for one β€” is compared as the term it stands for rather than as the +-- pattern it was written as. A side holding a meta nothing bound cannot be +-- built, and an equality nobody can work out does not hold. +_eq (Y.CmpExpr left) (Y.CmpExpr right) subst _ = + case (buildExpression left subst, buildExpression right subst) of + (Right left', Right right') -> pure [subst | left' == right'] + (_, _) -> pure [] _eq _ _ _ _ = pure [] -- Hold if the left number is strictly greater than the right one. Only @@ -373,7 +370,22 @@ goArgument (ArAlpha _ expr) = go expr matchExpressionWithRule :: Expression -> Y.Rule -> RuleContext -> IO [Subst] -matchExpressionWithRule = matchExpressionBy matchExpression [substEmpty] +matchExpressionWithRule = matchExpressionWithRuleIn Nothing + +-- Match a rewriting rule against an expression standing in the given universe. +-- A rule carrying an 'e-match' is matched against that universe too and what it +-- binds there joins every match, which is how 'dot' tells the formation it +-- dispatched from the whole program (#1318). A rule carrying none is matched +-- exactly as 'matchExpressionWithRule' matches it, and so is every rule where +-- no universe is known β€” the 'rewrite' command rewrites a term and no world +-- around it, and 'isNF' asks about a term alone. +matchExpressionWithRuleIn :: Maybe Expression -> Expression -> Y.Rule -> RuleContext -> IO [Subst] +matchExpressionWithRuleIn universe expr rule = matchExpressionBy matchExpression seed expr rule + where + seed :: [Subst] + seed = case (rule.ematch, universe) of + (Just ptn, Just whole) -> matchExpression' ptn whole + _ -> [substEmpty] -- Like 'matchExpressionWithRule' but matches the pattern against the whole -- expression only (no deep, sub-expression matching). Used by the dataization diff --git a/src/Slots.hs b/src/Slots.hs --- a/src/Slots.hs +++ b/src/Slots.hs @@ -62,4 +62,5 @@ instance Slots Function where slots (FnAny slot) = [slot] + slots (FnFresh slot) = [slot] slots _ = [] diff --git a/src/Yaml.hs b/src/Yaml.hs --- a/src/Yaml.hs +++ b/src/Yaml.hs @@ -22,6 +22,7 @@ import Data.Yaml (Parser) import qualified Data.Yaml as Yaml import GHC.Generics (Generic) +import Metas import Parser import Slots import Text.Printf (printf) @@ -181,6 +182,7 @@ defaultOptions { fieldLabelModifier = \case "where_" -> "where" + "ematch" -> "e-match" other -> other } value @@ -238,6 +240,12 @@ , label :: Maybe String , description :: Maybe String , pattern :: Expression + , -- The universe-argument matcher, the one 'MorphRule' spells as 'ematch'. + -- A rewriting rule is about a term and knows nothing of the world around + -- it, so almost every rule leaves this out; a rule that does carry one is + -- matched against the universe too and reads what it binds, which is how + -- 'dot' tells the formation it dispatched from the whole program (#1318). + ematch :: Maybe Expression , result :: Expression , when :: Maybe Condition , where_ :: Maybe [Extra] @@ -289,6 +297,128 @@ slots (OpEvaluate expr universe) = slots expr ++ slots universe slots (OpContextualize expr context) = slots expr ++ slots context slots (OpDataize expr) = slots expr + +instance Metas Condition where + metas (And conds) = metas conds + metas (Or conds) = metas conds + metas (Not cond) = metas cond + metas (In attr bd) = metas attr ++ metas bd + metas (Eq left right) = metas left ++ metas right + metas (Gt left right) = metas left ++ metas right + metas (NF expr) = metas expr + metas (Absolute expr) = metas expr + metas (Matches _ expr) = metas expr + metas (PartOf expr bd) = metas expr ++ metas bd + metas (Disjoint attrs bds) = metas attrs ++ metas bds + metas (IsFormation expr) = metas expr + bare names (And conds) = And (bare names conds) + bare names (Or conds) = Or (bare names conds) + bare names (Not cond) = Not (bare names cond) + bare names (In attr bd) = In (bare names attr) (bare names bd) + bare names (Eq left right) = Eq (bare names left) (bare names right) + bare names (Gt left right) = Gt (bare names left) (bare names right) + bare names (NF expr) = NF (bare names expr) + bare names (Absolute expr) = Absolute (bare names expr) + bare names (Matches regex expr) = Matches regex (bare names expr) + bare names (PartOf expr bd) = PartOf (bare names expr) (bare names bd) + bare names (Disjoint attrs bds) = Disjoint (bare names attrs) (bare names bds) + bare names (IsFormation expr) = IsFormation (bare names expr) + +instance Metas Comparable where + metas (CmpAttr attr) = metas attr + metas (CmpNum num) = metas num + metas (CmpExpr expr) = metas expr + bare names (CmpAttr attr) = CmpAttr (bare names attr) + bare names (CmpNum num) = CmpNum (bare names num) + bare names (CmpExpr expr) = CmpExpr (bare names expr) + +instance Metas Number where + metas (MetaIndex named) = metas named + metas (AnyIndex slot) = metas slot + metas (Length bd) = metas bd + metas (Domain bd) = metas bd + metas (Literal _) = [] + bare names (MetaIndex named) = MetaIndex (bare names named) + bare names (Length bd) = Length (bare names bd) + bare names (Domain bd) = Domain (bare names bd) + bare _ num = num + +instance Metas ExtraArgument where + metas (ArgAttribute attr) = metas attr + metas (ArgExpression expr) = metas expr + metas (ArgBinding bd) = metas bd + metas (ArgBytes bts) = metas bts + bare names (ArgAttribute attr) = ArgAttribute (bare names attr) + bare names (ArgExpression expr) = ArgExpression (bare names expr) + bare names (ArgBinding bd) = ArgBinding (bare names bd) + bare names (ArgBytes bts) = ArgBytes (bare names bts) + +instance Metas Extra where + metas extra = metas extra.meta ++ metas extra.args + bare names extra = extra{meta = bare names extra.meta, args = bare names extra.args} + +instance Metas Premise where + metas premise = metas premise.result ++ metas premise.operation + bare names premise = premise{result = bare names premise.result, operation = bare names premise.operation} + +instance Metas Operation where + metas (OpMorph expr) = metas expr + metas (OpNormalize expr) = metas expr + metas (OpEvaluate expr universe) = metas expr ++ metas universe + metas (OpContextualize expr context) = metas expr ++ metas context + metas (OpDataize expr) = metas expr + bare names (OpMorph expr) = OpMorph (bare names expr) + bare names (OpNormalize expr) = OpNormalize (bare names expr) + bare names (OpEvaluate expr universe) = OpEvaluate (bare names expr) (bare names universe) + bare names (OpContextualize expr context) = OpContextualize (bare names expr) (bare names context) + bare names (OpDataize expr) = OpDataize (bare names expr) + +-- A rule is the scope an index counts in: the reader meets the metas of one +-- inference within it and nowhere else, so a kind the rule names just once +-- carries no index anywhere in the rule. +instance Metas Rule where + metas rule = metas rule.pattern ++ metas rule.ematch ++ metas rule.result ++ metas rule.when ++ metas rule.having ++ metas rule.where_ + bare names rule = + rule + { pattern = bare names rule.pattern + , ematch = bare names rule.ematch + , result = bare names rule.result + , when = bare names rule.when + , having = bare names rule.having + , where_ = bare names rule.where_ + } + +instance Metas MorphRule where + metas rule = metas rule.match ++ metas rule.ematch ++ metas rule.nresult ++ metas rule.when ++ metas rule.premises + bare names rule = + rule + { match = bare names rule.match + , ematch = bare names rule.ematch + , nresult = bare names rule.nresult + , when = bare names rule.when + , premises = bare names rule.premises + } + +instance Metas DataizeRule where + metas rule = metas rule.match ++ metas rule.ematch ++ metas rule.dresult ++ metas rule.when ++ metas rule.premises + bare names rule = + rule + { match = bare names rule.match + , ematch = bare names rule.ematch + , dresult = bare names rule.dresult + , when = bare names rule.when + , premises = bare names rule.premises + } + +instance Metas ContextualizeRule where + metas rule = metas rule.match ++ metas rule.cmatch ++ metas rule.cresult ++ metas rule.premises + bare names rule = + rule + { match = bare names rule.match + , cmatch = bare names rule.cmatch + , cresult = bare names rule.cresult + , premises = bare names rule.premises + } -- An anonymous meta-variable is bound by the pattern it stands in and is -- forgotten as soon as that pattern matches, so it has no name for any other diff --git a/test/AtomsSpec.hs b/test/AtomsSpec.hs deleted file mode 100644 --- a/test/AtomsSpec.hs +++ /dev/null @@ -1,780 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com --- SPDX-License-Identifier: MIT - -module AtomsSpec (spec) where - -import AST -import Atoms (Atom (..), Program (..), ReduceFunc, Registry, Runtime (RtNode), Session (_program), closeRegistry, emptyRegistry, fireAtom, readRegistry, registeredAtom) -import Control.Exception (SomeException, finally) -import Control.Monad (forM_) -import Data.Aeson (Value, object, (.=)) -import Data.Aeson.Key qualified as Key -import Data.Aeson.Types (Pair) -import Data.ByteString qualified as BS -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.List (isInfixOf) -import Data.Text qualified as T -import Data.Text.Encoding (encodeUtf8) -import Fixtures (resident, withExecutable, withNode, withRegistryOf, withScript, withShell, withTemp) -import Parser (parseExpressionThrows) -import System.Directory (doesFileExist, getTemporaryDirectory, removePathForcibly) -import System.FilePath (()) -import Test.Hspec -import Text.Printf (printf) - --- The registry of the given Ξ» functions, every one of them the same entry -registryOf :: [T.Text] -> [Pair] -> Value -registryOf names fields = object [Key.fromText name .= object fields | name <- names] - --- The entry of a Ξ» function run as the given file, which goes through JSON --- encoding rather than into text by hand, since a Windows path spells its --- separators with the escape character of JSON -executing :: FilePath -> [Pair] -executing file = ["rt" .= ("exec" :: T.Text), "path" .= file] - --- The entry of a Ξ» function run as the given script under node -scripted :: T.Text -> [Pair] -scripted script = ["rt" .= ("node" :: T.Text), "script" .= script] - --- The same entry, kept for the run -served :: [Pair] -> [Pair] -served fields = ("serve" .= True) : fields - --- The text of a registry of node scripts under the given keys, in exactly the --- order given, which 'registryOf' cannot promise -ordered :: [(T.Text, T.Text)] -> BS.ByteString -ordered entries = encodeUtf8 ("{" <> T.intercalate ", " ["\"" <> key <> "\": {\"rt\": \"node\", \"script\": \"" <> script <> "\"}" | (key, script) <- entries] <> "}") - --- The Ξ» functions of the given registry, read from a file, with every program --- it has started stopped afterwards, so that no spec leaves a process behind -withRegistered :: Value -> (Registry -> IO a) -> IO a -withRegistered registry action = - withRegistryOf registry $ \path -> do - atoms <- readRegistry path - action atoms `finally` closeRegistry atoms - --- The Ξ» functions of the registry naming a resident program built of the given --- per-request snippet (see 'resident') under every given name -withServed :: [T.Text] -> T.Text -> (Registry -> IO a) -> IO a -withServed names snippet action = - withExecutable (resident snippet) $ \file -> - withRegistered (registryOf names (served (executing file))) action - --- What phino answers a program that asks it to reduce an expression: reducing --- one is 'Dataize's business and not this module's, so every question is --- answered here with the same bytes -reducing :: ReduceFunc -reducing _ = parseExpressionThrows "⟦ Ξ” ‍ 2A- ⟧" - --- The same, keeping the expression it was asked about, so a case may assert on --- what reached phino -recording :: IORef (Maybe Expression) -> ReduceFunc -recording seen expr = writeIORef seen (Just expr) >> reducing expr - --- Fire the given Ξ» function out of the registry, against the same formation --- 'fired' uses, inside the given universe -firedFrom :: Registry -> T.Text -> String -> IO Expression -firedFrom registry func universe = firedFrom' registry func universe reducing - --- The same, with phino reducing whatever the program asks about the given way -firedFrom' :: Registry -> T.Text -> String -> ReduceFunc -> IO Expression -firedFrom' registry func = firedAt registry func "⟦ x ↦ ⟦ Ξ” ‍ 01- ⟧ ⟧" - --- The same, against the given receiver rather than the one every other case --- fires at -firedAt :: Registry -> T.Text -> String -> String -> ReduceFunc -> IO Expression -firedAt registry func receiver universe reduce = do - form <- parseExpressionThrows receiver - univ <- parseExpressionThrows universe - maybe (fail (printf "'%s' is not registered" (T.unpack func))) (\atom -> fireAtom func atom form univ reduce) (registeredAtom registry func) - --- Fire the Ξ» function 'L_answer' out of the given atom, against a formation --- binding 'x' inside a universe binding 'y' -fired :: Atom -> IO Expression -fired atom = do - form <- parseExpressionThrows "⟦ x ↦ ⟦ Ξ” ‍ 01- ⟧ ⟧" - univ <- parseExpressionThrows "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - fireAtom "L_answer" atom form univ reducing - --- The program a Ξ» function is kept for the run with, if it is kept at all -kept :: Maybe Atom -> Maybe Program -kept (Just (Resident session)) = Just (_program session) -kept _ = Nothing - --- A script run once per fire, answering the request with the given JavaScript --- expression, in which 'lines' is every line phino said, 'universe' the one --- carrying '𝑒' and 'request' the one carrying 'id', so a case asserts on what --- phino says rather than on how a script reads it -scripting :: T.Text -> T.Text -scripting expr = - T.unlines - [ "const lines = require('fs').readFileSync(0, 'utf8').split('\\n').filter(Boolean).map((line) => JSON.parse(line));" - , "const universe = lines.find((message) => '𝑒' in message);" - , "const request = lines.find((message) => 'id' in message);" - , "process.stdout.write(JSON.stringify({id: request.id, '𝑛': " <> expr <> "}));" - ] - --- A script reading phino's lines one by one until its stdin closes and --- answering every request with how many it has seen, so a case tells one --- process kept across fires from one started afresh for each -counting :: T.Text -counting = - T.unlines - [ "let seen = 0;" - , "require('readline').createInterface({input: process.stdin}).on('line', (line) => {" - , " const message = JSON.parse(line);" - , " if ('id' in message) {" - , " seen += 1;" - , " process.stdout.write(JSON.stringify({id: message.id, '𝑛': '⟦ Ξ” ‍ 0' + seen + '- ⟧'}) + '\\n');" - , " }" - , "});" - ] - --- What the script wrote under '𝑛' has to come back parsed, so a case asserting --- on it says which expression it expects in πœ‘ rather than in constructors -answers :: T.Text -> String -> Expectation -answers script expected = withNode $ do - answer <- fired (Transient (Scripted RtNode script)) - wanted <- parseExpressionThrows expected - answer `shouldBe` wanted - --- The same, for an atom phino runs off its path instead of staging it -executes :: T.Text -> String -> Expectation -executes script expected = withShell $ - withExecutable script $ \file -> do - answer <- fired (Transient (Executable file)) - wanted <- parseExpressionThrows expected - answer `shouldBe` wanted - --- The same, for an atom served by a resident program built of the given --- per-request snippet -serves :: T.Text -> String -> Expectation -serves = servesAt "⟦ x ↦ ⟦ Ξ” ‍ 01- ⟧ ⟧" - --- The same, against the given receiver rather than the one every other case --- fires at -servesAt :: String -> T.Text -> String -> Expectation -servesAt receiver snippet expected = withShell $ - withServed ["L_answer"] snippet $ \registry -> do - answer <- firedAt registry "L_answer" receiver "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" reducing - wanted <- parseExpressionThrows expected - answer `shouldBe` wanted - --- A firing of a script that has to fail, with the reason naming the given --- fragments -fails :: T.Text -> [String] -> Expectation -fails script fragments = - withNode $ - fired (Transient (Scripted RtNode script)) - `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) fragments) - --- The same, for a served atom -refuses :: T.Text -> [String] -> Expectation -refuses = refusesAt "⟦ x ↦ ⟦ Ξ” ‍ 01- ⟧ ⟧" - --- The same, against the given receiver rather than the one every other case --- fires at -refusesAt :: String -> T.Text -> [String] -> Expectation -refusesAt receiver snippet fragments = withShell $ - withServed ["L_answer"] snippet $ \registry -> - firedAt registry "L_answer" receiver "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" reducing - `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) fragments) - --- The reply of a resident program answering the request with the given bytes -replying :: T.Text -> T.Text -replying bytes = "printf '{\"id\": %s, \"𝑛\": \"⟦ Ξ” ‍ %s ⟧\"}\\n' \"$id\" \"" <> bytes <> "\"" - --- A resident program that cannot answer its request before phino reduces --- something for it: it asks about the given πœ‘-expression under the question --- 'id' 7, then answers with 'FF-' when what phino said back matches the given --- shell pattern and with '00-' when it does not -asking :: T.Text -> T.Text -> T.Text -asking expr pattern = - T.unlines - [ "printf '{\"id\": 7, \"ask\": \"" <> expr <> "\"}\\n'" - , "IFS= read -r reply" - , "case \"$reply\" in" - , " " <> pattern <> ") " <> replying "FF-" <> ";;" - , " *) " <> replying "00-" <> ";;" - , "esac" - ] - --- A resident program that names an operand instead of quoting a receiver --- (#1165): it asks phino for the given 'attr' of the in-flight request 'of', --- reduced when the second argument says so, under the question 'id' 7, then --- answers its own request with 'FF-' when what phino said back matches the --- given shell pattern and with '00-' when it does not -referring :: Int -> T.Text -> Bool -> T.Text -> T.Text -referring request attr doReduce pattern = - T.unlines - [ "printf '{\"id\": 7, \"of\": " <> T.pack (show request) <> ", \"attr\": \"" <> attr <> "\"" <> reduce <> "}\\n'" - , "IFS= read -r reply" - , "case \"$reply\" in" - , " " <> pattern <> ") " <> replying "FF-" <> ";;" - , " *) " <> replying "00-" <> ";;" - , "esac" - ] - where - reduce = if doReduce then ", \"reduce\": true" else "" - --- A resident program whose question phino cannot answer without firing the --- same program again: it asks, then serves every request phino sends while its --- question is open, and answers its own request once the answer to the --- question arrives, telling phino whether that answer carried '2A-' -nesting :: T.Text -nesting = - T.unlines - [ "printf '{\"id\": 7, \"ask\": \"Q.x\"}\\n'" - , "while IFS= read -r reply; do" - , " case \"$reply\" in" - , " *'\"Ξ»\"'*) printf '{\"id\": %s, \"𝑛\": \"⟦ Ξ” ‍ 2A- ⟧\"}\\n' \"$(printf '%s' \"$reply\" | sed 's/.*\"id\":\\([0-9]*\\).*/\\1/')\";;" - , " *) break;;" - , " esac" - , "done" - , "case \"$reply\" in" - , " *'2A-'*) " <> replying "FF-" <> ";;" - , " *) " <> replying "00-" <> ";;" - , "esac" - ] - -spec :: Spec -spec = do - -- phino implements no Ξ» function, so an empty registry is what a run without - -- '--atoms' fires against: every name is unknown there - describe "emptyRegistry" $ - it "registers no Ξ» function at all" $ - registeredAtom emptyRegistry "L_bytes_eq" `shouldBe` Nothing - - describe "readRegistry" $ do - it "reads a Ξ» function together with its runtime and script" $ - withRegistryOf (registryOf ["L_answer"] (scripted "say(1)")) $ \path -> do - registry <- readRegistry path - registeredAtom registry "L_answer" `shouldBe` Just (Transient (Scripted RtNode "say(1)")) - - -- An atom the object model brought as a binary of its own names no - -- interpreter at all, only the file phino is to run - it "reads an executable Ξ» function as the file it runs" $ - withShell $ - withExecutable "" $ \file -> - withRegistryOf (registryOf ["L_answer"] (executing file)) $ \path -> do - registry <- readRegistry path - registeredAtom registry "L_answer" `shouldBe` Just (Transient (Executable file)) - - -- Whether a program is kept for the run is its own flag, so any program - -- may be kept, whatever runs it - it "keeps an executable Ξ» function for the run when its entry says serve" $ - withShell $ - withExecutable "" $ \file -> - withRegistryOf (registryOf ["L_answer"] (served (executing file))) $ \path -> do - registry <- readRegistry path - kept (registeredAtom registry "L_answer") `shouldBe` Just (Executable file) - - it "keeps a script for the run when its entry says serve" $ - withRegistryOf (registryOf ["L_answer"] (served (scripted "say(1)"))) $ \path -> do - registry <- readRegistry path - kept (registeredAtom registry "L_answer") `shouldBe` Just (Scripted RtNode "say(1)") - - it "starts a program afresh for every fire when its entry says not to serve" $ - withRegistryOf (registryOf ["L_answer"] (("serve" .= False) : scripted "say(1)")) $ \path -> do - registry <- readRegistry path - registeredAtom registry "L_answer" `shouldBe` Just (Transient (Scripted RtNode "say(1)")) - - it "leaves a name the file does not carry unregistered" $ - withRegistryOf (registryOf ["L_answer"] (scripted "say(1)")) $ \path -> do - registry <- readRegistry path - registeredAtom registry "L_bytes_eq" `shouldBe` Nothing - - -- A key is a regular expression, so one entry may stand for a whole family - -- of atoms and the same program need not be spelled once per name - it "matches a Ξ» name against the key as a regular expression" $ - withRegistryOf (registryOf ["L_number_.*"] (scripted "say(1)")) $ \path -> do - registry <- readRegistry path - registeredAtom registry "L_number_plus" `shouldBe` Just (Transient (Scripted RtNode "say(1)")) - - -- A plain name is a regular expression too, and it means that one atom, - -- not every atom whose name it is a part of - it "matches the key against the whole Ξ» name" $ - withRegistryOf (registryOf ["L_number"] (scripted "say(1)")) $ \path -> do - registry <- readRegistry path - registeredAtom registry "L_number_plus" `shouldBe` Nothing - - -- The keys are tried in the order the file lists them, so a catch-all - -- placed first hides everything below it, and the file is written by hand - -- here because 'object' does not keep the order of its keys - it "fires the first key top to bottom that matches" $ - withTemp "phino-atoms-.json" (ordered [(".*", "say(1)"), ("L_answer", "say(2)")]) $ \path -> do - registry <- readRegistry path - registeredAtom registry "L_answer" `shouldBe` Just (Transient (Scripted RtNode "say(1)")) - - it "reaches a later key when the earlier ones do not match" $ - withTemp "phino-atoms-.json" (ordered [("L_other", "say(1)"), (".*", "say(2)")]) $ \path -> do - registry <- readRegistry path - registeredAtom registry "L_answer" `shouldBe` Just (Transient (Scripted RtNode "say(2)")) - - -- A malformed entry is refused where the file is read, which is before any - -- dataization starts, rather than at the moment an atom of it would fire - forM_ - [ - ( "the runtime is not one phino can run" - , registryOf ["L_answer"] ["rt" .= ("ruby" :: T.Text), "script" .= ("say(1)" :: T.Text)] - , ["unknown runtime 'ruby'", "node"] - ) - , - ( "an entry carries no script" - , registryOf ["L_answer"] ["rt" .= ("node" :: T.Text)] - , ["script"] - ) - , - ( "an entry carries no runtime" - , registryOf ["L_answer"] ["script" .= ("say(1)" :: T.Text)] - , ["rt"] - ) - , - ( "an executable entry carries no path" - , registryOf ["L_answer"] ["rt" .= ("exec" :: T.Text)] - , ["path"] - ) - , - ( "the executable file is not there" - , registryOf ["L_answer"] (executing "no-such-atom") - , ["L_answer", "no-such-atom", "there is no such file"] - ) - , - ( "the file to serve from is not there" - , registryOf ["L_answer"] (served (executing "no-such-atom")) - , ["L_answer", "no-such-atom", "there is no such file"] - ) - , - ( "serve is not a boolean" - , registryOf ["L_answer"] (("serve" .= ("yes" :: T.Text)) : scripted "say(1)") - , ["serve", "Bool"] - ) - ] - ( \(desc, registry, fragments) -> - it ("fails when " ++ desc) $ - withRegistryOf registry $ \path -> - readRegistry path - `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) fragments) - ) - - it "fails when the file is not JSON at all" $ - withTemp "phino-atoms-.json" "L_answer: js" $ \path -> - readRegistry path - `shouldThrow` (\failure -> "cannot be read" `isInfixOf` show (failure :: SomeException)) - - it "fails when a key is not a regular expression" $ - withRegistryOf (registryOf ["L_(answer"] (scripted "say(1)")) $ \path -> - readRegistry path - `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) ["L_(answer", "regular expression"]) - - it "fails when the file is a JSON array" $ - withTemp "phino-atoms-.json" "[]" $ \path -> - readRegistry path - `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) ["cannot be read", "object"]) - - it "fails when there is more in the file than the JSON object" $ - withTemp "phino-atoms-.json" "{} {}" $ \path -> - readRegistry path - `shouldThrow` (\failure -> all (`isInfixOf` show (failure :: SomeException)) ["cannot be read", "more in the file"]) - - it "fails when the file is not there" $ - readRegistry "no-such-registry.json" - `shouldThrow` (\failure -> "cannot be read" `isInfixOf` show (failure :: SomeException)) - - -- A file nobody may run is refused where the registry is read, not where - -- the atom would fire - it "fails when the file of an executable Ξ» function cannot be run" $ - withScript "" $ \file -> - withRegistryOf (registryOf ["L_answer"] (executing file)) $ \path -> - readRegistry path - `shouldThrow` (\failure -> "not executable" `isInfixOf` show (failure :: SomeException)) - - it "fails when the file to serve from cannot be run" $ - withScript "" $ \file -> - withRegistryOf (registryOf ["L_answer"] (served (executing file))) $ \path -> - readRegistry path - `shouldThrow` (\failure -> "not executable" `isInfixOf` show (failure :: SomeException)) - - describe "fireAtom" $ do - -- Every program is spoken to in the letters of the evaluation rule of the - -- calculus, 𝔼(𝑏, 𝑒, 𝑠) = 𝑛, one JSON object per line, whether it is - -- started for the fire or kept for the run - it "hands back the πœ‘-expression the script wrote under '𝑛'" $ - answers (scripting "'⟦ Ξ” ‍ 2A- ⟧'") "⟦ Ξ” ‍ 2A- ⟧" - - -- One script may stand for several Ξ» functions, so every request names - -- the one being fired - it "names the Ξ» function being fired under 'Ξ»' in the request" $ - answers - (scripting "request['Ξ»'] === 'L_answer' ? '⟦ Ξ” ‍ FF- ⟧' : '⟦ Ξ” ‍ 00- ⟧'") - "⟦ Ξ” ‍ FF- ⟧" - - it "carries the formation under '𝑏' in the request and the universe under '𝑒'" $ - answers - (scripting "request['𝑏'].includes('x ↦') && universe['𝑒'].includes('y ↦') ? '⟦ Ξ” ‍ FF- ⟧' : '⟦ Ξ” ‍ 00- ⟧'") - "⟦ Ξ” ‍ FF- ⟧" - - it "tells the script the universe before the request" $ - answers - (scripting "'𝑒' in lines[0] && 'id' in lines[1] ? '⟦ Ξ” ‍ FF- ⟧' : '⟦ Ξ” ‍ 00- ⟧'") - "⟦ Ξ” ‍ FF- ⟧" - - -- Neither payload carries syntax sugar, whatever '--sweet' says about the - -- output of the run, so a script finds every datum spelled as a Ξ” binding - it "spells the payloads as canonical πœ‘-calculus" $ - answers - (scripting "request['𝑏'].includes('Ξ” ‍ 01-') ? '⟦ Ξ” ‍ FF- ⟧' : '⟦ Ξ” ‍ 00- ⟧'") - "⟦ Ξ” ‍ FF- ⟧" - - -- A script started for the fire is asked one request, the first, so it - -- may answer without reading anything at all - it "reads a script that says nothing to stdin without waiting for it" $ - answers "process.stdout.write(JSON.stringify({id: 1, '𝑛': '⟦ Ξ” ‍ 01- ⟧'}))" "⟦ Ξ” ‍ 01- ⟧" - - -- The stdin of a script started for the fire closes behind the request, - -- so a script that reads line by line answers and quits on its own, the - -- same as it would were it kept for the run - it "lets a script that reads line by line answer and quit on its own" $ - answers counting "⟦ Ξ” ‍ 01- ⟧" - - it "fails with the script's own complaint when it exits non-zero" $ - fails - "process.stderr.write('no idea what to do');process.exit(4)" - ["L_answer", "exit code 4", "no idea what to do"] - - -- A script is judged by its exit status even once it has answered, since - -- an answer it did not stand behind is no answer - it "fails when the script answers and then exits non-zero" $ - fails - "process.stdout.write(JSON.stringify({id: 1, '𝑛': '⟦ Ξ” ‍ 2A- ⟧'}) + '\\n');process.exit(2)" - ["L_answer", "exit code 2"] - - it "fails when the script writes something other than JSON" $ - fails "process.stdout.write('almost')" ["L_answer", "almost"] - - it "fails when the script writes JSON with no '𝑛' in it" $ - fails "process.stdout.write(JSON.stringify({id: 1, m: '⟦ ⟧'}))" ["L_answer", "𝑛"] - - it "fails when the script answers another request" $ - fails "process.stdout.write(JSON.stringify({id: 7, '𝑛': '⟦ Ξ” ‍ 2A- ⟧'}))" ["L_answer", "request 7"] - - it "fails when what the script put under '𝑛' is not a πœ‘-expression" $ - fails "process.stdout.write(JSON.stringify({id: 1, '𝑛': '⟦ ⟧⟧'}))" ["L_answer"] - - -- An executable atom is spawned as it is, under no interpreter, so phino - -- stages nothing of it and the file speaks the same protocol a script does - it "runs an executable Ξ» function straight off its path" $ - executes "echo '{\"id\": 1, \"𝑛\": \"⟦ Ξ” ‍ 2A- ⟧\"}'" "⟦ Ξ” ‍ 2A- ⟧" - - it "speaks the same lines to an executable as to a script" $ - executes - "case \"$(cat)\" in *'\"Ξ»\":\"L_answer\"'*) echo '{\"id\": 1, \"𝑛\": \"⟦ Ξ” ‍ FF- ⟧\"}';; *) echo '{\"id\": 1, \"𝑛\": \"⟦ Ξ” ‍ 00- ⟧\"}';; esac" - "⟦ Ξ” ‍ FF- ⟧" - - -- A program kept for the run is asked over the streams of one process, - -- whatever runs it, so a script that counts its requests sees them all - it "keeps a script that serves across the fires" $ - withNode $ - withRegistered (registryOf ["L_answer"] (served (scripted counting))) $ \registry -> do - _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - second <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - wanted <- parseExpressionThrows "⟦ Ξ” ‍ 02- ⟧" - second `shouldBe` wanted - - it "hands back the πœ‘-expression the resident program wrote under '𝑛'" $ - serves (replying "2A-") "⟦ Ξ” ‍ 2A- ⟧" - - it "keeps one resident program across the fires" $ - withShell $ - withServed ["L_answer"] (replying "0$n-") $ \registry -> do - _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - second <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - wanted <- parseExpressionThrows "⟦ Ξ” ‍ 02- ⟧" - second `shouldBe` wanted - - -- One file may be registered under several Ξ» names, and it is one program - -- that serves them all, not one per name - it "serves every Ξ» name registered on the same file from one program" $ - withShell $ - withServed ["L_answer", "L_other"] (replying "0$n-") $ \registry -> do - _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - second <- firedFrom registry "L_other" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - wanted <- parseExpressionThrows "⟦ Ξ” ‍ 02- ⟧" - second `shouldBe` wanted - - -- One key matching many names is the way to have one program serve them - -- all without spelling it once per name - it "serves every Ξ» name one key matches from one program" $ - withShell $ - withServed [".*"] (replying "0$n-") $ \registry -> do - _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - second <- firedFrom registry "L_other" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - wanted <- parseExpressionThrows "⟦ Ξ” ‍ 02- ⟧" - second `shouldBe` wanted - - it "tells the resident program the universe under '𝑒' before the first request" $ - serves (replying "0$e-") "⟦ Ξ” ‍ 01- ⟧" - - it "does not tell the resident program a universe it was told already" $ - withShell $ - withServed ["L_answer"] (replying "0$e-") $ \registry -> do - _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - second <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - wanted <- parseExpressionThrows "⟦ Ξ” ‍ 01- ⟧" - second `shouldBe` wanted - - it "tells the resident program the universe again when it changes" $ - withShell $ - withServed ["L_answer"] (replying "0$e-") $ \registry -> do - _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - second <- firedFrom registry "L_answer" "⟦ z ↦ ⟦ Ξ” ‍ 03- ⟧ ⟧" - wanted <- parseExpressionThrows "⟦ Ξ” ‍ 02- ⟧" - second `shouldBe` wanted - - it "fails when the resident program answers another request" $ - refuses "printf '{\"id\": 99, \"𝑛\": \"⟦ Ξ” ‍ 2A- ⟧\"}\\n'" ["L_answer", "request 99"] - - it "fails with the resident program's own complaint when it quits non-zero" $ - refuses "echo 'no idea what to do' >&2; exit 4" ["L_answer", "exit code 4", "no idea what to do"] - - it "fails when the resident program quits without answering" $ - refuses "exit 0" ["L_answer", "without answering"] - - it "fails when the resident program writes something other than JSON" $ - refuses "echo almost" ["L_answer", "almost"] - - -- An operand reaches a program unreduced, since reducing it may take the - -- very atom being fired, so the program asks phino for it over the channel - -- it answers on, instead of running a phino of its own - it "answers the question a resident program asks with what phino reduced" $ - serves (asking "Q.x" "*'2A-'*") "⟦ Ξ” ‍ FF- ⟧" - - -- A question mints an 'id' of its own, which phino echoes, so a program - -- that has several of them open tells the answers apart - it "echoes in its answer the 'id' the question minted" $ - serves (asking "Q.x" "*'\"id\":7'*") "⟦ Ξ” ‍ FF- ⟧" - - it "hands the πœ‘-expression of the question over to be reduced" $ - withShell $ - withServed ["L_answer"] (asking "⟦ z ↦ ⟦ Ξ” ‍ 03- ⟧ ⟧" "*'2A-'*") $ \registry -> do - seen <- newIORef Nothing - _ <- firedFrom' registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" (recording seen) - wanted <- parseExpressionThrows "⟦ z ↦ ⟦ Ξ” ‍ 03- ⟧ ⟧" - readIORef seen `shouldReturn` Just wanted - - -- Serving a question re-enters the evaluator, which fires atoms of its - -- own, and one of them may be the very atom that asked: that request - -- reaches the same program, over the same handles, while its question is - -- still open - it "fires the same program again while its question is open" $ - withShell $ - withServed ["L_answer"] nesting $ \registry -> do - answer <- firedFrom' registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" (const (firedFrom registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧")) - wanted <- parseExpressionThrows "⟦ Ξ” ‍ FF- ⟧" - answer `shouldBe` wanted - - it "fails when what a resident program asks about is not a πœ‘-expression" $ - refuses "printf '{\"id\": 7, \"ask\": \"⟦ ⟧⟧\"}\\n'" ["L_answer", "does not parse"] - - -- The stdin of a program started for the fire is closed behind its - -- request, since it may read its input whole before it answers, so there - -- is nothing left to answer a question of its own over - it "fails when a script started for the fire asks a question" $ - fails "process.stdout.write(JSON.stringify({id: 7, ask: 'Q.x'}))" ["L_answer", "serve"] - - -- A question of 'of' and 'attr' is served from the receiver phino holds - -- for that in-flight request, so the node is handed over without either - -- side quoting or re-parsing it (#1165) - it "hands the node of a named attribute to a program that asks for it by reference" $ - serves (referring 1 "x" False "*01-*") "⟦ Ξ” ‍ FF- ⟧" - - -- The same naming, with 'reduce': the value is dataized the way an 'ask' - -- is, which is what the answer of the question is made of - it "dataizes the named attribute when the question says 'reduce'" $ - serves (referring 1 "x" True "*2A-*") "⟦ Ξ” ‍ FF- ⟧" - - -- What gets reduced for a by-reference question is the value the attribute - -- carries, not a re-parse of anything quoted - it "reduces the very node the attribute carries when the question asks to" $ - withShell $ - withServed ["L_answer"] (referring 1 "x" True "*2A-*") $ \registry -> do - seen <- newIORef Nothing - _ <- firedFrom' registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" (recording seen) - wanted <- parseExpressionThrows "⟦ Ξ” ‍ 01- ⟧" - readIORef seen `shouldReturn` Just wanted - - -- The ΞΎ of a node bound in a formation stands for that formation, so a - -- node leaving one to be reduced elsewhere takes it along, the way the - -- 'dot' rule does. Without it the body of the very formation being fired - -- is the one node no question can reduce, since its ΞΎ finds nothing where - -- the reduction binds it (#1220) - it "binds the ΞΎ of the node it reduces to the formation the node came from" $ - withShell $ - withServed ["L_answer"] (referring 1 "Ο†" True "*2A-*") $ \registry -> do - seen <- newIORef Nothing - _ <- firedAt registry "L_answer" "⟦ a ↦ ⟦ Ξ” ‍ 01- ⟧, Ο† ↦ ΞΎ.a ⟧" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" (recording seen) - wanted <- parseExpressionThrows "⟦ a ↦ ⟦ Ξ” ‍ 01- ⟧, Ο† ↦ ΞΎ.a ⟧.a" - readIORef seen `shouldReturn` Just wanted - - -- A question that does not reduce is answered with the node as it is - -- written, ΞΎ and all, since binding that ΞΎ is what reducing does - it "leaves the ΞΎ of a node alone when the question does not reduce it" $ - servesAt "⟦ a ↦ ⟦ Ξ” ‍ 01- ⟧, Ο† ↦ ΞΎ.a ⟧" (referring 1 "Ο†" False "*'ΞΎ.a'*") "⟦ Ξ” ‍ FF- ⟧" - - -- A receiver is of no use to the channel once its request has been - -- answered, and a question may not dig out of it after that - it "fails a question about a request that is no longer in flight" $ - refuses (referring 2 "x" False "*2A-*") ["L_answer", "no in-flight request 2"] - - it "fails a question about an attribute the receiver does not carry" $ - refuses (referring 1 "z" False "*2A-*") ["L_answer", "carries no attribute 'z'"] - - -- The shape of an answer is phino's knowledge, not the program's, so what - -- the answered node carries is spelled next to it in the JSON and no - -- program has to keep a πœ‘ reader of its own (#1206) - it "says under 'Ξ”' what bytes the node of a by-reference answer carries" $ - serves (referring 1 "x" False "*'\"Ξ”\":\"01-\"'*") "⟦ Ξ” ‍ FF- ⟧" - - it "says under 'Ξ”' what bytes the answer to a quoted question carries" $ - serves (asking "Q.x" "*'\"Ξ”\":\"2A-\"'*") "⟦ Ξ” ‍ FF- ⟧" - - -- A node that is a stuck atom is told apart from a datum by the Ξ» name it - -- is stuck on, which is the very thing a program used to read off the text - it "says under 'Ξ»' which function the node of an answer is stuck on" $ - servesAt "⟦ x ↦ ⟦ Ξ» ‍ S4 ⟧ ⟧" (referring 1 "x" False "*'\"Ξ»\":\"S4\"'*") "⟦ Ξ” ‍ FF- ⟧" - - -- A void attribute is bound to nothing at all, which is a fact about the - -- receiver and not a failure of the question: a program may ask whether an - -- operand is bound and read the answer off 'βˆ…' - it "answers that the attribute a question names is void" $ - servesAt "⟦ x ↦ ⟦ Ξ” ‍ 01- ⟧, v ↦ βˆ… ⟧" (referring 1 "v" False "*'\"βˆ…\":true'*") "⟦ Ξ” ‍ FF- ⟧" - - -- phino holds the receiver, so depth is the only thing a question by - -- reference was missing: 'attr' is a dotted path and every segment but the - -- last has to name a formation to go on into (#1207) - it "reaches the attribute of the attribute a dotted path names" $ - servesAt "⟦ x ↦ ⟦ y ↦ ⟦ Ξ” ‍ 07- ⟧ ⟧ ⟧" (referring 1 "x.y" False "*'\"Ξ”\":\"07-\"'*") "⟦ Ξ” ‍ FF- ⟧" - - it "answers that the attribute a dotted path ends at is void" $ - servesAt "⟦ x ↦ ⟦ v ↦ βˆ… ⟧ ⟧" (referring 1 "x.v" False "*'\"βˆ…\":true'*") "⟦ Ξ” ‍ FF- ⟧" - - -- What a question asks to reduce is the node its path ends at, not the one - -- the first segment names - it "reduces the node a dotted path ends at when the question asks to" $ - withShell $ - withServed ["L_answer"] (referring 1 "x.y" True "*2A-*") $ \registry -> do - seen <- newIORef Nothing - _ <- firedAt registry "L_answer" "⟦ x ↦ ⟦ y ↦ ⟦ Ξ” ‍ 07- ⟧ ⟧ ⟧" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" (recording seen) - wanted <- parseExpressionThrows "⟦ Ξ” ‍ 07- ⟧" - readIORef seen `shouldReturn` Just wanted - - it "fails a question whose dotted path names a segment the receiver lacks" $ - refusesAt "⟦ x ↦ ⟦ y ↦ ⟦ Ξ” ‍ 07- ⟧ ⟧ ⟧" (referring 1 "x.z" False "*2A-*") ["L_answer", "carries no attribute 'x.z'"] - - it "fails a question whose dotted path runs into a void attribute" $ - refusesAt "⟦ v ↦ βˆ… ⟧" (referring 1 "v.length" False "*2A-*") ["L_answer", "carries no attribute 'v.length'"] - - -- An argument of an application binds an attribute the way a Ο„ binding of - -- a formation does, so a path walks into one just the same: a marker a - -- program built itself and put in a void is read back as written, since - -- dataizing the object around it would fire the Ξ» inside it (#1212) - it "reaches an attribute an argument of an application binds" $ - servesAt - "⟦ x ↦ Ξ¦.bool( if ↦ ⟦ guard ↦ ⟦ Ξ» ‍ S1 ⟧ ⟧ ) ⟧" - (referring 1 "x.if.guard" False "*'\"Ξ»\":\"S1\"'*") - "⟦ Ξ” ‍ FF- ⟧" - - it "walks past the arguments of an application the path does not name" $ - servesAt - "⟦ x ↦ Ξ¦.tuple( length ↦ ⟦ Ξ” ‍ 01- ⟧, head ↦ ⟦ Ξ” ‍ 02- ⟧ ) ⟧" - (referring 1 "x.length" False "*'\"Ξ”\":\"01-\"'*") - "⟦ Ξ” ‍ FF- ⟧" - - it "walks past a positional argument of an application" $ - servesAt - "⟦ x ↦ ⟦ y ↦ ⟦ Ξ” ‍ 04- ⟧ ⟧( Ξ±0 ↦ ⟦ Ξ” ‍ 05- ⟧ ) ⟧" - (referring 1 "x.y" False "*'\"Ξ”\":\"04-\"'*") - "⟦ Ξ” ‍ FF- ⟧" - - -- What an application binds an attribute to is what the attribute is, - -- whatever the formation under it still says about it - it "takes the argument of an application over the void it fills" $ - servesAt - "⟦ x ↦ ⟦ y ↦ βˆ… ⟧( y ↦ ⟦ Ξ” ‍ 03- ⟧ ) ⟧" - (referring 1 "x.y" False "*'\"Ξ”\":\"03-\"'*") - "⟦ Ξ” ‍ FF- ⟧" - - -- πœ‘-calculus types nothing nominally, so the forma of a typed literal - -- lives in the name it is dispatched off Ξ¦ by and nowhere else: an answer - -- that is an application spells that name, the way a formation spells its - -- Ξ” and its Ξ» (#1210) - it "says under 'Ξ¦.' the forma a typed literal is dispatched by" $ - servesAt - "⟦ x ↦ Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ” ‍ 40-08-00-00-00-00-00-00 ⟧ ) ) ⟧" - (referring 1 "x" False "*'\"Ξ¦.\":\"number\"'*") - "⟦ Ξ” ‍ FF- ⟧" - - it "says under 'Ξ¦.' the forma of an object taking no argument at all" $ - servesAt "⟦ x ↦ Ξ¦.true ⟧" (referring 1 "x" False "*'\"Ξ¦.\":\"true\"'*") "⟦ Ξ” ‍ FF- ⟧" - - it "says under 'Ξ¦.' the forma of an object taking several arguments" $ - servesAt - "⟦ x ↦ Ξ¦.tuple( length ↦ ⟦ Ξ” ‍ 01- ⟧, head ↦ ⟦ Ξ” ‍ 02- ⟧, tail ↦ ⟦ Ξ” ‍ 03- ⟧ ) ⟧" - (referring 1 "x" False "*'\"Ξ¦.\":\"tuple\"'*") - "⟦ Ξ” ‍ FF- ⟧" - - it "says under 'Ξ¦.' the whole chain a forma is spelled by" $ - servesAt - "⟦ x ↦ Ξ¦.org.eolang.number( Ο† ↦ ⟦ Ξ” ‍ 01- ⟧ ) ⟧" - (referring 1 "x" False "*'\"Ξ¦.\":\"org.eolang.number\"'*") - "⟦ Ξ” ‍ FF- ⟧" - - -- A chain with an application inside it names no forma, since what it - -- dispatches off is a term phino would have to dataize to know - it "stays silent about an answer whose chain has an application inside it" $ - servesAt - "⟦ x ↦ Ξ¦.number( Ο† ↦ ⟦ Ξ” ‍ 01- ⟧ ).plus( y ↦ ⟦ Ξ” ‍ 02- ⟧ ) ⟧" - (referring 1 "x" False "*'\"Ξ¦.\":'*") - "⟦ Ξ” ‍ 00- ⟧" - - -- A program kept for the run is served a lean '𝑏', with no ρ chain: the - -- chain climbs to the universe and compounds every question that quotes - -- its receiver, and whatever the lean text leaves out this program can - -- ask for, which a transient one cannot (#1165) - it "tells the resident program the receiver without its ρ chain" $ - serves - ( T.unlines - [ "case \"$line\" in" - , " *'ρ ↦'*) " <> replying "FF-" <> ";;" - , " *) " <> replying "00-" <> ";;" - , "esac" - ] - ) - "⟦ Ξ” ‍ 00- ⟧" - - -- A program started for the fire cannot ask, so its '𝑏' keeps the whole - -- receiver, ρ and all β€” the lean channel is tied to 'serve', not to a new - -- flag - it "keeps the whole receiver in the '𝑏' of a program started for the fire" $ - answers - (scripting "/\\u03c1 \\u21a6/.test(request['𝑏']) ? '⟦ Ξ” ‍ FF- ⟧' : '⟦ Ξ” ‍ 00- ⟧'") - "⟦ Ξ” ‍ FF- ⟧" - - describe "closeRegistry" $ do - -- The program is told to quit by its stdin closing, which its read loop - -- notices, so it gets to run whatever it does on exit - it "stops the resident program the registry has started" $ - withShell $ do - dir <- getTemporaryDirectory - let mark = dir "phino-resident-quit" - removePathForcibly mark - withServed ["L_answer"] ("trap 'touch " <> T.pack mark <> "' EXIT; " <> replying "2A-") $ \registry -> do - _ <- firedFrom registry "L_answer" "⟦ y ↦ ⟦ Ξ” ‍ 02- ⟧ ⟧" - closeRegistry registry - doesFileExist mark `shouldReturn` True - - it "leaves a registry that started no program alone" $ - closeRegistry emptyRegistry `shouldReturn` () diff --git a/test/BuilderSpec.hs b/test/BuilderSpec.hs --- a/test/BuilderSpec.hs +++ b/test/BuilderSpec.hs @@ -57,10 +57,10 @@ , Left "meta 't' is either does not exist or refers to an inappropriate term" ) , - ( "!e0(!t1 -> !e1, !t2 => !e2) => (!e0 >> [[]], !t1 >> x, !e1 >> Q, !t2 >> y, !e2 >> $) => [[]](x -> Q, y -> $)" - , ExApplication (ExApplication (ExMeta "e0") (ArTau (AtMeta "t1") (ExMeta "e1"))) (ArTau (AtMeta "t2") (ExMeta "e2")) + ( "!e3(!t1 -> !e1, !t2 => !e2) => (!e3 >> [[]], !t1 >> x, !e1 >> Q, !t2 >> y, !e2 >> $) => [[]](x -> Q, y -> $)" + , ExApplication (ExApplication (ExMeta "e3") (ArTau (AtMeta "t1") (ExMeta "e1"))) (ArTau (AtMeta "t2") (ExMeta "e2")) , - [ ("e0", MvExpression (ExFormation [])) + [ ("e3", MvExpression (ExFormation [])) , ("t1", MvAttribute (AtLabel "x")) , ("e1", MvExpression ExRoot) , ("t2", MvAttribute (AtLabel "y")) @@ -154,7 +154,7 @@ [ ( "builds a lambda binding from a bound function meta" , BiLambda (FnMeta "f") - , substSingle "f" (MvFunction "Func") + , substSingle "f" (MvFunction (Function "Func")) , Right [BiLambda (Function "Func")] ) , diff --git a/test/CLIHelpersSpec.hs b/test/CLIHelpersSpec.hs --- a/test/CLIHelpersSpec.hs +++ b/test/CLIHelpersSpec.hs @@ -53,5 +53,5 @@ describe "getRules" $ it "deduplicates the same --rule file listed twice" $ do - rules <- getRules False False ["test-resources/cli/simple.yaml", "test-resources/cli/simple.yaml"] + rules <- getRules False False ["test-resources/cli/rules/simple.yaml", "test-resources/cli/rules/simple.yaml"] length rules `shouldBe` 1 diff --git a/test/CLISpec.hs b/test/CLISpec.hs --- a/test/CLISpec.hs +++ b/test/CLISpec.hs @@ -16,2154 +16,2532 @@ import Data.Time.Clock (addUTCTime, getCurrentTime) import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Version (showVersion) -import Fixtures (withAskingRegistry, withFixtureRegistry, withLoopingAskRegistry, withNode, withServing, withShell) -import GHC.IO.Handle -import Paths_phino (version) -import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getTemporaryDirectory, listDirectory, removeDirectoryRecursive, removeFile, removePathForcibly, setModificationTime) -import System.Exit (ExitCode (ExitFailure)) -import System.FilePath (()) -import System.IO -import Test.Hspec -import Text.Printf (printf) - -withStdin :: String -> IO a -> IO a -withStdin input action = - bracket (openTempFile "." "stdinXXXXXX.tmp") cleanup $ \(filePath, h) -> do - hSetEncoding h utf8 - hPutStr h input - hFlush h - hClose h - withFile filePath ReadMode $ \hIn -> do - hSetEncoding hIn utf8 - bracket (hDuplicate stdin) restoreStdin $ \_ -> do - hDuplicateTo hIn stdin - hSetEncoding stdin utf8 - action - where - restoreStdin orig = hDuplicateTo orig stdin >> hClose orig - cleanup (fp, _) = removeFile fp - -withStdout :: IO a -> IO (String, a) -withStdout action = - bracket - (openTempFile "." "stdoutXXXXXX.tmp") - cleanup - ( \(path, hTmp) -> do - hSetEncoding hTmp utf8 - oldOut <- hDuplicate stdout - oldErr <- hDuplicate stderr - hDuplicateTo hTmp stdout - hDuplicateTo hTmp stderr - - result <- - action `finally` do - hFlush stdout - hFlush stderr - hDuplicateTo oldOut stdout >> hClose oldOut - hDuplicateTo oldErr stderr >> hClose oldErr - hClose hTmp - - captured <- readFile path - _ <- evaluate (length captured) - return (captured, result) - ) - where - cleanup (fp, _) = removeFile fp - -withTempFile :: String -> ((FilePath, Handle) -> IO a) -> IO a -withTempFile pattern = - bracket - (openTempFile "." pattern) - (\(path, _) -> removeFile path) - -withTempFileContent :: String -> String -> (FilePath -> IO a) -> IO a -withTempFileContent pattern content action = - withTempFile pattern $ \(path, h) -> do - hPutStr h content - hClose h - action path - --- A fresh, uniquely-named directory under the system temp directory, removed --- afterwards even when the action throws (an assertion failure included), so a --- red run never leaves it behind for the next run to depend on. -withTempDirectory :: String -> (FilePath -> IO a) -> IO a -withTempDirectory prefix action = do - tmp <- getTemporaryDirectory - stamp <- getPOSIXTime - let dir = tmp (prefix ++ "-" ++ show (round (stamp * 1000000) :: Integer)) - bracket (pure dir) removePathForcibly action - -readUtf8 :: FilePath -> IO String -readUtf8 path = - withFile path ReadMode $ \stream -> do - hSetEncoding stream utf8 - content <- hGetContents stream - _ <- evaluate (length content) - pure content - -testCLI' :: [String] -> [String] -> Either ExitCode () -> Expectation -testCLI' args outputs exit = do - (out, result) <- withStdout (try (runCLI args) :: IO (Either ExitCode ())) - if null outputs - then - unless (null out) $ - expectationFailure ("Expected that output is empty, but got:\n" ++ out) - else - forM_ - outputs - ( \output -> - unless (output `isInfixOf` out) $ - expectationFailure - ("Expected that output contains:\n" ++ output ++ "\nbut got:\n" ++ out) - ) - result `shouldBe` exit - -testCLISucceeded :: [String] -> [String] -> Expectation -testCLISucceeded args outputs = testCLI' args outputs (Right ()) - --- phino implements no Ξ» function of its own, so a case that needs an atom to --- fire brings the fixture registry in and hands its path to the command as --- '--atoms' (see 'Fixtures'). Every such atom runs under 'node', so the case is --- pending where 'node' is not installed. -withAtoms :: (String -> Expectation) -> Expectation -withAtoms action = withNode (withFixtureRegistry (action . ("--atoms=" ++))) - --- The same, for the fixture that reduces no operand of its own and asks phino --- for every one of them instead (see 'Fixtures') -withAsking :: (String -> Expectation) -> Expectation -withAsking action = withNode (withAskingRegistry (action . ("--atoms=" ++))) - -withLoopingAsk :: (String -> Expectation) -> Expectation -withLoopingAsk action = withNode (withLoopingAskRegistry (action . ("--atoms=" ++))) - --- A resident program that cannot answer its request before phino reduces --- 'Q.nope' for it, a dispatch on an atom the registry does not carry and --- '--partial' parks: it answers 'FF-' when phino said the parked node back --- alone and '00-' when the answer carried the whole universe that node was --- reduced inside, which the other atom of the universe is named in -parking :: T.Text -parking = - T.pack $ - unlines - [ "printf '{\"id\": 7, \"ask\": \"Q.nope\"}\\n'" - , "IFS= read -r reply" - , "case \"$reply\" in" - , " *L_answer*) " ++ answering "00-" ++ ";;" - , " *) " ++ answering "FF-" ++ ";;" - , "esac" - ] - where - answering :: String -> String - answering bytes = "printf '{\"id\": %s, \"𝑛\": \"⟦ Ξ” ‍ " ++ bytes ++ " ⟧\"}\\n' \"$id\"" - -testCLIFailed :: [String] -> [String] -> Expectation -testCLIFailed args outputs = testCLI' args outputs (Left (ExitFailure 1)) - -resource :: String -> String -resource file = "test-resources/cli/" <> file - -rule :: String -> String -rule file = "--rule=" <> resource file - -spec :: Spec -spec = do - it "prints version" $ - testCLISucceeded ["--version"] [showVersion version] - - it "prints help" $ - testCLISucceeded - ["--help"] - ["Phino - CLI Manipulator of πœ‘-Calculus Expressions", "Usage:"] - - describe "--pin" $ - forM_ - [ - ( "succeeds when --pin matches actual version" - , ["--pin=" ++ showVersion version, "rewrite", "--sweet"] - , testCLISucceeded - , ["⟦⟧"] - ) - , - ( "fails when --pin doesn't match actual version" - , ["--pin=9.9.9.9", "rewrite"] - , testCLIFailed - , ["Version mismatch: --pin requires '9.9.9.9', but this is phino " ++ showVersion version] - ) - , - ( "fails when --pin is empty" - , ["--pin=", "rewrite"] - , testCLIFailed - , ["Version mismatch: --pin requires ''"] - ) - ] - (\(desc, args, test, expected) -> it desc (withStdin "[[ ]]" (test args expected))) - - describe "--hide-rho" $ - forM_ - [ - ( "drops every rho binding from the default salty output" - , "[[ foo -> [[ x -> [[ ]], ^ -> $.y ]], y -> [[ ]] ]]" - , ["rewrite", "--flat", "--hide-rho"] - , ["⟦ foo ↦ ⟦ x ↦ ⟦⟧ ⟧, y ↦ ⟦⟧ ⟧"] - ) - , - ( "also drops the rho that --sweet leaves behind" - , "[[ foo -> [[ x -> [[ ]], ^ -> $.y ]], y -> [[ ]] ]]" - , ["rewrite", "--flat", "--sweet", "--hide-rho"] - , ["⟦ foo ↦ ⟦ x ↦ ⟦⟧ ⟧, y ↦ ⟦⟧ ⟧"] - ) - , - ( "keeps sweet numeric literals intact" - , "[[ a -> 42 ]]" - , ["rewrite", "--flat", "--sweet", "--hide-rho"] - , ["⟦ a ↦ 42 ⟧"] - ) - ] - (\(desc, input, args, expected) -> it desc (withStdin input (testCLISucceeded args expected))) - - it "prints debug info with --log-level=DEBUG" $ - withStdin "[[]]" $ - testCLISucceeded ["rewrite", "--log-level=DEBUG"] ["[DEBUG]:"] - - describe "--log-level accepts every named level" $ - forM_ - ["ERROR", "ERR", "error", "NONE", "none"] - ( \flagValue -> - it ("--log-level=" ++ flagValue) $ - withStdin "[[]]" $ - testCLISucceeded ["rewrite", "--log-level=" ++ flagValue] ["⟧"] - ) - - it "fails on an unrecognized --log-level value" $ - withStdin "[[]]" $ - testCLIFailed ["rewrite", "--log-level=verbose"] ["unknown log-level: verbose"] - - describe "rewriting" $ do - describe "fails" $ do - forM_ - [ ("with --input=latex", "", ["rewrite", "--input=latex"], ["The value 'latex' can't be used for '--input' option"]) - , ("with negative --log-lines", "", ["rewrite", "--log-lines=-2"], ["--log-lines must be >= -1"]) - , ("with negative --max-depth", "", ["rewrite", "--max-depth=-1"], ["--max-depth must be positive"]) - , ("with zero --max-cycles", "", ["rewrite", "--max-cycles=0"], ["--max-cycles must be positive"]) - , ("with zero --meet-length", "", ["rewrite", "--output=latex", "--meet-length=0"], ["--meet-length must be positive"]) - , - ( "with --normalize and --must=1" - , "[[ x -> [[ y -> 5 ]].y ]].x" - , ["rewrite", "--max-cycles=2", "--max-depth=1", "--normalize", "--must=1"] - , ["it's expected rewriting cycles to be in range [1], but rewriting has already reached 2"] - ) - , ("when --in-place is used without input file", "[[ ]]", ["rewrite", "--in-place"], ["--in-place requires an input file"]) - , - ( "with --output=xmir on a non-top-level expression" - , "⟦ x ↦ 1, ρ ↦ 2 ⟧" - , ["rewrite", "--output=xmir"] - , ["[ERROR]:", "its top level must be a single binding followed by ρ ↦ βˆ…"] - ) - ] - (\(desc, input, args, expected) -> it desc (withStdin input (testCLIFailed args expected))) - - it "when --in-place is used with --target" $ - withTempFile "inplaceXXXXXX.phi" $ \(path, h) -> do - hPutStr h "[[ ]]" - hClose h - testCLIFailed - ["rewrite", "--in-place", "--target=output.phi", path] - ["--in-place and --target cannot be used together"] - - it "fails when --in-place is used with a non-phi output format" $ - withTempFile "inplaceXXXXXX.phi" $ \(path, h) -> do - hPutStr h "[[ ]]" - hClose h - testCLIFailed - ["rewrite", "--in-place", "--output=latex", path] - ["--in-place can only be used together with --output=phi"] - - it "does not leak a HasCallStack backtrace into errors" $ do - (out, _) <- withStdout (try (runCLI ["rewrite", "--in-place"]) :: IO (Either ExitCode ())) - out `shouldNotContain` "HasCallStack backtrace" - out `shouldNotContain` "ExitFailure 1" - out `shouldContain` "[ERROR]:" - - it "prints optparse errors once, without a backtrace" $ do - (out, _) <- withStdout (try (runCLI ["rewrite", "--badopt"]) :: IO (Either ExitCode ())) - out `shouldNotContain` "HasCallStack backtrace" - out `shouldNotContain` "ExitFailure 1" - out `shouldContain` "[ERROR]:" - - forM_ - [ ("when --update is used without --target", "[[ ]]", ["rewrite", "--update"], ["--update requires --target"]) - , - ( "when --update is used without an input file" - , "[[ ]]" - , ["rewrite", "--update", "--target=output.phi"] - , ["--update requires an input file"] - ) - , - ( "when --update is used with --in-place" - , "[[ ]]" - , ["rewrite", "--update", "--in-place", "input.phi"] - , ["--update and --in-place cannot be used together"] - ) - , - ( "with --depth-sensitive" - , "[[ x -> \"x\"]]" - , ["rewrite", "--depth-sensitive", "--max-depth=1", "--max-cycles=1", rule "infinite.yaml"] - , ["[ERROR]: With option --depth-sensitive it's expected rewriting iterations amount does not reach the limit: --max-depth=1"] - ) - , - ( "with looping rules" - , "[[ x -> \"0\" ]]" - , ["rewrite", rule "first.yaml", rule "second.yaml", "--max-depth=1", "--max-cycles=3"] - , ["it seems rewriting is looping"] - ) - ] - (\(desc, input, args, expected) -> it desc (withStdin input (testCLIFailed args expected))) - - -- Only assert the stable parts of the parse error: phino's envelope and - -- that megaparsec reports an 'unexpected' token. The exact line:column and - -- offending token depend on megaparsec's internal try/longest-match error - -- merging, which shifts between megaparsec releases (deps are unpinned), so - -- pinning them here makes the test brittle without testing anything extra. - it "with wrong attribute and valid error message" $ - testCLIFailed - ["rewrite", resource "with-$this-attribute.phi"] - [ "[ERROR]: Couldn't parse given phi expression, cause:" - , "unexpected" - ] - - forM_ - [ - ( "with --output != latex and --nonumber" - , ["rewrite", "--nonumber", "--output=xmir"] - , ["The --nonumber option can stay together with --output=latex only"] - ) - , ("with --omit-listing and --output != xmir", ["rewrite", "--omit-listing", "--output=phi"], ["--omit-listing"]) - , ("with --omit-comments and --output != xmir", ["rewrite", "--omit-comments", "--output=phi"], ["--omit-comments"]) - , - ( "with --expression and --output != latex" - , ["rewrite", "--expression=foo", "--output=phi"] - , ["--expression option can stay together with --output=latex only"] - ) - , - ( "with --label and --output != latex" - , ["rewrite", "--label=foo", "--output=phi"] - , ["--label option can stay together with --output=latex only"] - ) - , - ( "with --compress and --output != latex" - , ["rewrite", "--compress", "--output=phi"] - , ["--compress option can stay together with --output=latex only"] - ) - , - ( "with --meet-prefix and --output != latex" - , ["rewrite", "--meet-prefix=foo", "--output=phi"] - , ["--meet-prefix option can stay together with --output=latex only"] - ) - , - ( "with wrong --hide option" - , ["rewrite", "--hide=Q.x(Q.y)"] - , ["[ERROR]: Invalid set of arguments: Only dispatch expression", "but given: Ξ¦.x( Ξ¦.y )"] - ) - , ("with many --show options", ["rewrite", "--show=Q.x.y", "--show=hello"], ["The option --show can be used only once"]) - , - ( "with wrong --show option" - , ["rewrite", "--show=Q.x(Q.y)"] - , ["[ERROR]:", "Only dispatch expression started with Ξ¦ (or Q) can be used in --show"] - ) - , ("with --show overlapping --hide", ["rewrite", "--show=Q.x", "--hide=Q.x"], ["[ERROR]:", "The --show locator 'Ξ¦.x' is also listed in --hide"]) - , ("with --meet-popularity < 0", ["rewrite", "--meet-popularity=-1"], ["[ERROR]:", "--meet-popularity must be positive"]) - , ("with --meet-popularity > 100", ["rewrite", "--meet-popularity=102"], ["[ERROR]:", "--meet-popularity must be <= 100"]) - , - ( "with --meet-popularity and output != latex" - , ["rewrite", "--meet-popularity=51", "--output=phi"] - , ["[ERROR]:", "--meet-popularity option can stay together with --output=latex only"] - ) - , - ( "with --meet-length and output != latex" - , ["rewrite", "--meet-length=4", "--output=phi"] - , ["[ERROR]:", "--meet-length option can stay together with --output=latex only"] - ) - , ("with non-dispatch --focus", ["rewrite", "--focus=Q.x(Q.y)"], ["[ERROR]"]) - , ("with --focus!=Q and --output=XMIR", ["rewrite", "--focus=Q.x", "--output=xmir"], ["[ERROR]"]) - , ("with --margin < 0", ["rewrite", "--margin=-1"], ["[ERROR]"]) - , ("with --breakpoint which does not exist across the rules", ["rewrite", "--breakpoint=hello", "--normalize"], ["[ERROR]"]) - ] - (\(desc, args, expected) -> it desc (withStdin "" (testCLIFailed args expected))) - - it "prints help" $ - testCLISucceeded - ["rewrite", "--help"] - ["Rewrite the πœ‘-expression", "--seed SEED"] - - it "accepts --seed flag" $ - withStdin "[[ x -> 5 ]]" $ - testCLISucceeded - ["rewrite", "--seed=42", "--sweet"] - ["⟦ x ↦ 5 ⟧"] - - it "defaults --seed to 0 in help" $ - testCLISucceeded - ["rewrite", "--help"] - ["default: 0"] - - it "reproduces the same shuffle order for the same --seed" $ do - let args = - [ "rewrite" - , "--shuffle" - , "--seed=42" - , "--sweet" - , "--sequence" - , "--max-depth=1" - , "--max-cycles=1" - , rule "swap-a.yaml" - , rule "swap-b.yaml" - ] - (firstRun, _) <- withStdin "[[ x -> 5 ]]" $ withStdout (runCLI args) - (secondRun, _) <- withStdin "[[ x -> 5 ]]" $ withStdout (runCLI args) - firstRun `shouldBe` secondRun - - it "fails with a non-integer --seed" $ - withStdin "[[ ]]" $ - testCLIFailed - ["rewrite", "--seed=abc"] - ["[ERROR]"] - - it "saves steps to dir with --steps-dir" $ - withTempDirectory "phino-steps" $ \dir -> - withStdin "[[ x -> \"hello\"]]" $ do - testCLISucceeded - ["rewrite", rule "infinite.yaml", "--max-cycles=2", "--max-depth=2", "--steps-dir=" ++ dir, "--sweet"] - ["hello_hi_hi"] - doesDirectoryExist dir `shouldReturn` True - files <- listDirectory dir - length files `shouldBe` 4 - doesFileExist (dir ++ "/00001.phi") `shouldReturn` True - doesFileExist (dir ++ "/00003.phi") `shouldReturn` True - - -- A served atom is asked over the streams of one resident program that - -- 'phino' starts on the first fire and stops when the run is over, so the - -- whole of it goes through the command line here: registry, program and - -- the bytes it answers with - it "dataizes with an atom served by a resident program" $ - withShell $ - withServing (T.pack "printf '{\"id\": %s, \"𝑛\": \"⟦ Ξ” ‍ 2A- ⟧\"}\\n' \"$id\"") $ \registry -> - withStdin "⟦ @ ↦ ⟦ Ξ» ‍ L_answer ⟧ ⟧" $ - testCLISucceeded ["dataize", "--atoms=" ++ registry] ["2A-"] - - -- The body of the formation being fired is what a program asks phino to - -- reduce for it, and the ΞΎ of that body stands for the very formation the - -- program was handed, so the whole of it goes through the command line - -- here: the question names 'Ο†', the answer brings what ΞΎ.a reached (#1220) - it "dataizes with an atom whose question reduces a body written with ΞΎ" - $ withShell - $ withServing - ( T.unlines - [ T.pack "printf '{\"id\": 7, \"of\": %s, \"attr\": \"Ο†\", \"reduce\": true}\\n' \"$id\"" - , T.pack "IFS= read -r reply" - , T.pack "case \"$reply\" in" - , T.pack " *01-02*) printf '{\"id\": %s, \"𝑛\": \"⟦ Ξ” ‍ 2A- ⟧\"}\\n' \"$id\";;" - , T.pack " *) printf '{\"id\": %s, \"𝑛\": \"⟦ Ξ” ‍ 00- ⟧\"}\\n' \"$id\";;" - , T.pack "esac" - ] - ) - $ \registry -> - withStdin "⟦ @ ↦ ⟦ a ↦ ⟦ Ξ” ‍ 01-02 ⟧, Ο† ↦ ΞΎ.a, Ξ» ‍ L_answer ⟧ ⟧" $ - testCLISucceeded ["dataize", "--atoms=" ++ registry] ["2A-"] - - it "saves dataize steps to dir with --steps-dir" $ - withAtoms $ \atoms -> - withTempDirectory "phino-steps-dataize" $ \dir -> - withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6).plus(7) ]]" $ do - testCLISucceeded - ["dataize", atoms, "--steps-dir=" ++ dir, "--sweet"] - ["40-32"] - doesDirectoryExist dir `shouldReturn` True - files <- listDirectory dir - let steps = sort files - -- The fix is about numbering, not about a specific rule set: the file - -- names must be distinct and contiguous from 00001, and there must be - -- more of them than a single normalization pass produces (this input - -- runs several normalizations, so a global counter yields more steps). - steps `shouldBe` map (\n -> printf "%05d.phi" (n :: Int)) [1 .. length steps] - length steps `shouldSatisfy` (> 18) - - it "saves steps with a .tex extension when --output=latex is used with --steps-dir" $ - withTempDirectory "phino-steps-latex" $ \dir -> - withStdin "[[ x -> \"hello\"]]" $ do - testCLISucceeded - ["rewrite", rule "infinite.yaml", "--max-cycles=2", "--max-depth=2", "--steps-dir=" ++ dir, "--output=latex", "--sweet"] - ["\\begin{phiquation}"] - doesDirectoryExist dir `shouldReturn` True - files <- listDirectory dir - length files `shouldBe` 4 - doesFileExist (dir ++ "/00001.tex") `shouldReturn` True - doesFileExist (dir ++ "/00003.tex") `shouldReturn` True - - it "desugares without any rules flag from file" $ - testCLISucceeded - ["rewrite", resource "desugar.phi"] - ["⟦ foo ↦ ΞΎ.x, ρ ↦ βˆ… ⟧"] - - it "desugares with without any rules flag from stdin" $ - withStdin "[[foo ↦ x]]" $ - testCLISucceeded ["rewrite"] ["⟦ foo ↦ ΞΎ.x, ρ ↦ βˆ… ⟧"] - - it "keeps the bytes of a string intact while desugaring it" $ - withStdin "⟦ Ο† ↦ Ξ¦.string(as-bytes ↦ Ξ¦.bytes(data ↦ ⟦ Ξ” ‍ 65-0A-65, ρ ↦ βˆ… ⟧)), ρ ↦ βˆ… ⟧" $ - testCLISucceeded ["rewrite", "--flat"] ["Ξ” ‍ 65-0A-65"] - - it "rewrites with single rule" $ - withStdin "T(x -> Q.y)" $ - testCLISucceeded ["rewrite", "--rule=resources/normalize/dc.yaml"] ["βŠ₯"] - - it "fails when a rewriting rule uses a dataization-only function" $ - withStdin "⟦⟧" $ - testCLIFailed - ["rewrite", rule "evaluate-in-rewrite.yaml"] - ["Function 'evaluate' in rule 'uses-evaluate' is available only for dataization and morphing, not for rewriting"] - - it "names the join function in the error message" $ - withStdin "⟦⟧" $ - testCLIFailed - ["rewrite", rule "join-broken.yaml"] - ["Function join() can work with bindings only"] - - it "normalizes with --normalize flag" $ - testCLISucceeded - ["rewrite", "--normalize", resource "normalize.phi", "--margin=25"] - [ unlines - [ "⟦" - , " x ↦ ⟦" - , " ρ ↦ ⟦" - , " y ↦ ⟦ ρ ↦ βˆ… ⟧," - , " ρ ↦ βˆ…" - , " ⟧" - , " ⟧," - , " ρ ↦ βˆ…" - , "⟧" - ] - ] - - it "normalizes and applies --rule at the same time" $ - withStdin "⟦ k ↦ ⟦ m ↦ ⟦ Ξ” ‍ 01- ⟧ ⟧.m, j ↦ ⟦ Ξ» ‍ Marker ⟧ ⟧" $ - testCLISucceeded - ["rewrite", "--normalize", rule "marker.yaml", "--sweet"] - ["⟦ k ↦ ⟦ Ξ” ‍ 01-, ρ ↦ ⟦ m ↦ ⟦ Ξ” ‍ 01- ⟧ ⟧ ⟧, j ↦ ⟦ Ξ” ‍ FF- ⟧ ⟧"] - - it "normalizes from stdin" $ - withStdin "⟦ a ↦ ⟦ b ↦ βˆ… ⟧ (b ↦ [[ ]]) ⟧" $ - testCLISucceeded - ["rewrite", "--normalize", "--margin=20"] - [ unlines - [ "⟦" - , " a ↦ ⟦" - , " b ↦ ⟦ ρ ↦ βˆ… ⟧," - , " ρ ↦ βˆ…" - , " ⟧," - , " ρ ↦ βˆ…" - , "⟧" - ] - ] - - it "rewrites with --sweet flag" $ - withStdin "[[ x -> 5]]" $ - testCLISucceeded - ["rewrite", "--sweet"] - ["⟦ x ↦ 5 ⟧"] - - it "rewrites as XMIR" $ - withStdin "[[ x -> Q.y ]]" $ - testCLISucceeded - ["rewrite", "--output=xmir"] - ["", ""] - - it "emits a real revision and ms in XMIR" $ do - (output, _) <- withStdin "[[ x -> Q.y ]]" $ withStdout (runCLI ["rewrite", "--output=xmir"]) - let attrValue :: String -> String -> String - attrValue name text = - let needle = name ++ "=\"" - breakOn :: String -> Maybe String - breakOn haystack - | needle `isPrefixOf` haystack = Just (drop (length needle) haystack) - | null haystack = Nothing - | otherwise = breakOn (drop 1 haystack) - in case breakOn text of - Just afterNeedle -> takeWhile (/= '"') afterNeedle - Nothing -> "" - revision = attrValue "revision" output - ms = attrValue "ms" output - revision `shouldSatisfy` (\sha -> length sha == 7 && all (`elem` "0123456789abcdef") sha) - revision `shouldNotBe` "1234567" - ms `shouldSatisfy` (all isDigit) - - it "rewrites as LaTeX" $ - withStdin "[[ x_o -> Q.z(y -> 5), q$ -> T, w -> $, ^ -> Q, @ -> 1, y -> \"H$@^M\", L> Fu_nc ]]" $ - testCLISucceeded - ["rewrite", "--output=latex", "--sweet"] - [ unlines - [ "\\begin{phiquation}" - , "[[" - , " |x\\char95{}o| -> Q . |z| ( |y| -> 5 )," - , " |q\\char36{}| -> T," - , " |w| -> \\phiTerminal{\\xi}," - , " \\phiTerminal{\\rho} -> Q," - , " @ -> 1," - , " |y| -> \"H$@^M\"," - , " L> |Fu\\char95{}nc|" - , "]]{.}" - , "\\end{phiquation}" - ] - ] - - it "rewrites as LaTeX without numeration" $ - withStdin "[[ x -> 5 ]]" $ - testCLISucceeded - ["rewrite", "--output=latex", "--sweet", "--nonumber", "--flat"] - [ unlines - [ "\\begin{phiquation*}" - , "[[ |x| -> 5 ]]{.}" - , "\\end{phiquation*}" - ] - ] - - it "rewrites an alpha-index argument as \\alpha subscript in LaTeX" $ - withStdin "Q.foo(~1 -> Q.y)" $ - testCLISucceeded - ["rewrite", "--output=latex", "--flat", "--nonumber"] - [ unlines - [ "\\begin{phiquation*}" - , "Q . |foo| ( \\phiTerminal{\\alpha_{1}} -> Q . |y| ){.}" - , "\\end{phiquation*}" - ] - ] - - it "rewrite as LaTeX with expression name" $ - withStdin "[[ x -> 5 ]]" $ - testCLISucceeded - ["rewrite", "--output=latex", "--sweet", "--flat", "--expression=foo"] - [ unlines - [ "\\begin{phiquation}" - , "\\phiExpression{foo} [[ |x| -> 5 ]]{.}" - , "\\end{phiquation}" - ] - ] - - it "rewrite as LaTeX with label name" $ - withStdin "[[ x -> 5 ]]" $ - testCLISucceeded - ["rewrite", "--output=latex", "--sweet", "--flat", "--label=foo"] - [ unlines - [ "\\begin{phiquation}\n\\label{foo}" - , "[[ |x| -> 5 ]]{.}" - , "\\end{phiquation}" - ] - ] - - it "rewrites with XMIR as input" $ - withStdin "" $ - testCLISucceeded - ["rewrite", "--input=xmir", "--sweet"] - ["⟦ app ↦ ⟦ x ↦ Ξ¦.number ⟧ ⟧"] - - it "rewrites and prints with XMIR as input and output" $ - withStdin - ( intercalate - "" - [ "" - , "" - ] - ) - ( testCLISucceeded - ["rewrite", "--input=xmir", "--output=xmir", "--sweet"] - [ "" - , "<?xml version="1.0" encoding="UTF-8"?><object><o name="app"><o name="x" base="Ξ¦.number"/></o></object>" - ] - ) - - it "rewrites as XMIR with omit-listing flag" $ - withStdin "[[ x -> Q.y ]]" $ - testCLISucceeded - ["rewrite", "--output=xmir", "--omit-listing"] - ["", "1 line(s)", " "] - - it "does not fail on exactly 1 rewriting" $ - withStdin "⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧" $ - testCLISucceeded - ["rewrite", rule "simple.yaml", "--must=1", "--sweet"] - ["x ↦ \"bar\""] - - it "prints many expressions with --sequence" $ - withStdin "[[ x -> \"foo\" ]]" $ - testCLISucceeded - [ "rewrite" - , rule "first.yaml" - , rule "second.yaml" - , "--max-depth=1" - , "--max-cycles=2" - , "--sequence" - , "--sweet" - , "--flat" - ] - [ unlines - [ "⟦ x ↦ \"foo\" ⟧" - , "Ξ¦.x( y ↦ \"foo\" )" - , "⟦ x ↦ \"foo\" ⟧" - ] - ] - - it "prefixes every step with a header when --headers is on" $ - withStdin "[[ x -> \"foo\" ]]" $ - testCLISucceeded - [ "rewrite" - , rule "first.yaml" - , rule "second.yaml" - , "--max-depth=1" - , "--max-cycles=2" - , "--sequence" - , "--headers" - , "--sweet" - , "--flat" - ] - [ intercalate - "\n" - [ "" - , "=== Step #1" - , "⟦ x ↦ \"foo\" ⟧" - , "" - , "=== Step #2, Rule 'first', 31t -> 30t" - , "Ξ¦.x( y ↦ \"foo\" )" - , "" - , "=== Step #3, Rule 'second', 30t -> 31t" - , "⟦ x ↦ \"foo\" ⟧" - ] - ] - - it "ignores --headers without --sequence" $ - withStdin "[[ x -> \"foo\" ]]" $ - testCLISucceeded - ["rewrite", rule "simple.yaml", "--headers", "--sweet", "--flat"] - ["⟦ x ↦ \"bar\" ⟧"] - - it "emits step headers as LaTeX comments with --headers" $ - withStdin "[[ x -> \"foo\" ]]" $ - testCLISucceeded - [ "rewrite" - , rule "first.yaml" - , rule "second.yaml" - , "--max-depth=1" - , "--max-cycles=2" - , "--sequence" - , "--headers" - , "--sweet" - , "--flat" - , "--output=latex" - ] - [ unlines - [ "\\begin{phiquation}" - , "% === Step #1" - , "[[ |x| -> \"foo\" ]] \\leadsto_{\\nameref{r:first}}" - , "% === Step #2, Rule 'first', 31t -> 30t" - , " \\leadsto Q . |x| ( |y| -> \"foo\" ) \\leadsto_{\\nameref{r:second}}" - , "% === Step #3, Rule 'second', 30t -> 31t" - , " \\leadsto [[ |x| -> \"foo\" ]]{.}" - , "\\end{phiquation}" - ] - ] - - it "prints only one latex preamble with --sequence" $ - withStdin "[[ x -> \"foo\" ]]" $ - testCLISucceeded - [ "rewrite" - , rule "first.yaml" - , rule "second.yaml" - , "--max-depth=1" - , "--max-cycles=2" - , "--sequence" - , "--sweet" - , "--flat" - , "--output=latex" - ] - [ unlines - [ "\\begin{phiquation}" - , "[[ |x| -> \"foo\" ]] \\leadsto_{\\nameref{r:first}}" - , " \\leadsto Q . |x| ( |y| -> \"foo\" ) \\leadsto_{\\nameref{r:second}}" - , " \\leadsto [[ |x| -> \"foo\" ]]{.}" - , "\\end{phiquation}" - ] - ] - - it "prints meet prefix with --meet-prefix=foo in LaTeX" $ - withStdin "[[ x -> ?, y -> $.x ]](x -> [[ D> 42- ]]).y" $ - testCLISucceeded - ["rewrite", "--normalize", "--sweet", "--sequence", "--output=latex", "--flat", "--compress", "--meet-prefix=foo"] - [ unlines - [ "\\begin{phiquation}" - , "[[ |x| -> ?, |y| -> |x| ]] ( |x| -> \\phinoMeet{foo:1}{ [[ D> |42-| ]] } ) . |y| \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto \\phinoMeet{foo:2}{ [[ |x| -> \\phinoAgain{foo:1}, |y| -> |x| ]] } . |y| \\leadsto_{\\nameref{r:dot}}" - , " \\leadsto \\phinoMeet{foo:3}{ [[ |x| -> \\phinoAgain{foo:1} ]] } . |x| ( \\phiTerminal{\\rho} -> \\phinoAgain{foo:2} ) \\leadsto_{\\nameref{r:dot}}" - , " \\leadsto \\phinoAgain{foo:1} ( \\phiTerminal{\\rho} -> \\phinoAgain{foo:3}, \\phiTerminal{\\rho} -> \\phinoAgain{foo:2} ) \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto [[ D> |42-|, \\phiTerminal{\\rho} -> \\phinoAgain{foo:3} ]] ( \\phiTerminal{\\rho} -> \\phinoAgain{foo:2} ) \\leadsto_{\\nameref{r:stay}}" - , " \\leadsto [[ D> |42-|, \\phiTerminal{\\rho} -> \\phinoAgain{foo:3} ]]{.}" - , "\\end{phiquation}" - ] - ] - - it "prints with compressed expressions in LaTeX" $ - withStdin "[[ x -> ?, y -> $.x ]](x -> [[ D> 42- ]]).y" $ - testCLISucceeded - ["rewrite", "--normalize", "--sweet", "--sequence", "--output=latex", "--flat", "--compress"] - [ unlines - [ "\\begin{phiquation}" - , "[[ |x| -> ?, |y| -> |x| ]] ( |x| -> \\phinoMeet{1}{ [[ D> |42-| ]] } ) . |y| \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto \\phinoMeet{2}{ [[ |x| -> \\phinoAgain{1}, |y| -> |x| ]] } . |y| \\leadsto_{\\nameref{r:dot}}" - , " \\leadsto \\phinoMeet{3}{ [[ |x| -> \\phinoAgain{1} ]] } . |x| ( \\phiTerminal{\\rho} -> \\phinoAgain{2} ) \\leadsto_{\\nameref{r:dot}}" - , " \\leadsto \\phinoAgain{1} ( \\phiTerminal{\\rho} -> \\phinoAgain{3}, \\phiTerminal{\\rho} -> \\phinoAgain{2} ) \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto [[ D> |42-|, \\phiTerminal{\\rho} -> \\phinoAgain{3} ]] ( \\phiTerminal{\\rho} -> \\phinoAgain{2} ) \\leadsto_{\\nameref{r:stay}}" - , " \\leadsto [[ D> |42-|, \\phiTerminal{\\rho} -> \\phinoAgain{3} ]]{.}" - , "\\end{phiquation}" - ] - ] - - it "should not print \\phinoMeet{} twice" $ - withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ - testCLISucceeded - ["rewrite", "--normalize", "--sequence", "--flat", "--compress", "--output=latex", "--sweet"] - [ unlines - [ "\\begin{phiquation}" - , "[[ |ex| -> [[ |x| -> [[ |y| -> ?, |k| -> \\phinoMeet{1}{ [[ |t| -> 42 ]] } ]] ( |y| -> \\phinoAgain{1} ) ]] . |i| ]] \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto [[ |ex| -> [[ |x| -> [[ |y| -> \\phinoAgain{1}, |k| -> \\phinoAgain{1} ]] ]] . |i| ]] \\leadsto_{\\nameref{r:stop}}" - , " \\leadsto [[ |ex| -> T ]]{.}" - , "\\end{phiquation}" - ] - ] - - it "should not meet expression with high --meet-popularity" $ - withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ - testCLISucceeded - ["rewrite", "--normalize", "--sequence", "--flat", "--compress", "--output=latex", "--sweet", "--meet-popularity=70"] - [ unlines - [ "\\begin{phiquation}" - , "[[ |ex| -> [[ |x| -> [[ |y| -> ?, |k| -> [[ |t| -> 42 ]] ]] ( |y| -> [[ |t| -> 42 ]] ) ]] . |i| ]] \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto [[ |ex| -> [[ |x| -> [[ |y| -> [[ |t| -> 42 ]], |k| -> [[ |t| -> 42 ]] ]] ]] . |i| ]] \\leadsto_{\\nameref{r:stop}}" - , " \\leadsto [[ |ex| -> T ]]{.}" - , "\\end{phiquation}" - ] - ] - - it "meets with --meet-length=32" $ - withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ - testCLISucceeded - ["rewrite", "--normalize", "--sequence", "--flat", "--compress", "--output=latex", "--sweet", "--meet-length=32"] - [ unlines - [ "\\begin{phiquation}" - , "[[ |ex| -> [[ |x| -> [[ |y| -> ?, |k| -> [[ |t| -> 42 ]] ]] ( |y| -> [[ |t| -> 42 ]] ) ]] . |i| ]] \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto [[ |ex| -> [[ |x| -> [[ |y| -> [[ |t| -> 42 ]], |k| -> [[ |t| -> 42 ]] ]] ]] . |i| ]] \\leadsto_{\\nameref{r:stop}}" - , " \\leadsto [[ |ex| -> T ]]{.}" - , "\\end{phiquation}" - ] - ] - - it "focuses expression in latex with sequence" $ - withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ - testCLISucceeded - ["rewrite", "--normalize", "--sequence", "--flat", "--output=latex", "--sweet", "--focus=Q.ex"] - [ unlines - [ "\\begin{phiquation}" - , "[[ |x| -> [[ |y| -> ?, |k| -> [[ |t| -> 42 ]] ]] ( |y| -> [[ |t| -> 42 ]] ) ]] . |i| \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto [[ |x| -> [[ |y| -> [[ |t| -> 42 ]], |k| -> [[ |t| -> 42 ]] ]] ]] . |i| \\leadsto_{\\nameref{r:stop}}" - , " \\leadsto T{.}" - , "\\end{phiquation}" - ] - ] - - it "focuses expression in latex without sequence" $ - withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ - testCLISucceeded - ["rewrite", "--normalize", "--flat", "--output=latex", "--sweet", "--focus=Q.ex"] - [ unlines - [ "\\begin{phiquation}" - , "T{.}" - , "\\end{phiquation}" - ] - ] - - it "shows exceeding of limits in latex" $ - withStdin "[[ x -> $.y, y -> $.x ]].x" $ - testCLISucceeded - ["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 [[ |y| -> |x| ]] . |y| ( \\phiTerminal{\\rho} -> [[ |x| -> |y|, |y| -> |x| ]] ) \\leadsto" - , " \\leadsto \\dots" - , "\\end{phiquation}" - ] - ] - - it "focuses expression in phi without sequence" $ - withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ - testCLISucceeded - ["rewrite", "--normalize", "--flat", "--output=phi", "--sweet", "--focus=Q.ex"] - ["βŠ₯"] - - it "focuses expression in phi with sequence" $ - withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ - testCLISucceeded - ["rewrite", "--normalize", "--sequence", "--flat", "--output=phi", "--sweet", "--focus=Q.ex"] - [ unlines - [ "⟦ x ↦ ⟦ y ↦ βˆ…, k ↦ ⟦ t ↦ 42 ⟧ ⟧( y ↦ ⟦ t ↦ 42 ⟧ ) ⟧.i" - , "⟦ x ↦ ⟦ y ↦ ⟦ t ↦ 42 ⟧, k ↦ ⟦ t ↦ 42 ⟧ ⟧ ⟧.i" - , "βŠ₯" - ] - ] - - it "prints input as listing in XMIR" $ - withStdin "[[ app -> [[]] ]]" $ - testCLISucceeded - ["rewrite", "--output=xmir", "--omit-comments", "--sweet", "--flat"] - [" [[ app -> [[]] ]]"] - - it "print expression in listing in XMIRs with --sequence" $ - withStdin "[[ x -> \"foo\" ]]" $ - testCLISucceeded - ["rewrite", "--output=xmir", "--omit-comments", "--sweet", "--flat", "--sequence", rule "simple.yaml"] - [" ⟦ x ↦ \"foo\" ⟧", " ⟦ x ↦ \"bar\" ⟧"] - - describe "must range tests" $ do - describe "fails" $ do - it "when cycles exceed range ..1" $ - withStdin "[[ x -> [[ y -> 5 ]].y ]].x" $ - testCLIFailed - ["rewrite", "--max-depth=1", "--max-cycles=2", "--normalize", "--must=..1"] - ["it's expected rewriting cycles to be in range [..1], but rewriting has already reached 2"] - - it "when cycles below range 2.." $ - withStdin "⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧" $ - testCLIFailed - ["rewrite", rule "simple.yaml", "--must=2.."] - ["it's expected rewriting cycles to be in range [2..], but rewriting stopped after 1"] - - it "with invalid range 5..3" $ - withStdin "[[ ]]" $ - testCLIFailed - ["rewrite", "--must=5..3"] - ["cannot parse value `5..3'"] - - it "with negative in range -1..5" $ - withStdin "[[ ]]" $ - testCLIFailed - ["rewrite", "--must=-1..5"] - ["cannot parse value `-1..5'"] - - it "with malformed range syntax" $ - withStdin "[[ ]]" $ - testCLIFailed - ["rewrite", "--must=3...5"] - ["cannot parse value `3...5'"] - - it "accepts range ..5 (0 to 5 cycles)" $ - withStdin "[[ ]]" $ - testCLISucceeded ["rewrite", "--must=..5", "--sweet"] ["⟦⟧"] - - it "accepts range 0..0 (exactly 0 cycles)" $ - withStdin "[[ ]]" $ - testCLISucceeded ["rewrite", "--must=0..0", "--sweet"] ["⟦⟧"] - - it "accepts range 1..1 (exactly 1 cycle)" $ - withStdin "⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧" $ - testCLISucceeded - ["rewrite", rule "simple.yaml", "--must=1..1", "--sweet"] - ["x ↦ \"bar\""] - - it "accepts range 1..3 when 1 cycle happens" $ - withStdin "⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧" $ - testCLISucceeded - ["rewrite", rule "simple.yaml", "--must=1..3", "--sweet"] - ["x ↦ \"bar\""] - - it "accepts range 0.. (0 or more)" $ - withStdin "[[ ]]" $ - testCLISucceeded ["rewrite", "--must=0..", "--sweet"] ["⟦⟧"] - - it "prints to target file" $ - withStdin "[[ ]]" $ - withTempFile "targetXXXXXX.tmp" $ \(path, h) -> do - hClose h - testCLISucceeded ["rewrite", "--sweet", printf "--target=%s" path] [] - content <- readFile path - content `shouldBe` "⟦⟧" - - it "modifies file in-place" $ - withTempFile "inplaceXXXXXX.phi" $ \(path, h) -> do - hPutStr h "[[ x -> \"foo\" ]]" - hClose h - testCLISucceeded ["rewrite", rule "simple.yaml", "--in-place", "--sweet", path] [] - content <- readFile path - content `shouldBe` "⟦ x ↦ \"bar\" ⟧" - - it "skips rewriting with --update when target is newer than source" $ - withTempFileContent "src-XXXXXX.phi" "[[ x -> \"foo\" ]]" $ \src -> - withTempFileContent "tgt-XXXXXX.phi" "ORIGINAL" $ \tgt -> do - now <- getCurrentTime - setModificationTime src (addUTCTime (-60) now) - setModificationTime tgt now - testCLISucceeded - ["rewrite", rule "simple.yaml", "--update", "--sweet", "--target=" ++ tgt, src] - [] - content <- readFile tgt - content `shouldBe` "ORIGINAL" - - it "logs the skip reason at debug level when --update finds a newer target" $ - withTempFileContent "src-XXXXXX.phi" "[[ x -> \"foo\" ]]" $ \src -> - withTempFileContent "tgt-XXXXXX.phi" "ORIGINAL" $ \tgt -> do - now <- getCurrentTime - setModificationTime src (addUTCTime (-60) now) - setModificationTime tgt now - testCLISucceeded - ["rewrite", rule "simple.yaml", "--update", "--sweet", "--log-level=DEBUG", "--target=" ++ tgt, src] - ["is newer than source", "skipping rewriting (--update)"] - - it "logs progress at debug level when printing to --target" $ - withStdin "[[ ]]" $ - withTempFile "targetXXXXXX.tmp" $ \(path, h) -> do - hClose h - testCLISucceeded - ["rewrite", "--sweet", "--log-level=DEBUG", printf "--target=%s" path] - ["The option '--target' is specified, printing to", "The command result was saved in"] - - it "logs progress at debug level when modifying a file in-place" $ - withTempFile "inplaceXXXXXX.phi" $ \(path, h) -> do - hPutStr h "[[ x -> \"foo\" ]]" - hClose h - testCLISucceeded - ["rewrite", rule "simple.yaml", "--in-place", "--sweet", "--log-level=DEBUG", path] - ["The option '--in-place' is specified, writing back to", "was modified in-place"] - - it "rewrites with --update when source is newer than target" $ - withTempFileContent "src-XXXXXX.phi" "[[ x -> \"foo\" ]]" $ \src -> - withTempFileContent "tgt-XXXXXX.phi" "ORIGINAL" $ \tgt -> do - now <- getCurrentTime - setModificationTime tgt (addUTCTime (-60) now) - setModificationTime src now - testCLISucceeded - ["rewrite", rule "simple.yaml", "--update", "--sweet", "--target=" ++ tgt, src] - [] - content <- readFile tgt - content `shouldBe` "⟦ x ↦ \"bar\" ⟧" - - it "rewrites with cycles" $ - withStdin "[[ x -> \"x\" ]]" $ - testCLISucceeded - ["rewrite", "--sweet", rule "infinite.yaml", "--max-depth=1", "--max-cycles=2"] - ["⟦ x ↦ \"x_hi_hi\" ⟧"] - - it "hides default package" $ - withStdin "[[ org -> [[ eolang -> [[ number -> [[]] ]]]], x -> 42 ]]" $ - testCLISucceeded - ["rewrite", "--sweet", "--flat", "--hide=Q.org"] - ["⟦ x ↦ 42 ⟧"] - - it "hides several FQNs" $ - withStdin "[[ org -> [[ eolang -> Q.x, yegor256 -> Q.y ]], x -> 42 ]]" $ - testCLISucceeded - ["rewrite", "--sweet", "--flat", "--hide=Q.org.eolang", "--hide=Q.org.yegor256"] - ["⟦ org ↦ ⟦⟧, x ↦ 42 ⟧"] - - it "shows and hides" $ - withStdin "[[ org -> [[ eolang -> Q.x, yegor256 -> Q.y ]], x -> 42 ]]" $ - testCLISucceeded - ["rewrite", "--sweet", "--flat", "--show=Q.org", "--hide=Q.org.eolang"] - ["⟦ org ↦ ⟦ yegor256 ↦ Ξ¦.y ⟧ ⟧"] - - it "prints in line with --flat" $ - withStdin "[[ x -> 5, y -> \"hey\", z -> [[ w -> [[ ]] ]] ]]" $ - testCLISucceeded - ["rewrite", "--sweet", "--flat"] - ["⟦ x ↦ 5, y ↦ \"hey\", z ↦ ⟦ w ↦ ⟦⟧ ⟧ ⟧"] - - it "removes unnecessary rho bindings in primitive applications" $ - withStdin - ( unlines - [ "[[" - , " z -> [[ x -> [[ t -> 42 ]].t ]].x," - , " org -> [[ eolang -> [[ bytes -> [[ data -> ? ]], number -> [[ as-bytes -> ? ]] ]] ]]" - , "]]" - ] - ) - ( testCLISucceeded - ["rewrite", "--sweet", "--normalize", "--flat"] - ["⟦ z ↦ 42, org ↦ ⟦ eolang ↦ ⟦ bytes(data) ↦ ⟦⟧, number(as-bytes) ↦ ⟦⟧ ⟧ ⟧ ⟧"] - ) - - it "reduces log message" $ - withStdin "[[ x -> [[ y -> ? ]](y -> 5) ]]" $ - testCLISucceeded - ["rewrite", "--log-level=debug", "--log-lines=1", "--normalize"] - [ intercalate - "\n" - [ "[DEBUG]: Applied 'copy' (44 nodes -> 39 nodes)" - , "---| log is limited by --log-lines=1 option |---" - ] - ] - - -- 'matches' inside 'when' raises while dataizing a formation: the - -- substitution is still dropped (the policy #1079 questions), but the - -- reason surfaces in the debug log instead of vanishing - it "reports a condition that raised while being evaluated" $ - withStdin "[[ x -> [[ y -> βˆ… ]] ]]" $ - testCLISucceeded - ["rewrite", rule "raising-condition.yaml", "--log-level=debug", "--flat"] - [ "raised and was treated as not met: user error (Only data objects and bytes are supported" - , "⟦ x ↦ ⟦ y ↦ βˆ…, ρ ↦ βˆ… ⟧, ρ ↦ βˆ… ⟧" - ] - - it "canonizes expression" $ - withStdin "[[ x -> [[ y -> [[ L> Func ]].q, z -> Q.x(a -> [[ w -> [[ L> Atom ]], L> Hello ]]) ]], L> Package ]]" $ - testCLISucceeded - ["rewrite", "--canonize", "--sweet", "--flat"] - ["⟦ x ↦ ⟦ y ↦ ⟦ Ξ» ‍ Fn1 ⟧.q, z ↦ Ξ¦.x( a ↦ ⟦ w ↦ ⟦ Ξ» ‍ Fn2 ⟧, Ξ» ‍ Fn3 ⟧ ) ⟧, Ξ» ‍ Fn4 ⟧"] - - it "rewrites by locator" $ - withStdin "[[ ex -> [[ x -> [[ y -> 5 ]].y ]], abc -> [[ x -> ? ]](x -> 5) ]]" $ - testCLISucceeded - ["rewrite", "--sweet", "--flat", "--locator=Q.ex", "--normalize"] - ["⟦ ex ↦ ⟦ x ↦ 5 ⟧, abc ↦ ⟦ x ↦ βˆ… ⟧( x ↦ 5 ) ⟧"] - - it "returns original expression on --breakpoint" $ - withStdin "[[ x -> ?, y -> $.x ]](x -> [[ D> 42- ]]).y" $ - testCLISucceeded - ["rewrite", "--sweet", "--flat", "--normalize", "--breakpoint=stop", "--log-level=debug"] - [ "Applied 'copy' (30 nodes -> 25 nodes)" - , "Rule 'stop' is a breakpoint, dropping down all the previous rewritings..." - , "⟦ x ↦ βˆ…, y ↦ x ⟧( x ↦ ⟦ Ξ” ‍ 42- ⟧ ).y" - ] - - describe "dataize" $ do - it "prints help" $ - testCLISucceeded ["dataize", "--help"] ["Dataize the πœ‘-expression"] - - it "dataizes simple expression" $ - withStdin "[[ D> 01- ]]" $ - testCLISucceeded ["dataize"] ["01-"] - - it "accepts --seed flag" $ - withStdin "[[ D> 01- ]]" $ - testCLISucceeded ["dataize", "--seed=7"] ["01-"] - - it "fails to dataize an empty object, which dataizes the terminator βŠ₯" $ - withStdin "[[ ]]" $ - testCLIFailed ["dataize"] ["terminator βŠ₯"] - - it "fails with negative --max-steps" $ - withStdin "[[ D> 01- ]]" $ - testCLIFailed ["dataize", "--max-steps=-1"] ["--max-steps must be positive"] - - -- The 𝕄/𝔻 recursion used to be unbounded, so this division kept morphing - -- forever and no option could stop it (#1052) - it "fails on --max-steps instead of morphing forever" $ - withAtoms $ \atoms -> - withStdin "⟦ @ ↦ ⟦ Ξ» ‍ L_number_div, ρ ↦ ⟦ Ξ” ‍ 40-45-00-00-00-00-00-00 ⟧, x ↦ ⟦ Ξ” ‍ 40-00-00-00-00-00-00-00 ⟧ ⟧ ⟧" $ - testCLIFailed - ["dataize", atoms, "--max-steps=40"] - ["[ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=40"] - - -- Under '--partial' the same term does not fail: the spent budget is a - -- stuck site too, and the run ends on the residual the spine reached (#1078) - it "parks --max-steps on a residual with --partial" $ - withAtoms $ \atoms -> - withStdin "⟦ @ ↦ ⟦ Ξ» ‍ L_number_div, ρ ↦ ⟦ Ξ” ‍ 40-45-00-00-00-00-00-00 ⟧, x ↦ ⟦ Ξ” ‍ 40-00-00-00-00-00-00-00 ⟧ ⟧ ⟧" $ - testCLISucceeded - ["dataize", atoms, "--max-steps=40", "--partial", "--flat"] - ["Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ” ‍ 40-35-00-00-00-00-00-00"] - - it "dataizes with --sequence" $ - withStdin "[[ @ -> [[ x -> [[ D> 01-, y -> ? ]](y -> [[ ]]) ]].x ]]" $ - testCLISucceeded - ["dataize", "--sequence", "--output=latex", "--flat", "--sweet"] - [ intercalate - "\n" - [ "\\begin{phiquation}" - , "[[ @ -> [[ |x| -> [[ D> |01-|, |y| -> ? ]] ( |y| -> [[]] ) ]] . |x| ]] \\leadsto_{\\nameref{r:contextualize}}" - , " \\leadsto [[ |x| -> [[ D> |01-|, |y| -> ? ]] ( |y| -> [[]] ) ]] . |x| \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto [[ |x| -> [[ D> |01-|, |y| -> [[]] ]] ]] . |x| \\leadsto_{\\nameref{r:dot}}" - , " \\leadsto [[ D> |01-|, |y| -> [[]] ]] ( \\phiTerminal{\\rho} -> [[ |x| -> [[ D> |01-|, |y| -> [[]] ]] ]] ) \\leadsto_{\\nameref{r:copy}}" - , " \\leadsto [[ D> |01-|, |y| -> [[]], \\phiTerminal{\\rho} -> [[ |x| -> [[ D> |01-|, |y| -> [[]] ]] ]] ]] \\leadsto_{\\nameref{r:delta}}" - , " \\leadsto |01-|{.}" - , "\\end{phiquation}" - , "01-" - ] - ] - - it "keeps the delta step in --sequence under --quiet" $ - withStdin "[[ D> 01- ]]" $ - testCLISucceeded - ["dataize", "--sequence", "--quiet", "--output=latex", "--flat", "--sweet"] - [ intercalate - "\n" - [ "[[ D> |01-| ]] \\leadsto_{\\nameref{r:delta}}" - , " \\leadsto |01-|{.}" - , "\\end{phiquation}" - ] - ] - - it "ends the phi --sequence at the bare data" $ - withStdin "[[ D> 01- ]]" $ - testCLISucceeded - ["dataize", "--sequence", "--quiet", "--flat", "--sweet"] - ["⟦ Ξ” ‍ 01- ⟧\n01-"] - - it "focuses a compressed sequence whose meet replaces a step root" $ - withAtoms $ \atoms -> - withStdin "[[ @ -> [[ @ -> $.c.plus( 32.0 ), c -> 25.0 ]], bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus -> [[ x -> ?, L> L_number_plus ]] ]] ]]" $ - testCLISucceeded - ["dataize", atoms, "--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}}"] - - it "compresses a canonized whole-expression sequence into a meet" $ - withAtoms $ \atoms -> - withStdin "[[ @ -> [[ @ -> $.c.plus( 32.0 ), c -> 25.0 ]], bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus -> [[ x -> ?, L> L_number_plus ]] ]] ]]" $ - testCLISucceeded - ["dataize", atoms, "--output=latex", "--sweet", "--nonumber", "--compress", "--canonize", "--meet-prefix=dataization", "--sequence", "--flat", "--quiet", "--meet-length=5", "--meet-popularity=1"] - ["\\phinoMeet{dataization:1}"] - - it "dataizes with --locator" $ - withStdin "[[ ex -> [[ @ -> Q.x ]], x -> [[ D> 42- ]] ]]" $ - testCLISucceeded ["dataize", "--locator=Q.ex"] ["42-"] - - it "does not print bytes with --quiet" $ - withStdin "[[ D> 01- ]]" $ - testCLISucceeded ["dataize", "--quiet"] [] - - describe "--evaluations" $ do - it "writes one tab-separated record per fired atom" $ - withAtoms $ \atoms -> - withTempFile "evaluationsXXXXXX.txt" $ \(path, stream) -> do - hClose stream - withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6) ]]" $ - testCLISucceeded ["dataize", atoms, "--evaluations=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] - records <- readUtf8 path - records `shouldBe` "L_number_plus\t⟦ x ↦ 6 ⟧\t11\n" - - it "writes a record for every firing" $ - withAtoms $ \atoms -> - withTempFile "evaluationsXXXXXX.txt" $ \(path, stream) -> do - hClose stream - withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6).plus(7) ]]" $ - testCLISucceeded ["dataize", atoms, "--evaluations=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] - records <- readUtf8 path - lines records `shouldBe` ["L_number_plus\t⟦ x ↦ 6 ⟧\t11", "L_number_plus\t⟦ x ↦ 7 ⟧\t18"] - - it "writes records in canonical syntax without --sweet" $ - withAtoms $ \atoms -> - withTempFile "evaluationsXXXXXX.txt" $ \(path, stream) -> do - hClose stream - withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6) ]]" $ - testCLISucceeded ["dataize", atoms, "--evaluations=" ++ path, "--quiet", "--hide-rho"] [] - records <- readUtf8 path - records `shouldEndWith` "\tΞ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ” ‍ 40-26-00-00-00-00-00-00 ⟧ ) )\n" - - it "keeps the records of a run that fails" $ - withAtoms $ \atoms -> - withTempFile "evaluationsXXXXXX.txt" $ \(path, stream) -> do - hClose stream - withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]], nope -> [[ L> L_number_nope ]] ]], @ -> 5.plus(6).nope ]]" $ - testCLIFailed - ["dataize", atoms, "--evaluations=" ++ path, "--quiet", "--sweet", "--hide-rho"] - ["Atom 'L_number_nope' does not exist"] - records <- readUtf8 path - records `shouldBe` "L_number_plus\t⟦ x ↦ 6 ⟧\t11\n" - - it "truncates the records left over from the previous run" $ - withTempFileContent "evaluationsXXXXXX.txt" "L_number_gt\t[[ ]]\t01-\n" $ \path -> do - withStdin "[[ D> 01- ]]" $ - testCLISucceeded ["dataize", "--evaluations=" ++ path, "--quiet"] [] - records <- readUtf8 path - records `shouldBe` "" - - it "fails with --output=xmir" $ - withStdin "[[ D> 01- ]]" $ - testCLIFailed - ["dataize", "--evaluations=evaluations.txt", "--output=xmir"] - ["The --evaluations option can stay together with --output=phi only"] - - it "fails with --output=latex" $ - withStdin "[[ D> 01- ]]" $ - testCLIFailed - ["dataize", "--evaluations=evaluations.txt", "--output=latex"] - ["The --evaluations option can stay together with --output=phi only"] - - -- A Ξ» function the '--atoms' registry does not carry cannot fire β€” a - -- placeholder such as ⟦ Ξ» ‍ Sym_arg_0 ⟧ standing in for a data input, or - -- an operation the caller left out of its registry on purpose. The run used - -- to die on it, discarding what it had already evaluated (#1060) - describe "--partial" $ do - let stuck = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ times(x) -> [[ L> L_number_times ]], nope -> [[ L> L_number_nope ]] ]], @ -> 2.times(3).nope ]]" - it "fails on an atom that cannot fire without the flag" $ - withAtoms $ \atoms -> - withStdin stuck $ - testCLIFailed ["dataize", atoms, "--sweet", "--hide-rho"] ["Atom 'L_number_nope' does not exist"] - - it "prints the residue with the stuck application intact and exits successfully" $ - withAtoms $ \atoms -> - withStdin stuck $ - testCLISucceeded - ["dataize", atoms, "--partial", "--sweet", "--hide-rho"] - ["⟦ Ξ» ‍ L_number_nope ⟧"] - - it "keeps what was evaluated before the stuck site in the residue" $ - withAtoms $ \atoms -> - withStdin stuck $ - testCLISucceeded - ["dataize", atoms, "--partial", "--sweet"] - ["Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ” ‍ 40-18-00-00-00-00-00-00 ⟧ )"] - - it "records every stuck site in --evaluations with no result" $ - withAtoms $ \atoms -> - withTempFile "evaluationsXXXXXX.txt" $ \(path, stream) -> do - hClose stream - withStdin stuck $ - testCLISucceeded ["dataize", atoms, "--partial", "--evaluations=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] - records <- readUtf8 path - lines records - `shouldBe` [ "L_number_times\t⟦ x ↦ 3 ⟧\t6" - , "L_number_nope\t⟦⟧" - ] - - it "still prints bytes when nothing gets stuck" $ - withAtoms $ \atoms -> - withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6) ]]" $ - testCLISucceeded ["dataize", atoms, "--partial"] ["40-26-00-00-00-00-00-00"] - - -- The residual is an arbitrary formation, and a multi-binding - -- is exactly what XMIR now carries: one per binding (#1076) - it "prints the residual to XMIR, with its real listing by default" $ - withAtoms $ \atoms -> - withStdin stuck $ - testCLISucceeded - ["dataize", atoms, "--partial", "--output=xmir"] - ["L_number_nope", "", "⟦"] - - it "honors --hide-rho and --omit-listing when printing the residual to XMIR" $ - withAtoms $ \atoms -> - withStdin stuck $ - testCLISucceeded - ["dataize", atoms, "--partial", "--output=xmir", "--hide-rho", "--omit-listing"] - ["L_number_nope", "line(s)"] - - it "prints the chain of steps ending in the residue with --sequence" $ - withAtoms $ \atoms -> - withStdin stuck $ - testCLISucceeded - ["dataize", atoms, "--partial", "--sequence", "--sweet", "--hide-rho", "--flat"] - ["2.times( 3 ).nope", "⟦ Ξ» ‍ L_number_nope ⟧"] - - it "still stops on the terminator βŠ₯, since a wrong operand is not a stuck atom" $ - withStdin "[[ ]]" $ - testCLIFailed ["dataize", "--partial"] ["terminator βŠ₯"] - - -- Which Ξ» functions exist is not phino's business any more: the registry - -- given with '--atoms' decides, and phino carries none of its own - describe "--atoms" $ do - let sum' = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6) ]]" - it "fires the Ξ» function the registry carries" $ - withAtoms $ \atoms -> - withStdin sum' $ - testCLISucceeded ["dataize", atoms] ["40-26-00-00-00-00-00-00"] - - it "gets stuck on every atom when it is not given" $ - withStdin sum' $ - testCLIFailed ["dataize"] ["Atom 'L_number_plus' does not exist"] - - it "fails when the registry file is not there" $ - withStdin sum' $ - testCLIFailed ["dataize", "--atoms=no-such-registry.json"] ["no-such-registry.json"] - - -- An unknown runtime is refused where the registry is read, which is - -- before the input is even parsed, rather than when an atom of it fires - it "fails on a runtime phino cannot run, before dataizing anything" $ - withTempFileContent "atomsXXXXXX.json" "{\"L_number_plus\": {\"rt\": \"ruby\", \"script\": \"puts 1\"}}" $ \path -> - withStdin sum' $ - testCLIFailed ["dataize", "--atoms=" ++ path] ["unknown runtime 'ruby'"] - - it "fails on a registry that is not JSON" $ - withTempFileContent "atomsXXXXXX.json" "L_number_plus: js" $ \path -> - withStdin sum' $ - testCLIFailed ["dataize", "--atoms=" ++ path] ["cannot be read"] - - -- An operand reaches an atom as it was written, so 'x' arrives here as - -- '6.plus( 7 )': a program that needs it reduced asks phino for it over - -- the very channel it answers on, and serving that question costs - -- another fire of the same program, which arrives while the question is - -- still open - it "reduces the operand a program asks it about" $ - withAsking $ \atoms -> - withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6.plus(7)) ]]" $ - testCLISucceeded ["dataize", atoms] ["40-32-00-00-00-00-00-00"] - - -- A question about a term the universe cannot finish reducing does not - -- kill a '--partial' run: phino parks the cycle the question walks into - -- and answers with the residual, so the program still replies and the - -- bytes arrive (#1078, over the ask channel of #1160) - it "answers a looping question with a parked residual under --partial" $ - withLoopingAsk $ \atoms -> - withStdin "⟦ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number ↦ ⟦ Ο† ↦ βˆ…, gt(x) ↦ ⟦ Ξ» ‍ L_number_gt ⟧ ⟧, Ο† ↦ 5.gt(1) ⟧" $ - testCLISucceeded - ["dataize", atoms, "--partial", "--max-steps=200"] - ["2A-"] - - -- A question is answered with the node the program asked about, and - -- never with the universe that node was reduced inside: a parked - -- question used to hand the residue back whole, so a program reading a - -- seventeen-byte node paid for a print of the entire universe, once per - -- question (#1167) - it "answers a parked question with the node alone" $ - withShell $ - withServing parking $ \registry -> - withStdin "⟦ nope ↦ ⟦ Ξ» ‍ L_nope ⟧, Ο† ↦ ⟦ Ξ» ‍ L_answer ⟧ ⟧" $ - testCLISucceeded ["dataize", "--atoms=" ++ registry, "--partial"] ["FF-"] - - -- Without '--partial' the exhausted budget fails the run through a - -- question just as it fails it anywhere else (#1052's message) - it "fails a looping question without --partial" $ - withLoopingAsk $ \atoms -> - withStdin "⟦ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number ↦ ⟦ Ο† ↦ βˆ…, gt(x) ↦ ⟦ Ξ» ‍ L_number_gt ⟧ ⟧, Ο† ↦ 5.gt(1) ⟧" $ - testCLIFailed - ["dataize", atoms, "--max-steps=200"] - ["--max-steps=200"] - - -- An atom script cannot reduce the operands it was handed by itself, so it - -- asks phino for them: '--inside' binds an expression to a synthetic - -- attribute of the universe and aims the run at it - describe "--inside" $ do - let universe = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> [[ D> 01- ]] ]]" - it "dataizes an expression the input does not contain" $ - withAtoms $ \atoms -> - withStdin universe $ - testCLISucceeded ["dataize", atoms, "--inside=5.plus( 6 )"] ["40-26-00-00-00-00-00-00"] - - -- The expression is normalized first, so a dispatch off a formation β€” the - -- very shape a script asks about, '⟦ x ↦ 6, ρ ↦ 5 ⟧.x' β€” reduces too - it "normalizes what it is handed before dataizing it" $ - withStdin universe $ - testCLISucceeded ["dataize", "--inside=[[ x -> [[ D> 2A- ]] ]].x"] ["2A-"] - - it "morphs inside the universe just as it dataizes inside it" $ - withAtoms $ \atoms -> - withStdin universe $ - testCLISucceeded ["morph", atoms, "--inside=5.plus( 6 )", "--sweet", "--hide-rho", "--flat"] ["⟦ x ↦ 6, Ξ» ‍ L_number_plus ⟧"] - - it "cannot be used together with --locator" $ - withStdin universe $ - testCLIFailed ["dataize", "--inside=Q.@", "--locator=Q.@"] ["--inside and --locator cannot be used together"] - - it "fails when the input expression is not a formation" $ - withStdin "Q.x" $ - testCLIFailed ["dataize", "--inside=Q.x"] ["--inside requires the input expression to be a formation"] - - describe "fails" $ do - it "with --output != latex and --nonumber" $ - withStdin "" $ - testCLIFailed - ["dataize", "--nonumber", "--output=xmir"] - ["The --nonumber option can stay together with --output=latex only"] - - it "with --omit-listing and --output != xmir" $ - withStdin "" $ - testCLIFailed - ["dataize", "--omit-listing", "--output=phi"] - ["--omit-listing"] - - it "with --omit-comments and --output != xmir" $ - withStdin "" $ - testCLIFailed - ["dataize", "--omit-comments", "--output=phi"] - ["--omit-comments"] - - it "with --expression and --output != latex" $ - withStdin "" $ - testCLIFailed - ["dataize", "--expression=foo", "--output=phi"] - ["--expression option can stay together with --output=latex only"] - - it "with --label and --output != latex" $ - withStdin "" $ - testCLIFailed - ["dataize", "--label=foo", "--output=phi"] - ["--label option can stay together with --output=latex only"] - - it "with wrong --hide option" $ - withStdin "" $ - testCLIFailed - ["dataize", "--hide=Q.x(Q.y)"] - ["[ERROR]: Invalid set of arguments: Only dispatch expression", "but given: Ξ¦.x( Ξ¦.y )"] - - it "with wrong --show option" $ - withStdin "" $ - testCLIFailed - ["dataize", "--show=Q.x(Q.y)"] - ["[ERROR]:", "Only dispatch expression started with Ξ¦ (or Q) can be used in --show"] - - it "with wrong --locator option" $ - withStdin "" $ - testCLIFailed - ["dataize", "--locator=Q.x(Q.y)"] - ["[ERROR]:", "Only dispatch expression started with Ξ¦ (or Q) can be used in --locator"] - - it "with wrong --focus option" $ - withStdin "" $ - testCLIFailed - ["dataize", "--focus=Q.x(Q.y)"] - ["[ERROR]:", "Only dispatch expression started with Ξ¦ (or Q) can be used in --focus"] - - it "accepts --depth-sensitive" $ - withStdin "[[ D> 01- ]]" $ - testCLISucceeded ["dataize", "--depth-sensitive"] ["01-"] - - -- 𝕄 was reachable only from inside 𝔻, through the 'norm' rule of the - -- dataization relation, so there was no way to ask phino for 𝕄(n, Ξ¦) on its - -- own (#1114) - describe "morph" $ do - -- Two chained atom calls: the inner one fires under 'ml', because '.plus' - -- is dispatched on its result, while the outer application is saturated but - -- bare, so 'mf' hands it back and firing it is 𝔻's job - let chained = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6).plus(7) ]]" - it "prints help" $ - testCLISucceeded ["morph", "--help"] ["Morph the πœ‘-expression"] - - it "hands the top formation back untouched under the default locator" $ - withStdin "[[ D> 01- ]]" $ - testCLISucceeded ["morph", "--flat", "--hide-rho"] ["⟦ Ξ” ‍ 01- ⟧"] - - it "stops at the bare saturated Ξ»-formation" $ - withAtoms $ \atoms -> - withStdin chained $ - testCLISucceeded - ["morph", atoms, "--locator=Q.@", "--sweet", "--hide-rho", "--flat"] - ["⟦ x ↦ 7, Ξ» ‍ L_number_plus ⟧"] - - -- The same term under 𝔻, which insists on bytes and fires what 𝕄 left bare - it "leaves to dataize the firing that takes the same term to bytes" $ - withAtoms $ \atoms -> - withStdin chained $ - testCLISucceeded ["dataize", atoms] ["40-32-00-00-00-00-00-00"] - - -- 'mf' hands a formation back as it is, so '--locator' is how one aims 𝕄 at - -- a subterm worth navigating: here it resolves Ξ¦ against the universe and - -- peels the dispatch through 𝒩 - it "morphs the subterm --locator aims at" $ - withStdin "[[ ex -> Q.x, x -> [[ D> 42- ]] ]]" $ - testCLISucceeded ["morph", "--locator=Q.ex", "--flat", "--hide-rho"] ["⟦ Ξ” ‍ 42- ⟧"] - - -- 𝕄 is total and 𝔻 is not: where the derivation dies, 𝕄 answers βŠ₯ ('xi' - -- here) and the run succeeds, while 𝔻 has no bytes to give and fails - it "prints βŠ₯ instead of failing the run" $ - withStdin "[[ x -> $ ]]" $ - testCLISucceeded ["morph", "--locator=Q.x"] ["βŠ₯"] - - it "fails to dataize what it morphs to βŠ₯" $ - withStdin "[[ x -> $ ]]" $ - testCLIFailed ["dataize", "--locator=Q.x"] ["terminator βŠ₯"] - - -- The chain carries the spine: the morphing rules that reduced the term - -- ('maa', then the terminal 'mf') with the normalization steps they spliced - -- in ('alpha', 'copy'). The 'ml' firing of the inner call is not there by - -- design β€” it happens in a side premise, which reduces on a chain of its - -- own and discards it - it "prints the chain of morphing steps with --sequence" $ - withAtoms $ \atoms -> - withStdin chained $ - testCLISucceeded - ["morph", atoms, "--locator=Q.@", "--sequence", "--headers", "--sweet", "--hide-rho", "--flat"] - [ "Rule 'maa'" - , "Rule 'alpha'" - , "Rule 'copy'" - , "Rule 'mf'" - , "⟦ x ↦ 7, Ξ» ‍ L_number_plus ⟧" - ] - - it "does not print the result with --quiet" $ - withStdin "[[ D> 01- ]]" $ - testCLISucceeded ["morph", "--quiet"] [] - - it "records the atoms it fires with --evaluations" $ - withAtoms $ \atoms -> - withTempFile "evaluationsXXXXXX.txt" $ \(path, stream) -> do - hClose stream - withStdin chained $ - testCLISucceeded ["morph", atoms, "--locator=Q.@", "--evaluations=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] - records <- readUtf8 path - lines records `shouldBe` ["L_number_plus\t⟦ x ↦ 6 ⟧\t11"] - - it "saves morphing steps to dir with --steps-dir" $ - withAtoms $ \atoms -> - withTempDirectory "phino-steps-morph" $ \dir -> - withStdin chained $ do - testCLISucceeded - ["morph", atoms, "--locator=Q.@", "--steps-dir=" ++ dir, "--sweet", "--hide-rho", "--flat"] - ["⟦ x ↦ 7, Ξ» ‍ L_number_plus ⟧"] - steps <- sort <$> listDirectory dir - steps `shouldBe` map (\n -> printf "%05d.phi" (n :: Int)) [1 .. length steps] - length steps `shouldSatisfy` (> 0) - - it "accepts --seed, --shuffle and --depth-sensitive" $ - withStdin "[[ D> 01- ]]" $ - testCLISucceeded ["morph", "--seed=7", "--shuffle", "--depth-sensitive", "--flat", "--hide-rho"] ["⟦ Ξ” ‍ 01- ⟧"] - - -- The division 𝔻 cannot finish, whatever '--max-steps' it is given (#1052), - -- is no work at all for 𝕄: the term is already a formation, so 'mf' hands - -- it back and the atom is never fired - it "returns the Ξ»-formation dataize cannot finish on" $ - withStdin "⟦ @ ↦ ⟦ Ξ» ‍ L_number_div, ρ ↦ ⟦ Ξ” ‍ 40-45-00-00-00-00-00-00 ⟧, x ↦ ⟦ Ξ” ‍ 40-00-00-00-00-00-00-00 ⟧ ⟧ ⟧" $ - testCLISucceeded - ["morph", "--locator=Q.@", "--max-steps=40", "--flat", "--hide-rho"] - ["⟦ Ξ» ‍ L_number_div"] - - -- '--max-steps' bounds the 𝕄 recursion just as it bounds the 𝕄/𝔻 one - it "fails once the --max-steps budget is spent" $ - withStdin chained $ - testCLIFailed - ["morph", "--locator=Q.@", "--max-steps=3"] - ["[ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=3"] - - -- '--partial' parks a spent 𝕄 budget the same way it parks a stuck atom: - -- the answer is the term the walk had reached, dispatch intact (#1078) - it "parks the spent budget as a residual with --partial" $ - withStdin "⟦ Ο† ↦ 5.gt(Ξ¦.nan) ⟧" $ - testCLISucceeded - ["morph", "--locator=Q.@", "--max-steps=10", "--partial", "--flat", "--hide-rho", "--sweet"] - ["5.gt( Ξ¦.nan )"] - - -- 𝕄 never fires a bare Ξ»-formation, so only the atoms sitting under a - -- dispatch ('ml') can get stuck; '--partial' parks them exactly as under 𝔻 - describe "--partial" $ do - let stuck = "[[ @ -> [[ L> Sym_arg_0 ]].foo ]]" - it "fails on an atom that cannot fire without the flag" $ - withStdin stuck $ - testCLIFailed ["morph", "--locator=Q.@"] ["Atom 'Sym_arg_0' does not exist"] - - it "prints the residue with the stuck application intact and exits successfully" $ - withStdin stuck $ - testCLISucceeded - ["morph", "--locator=Q.@", "--partial", "--flat", "--hide-rho"] - ["⟦ Ξ» ‍ Sym_arg_0 ⟧.foo"] - - -- 𝕄 stops at the first formation and hands its bindings back as they were - -- written, so a program whose parts nothing demands is never reduced; - -- '--deep' enters every binding and finishes what 'mf' left, while what no - -- atom touched keeps its name and the answer stays a program (#1124) - describe "--deep" $ do - let program = - "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, \ - \number(Ο†) -> [[ times(x) -> [[ L> L_number_times ]] ]], \ - \bar(x) -> [[ L> L_bar ]], \ - \demo -> [[ foo -> [[ n -> 3, @ -> Q.bar( $.n.times( 5 ).times( 7 ) ) ]] ]] ]]" - it "answers the formation as it was written without the flag" $ - withAtoms $ \atoms -> - withStdin program $ - testCLISucceeded - ["morph", atoms, "--inside=Q.demo.foo", "--sweet", "--hide-rho", "--flat"] - ["⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( n.times( 5 ).times( 7 ) ) ⟧"] - - -- 'L_bar' is not in the registry, so the call to it stays as written and - -- keeps its name, while the arithmetic in the argument nothing demands - -- folds into the number it makes - it "reduces every binding it can and leaves the rest in place" $ - withAtoms $ \atoms -> - withStdin program $ - testCLISucceeded - ["morph", atoms, "--deep", "--inside=Q.demo.foo", "--sweet", "--hide-rho", "--flat"] - ["⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( 105 ) ⟧"] - - -- The same term the run above stops at as a bare Ξ»-formation: 'mf' leaves - -- it to 𝔻, and the walk fires it instead of demanding bytes - it "fires the bare saturated Ξ»-formation mf hands back" $ - withAtoms $ \atoms -> - withStdin chained $ - testCLISucceeded - ["morph", atoms, "--deep", "--locator=Q.@", "--sweet", "--hide-rho", "--flat"] - ["18"] - - -- The default locator walks the whole program: the method table of the - -- object model keeps every one of its Ξ»-formations, since not one of them - -- is saturated, while the one place that can be computed is - it "keeps the object model intact while it folds the program" $ - withAtoms $ \atoms -> - withStdin program $ - testCLISucceeded - ["morph", atoms, "--deep", "--sweet", "--hide-rho", "--flat"] - [ "number(Ο†) ↦ ⟦ times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧" - , "demo ↦ ⟦ foo ↦ ⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( 105 ) ⟧ ⟧" - ] - - it "keeps a binding whose spine got stuck with --partial" $ - withStdin "[[ x -> [[ L> Sym_arg_0 ]].foo ]]" $ - testCLISucceeded - ["morph", "--deep", "--partial", "--sweet", "--hide-rho", "--flat"] - ["⟦ x ↦ ⟦ Ξ» ‍ Sym_arg_0 ⟧.foo ⟧"] - - it "fails on that same spine without --partial" $ - withStdin "[[ x -> [[ L> Sym_arg_0 ]].foo ]]" $ - testCLIFailed ["morph", "--deep"] ["Atom 'Sym_arg_0' does not exist"] - - describe "fails" $ do - it "with --output != latex and --nonumber" $ - withStdin "" $ - testCLIFailed - ["morph", "--nonumber", "--output=xmir"] - ["The --nonumber option can stay together with --output=latex only"] - - it "with --evaluations and --output != phi" $ - withStdin "[[ D> 01- ]]" $ - testCLIFailed - ["morph", "--evaluations=evaluations.txt", "--output=latex"] - ["The --evaluations option can stay together with --output=phi only"] - - it "with --show used more than once" $ - withStdin "" $ - testCLIFailed - ["morph", "--show=Q.a", "--show=Q.b"] - ["The option --show can be used only once"] - - it "with wrong --locator option" $ - withStdin "" $ - testCLIFailed - ["morph", "--locator=Q.x(Q.y)"] - ["[ERROR]:", "Only dispatch expression started with Ξ¦ (or Q) can be used in --locator"] - - describe "explain" $ do - it "prints help" $ - testCLISucceeded - ["explain", "--help"] - ["Explain built-in morphing rules", "Explain built-in dataization rules", "Explain built-in contextualization rules"] - - it "explains single rule" $ - testCLISucceeded - ["explain", "--rule=resources/normalize/copy.yaml"] - [ unlines - [ "\\phinoNormalizationRule{copy}" - , " { [[ B_1, \\tau_1 -> ?, B_2 ]] ( \\tau_1 -> k_1 ) }" - , " { [[ B_1, \\tau_1 -> k_1, B_2 ]] }" - , " { }" - , " { }" - ] - ] - - it "explains single rule with a label" $ - testCLISucceeded - ["explain", "--rule=test-resources/cli/labeled.yaml"] - [ unlines - [ "\\phinoNormalizationRule[\\lambda]{copy}" - , " { [[ B_1, \\tau_1 -> ?, B_2 ]] ( \\tau_1 -> k_1 ) }" - , " { [[ B_1, \\tau_1 -> k_1, B_2 ]] }" - , " { }" - , " { }" - ] - ] - - it "explains multiple rules" $ - testCLISucceeded - ["explain", "--rule=resources/normalize/copy.yaml", "--rule=resources/normalize/alpha.yaml"] - ["\\phinoNormalizationRule{copy}", "\\phinoNormalizationRule{alpha}"] - - it "reproduces the same shuffle order for the same --seed" $ do - let args = - [ "explain" - , "--shuffle" - , "--seed=42" - , rule "swap-a.yaml" - , rule "swap-b.yaml" - ] - (firstRun, _) <- withStdout (runCLI args) - (secondRun, _) <- withStdout (runCLI args) - firstRun `shouldBe` secondRun - - it "accepts --seed flag" $ - testCLISucceeded - ["explain", "--seed=7", "--normalize"] - ["\\phinoNormalizationRule{alpha}"] - - it "explains normalization rules" $ - testCLISucceeded - ["explain", "--normalize"] - [ unlines - [ "\\phinoNormalizationRule{alpha}" - , " { [[ B_1, \\tau_1 -> ?, B_2 ]] ( \\phiTerminal{\\alpha_{i1}} -> e_1 ) }" - , " { [[ B_1, \\tau_1 -> ?, B_2 ]] ( \\tau_1 -> e_1 ) }" - , " { i_1 = \\vert \\overline{ B_1 } \\vert \\;\\text{and}\\; \\tau_1 \\not= \\phiTerminal{\\rho} }" - , " { }" - , "\\phinoNormalizationRule{amiss}" - , " { [[ B_1 ]] ( \\phiTerminal{\\alpha_{i1}} -> e ) }" - , " { T }" - , " { \\vert \\overline{ B_1 } \\vert \\leq i_1 }" - , " { }" - , "\\phinoNormalizationRule{copy}" - , " { [[ B_1, \\tau_1 -> ?, B_2 ]] ( \\tau_1 -> k_1 ) }" - , " { [[ B_1, \\tau_1 -> k_1, B_2 ]] }" - , " { }" - , " { }" - , "\\phinoNormalizationRule{dc}" - , " { T ( \\tau -> e ) }" - , " { T }" - , " { }" - , " { }" - , "\\phinoNormalizationRule{dca}" - , " { T ( \\phiTerminal{\\alpha_{i}} -> e ) }" - , " { T }" - , " { }" - , " { }" - , "\\phinoNormalizationRule{dd}" - , " { T . \\tau }" - , " { T }" - , " { }" - , " { }" - , "\\phinoNormalizationRule{dl}" - , " { [[ B_1, L> F, B_2 ]] }" - , " { T }" - , " { D \\in B_1 \\;\\text{or}\\; D \\in B_2 }" - , " { }" - , "\\phinoNormalizationRule{dot}" - , " { [[ B_1, \\tau_1 -> n_1, B_2 ]] . \\tau_1 }" - , " { e_1 ( \\phiTerminal{\\rho} -> [[ B_1, \\tau_1 -> n_1, B_2 ]] ) }" - , " { }" - , " { \\phinoContextualize{ n_1 }{ [[ B_1, B_2 ]] }{ e_1 } }" - , "\\phinoNormalizationRule{miss}" - , " { [[ B_1 ]] ( \\tau_1 -> e ) }" - , " { T }" - , " { \\tau_1 \\notin B_1 }" - , " { }" - , "\\phinoNormalizationRule{null}" - , " { [[ B_1, \\tau_1 -> ?, B_2 ]] . \\tau_1 }" - , " { T }" - , " { }" - , " { }" - , "\\phinoNormalizationRule{over}" - , " { [[ B_1, \\tau_1 -> e_1, B_2 ]] ( \\tau_1 -> e_2 ) }" - , " { T }" - , " { \\tau_1 \\not= \\phiTerminal{\\rho} }" - , " { }" - , "\\phinoNormalizationRule{overa}" - , " { [[ B_1, \\tau_1 -> e_1, B_2 ]] ( \\phiTerminal{\\alpha_{i1}} -> e_2 ) }" - , " { T }" - , " { i_1 = \\vert \\overline{ B_1 } \\vert \\;\\text{and}\\; \\tau_1 \\not= \\phiTerminal{\\rho} }" - , " { }" - , "\\phinoNormalizationRule{stay}" - , " { [[ B_1, \\phiTerminal{\\rho} -> e_1, B_2 ]] ( \\phiTerminal{\\rho} -> e_2 ) }" - , " { [[ B_1, \\phiTerminal{\\rho} -> e_1, B_2 ]] }" - , " { }" - , " { }" - , "\\phinoNormalizationRule{stop}" - , " { [[ B_1 ]] . \\tau_1 }" - , " { T }" - , " { \\tau_1 \\notin B_1 \\;\\text{and}\\; @ \\notin B_1 \\;\\text{and}\\; L \\notin B_1 }" - , " { }" - ] - ] - - it "explains morphing rules" $ - testCLISucceeded - ["explain", "--morph"] - [ unlines - [ "\\begin{phinoMorphingInference}" - , " \\phinoName{dead}" - , " \\phinoConclusion{ \\phinoMorph{ T }{ e_0 }{ s }{ T }{ s } }" - , "\\end{phinoMorphingInference}" - , "\\begin{phinoMorphingInference}" - , " \\phinoName{ma}" - , " \\phinoPremise{ \\phinoMorph{ n_0 }{ e_0 }{ s_1 }{ n_1 }{ s_2 } }" - , " \\phinoPremise{ \\phinoNormalize{ n_1 ( \\tau_0 -> k_1 ) }{ n_2 } }" - , " \\phinoPremise{ \\phinoMorph{ n_2 }{ e_0 }{ s_2 }{ n_3 }{ s_3 } }" - , " \\phinoConclusion{ \\phinoMorph{ n_0 ( \\tau_0 -> k_1 ) }{ e_0 }{ s_1 }{ n_3 }{ s_3 } }" - , "\\end{phinoMorphingInference}" - , "\\begin{phinoMorphingInference}" - , " \\phinoName{maa}" - , " \\phinoPremise{ \\phinoMorph{ n_0 }{ e_0 }{ s_1 }{ n_1 }{ s_2 } }" - , " \\phinoPremise{ \\phinoNormalize{ n_1 ( \\phiTerminal{\\alpha_{i0}} -> k_1 ) }{ n_2 } }" - , " \\phinoPremise{ \\phinoMorph{ n_2 }{ e_0 }{ s_2 }{ n_3 }{ s_3 } }" - , " \\phinoConclusion{ \\phinoMorph{ n_0 ( \\phiTerminal{\\alpha_{i0}} -> k_1 ) }{ e_0 }{ s_1 }{ n_3 }{ s_3 } }" - , "\\end{phinoMorphingInference}" - , "\\begin{phinoMorphingInference}" - , " \\phinoName{maad}" - , " \\phinoCondition{ \\phinoNotAbsolute{ n_1 } }" - , " \\phinoPremise{ \\phinoMorph{ T }{ e_0 }{ s_1 }{ n_2 }{ s_2 } }" - , " \\phinoConclusion{ \\phinoMorph{ n ( \\phiTerminal{\\alpha_{i}} -> n_1 ) }{ e_0 }{ s_1 }{ n_2 }{ s_2 } }" - , "\\end{phinoMorphingInference}" - , "\\begin{phinoMorphingInference}" - , " \\phinoName{mad}" - , " \\phinoCondition{ \\phinoNotAbsolute{ n_1 } }" - , " \\phinoPremise{ \\phinoMorph{ T }{ e_0 }{ s_1 }{ n_2 }{ s_2 } }" - , " \\phinoConclusion{ \\phinoMorph{ n ( \\tau -> n_1 ) }{ e_0 }{ s_1 }{ n_2 }{ s_2 } }" - , "\\end{phinoMorphingInference}" - , "\\begin{phinoMorphingInference}" - , " \\phinoName{md}" - , " \\phinoCondition{ \\phinoNotFormation{ n_0 } }" - , " \\phinoPremise{ \\phinoMorph{ n_0 }{ e_0 }{ s_1 }{ n_1 }{ s_2 } }" - , " \\phinoPremise{ \\phinoNormalize{ n_1 . \\tau_0 }{ n_2 } }" - , " \\phinoPremise{ \\phinoMorph{ n_2 }{ e_0 }{ s_2 }{ n_3 }{ s_3 } }" - , " \\phinoConclusion{ \\phinoMorph{ n_0 . \\tau_0 }{ e_0 }{ s_1 }{ n_3 }{ s_3 } }" - , "\\end{phinoMorphingInference}" - , "\\begin{phinoMorphingInference}" - , " \\phinoName{mf}" - , " \\phinoConclusion{ \\phinoMorph{ [[ B_0 ]] }{ e_0 }{ s }{ [[ B_0 ]] }{ s } }" - , "\\end{phinoMorphingInference}" - , "\\begin{phinoMorphingInference}" - , " \\phinoName{mg}" - , " \\phinoPremise{ \\phinoMorph{ T }{ Q }{ s_1 }{ n_1 }{ s_2 } }" - , " \\phinoConclusion{ \\phinoMorph{ Q }{ Q }{ s_1 }{ n_1 }{ s_2 } }" - , "\\end{phinoMorphingInference}" - , "\\begin{phinoMorphingInference}" - , " \\phinoName{ml}" - , " \\phinoLabel{\\lambda}" - , " \\phinoPremise{ \\phinoEvaluate{ [[ B_1, L> F_0, B_2 ]] }{ e_0 }{ s_1 }{ n_1 }{ s_2 } }" - , " \\phinoPremise{ \\phinoNormalize{ n_1 . \\tau_0 }{ n_2 } }" - , " \\phinoPremise{ \\phinoMorph{ n_2 }{ e_0 }{ s_2 }{ n_3 }{ s_3 } }" - , " \\phinoConclusion{ \\phinoMorph{ [[ B_1, L> F_0, B_2 ]] . \\tau_0 }{ e_0 }{ s_1 }{ n_3 }{ s_3 } }" - , "\\end{phinoMorphingInference}" - , "\\begin{phinoMorphingInference}" - , " \\phinoName{mphi}" - , " \\phinoLabel{\\varphi}" - , " \\phinoCondition{ @ \\in B_0 \\;\\text{and}\\; \\tau_0 \\notin B_0 \\;\\text{and}\\; L \\notin B_0 }" - , " \\phinoPremise{ \\phinoNormalize{ [[ B_0 ]] . @ . \\tau_0 }{ n_1 } }" - , " \\phinoPremise{ \\phinoMorph{ n_1 }{ e_0 }{ s_1 }{ n_2 }{ s_2 } }" - , " \\phinoConclusion{ \\phinoMorph{ [[ B_0 ]] . \\tau_0 }{ e_0 }{ s_1 }{ n_2 }{ s_2 } }" - , "\\end{phinoMorphingInference}" - , "\\begin{phinoMorphingInference}" - , " \\phinoName{universe}" - , " \\phinoLabel{\\Phi}" - , " \\phinoCondition{ e_0 \\not= Q }" - , " \\phinoPremise{ \\phinoNormalize{ e_0 }{ n_1 } }" - , " \\phinoPremise{ \\phinoMorph{ n_1 }{ e_0 }{ s_1 }{ n_2 }{ s_2 } }" - , " \\phinoConclusion{ \\phinoMorph{ Q }{ e_0 }{ s_1 }{ n_2 }{ s_2 } }" - , "\\end{phinoMorphingInference}" - , "\\begin{phinoMorphingInference}" - , " \\phinoName{xi}" - , " \\phinoPremise{ \\phinoMorph{ T }{ e_0 }{ s_1 }{ n_1 }{ s_2 } }" - , " \\phinoConclusion{ \\phinoMorph{ \\phiTerminal{\\xi} }{ e_0 }{ s_1 }{ n_1 }{ s_2 } }" - , "\\end{phinoMorphingInference}" - ] - ] - - it "explains dataization rules" $ - testCLISucceeded - ["explain", "--dataize"] - [ unlines - [ "\\begin{phinoDataizationInference}" - , " \\phinoName{box}" - , " \\phinoCondition{ [ D \\char44{} L ] \\cap \\lparen B_1 \\cup B_2 \\rparen = \\emptyset }" - , " \\phinoPremise{ \\phinoContextualize{ e_1 }{ [[ B_1, @ -> e_1, B_2 ]] }{ e_2 } }" - , " \\phinoPremise{ \\phinoNormalize{ e_2 }{ n_1 } }" - , " \\phinoPremise{ \\phinoDataize{ n_1 }{ e_0 }{ s_1 }{ \\delta_0 }{ s_2 } }" - , " \\phinoConclusion{ \\phinoDataize{ [[ B_1, @ -> e_1, B_2 ]] }{ e_0 }{ s_1 }{ \\delta_0 }{ s_2 } }" - , "\\end{phinoDataizationInference}" - , "\\begin{phinoDataizationInference}" - , " \\phinoName{delta}" - , " \\phinoLabel{\\Delta}" - , " \\phinoConclusion{ \\phinoDataize{ [[ B_1, D> \\delta_0, B_2 ]] }{ e_0 }{ s }{ \\delta_0 }{ s } }" - , "\\end{phinoDataizationInference}" - , "\\begin{phinoDataizationInference}" - , " \\phinoName{fire}" - , " \\phinoPremise{ \\phinoEvaluate{ [[ B_1, L> F_0, B_2 ]] }{ e_0 }{ s_1 }{ n_1 }{ s_2 } }" - , " \\phinoPremise{ \\phinoDataize{ n_1 }{ e_0 }{ s_2 }{ \\delta_0 }{ s_3 } }" - , " \\phinoConclusion{ \\phinoDataize{ [[ B_1, L> F_0, B_2 ]] }{ e_0 }{ s_1 }{ \\delta_0 }{ s_3 } }" - , "\\end{phinoDataizationInference}" - , "\\begin{phinoDataizationInference}" - , " \\phinoName{none}" - , " \\phinoCondition{ [ D \\char44{} L \\char44{} @ ] \\cap B_0 = \\emptyset }" - , " \\phinoPremise{ \\phinoDataize{ T }{ e_0 }{ s_1 }{ \\delta_0 }{ s_2 } }" - , " \\phinoConclusion{ \\phinoDataize{ [[ B_0 ]] }{ e_0 }{ s_1 }{ \\delta_0 }{ s_2 } }" - , "\\end{phinoDataizationInference}" - , "\\begin{phinoDataizationInference}" - , " \\phinoName{norm}" - , " \\phinoCondition{ \\phinoNotFormation{ n_0 } \\;\\text{and}\\; n_0 \\not= T }" - , " \\phinoPremise{ \\phinoMorph{ n_0 }{ e_0 }{ s_1 }{ n_1 }{ s_2 } }" - , " \\phinoPremise{ \\phinoDataize{ n_1 }{ e_0 }{ s_2 }{ \\delta_0 }{ s_3 } }" - , " \\phinoConclusion{ \\phinoDataize{ n_0 }{ e_0 }{ s_1 }{ \\delta_0 }{ s_3 } }" - , "\\end{phinoDataizationInference}" - ] - ] - - it "explains contextualization rules" $ - testCLISucceeded - ["explain", "--contextualize"] - [ unlines - [ "\\begin{phinoContextualizationInference}" - , " \\phinoName{ca}" - , " \\phinoPremise{ \\phinoContextualize{ n_0 }{ k_0 }{ n_1 } }" - , " \\phinoPremise{ \\phinoContextualize{ e_1 }{ k_0 }{ n_2 } }" - , " \\phinoConclusion{ \\phinoContextualize{ n_0 ( \\tau_0 -> e_1 ) }{ k_0 }{ n_1 ( \\tau_0 -> n_2 ) } }" - , "\\end{phinoContextualizationInference}" - , "\\begin{phinoContextualizationInference}" - , " \\phinoName{caa}" - , " \\phinoPremise{ \\phinoContextualize{ n_0 }{ k_0 }{ n_1 } }" - , " \\phinoPremise{ \\phinoContextualize{ e_1 }{ k_0 }{ n_2 } }" - , " \\phinoConclusion{ \\phinoContextualize{ n_0 ( \\phiTerminal{\\alpha_{i0}} -> e_1 ) }{ k_0 }{ n_1 ( \\phiTerminal{\\alpha_{i0}} -> n_2 ) } }" - , "\\end{phinoContextualizationInference}" - , "\\begin{phinoContextualizationInference}" - , " \\phinoName{cd}" - , " \\phinoPremise{ \\phinoContextualize{ n_0 }{ k_0 }{ n_1 } }" - , " \\phinoConclusion{ \\phinoContextualize{ n_0 . \\tau_0 }{ k_0 }{ n_1 . \\tau_0 } }" - , "\\end{phinoContextualizationInference}" - , "\\begin{phinoContextualizationInference}" - , " \\phinoName{cf}" - , " \\phinoConclusion{ \\phinoContextualize{ [[ B_0 ]] }{ k_0 }{ [[ B_0 ]] } }" - , "\\end{phinoContextualizationInference}" - , "\\begin{phinoContextualizationInference}" - , " \\phinoName{cg}" - , " \\phinoConclusion{ \\phinoContextualize{ Q }{ k_0 }{ Q } }" - , "\\end{phinoContextualizationInference}" - , "\\begin{phinoContextualizationInference}" - , " \\phinoName{ct}" - , " \\phinoConclusion{ \\phinoContextualize{ T }{ k_0 }{ T } }" - , "\\end{phinoContextualizationInference}" - , "\\begin{phinoContextualizationInference}" - , " \\phinoName{cxi}" - , " \\phinoConclusion{ \\phinoContextualize{ \\phiTerminal{\\xi} }{ k_0 }{ k_0 } }" - , "\\end{phinoContextualizationInference}" - ] - ] - - it "fails with no rules specified" $ - testCLIFailed - ["explain"] - ["Either --rule, --normalize, --morph, --dataize or --contextualize must be specified"] - - it "fails when more than one rule set is specified" $ - testCLIFailed - ["explain", "--morph", "--dataize"] - ["Only one of --morph, --dataize or --contextualize can be specified"] - - it "allows --normalize together with --rule" $ - testCLISucceeded - ["explain", "--normalize", "--rule=resources/normalize/copy.yaml"] - ["\\phinoNormalizationRule{copy}"] - - it "allows --shuffle together with --morph" $ - testCLISucceeded - ["explain", "--morph", "--shuffle"] - ["\\begin{phinoMorphingInference}"] - - it "writes to target file" $ - bracket - ( do - tmp <- getTemporaryDirectory - stamp <- getPOSIXTime - let dir = tmp ("phino-test-" ++ show (floor stamp :: Integer)) - createDirectoryIfMissing True dir - pure (dir "explain.tex", dir) - ) - (\(_, dir) -> removeDirectoryRecursive dir) - ( \(path, _) -> do - testCLISucceeded ["explain", "--normalize", printf "--target=%s" path] [] - content <- readFile path - _ <- evaluate (length content) - content `shouldContain` "\\phinoNormalizationRule{alpha}" - ) - - describe "merge" $ do - it "prints help" $ - testCLISucceeded ["merge", "--help"] ["Paths to input files"] - - it "merges single expression" $ - testCLISucceeded - ["merge", resource "desugar.phi", "--sweet", "--flat"] - ["⟦ foo ↦ x ⟧"] - - it "merges EO expressions" $ - testCLISucceeded - ["merge", "--sweet", resource "number.phi", resource "bytes.phi", resource "string.phi", "--margin=25"] - [ unlines - [ "⟦" - , " org ↦ ⟦" - , " eolang ↦ ⟦" - , " number(Ο†) ↦ ⟦⟧," - , " bytes(data) ↦ ⟦⟧," - , " string(Ο†) ↦ ⟦⟧," - , " Ξ» ‍ Package" - , " ⟧," - , " Ξ» ‍ Package" - , " ⟧" - , "⟧" - ] - ] - - it "fails on merging non formations" $ - testCLIFailed - ["merge", resource "dispatch.phi", resource "number.phi"] - ["Invalid expression format, only expressions with top level formations are supported for 'merge' command"] - - it "fails on merging conflicted bindings" $ - testCLIFailed - ["merge", resource "foo.phi", resource "desugar.phi"] - ["Can't merge two bindings, conflict found"] - - it "fails on merging empty list of expressions" $ - testCLIFailed - ["merge"] - ["At least one input file must be specified for 'merge' command"] - - it "merges and prints as XMIR, with the listing rendered from the merged expression" $ - testCLISucceeded - ["merge", resource "desugar.phi", "--output=xmir"] - ["", "⟦ foo ↦ ΞΎ.x, ρ ↦ βˆ… ⟧", ""] - - it "reproduces the same output for the same --seed" $ do - let args = - [ "merge" - , "--seed=42" - , "--sweet" - , resource "number.phi" - , resource "bytes.phi" - ] - (firstRun, _) <- withStdout (runCLI args) - (secondRun, _) <- withStdout (runCLI args) - firstRun `shouldBe` secondRun - - describe "match" $ do - it "prints help" $ - testCLISucceeded - ["match", "--help"] - ["Pattern expression to match against", "Predicate for matched substitutions"] - - it "takes from stdin" $ - withStdin "[[]]" $ - testCLISucceeded ["match", "--log-level=debug"] ["[DEBUG]"] - - it "takes from file" $ - testCLISucceeded ["match", "test-resources/cli/foo.phi", "--log-level=debug"] ["[DEBUG]"] - - it "does not print substitutions without pattern" $ - withStdin "[[]]" $ - testCLISucceeded ["match", "--log-level=debug"] ["[DEBUG]: The --pattern is not provided, no substitutions are built"] - - it "reproduces the same output for the same --seed" $ do - dir <- getTemporaryDirectory - let file = dir ++ "/phino-match-seed-test.phi" - writeFile file "[[ x -> Q.x, y -> Q.y, z -> Q.z ]]" - let args = - [ "match" - , "--seed=42" - , "--sweet" - , "--flat" - , "--pattern=Q.!t" - , file - ] - (firstRun, _) <- withStdout (runCLI args) - (secondRun, _) <- withStdout (runCLI args) - firstRun `shouldBe` secondRun - removeFile file - - it "prints many substitutions" $ - withStdin "[[ x -> Q.x, y -> Q.y ]]" $ - testCLISucceeded ["match", "--pattern=Q.!t"] ["t >> x\n------\nt >> y"] - - it "builds substitutions with conditions" $ - withStdin "[[ x -> Q.y ]].x" $ - testCLISucceeded - ["match", "--pattern=[[ !t1 -> Q.y, !B1 ]].!t1", "--when=eq(length(!B1),1)"] - ["B1 >> ⟦ ρ ↦ βˆ… ⟧\nt1 >> x"] - - it "builds with condition from file" $ - testCLISucceeded - ["match", "--pattern=[[ !B1 ]]", "--when=eq(length(!B1),2)", "test-resources/cli/foo.phi"] +import Fixtures (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.Exit (ExitCode (ExitFailure)) +import System.FilePath (()) +import System.IO +import Test.Hspec +import Text.Printf (printf) + +withStdin :: String -> IO a -> IO a +withStdin input action = + bracket (openTempFile "." "stdinXXXXXX.tmp") cleanup $ \(filePath, h) -> do + hSetEncoding h utf8 + hPutStr h input + hFlush h + hClose h + withFile filePath ReadMode $ \hIn -> do + hSetEncoding hIn utf8 + bracket (hDuplicate stdin) restoreStdin $ \_ -> do + hDuplicateTo hIn stdin + hSetEncoding stdin utf8 + action + where + restoreStdin orig = hDuplicateTo orig stdin >> hClose orig + cleanup (fp, _) = removeFile fp + +withStdout :: IO a -> IO (String, a) +withStdout action = + bracket + (openTempFile "." "stdoutXXXXXX.tmp") + cleanup + ( \(path, hTmp) -> do + hSetEncoding hTmp utf8 + oldOut <- hDuplicate stdout + oldErr <- hDuplicate stderr + hDuplicateTo hTmp stdout + hDuplicateTo hTmp stderr + + result <- + action `finally` do + hFlush stdout + hFlush stderr + hDuplicateTo oldOut stdout >> hClose oldOut + hDuplicateTo oldErr stderr >> hClose oldErr + hClose hTmp + + captured <- readFile path + _ <- evaluate (length captured) + return (captured, result) + ) + where + cleanup (fp, _) = removeFile fp + +withTempFile :: String -> ((FilePath, Handle) -> IO a) -> IO a +withTempFile pattern = + bracket + (openTempFile "." pattern) + (\(path, _) -> removeFile path) + +withTempFileContent :: String -> String -> (FilePath -> IO a) -> IO a +withTempFileContent pattern content action = + withTempFile pattern $ \(path, h) -> do + hPutStr h content + hClose h + action path + +-- A fresh, uniquely-named directory under the system temp directory, removed +-- afterwards even when the action throws (an assertion failure included), so a +-- red run never leaves it behind for the next run to depend on. +withTempDirectory :: String -> (FilePath -> IO a) -> IO a +withTempDirectory prefix action = do + tmp <- getTemporaryDirectory + stamp <- getPOSIXTime + let dir = tmp (prefix ++ "-" ++ show (round (stamp * 1000000) :: Integer)) + bracket (pure dir) removePathForcibly action + +testCLI' :: [String] -> [String] -> Either ExitCode () -> Expectation +testCLI' args outputs exit = do + (out, result) <- withStdout (try (runCLI args) :: IO (Either ExitCode ())) + if null outputs + then + unless (null out) $ + expectationFailure ("Expected that output is empty, but got:\n" ++ out) + else + forM_ + outputs + ( \output -> + unless (output `isInfixOf` out) $ + expectationFailure + ("Expected that output contains:\n" ++ output ++ "\nbut got:\n" ++ out) + ) + result `shouldBe` exit + +testCLISucceeded :: [String] -> [String] -> Expectation +testCLISucceeded args outputs = testCLI' args outputs (Right ()) + +-- phino implements no Ξ» function of its own, so a case that needs one to +-- answer hands the fixture file to the command as '--symbolic' (see +-- 'Fixtures'). +symbolic :: String +symbolic = "--symbolic=" ++ lambdasFile + +testCLIFailed :: [String] -> [String] -> Expectation +testCLIFailed args outputs = testCLI' args outputs (Left (ExitFailure 1)) + +resource :: String -> String +resource file = "test-resources/cli/expressions/" <> file + +rule :: String -> String +rule file = "--rule=test-resources/cli/rules/" <> file + +spec :: Spec +spec = do + it "prints version" $ + testCLISucceeded ["--version"] [showVersion version] + + it "prints help" $ + testCLISucceeded + ["--help"] + ["Phino - CLI Manipulator of πœ‘-Calculus Expressions", "Usage:"] + + describe "--pin" $ + forM_ + [ + ( "succeeds when --pin matches actual version" + , ["--pin=" ++ showVersion version, "rewrite", "--sweet"] + , testCLISucceeded + , ["⟦⟧"] + ) + , + ( "fails when --pin doesn't match actual version" + , ["--pin=9.9.9.9", "rewrite"] + , testCLIFailed + , ["Version mismatch: --pin requires '9.9.9.9', but this is phino " ++ showVersion version] + ) + , + ( "fails when --pin is empty" + , ["--pin=", "rewrite"] + , testCLIFailed + , ["Version mismatch: --pin requires ''"] + ) + ] + (\(desc, args, test, expected) -> it desc (withStdin "[[ ]]" (test args expected))) + + describe "--hide-rho" $ + forM_ + [ + ( "drops every rho binding from the default salty output" + , "[[ foo -> [[ x -> [[ ]], ^ -> $.y ]], y -> [[ ]] ]]" + , ["rewrite", "--flat", "--hide-rho"] + , ["⟦ foo ↦ ⟦ x ↦ ⟦⟧ ⟧, y ↦ ⟦⟧ ⟧"] + ) + , + ( "also drops the rho that --sweet leaves behind" + , "[[ foo -> [[ x -> [[ ]], ^ -> $.y ]], y -> [[ ]] ]]" + , ["rewrite", "--flat", "--sweet", "--hide-rho"] + , ["⟦ foo ↦ ⟦ x ↦ ⟦⟧ ⟧, y ↦ ⟦⟧ ⟧"] + ) + , + ( "keeps sweet numeric literals intact" + , "[[ a -> 42 ]]" + , ["rewrite", "--flat", "--sweet", "--hide-rho"] + , ["⟦ a ↦ 42 ⟧"] + ) + ] + (\(desc, input, args, expected) -> it desc (withStdin input (testCLISucceeded args expected))) + + it "prints debug info with --log-level=DEBUG" $ + withStdin "[[]]" $ + testCLISucceeded ["rewrite", "--log-level=DEBUG"] ["[DEBUG]:"] + + describe "--log-level accepts every named level" $ + forM_ + ["ERROR", "ERR", "error", "NONE", "none"] + ( \flagValue -> + it ("--log-level=" ++ flagValue) $ + withStdin "[[]]" $ + testCLISucceeded ["rewrite", "--log-level=" ++ flagValue] ["⟧"] + ) + + it "fails on an unrecognized --log-level value" $ + withStdin "[[]]" $ + testCLIFailed ["rewrite", "--log-level=verbose"] ["unknown log-level: verbose"] + + describe "rewriting" $ do + describe "fails" $ do + forM_ + [ ("with --input=latex", "", ["rewrite", "--input=latex"], ["The value 'latex' can't be used for '--input' option"]) + , ("with negative --log-lines", "", ["rewrite", "--log-lines=-2"], ["--log-lines must be >= -1"]) + , ("with negative --max-depth", "", ["rewrite", "--max-depth=-1"], ["--max-depth must be positive"]) + , ("with zero --max-cycles", "", ["rewrite", "--max-cycles=0"], ["--max-cycles must be positive"]) + , ("with zero --meet-length", "", ["rewrite", "--output=latex", "--meet-length=0"], ["--meet-length must be positive"]) + , + ( "with --normalize and --must=1" + , "[[ x -> [[ y -> 5 ]].y ]].x" + , ["rewrite", "--max-cycles=2", "--max-depth=1", "--normalize", "--must=1"] + , ["it's expected rewriting cycles to be in range [1], but rewriting has already reached 2"] + ) + , ("when --in-place is used without input file", "[[ ]]", ["rewrite", "--in-place"], ["--in-place requires an input file"]) + , + ( "with --output=xmir on a non-top-level expression" + , "⟦ x ↦ 1, ρ ↦ 2 ⟧" + , ["rewrite", "--output=xmir"] + , ["[ERROR]:", "its top level must be a single binding followed by ρ ↦ βˆ…"] + ) + ] + (\(desc, input, args, expected) -> it desc (withStdin input (testCLIFailed args expected))) + + it "when --in-place is used with --target" $ + withTempFile "inplaceXXXXXX.phi" $ \(path, h) -> do + hPutStr h "[[ ]]" + hClose h + testCLIFailed + ["rewrite", "--in-place", "--target=output.phi", path] + ["--in-place and --target cannot be used together"] + + it "fails when --in-place is used with a non-phi output format" $ + withTempFile "inplaceXXXXXX.phi" $ \(path, h) -> do + hPutStr h "[[ ]]" + hClose h + testCLIFailed + ["rewrite", "--in-place", "--output=latex", path] + ["--in-place can only be used together with --output=phi"] + + it "does not leak a HasCallStack backtrace into errors" $ do + (out, _) <- withStdout (try (runCLI ["rewrite", "--in-place"]) :: IO (Either ExitCode ())) + out `shouldNotContain` "HasCallStack backtrace" + out `shouldNotContain` "ExitFailure 1" + out `shouldContain` "[ERROR]:" + + it "prints optparse errors once, without a backtrace" $ do + (out, _) <- withStdout (try (runCLI ["rewrite", "--badopt"]) :: IO (Either ExitCode ())) + out `shouldNotContain` "HasCallStack backtrace" + out `shouldNotContain` "ExitFailure 1" + out `shouldContain` "[ERROR]:" + + forM_ + [ ("when --update is used without --target", "[[ ]]", ["rewrite", "--update"], ["--update requires --target"]) + , + ( "when --update is used without an input file" + , "[[ ]]" + , ["rewrite", "--update", "--target=output.phi"] + , ["--update requires an input file"] + ) + , + ( "when --update is used with --in-place" + , "[[ ]]" + , ["rewrite", "--update", "--in-place", "input.phi"] + , ["--update and --in-place cannot be used together"] + ) + , + ( "with --depth-sensitive" + , "[[ x -> \"x\"]]" + , ["rewrite", "--depth-sensitive", "--max-depth=1", "--max-cycles=1", rule "infinite.yaml"] + , ["[ERROR]: With option --depth-sensitive it's expected rewriting iterations amount does not reach the limit: --max-depth=1"] + ) + , + ( "with looping rules" + , "[[ x -> \"0\" ]]" + , ["rewrite", rule "first.yaml", rule "second.yaml", "--max-depth=1", "--max-cycles=3"] + , ["it seems rewriting is looping"] + ) + ] + (\(desc, input, args, expected) -> it desc (withStdin input (testCLIFailed args expected))) + + -- Only assert the stable parts of the parse error: phino's envelope and + -- that megaparsec reports an 'unexpected' token. The exact line:column and + -- offending token depend on megaparsec's internal try/longest-match error + -- merging, which shifts between megaparsec releases (deps are unpinned), so + -- pinning them here makes the test brittle without testing anything extra. + it "with wrong attribute and valid error message" $ + testCLIFailed + ["rewrite", resource "with-$this-attribute.phi"] + [ "[ERROR]: Couldn't parse given phi expression, cause:" + , "unexpected" + ] + + forM_ + [ + ( "with --output != latex and --nonumber" + , ["rewrite", "--nonumber", "--output=xmir"] + , ["The --nonumber option can stay together with --output=latex only"] + ) + , ("with --omit-listing and --output != xmir", ["rewrite", "--omit-listing", "--output=phi"], ["--omit-listing"]) + , ("with --omit-comments and --output != xmir", ["rewrite", "--omit-comments", "--output=phi"], ["--omit-comments"]) + , + ( "with --expression and --output != latex" + , ["rewrite", "--expression=foo", "--output=phi"] + , ["--expression option can stay together with --output=latex only"] + ) + , + ( "with --label and --output != latex" + , ["rewrite", "--label=foo", "--output=phi"] + , ["--label option can stay together with --output=latex only"] + ) + , + ( "with --compress and --output != latex" + , ["rewrite", "--compress", "--output=phi"] + , ["--compress option can stay together with --output=latex only"] + ) + , + ( "with --meet-prefix and --output != latex" + , ["rewrite", "--meet-prefix=foo", "--output=phi"] + , ["--meet-prefix option can stay together with --output=latex only"] + ) + , + ( "with wrong --hide option" + , ["rewrite", "--hide=Q.x(Q.y)"] + , ["[ERROR]: Invalid set of arguments: Only dispatch expression", "but given: Ξ¦.x( Ξ¦.y )"] + ) + , ("with many --show options", ["rewrite", "--show=Q.x.y", "--show=hello"], ["The option --show can be used only once"]) + , + ( "with wrong --show option" + , ["rewrite", "--show=Q.x(Q.y)"] + , ["[ERROR]:", "Only dispatch expression started with Ξ¦ (or Q) can be used in --show"] + ) + , ("with --show overlapping --hide", ["rewrite", "--show=Q.x", "--hide=Q.x"], ["[ERROR]:", "The --show locator 'Ξ¦.x' is also listed in --hide"]) + , ("with --meet-popularity < 0", ["rewrite", "--meet-popularity=-1"], ["[ERROR]:", "--meet-popularity must be positive"]) + , ("with --meet-popularity > 100", ["rewrite", "--meet-popularity=102"], ["[ERROR]:", "--meet-popularity must be <= 100"]) + , + ( "with --meet-popularity and output != latex" + , ["rewrite", "--meet-popularity=51", "--output=phi"] + , ["[ERROR]:", "--meet-popularity option can stay together with --output=latex only"] + ) + , + ( "with --meet-length and output != latex" + , ["rewrite", "--meet-length=4", "--output=phi"] + , ["[ERROR]:", "--meet-length option can stay together with --output=latex only"] + ) + , ("with non-dispatch --focus", ["rewrite", "--focus=Q.x(Q.y)"], ["[ERROR]"]) + , ("with --focus!=Q and --output=XMIR", ["rewrite", "--focus=Q.x", "--output=xmir"], ["[ERROR]"]) + , ("with --margin < 0", ["rewrite", "--margin=-1"], ["[ERROR]"]) + , ("with --breakpoint which does not exist across the rules", ["rewrite", "--breakpoint=hello", "--normalize"], ["[ERROR]"]) + ] + (\(desc, args, expected) -> it desc (withStdin "" (testCLIFailed args expected))) + + it "prints help" $ + testCLISucceeded + ["rewrite", "--help"] + ["Rewrite the πœ‘-expression", "--seed SEED"] + + it "accepts --seed flag" $ + withStdin "[[ x -> 5 ]]" $ + testCLISucceeded + ["rewrite", "--seed=42", "--sweet"] + ["⟦ x ↦ 5 ⟧"] + + it "defaults --seed to 0 in help" $ + testCLISucceeded + ["rewrite", "--help"] + ["default: 0"] + + it "reproduces the same shuffle order for the same --seed" $ do + let args = + [ "rewrite" + , "--shuffle" + , "--seed=42" + , "--sweet" + , "--sequence" + , "--max-depth=1" + , "--max-cycles=1" + , rule "swap-a.yaml" + , rule "swap-b.yaml" + ] + (firstRun, _) <- withStdin "[[ x -> 5 ]]" $ withStdout (runCLI args) + (secondRun, _) <- withStdin "[[ x -> 5 ]]" $ withStdout (runCLI args) + firstRun `shouldBe` secondRun + + it "fails with a non-integer --seed" $ + withStdin "[[ ]]" $ + testCLIFailed + ["rewrite", "--seed=abc"] + ["[ERROR]"] + + it "saves steps to dir with --steps-dir" $ + withTempDirectory "phino-steps" $ \dir -> + withStdin "[[ x -> \"hello\"]]" $ do + testCLISucceeded + ["rewrite", rule "infinite.yaml", "--max-cycles=2", "--max-depth=2", "--steps-dir=" ++ dir, "--sweet"] + ["hello_hi_hi"] + doesDirectoryExist dir `shouldReturn` True + files <- listDirectory dir + length files `shouldBe` 4 + doesFileExist (dir ++ "/00001.phi") `shouldReturn` True + doesFileExist (dir ++ "/00003.phi") `shouldReturn` True + + it "saves dataize steps to dir with --steps-dir" $ + withTempDirectory "phino-steps-dataize" $ \dir -> + withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6).plus(7) ]]" $ do + testCLISucceeded + ["dataize", symbolic, "--steps-dir=" ++ dir, "--sweet"] + ["40-45"] + doesDirectoryExist dir `shouldReturn` True + files <- listDirectory dir + let steps = sort files + -- The fix is about numbering, not about a specific rule set: the file + -- names must be distinct and contiguous from 00001, and there must be + -- more of them than a single normalization pass produces (this input + -- runs several normalizations, so a global counter yields more steps). + steps `shouldBe` map (\n -> printf "%05d.phi" (n :: Int)) [1 .. length steps] + length steps `shouldSatisfy` (> 18) + + it "saves steps with a .tex extension when --output=latex is used with --steps-dir" $ + withTempDirectory "phino-steps-latex" $ \dir -> + withStdin "[[ x -> \"hello\"]]" $ do + testCLISucceeded + ["rewrite", rule "infinite.yaml", "--max-cycles=2", "--max-depth=2", "--steps-dir=" ++ dir, "--output=latex", "--sweet"] + ["\\begin{phiquation}"] + doesDirectoryExist dir `shouldReturn` True + files <- listDirectory dir + length files `shouldBe` 4 + doesFileExist (dir ++ "/00001.tex") `shouldReturn` True + doesFileExist (dir ++ "/00003.tex") `shouldReturn` True + + it "desugares without any rules flag from file" $ + testCLISucceeded + ["rewrite", resource "desugar.phi"] + ["⟦ foo ↦ ΞΎ.x, ρ ↦ βˆ… ⟧"] + + it "desugares with without any rules flag from stdin" $ + withStdin "[[foo ↦ x]]" $ + testCLISucceeded ["rewrite"] ["⟦ foo ↦ ΞΎ.x, ρ ↦ βˆ… ⟧"] + + it "keeps the bytes of a string intact while desugaring it" $ + withStdin "⟦ Ο† ↦ Ξ¦.string(as-bytes ↦ Ξ¦.bytes(data ↦ ⟦ Ξ” ‍ 65-0A-65, ρ ↦ βˆ… ⟧)), ρ ↦ βˆ… ⟧" $ + testCLISucceeded ["rewrite", "--flat"] ["Ξ” ‍ 65-0A-65"] + + it "rewrites with single rule" $ + withStdin "T(x -> Q.y)" $ + testCLISucceeded ["rewrite", "--rule=resources/normalize/dc.yaml"] ["βŠ₯"] + + it "fails when a rewriting rule uses a dataization-only function" $ + withStdin "⟦⟧" $ + testCLIFailed + ["rewrite", rule "evaluate-in-rewrite.yaml"] + ["Function 'evaluate' in rule 'uses-evaluate' is available only for dataization and morphing, not for rewriting"] + + it "names the join function in the error message" $ + withStdin "⟦⟧" $ + testCLIFailed + ["rewrite", rule "join-broken.yaml"] + ["Function join() can work with bindings only"] + + it "normalizes with --normalize flag" $ + testCLISucceeded + ["rewrite", "--normalize", resource "normalize.phi", "--margin=25"] + [ unlines + [ "⟦" + , " x ↦ ⟦" + , " ρ ↦ ⟦" + , " y ↦ ⟦ ρ ↦ βˆ… ⟧," + , " ρ ↦ βˆ…" + , " ⟧" + , " ⟧," + , " ρ ↦ βˆ…" + , "⟧" + ] + ] + + it "normalizes and applies --rule at the same time" $ + withStdin "⟦ k ↦ ⟦ m ↦ ⟦ Ξ” ‍ 01- ⟧ ⟧.m, j ↦ ⟦ Ξ» ‍ Marker ⟧ ⟧" $ + testCLISucceeded + ["rewrite", "--normalize", rule "marker.yaml", "--sweet"] + ["⟦ k ↦ ⟦ Ξ” ‍ 01-, ρ ↦ ⟦ m ↦ ⟦ Ξ” ‍ 01- ⟧ ⟧ ⟧, j ↦ ⟦ Ξ” ‍ FF- ⟧ ⟧"] + + it "normalizes from stdin" $ + withStdin "⟦ a ↦ ⟦ b ↦ βˆ… ⟧ (b ↦ [[ ]]) ⟧" $ + testCLISucceeded + ["rewrite", "--normalize", "--margin=20"] + [ unlines + [ "⟦" + , " a ↦ ⟦" + , " b ↦ ⟦ ρ ↦ βˆ… ⟧," + , " ρ ↦ βˆ…" + , " ⟧," + , " ρ ↦ βˆ…" + , "⟧" + ] + ] + + it "rewrites with --sweet flag" $ + withStdin "[[ x -> 5]]" $ + testCLISucceeded + ["rewrite", "--sweet"] + ["⟦ x ↦ 5 ⟧"] + + it "rewrites as XMIR" $ + withStdin "[[ x -> Q.y ]]" $ + testCLISucceeded + ["rewrite", "--output=xmir"] + ["", ""] + + it "emits a real revision and ms in XMIR" $ do + (output, _) <- withStdin "[[ x -> Q.y ]]" $ withStdout (runCLI ["rewrite", "--output=xmir"]) + let attrValue :: String -> String -> String + attrValue name text = + let needle = name ++ "=\"" + breakOn :: String -> Maybe String + breakOn haystack + | needle `isPrefixOf` haystack = Just (drop (length needle) haystack) + | null haystack = Nothing + | otherwise = breakOn (drop 1 haystack) + in case breakOn text of + Just afterNeedle -> takeWhile (/= '"') afterNeedle + Nothing -> "" + revision = attrValue "revision" output + ms = attrValue "ms" output + revision `shouldSatisfy` (\sha -> length sha == 7 && all (`elem` "0123456789abcdef") sha) + revision `shouldNotBe` "1234567" + ms `shouldSatisfy` (all isDigit) + + it "rewrites as LaTeX" $ + withStdin "[[ x_o -> Q.z(y -> 5), q$ -> T, w -> $, ^ -> Q, @ -> 1, y -> \"H$@^M\", L> Fu_nc ]]" $ + testCLISucceeded + ["rewrite", "--output=latex", "--sweet"] + [ unlines + [ "\\begin{phiquation}" + , "[[" + , " |x\\char95{}o| -> Q . |z| ( |y| -> 5 )," + , " |q\\char36{}| -> T," + , " |w| -> \\phiTerminal{\\xi}," + , " \\phiTerminal{\\rho} -> Q," + , " @ -> 1," + , " |y| -> \"H$@^M\"," + , " L> |Fu\\char95{}nc|" + , "]]{.}" + , "\\end{phiquation}" + ] + ] + + it "rewrites as LaTeX without numeration" $ + withStdin "[[ x -> 5 ]]" $ + testCLISucceeded + ["rewrite", "--output=latex", "--sweet", "--nonumber", "--flat"] + [ unlines + [ "\\begin{phiquation*}" + , "[[ |x| -> 5 ]]{.}" + , "\\end{phiquation*}" + ] + ] + + it "rewrites an alpha-index argument as \\alpha subscript in LaTeX" $ + withStdin "Q.foo(~1 -> Q.y)" $ + testCLISucceeded + ["rewrite", "--output=latex", "--flat", "--nonumber"] + [ unlines + [ "\\begin{phiquation*}" + , "Q . |foo| ( \\phiTerminal{\\alpha_{1}} -> Q . |y| ){.}" + , "\\end{phiquation*}" + ] + ] + + it "rewrite as LaTeX with expression name" $ + withStdin "[[ x -> 5 ]]" $ + testCLISucceeded + ["rewrite", "--output=latex", "--sweet", "--flat", "--expression=foo"] + [ unlines + [ "\\begin{phiquation}" + , "\\phiExpression{foo} [[ |x| -> 5 ]]{.}" + , "\\end{phiquation}" + ] + ] + + it "rewrite as LaTeX with label name" $ + withStdin "[[ x -> 5 ]]" $ + testCLISucceeded + ["rewrite", "--output=latex", "--sweet", "--flat", "--label=foo"] + [ unlines + [ "\\begin{phiquation}\n\\label{foo}" + , "[[ |x| -> 5 ]]{.}" + , "\\end{phiquation}" + ] + ] + + it "rewrites with XMIR as input" $ + withStdin "" $ + testCLISucceeded + ["rewrite", "--input=xmir", "--sweet"] + ["⟦ app ↦ ⟦ x ↦ Ξ¦.number ⟧ ⟧"] + + it "rewrites and prints with XMIR as input and output" $ + withStdin + ( intercalate + "" + [ "" + , "" + ] + ) + ( testCLISucceeded + ["rewrite", "--input=xmir", "--output=xmir", "--sweet"] + [ "" + , "<?xml version="1.0" encoding="UTF-8"?><object><o name="app"><o name="x" base="Ξ¦.number"/></o></object>" + ] + ) + + it "rewrites as XMIR with omit-listing flag" $ + withStdin "[[ x -> Q.y ]]" $ + testCLISucceeded + ["rewrite", "--output=xmir", "--omit-listing"] + ["", "1 line(s)", " "] + + it "does not fail on exactly 1 rewriting" $ + withStdin "⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧" $ + testCLISucceeded + ["rewrite", rule "simple.yaml", "--must=1", "--sweet"] + ["x ↦ \"bar\""] + + it "prints many expressions with --sequence" $ + withStdin "[[ x -> \"foo\" ]]" $ + testCLISucceeded + [ "rewrite" + , rule "first.yaml" + , rule "second.yaml" + , "--max-depth=1" + , "--max-cycles=2" + , "--sequence" + , "--sweet" + , "--flat" + ] + [ unlines + [ "⟦ x ↦ \"foo\" ⟧" + , "Ξ¦.x( y ↦ \"foo\" )" + , "⟦ x ↦ \"foo\" ⟧" + ] + ] + + it "prefixes every step with a header when --headers is on" $ + withStdin "[[ x -> \"foo\" ]]" $ + testCLISucceeded + [ "rewrite" + , rule "first.yaml" + , rule "second.yaml" + , "--max-depth=1" + , "--max-cycles=2" + , "--sequence" + , "--headers" + , "--sweet" + , "--flat" + ] + [ intercalate + "\n" + [ "" + , "=== Step #1" + , "⟦ x ↦ \"foo\" ⟧" + , "" + , "=== Step #2, Rule 'first', 31t -> 30t" + , "Ξ¦.x( y ↦ \"foo\" )" + , "" + , "=== Step #3, Rule 'second', 30t -> 31t" + , "⟦ x ↦ \"foo\" ⟧" + ] + ] + + it "ignores --headers without --sequence" $ + withStdin "[[ x -> \"foo\" ]]" $ + testCLISucceeded + ["rewrite", rule "simple.yaml", "--headers", "--sweet", "--flat"] + ["⟦ x ↦ \"bar\" ⟧"] + + it "emits step headers as LaTeX comments with --headers" $ + withStdin "[[ x -> \"foo\" ]]" $ + testCLISucceeded + [ "rewrite" + , rule "first.yaml" + , rule "second.yaml" + , "--max-depth=1" + , "--max-cycles=2" + , "--sequence" + , "--headers" + , "--sweet" + , "--flat" + , "--output=latex" + ] + [ unlines + [ "\\begin{phiquation}" + , "% === Step #1" + , "[[ |x| -> \"foo\" ]] \\leadsto_{\\nameref{r:first}}" + , "% === Step #2, Rule 'first', 31t -> 30t" + , " \\leadsto Q . |x| ( |y| -> \"foo\" ) \\leadsto_{\\nameref{r:second}}" + , "% === Step #3, Rule 'second', 30t -> 31t" + , " \\leadsto [[ |x| -> \"foo\" ]]{.}" + , "\\end{phiquation}" + ] + ] + + it "prints only one latex preamble with --sequence" $ + withStdin "[[ x -> \"foo\" ]]" $ + testCLISucceeded + [ "rewrite" + , rule "first.yaml" + , rule "second.yaml" + , "--max-depth=1" + , "--max-cycles=2" + , "--sequence" + , "--sweet" + , "--flat" + , "--output=latex" + ] + [ unlines + [ "\\begin{phiquation}" + , "[[ |x| -> \"foo\" ]] \\leadsto_{\\nameref{r:first}}" + , " \\leadsto Q . |x| ( |y| -> \"foo\" ) \\leadsto_{\\nameref{r:second}}" + , " \\leadsto [[ |x| -> \"foo\" ]]{.}" + , "\\end{phiquation}" + ] + ] + + it "prints meet prefix with --meet-prefix=foo in LaTeX" $ + withStdin "[[ x -> ?, y -> $.x ]](x -> [[ D> 42- ]]).y" $ + testCLISucceeded + ["rewrite", "--normalize", "--sweet", "--sequence", "--output=latex", "--flat", "--compress", "--meet-prefix=foo"] + [ unlines + [ "\\begin{phiquation}" + , "[[ |x| -> ?, |y| -> |x| ]] ( |x| -> \\phinoMeet{foo:1}{ [[ D> |42-| ]] } ) . |y| \\leadsto_{\\nameref{r:copy}}" + , " \\leadsto \\phinoMeet{foo:2}{ [[ |x| -> \\phinoAgain{foo:1}, |y| -> |x| ]] } . |y| \\leadsto_{\\nameref{r:dot}}" + , " \\leadsto \\phinoMeet{foo:3}{ [[ |x| -> \\phinoAgain{foo:1} ]] } . |x| ( \\phiTerminal{\\rho} -> \\phinoAgain{foo:2} ) \\leadsto_{\\nameref{r:dot}}" + , " \\leadsto \\phinoAgain{foo:1} ( \\phiTerminal{\\rho} -> \\phinoAgain{foo:3}, \\phiTerminal{\\rho} -> \\phinoAgain{foo:2} ) \\leadsto_{\\nameref{r:copy}}" + , " \\leadsto [[ D> |42-|, \\phiTerminal{\\rho} -> \\phinoAgain{foo:3} ]] ( \\phiTerminal{\\rho} -> \\phinoAgain{foo:2} ) \\leadsto_{\\nameref{r:stay}}" + , " \\leadsto [[ D> |42-|, \\phiTerminal{\\rho} -> \\phinoAgain{foo:3} ]]{.}" + , "\\end{phiquation}" + ] + ] + + it "prints with compressed expressions in LaTeX" $ + withStdin "[[ x -> ?, y -> $.x ]](x -> [[ D> 42- ]]).y" $ + testCLISucceeded + ["rewrite", "--normalize", "--sweet", "--sequence", "--output=latex", "--flat", "--compress"] + [ unlines + [ "\\begin{phiquation}" + , "[[ |x| -> ?, |y| -> |x| ]] ( |x| -> \\phinoMeet{1}{ [[ D> |42-| ]] } ) . |y| \\leadsto_{\\nameref{r:copy}}" + , " \\leadsto \\phinoMeet{2}{ [[ |x| -> \\phinoAgain{1}, |y| -> |x| ]] } . |y| \\leadsto_{\\nameref{r:dot}}" + , " \\leadsto \\phinoMeet{3}{ [[ |x| -> \\phinoAgain{1} ]] } . |x| ( \\phiTerminal{\\rho} -> \\phinoAgain{2} ) \\leadsto_{\\nameref{r:dot}}" + , " \\leadsto \\phinoAgain{1} ( \\phiTerminal{\\rho} -> \\phinoAgain{3}, \\phiTerminal{\\rho} -> \\phinoAgain{2} ) \\leadsto_{\\nameref{r:copy}}" + , " \\leadsto [[ D> |42-|, \\phiTerminal{\\rho} -> \\phinoAgain{3} ]] ( \\phiTerminal{\\rho} -> \\phinoAgain{2} ) \\leadsto_{\\nameref{r:stay}}" + , " \\leadsto [[ D> |42-|, \\phiTerminal{\\rho} -> \\phinoAgain{3} ]]{.}" + , "\\end{phiquation}" + ] + ] + + it "should not print \\phinoMeet{} twice" $ + withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ + testCLISucceeded + ["rewrite", "--normalize", "--sequence", "--flat", "--compress", "--output=latex", "--sweet"] + [ unlines + [ "\\begin{phiquation}" + , "[[ |ex| -> [[ |x| -> [[ |y| -> ?, |k| -> \\phinoMeet{1}{ [[ |t| -> 42 ]] } ]] ( |y| -> \\phinoAgain{1} ) ]] . |i| ]] \\leadsto_{\\nameref{r:copy}}" + , " \\leadsto [[ |ex| -> [[ |x| -> [[ |y| -> \\phinoAgain{1}, |k| -> \\phinoAgain{1} ]] ]] . |i| ]] \\leadsto_{\\nameref{r:stop}}" + , " \\leadsto [[ |ex| -> T ]]{.}" + , "\\end{phiquation}" + ] + ] + + it "should not meet expression with high --meet-popularity" $ + withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ + testCLISucceeded + ["rewrite", "--normalize", "--sequence", "--flat", "--compress", "--output=latex", "--sweet", "--meet-popularity=70"] + [ unlines + [ "\\begin{phiquation}" + , "[[ |ex| -> [[ |x| -> [[ |y| -> ?, |k| -> [[ |t| -> 42 ]] ]] ( |y| -> [[ |t| -> 42 ]] ) ]] . |i| ]] \\leadsto_{\\nameref{r:copy}}" + , " \\leadsto [[ |ex| -> [[ |x| -> [[ |y| -> [[ |t| -> 42 ]], |k| -> [[ |t| -> 42 ]] ]] ]] . |i| ]] \\leadsto_{\\nameref{r:stop}}" + , " \\leadsto [[ |ex| -> T ]]{.}" + , "\\end{phiquation}" + ] + ] + + it "meets with --meet-length=32" $ + withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ + testCLISucceeded + ["rewrite", "--normalize", "--sequence", "--flat", "--compress", "--output=latex", "--sweet", "--meet-length=32"] + [ unlines + [ "\\begin{phiquation}" + , "[[ |ex| -> [[ |x| -> [[ |y| -> ?, |k| -> [[ |t| -> 42 ]] ]] ( |y| -> [[ |t| -> 42 ]] ) ]] . |i| ]] \\leadsto_{\\nameref{r:copy}}" + , " \\leadsto [[ |ex| -> [[ |x| -> [[ |y| -> [[ |t| -> 42 ]], |k| -> [[ |t| -> 42 ]] ]] ]] . |i| ]] \\leadsto_{\\nameref{r:stop}}" + , " \\leadsto [[ |ex| -> T ]]{.}" + , "\\end{phiquation}" + ] + ] + + it "focuses expression in latex with sequence" $ + withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ + testCLISucceeded + ["rewrite", "--normalize", "--sequence", "--flat", "--output=latex", "--sweet", "--focus=Q.ex"] + [ unlines + [ "\\begin{phiquation}" + , "[[ |x| -> [[ |y| -> ?, |k| -> [[ |t| -> 42 ]] ]] ( |y| -> [[ |t| -> 42 ]] ) ]] . |i| \\leadsto_{\\nameref{r:copy}}" + , " \\leadsto [[ |x| -> [[ |y| -> [[ |t| -> 42 ]], |k| -> [[ |t| -> 42 ]] ]] ]] . |i| \\leadsto_{\\nameref{r:stop}}" + , " \\leadsto T{.}" + , "\\end{phiquation}" + ] + ] + + it "focuses expression in latex without sequence" $ + withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ + testCLISucceeded + ["rewrite", "--normalize", "--flat", "--output=latex", "--sweet", "--focus=Q.ex"] + [ unlines + [ "\\begin{phiquation}" + , "T{.}" + , "\\end{phiquation}" + ] + ] + + it "shows exceeding of limits in latex" $ + withStdin "[[ x -> $.y, y -> $.x ]].x" $ + testCLISucceeded + ["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 [[ |y| -> |x| ]] . |y| ( \\phiTerminal{\\rho} -> [[ |x| -> |y|, |y| -> |x| ]] ) \\leadsto" + , " \\leadsto \\dots" + , "\\end{phiquation}" + ] + ] + + it "focuses expression in phi without sequence" $ + withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ + testCLISucceeded + ["rewrite", "--normalize", "--flat", "--output=phi", "--sweet", "--focus=Q.ex"] + ["βŠ₯"] + + it "focuses expression in phi with sequence" $ + withStdin "[[ ex -> [[ x -> [[ y -> ?, k -> [[ t -> 42]] ]]( y -> [[ t -> 42 ]]) ]].i ]]" $ + testCLISucceeded + ["rewrite", "--normalize", "--sequence", "--flat", "--output=phi", "--sweet", "--focus=Q.ex"] + [ unlines + [ "⟦ x ↦ ⟦ y ↦ βˆ…, k ↦ ⟦ t ↦ 42 ⟧ ⟧( y ↦ ⟦ t ↦ 42 ⟧ ) ⟧.i" + , "⟦ x ↦ ⟦ y ↦ ⟦ t ↦ 42 ⟧, k ↦ ⟦ t ↦ 42 ⟧ ⟧ ⟧.i" + , "βŠ₯" + ] + ] + + it "prints input as listing in XMIR" $ + withStdin "[[ app -> [[]] ]]" $ + testCLISucceeded + ["rewrite", "--output=xmir", "--omit-comments", "--sweet", "--flat"] + [" [[ app -> [[]] ]]"] + + it "print expression in listing in XMIRs with --sequence" $ + withStdin "[[ x -> \"foo\" ]]" $ + testCLISucceeded + ["rewrite", "--output=xmir", "--omit-comments", "--sweet", "--flat", "--sequence", rule "simple.yaml"] + [" ⟦ x ↦ \"foo\" ⟧", " ⟦ x ↦ \"bar\" ⟧"] + + describe "must range tests" $ do + describe "fails" $ do + it "when cycles exceed range ..1" $ + withStdin "[[ x -> [[ y -> 5 ]].y ]].x" $ + testCLIFailed + ["rewrite", "--max-depth=1", "--max-cycles=2", "--normalize", "--must=..1"] + ["it's expected rewriting cycles to be in range [..1], but rewriting has already reached 2"] + + it "when cycles below range 2.." $ + withStdin "⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧" $ + testCLIFailed + ["rewrite", rule "simple.yaml", "--must=2.."] + ["it's expected rewriting cycles to be in range [2..], but rewriting stopped after 1"] + + it "with invalid range 5..3" $ + withStdin "[[ ]]" $ + testCLIFailed + ["rewrite", "--must=5..3"] + ["cannot parse value `5..3'"] + + it "with negative in range -1..5" $ + withStdin "[[ ]]" $ + testCLIFailed + ["rewrite", "--must=-1..5"] + ["cannot parse value `-1..5'"] + + it "with malformed range syntax" $ + withStdin "[[ ]]" $ + testCLIFailed + ["rewrite", "--must=3...5"] + ["cannot parse value `3...5'"] + + it "accepts range ..5 (0 to 5 cycles)" $ + withStdin "[[ ]]" $ + testCLISucceeded ["rewrite", "--must=..5", "--sweet"] ["⟦⟧"] + + it "accepts range 0..0 (exactly 0 cycles)" $ + withStdin "[[ ]]" $ + testCLISucceeded ["rewrite", "--must=0..0", "--sweet"] ["⟦⟧"] + + it "accepts range 1..1 (exactly 1 cycle)" $ + withStdin "⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧" $ + testCLISucceeded + ["rewrite", rule "simple.yaml", "--must=1..1", "--sweet"] + ["x ↦ \"bar\""] + + it "accepts range 1..3 when 1 cycle happens" $ + withStdin "⟦ t ↦ ⟦ x ↦ \"foo\" ⟧ ⟧" $ + testCLISucceeded + ["rewrite", rule "simple.yaml", "--must=1..3", "--sweet"] + ["x ↦ \"bar\""] + + it "accepts range 0.. (0 or more)" $ + withStdin "[[ ]]" $ + testCLISucceeded ["rewrite", "--must=0..", "--sweet"] ["⟦⟧"] + + it "prints to target file" $ + withStdin "[[ ]]" $ + withTempFile "targetXXXXXX.tmp" $ \(path, h) -> do + hClose h + testCLISucceeded ["rewrite", "--sweet", printf "--target=%s" path] [] + content <- readFile path + content `shouldBe` "⟦⟧" + + it "modifies file in-place" $ + withTempFile "inplaceXXXXXX.phi" $ \(path, h) -> do + hPutStr h "[[ x -> \"foo\" ]]" + hClose h + testCLISucceeded ["rewrite", rule "simple.yaml", "--in-place", "--sweet", path] [] + content <- readFile path + content `shouldBe` "⟦ x ↦ \"bar\" ⟧" + + it "skips rewriting with --update when target is newer than source" $ + withTempFileContent "src-XXXXXX.phi" "[[ x -> \"foo\" ]]" $ \src -> + withTempFileContent "tgt-XXXXXX.phi" "ORIGINAL" $ \tgt -> do + now <- getCurrentTime + setModificationTime src (addUTCTime (-60) now) + setModificationTime tgt now + testCLISucceeded + ["rewrite", rule "simple.yaml", "--update", "--sweet", "--target=" ++ tgt, src] + [] + content <- readFile tgt + content `shouldBe` "ORIGINAL" + + it "logs the skip reason at debug level when --update finds a newer target" $ + withTempFileContent "src-XXXXXX.phi" "[[ x -> \"foo\" ]]" $ \src -> + withTempFileContent "tgt-XXXXXX.phi" "ORIGINAL" $ \tgt -> do + now <- getCurrentTime + setModificationTime src (addUTCTime (-60) now) + setModificationTime tgt now + testCLISucceeded + ["rewrite", rule "simple.yaml", "--update", "--sweet", "--log-level=DEBUG", "--target=" ++ tgt, src] + ["is newer than source", "skipping rewriting (--update)"] + + it "logs progress at debug level when printing to --target" $ + withStdin "[[ ]]" $ + withTempFile "targetXXXXXX.tmp" $ \(path, h) -> do + hClose h + testCLISucceeded + ["rewrite", "--sweet", "--log-level=DEBUG", printf "--target=%s" path] + ["The option '--target' is specified, printing to", "The command result was saved in"] + + it "logs progress at debug level when modifying a file in-place" $ + withTempFile "inplaceXXXXXX.phi" $ \(path, h) -> do + hPutStr h "[[ x -> \"foo\" ]]" + hClose h + testCLISucceeded + ["rewrite", rule "simple.yaml", "--in-place", "--sweet", "--log-level=DEBUG", path] + ["The option '--in-place' is specified, writing back to", "was modified in-place"] + + it "rewrites with --update when source is newer than target" $ + withTempFileContent "src-XXXXXX.phi" "[[ x -> \"foo\" ]]" $ \src -> + withTempFileContent "tgt-XXXXXX.phi" "ORIGINAL" $ \tgt -> do + now <- getCurrentTime + setModificationTime tgt (addUTCTime (-60) now) + setModificationTime src now + testCLISucceeded + ["rewrite", rule "simple.yaml", "--update", "--sweet", "--target=" ++ tgt, src] + [] + content <- readFile tgt + content `shouldBe` "⟦ x ↦ \"bar\" ⟧" + + it "rewrites with cycles" $ + withStdin "[[ x -> \"x\" ]]" $ + testCLISucceeded + ["rewrite", "--sweet", rule "infinite.yaml", "--max-depth=1", "--max-cycles=2"] + ["⟦ x ↦ \"x_hi_hi\" ⟧"] + + it "hides default package" $ + withStdin "[[ org -> [[ eolang -> [[ number -> [[]] ]]]], x -> 42 ]]" $ + testCLISucceeded + ["rewrite", "--sweet", "--flat", "--hide=Q.org"] + ["⟦ x ↦ 42 ⟧"] + + it "hides several FQNs" $ + withStdin "[[ org -> [[ eolang -> Q.x, yegor256 -> Q.y ]], x -> 42 ]]" $ + testCLISucceeded + ["rewrite", "--sweet", "--flat", "--hide=Q.org.eolang", "--hide=Q.org.yegor256"] + ["⟦ org ↦ ⟦⟧, x ↦ 42 ⟧"] + + it "shows and hides" $ + withStdin "[[ org -> [[ eolang -> Q.x, yegor256 -> Q.y ]], x -> 42 ]]" $ + testCLISucceeded + ["rewrite", "--sweet", "--flat", "--show=Q.org", "--hide=Q.org.eolang"] + ["⟦ org ↦ ⟦ yegor256 ↦ Ξ¦.y ⟧ ⟧"] + + it "prints in line with --flat" $ + withStdin "[[ x -> 5, y -> \"hey\", z -> [[ w -> [[ ]] ]] ]]" $ + testCLISucceeded + ["rewrite", "--sweet", "--flat"] + ["⟦ x ↦ 5, y ↦ \"hey\", z ↦ ⟦ w ↦ ⟦⟧ ⟧ ⟧"] + + it "removes unnecessary rho bindings in primitive applications" $ + withStdin + ( unlines + [ "[[" + , " z -> [[ x -> [[ t -> 42 ]].t ]].x," + , " org -> [[ eolang -> [[ bytes -> [[ data -> ? ]], number -> [[ as-bytes -> ? ]] ]] ]]" + , "]]" + ] + ) + ( testCLISucceeded + ["rewrite", "--sweet", "--normalize", "--flat"] + ["⟦ z ↦ 42, org ↦ ⟦ eolang ↦ ⟦ bytes(data) ↦ ⟦⟧, number(as-bytes) ↦ ⟦⟧ ⟧ ⟧ ⟧"] + ) + + it "reduces log message" $ + withStdin "[[ x -> [[ y -> ? ]](y -> 5) ]]" $ + testCLISucceeded + ["rewrite", "--log-level=debug", "--log-lines=1", "--normalize"] + [ intercalate + "\n" + [ "[DEBUG]: Applied 'copy' (44 nodes -> 39 nodes)" + , "---| log is limited by --log-lines=1 option |---" + ] + ] + + -- 'matches' inside 'when' raises while dataizing a formation: the + -- substitution is still dropped (the policy #1079 questions), but the + -- reason surfaces in the debug log instead of vanishing + it "reports a condition that raised while being evaluated" $ + withStdin "[[ x -> [[ y -> βˆ… ]] ]]" $ + testCLISucceeded + ["rewrite", rule "raising-condition.yaml", "--log-level=debug", "--flat"] + [ "raised and was treated as not met: user error (Only data objects and bytes are supported" + , "⟦ x ↦ ⟦ y ↦ βˆ…, ρ ↦ βˆ… ⟧, ρ ↦ βˆ… ⟧" + ] + + it "canonizes expression" $ + withStdin "[[ x -> [[ y -> [[ L> Func ]].q, z -> Q.x(a -> [[ w -> [[ L> Atom ]], L> Hello ]]) ]], L> Package ]]" $ + testCLISucceeded + ["rewrite", "--canonize", "--sweet", "--flat"] + ["⟦ x ↦ ⟦ y ↦ ⟦ Ξ» ‍ Fn1 ⟧.q, z ↦ Ξ¦.x( a ↦ ⟦ w ↦ ⟦ Ξ» ‍ Fn2 ⟧, Ξ» ‍ Fn3 ⟧ ) ⟧, Ξ» ‍ Fn4 ⟧"] + + it "rewrites by locator" $ + withStdin "[[ ex -> [[ x -> [[ y -> 5 ]].y ]], abc -> [[ x -> ? ]](x -> 5) ]]" $ + testCLISucceeded + ["rewrite", "--sweet", "--flat", "--locator=Q.ex", "--normalize"] + ["⟦ ex ↦ ⟦ x ↦ 5 ⟧, abc ↦ ⟦ x ↦ βˆ… ⟧( x ↦ 5 ) ⟧"] + + it "returns original expression on --breakpoint" $ + withStdin "[[ x -> ?, y -> $.x ]](x -> [[ D> 42- ]]).y" $ + testCLISucceeded + ["rewrite", "--sweet", "--flat", "--normalize", "--breakpoint=stop", "--log-level=debug"] + [ "Applied 'copy' (30 nodes -> 25 nodes)" + , "Rule 'stop' is a breakpoint, dropping down all the previous rewritings..." + , "⟦ x ↦ βˆ…, y ↦ x ⟧( x ↦ ⟦ Ξ” ‍ 42- ⟧ ).y" + ] + + describe "dataize" $ do + it "prints help" $ + testCLISucceeded ["dataize", "--help"] ["Dataize the πœ‘-expression"] + + it "dataizes simple expression" $ + withStdin "[[ D> 01- ]]" $ + testCLISucceeded ["dataize"] ["01-"] + + it "accepts --seed flag" $ + withStdin "[[ D> 01- ]]" $ + testCLISucceeded ["dataize", "--seed=7"] ["01-"] + + it "fails to dataize an empty object, which dataizes the terminator βŠ₯" $ + withStdin "[[ ]]" $ + testCLIFailed ["dataize"] ["terminator βŠ₯"] + + it "fails with negative --max-steps" $ + withStdin "[[ D> 01- ]]" $ + testCLIFailed ["dataize", "--max-steps=-1"] ["--max-steps must be positive"] + + -- The 𝕄/𝔻 recursion used to be unbounded, so a Ξ» function answering with a + -- firing of itself kept morphing forever and no option could stop it + -- (#1052) + it "fails on --max-steps instead of dataizing forever" $ + loopingLambdas $ \endless -> + withStdin "⟦ @ ↦ ⟦ Ξ» ‍ L_loop ⟧ ⟧" $ + testCLIFailed + ["dataize", "--symbolic=" ++ endless, "--max-steps=40"] + ["[ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=40"] + + -- Under '--partial' the same term does not fail: the spent budget is a + -- stuck site too, and the run ends on the residual the spine reached (#1078) + it "parks --max-steps on a residual with --partial" $ + loopingLambdas $ \endless -> + withStdin "⟦ @ ↦ ⟦ Ξ» ‍ L_loop ⟧ ⟧" $ + testCLISucceeded + ["dataize", "--symbolic=" ++ endless, "--max-steps=40", "--partial", "--flat", "--hide-rho"] + ["⟦ Ξ» ‍ L_loop ⟧"] + + -- '--acyclic' used to be the 'morph' command's alone, so a program coming + -- back to a term through 𝔻 rather than 𝕄 β€” a body dispatching the very + -- object it stands in, which 𝕄 stops at a formation of every round and + -- only 𝔻 walks round β€” spent the whole budget and failed on the limit + -- (#1290) + describe "--acyclic" $ do + let circling = "⟦ cyc ↦ ⟦ x ↦ βˆ…, Ο† ↦ Ξ¦.cyc( ΞΎ.x ) ⟧, t ↦ Ξ¦.cyc( ⟦⟧ ) ⟧" + it "spends the whole budget and fails on the limit without the flag" $ + withStdin circling $ + testCLIFailed + ["dataize", "--locator=Q.t", "--max-steps=40"] + ["[ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=40"] + + -- The budget here is far larger than the one the run above failed on, so + -- what ends this one is the cut and not the limit + it "names the term it came back to with the flag" $ + withStdin circling $ + testCLIFailed + ["dataize", "--locator=Q.t", "--acyclic", "--max-steps=4000"] + ["[ERROR]: Reduction came back to a term it is already reducing:"] + + -- 𝔻 insists on bytes and a parked term carries none, so what a cut run + -- prints is the residual program, exactly as it prints one for a Ξ» + -- function that cannot fire + it "prints the residue and exits successfully with --partial" $ + withStdin circling $ + testCLISucceeded + ["dataize", "--locator=Q.t", "--acyclic", "--partial", "--max-steps=4000", "--flat", "--hide-rho"] + ["⟦ cyc ↦ ⟦ x ↦ βˆ…, Ο† ↦ Ξ¦.cyc( Ξ±0 ↦ ΞΎ.x ) ⟧, t ↦ ⟦ x ↦ ⟦⟧, Ο† ↦ Ξ¦.cyc( Ξ±0 ↦ ΞΎ.x ) ⟧ ⟧"] + + -- The guard reads nothing but the terms the frames above it are + -- dataizing, so a run that never comes back to one answers as it always did + it "answers a terminating program the same way with the flag" $ + withStdin "⟦ t ↦ ⟦ Ξ” ‍ 01-02 ⟧ ⟧" $ + testCLISucceeded ["dataize", "--locator=Q.t", "--acyclic"] ["01-02"] + + it "dataizes with --sequence" $ + withStdin "[[ @ -> [[ x -> [[ D> 01-, y -> ? ]](y -> [[ ]]) ]].x ]]" $ + testCLISucceeded + ["dataize", "--sequence", "--output=latex", "--flat", "--sweet"] + [ intercalate + "\n" + [ "\\begin{phiquation}" + , "[[ @ -> [[ |x| -> [[ D> |01-|, |y| -> ? ]] ( |y| -> [[]] ) ]] . |x| ]] \\leadsto_{\\nameref{r:contextualize}}" + , " \\leadsto [[ |x| -> [[ D> |01-|, |y| -> ? ]] ( |y| -> [[]] ) ]] . |x| \\leadsto_{\\nameref{r:copy}}" + , " \\leadsto [[ |x| -> [[ D> |01-|, |y| -> [[]] ]] ]] . |x| \\leadsto_{\\nameref{r:dot}}" + , " \\leadsto [[ D> |01-|, |y| -> [[]] ]] ( \\phiTerminal{\\rho} -> [[ |x| -> [[ D> |01-|, |y| -> [[]] ]] ]] ) \\leadsto_{\\nameref{r:copy}}" + , " \\leadsto [[ D> |01-|, |y| -> [[]], \\phiTerminal{\\rho} -> [[ |x| -> [[ D> |01-|, |y| -> [[]] ]] ]] ]] \\leadsto_{\\nameref{r:delta}}" + , " \\leadsto |01-|{.}" + , "\\end{phiquation}" + , "01-" + ] + ] + + it "keeps the delta step in --sequence under --quiet" $ + withStdin "[[ D> 01- ]]" $ + testCLISucceeded + ["dataize", "--sequence", "--quiet", "--output=latex", "--flat", "--sweet"] + [ intercalate + "\n" + [ "[[ D> |01-| ]] \\leadsto_{\\nameref{r:delta}}" + , " \\leadsto |01-|{.}" + , "\\end{phiquation}" + ] + ] + + it "ends the phi --sequence at the bare data" $ + withStdin "[[ D> 01- ]]" $ + testCLISucceeded + ["dataize", "--sequence", "--quiet", "--flat", "--sweet"] + ["⟦ Ξ” ‍ 01- ⟧\n01-"] + + it "focuses a compressed sequence whose meet replaces a step root" $ + 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}}"] + + 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 ]] ]] ]]" $ + testCLISucceeded + ["dataize", symbolic, "--output=latex", "--sweet", "--nonumber", "--compress", "--canonize", "--meet-prefix=dataization", "--sequence", "--flat", "--quiet", "--meet-length=5", "--meet-popularity=1"] + ["\\phinoMeet{dataization:1}"] + + it "dataizes with --locator" $ + withStdin "[[ ex -> [[ @ -> Q.x ]], x -> [[ D> 42- ]] ]]" $ + testCLISucceeded ["dataize", "--locator=Q.ex"] ["42-"] + + it "does not print bytes with --quiet" $ + withStdin "[[ D> 01- ]]" $ + testCLISucceeded ["dataize", "--quiet"] [] + + -- Every firing of the run reaches the protocol as a tree: the run itself, + -- one line per firing, one per operand it brought down or reduced and one + -- per answer it gave. Nothing but the symbols ties them together, so the + -- lines a firing writes are what a reader of the file walks back (#1226). + describe "--protocol" $ do + let sum' = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6) ]]" + chained = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6).plus(7) ]]" + nested = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6.plus(7)) ]]" + mixed = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]], times(x) -> [[ L> L_number_times ]] ]], @ -> 5.plus(6).times(7) ]]" + it "opens the protocol with the run it is the protocol of" $ + withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do + hClose stream + withStdin "[[ D> 01- ]]" $ + testCLISucceeded ["dataize", "--protocol=" ++ path, "--quiet"] [] + records <- readUtf8 path + records `shouldBe` "𝔻(Ξ¦)\n" + + -- An operand line says what the meta was bound to and, after two spaces + -- and '#', the term the entry wrote under it, so a reader never has to + -- open the '--symbolic' file beside the protocol to see what came down + -- to what (#1265) + it "writes one line per operand and one per answer of a firing" $ + withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do + hClose stream + withStdin sum' $ + testCLISucceeded ["dataize", symbolic, "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "𝔻(Ξ¦)" + , " 𝔼(L_number_plus) # 𝔻(Ξ¦)" + , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ)" + , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ΞΎ.x)" + , " 𝑛.1.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) # 𝑛" + , " 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1)" + ] + + -- The second firing of one entry numbers its own metas 𝛿1.2 and 𝛿2.2, + -- and the operand it brings down is the answer of the first, which the + -- protocol names rather than dataizes: every symbol answers the same 42 + it "numbers the firings of one entry apart and names the symbol between them" $ + withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do + hClose stream + withStdin chained $ + testCLISucceeded ["dataize", symbolic, "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "𝔻(Ξ¦)" + , " 𝔼(L_number_plus) # 𝕄(Ξ¦)" + , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ)" + , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ΞΎ.x)" + , " 𝑛.1.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) # 𝑛" + , " 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1)" + , " 𝔼(L_number_plus) # 𝔻(Ξ¦)" + , " 𝛿1.2 := 𝔻(⟦ Ξ» ‍ 𝜎1 ⟧) # 𝔻(ΞΎ.ρ)" + , " 𝛿2.2 := 40-1C-00-00-00-00-00-00 # 𝔻(ΞΎ.x)" + , " 𝑛.2.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ) # 𝑛" + , " 𝑛.2.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.2.1)" + ] + + -- A meta is a variable bound exactly once, so its name has to be unique + -- in the whole file and the protocol refers back to it as a name. The + -- firings are therefore numbered across the run and not per Ξ» function: + -- the first firing of 'L_number_times' calls its operand 𝛿1.2, never the + -- 𝛿1.1 the first firing of 'L_number_plus' has already taken (#1261) + it "numbers the firings of different entries apart" $ + withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do + hClose stream + withStdin mixed $ + testCLISucceeded ["dataize", symbolic, "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "𝔻(Ξ¦)" + , " 𝔼(L_number_plus) # 𝕄(Ξ¦)" + , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ)" + , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ΞΎ.x)" + , " 𝑛.1.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) # 𝑛" + , " 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧ # 𝕄(𝑛.1.1)" + , " 𝔼(L_number_times) # 𝔻(Ξ¦)" + , " 𝛿1.2 := 𝔻(⟦ Ξ» ‍ 𝜎1 ⟧) # 𝔻(ΞΎ.ρ)" + , " 𝛿2.2 := 40-1C-00-00-00-00-00-00 # 𝔻(ΞΎ.x)" + , " 𝑛.2.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ) # 𝑛" + , " 𝑛.2.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧ # 𝕄(𝑛.2.1)" + ] + + -- An operand is brought down by a whole run of 𝔻, so a Ξ» function it + -- fires on the way sits one level deeper than the firing waiting for it + it "nests the firing an operand of another firing brought down" $ + withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do + hClose stream + withStdin nested $ + testCLISucceeded ["dataize", symbolic, "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "𝔻(Ξ¦)" + , " 𝔼(L_number_plus) # 𝔻(Ξ¦)" + , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ)" + , " 𝔼(L_number_plus) # 𝔻(Ξ¦.a🌡1)" + , " 𝛿1.2 := 40-18-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ)" + , " 𝛿2.2 := 40-1C-00-00-00-00-00-00 # 𝔻(ΞΎ.x)" + , " 𝑛.2.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) # 𝑛" + , " 𝑛.2.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.2.1)" + , " 𝛿2.1 := 𝔻(⟦ Ξ» ‍ 𝜎1 ⟧) # 𝔻(ΞΎ.x)" + , " 𝑛.1.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ) # 𝑛" + , " 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1)" + ] + + -- A 'symbolize' line stands the data of a term an earlier line bound + -- into unknowns, so the protocol says what is known about each fresh + -- symbol before it writes the term carrying them. The fact is no + -- assignment to the symbol: a 𝜎 is the name of a Ξ» function and + -- nothing binds bytes to it, so what is known is that dataizing the + -- formation it names answers them (#1269) + it "writes what is known about every symbol a 'symbolize' line minted" $ + withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do + hClose stream + withLambdasOf (T.pack "- Ξ»: L_stand\n morph:\n 𝑛1: $.x\n symbolize:\n 𝑛2: 𝑛1\n 𝑛: ⟦ z ↦ 𝑛2 ⟧\n") $ \stands -> + withStdin "⟦ y ↦ ⟦ x ↦ ⟦ Ξ” ‍ 01- ⟧, Ξ» ‍ L_stand ⟧.z ⟧" $ + testCLISucceeded ["morph", "--symbolic=" ++ stands, "--locator=Q.y", "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "𝕄(Ξ¦.y)" + , " 𝔼(L_stand) # 𝕄(Ξ¦.y)" + , " 𝑛1.1 := ⟦ Ξ” ‍ 01- ⟧ # 𝕄(ΞΎ.x)" + , " 𝔻(⟦ Ξ» ‍ 𝜎1 ⟧) == 01-" + , " 𝑛2.1 := ⟦ Ξ» ‍ 𝜎1 ⟧ # 𝑛1" + , " 𝑛.1.1 := ⟦ z ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧ # 𝑛" + , " 𝑛.1.2 := ⟦ z ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧ # 𝕄(𝑛.1.1)" + ] + + it "keeps the lines of a run that fails" $ + withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do + hClose stream + withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]], nope -> [[ L> L_number_nope ]] ]], @ -> 5.plus(6).nope ]]" $ + testCLIFailed + ["dataize", symbolic, "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] + ["No entry of --symbolic answers the Ξ» function 'L_number_nope'"] + records <- readUtf8 path + lines records + `shouldBe` [ "𝔻(Ξ¦)" + , " 𝔼(L_number_plus) # 𝕄(Ξ¦)" + , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ)" + , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ΞΎ.x)" + , " 𝑛.1.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) # 𝑛" + , " 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, nope ↦ ⟦ Ξ» ‍ L_number_nope ⟧ ⟧ # 𝕄(𝑛.1.1)" + , " ?(L_number_nope) # 𝔻(⟦ Ξ» ‍ L_number_nope ⟧)" + ] + + it "truncates the lines left over from the previous run" $ + withTempFileContent "protocolXXXXXX.txt" "𝔼(L_number_gt)\n" $ \path -> do + withStdin "[[ D> 01- ]]" $ + testCLISucceeded ["dataize", "--protocol=" ++ path, "--quiet"] [] + records <- readUtf8 path + records `shouldBe` "𝔻(Ξ¦)\n" + + -- The protocol is a tree of one-line πœ‘ records whatever the run prints + -- its own answer as, so a program reading it back never has to know + it "writes the lines in πœ‘ even with --output=xmir" $ + withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do + hClose stream + withStdin sum' $ + testCLISucceeded ["dataize", symbolic, "--protocol=" ++ path, "--output=xmir", "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + records `shouldEndWith` " 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1)\n" + + -- The same facts as markup, so a program reading the protocol back never + -- has to parse πœ‘ to learn them: the name of an element says what its + -- record is, the value a meta took is the text of the element and each + -- symbol a firing minted stands in a record of its own (#1245, #1257, + -- #1280). Which of the two formats is written is decided by the name of + -- the file and by nothing else + describe "as XML" $ do + it "writes the document when the file is named .xml" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withStdin sum' $ + testCLISucceeded ["dataize", symbolic, "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , " " + , " 40-14-00-00-00-00-00-00" + , " 40-18-00-00-00-00-00-00" + , " 𝜎1" + , " Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )" + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧" + , " " + , "" + ] + + -- A run firing nothing still writes a document a parser can read, + -- since the root is closed on the way out and not by the last firing + it "closes the document even when nothing fires" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withStdin "[[ D> 01- ]]" $ + testCLISucceeded ["dataize", "--protocol=" ++ path, "--quiet"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , "" + ] + + -- An operand that came down to a manufactured datum is a 'dataize' + -- holding the formation its symbol names, never the 42 every symbol + -- answers and never the bare name a 𝔻 cannot be applied to (#1278), + -- while one that came down to data is a 'bind' holding that data: the + -- name of the element is what tells the two apart (#1257) + it "tells a manufactured datum from data by the name of the element" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withStdin chained $ + testCLISucceeded ["dataize", symbolic, "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , " " + , " 40-14-00-00-00-00-00-00" + , " 40-18-00-00-00-00-00-00" + , " 𝜎1" + , " Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )" + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧" + , " " + , " " + , " ⟦ Ξ» ‍ 𝜎1 ⟧" + , " 40-1C-00-00-00-00-00-00" + , " 𝜎2" + , " Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ )" + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧" + , " " + , "" + ] + + -- The fact a 'symbolize' line knows about a symbol is an element of + -- its own, next to '' and '': the symbol stands in the + -- attribute a reader joins lines on and the data it stands for is the + -- text, so a consumer reads a constant off the markup without parsing + -- πœ‘ (#1269) + it "writes what is known about a symbol as an element of its own" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withLambdasOf (T.pack "- Ξ»: L_stand\n morph:\n 𝑛1: $.x\n symbolize:\n 𝑛2: 𝑛1\n 𝑛: ⟦ z ↦ 𝑛2 ⟧\n") $ \stands -> + withStdin "⟦ y ↦ ⟦ x ↦ ⟦ Ξ” ‍ 01- ⟧, Ξ» ‍ L_stand ⟧.z ⟧" $ + testCLISucceeded ["morph", "--symbolic=" ++ stands, "--locator=Q.y", "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , " " + , " ⟦ Ξ” ‍ 01- ⟧" + , " 01-" + , " ⟦ Ξ» ‍ 𝜎1 ⟧" + , " ⟦ z ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧" + , " ⟦ z ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧" + , " " + , "" + ] + + -- What a 'join' line knows about the symbol it minted is an element of + -- its own too, the way the fact a 'symbolize' line writes is: the + -- fresh symbol stands in the attribute a reader joins lines on and the + -- two symbols it was minted for are the text, in the order the line + -- lists the metas it joins. The meta it binds is a '' like every + -- other meta of the firing (#1246). The branches differ under Ο†, that + -- being where the value of a branch is reached and so the only place a + -- join looks at all (#1293) + it "writes what a 'join' line knows as an element of its own" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withLambdasOf (T.pack "- Ξ»: L_fork\n morph:\n 𝑛1: $.a\n 𝑛2: $.b\n join:\n 𝑛3: [𝑛1, 𝑛2]\n 𝑛: 𝑛3\n") $ \forks -> + withStdin "⟦ y ↦ ⟦ a ↦ ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧, b ↦ ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ⟧, Ξ» ‍ L_fork ⟧.Ο† ⟧" $ + testCLISucceeded ["morph", "--symbolic=" ++ forks, "--locator=Q.y", "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , " " + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧" + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ⟧" + , " 𝜎1 𝜎2" + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎3 ⟧ ⟧" + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎3 ⟧ ⟧" + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎3 ⟧ ⟧" + , " " + , "" + ] + + -- Which symbols a firing minted is a fact about the firing and not a + -- property of one term of it, so each of them stands in a record of + -- its own, the way what is known about a symbol does: an answer + -- minting two writes two, and nothing is left to guess which of the + -- two an attribute summarizing the term would have named (#1280) + it "writes one 'minted' element per symbol the answer asked for" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withLambdasOf (T.pack "- Ξ»: L_pair\n morph:\n 𝑛1: $.x\n 𝑛: ⟦ left ↦ ⟦ Ξ» ‍ 𝜎 ⟧, right ↦ ⟦ Ξ» ‍ 𝜎 ⟧ ⟧\n") $ \pairs -> + withStdin "⟦ y ↦ ⟦ x ↦ ⟦ Ξ” ‍ 01- ⟧, Ξ» ‍ L_pair ⟧.left ⟧" $ + testCLISucceeded ["morph", "--symbolic=" ++ pairs, "--locator=Q.y", "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , " " + , " ⟦ Ξ” ‍ 01- ⟧" + , " 𝜎1" + , " 𝜎2" + , " ⟦ left ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, right ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ⟧" + , " ⟦ left ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, right ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ⟧" + , " " + , "" + ] + + -- An entry answering a meta it already bound asks for no symbol of its + -- own, so its block holds no 'minted' at all: the records say what the + -- firing did and never stand empty to say that it did nothing (#1280) + it "writes no 'minted' element for a firing minting nothing" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withLambdasOf (T.pack "- Ξ»: L_keep\n morph:\n 𝑛1: $.x\n 𝑛: ⟦ z ↦ 𝑛1 ⟧\n") $ \keeps -> + withStdin "⟦ y ↦ ⟦ x ↦ ⟦ Ξ” ‍ 01- ⟧, Ξ» ‍ L_keep ⟧.z ⟧" $ + testCLISucceeded ["morph", "--symbolic=" ++ keeps, "--locator=Q.y", "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , " " + , " ⟦ Ξ” ‍ 01- ⟧" + , " ⟦ z ↦ ⟦ Ξ” ‍ 01- ⟧ ⟧" + , " ⟦ z ↦ ⟦ Ξ” ‍ 01- ⟧ ⟧" + , " " + , "" + ] + + -- A firing taken while an operand of another was coming down stands + -- inside that firing's element, which is where the indented tree of + -- the text format stands it too + it "nests a firing an operand took inside the firing that asked" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withStdin nested $ + testCLISucceeded ["dataize", symbolic, "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , " " + , " 40-14-00-00-00-00-00-00" + , " " + , " 40-18-00-00-00-00-00-00" + , " 40-1C-00-00-00-00-00-00" + , " 𝜎1" + , " Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )" + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧" + , " " + , " ⟦ Ξ» ‍ 𝜎1 ⟧" + , " 𝜎2" + , " Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ )" + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧" + , " " + , "" + ] + + -- Nothing fired, so the element stands alone and nothing opens under + -- it, exactly as '?(…)' stands alone in the text format; the formation + -- 𝔼 was asked about stands as the text of it, the way the comment of + -- the text format carries it (#1300) + it "records a Ξ» function no entry answers as a childless element" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ times(x) -> [[ L> L_number_times ]], nope -> [[ L> L_number_nope ]] ]], @ -> 2.times(3).nope ]]" $ + testCLISucceeded ["dataize", symbolic, "--partial", "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , " " + , " 40-00-00-00-00-00-00-00" + , " 40-08-00-00-00-00-00-00" + , " 𝜎1" + , " Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )" + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧, nope ↦ ⟦ Ξ» ‍ L_number_nope ⟧ ⟧" + , " " + , " ⟦ Ξ» ‍ L_number_nope ⟧" + , "" + ] + + -- The root is named after the judgment the run ran, the way every + -- record under it is named after the judgment it carries, and the term + -- the run was aimed at stands in its one attribute: a morphing opens + -- 'morph' where the text format opens 𝕄(Ξ¦.x) (#1279) + it "names the root after the judgment a morphing ran" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withStdin "[[ x -> [[ L> L_number_nope ]].foo ]]" $ + testCLISucceeded ["morph", "--locator=Q.x", "--partial", "--protocol=" ++ path, "--quiet"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , " ⟦ Ξ» ‍ L_number_nope, ρ ↦ βˆ… ⟧" + , "" + ] + + -- A document a parser chokes on is worth nothing, so what the run left + -- open is closed on the way out and not by the last record: a run that + -- dies half-way through a derivation still leaves the firings it paid + -- for, inside elements that end + it "closes the document even when the run fails" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ times(x) -> [[ L> L_number_times ]], nope -> [[ L> L_number_nope ]] ]], @ -> 2.times(3).nope ]]" $ + testCLIFailed ["dataize", symbolic, "--protocol=" ++ path] ["No entry of --symbolic answers"] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , " " + , " 40-00-00-00-00-00-00-00" + , " 40-08-00-00-00-00-00-00" + , " 𝜎1" + , " Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1, ρ ↦ βˆ… ⟧ )" + , " ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1, ρ ↦ βˆ… ⟧, times ↦ ⟦ x ↦ βˆ…, Ξ» ‍ L_number_times, ρ ↦ βˆ… ⟧, nope ↦ ⟦ Ξ» ‍ L_number_nope, ρ ↦ βˆ… ⟧, ρ ↦ Ξ¦ ⟧" + , " " + , " ⟦ Ξ» ‍ L_number_nope, ρ ↦ ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1, ρ ↦ βˆ… ⟧, times ↦ ⟦ x ↦ βˆ…, Ξ» ‍ L_number_times, ρ ↦ βˆ… ⟧, nope ↦ ⟦ Ξ» ‍ L_number_nope, ρ ↦ βˆ… ⟧, ρ ↦ Ξ¦ ⟧ ⟧" + , "" + ] + + -- A 'morph' operand 𝕄 answered the terminator for says what it is by + -- being βŠ₯ and nothing else, the way every other bound meta says what + -- it is by its own term. The entry answers with a fresh symbol and the + -- dispatch '.foo' then stands on it, so the run ends on the symbol the + -- way it ends on a Ξ» name nothing answers, and the markup carries that + -- site too (#1287) + it "writes the terminator as the term a meta was bound to" $ + withTempFile "protocolXXXXXX.xml" $ \(path, stream) -> do + hClose stream + withLambdasOf (T.pack "- Ξ»: L_pick\n morph:\n 𝑛1: ΞΎ.absent\n 𝑛: ⟦ Ξ» ‍ 𝜎 ⟧\n") $ \picks -> + withStdin "[[ x -> [[ here -> [[ ]], L> L_pick ]].foo ]]" $ + testCLIFailed ["morph", "--symbolic=" ++ picks, "--locator=Q.x", "--protocol=" ++ path, "--quiet", "--hide-rho"] ["No entry of --symbolic answers the Ξ» function '𝜎1'"] + records <- readUtf8 path + lines records + `shouldBe` [ "" + , "" + , " " + , " βŠ₯" + , " 𝜎1" + , " ⟦ Ξ» ‍ 𝜎1 ⟧" + , " ⟦ Ξ» ‍ 𝜎1 ⟧" + , " " + , " ⟦ Ξ» ‍ 𝜎1 ⟧" + , "" + ] + + -- The extension decides and nothing else, so a name ending in + -- anything but '.xml' keeps the indented text it has always written + it "keeps writing text when the file is named anything else" $ + withTempFile "protocolXXXXXX.xmir" $ \(path, stream) -> do + hClose stream + withStdin sum' $ + testCLISucceeded ["dataize", symbolic, "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + take 1 (lines records) `shouldBe` ["𝔻(Ξ¦)"] + + -- A Ξ» function no entry of the '--symbolic' file answers cannot fire β€” a + -- placeholder such as ⟦ Ξ» ‍ Sym_arg_0 ⟧ standing in for a data input, or + -- an operation the caller left out of its file on purpose. The run used + -- to die on it, discarding what it had already evaluated (#1060) + describe "--partial" $ do + let stuck = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ times(x) -> [[ L> L_number_times ]], nope -> [[ L> L_number_nope ]] ]], @ -> 2.times(3).nope ]]" + dispatched = "[[ foo -> [[ bar -> [[ L> L_number_nope ]] ]], @ -> Q.foo.bar ]]" + it "fails on a Ξ» function that cannot fire without the flag" $ + withStdin stuck $ + testCLIFailed + ["dataize", symbolic, "--sweet", "--hide-rho"] + ["No entry of --symbolic answers the Ξ» function 'L_number_nope'"] + + it "prints the residue with the stuck application intact and exits successfully" $ + withStdin stuck $ + testCLISucceeded + ["dataize", symbolic, "--partial", "--sweet", "--hide-rho"] + ["⟦ Ξ» ‍ L_number_nope ⟧"] + + -- What the firing before the stuck one answered is a symbol, and the + -- residue carries it where the value nobody worked out belongs + it "keeps what was evaluated before the stuck site in the residue" $ + withStdin stuck $ + testCLISucceeded + ["dataize", symbolic, "--partial", "--sweet"] + ["Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧"] + + it "records every firing before the stuck site in --protocol" $ + withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do + hClose stream + withStdin stuck $ + testCLISucceeded ["dataize", symbolic, "--partial", "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "𝔻(Ξ¦)" + , " 𝔼(L_number_times) # 𝕄(Ξ¦)" + , " 𝛿1.1 := 40-00-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ)" + , " 𝛿2.1 := 40-08-00-00-00-00-00-00 # 𝔻(ΞΎ.x)" + , " 𝑛.1.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) # 𝑛" + , " 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧, nope ↦ ⟦ Ξ» ‍ L_number_nope ⟧ ⟧ # 𝕄(𝑛.1.1)" + , " ?(L_number_nope) # 𝔻(⟦ Ξ» ‍ L_number_nope ⟧)" + ] + + it "still prints bytes when nothing gets stuck" $ + withStdin "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6) ]]" $ + testCLISucceeded ["dataize", symbolic, "--partial"] ["40-45-00-00-00-00-00-00"] + + -- The residual is an arbitrary formation, and a multi-binding + -- is exactly what XMIR now carries: one per binding (#1076) + it "prints the residual to XMIR, with its real listing by default" $ + withStdin dispatched $ + testCLISucceeded + ["dataize", symbolic, "--partial", "--output=xmir"] + ["L_number_nope", "", "⟦"] + + it "honors --hide-rho and --omit-listing when printing the residual to XMIR" $ + withStdin dispatched $ + testCLISucceeded + ["dataize", symbolic, "--partial", "--output=xmir", "--hide-rho", "--omit-listing"] + ["L_number_nope", "line(s)"] + + -- A symbol is a name of the calculus, and XMIR carries no notation for + -- one, so a residue standing for an unknown cannot be printed as XMIR + it "cannot print a residue carrying a symbol as XMIR" $ + withStdin stuck $ + testCLIFailed + ["dataize", symbolic, "--partial", "--output=xmir"] + ["XMIR does not support such bindings"] + + it "prints the chain of steps ending in the residue with --sequence" $ + withStdin stuck $ + testCLISucceeded + ["dataize", symbolic, "--partial", "--sequence", "--sweet", "--hide-rho", "--flat"] + ["2.times( 3 ).nope", "⟦ Ξ» ‍ L_number_nope ⟧"] + + it "still stops on the terminator βŠ₯, since a wrong operand is not a stuck Ξ» function" $ + withStdin "[[ ]]" $ + testCLIFailed ["dataize", "--partial"] ["terminator βŠ₯"] + + -- Which Ξ» functions exist is not phino's business: the file given with + -- '--symbolic' decides, and phino carries none of its own + describe "--symbolic" $ do + let sum' = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6) ]]" + -- Nothing is worked out: the entry answers a number standing for the sum + -- and the run brings that symbol down to the datum every symbol answers + it "fires the Ξ» function an entry of the file answers" $ + withStdin sum' $ + testCLISucceeded ["dataize", symbolic] ["40-45-00-00-00-00-00-00"] + + it "gets stuck on every Ξ» function when it is not given" $ + withStdin sum' $ + testCLIFailed ["dataize"] ["No entry of --symbolic answers the Ξ» function 'L_number_plus'"] + + it "fails when the file is not there" $ + withStdin sum' $ + testCLIFailed ["dataize", "--symbolic=no-such-file.yaml"] ["no-such-file.yaml"] + + -- A file that is no list of entries is refused where it is read, which + -- is before the input is even parsed, rather than when a Ξ» function of + -- it fires + it "fails on a file that carries no entries at all, before dataizing anything" $ + withTempFileContent "symbolicXXXXXX.yaml" "nope: true\n" $ \path -> + withStdin sum' $ + testCLIFailed ["dataize", "--symbolic=" ++ path] ["cannot be read"] + + -- An expression the program does not carry is reduced inside it all the + -- same: '--inside' binds it to a synthetic attribute of the universe and + -- aims the run at it, which is what the 'dataize' block of a Ξ» function + -- does for every operand it names + describe "--inside" $ do + let universe = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> [[ D> 01- ]] ]]" + it "dataizes an expression the input does not contain" $ + withStdin universe $ + testCLISucceeded ["dataize", symbolic, "--inside=5.plus( 6 )"] ["40-45-00-00-00-00-00-00"] + + -- The expression is normalized first, so a dispatch off a formation β€” + -- the very shape an operand reaches 𝔻 as, '⟦ x ↦ 6, ρ ↦ 5 ⟧.x' β€” + -- reduces too + it "normalizes what it is handed before dataizing it" $ + withStdin universe $ + testCLISucceeded ["dataize", "--inside=[[ x -> [[ D> 2A- ]] ]].x"] ["2A-"] + + it "morphs inside the universe just as it dataizes inside it" $ + withStdin universe $ + testCLISucceeded ["morph", symbolic, "--inside=5.plus( 6 )", "--sweet", "--hide-rho", "--flat"] ["⟦ x ↦ 6, Ξ» ‍ L_number_plus ⟧"] + + it "cannot be used together with --locator" $ + withStdin universe $ + testCLIFailed ["dataize", "--inside=Q.@", "--locator=Q.@"] ["--inside and --locator cannot be used together"] + + it "fails when the input expression is not a formation" $ + withStdin "Q.x" $ + testCLIFailed ["dataize", "--inside=Q.x"] ["--inside requires the input expression to be a formation"] + + describe "fails" $ do + it "with --output != latex and --nonumber" $ + withStdin "" $ + testCLIFailed + ["dataize", "--nonumber", "--output=xmir"] + ["The --nonumber option can stay together with --output=latex only"] + + it "with --omit-listing and --output != xmir" $ + withStdin "" $ + testCLIFailed + ["dataize", "--omit-listing", "--output=phi"] + ["--omit-listing"] + + it "with --omit-comments and --output != xmir" $ + withStdin "" $ + testCLIFailed + ["dataize", "--omit-comments", "--output=phi"] + ["--omit-comments"] + + it "with --expression and --output != latex" $ + withStdin "" $ + testCLIFailed + ["dataize", "--expression=foo", "--output=phi"] + ["--expression option can stay together with --output=latex only"] + + it "with --label and --output != latex" $ + withStdin "" $ + testCLIFailed + ["dataize", "--label=foo", "--output=phi"] + ["--label option can stay together with --output=latex only"] + + it "with wrong --hide option" $ + withStdin "" $ + testCLIFailed + ["dataize", "--hide=Q.x(Q.y)"] + ["[ERROR]: Invalid set of arguments: Only dispatch expression", "but given: Ξ¦.x( Ξ¦.y )"] + + it "with wrong --show option" $ + withStdin "" $ + testCLIFailed + ["dataize", "--show=Q.x(Q.y)"] + ["[ERROR]:", "Only dispatch expression started with Ξ¦ (or Q) can be used in --show"] + + it "with wrong --locator option" $ + withStdin "" $ + testCLIFailed + ["dataize", "--locator=Q.x(Q.y)"] + ["[ERROR]:", "Only dispatch expression started with Ξ¦ (or Q) can be used in --locator"] + + it "with wrong --focus option" $ + withStdin "" $ + testCLIFailed + ["dataize", "--focus=Q.x(Q.y)"] + ["[ERROR]:", "Only dispatch expression started with Ξ¦ (or Q) can be used in --focus"] + + it "accepts --depth-sensitive" $ + withStdin "[[ D> 01- ]]" $ + testCLISucceeded ["dataize", "--depth-sensitive"] ["01-"] + + -- 𝕄 was reachable only from inside 𝔻, through the 'norm' rule of the + -- dataization relation, so there was no way to ask phino for 𝕄(n, Ξ¦) on its + -- own (#1114) + describe "morph" $ do + -- Two chained Ξ» function calls: the inner fires under 'ml', because '.plus' + -- is dispatched on its result, while the outer application is saturated but + -- bare, so 'mf' hands it back and firing it is 𝔻's job + let chained = "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6).plus(7) ]]" + it "prints help" $ + testCLISucceeded ["morph", "--help"] ["Morph the πœ‘-expression"] + + it "hands the top formation back untouched under the default locator" $ + withStdin "[[ D> 01- ]]" $ + testCLISucceeded ["morph", "--flat", "--hide-rho"] ["⟦ Ξ” ‍ 01- ⟧"] + + it "stops at the bare saturated Ξ»-formation" $ + withStdin chained $ + testCLISucceeded + ["morph", symbolic, "--locator=Q.@", "--sweet", "--hide-rho", "--flat"] + ["⟦ x ↦ 7, Ξ» ‍ L_number_plus ⟧"] + + -- The same term under 𝔻, which insists on bytes and fires what 𝕄 left bare + it "leaves to dataize the firing that takes the same term to bytes" $ + withStdin chained $ + testCLISucceeded ["dataize", symbolic] ["40-45-00-00-00-00-00-00"] + + -- 'mf' hands a formation back as it is, so '--locator' is how one aims 𝕄 at + -- a subterm worth navigating: here it resolves Ξ¦ against the universe and + -- peels the dispatch through 𝒩 + it "morphs the subterm --locator aims at" $ + withStdin "[[ ex -> Q.x, x -> [[ D> 42- ]] ]]" $ + testCLISucceeded ["morph", "--locator=Q.ex", "--flat", "--hide-rho"] ["⟦ Ξ” ‍ 42- ⟧"] + + -- 𝕄 is total and 𝔻 is not: where the derivation dies, 𝕄 answers βŠ₯ ('xi' + -- here) and the run succeeds, while 𝔻 has no bytes to give and fails + it "prints βŠ₯ instead of failing the run" $ + withStdin "[[ x -> $ ]]" $ + testCLISucceeded ["morph", "--locator=Q.x"] ["βŠ₯"] + + it "fails to dataize what it morphs to βŠ₯" $ + withStdin "[[ x -> $ ]]" $ + testCLIFailed ["dataize", "--locator=Q.x"] ["terminator βŠ₯"] + + -- The chain carries the spine: the morphing rules that reduced the term + -- ('maa', then the terminal 'mf') with the normalization steps they spliced + -- in ('alpha', 'copy'). The 'ml' firing of the inner call is not there by + -- design β€” it happens in a side premise, which reduces on a chain of its + -- own and discards it + it "prints the chain of morphing steps with --sequence" $ + withStdin chained $ + testCLISucceeded + ["morph", symbolic, "--locator=Q.@", "--sequence", "--headers", "--sweet", "--hide-rho", "--flat"] + [ "Rule 'maa'" + , "Rule 'alpha'" + , "Rule 'copy'" + , "Rule 'mf'" + , "⟦ x ↦ 7, Ξ» ‍ L_number_plus ⟧" + ] + + it "does not print the result with --quiet" $ + withStdin "[[ D> 01- ]]" $ + testCLISucceeded ["morph", "--quiet"] [] + + it "records the Ξ» functions it fires with --protocol" $ + withTempFile "protocolXXXXXX.txt" $ \(path, stream) -> do + hClose stream + withStdin chained $ + testCLISucceeded ["morph", symbolic, "--locator=Q.@", "--protocol=" ++ path, "--quiet", "--sweet", "--hide-rho"] [] + records <- readUtf8 path + lines records + `shouldBe` [ "𝕄(Ξ¦.Ο†)" + , " 𝔼(L_number_plus) # 𝕄(Ξ¦.Ο†)" + , " 𝛿1.1 := 40-14-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ)" + , " 𝛿2.1 := 40-18-00-00-00-00-00-00 # 𝔻(ΞΎ.x)" + , " 𝑛.1.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) # 𝑛" + , " 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧ # 𝕄(𝑛.1.1)" + ] + + it "saves morphing steps to dir with --steps-dir" $ + withTempDirectory "phino-steps-morph" $ \dir -> + withStdin chained $ do + testCLISucceeded + ["morph", symbolic, "--locator=Q.@", "--steps-dir=" ++ dir, "--sweet", "--hide-rho", "--flat"] + ["⟦ x ↦ 7, Ξ» ‍ L_number_plus ⟧"] + steps <- sort <$> listDirectory dir + steps `shouldBe` map (\n -> printf "%05d.phi" (n :: Int)) [1 .. length steps] + length steps `shouldSatisfy` (> 0) + + it "accepts --seed, --shuffle and --depth-sensitive" $ + withStdin "[[ D> 01- ]]" $ + testCLISucceeded ["morph", "--seed=7", "--shuffle", "--depth-sensitive", "--flat", "--hide-rho"] ["⟦ Ξ” ‍ 01- ⟧"] + + -- The division 𝔻 cannot finish, whatever '--max-steps' it is given (#1052), + -- is no work at all for 𝕄: the term is already a formation, so 'mf' hands + -- it back and the Ξ» function is never fired + it "returns the Ξ»-formation dataize cannot finish on" $ + withStdin "⟦ @ ↦ ⟦ Ξ» ‍ L_number_div, ρ ↦ ⟦ Ξ” ‍ 40-45-00-00-00-00-00-00 ⟧, x ↦ ⟦ Ξ” ‍ 40-00-00-00-00-00-00-00 ⟧ ⟧ ⟧" $ + testCLISucceeded + ["morph", "--locator=Q.@", "--max-steps=40", "--flat", "--hide-rho"] + ["⟦ Ξ» ‍ L_number_div"] + + -- '--max-steps' bounds the 𝕄 recursion just as it bounds the 𝕄/𝔻 one + it "fails once the --max-steps budget is spent" $ + withStdin chained $ + testCLIFailed + ["morph", "--locator=Q.@", "--max-steps=3"] + ["[ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=3"] + + -- '--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" $ + withStdin "⟦ Ο† ↦ 5.gt(Ξ¦.nan) ⟧" $ + testCLISucceeded + ["morph", "--locator=Q.@", "--max-steps=10", "--partial", "--flat", "--hide-rho", "--sweet"] + ["5.gt( Ξ¦.nan )"] + + -- 𝕄 never fires a bare Ξ»-formation, so only the Ξ» functions sitting under + -- a dispatch ('ml') can get stuck; '--partial' parks them as under 𝔻 + describe "--partial" $ do + let stuck = "[[ @ -> [[ L> Sym_arg_0 ]].foo ]]" + it "fails on a Ξ» function that cannot fire without the flag" $ + withStdin stuck $ + testCLIFailed ["morph", "--locator=Q.@"] ["No entry of --symbolic answers the Ξ» function 'Sym_arg_0'"] + + it "prints the residue with the stuck application intact and exits successfully" $ + withStdin stuck $ + testCLISucceeded + ["morph", "--locator=Q.@", "--partial", "--flat", "--hide-rho"] + ["⟦ Ξ» ‍ Sym_arg_0 ⟧.foo"] + + -- 𝕄 stops at the first formation and hands its bindings back as they were + -- written, so a program whose parts nothing demands is never reduced; + -- '--deep' enters every binding and finishes what 'mf' left, while what no + -- Ξ» function touched keeps its name and the answer stays a program (#1124) + describe "--deep" $ do + let program = + "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, \ + \number(Ο†) -> [[ times(x) -> [[ L> L_number_times ]] ]], \ + \bar(x) -> [[ L> L_bar ]], \ + \demo -> [[ foo -> [[ n -> 3, @ -> Q.bar( $.n.times( 5 ).times( 7 ) ) ]] ]] ]]" + it "answers the formation as it was written without the flag" $ + withStdin program $ + testCLISucceeded + ["morph", symbolic, "--inside=Q.demo.foo", "--sweet", "--hide-rho", "--flat"] + ["⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( n.times( 5 ).times( 7 ) ) ⟧"] + + -- No entry answers 'L_bar', so the call to it stays as written and keeps + -- its name, while the arithmetic in the argument nothing demands folds + -- into the symbol standing for the number nobody worked out + it "reduces every binding it can and leaves the rest in place" $ + withStdin program $ + testCLISucceeded + ["morph", symbolic, "--deep", "--inside=Q.demo.foo", "--sweet", "--hide-rho", "--flat"] + ["⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧ ) ⟧"] + + -- The same term the run above stops at as a bare Ξ»-formation: 'mf' leaves + -- it to 𝔻, and the walk fires it instead of demanding bytes + it "fires the bare saturated Ξ»-formation mf hands back" $ + withStdin chained $ + testCLISucceeded + ["morph", symbolic, "--deep", "--locator=Q.@", "--sweet", "--hide-rho", "--flat"] + ["⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧"] + + -- The default locator walks the whole program: the method table of the + -- object model keeps every one of its Ξ»-formations, since not one of them + -- is saturated, while the one place that can be computed is + it "keeps the object model intact while it folds the program" $ + withStdin program $ + testCLISucceeded + ["morph", symbolic, "--deep", "--sweet", "--hide-rho", "--flat"] + [ "number(Ο†) ↦ ⟦ times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧" + , "demo ↦ ⟦ foo ↦ ⟦ n ↦ 3, Ο† ↦ Ξ¦.bar( ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧ ⟧ ) ⟧ ⟧" + ] + + it "keeps a binding whose spine got stuck with --partial" $ + withStdin "[[ x -> [[ L> Sym_arg_0 ]].foo ]]" $ + testCLISucceeded + ["morph", "--deep", "--partial", "--sweet", "--hide-rho", "--flat"] + ["⟦ x ↦ ⟦ Ξ» ‍ Sym_arg_0 ⟧.foo ⟧"] + + it "fails on that same spine without --partial" $ + withStdin "[[ x -> [[ L> Sym_arg_0 ]].foo ]]" $ + testCLIFailed ["morph", "--deep"] ["No entry of --symbolic answers the Ξ» function 'Sym_arg_0'"] + + -- The step budget used to be the only thing ending the 𝕄/𝔻 recursion, so an + -- entry answering with a firing of itself spent the whole of it and then + -- failed on the limit; '--acyclic' stops the moment morphing comes back to a + -- term a frame above it is already reducing and parks that site the way + -- '--partial' parks a Ξ» function that cannot fire + describe "--acyclic" $ do + let looping = "⟦ x ↦ ⟦ Ξ» ‍ L_loop ⟧.foo ⟧" + it "spends the whole budget and fails on the limit without the flag" $ + loopingLambdas $ \endless -> + withStdin looping $ + testCLIFailed + ["morph", "--symbolic=" ++ endless, "--locator=Q.x", "--max-steps=40"] + ["[ERROR]: Dataization did not finish before reaching the limit of steps: --max-steps=40"] + + -- The budget here is far larger than the one the run above failed on, so + -- what ends this one is the cut and not the limit + it "prints the residue and exits successfully with the flag" $ + loopingLambdas $ \endless -> + withStdin looping $ + testCLISucceeded + ["morph", "--symbolic=" ++ endless, "--locator=Q.x", "--acyclic", "--max-steps=4000", "--flat", "--hide-rho"] + ["⟦ Ξ» ‍ L_loop ⟧.foo"] + + -- The guard reads nothing but the terms the frames above it are reducing, + -- so a run that never comes back to one answers exactly as it did before + it "answers a terminating program the same way with the flag" $ + withStdin chained $ + testCLISucceeded + ["morph", symbolic, "--acyclic", "--locator=Q.@", "--sweet", "--hide-rho", "--flat"] + ["⟦ x ↦ 7, Ξ» ‍ L_number_plus ⟧"] + + -- The deep walk parks the one binding that loops and walks on, the way it + -- walks on past a Ξ» function '--partial' could not fire, so what the loop + -- costs is that binding and not the rest of the program + it "parks the looping binding and keeps walking with --deep" $ + loopingLambdas $ \endless -> + withStdin "⟦ x ↦ ⟦ Ξ» ‍ L_loop ⟧.foo, y ↦ ⟦ z ↦ ⟦⟧ ⟧ ⟧" $ + testCLISucceeded + ["morph", "--symbolic=" ++ endless, "--deep", "--acyclic", "--max-steps=4000", "--flat", "--hide-rho"] + ["⟦ x ↦ ⟦ Ξ» ‍ L_loop ⟧.foo, y ↦ ⟦ z ↦ ⟦⟧ ⟧ ⟧"] + + describe "fails" $ do + it "with --output != latex and --nonumber" $ + withStdin "" $ + testCLIFailed + ["morph", "--nonumber", "--output=xmir"] + ["The --nonumber option can stay together with --output=latex only"] + + it "with --show used more than once" $ + withStdin "" $ + testCLIFailed + ["morph", "--show=Q.a", "--show=Q.b"] + ["The option --show can be used only once"] + + it "with wrong --locator option" $ + withStdin "" $ + testCLIFailed + ["morph", "--locator=Q.x(Q.y)"] + ["[ERROR]:", "Only dispatch expression started with Ξ¦ (or Q) can be used in --locator"] + + describe "explain" $ do + it "prints help" $ + testCLISucceeded + ["explain", "--help"] + ["Explain built-in morphing rules", "Explain built-in dataization rules", "Explain built-in contextualization rules"] + + it "explains single rule" $ + testCLISucceeded + ["explain", "--rule=resources/normalize/copy.yaml"] + [ unlines + [ "\\phinoNormalizationRule{copy}" + , " { [[ B_1, \\tau -> ?, B_2 ]] ( \\tau -> k ) }" + , " { [[ B_1, \\tau -> k, B_2 ]] }" + , " { }" + , " { }" + ] + ] + + it "explains single rule with a label" $ + testCLISucceeded + ["explain", rule "labeled.yaml"] + [ unlines + [ "\\phinoNormalizationRule[\\lambda]{copy}" + , " { [[ B_1, \\tau -> ?, B_2 ]] ( \\tau -> k ) }" + , " { [[ B_1, \\tau -> k, B_2 ]] }" + , " { }" + , " { }" + ] + ] + + it "explains multiple rules" $ + testCLISucceeded + ["explain", "--rule=resources/normalize/copy.yaml", "--rule=resources/normalize/alpha.yaml"] + ["\\phinoNormalizationRule{copy}", "\\phinoNormalizationRule{alpha}"] + + it "reproduces the same shuffle order for the same --seed" $ do + let args = + [ "explain" + , "--shuffle" + , "--seed=42" + , rule "swap-a.yaml" + , rule "swap-b.yaml" + ] + (firstRun, _) <- withStdout (runCLI args) + (secondRun, _) <- withStdout (runCLI args) + firstRun `shouldBe` secondRun + + it "accepts --seed flag" $ + testCLISucceeded + ["explain", "--seed=7", "--normalize"] + ["\\phinoNormalizationRule{alpha}"] + + it "explains normalization rules" $ + testCLISucceeded + ["explain", "--normalize"] + [ unlines + [ "\\phinoNormalizationRule{alpha}" + , " { [[ B_1, \\tau -> ?, B_2 ]] ( \\phiTerminal{\\alpha_{i}} -> e ) }" + , " { [[ B_1, \\tau -> ?, B_2 ]] ( \\tau -> e ) }" + , " { i = \\vert \\overline{ B_1 } \\vert \\;\\text{and}\\; \\tau \\not= \\phiTerminal{\\rho} }" + , " { }" + , "\\phinoNormalizationRule{amiss}" + , " { [[ B ]] ( \\phiTerminal{\\alpha_{i}} -> e ) }" + , " { T }" + , " { \\vert \\overline{ B } \\vert \\leq i }" + , " { }" + , "\\phinoNormalizationRule{copy}" + , " { [[ B_1, \\tau -> ?, B_2 ]] ( \\tau -> k ) }" + , " { [[ B_1, \\tau -> k, B_2 ]] }" + , " { }" + , " { }" + , "\\phinoNormalizationRule{dc}" + , " { T ( \\tau -> e ) }" + , " { T }" + , " { }" + , " { }" + , "\\phinoNormalizationRule{dca}" + , " { T ( \\phiTerminal{\\alpha_{i}} -> e ) }" + , " { T }" + , " { }" + , " { }" + , "\\phinoNormalizationRule{dd}" + , " { T . \\tau }" + , " { T }" + , " { }" + , " { }" + , "\\phinoNormalizationRule{dl}" + , " { [[ B_1, L> F, B_2 ]] }" + , " { T }" + , " { D \\in B_1 \\;\\text{or}\\; D \\in B_2 }" + , " { }" + , "\\phinoNormalizationRule{dot}" + , " { [[ B_1, \\tau -> n, B_2 ]] . \\tau }" + , " { e_2 ( \\phiTerminal{\\rho} -> [[ B_1, \\tau -> n, B_2 ]] ) }" + , " { [[ B_1, \\tau -> n, B_2 ]] \\not= e_1 }" + , " { \\phinoContextualize{ n }{ [[ B_1, B_2 ]] }{ e_2 } }" + , "\\phinoNormalizationRule{dotg}" + , " { [[ B_1, \\tau -> n, B_2 ]] . \\tau }" + , " { e_2 ( \\phiTerminal{\\rho} -> Q ) }" + , " { [[ B_1, \\tau -> n, B_2 ]] = e_1 }" + , " { \\phinoContextualize{ n }{ [[ B_1, B_2 ]] }{ e_2 } }" + , "\\phinoNormalizationRule{miss}" + , " { [[ B ]] ( \\tau -> e ) }" + , " { T }" + , " { \\tau \\notin B }" + , " { }" + , "\\phinoNormalizationRule{null}" + , " { [[ B_1, \\tau -> ?, B_2 ]] . \\tau }" + , " { T }" + , " { }" + , " { }" + , "\\phinoNormalizationRule{over}" + , " { [[ B_1, \\tau -> e_1, B_2 ]] ( \\tau -> e_2 ) }" + , " { T }" + , " { \\tau \\not= \\phiTerminal{\\rho} }" + , " { }" + , "\\phinoNormalizationRule{overa}" + , " { [[ B_1, \\tau -> e_1, B_2 ]] ( \\phiTerminal{\\alpha_{i}} -> e_2 ) }" + , " { T }" + , " { i = \\vert \\overline{ B_1 } \\vert \\;\\text{and}\\; \\tau \\not= \\phiTerminal{\\rho} }" + , " { }" + , "\\phinoNormalizationRule{stay}" + , " { [[ B_1, \\phiTerminal{\\rho} -> e_1, B_2 ]] ( \\phiTerminal{\\rho} -> e_2 ) }" + , " { [[ B_1, \\phiTerminal{\\rho} -> e_1, B_2 ]] }" + , " { }" + , " { }" + , "\\phinoNormalizationRule{stop}" + , " { [[ B ]] . \\tau }" + , " { T }" + , " { \\tau \\notin B \\;\\text{and}\\; @ \\notin B \\;\\text{and}\\; L \\notin B }" + , " { }" + ] + ] + + it "explains morphing rules" $ + testCLISucceeded + ["explain", "--morph"] + [ unlines + [ "\\begin{phinoMorphingInference}" + , " \\phinoName{dead}" + , " \\phinoConclusion{ \\phinoMorph{ T }{ e }{ s }{ T }{ s } }" + , "\\end{phinoMorphingInference}" + , "\\begin{phinoMorphingInference}" + , " \\phinoName{ma}" + , " \\phinoPremise{ \\phinoMorph{ n_1 }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , " \\phinoPremise{ \\phinoNormalize{ n_2 ( \\tau -> k ) }{ n_3 } }" + , " \\phinoPremise{ \\phinoMorph{ n_3 }{ e }{ s_2 }{ n_4 }{ s_3 } }" + , " \\phinoConclusion{ \\phinoMorph{ n_1 ( \\tau -> k ) }{ e }{ s_1 }{ n_4 }{ s_3 } }" + , "\\end{phinoMorphingInference}" + , "\\begin{phinoMorphingInference}" + , " \\phinoName{maa}" + , " \\phinoPremise{ \\phinoMorph{ n_1 }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , " \\phinoPremise{ \\phinoNormalize{ n_2 ( \\phiTerminal{\\alpha_{i}} -> k ) }{ n_3 } }" + , " \\phinoPremise{ \\phinoMorph{ n_3 }{ e }{ s_2 }{ n_4 }{ s_3 } }" + , " \\phinoConclusion{ \\phinoMorph{ n_1 ( \\phiTerminal{\\alpha_{i}} -> k ) }{ e }{ s_1 }{ n_4 }{ s_3 } }" + , "\\end{phinoMorphingInference}" + , "\\begin{phinoMorphingInference}" + , " \\phinoName{maad}" + , " \\phinoCondition{ \\phinoNotAbsolute{ n_1 } }" + , " \\phinoPremise{ \\phinoMorph{ T }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , " \\phinoConclusion{ \\phinoMorph{ n ( \\phiTerminal{\\alpha_{i}} -> n_1 ) }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , "\\end{phinoMorphingInference}" + , "\\begin{phinoMorphingInference}" + , " \\phinoName{mad}" + , " \\phinoCondition{ \\phinoNotAbsolute{ n_1 } }" + , " \\phinoPremise{ \\phinoMorph{ T }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , " \\phinoConclusion{ \\phinoMorph{ n ( \\tau -> n_1 ) }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , "\\end{phinoMorphingInference}" + , "\\begin{phinoMorphingInference}" + , " \\phinoName{md}" + , " \\phinoCondition{ \\phinoNotFormation{ n_1 } }" + , " \\phinoPremise{ \\phinoMorph{ n_1 }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , " \\phinoPremise{ \\phinoNormalize{ n_2 . \\tau }{ n_3 } }" + , " \\phinoPremise{ \\phinoMorph{ n_3 }{ e }{ s_2 }{ n_4 }{ s_3 } }" + , " \\phinoConclusion{ \\phinoMorph{ n_1 . \\tau }{ e }{ s_1 }{ n_4 }{ s_3 } }" + , "\\end{phinoMorphingInference}" + , "\\begin{phinoMorphingInference}" + , " \\phinoName{mf}" + , " \\phinoConclusion{ \\phinoMorph{ [[ B ]] }{ e }{ s }{ [[ B ]] }{ s } }" + , "\\end{phinoMorphingInference}" + , "\\begin{phinoMorphingInference}" + , " \\phinoName{mg}" + , " \\phinoPremise{ \\phinoMorph{ T }{ Q }{ s_1 }{ n }{ s_2 } }" + , " \\phinoConclusion{ \\phinoMorph{ Q }{ Q }{ s_1 }{ n }{ s_2 } }" + , "\\end{phinoMorphingInference}" + , "\\begin{phinoMorphingInference}" + , " \\phinoName{ml}" + , " \\phinoLabel{\\lambda}" + , " \\phinoPremise{ \\phinoEvaluate{ [[ B_1, L> F, B_2 ]] }{ e }{ s_1 }{ n_1 }{ s_2 } }" + , " \\phinoPremise{ \\phinoNormalize{ n_1 . \\tau }{ n_2 } }" + , " \\phinoPremise{ \\phinoMorph{ n_2 }{ e }{ s_2 }{ n_3 }{ s_3 } }" + , " \\phinoConclusion{ \\phinoMorph{ [[ B_1, L> F, B_2 ]] . \\tau }{ e }{ s_1 }{ n_3 }{ s_3 } }" + , "\\end{phinoMorphingInference}" + , "\\begin{phinoMorphingInference}" + , " \\phinoName{mphi}" + , " \\phinoLabel{\\varphi}" + , " \\phinoCondition{ @ \\in B \\;\\text{and}\\; \\tau \\notin B \\;\\text{and}\\; L \\notin B }" + , " \\phinoPremise{ \\phinoNormalize{ [[ B ]] . @ . \\tau }{ n_1 } }" + , " \\phinoPremise{ \\phinoMorph{ n_1 }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , " \\phinoConclusion{ \\phinoMorph{ [[ B ]] . \\tau }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , "\\end{phinoMorphingInference}" + , "\\begin{phinoMorphingInference}" + , " \\phinoName{universe}" + , " \\phinoLabel{\\Phi}" + , " \\phinoCondition{ e \\not= Q }" + , " \\phinoPremise{ \\phinoNormalize{ e }{ n_1 } }" + , " \\phinoPremise{ \\phinoMorph{ n_1 }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , " \\phinoConclusion{ \\phinoMorph{ Q }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , "\\end{phinoMorphingInference}" + , "\\begin{phinoMorphingInference}" + , " \\phinoName{xi}" + , " \\phinoPremise{ \\phinoMorph{ T }{ e }{ s_1 }{ n }{ s_2 } }" + , " \\phinoConclusion{ \\phinoMorph{ \\phiTerminal{\\xi} }{ e }{ s_1 }{ n }{ s_2 } }" + , "\\end{phinoMorphingInference}" + ] + ] + + it "explains dataization rules" $ + testCLISucceeded + ["explain", "--dataize"] + [ unlines + [ "\\begin{phinoDataizationInference}" + , " \\phinoName{box}" + , " \\phinoCondition{ [ D \\char44{} L ] \\cap \\lparen B_1 \\cup B_2 \\rparen = \\emptyset }" + , " \\phinoPremise{ \\phinoContextualize{ e_2 }{ [[ B_1, @ -> e_2, B_2 ]] }{ e_3 } }" + , " \\phinoPremise{ \\phinoNormalize{ e_3 }{ n } }" + , " \\phinoPremise{ \\phinoDataize{ n }{ e_1 }{ s_1 }{ \\delta }{ s_2 } }" + , " \\phinoConclusion{ \\phinoDataize{ [[ B_1, @ -> e_2, B_2 ]] }{ e_1 }{ s_1 }{ \\delta }{ s_2 } }" + , "\\end{phinoDataizationInference}" + , "\\begin{phinoDataizationInference}" + , " \\phinoName{delta}" + , " \\phinoLabel{\\Delta}" + , " \\phinoConclusion{ \\phinoDataize{ [[ B_1, D> \\delta, B_2 ]] }{ e }{ s }{ \\delta }{ s } }" + , "\\end{phinoDataizationInference}" + , "\\begin{phinoDataizationInference}" + , " \\phinoName{fire}" + , " \\phinoPremise{ \\phinoEvaluate{ [[ B_1, L> F, B_2 ]] }{ e }{ s_1 }{ n }{ s_2 } }" + , " \\phinoPremise{ \\phinoDataize{ n }{ e }{ s_2 }{ \\delta }{ s_3 } }" + , " \\phinoConclusion{ \\phinoDataize{ [[ B_1, L> F, B_2 ]] }{ e }{ s_1 }{ \\delta }{ s_3 } }" + , "\\end{phinoDataizationInference}" + , "\\begin{phinoDataizationInference}" + , " \\phinoName{none}" + , " \\phinoCondition{ [ D \\char44{} L \\char44{} @ ] \\cap B = \\emptyset }" + , " \\phinoPremise{ \\phinoDataize{ T }{ e }{ s_1 }{ \\delta }{ s_2 } }" + , " \\phinoConclusion{ \\phinoDataize{ [[ B ]] }{ e }{ s_1 }{ \\delta }{ s_2 } }" + , "\\end{phinoDataizationInference}" + , "\\begin{phinoDataizationInference}" + , " \\phinoName{norm}" + , " \\phinoCondition{ \\phinoNotFormation{ n_1 } \\;\\text{and}\\; n_1 \\not= T }" + , " \\phinoPremise{ \\phinoMorph{ n_1 }{ e }{ s_1 }{ n_2 }{ s_2 } }" + , " \\phinoPremise{ \\phinoDataize{ n_2 }{ e }{ s_2 }{ \\delta }{ s_3 } }" + , " \\phinoConclusion{ \\phinoDataize{ n_1 }{ e }{ s_1 }{ \\delta }{ s_3 } }" + , "\\end{phinoDataizationInference}" + ] + ] + + it "explains contextualization rules" $ + testCLISucceeded + ["explain", "--contextualize"] + [ unlines + [ "\\begin{phinoContextualizationInference}" + , " \\phinoName{ca}" + , " \\phinoPremise{ \\phinoContextualize{ n_1 }{ k }{ n_2 } }" + , " \\phinoPremise{ \\phinoContextualize{ e }{ k }{ n_3 } }" + , " \\phinoConclusion{ \\phinoContextualize{ n_1 ( \\tau -> e ) }{ k }{ n_2 ( \\tau -> n_3 ) } }" + , "\\end{phinoContextualizationInference}" + , "\\begin{phinoContextualizationInference}" + , " \\phinoName{caa}" + , " \\phinoPremise{ \\phinoContextualize{ n_1 }{ k }{ n_2 } }" + , " \\phinoPremise{ \\phinoContextualize{ e }{ k }{ n_3 } }" + , " \\phinoConclusion{ \\phinoContextualize{ n_1 ( \\phiTerminal{\\alpha_{i}} -> e ) }{ k }{ n_2 ( \\phiTerminal{\\alpha_{i}} -> n_3 ) } }" + , "\\end{phinoContextualizationInference}" + , "\\begin{phinoContextualizationInference}" + , " \\phinoName{cd}" + , " \\phinoPremise{ \\phinoContextualize{ n_1 }{ k }{ n_2 } }" + , " \\phinoConclusion{ \\phinoContextualize{ n_1 . \\tau }{ k }{ n_2 . \\tau } }" + , "\\end{phinoContextualizationInference}" + , "\\begin{phinoContextualizationInference}" + , " \\phinoName{cf}" + , " \\phinoConclusion{ \\phinoContextualize{ [[ B ]] }{ k }{ [[ B ]] } }" + , "\\end{phinoContextualizationInference}" + , "\\begin{phinoContextualizationInference}" + , " \\phinoName{cg}" + , " \\phinoConclusion{ \\phinoContextualize{ Q }{ k }{ Q } }" + , "\\end{phinoContextualizationInference}" + , "\\begin{phinoContextualizationInference}" + , " \\phinoName{ct}" + , " \\phinoConclusion{ \\phinoContextualize{ T }{ k }{ T } }" + , "\\end{phinoContextualizationInference}" + , "\\begin{phinoContextualizationInference}" + , " \\phinoName{cxi}" + , " \\phinoConclusion{ \\phinoContextualize{ \\phiTerminal{\\xi} }{ k }{ k } }" + , "\\end{phinoContextualizationInference}" + ] + ] + + it "fails with no rules specified" $ + testCLIFailed + ["explain"] + ["Either --rule, --normalize, --morph, --dataize or --contextualize must be specified"] + + it "fails when more than one rule set is specified" $ + testCLIFailed + ["explain", "--morph", "--dataize"] + ["Only one of --morph, --dataize or --contextualize can be specified"] + + it "allows --normalize together with --rule" $ + testCLISucceeded + ["explain", "--normalize", "--rule=resources/normalize/copy.yaml"] + ["\\phinoNormalizationRule{copy}"] + + it "allows --shuffle together with --morph" $ + testCLISucceeded + ["explain", "--morph", "--shuffle"] + ["\\begin{phinoMorphingInference}"] + + it "writes to target file" $ + bracket + ( do + tmp <- getTemporaryDirectory + stamp <- getPOSIXTime + let dir = tmp ("phino-test-" ++ show (floor stamp :: Integer)) + createDirectoryIfMissing True dir + pure (dir "explain.tex", dir) + ) + (\(_, dir) -> removeDirectoryRecursive dir) + ( \(path, _) -> do + testCLISucceeded ["explain", "--normalize", printf "--target=%s" path] [] + content <- readFile path + _ <- evaluate (length content) + content `shouldContain` "\\phinoNormalizationRule{alpha}" + ) + + describe "merge" $ do + it "prints help" $ + testCLISucceeded ["merge", "--help"] ["Paths to input files"] + + it "merges single expression" $ + testCLISucceeded + ["merge", resource "desugar.phi", "--sweet", "--flat"] + ["⟦ foo ↦ x ⟧"] + + it "merges EO expressions" $ + testCLISucceeded + ["merge", "--sweet", resource "number.phi", resource "bytes.phi", resource "string.phi", "--margin=25"] + [ unlines + [ "⟦" + , " org ↦ ⟦" + , " eolang ↦ ⟦" + , " number(Ο†) ↦ ⟦⟧," + , " bytes(data) ↦ ⟦⟧," + , " string(Ο†) ↦ ⟦⟧," + , " Ξ» ‍ Package" + , " ⟧," + , " Ξ» ‍ Package" + , " ⟧" + , "⟧" + ] + ] + + it "fails on merging non formations" $ + testCLIFailed + ["merge", resource "dispatch.phi", resource "number.phi"] + ["Invalid expression format, only expressions with top level formations are supported for 'merge' command"] + + it "fails on merging conflicted bindings" $ + testCLIFailed + ["merge", resource "foo.phi", resource "desugar.phi"] + ["Can't merge two bindings, conflict found"] + + it "fails on merging empty list of expressions" $ + testCLIFailed + ["merge"] + ["At least one input file must be specified for 'merge' command"] + + it "merges and prints as XMIR, with the listing rendered from the merged expression" $ + testCLISucceeded + ["merge", resource "desugar.phi", "--output=xmir"] + ["", "⟦ foo ↦ ΞΎ.x, ρ ↦ βˆ… ⟧", ""] + + it "reproduces the same output for the same --seed" $ do + let args = + [ "merge" + , "--seed=42" + , "--sweet" + , resource "number.phi" + , resource "bytes.phi" + ] + (firstRun, _) <- withStdout (runCLI args) + (secondRun, _) <- withStdout (runCLI args) + firstRun `shouldBe` secondRun + + describe "match" $ do + it "prints help" $ + testCLISucceeded + ["match", "--help"] + ["Pattern expression to match against", "Predicate for matched substitutions"] + + it "takes from stdin" $ + withStdin "[[]]" $ + testCLISucceeded ["match", "--log-level=debug"] ["[DEBUG]"] + + it "takes from file" $ + testCLISucceeded ["match", resource "foo.phi", "--log-level=debug"] ["[DEBUG]"] + + it "does not print substitutions without pattern" $ + withStdin "[[]]" $ + testCLISucceeded ["match", "--log-level=debug"] ["[DEBUG]: The --pattern is not provided, no substitutions are built"] + + it "reproduces the same output for the same --seed" $ do + dir <- getTemporaryDirectory + let file = dir ++ "/phino-match-seed-test.phi" + writeFile file "[[ x -> Q.x, y -> Q.y, z -> Q.z ]]" + let args = + [ "match" + , "--seed=42" + , "--sweet" + , "--flat" + , "--pattern=Q.!t" + , file + ] + (firstRun, _) <- withStdout (runCLI args) + (secondRun, _) <- withStdout (runCLI args) + firstRun `shouldBe` secondRun + removeFile file + + it "prints many substitutions" $ + withStdin "[[ x -> Q.x, y -> Q.y ]]" $ + testCLISucceeded ["match", "--pattern=Q.!t"] ["t >> x\n------\nt >> y"] + + it "builds substitutions with conditions" $ + withStdin "[[ x -> Q.y ]].x" $ + testCLISucceeded + ["match", "--pattern=[[ !t1 -> Q.y, !B1 ]].!t1", "--when=eq(length(!B1),1)"] + ["B1 >> ⟦ ρ ↦ βˆ… ⟧\nt1 >> x"] + + it "builds with condition from file" $ + testCLISucceeded + ["match", "--pattern=[[ !B1 ]]", "--when=eq(length(!B1),2)", resource "foo.phi"] ["B1 >> ⟦ foo ↦ Ξ¦.org.eolang.x, ρ ↦ βˆ… ⟧"] it "rejects an anonymous meta in --when" $ diff --git a/test/DataizeSpec.hs b/test/DataizeSpec.hs --- a/test/DataizeSpec.hs +++ b/test/DataizeSpec.hs @@ -10,21 +10,22 @@ module DataizeSpec (spec) where import AST -import Atoms (Registry, emptyRegistry) import Control.Exception (SomeException) import Control.Monad import Data.Aeson (FromJSON) -import Data.IORef (modifyIORef', newIORef, readIORef) import Data.List (find, isInfixOf, nub) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromMaybe, isJust) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) import Data.Yaml qualified as Decode import Dataize (Outcome (..), dataize, dataize', reduction) -import Deps (Evaluation (..), dontSaveEval, dontSaveStep) +import Deps (Judgment (..), State, dontSaveEval, dontSaveStep) +import Evaluate (evaluation, fired) import Files (allPathsIn) -import Fixtures (defaultReduceContext, fixtureRegistry, primitives, withAtoms, withNode) +import Fixtures (defaultReduceContext, fixtureLambdas, loopingLambdas, primitives, recorded, withLambdas) import Functions (buildTerm) import GHC.Generics (Generic) +import Lambdas (Lambdas, emptyLambdas, readLambdas) import Matcher (substEmpty) import Morph (ReduceContext (..), Steps (..), emptyState, execBuildTerm) import Parser (parseBytes, parseExpressionThrows) @@ -34,7 +35,7 @@ import Test.Hspec import Yaml qualified -test :: (Eq a, Show a) => ((Expression, NonEmpty Rewritten) -> Expression -> String -> ReduceContext -> IO ((a, [Rewritten]), String)) -> [(String, Expression, Expression, a)] -> Spec +test :: (Eq a, Show a) => ((Expression, NonEmpty Rewritten) -> Expression -> State -> ReduceContext -> IO ((a, [Rewritten]), State)) -> [(String, Expression, Expression, a)] -> Spec test func useCases = forM_ useCases $ \(desc, input, expr, output) -> it desc $ do @@ -43,59 +44,55 @@ -- One case of 𝔻, as a pack of 'test-resources/dataization-packs' spells it: the -- program under 'input', wrapped in the fixture object model where 'model' says --- so and run against the fixture Ξ» functions where 'atoms' does, entered at +-- so and run against the fixture Ξ» functions where 'symbolic' does, entered at -- 'location' and answering either the bytes under 'result' or the failure under -- 'fails'. data DataizePack = DataizePack { location :: Maybe String , input :: String , model :: Maybe Bool - , atoms :: Maybe Bool + , symbolic :: Maybe Bool , result :: Maybe String , fails :: Maybe String } deriving (Generic, Show, FromJSON) --- Dataize one such pack and check what it answers. A pack that registers the --- fixture Ξ» functions runs an external script, so it is pending where 'node' is --- not installed. -testDataize :: Registry -> FilePath -> Expectation -testDataize registry pth = do +-- Dataize one such pack and check what it answers +testDataize :: Lambdas -> FilePath -> Expectation +testDataize known pth = do DataizePack{..} <- Decode.decodeFileThrow pth expr <- parseExpressionThrows (if model == Just True then primitives input else input) loc <- parseExpressionThrows (fromMaybe "Q" location) - let ctx = (defaultReduceContext loc){_atoms = if atoms == Just True then registry else emptyRegistry} - checked :: Expectation - checked = case (result, fails) of - (Just res, Nothing) -> do - bts <- either (fail . ("cannot read the expected bytes: " ++)) pure (parseBytes res) - (value, _) <- dataize expr ctx - value `shouldBe` Dataized bts - (Nothing, Just message) -> - dataize expr ctx `shouldThrow` (\err -> message `isInfixOf` show (err :: SomeException)) - _ -> expectationFailure "The pack holds neither a single 'result' nor a single 'fails'" - if atoms == Just True then withNode checked else checked + let ctx = (defaultReduceContext loc){_symbolic = if symbolic == Just True then known else emptyLambdas} + case (result, fails) of + (Just res, Nothing) -> do + bts <- either (fail . ("cannot read the expected bytes: " ++)) pure (parseBytes res) + (value, _, _) <- dataize expr emptyState ctx + value `shouldBe` Dataized bts + (Nothing, Just message) -> + dataize expr emptyState ctx `shouldThrow` (\err -> message `isInfixOf` show (err :: SomeException)) + _ -> expectationFailure "The pack holds neither a single 'result' nor a single 'fails'" --- Dataize under '--partial', collecting every report 𝔼 makes on the way, in --- the order it makes them -partially :: Registry -> String -> IO ((Outcome, [Rewritten]), [Evaluation]) -partially registry src = do +-- Dataize under '--partial', handing back the protocol of '--protocol' +-- alongside the answer, verbatim +partially :: Lambdas -> String -> IO ((Outcome, [Rewritten]), String) +partially known src = do expr <- parseExpressionThrows (primitives src) - reports <- newIORef [] - let ctx = - (withAtoms registry (defaultReduceContext ExRoot)) - { _partial = True - , _saveEval = \report -> modifyIORef' reports (report :) - } - result <- dataize expr ctx - collected <- readIORef reports - pure (result, reverse collected) + recorded $ \record -> do + let ctx = (withLambdas known (defaultReduceContext ExRoot)){_partial = True, _saveEval = record} + (outcome, chain, _) <- dataize expr emptyState ctx + pure (outcome, chain) +-- The one Ξ» function that answers with a firing of itself, read the way +-- '--symbolic' reads it, so that a run fires it until the step budget is gone +looping :: (Lambdas -> IO a) -> IO a +looping action = loopingLambdas (readLambdas >=> action) + spec :: Spec spec = do - -- Every Ξ» function a case may fire comes from the fixture registry, read - -- once here: phino carries none of its own (see 'Fixtures'). - registry <- runIO fixtureRegistry + -- Every Ξ» function a case may fire comes from the fixture file, read once + -- here: phino carries none of its own (see 'Fixtures'). + known <- runIO fixtureLambdas -- Symmetric to the morphing fallback above: every normal form 𝔻 actually -- receives is covered by 'delta'/'box'/'fire'/'none' (formations) or 'norm' @@ -119,7 +116,7 @@ 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 - asRule r = Yaml.Rule r.name Nothing Nothing r.match ExRoot r.when Nothing Nothing + asRule r = Yaml.Rule r.name Nothing Nothing r.match Nothing ExRoot r.when Nothing Nothing it "does not fire on a formation" $ do substs <- matchExpressionWithRule' [substEmpty] (ExFormation [BiDelta (BtOne "00")]) (asRule (dataizeRule "norm")) rctx substs `shouldBe` [] @@ -133,18 +130,17 @@ -- Most cases of 𝔻 are four plain values β€” the program, where the run enters -- it, which Ξ» functions answer it and what it must dataize to β€” so they are -- packs of 'test-resources/dataization-packs' rather than Haskell (#1201). - -- Which Ξ» functions exist is no longer phino's business: the registry given - -- with '--atoms' decides, and each one runs as an external script (see - -- 'Atoms'). What a pack with 'atoms' on asserts is that the answer of such a - -- script lands in the derivation exactly where a built-in atom's answer used - -- to: 𝔼 normalizes it and 𝔻 carries on. The Ξ» functions themselves are the - -- fixture ones (see 'Fixtures'), and 'number.eq' is composed out of - -- 'L_bytes_eq' the way 'eq.eo' composes it, so the EO-level composition is - -- exercised too. + -- Which Ξ» functions exist is no longer phino's business: the YAML file given + -- with '--symbolic' decides, and each entry of it answers the firing with a + -- term of the calculus (see 'Lambdas'). What a pack with 'symbolic' on + -- asserts is that such an answer lands in the derivation exactly where a + -- built-in atom's answer used to: 𝔼 normalizes it and 𝔻 carries on. Nothing + -- is computed on the way, so every one of them ends on the datum a symbol is + -- manufactured for. describe "dataize" $ do let resources = "test-resources/dataization-packs" packs <- runIO (allPathsIn resources) - forM_ packs (\pth -> it (makeRelative resources pth) (testDataize registry pth)) + forM_ packs (\pth -> it (makeRelative resources pth) (testDataize known pth)) describe "dataize'" $ test @@ -204,112 +200,109 @@ (ExApplication (ExFormation [BiVoid (AtLabel "x")]) (ArTau (AtLabel "x") (ExDispatch ExXi (AtLabel "foo")))) -- '--max-cycles' and '--max-depth' reach only the normalization run inside a - -- single step, so the 𝕄/𝔻 recursion itself was unbounded: this division, whose - -- Ξ»-atom keeps re-firing on a term that never reduces to bytes, sent 'morph'' - -- through md β†’ ma β†’ universe β†’ mf β†’ mphi β†’ ml forever and no CLI option could - -- stop it (#1052). '--max-steps' bounds that recursion and fails once the - -- budget is gone. + -- single step, so the 𝕄/𝔻 recursion itself was unbounded: a Ξ» function that + -- answers with a firing of itself sent 'morph'' through md β†’ ma β†’ universe β†’ + -- mf β†’ mphi β†’ ml forever and no CLI option could stop it (#1052). Recursion + -- is nothing phino prevents β€” whether a Ξ» function ends is the object model's + -- business β€” so '--max-steps' is what bounds that recursion and fails once + -- the budget is gone. describe "stops a dataization that never reaches bytes" $ do it "fails on the step limit instead of morphing forever" $ - withNode $ do - expr <- parseExpressionThrows "⟦ @ ↦ ⟦ Ξ» ‍ L_number_div, ρ ↦ ⟦ Ξ” ‍ 40-45-00-00-00-00-00-00 ⟧, x ↦ ⟦ Ξ” ‍ 40-00-00-00-00-00-00-00 ⟧ ⟧ ⟧" - dataize expr (ReduceContext ExRoot 25 25 (Steps 40 0) False True False False registry buildTerm reduction dontSaveStep dontSaveEval) + looping $ \endless -> do + expr <- parseExpressionThrows "⟦ @ ↦ ⟦ Ξ» ‍ L_loop ⟧ ⟧" + dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 25 (Steps 40 0) 1 False True False False False Dataization [] Map.empty Map.empty endless buildTerm reduction evaluation fired dontSaveStep dontSaveEval) `shouldThrow` (\e -> "--max-steps=40" `isInfixOf` show (e :: SomeException)) - -- A budget spent on a cycle is a stuck site just as an atom that cannot - -- fire is: under '_partial' the run ends on the residual the spine had - -- reached instead of failing hard (#1078) + -- A budget spent on a cycle is a stuck site just as a Ξ» function that + -- cannot fire is: under '_partial' the run ends on the residual the spine + -- had reached instead of failing hard (#1078) it "parks the step limit as a residual with --partial" $ - withNode $ do - expr <- parseExpressionThrows "⟦ @ ↦ ⟦ Ξ» ‍ L_number_div, ρ ↦ ⟦ Ξ” ‍ 40-45-00-00-00-00-00-00 ⟧, x ↦ ⟦ Ξ” ‍ 40-00-00-00-00-00-00-00 ⟧ ⟧ ⟧" - (outcome, _) <- dataize expr (ReduceContext ExRoot 25 25 (Steps 40 0) False True True False registry buildTerm reduction dontSaveStep dontSaveEval) + looping $ \endless -> do + expr <- parseExpressionThrows "⟦ @ ↦ ⟦ Ξ» ‍ L_loop ⟧ ⟧" + (outcome, _, _) <- dataize expr emptyState (ReduceContext ExRoot ExRoot Nothing 25 25 (Steps 40 0) 1 False True True False False Dataization [] Map.empty Map.empty endless buildTerm reduction evaluation fired dontSaveStep dontSaveEval) case outcome of Residual _ -> pure () Dataized bts -> expectationFailure ("expected a residual, dataized to " ++ show bts) - -- An atom phino does not know β€” a name the '--atoms' registry 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 residue - -- instead: the working expression the spine had reached, with the stuck - -- application intact and everything the calculus demanded before it already - -- evaluated, while 𝔼 reports each parked site with no result. Since the atoms - -- moved out of the binary, an operand that cannot be reduced is the script's - -- own business, so what parks here is the unregistered Ξ» function alone. - describe "partially evaluates around an atom that cannot fire (--partial)" $ do + -- 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 + -- residue instead: the working expression the spine had reached, with the + -- stuck application intact and everything the calculus demanded before it + -- already evaluated, while the protocol of '--protocol' keeps the firings + -- that did answer. + describe "partially evaluates around a Ξ» function that cannot fire (--partial)" $ do -- the parser gives every formation its void ρ let placeholder = ExFormation [BiLambda (Function "Sym_arg_0"), BiVoid AtRho] - it "fails on it without the flag, naming the unknown atom" $ - withNode $ do - expr <- parseExpressionThrows (primitives "2.times(3).nope") - dataize expr (withAtoms registry (defaultReduceContext ExRoot)) - `shouldThrow` (\e -> "Atom 'L_number_nope' does not exist" `isInfixOf` show (e :: SomeException)) - it "leaves the application of the unregistered atom in place" $ - withNode $ do - ((outcome, _), _) <- partially registry "2.times(3).nope" - case outcome of - Residual (ExFormation bds) -> bds `shouldContain` [BiLambda (Function "L_number_nope")] - other -> expectationFailure ("expected a residual formation, got " ++ show other) - it "keeps what was evaluated before the stuck site in the residue" $ - withNode $ do - ((outcome, _), _) <- partially registry "2.times(3).nope" - case outcome of - Residual (ExFormation bds) -> do - let rho = [value | BiTau AtRho value <- bds] - length rho `shouldBe` 1 - -- 2 Γ— 3 = 6.0, whose IEEE 754 bytes are 40-18-00-00-00-00-00-00 - show rho `shouldContain` show (BtMany ["40", "18", "00", "00", "00", "00", "00", "00"]) - -- the times application is gone: ρ is the number it produced, its 'as-bytes' bound - [() | ExFormation inner <- rho, BiTau (AtLabel "as-bytes") _ <- inner] `shouldBe` [()] - other -> expectationFailure ("expected a residual formation, got " ++ show other) - it "reports the firing that succeeded with its result and the stuck site without one" $ - withNode $ do - (_, reports) <- partially registry "2.times(3).nope" - map (._function) reports `shouldBe` ["L_number_times", "L_number_nope"] - map (isJust . (._result)) reports `shouldBe` [True, False] - it "leaves an unknown atom dataized directly as the whole residue" $ - withNode $ do - ((outcome, chain), reports) <- partially registry "[[ L> Sym_arg_0 ]]" - outcome `shouldBe` Residual placeholder - map (._function) reports `shouldBe` ["Sym_arg_0"] - map fst chain `shouldEndWith` [placeholder] - it "still reaches bytes when nothing is stuck" $ - withNode $ do - ((outcome, _), reports) <- partially registry "2.times(3)" - outcome `shouldBe` Dataized (BtMany ["40", "18", "00", "00", "00", "00", "00", "00"]) - map (._function) reports `shouldBe` ["L_number_times"] - it "stops on the terminator βŠ₯ as before, since a wrong operand is not a stuck atom" $ - withNode $ do - expr <- parseExpressionThrows (primitives "5.plus( Ξ¦.bytes( Ο† ↦ ⟦ Ξ” ‍ -- ⟧ ) )") - dataize expr ((withAtoms registry (defaultReduceContext ExRoot)){_partial = True}) - `shouldThrow` (\e -> "terminator" `isInfixOf` show (e :: SomeException)) + it "fails on it without the flag, naming the Ξ» function" $ do + expr <- parseExpressionThrows (primitives "2.times(3).nope") + dataize expr emptyState (withLambdas known (defaultReduceContext ExRoot)) + `shouldThrow` (\e -> "No entry of --symbolic answers the Ξ» function 'L_number_nope'" `isInfixOf` show (e :: SomeException)) + it "leaves the application of the unanswered Ξ» function in place" $ do + ((outcome, _), _) <- partially known "2.times(3).nope" + case outcome of + Residual (ExFormation bds) -> bds `shouldContain` [BiLambda (Function "L_number_nope")] + other -> expectationFailure ("expected a residual formation, got " ++ show other) + it "keeps what was evaluated before the stuck site in the residue" $ do + ((outcome, _), _) <- partially known "2.times(3).nope" + case outcome of + Residual (ExFormation bds) -> do + let rho = [value | BiTau AtRho value <- bds] + length rho `shouldBe` 1 + -- the times application is gone: ρ is the number it answered, its 'as-bytes' bound + [() | ExFormation inner <- rho, BiTau (AtLabel "as-bytes") _ <- inner] `shouldBe` [()] + other -> expectationFailure ("expected a residual formation, got " ++ show other) + it "writes the firing that answered into the protocol and stops at the stuck one" $ do + (_, protocol) <- partially known "2.times(3).nope" + protocol + `shouldBe` unlines + [ " 𝔼(L_number_times) # 𝕄(Ξ¦)" + , " 𝛿1.1 := 40-00-00-00-00-00-00-00 # 𝔻(ΞΎ.ρ)" + , " 𝛿2.1 := 40-08-00-00-00-00-00-00 # 𝔻(ΞΎ.x)" + , " 𝑛.1.1 := Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) # 𝑛" + , " 𝑛.1.2 := ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, as-bytes ↦ Ο†, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧, div(x) ↦ ⟦ Ξ» ‍ L_number_div ⟧, gt(x) ↦ ⟦ Ξ» ‍ L_number_gt ⟧, eq(x) ↦ ⟦ Ο† ↦ ρ.as-bytes.eq( x.as-bytes ) ⟧, nope ↦ ⟦ Ξ» ‍ L_number_nope ⟧, ρ ↦ Ξ¦ ⟧ # 𝕄(𝑛.1.1)" + , " ?(L_number_nope) # 𝔻(⟦ Ξ» ‍ L_number_nope, ρ ↦ ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, as-bytes ↦ Ο†, plus(x) ↦ ⟦ Ξ» ‍ L_number_plus ⟧, times(x) ↦ ⟦ Ξ» ‍ L_number_times ⟧, div(x) ↦ ⟦ Ξ» ‍ L_number_div ⟧, gt(x) ↦ ⟦ Ξ» ‍ L_number_gt ⟧, eq(x) ↦ ⟦ Ο† ↦ ρ.as-bytes.eq( x.as-bytes ) ⟧, nope ↦ ⟦ Ξ» ‍ L_number_nope ⟧, ρ ↦ Ξ¦ ⟧ ⟧)" + ] + it "leaves an unanswered Ξ» function dataized directly as the whole residue" $ do + ((outcome, chain), protocol) <- partially known "[[ L> Sym_arg_0 ]]" + outcome `shouldBe` Residual placeholder + protocol `shouldBe` " ?(Sym_arg_0) # 𝔻(⟦ Ξ» ‍ Sym_arg_0 ⟧)\n" + map fst chain `shouldEndWith` [placeholder] + it "still reaches the manufactured datum when nothing is stuck" $ do + ((outcome, _), _) <- partially known "2.times(3)" + outcome `shouldBe` Dataized (BtMany ["40", "45", "00", "00", "00", "00", "00", "00"]) + it "stops on the terminator βŠ₯ as before, since a data-less formation is not a stuck Ξ» function" $ do + expr <- parseExpressionThrows (primitives "5.plus( ⟦ ⟧ )") + dataize expr emptyState ((withLambdas known (defaultReduceContext ExRoot)){_partial = True}) + `shouldThrow` (\e -> "terminator" `isInfixOf` show (e :: SomeException)) describe "ReduceContext's --max-depth/--max-cycles reach into the normalization it splices in" $ do let boxed = "[[ @ -> [[ D> 00- ]] ]]" forM_ [ ( "--max-cycles" - , ReduceContext ExRoot 25 0 (Steps 250 0) True True False False emptyRegistry buildTerm reduction dontSaveStep dontSaveEval + , ReduceContext ExRoot ExRoot Nothing 25 0 (Steps 250 0) 1 True True False False False Dataization [] Map.empty Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval , "--max-cycles=0" ) , ( "--max-depth" - , ReduceContext ExRoot 0 25 (Steps 250 0) True True False False emptyRegistry buildTerm reduction dontSaveStep dontSaveEval + , ReduceContext ExRoot ExRoot Nothing 0 25 (Steps 250 0) 1 True True False False False Dataization [] Map.empty Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval , "--max-depth=0" ) ] ( \(flag, ctx, message) -> it ("throws once " ++ flag ++ " is exhausted with --depth-sensitive") $ do expr <- parseExpressionThrows boxed - dataize expr ctx `shouldThrow` (\e -> message `isInfixOf` show (e :: SomeException)) + dataize expr emptyState ctx `shouldThrow` (\e -> message `isInfixOf` show (e :: SomeException)) ) forM_ - [ ("--max-cycles", ReduceContext ExRoot 25 0 (Steps 250 0) False True False False emptyRegistry buildTerm reduction dontSaveStep dontSaveEval) - , ("--max-depth", ReduceContext ExRoot 0 25 (Steps 250 0) False True False False emptyRegistry buildTerm reduction dontSaveStep dontSaveEval) + [ ("--max-cycles", ReduceContext ExRoot ExRoot Nothing 25 0 (Steps 250 0) 1 False True False False False Dataization [] Map.empty Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval) + , ("--max-depth", ReduceContext ExRoot ExRoot Nothing 0 25 (Steps 250 0) 1 False True False False False Dataization [] Map.empty Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval) ] ( \(flag, ctx) -> it ("does not throw without --depth-sensitive even once " ++ flag ++ " is exhausted") $ do expr <- parseExpressionThrows boxed - (value, _) <- dataize expr ctx + (value, _, _) <- dataize expr emptyState ctx value `shouldBe` Dataized (BtOne "00") ) @@ -326,15 +319,14 @@ ++ map (.name) Yaml.normalizationRules ++ concatMap (map (verb . (.operation)) . (.premises)) Yaml.morphingRules ++ concatMap (map (verb . (.operation)) . (.premises)) Yaml.dataizationRules - it "uses no step label without a defining rule or operation" $ - withNode $ do - expr <- parseExpressionThrows (primitives "5.plus(6)") - loc <- parseExpressionThrows "Q" - (_, chain) <- dataize expr (withAtoms registry (defaultReduceContext loc)) - let orphans = nub [label | (_, Just label) <- chain, label `notElem` allowed] - unless - (null orphans) - (expectationFailure ("Dataization emitted step labels with no defining rule or operation: " ++ show orphans)) + it "uses no step label without a defining rule or operation" $ do + 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"] + unless + (null orphans) + (expectationFailure ("Dataization emitted step labels with no defining rule or operation: " ++ show orphans)) describe "names every rule uniquely across rule sets" $ it "shares no rule name between morphing, dataization, normalization and contextualization" $ do @@ -350,31 +342,27 @@ let labelsOf loc src = do expr <- parseExpressionThrows src loc' <- parseExpressionThrows loc - (_, chain) <- dataize expr (withAtoms registry (defaultReduceContext loc')) + (_, chain, _) <- dataize expr emptyState (withLambdas known (defaultReduceContext loc')) pure [label | (_, Just label) <- chain] - it "dataizes 5.plus(6) through the expected rules" $ - withNode $ do - labels <- - labelsOf - "Q" - "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6) ]]" - labels - `shouldBe` [ "contextualize" - , "maa" - , "alpha" - , "copy" - , "mf" - , "evaluate" - , "ma" - , "copy" - , "mf" - , "contextualize" - , "ma" - , "copy" - , "mf" - , "contextualize" - , "delta" - ] + -- '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 + -- given a formation and has nothing left to peel (#1268) + it "dataizes 5.plus(6) through the expected rules" $ do + labels <- + labelsOf + "Q" + "[[ bytes ↦ ⟦ Ο† ↦ βˆ… ⟧, number(Ο†) -> [[ plus(x) -> [[ L> L_number_plus ]] ]], @ -> 5.plus(6) ]]" + labels + `shouldBe` [ "contextualize" + , "maa" + , "alpha" + , "copy" + , "mf" + , "evaluate" + , "contextualize" + , "symbol" + ] 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", "copy", "mf", "delta"] + labels `shouldBe` ["contextualize", "md", "dotg", "copy", "mf", "delta"] diff --git a/test/EncodingSpec.hs b/test/EncodingSpec.hs --- a/test/EncodingSpec.hs +++ b/test/EncodingSpec.hs @@ -178,15 +178,28 @@ , PA_META_LAMBDA' (META EXCL F' "fn") ) , - ( "PA_META_DELTA becomes PA_META_DELTA' with head D'" + ( "PA_DELTA recurses into its bytes, forcing a meta head to D''" + , toASCII (PA_DELTA (BT_META (META NO_EXCL D "0"))) + , PA_DELTA' (BT_META (META EXCL D'' "0")) + ) + , + ( "PA_META_DELTA becomes PA_META_DELTA' with head D''" , toASCII (PA_META_DELTA (META NO_EXCL D "dl")) - , PA_META_DELTA' (META EXCL D' "dl") + , PA_META_DELTA' (META EXCL D'' "dl") ) , ("leaves an already-ASCII PA_LAMBDA' untouched", toASCII (PA_LAMBDA' "Func"), PA_LAMBDA' "Func") , ("leaves an already-ASCII PA_DELTA' untouched", toASCII (PA_DELTA' BT_EMPTY), PA_DELTA' BT_EMPTY) ] (\(desc, actual, expected) -> it desc (actual `shouldBe` expected)) + describe "toASCII on BYTES" $ + forM_ + [ ("BT_META forces the head to D''", toASCII (BT_META (META NO_EXCL D "ψ")), BT_META (META EXCL D'' "ψ")) + , ("leaves BT_MANY untouched", toASCII (BT_MANY ["00", "FF"]), BT_MANY ["00", "FF"]) + , ("leaves BT_EMPTY untouched", toASCII BT_EMPTY, BT_EMPTY) + ] + (\(desc, actual, expected) -> it desc (actual `shouldBe` expected)) + describe "toASCII on ALPHA" $ forM_ [ ("recurses through AL_IDX", toASCII (AL_IDX ALPHA 7), AL_IDX ALPHA' 7) @@ -274,7 +287,12 @@ [ ("recurses through ARG_ATTR", toASCII (ARG_ATTR (AT_PHI PHI)), ARG_ATTR (AT_PHI AT)) , ("recurses through ARG_EXPR", toASCII (ARG_EXPR leafExpr), ARG_EXPR leafExprASCII) , ("recurses through ARG_BINDING", toASCII (ARG_BINDING biPair), ARG_BINDING biPairASCII) - , ("leaves ARG_BYTES untouched", toASCII (ARG_BYTES BT_EMPTY), ARG_BYTES BT_EMPTY) + , ("leaves ARG_BYTES without a meta untouched", toASCII (ARG_BYTES BT_EMPTY), ARG_BYTES BT_EMPTY) + , + ( "recurses through ARG_BYTES, forcing a meta head to D''" + , toASCII (ARG_BYTES (BT_META (META NO_EXCL D "bts"))) + , ARG_BYTES (BT_META (META EXCL D'' "bts")) + ) ] (\(desc, actual, expected) -> it desc (actual `shouldBe` expected)) diff --git a/test/EvaluateSpec.hs b/test/EvaluateSpec.hs new file mode 100644 --- /dev/null +++ b/test/EvaluateSpec.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module EvaluateSpec (spec) where + +import AST +import CLI.Helpers (started) +import Control.Exception (SomeException) +import Control.Monad +import Data.Aeson (FromJSON (parseJSON), camelTo2, defaultOptions, fieldLabelModifier, genericParseJSON) +import Data.List (isInfixOf) +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Data.Yaml qualified as Decode +import Deps (Evaluation (EvRun), Judgment (Morphing), Term (TeExpression)) +import Encoding (Encoding (UNICODE)) +import Files (allPathsIn) +import Fixtures (defaultReduceContext, fixtureLambdas, recorded, recorded', withLambdas, withLambdasOf) +import GHC.Generics (Generic) +import Lambdas (readLambdas) +import Lining (LineFormat (SINGLELINE)) +import Margin (defaultMargin) +import Matcher (substEmpty) +import Morph (ReduceContext (..), Steps (..), execBuildTerm, morph) +import Parser (parseExpressionThrows) +import Printer (printExpression, printExpression', printExpressionHidingRho') +import Sugar (SugarType (SWEET)) +import System.FilePath (makeRelative) +import Tau (seedTaus) +import Test.Hspec +import Yaml (ExtraArgument (..)) + +-- One case of a Ξ» function answered by the '--symbolic' file, as a pack of +-- 'test-resources/evaluate-packs' spells it: the file itself under +-- 'symbolic', the program it is fired against under 'input', the whole protocol +-- of '--protocol' under 'protocol' and, where the answer is small enough to be +-- worth spelling, the program 𝕄 lands on under 'result' β€” or the failure under +-- 'fails'. The protocol is one block of text rather than a list of lines, so a +-- pack holds the file a user of the option reads back and the case compares the +-- two of them verbatim. Every term of both is spelled without its ρ bindings, +-- the way '--hide-rho' spells one, unless the pack says 'hide-rho: false': the +-- ρ chain is the universe an entry was fired inside and not the answer it gave, +-- so spelling it buries the symbol a pack is there to show (#1313). +data SymbolPack = SymbolPack + { symbolic :: String + , location :: Maybe String + , input :: String + , deep :: Maybe Bool + , partial :: Maybe Bool + , acyclic :: Maybe Bool + , steps :: Maybe Int + , protocol :: String + , result :: Maybe String + , fails :: Maybe String + , hideRho :: Maybe Bool + } + deriving (Generic, Show) + +-- The keys a pack spells its fields with, which are the fields themselves in +-- every case but 'hide-rho', where the option it is named after spells with a +-- dash what Haskell spells with a hump. +instance FromJSON SymbolPack where + parseJSON = genericParseJSON defaultOptions{fieldLabelModifier = camelTo2 '-'} + +-- Fire one symbol pack and check both what it answers and what its firings +-- wrote to the protocol, since a Ξ» function is as much what it reports as what +-- it hands back. The run opens the protocol with itself, the way the command +-- opens it, so a pack reads as the file a user of '--protocol' reads back. +testSymbols :: FilePath -> Expectation +testSymbols pth = do + SymbolPack{..} <- Decode.decodeFileThrow pth + expr <- parseExpressionThrows input + seedTaus expr + loc <- parseExpressionThrows (fromMaybe "Q" location) + let hidden = hideRho /= Just False + withLambdasOf (T.pack symbolic) $ \file -> do + known <- readLambdas file + (_, written) <- recorded' hidden $ \record -> do + let ctx = + (defaultReduceContext loc) + { _deep = deep == Just True + , _partial = partial == Just True + , _acyclic = acyclic == Just True + , _steps = Steps (fromMaybe 250 steps) 0 + , _symbolic = known + , _saveEval = record + } + record (EvRun Morphing (T.pack (printExpression loc))) + case fails of + Just message -> + morph expr (started expr) ctx `shouldThrow` (\err -> message `isInfixOf` show (err :: SomeException)) + Nothing -> do + (morphed, _, _) <- morph expr (started expr) ctx + forM_ result $ \res -> do + expected <- parseExpressionThrows res + spelled hidden morphed `shouldBe` spelled False expected + written `shouldBe` protocol + where + -- How a pack spells a program: πœ‘ on one line, in the sugar the protocol + -- writes its own terms with. The answer goes through it with the ρ bindings + -- hidden where the pack hides them and the 'result' of the pack goes + -- through it as it stands, so a pack still spelling a ρ of its own fails on + -- it rather than having it dropped from both sides and forgiven. A void ρ + -- says nothing either way, since the sweet syntax writes no 'ρ ↦ βˆ…' + -- whatever the pack asked for. + spelled :: Bool -> Expression -> String + spelled hidden term = + (if hidden then printExpressionHidingRho' else printExpression') term (SWEET, UNICODE, SINGLELINE, defaultMargin) + +spec :: Spec +spec = do + -- Every Ξ» function a case may fire comes from the fixture file, read once + -- here: phino carries none of its own (see 'Fixtures'). + known <- runIO fixtureLambdas + + -- The whole of what a Ξ» function answered by the '--symbolic' file does, pack + -- by pack: the file itself, the program it is fired against, every line the + -- protocol of '--protocol' writes and the program 𝕄 lands on. + describe "evaluate with the Ξ» functions of '--symbolic'" $ do + let resources = "test-resources/evaluate-packs" + packs <- runIO (allPathsIn resources) + forM_ packs (\pth -> it (makeRelative resources pth) (testSymbols pth)) + + -- 'execBuildTerm's "evaluate" case exposes 𝔼 to the matcher's condition path + -- (guards in 'when'/'having'). No built-in rule's guard actually calls the + -- function, so these error paths β€” reachable only by malformed arguments β€” + -- are exercised here directly through the exported 'execBuildTerm', the same + -- way the matcher would call it. + describe "execBuildTerm 'evaluate'" $ do + let univ = ExFormation [] + ctx = withLambdas known (defaultReduceContext ExRoot) + runEvaluate args = execBuildTerm univ ctx "evaluate" args substEmpty + forM_ + [ + ( "the first argument is not a formation" + , [ArgExpression ExRoot, ArgExpression univ] + , "Function evaluate() expects a formation" + ) + , + ( "not given exactly two expression arguments" + , [ArgExpression univ] + , "requires exactly 2 expression arguments" + ) + ] + ( \(desc, args, message) -> + it ("throws when " ++ desc) $ + runEvaluate args `shouldThrow` (\e -> message `isInfixOf` show (e :: SomeException)) + ) + + -- A Ξ» naming a symbol is none of those. A symbol is a value nobody worked + -- out, so no entry of the '--symbolic' file answers it and there is no + -- firing to make, which is the very thing a Ξ» name nothing answers means: + -- 𝔼 gets stuck on it rather than refusing the formation, and the site goes + -- to the protocol under the name every term carrying that symbol spells it + -- with. Before #1287 this threw a 'userError' nothing catches, so one such + -- term ended a whole run. + it "gets stuck on a Ξ» naming a symbol, instead of refusing the formation" $ do + (_, written) <- recorded $ \record -> do + let stuck = (withLambdas known (defaultReduceContext ExRoot)){_saveEval = record} + fire = execBuildTerm univ stuck "evaluate" [ArgExpression (ExFormation [BiLambda (FnSymbol 1)]), ArgExpression univ] substEmpty + fire `shouldThrow` (\e -> "No entry of --symbolic answers the Ξ» function '𝜎1'" `isInfixOf` show (e :: SomeException)) + written `shouldBe` " ?(𝜎1) # 𝕄(⟦ Ξ» ‍ 𝜎1 ⟧)\n" + + -- Two Ξ» bindings never reach 𝔼: the builder refuses to make a formation out + -- of them first. The case is here anyway, since what matters is that such a + -- formation fails rather than answering βŠ₯ the way a Ξ»-less one does. + it "throws when the formation carries more than one Ξ» binding" $ + runEvaluate [ArgExpression (ExFormation [BiLambda (Function "L_one"), BiLambda (Function "L_two")]), ArgExpression univ] + `shouldThrow` (\e -> "Duplicated attribute 'Ξ»'" `isInfixOf` show (e :: SomeException)) + + -- A formation with no Ξ» binding has nothing to fire, which is a question + -- the calculus answers rather than a malformed one: βŠ₯ is what 𝕄 hands back + -- for a term nobody can reduce further, and 𝔼 says the same. Only a Ξ» 𝔼 + -- cannot make sense of β€” several of them, or one standing for a meta or a + -- slot β€” is malformed and throws (see above). + forM_ + [ ("carries no binding at all", ExFormation []) + , ("carries bindings but none of them a Ξ»", ExFormation [BiVoid AtRho]) + ] + ( \(desc, form) -> + it ("answers βŠ₯ for a formation that " ++ desc) $ do + answered <- runEvaluate [ArgExpression form, ArgExpression univ] + case answered of + TeExpression expr -> expr `shouldBe` ExTermination + _ -> expectationFailure "expected TeExpression" + ) + it "evaluates a Ξ»-bearing formation to the answer of its entry, normalized" $ do + let form = ExFormation [BiLambda (Function "L_answer"), BiTau AtRho (ExFormation [BiDelta (BtOne "00")])] + answered <- withLambdasOf "- Ξ»: L_answer\n 𝑛: ⟦ Ξ” ‍ FF- ⟧\n" readLambdas + result <- execBuildTerm univ (withLambdas answered ctx) "evaluate" [ArgExpression form, ArgExpression univ] substEmpty + case result of + TeExpression expr -> expr `shouldBe` ExFormation [BiDelta (BtOne "FF"), BiVoid AtRho] + _ -> expectationFailure "expected TeExpression" diff --git a/test/FilesSpec.hs b/test/FilesSpec.hs --- a/test/FilesSpec.hs +++ b/test/FilesSpec.hs @@ -3,18 +3,27 @@ module FilesSpec where -import Control.Exception (bracket, try) +import Control.Exception (ErrorCall, bracket, try) import Control.Monad (forM_, void) +import Data.ByteString qualified as BS import Data.List (sort) +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE import Data.Time.Clock.POSIX (getPOSIXTime) -import Files (FsException (..), allPathsIn, ensuredFile) +import Files (FsException (..), allPathsIn, ensuredFile, overwrite) import System.Directory ( createDirectoryIfMissing + , executable + , getPermissions , getTemporaryDirectory + , listDirectory , removeDirectoryRecursive + , setOwnerExecutable + , setPermissions ) import System.FilePath (()) -import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy) +import System.Info (os) +import Test.Hspec (Spec, describe, it, pendingWith, shouldBe, shouldReturn, shouldSatisfy) exceptionPath :: FsException -> FilePath exceptionPath (FileDoesNotExist file) = file @@ -40,6 +49,30 @@ let path = dir "existing.txt" writeFile path "content" ensuredFile path >>= (`shouldBe` path) + + describe "overwrite" $ do + it "replaces the content of an existing file with utf-8 bytes" $ withScratchDir $ \dir -> do + let path = dir "Ο†-replaced.phi" + BS.writeFile path (TE.encodeUtf8 (T.pack "{⟦ x ↦ ΞΎ.y ⟧}")) + overwrite path "{⟦ ψ ↦ Ξ¦.org.eolang ⟧}" + TE.decodeUtf8 <$> BS.readFile path `shouldReturn` T.pack "{⟦ ψ ↦ Ξ¦.org.eolang ⟧}" + it "keeps the previous content when the new one fails half-way" $ withScratchDir $ \dir -> do + let path = dir "kept.phi" + BS.writeFile path (TE.encodeUtf8 (T.pack "{⟦ original ↦ βˆ… ⟧}")) + void (try (overwrite path ("{⟦ partial ↦ " ++ error "broken content")) :: IO (Either ErrorCall ())) + TE.decodeUtf8 <$> BS.readFile path `shouldReturn` T.pack "{⟦ original ↦ βˆ… ⟧}" + it "leaves no temporary file when the new content fails half-way" $ withScratchDir $ \dir -> do + BS.writeFile (dir "lonely.phi") BS.empty + void (try (overwrite (dir "lonely.phi") (replicate 100000 'Ο‰' ++ error "broken tail")) :: IO (Either ErrorCall ())) + listDirectory dir `shouldReturn` ["lonely.phi"] + it "keeps the executable permission of the replaced file" $ withScratchDir $ \dir -> do + let path = dir "script.sh" + BS.writeFile path BS.empty + getPermissions path >>= setPermissions path . setOwnerExecutable True + overwrite path "#!/bin/sh\necho βˆ€" + if os == "mingw32" + then pendingWith "Windows derives the executable permission from the file extension" + else executable <$> getPermissions path `shouldReturn` True describe "allPathsIn" $ do it "collects every leaf file path recursively" $ withScratchDir $ \dir -> do diff --git a/test/Fixtures.hs b/test/Fixtures.hs --- a/test/Fixtures.hs +++ b/test/Fixtures.hs @@ -4,78 +4,87 @@ -- SPDX-License-Identifier: MIT -- The Ξ» functions the specs fire. phino implements none of them, so a spec that --- needs an atom to answer brings its own: one JavaScript fixture, --- 'test-resources/atoms/primitives.js', registered under every name in --- 'fixtureAtoms' and branching on the one each request names under 'Ξ»', --- another, 'test-resources/atoms/asking.js', which reduces nothing itself and --- asks phino for its operands, a third, 'test-resources/atoms/asking-loops.js', --- which asks a question that never stops cycling, or a POSIX shell script --- written for the occasion, either run once per fire or kept resident for the --- run. +-- needs one to answer brings its own: the fixture file +-- 'test-resources/atoms.yaml', which spells them in the very rule language +-- '--symbolic' reads, or a file of its own written for the occasion. module Fixtures ( defaultReduceContext - , fixtureAtoms - , fixtureRegistry + , fixtureLambdas + , lambdasFile + , loopingLambdas , primitives - , resident - , withAskingRegistry - , withAtoms - , withExecutable - , withFixtureRegistry - , withLoopingAskRegistry - , withNode - , withRegistryOf - , withScript - , withServing - , withShell + , readUtf8 + , recorded + , recorded' + , withLambdas + , withLambdasOf , withTemp ) where -import AST (Expression) -import Atoms (Registry, emptyRegistry, readRegistry) -import Control.Exception (bracket) -import Data.Aeson (Value, encode, object, (.=)) -import Data.Aeson.Key qualified as Key +import AST (Expression (ExRoot)) +import CLI.Helpers (withEvalFunc) +import CLI.Types (IOFormat (PHI), PrintContext (PrintCtx)) +import Control.Exception (bracket, evaluate) import Data.ByteString qualified as BS -import Data.ByteString.Lazy qualified as BSL -import Data.Maybe (isNothing) +import Data.Map.Strict qualified as Map import Data.Text qualified as T -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Encoding (encodeUtf8) import Dataize (reduction) -import Deps (dontSaveEval, dontSaveStep) +import Deps (Judgment (..), SaveEvalFunc, dontSaveEval, dontSaveStep) +import Evaluate (evaluation, fired) import Functions (buildTerm) +import Lambdas (Lambdas, emptyLambdas, readLambdas) +import Lining (LineFormat (MULTILINE)) import Morph (ReduceContext (..), Steps (..)) -import System.Directory (findExecutable, getPermissions, getTemporaryDirectory, removePathForcibly, setOwnerExecutable, setPermissions) -import System.IO (Handle, hClose, openBinaryTempFile) -import System.Info (os) -import Test.Hspec (Expectation, pendingWith) +import Sugar (SugarType (SWEET)) +import System.Directory (getTemporaryDirectory, removePathForcibly) +import System.IO (Handle, IOMode (ReadMode), hClose, hGetContents, hSetEncoding, openBinaryTempFile, utf8, withFile) +import XMIR (defaultXmirContext) -- The context every reduction of a spec starts from. Shuffle is enabled so the -- suite exercises the order-independence of the morphing and dataization rules -- (#909): a hidden overlap surfaces as a nondeterministic failure instead of --- staying silently green. The registry of Ξ» functions is empty, since phino --- implements none of them: a case that needs an atom to answer brings the --- fixture registry in through 'withAtoms'. +-- staying silently green. No Ξ» function is registered, since phino implements +-- none of them: a case that needs one to answer brings the fixture file in +-- through 'withLambdas'. defaultReduceContext :: Expression -> ReduceContext -defaultReduceContext loc = ReduceContext loc 25 25 (Steps 250 0) False True False False emptyRegistry buildTerm reduction dontSaveStep dontSaveEval +defaultReduceContext loc = ReduceContext loc loc Nothing 25 25 (Steps 250 0) 1 False True False False False Morphing [] Map.empty Map.empty emptyLambdas buildTerm reduction evaluation fired dontSaveStep dontSaveEval --- The same context with the fixture Ξ» functions registered -withAtoms :: Registry -> ReduceContext -> ReduceContext -withAtoms registry ctx = ctx{_atoms = registry} +-- The same context with the given Ξ» functions registered +withLambdas :: Lambdas -> ReduceContext -> ReduceContext +withLambdas lambdas ctx = ctx{_symbolic = lambdas} +-- The file '--symbolic' reads in every case that fires one of the fixture Ξ» +-- functions, for the specs that go through the command line. +lambdasFile :: FilePath +lambdasFile = "test-resources/atoms.yaml" + +-- The same Ξ» functions, read once, for the specs that drive 𝕄 and 𝔻 directly. +fixtureLambdas :: IO Lambdas +fixtureLambdas = readLambdas lambdasFile + +-- The one Ξ» function that answers with a firing of itself, so that a run fires +-- it until the step budget is gone. Recursion is nothing phino prevents on its +-- own β€” that is the object model's business β€” so a program built on this one is +-- how the specs reach the '--max-steps' limit, and how they ask '--acyclic' to +-- end the same run before the limit does. +loopingLambdas :: (FilePath -> IO a) -> IO a +loopingLambdas = withLambdasOf "- Ξ»: L_loop\n 𝑛: ⟦ Ξ» ‍ L_loop ⟧\n" + +-- The given Ξ» functions, as the YAML file '--symbolic' reads, in a temporary +-- file removed afterwards. +withLambdasOf :: T.Text -> (FilePath -> IO a) -> IO a +withLambdasOf lambdas = withTemp "phino-symbolic-.yaml" (encodeUtf8 lambdas) + -- The EO objects the fixture Ξ» functions answer for, declared the way --- 'number.eo' and 'bytes.eo' declare them, so a case only has to spell the --- expression under Ο†. 'number.eq' is the one operation with no atom of its --- own: EO spells it out of 'L_bytes_eq' (eq.eo), so the fixture composes it the --- same way. Alongside them stand the objects the atoms hand results to: 'string' --- carries what a byte-array complaint would say, while 'true' and 'false' fill --- in for the real bool objects, since the single byte an EO bool dataizes to is --- all these cases assert. Those bytes are EO's own: 'true.eo' asserts --- 'true.as-bytes.eq FF-' and 'bool.eo' branches 'if' over 'FF-' and '00-', so a --- universe copied from here starts with a bool an EO program recognizes. --- 'number.nope' is declared and left out of the registry on purpose: it is the --- Ξ» function that cannot fire, the one '--partial' parks on. +-- 'number.eo', 'bytes.eo' and 'bool.eo' declare them, so a case only has to +-- spell the expression under Ο†. 'number.eq' is the one operation with no Ξ» +-- function of its own: EO spells it out of 'L_bytes_eq' (eq.eo), so the fixture +-- composes it the same way, and 'bool.if' is where a branch meets the symbol +-- its condition came down to. 'number.nope' is declared and left out of the +-- file on purpose: it is the Ξ» function that cannot fire, the one '--partial' +-- parks on. primitives :: String -> String primitives src = unlines @@ -85,6 +94,10 @@ , " not -> [[ L> L_bytes_not ]]," , " eq -> [[ b -> ?, L> L_bytes_eq ]]" , " ]]," + , " bool -> [[" + , " Ο† -> ?," + , " if -> [[ then -> ?, else -> ?, L> L_fork ]]" + , " ]]," , " number -> [[" , " Ο† -> ?," , " as-bytes -> $.Ο†," @@ -95,128 +108,67 @@ , " eq -> [[ x -> ?, @ -> $.^.as-bytes.eq( x.as-bytes ) ]]," , " nope -> [[ L> L_number_nope ]]" , " ]]," - , " string -> [[ Ο† -> ?, as-bytes -> $.Ο† ]]," - , " true -> [[ @ -> [[ D> FF- ]] ]]," - , " false -> [[ @ -> [[ D> 00- ]] ]]," , " @ -> " ++ src , "]]" ] --- Every Ξ» function the fixture answers for. A name outside this list is --- unregistered, which is how a spec asks for an atom that cannot fire. -fixtureAtoms :: [T.Text] -fixtureAtoms = - [ "L_number_plus" - , "L_number_times" - , "L_number_div" - , "L_number_gt" - , "L_bytes_eq" - , "L_bytes_not" - ] - --- One of the fixture scripts, read as UTF-8 rather than through the locale, --- since they spell πœ‘ expressions. -fixtureScript :: FilePath -> IO T.Text -fixtureScript name = decodeUtf8 <$> BS.readFile ("test-resources/atoms/" ++ name) - --- The registry the specs that drive 'Dataize' directly run against: the same --- file '--atoms' reads, read once and gone. -fixtureRegistry :: IO Registry -fixtureRegistry = withFixtureRegistry readRegistry - --- The same registry as the JSON file '--atoms' reads, in a temporary file --- removed afterwards, for the specs that go through the command line. -withFixtureRegistry :: (FilePath -> IO a) -> IO a -withFixtureRegistry action = do - script <- fixtureScript "primitives.js" - withRegistryOf (object [Key.fromText name .= entry script | name <- fixtureAtoms]) action - where - entry :: T.Text -> Value - entry script = object ["rt" .= ("node" :: T.Text), "script" .= script] - --- The registry of the one Ξ» function the asking fixture answers, --- 'L_number_plus', kept for the run, as the JSON file '--atoms' reads: a --- program may ask phino to reduce an operand only while its stdin is open, and --- phino closes the stdin of a program started for the fire behind its request. -withAskingRegistry :: (FilePath -> IO a) -> IO a -withAskingRegistry action = do - script <- fixtureScript "asking.js" - withRegistryOf (object ["L_number_plus" .= entry script]) action - where - entry :: T.Text -> Value - entry script = object ["rt" .= ("node" :: T.Text), "script" .= script, "serve" .= True] +-- Run the action with the function '--protocol' writes the run through, handing +-- back what it wrote alongside the answer, verbatim. The protocol goes through +-- the very plumbing the option runs, and it is handed back as the text of the +-- file and not as the lines of it, so a case asserting it asserts the very +-- bytes a user of the option reads back β€” the indentation of every record, the +-- order they stand in and the line the file ends on included. +recorded :: (SaveEvalFunc -> IO a) -> IO (a, String) +recorded = recorded' False --- The registry of the resident program that asks about a term the universe --- never finishes reducing: under '--partial' phino must park the looping --- question and hand the residual back rather than fail the run (#1078) -withLoopingAskRegistry :: (FilePath -> IO a) -> IO a -withLoopingAskRegistry action = do - script <- fixtureScript "asking-loops.js" - withRegistryOf (object ["L_number_gt" .= entry script]) action +-- The same, with the ρ bindings of every term dropped when asked, the way +-- '--hide-rho' drops them: a caller reading a protocol back for the terms an +-- entry answered with has no business reading the universe those terms were +-- fired inside, and the flag is what says so. +recorded' :: Bool -> (SaveEvalFunc -> IO a) -> IO (a, String) +recorded' hidden action = + withTemp "phino-protocol-.txt" BS.empty $ \path -> do + answer <- withEvalFunc (Just path) printing action + written <- readUtf8 path + pure (answer, written) where - entry :: T.Text -> Value - entry script = object ["rt" .= ("node" :: T.Text), "script" .= script, "serve" .= True] - --- The given JSON, as the registry file '--atoms' reads, in a temporary file --- removed afterwards. -withRegistryOf :: Value -> (FilePath -> IO a) -> IO a -withRegistryOf registry = withTemp "phino-atoms-.json" (BSL.toStrict (encode registry)) - --- Every atom the fixture provides runs under 'node', so a machine without it --- cannot fire one at all: such an expectation is pending rather than red. -withNode :: Expectation -> Expectation -withNode expectation = do - node <- findExecutable "node" - if isNothing node - then pendingWith "'node' is not installed, so no Ξ» function can be fired" - else expectation - --- A POSIX shell script is executable nowhere on Windows, so a case that needs --- one is pending there rather than red. -withShell :: Expectation -> Expectation -withShell expectation - | os == "mingw32" = pendingWith "no POSIX shell script is executable on Windows" - | otherwise = expectation - --- A file in the temporary directory holding the given POSIX shell script, --- removed afterwards. -withScript :: T.Text -> (FilePath -> IO a) -> IO a -withScript script = withTemp "phino-exec-.sh" (encodeUtf8 (T.unlines ["#!/bin/sh", script])) - --- The same file, executable, which is what an 'exec' or a 'serve' atom names --- and phino never stages itself. -withExecutable :: T.Text -> (FilePath -> IO a) -> IO a -withExecutable script action = withScript script $ \path -> do - permissions <- getPermissions path - setPermissions path (setOwnerExecutable True permissions) - action path - --- The registry of one Ξ» function, 'L_answer', kept for the run, as the JSON --- file '--atoms' reads, together with the resident program it names: a POSIX --- shell script built of the given per-request snippet (see 'resident'). Both --- files are removed afterwards. -withServing :: T.Text -> (FilePath -> IO a) -> IO a -withServing snippet action = - withExecutable (resident snippet) $ \program -> - withRegistryOf (object ["L_answer" .= object ["rt" .= ("exec" :: T.Text), "path" .= program, "serve" .= True]]) action + -- The protocol flattens every term itself, so the only things this context + -- decides are that the terms are πœ‘ and not XMIR and whether they carry + -- their ρ bindings. + printing :: PrintContext + printing = + PrintCtx + SWEET + hidden + MULTILINE + 2 + defaultXmirContext + False + False + False + False + False + 1 + 1 + ExRoot + Nothing + Nothing + Nothing + PHI --- A program as a POSIX shell script that reads phino's lines until its stdin --- closes, so it serves started once per fire and kept for the run alike: it --- counts the universes it is told in 'e' and runs the given snippet for every --- request, with the request in 'line', its number in 'id' and how many --- requests it has seen so far in 'n'. -resident :: T.Text -> T.Text -resident snippet = - T.unlines - [ "e=0" - , "n=0" - , "while IFS= read -r line; do" - , " case \"$line\" in" - , " *'\"𝑒\"'*) e=$((e+1));;" - , " *) n=$((n+1)); id=$(printf '%s' \"$line\" | sed 's/.*\"id\":\\([0-9]*\\).*/\\1/'); " <> snippet <> ";;" - , " esac" - , "done" - ] +-- Read a text file phino wrote, in the encoding it wrote it with. The whole +-- content is forced before the handle closes, since a lazy read of a closed +-- handle answers nothing. The file is read as text and not as bytes, so the +-- line terminator the platform writes is the one it reads back: on Windows +-- every line of a text file ends CRLF, and a case asserting the content of one +-- has no business seeing that. +readUtf8 :: FilePath -> IO String +readUtf8 path = + withFile path ReadMode $ \stream -> do + hSetEncoding stream utf8 + content <- hGetContents stream + _ <- evaluate (length content) + pure content -- Write the content to a fresh temporary file, hand its path to the action and -- delete the file afterwards. diff --git a/test/LaTeXSpec.hs b/test/LaTeXSpec.hs --- a/test/LaTeXSpec.hs +++ b/test/LaTeXSpec.hs @@ -9,7 +9,7 @@ -} module LaTeXSpec where -import AST (Attribute (AtLabel, AtPhi, AtRho), Binding (BiTau, BiVoid), Bytes (BtOne), Expression (ExFormation, ExMeta, ExPhiAgain, ExPhiMeet, ExRoot)) +import AST (Attribute (AtLabel, AtMeta, AtPhi, AtRho), Binding (BiDelta, BiMeta, BiTau, BiVoid), Bytes (BtMeta, BtOne), Expression (ExDispatch, ExFormation, ExMeta, ExPhiAgain, ExPhiMeet, ExRoot)) import Control.Monad (forM_) import Data.List (intercalate) import Data.Text qualified as T @@ -124,6 +124,11 @@ expressionToLaTeX nan defaultLatexContext `shouldBe` "\\begin{phiquation}\n[[ |x| -> Q . |nan| ]]{.}\n\\end{phiquation}" + it "renders a bytes meta with the '\\delta' head" $ do + bts <- parseExpressionThrows "[[ D> !d7 ]]" + expressionToLaTeX bts defaultLatexContext + `shouldBe` "\\begin{phiquation}\n[[ D> \\delta_7 ]]{.}\n\\end{phiquation}" + it "escapes '@' and '^' in an attribute label, same as '$' and '_'" $ do let weird = ExFormation [BiTau (AtLabel "a@b^c") ExRoot, BiVoid AtRho] expressionToLaTeX weird defaultLatexContext @@ -240,6 +245,7 @@ { name = "myrule" , label = Just "disp" , description = Nothing + , ematch = Nothing , pattern = ExMeta "n" , result = ExMeta "n" , when = Just (Y.NF (ExMeta "n")) @@ -272,6 +278,7 @@ { name = "myrule2" , label = Nothing , description = Nothing + , ematch = Nothing , pattern = ExMeta "n" , result = ExMeta "n" , when = Nothing @@ -292,6 +299,7 @@ { name = "myrule3" , label = Nothing , description = Nothing + , ematch = Nothing , pattern = ExMeta "n" , result = ExMeta "n" , when = Nothing @@ -383,4 +391,70 @@ , " \\phinoPremise{ \\phinoMorph{ n }{ e }{ s_1 }{ n_1 }{ s_2 } }" , " \\phinoConclusion{ \\phinoContextualize{ n }{ e }{ n_1 } }" , "\\end{phinoContextualizationInference}" + ] + + describe "bares the meta-variables a rule names just once" $ do + it "keeps the index of a kind named twice and drops it from a kind named once" $ do + let rule = + Y.DataizeRule + { name = "delta" + , label = Just "\\Delta" + , match = ExFormation [BiMeta "B1", BiDelta (BtMeta "d1"), BiMeta "B2"] + , ematch = ExMeta "e1" + , dresult = BtMeta "d1" + , when = Nothing + , premises = [] + } + explainDataizeRules [rule] + `shouldBe` intercalate + "\n" + [ "\\begin{phinoDataizationInference}" + , " \\phinoName{delta}" + , " \\phinoLabel{\\Delta}" + , " \\phinoConclusion{ \\phinoDataize{ [[ B_1, D> \\delta, B_2 ]] }{ e }{ s }{ \\delta }{ s } }" + , "\\end{phinoDataizationInference}" + ] + + it "bares a rule's condition the way it bares its pattern and result" $ do + let rule = + Y.Rule + { name = "norm1" + , label = Nothing + , description = Nothing + , ematch = Nothing + , pattern = ExDispatch (ExMeta "n1") (AtMeta "t1") + , result = ExMeta "n1" + , when = Just (Y.IsFormation (ExMeta "n1")) + , having = Nothing + , where_ = Nothing + } + explainRules [rule] + `shouldBe` intercalate + "\n " + [ "\\phinoNormalizationRule{norm1}" + , "{ n . \\tau }" + , "{ n }" + , "{ \\phinoIsFormation{ n } }" + , "{ }" + ] + + it "bares the meta a premise names, while the state keeps its own index" $ do + let rule = + Y.MorphRule + { name = "morph2" + , label = Nothing + , match = ExMeta "n1" + , ematch = ExMeta "e1" + , nresult = ExMeta "n1" + , when = Nothing + , premises = [Y.Premise{result = "d1", operation = Y.OpDataize (ExMeta "n1")}] + } + explainMorphRules [rule] + `shouldBe` intercalate + "\n" + [ "\\begin{phinoMorphingInference}" + , " \\phinoName{morph2}" + , " \\phinoPremise{ \\phinoDataize{ n }{ e }{ s_1 }{ \\delta }{ s_2 } }" + , " \\phinoConclusion{ \\phinoMorph{ n }{ e }{ s_1 }{ n }{ s_2 } }" + , "\\end{phinoMorphingInference}" ] diff --git a/test/LambdasSpec.hs b/test/LambdasSpec.hs new file mode 100644 --- /dev/null +++ b/test/LambdasSpec.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +module LambdasSpec (spec) where + +import AST +import Control.Exception (SomeException) +import Control.Monad (forM_) +import Data.List (isInfixOf) +import Data.Text qualified as T +import Fixtures (withLambdasOf) +import Lambdas (Lambda (..), Lambdas, Meta (..), emptyLambdas, joined, matched, minted, readLambdas, symbolized, taken) +import Parser (parseExpressionThrows) +import Test.Hspec + +-- The Ξ» functions the given text spells, read out of a file of its own, which +-- is how '--symbolic' reads them and the only way they are ever read +lambdasOf :: T.Text -> IO Lambdas +lambdasOf text = withLambdasOf text readLambdas + +-- One entry with the given key, one 'dataize' operand and an answer standing +-- for the unknown it came down to, which is the shape most cases start from +entry :: T.Text -> T.Text +entry key = "- Ξ»: " <> key <> "\n dataize:\n 𝛿1: $.ρ\n 𝑛: ⟦ Ξ» ‍ 𝜎 ⟧\n" + +-- The key the entry answering the given Ξ» name is registered under, or nothing +-- where no entry answers it. Lookups go through this rather than through the +-- entry itself, since an entry is no value and nothing compares two of them. +answering :: Lambdas -> T.Text -> Maybe T.Text +answering known func = _key <$> matched known func + +-- Every 'join' line of the entry answering the given Ξ» name, spelled the way +-- the file spells it: the meta it binds and the two it joins. +joins :: Lambdas -> T.Text -> [(T.Text, (T.Text, T.Text))] +joins known func = map spelled (maybe [] _paired (matched known func)) + where + spelled :: (Meta, (Meta, Meta)) -> (T.Text, (T.Text, T.Text)) + spelled (meta, (left, right)) = (_spelling meta, (_spelling left, _spelling right)) + +spec :: Spec +spec = do + describe "readLambdas" $ do + it "reads the Ξ» function its key names" $ do + known <- lambdasOf (entry "L_number_plus") + answering known "L_number_plus" `shouldBe` Just "L_number_plus" + + -- A key is a regular expression over Ξ» names, so one entry stands for the + -- whole family of them a box numbers its functions with + it "reads one Ξ» function for the whole family its key spells" $ do + known <- lambdasOf (entry "L_box_[0-9]+_number") + answering known "L_box_42_number" `shouldBe` Just "L_box_[0-9]+_number" + + -- The expression matches the whole name and not a part of it, so a plain + -- name keeps meaning that one Ξ» function + it "cannot read a Ξ» function whose name merely starts with a key" $ do + known <- lambdasOf (entry "L_number_plus") + answering known "L_number_plus_twice" `shouldBe` Nothing + + it "cannot read a Ξ» function no entry answers" $ do + known <- lambdasOf (entry "L_number_plus") + answering known "L_bytes_not" `shouldBe` Nothing + + -- A YAML mapping keeps no order of its own, so the metas are what orders + -- the operands: 𝛿1 comes down before 𝛿2 however the file lists them + it "reads the operands of 'dataize' in the order their metas number them" $ do + known <- lambdasOf "- Ξ»: L_pair\n dataize:\n 𝛿2: $.x\n 𝛿1: $.ρ\n 𝑛: ⟦ Ξ» ‍ 𝜎 ⟧\n" + map (_spelling . fst) (maybe [] _dataized (matched known "L_pair")) `shouldBe` ["𝛿1", "𝛿2"] + + -- The protocol spells a meta the way the file does, while a substitution + -- keeps it under the name πœ‘-calculus gives it, and the two differ + it "reads a meta under both the name it is spelled with and the name it binds" $ do + known <- lambdasOf "- Ξ»: L_pair\n dataize:\n 𝛿1: $.ρ\n 𝑛: ⟦ Ξ» ‍ 𝜎 ⟧\n" + map (_name . fst) (maybe [] _dataized (matched known "L_pair")) `shouldBe` ["d1"] + + it "reads the operands of 'morph' under expression metas" $ do + known <- lambdasOf "- Ξ»: L_fork\n morph:\n 𝑛1: $.then\n 𝑛2: $.else\n 𝑛: 𝑛1\n" + map (_spelling . fst) (maybe [] _morphed (matched known "L_fork")) `shouldBe` ["𝑛1", "𝑛2"] + + it "reads the operands of 'symbolize' under expression metas" $ do + known <- lambdasOf "- Ξ»: L_fork\n morph:\n 𝑛1: $.then\n symbolize:\n 𝑛2: 𝑛1\n 𝑛: 𝑛2\n" + map (_spelling . fst) (maybe [] _symbolized (matched known "L_fork")) `shouldBe` ["𝑛2"] + + -- A line of 'symbolize' stands data into unknowns, and the term it stands + -- may already be one a line above it made, so the block reads top to + -- bottom the way the metas number it + it "reads a 'symbolize' line standing the term the line above it made" $ do + known <- lambdasOf "- Ξ»: L_fork\n morph:\n 𝑛1: $.then\n symbolize:\n 𝑛2: 𝑛1\n 𝑛3: 𝑛2\n 𝑛: 𝑛3\n" + map (_spelling . fst) (maybe [] _symbolized (matched known "L_fork")) `shouldBe` ["𝑛2", "𝑛3"] + + it "reads the term an operand is reduced from" $ do + known <- lambdasOf "- Ξ»: L_pair\n dataize:\n 𝛿1: $.x\n 𝑛: ⟦ Ξ» ‍ 𝜎 ⟧\n" + operand <- parseExpressionThrows "$.x" + map snd (maybe [] _dataized (matched known "L_pair")) `shouldBe` [operand] + + it "reads the term the firing answers with" $ do + known <- lambdasOf "- Ξ»: L_pair\n 𝑛: Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎 ⟧ )\n" + term <- parseExpressionThrows "Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎 ⟧ )" + fmap _answer (matched known "L_pair") `shouldBe` Just term + + -- A fork answers neither of its branches but the join of the two, which a + -- 'join' line binds a meta of its own to, so the answer names that meta + it "reads the two metas a 'join' line joins" $ do + known <- lambdasOf "- Ξ»: L_fork\n morph:\n 𝑛1: $.then\n 𝑛2: $.else\n join:\n 𝑛3: [𝑛1, 𝑛2]\n 𝑛: 𝑛3\n" + joins known "L_fork" `shouldBe` [("𝑛3", ("𝑛1", "𝑛2"))] + + -- The two are joined in the order the line lists them, which is the order + -- the protocol writes the two symbols a fresh one stands for in + it "reads the two metas of a 'join' line in the order it lists them" $ do + known <- lambdasOf "- Ξ»: L_fork\n morph:\n 𝑛1: $.then\n 𝑛2: $.else\n join:\n 𝑛3: [𝑛2, 𝑛1]\n 𝑛: 𝑛3\n" + joins known "L_fork" `shouldBe` [("𝑛3", ("𝑛2", "𝑛1"))] + + -- 'join' runs after 'symbolize', so a line of it may join what that stage + -- stood, and a line of it may join what a line above it made + it "reads a 'join' line joining the terms a 'symbolize' line stood" $ do + known <- lambdasOf "- Ξ»: L_fork\n morph:\n 𝑛1: $.then\n 𝑛2: $.else\n symbolize:\n 𝑛3: 𝑛1\n 𝑛4: 𝑛2\n join:\n 𝑛5: [𝑛3, 𝑛4]\n 𝑛: 𝑛5\n" + joins known "L_fork" `shouldBe` [("𝑛5", ("𝑛3", "𝑛4"))] + + it "reads a 'join' line joining what a line above it joined" $ do + known <- lambdasOf "- Ξ»: L_fork\n morph:\n 𝑛1: $.a\n 𝑛2: $.b\n 𝑛3: $.c\n join:\n 𝑛4: [𝑛1, 𝑛2]\n 𝑛5: [𝑛4, 𝑛3]\n 𝑛: 𝑛5\n" + joins known "L_fork" `shouldBe` [("𝑛4", ("𝑛1", "𝑛2")), ("𝑛5", ("𝑛4", "𝑛3"))] + + it "reads an entry naming no 'join' block at all" $ do + known <- lambdasOf "- Ξ»: L_pair\n 𝑛: ⟦ Ξ» ‍ 𝜎 ⟧\n" + joins known "L_pair" `shouldBe` [] + + it "reads an entry naming neither operand block" $ do + known <- lambdasOf "- Ξ»: L_pair\n 𝑛: ⟦ Ξ» ‍ 𝜎 ⟧\n" + map (_spelling . fst) (maybe [] _dataized (matched known "L_pair")) `shouldBe` [] + + -- Everything a file may be wrong about fails where it is read, before any + -- reduction starts, so a run never gets half-way through a derivation to + -- discover that one of its Ξ» functions cannot be read at all + forM_ + [ ("a file which is no list of entries" :: String, "Ξ»: L_pair\n" :: T.Text, "cannot be read" :: String) + , ("an entry with no answer at all", "- Ξ»: L_pair\n", "cannot be read") + , ("an entry whose answer is no term of the calculus", "- Ξ»: L_pair\n 𝑛: ⟦ Ξ» ‍\n", "cannot be read") + , ("two entries under one key", entry "L_pair" <> entry "L_pair", "is used by more than one entry") + , ("a key which is no regular expression", entry "L_[pair", "is not a regular expression") + , ("an operand of 'dataize' which is no bytes meta", "- Ξ»: L_pair\n dataize:\n 𝑛1: $.x\n 𝑛: ⟦ Ξ» ‍ 𝜎 ⟧\n", "is not a bytes meta") + , ("an operand of 'morph' which is no expression meta", "- Ξ»: L_pair\n morph:\n 𝛿1: $.x\n 𝑛: ⟦ Ξ» ‍ 𝜎 ⟧\n", "is not an expression meta") + , ("an operand of 'symbolize' which is no expression meta", "- Ξ»: L_pair\n morph:\n 𝑛1: $.x\n symbolize:\n 𝛿1: 𝑛1\n 𝑛: 𝑛1\n", "is not an expression meta") + , ("an operand of 'symbolize' the entry never bound", "- Ξ»: L_pair\n symbolize:\n 𝑛2: 𝑛1\n 𝑛: 𝑛2\n", "names no meta") + , ("an operand of 'symbolize' which is no meta at all", "- Ξ»: L_pair\n morph:\n 𝑛1: $.x\n symbolize:\n 𝑛2: $.x\n 𝑛: 𝑛2\n", "names no meta") + , ("an operand of 'symbolize' standing the term of a line below it", "- Ξ»: L_pair\n morph:\n 𝑛1: $.x\n symbolize:\n 𝑛2: 𝑛3\n 𝑛3: 𝑛1\n 𝑛: 𝑛2\n", "names no meta") + , ("an operand referencing a meta the entry never matched", "- Ξ»: L_pair\n dataize:\n 𝛿1: '!n'\n 𝑛: ⟦ Ξ» ‍ 𝜎 ⟧\n", "cannot be referenced") + , ("an answer reading the data its operands came down to", "- Ξ»: L_pair\n dataize:\n 𝛿1: $.ρ\n 𝑛: ⟦ Ξ” ‍ 𝛿1 ⟧\n", "reads data") + , ("an answer carrying an anonymous meta of another kind", "- Ξ»: L_pair\n 𝑛: '⟦ Ο† ↦ !n ⟧'\n", "cannot be referenced") + , ("a 'join' line joining one meta alone", "- Ξ»: L_fork\n morph:\n 𝑛1: $.then\n join:\n 𝑛2: [𝑛1]\n 𝑛: 𝑛2\n", "must join exactly two metas") + , ("a 'join' line joining three metas", "- Ξ»: L_fork\n morph:\n 𝑛1: $.a\n 𝑛2: $.b\n 𝑛3: $.c\n join:\n 𝑛4: [𝑛1, 𝑛2, 𝑛3]\n 𝑛: 𝑛4\n", "must join exactly two metas") + , ("a 'join' line joining what is no expression meta", "- Ξ»: L_fork\n morph:\n 𝑛1: $.then\n join:\n 𝑛2: [𝑛1, $.else]\n 𝑛: 𝑛2\n", "is not an expression meta") + , ("a 'join' line bound to what is no expression meta", "- Ξ»: L_fork\n morph:\n 𝑛1: $.a\n 𝑛2: $.b\n join:\n 𝛿1: [𝑛1, 𝑛2]\n 𝑛: 𝑛1\n", "is not an expression meta") + , ("a 'join' line joining a meta the entry never bound", "- Ξ»: L_fork\n morph:\n 𝑛1: $.then\n join:\n 𝑛3: [𝑛1, 𝑛2]\n 𝑛: 𝑛3\n", "names no meta bound by 'morph' or by a line above it") + , ("a 'join' line joining a meta that came down to data", "- Ξ»: L_fork\n dataize:\n 𝛿1: $.ρ\n morph:\n 𝑛1: $.then\n join:\n 𝑛2: [𝑛1, 𝛿1]\n 𝑛: 𝑛2\n", "is not an expression meta") + , ("a 'join' line joining what a line below it made", "- Ξ»: L_fork\n morph:\n 𝑛1: $.a\n 𝑛2: $.b\n join:\n 𝑛3: [𝑛1, 𝑛4]\n 𝑛4: [𝑛1, 𝑛2]\n 𝑛: 𝑛3\n", "names no meta bound by 'morph' or by a line above it") + , ("a 'symbolize' line standing what a 'join' line made", "- Ξ»: L_fork\n morph:\n 𝑛1: $.a\n 𝑛2: $.b\n symbolize:\n 𝑛5: 𝑛3\n join:\n 𝑛3: [𝑛1, 𝑛2]\n 𝑛: 𝑛5\n", "names no meta bound by 'morph' or by a line above it") + ] + ( \(desc, text, message) -> + it ("cannot read " ++ desc) $ + lambdasOf text `shouldThrow` (\err -> message `isInfixOf` show (err :: SomeException)) + ) + + describe "emptyLambdas" $ + -- A run without '--symbolic' fires against no Ξ» function at all, which is + -- what every name getting stuck means and what '--partial' parks on + it "cannot read a Ξ» function without the file naming one" $ + answering emptyLambdas "L_number_plus" `shouldBe` Nothing + + -- Which symbol a fresh 𝜎 becomes is the state's business and not the file's: + -- the count of symbols the run has minted so far goes in and the names taken + -- come back out, so no two unknowns of one run are ever spelled alike. + describe "minted" $ do + it "mints one fresh symbol per bare 𝜎 the answer carries" $ do + answer <- parseExpressionThrows "⟦ a ↦ ⟦ Ξ» ‍ 𝜎 ⟧, b ↦ ⟦ Ξ» ‍ 𝜎 ⟧ ⟧" + map snd (fst (minted answer 4)) `shouldBe` [FnSymbol 5, FnSymbol 6] + + it "counts every symbol it minted into the state" $ do + answer <- parseExpressionThrows "⟦ a ↦ ⟦ Ξ» ‍ 𝜎 ⟧, b ↦ ⟦ Ξ» ‍ 𝜎 ⟧ ⟧" + snd (minted answer 4) `shouldBe` 6 + + -- A symbol the answer names is one the entry means, not one it asks for, + -- so nothing is minted for it + it "mints nothing for a symbol the answer already numbers" $ do + answer <- parseExpressionThrows "⟦ Ξ» ‍ 𝜎1 ⟧" + fst (minted answer 4) `shouldBe` [] + + it "mints nothing for an answer carrying no symbol at all" $ do + answer <- parseExpressionThrows "⟦ Ξ” ‍ 00- ⟧" + snd (minted answer 4) `shouldBe` 4 + + -- A datum a term carries is a value somebody worked out, and a normal form + -- reached from an unknown carries none, so the two compare as expressions + -- only once the data of the one are unknowns too. Standing them is what a + -- 'symbolize' line of an entry asks for. + describe "symbolized" $ do + it "stands every datum of a term into an unknown" $ do + term <- parseExpressionThrows "⟦ Ο† ↦ Ξ¦.f( Ο† ↦ ⟦ Ξ” ‍ 00- ⟧ )( t ↦ ⟦ Ξ” ‍ FF- ⟧ ) ⟧" + unknown <- parseExpressionThrows "⟦ Ο† ↦ Ξ¦.f( Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧ )( t ↦ ⟦ Ξ» ‍ 𝜎6 ⟧ ) ⟧" + let (masked, _, _) = symbolized term 4 + masked `shouldBe` unknown + + -- A 𝜎 is the name of a Ξ» function and no term, so the bytes are not bound + -- to it: what is known is that dataizing the formation it names answers + -- them + it "tells the data every symbol it minted stands for" $ do + term <- parseExpressionThrows "⟦ Ο† ↦ Ξ¦.f( Ο† ↦ ⟦ Ξ” ‍ 00- ⟧ )( t ↦ ⟦ Ξ” ‍ FF- ⟧ ) ⟧" + let (_, known, _) = symbolized term 4 + known `shouldBe` [(5, BtOne "00"), (6, BtOne "FF")] + + it "counts every symbol it minted into the state" $ do + term <- parseExpressionThrows "⟦ Ο† ↦ Ξ¦.f( Ο† ↦ ⟦ Ξ” ‍ 00- ⟧ )( t ↦ ⟦ Ξ” ‍ FF- ⟧ ) ⟧" + let (_, _, spent) = symbolized term 4 + spent `shouldBe` 6 + + -- A term carries the value it stands for where its Ο† chain ends, so a + -- datum anywhere else is not that value: the literal of a method is the + -- body of something nobody has called, and standing it would write an + -- unknown nobody reads. The method comes back exactly as it was written + -- (#1293). + it "leaves a datum standing outside the Ο† chain alone" $ do + term <- parseExpressionThrows "⟦ Ο† ↦ ⟦ Ξ” ‍ 00- ⟧, neg ↦ ⟦ Ο† ↦ ⟦ Ξ” ‍ FF- ⟧ ⟧ ⟧" + unknown <- parseExpressionThrows "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧, neg ↦ ⟦ Ο† ↦ ⟦ Ξ” ‍ FF- ⟧ ⟧ ⟧" + let (masked, known, spent) = symbolized term 4 + masked `shouldBe` unknown + known `shouldBe` [(5, BtOne "00")] + spent `shouldBe` 5 + + -- A term nobody worked a value out in is an unknown already, and standing + -- it changes nothing + it "leaves a term carrying no datum as it was written" $ do + term <- parseExpressionThrows "Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )" + let (masked, _, _) = symbolized term 4 + masked `shouldBe` term + + -- A literal is sugar for a datum sitting three levels down inside a + -- formation, which is the very place a computed value keeps its unknown + it "stands a datum standing as the argument of an application" $ do + term <- parseExpressionThrows "Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ” ‍ 00- ⟧ ) )" + unknown <- parseExpressionThrows "Ξ¦.number( Ο† ↦ Ξ¦.bytes( Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧ ) )" + let (masked, _, _) = symbolized term 4 + masked `shouldBe` unknown + + -- It is the Ξ” binding that becomes an unknown and not the formation around + -- it, since a datum carries a ρ of its own and so does the unknown it is + -- put beside + it "keeps what the formation of a datum carries besides the datum" $ do + term <- parseExpressionThrows "⟦ Ξ” ‍ 00-, ρ ↦ ⟦⟧ ⟧" + unknown <- parseExpressionThrows "⟦ Ξ» ‍ 𝜎5, ρ ↦ ⟦⟧ ⟧" + let (masked, _, _) = symbolized term 4 + masked `shouldBe` unknown + + -- A term carries the value it stands for where its Ο† chain ends, and a + -- datum sitting under ρ belongs to the object around this one: a normal + -- form drags the whole universe it was reduced inside along under ρ, so a + -- walk reaching into it would stand the data of the whole program into + -- unknowns to say one thing about one term + it "leaves the data a ρ carries alone" $ do + term <- parseExpressionThrows "⟦ Ο† ↦ ⟦ Ξ” ‍ 00- ⟧, ρ ↦ ⟦ x ↦ ⟦ Ξ” ‍ FF- ⟧ ⟧ ⟧" + unknown <- parseExpressionThrows "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧, ρ ↦ ⟦ x ↦ ⟦ Ξ” ‍ FF- ⟧ ⟧ ⟧" + let (masked, _, _) = symbolized term 4 + masked `shouldBe` unknown + + it "mints nothing for a term carrying no datum at all" $ do + term <- parseExpressionThrows "Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )" + let (_, _, spent) = symbolized term 4 + spent `shouldBe` 4 + + -- Neither branch of a fork is the value the fork answers with, since nobody + -- has picked between the two: what stands for either of them is the shape + -- both of them have, with a fresh symbol wherever they differ + describe "joined" $ do + let joining :: String -> String -> Int -> IO (Maybe (Expression, [(Int, (Int, Int))], Int)) + joining left right spent = do + one <- parseExpressionThrows left + two <- parseExpressionThrows right + pure (joined one two spent) + + it "joins two branches differing in one symbol into a fresh one" $ do + term <- parseExpressionThrows "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧ ⟧" + made <- joining "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧" "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ⟧" 4 + fmap (\(joint, _, _) -> joint) made `shouldBe` Just term + + -- A 𝜎 is the name of a Ξ» function and nothing is assigned to it, so what + -- comes back beside the term is which two symbols the fresh one stands for + it "tells the two symbols every fresh one stands for" $ do + made <- joining "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧" "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ⟧" 4 + fmap (\(_, facts, _) -> facts) made `shouldBe` Just [(5, (1, 2))] + + it "counts every symbol it minted into the state" $ do + made <- joining "⟦ Ο† ↦ Ξ¦.f( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )( t ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ) ⟧" "⟦ Ο† ↦ Ξ¦.f( Ο† ↦ ⟦ Ξ» ‍ 𝜎3 ⟧ )( t ↦ ⟦ Ξ» ‍ 𝜎4 ⟧ ) ⟧" 4 + fmap (\(_, _, spent) -> spent) made `shouldBe` Just 6 + + -- Two pairs are two choices and get two names of their own + it "mints one symbol per pair of differing symbols" $ do + made <- joining "⟦ Ο† ↦ Ξ¦.f( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )( t ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ) ⟧" "⟦ Ο† ↦ Ξ¦.f( Ο† ↦ ⟦ Ξ» ‍ 𝜎3 ⟧ )( t ↦ ⟦ Ξ» ‍ 𝜎4 ⟧ ) ⟧" 4 + fmap (\(_, facts, _) -> facts) made `shouldBe` Just [(5, (1, 3)), (6, (2, 4))] + + -- One pair met twice is one choice however often the two terms differ by + -- it, so it keeps the symbol it was given the first time + it "mints one symbol for the pair it meets twice" $ do + term <- parseExpressionThrows "⟦ Ο† ↦ Ξ¦.f( Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧ )( t ↦ ⟦ Ξ» ‍ 𝜎5 ⟧ ) ⟧" + made <- joining "⟦ Ο† ↦ Ξ¦.f( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )( t ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ) ⟧" "⟦ Ο† ↦ Ξ¦.f( Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ )( t ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ) ⟧" 4 + made `shouldBe` Just (term, [(5, (1, 2))], 5) + + -- Only the Ο† chain is compared, the value of a branch being where that + -- chain ends. Two branches differing inside a method are not two values: + -- the method is code nobody has called, the first branch's copy of it is + -- what the answer keeps, and nothing is minted for the difference (#1293). + it "carries a method from the first branch and mints nothing for it" $ do + term <- parseExpressionThrows "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧, neg ↦ ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎7 ⟧ ⟧ ⟧" + made <- joining "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, neg ↦ ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎7 ⟧ ⟧ ⟧" "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, neg ↦ ⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎8 ⟧ ⟧ ⟧" 4 + made `shouldBe` Just (term, [(5, (1, 2))], 5) + + -- What the two branches are is still read off their shape: a binding one + -- of them carries under a name the other does not is no fork at all, and + -- carrying the first branch's bindings never papers over that + it "refuses two branches whose bindings are named differently" $ do + made <- joining "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, m ↦ ⟦ x ↦ βˆ… ⟧ ⟧" "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, other ↦ ⟦ x ↦ βˆ… ⟧ ⟧" 4 + made `shouldBe` Nothing + + -- Two branches nothing tells apart are the answer themselves: there is + -- nothing to pick between and no unknown to stand for the pick + it "joins two branches that are one term into that very term" $ do + term <- parseExpressionThrows "Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )" + made <- joining "Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )" "Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )" 4 + made `shouldBe` Just (term, [], 4) + + it "joins two branches through the argument of an application" $ do + term <- parseExpressionThrows "Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧ )" + made <- joining "Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )" "Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ )" 4 + fmap (\(joint, _, _) -> joint) made `shouldBe` Just term + + -- A term carries the value it stands for where its Ο† chain ends, and what + -- sits under ρ belongs to the object around this one: the two branches of + -- a fork are reduced in scopes of their own, so their ρ differ wherever + -- that reduction left a trace and comparing them would refuse the join + -- over something saying nothing about either branch + it "leaves what a ρ carries alone" $ do + term <- parseExpressionThrows "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎5 ⟧, ρ ↦ ⟦ x ↦ ⟦ Ξ” ‍ 00- ⟧ ⟧ ⟧" + made <- joining "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, ρ ↦ ⟦ x ↦ ⟦ Ξ” ‍ 00- ⟧ ⟧ ⟧" "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, ρ ↦ ⟦ y ↦ ⟦ Ξ” ‍ FF- ⟧ ⟧ ⟧" 4 + made `shouldBe` Just (term, [(5, (1, 2))], 5) + + -- Two branches nothing but their ρ tells apart are one value, so nothing + -- is minted for what stands under it + it "joins two branches differing in their ρ alone" $ do + term <- parseExpressionThrows "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, ρ ↦ ⟦ x ↦ ⟦ Ξ” ‍ 00- ⟧ ⟧ ⟧" + made <- joining "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, ρ ↦ ⟦ x ↦ ⟦ Ξ” ‍ 00- ⟧ ⟧ ⟧" "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧, ρ ↦ ⟦ y ↦ ⟦ Ξ” ‍ FF- ⟧ ⟧ ⟧" 4 + made `shouldBe` Just (term, [], 4) + + -- The join is strict and a datum is never joined with anything, which is + -- why a branch carrying one goes through 'symbolized' first + forM_ + [ ("a datum with a symbol" :: String, "⟦ Ο† ↦ ⟦ Ξ” ‍ 00- ⟧ ⟧" :: String, "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧" :: String) + , ("two different data", "⟦ Ο† ↦ ⟦ Ξ” ‍ 00- ⟧ ⟧", "⟦ Ο† ↦ ⟦ Ξ” ‍ FF- ⟧ ⟧") + , ("a symbol with a Ξ» function nothing else names", "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧", "⟦ Ο† ↦ ⟦ Ξ» ‍ L_number_plus ⟧ ⟧") + , ("two branches one of which carries a binding more", "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧", "⟦ Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧, x ↦ ⟦⟧ ⟧") + , ("two branches binding their symbols under different attributes", "⟦ a ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ ⟧", "⟦ b ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ ⟧") + , ("two branches of different forma", "Ξ¦.number( Ο† ↦ ⟦ Ξ» ‍ 𝜎1 ⟧ )", "Ξ¦.bool( Ο† ↦ ⟦ Ξ» ‍ 𝜎2 ⟧ )") + ] + ( \(desc, left, right) -> + it ("cannot join " ++ desc) $ do + made <- joining left right 4 + fmap (\(joint, _, _) -> joint) made `shouldBe` Nothing + ) + + -- A program written by an earlier run holds symbols of its own, and a fresh + -- one must never be spelled like one of them + describe "taken" $ do + it "takes the last symbol the program already carries" $ do + program <- parseExpressionThrows "⟦ a ↦ ⟦ Ξ» ‍ 𝜎3 ⟧, b ↦ ⟦ Ξ» ‍ 𝜎7 ⟧ ⟧" + taken program `shouldBe` 7 + + it "takes nothing from a program carrying no symbol" $ do + program <- parseExpressionThrows "⟦ Ξ” ‍ 00- ⟧" + taken program `shouldBe` 0 diff --git a/test/MatcherSpec.hs b/test/MatcherSpec.hs --- a/test/MatcherSpec.hs +++ b/test/MatcherSpec.hs @@ -6,10 +6,12 @@ module MatcherSpec where import AST +import Control.Exception (evaluate) import Control.Monad (forM_) import Data.Map.Strict qualified as Map import Data.Text qualified as T import Matcher +import System.Timeout (timeout) import Test.Hspec (Example (Arg), Expectation, Spec, SpecWith, describe, it, shouldBe) substs :: [[(T.Text, MetaValue)]] -> [Subst] @@ -163,7 +165,7 @@ describe "matchFunction: function => function => substitution" $ forM_ - [ ("!f => Func => [(!f >> Func)]", FnMeta "f", Function "Func", substs [[("f", MvFunction "Func")]]) + [ ("!f => Func => [(!f >> Func)]", FnMeta "f", Function "Func", substs [[("f", MvFunction (Function "Func"))]]) , ("Func => Func => [()]", Function "Func", Function "Func", substs [[]]) , ("Func => Other => []", Function "Func", Function "Other", substs []) ] @@ -535,3 +537,18 @@ ) ] (\(desc, first, second, expected) -> it desc (combine first second `shouldBe` expected)) + + describe "matchBindings: a meta binding over a crowded formation" $ + it "dont cut the target anew at every index a meta binding may end at" $ do + matched <- timeout 5000000 (evaluate (length (matchExpression dot (ExDispatch (crowd 3000) (AtLabel "d1"))))) + matched `shouldBe` Just 1 + 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 + -- the dispatch names. + dot :: Expression + dot = ExDispatch (ExFormation [BiMeta "B1", BiTau (AtMeta "t1") (ExMeta "n1"), BiMeta "B2"]) (AtMeta "t1") + -- A formation of that many bindings, none of which the pattern above says + -- anything about beyond standing in one of its two runs. + crowd :: Int -> Expression + crowd size = ExFormation [BiTau (AtLabel (T.pack ("d" <> show idx))) (ExFormation [BiDelta (BtOne "00")]) | idx <- [1 .. size]] diff --git a/test/MetasSpec.hs b/test/MetasSpec.hs new file mode 100644 --- /dev/null +++ b/test/MetasSpec.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- SPDX-FileCopyrightText: Copyright (c) 2025 Objectionary.com +-- SPDX-License-Identifier: MIT + +{- | Tests for the Metas module that collects the meta-variables a term was +written with and drops the index from the ones that stand alone in their kind. +-} +module MetasSpec where + +import AST + ( Attribute (AtAny, AtMeta) + , Binding (BiDelta, BiMeta, BiTau, BiVoid) + , Bytes (BtMeta) + , Expression (ExAny, ExDispatch, ExFormation, ExMeta) + , Slot (Slot) + ) +import Metas (Metas (metas), lonely) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = do + describe "metas" $ do + it "names every meta-variable a formation was written with" $ + metas (ExFormation [BiMeta "B1", BiTau (AtMeta "t1") (ExMeta "n1"), BiDelta (BtMeta "d1")]) + `shouldBe` ["B1", "t1", "n1", "d1"] + + it "names an anonymous meta-variable by the sigil of its kind alone" $ + metas (ExDispatch (ExAny (Slot "n" 3)) (AtAny (Slot "t" 7))) `shouldBe` ["n", "t"] + + describe "lonely" $ do + it "drops the index from every kind the term names just once" $ + lonely (ExDispatch (ExMeta "n1") (AtMeta "t1")) `shouldBe` ExDispatch (ExMeta "n") (AtMeta "t") + + it "dont drop the index from a kind the term names twice" $ + lonely (ExFormation [BiMeta "B1", BiMeta "B2"]) `shouldBe` ExFormation [BiMeta "B1", BiMeta "B2"] + + it "dont drop the index of a kind an anonymous meta-variable already stands for" $ + lonely (ExFormation [BiVoid (AtMeta "t1"), BiVoid (AtAny (Slot "t" 9))]) + `shouldBe` ExFormation [BiVoid (AtMeta "t1"), BiVoid (AtAny (Slot "t" 9))] + + it "dont drop a suffix that counts nothing" $ + lonely (ExMeta "nfoo") `shouldBe` ExMeta "nfoo" diff --git a/test/MorphSpec.hs b/test/MorphSpec.hs --- a/test/MorphSpec.hs +++ b/test/MorphSpec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -10,7 +11,6 @@ module MorphSpec (spec) where import AST -import Atoms (Registry, emptyRegistry, readRegistry) import Control.Exception (SomeException) import Control.Monad import Data.Aeson (FromJSON) @@ -19,21 +19,23 @@ import Data.Maybe (fromMaybe) import Data.Yaml qualified as Decode import Dataize (Outcome (..), dataize) -import Deps (Term (TeExpression)) +import Deps (State, Term (TeExpression)) import Files (allPathsIn) -import Fixtures (defaultReduceContext, fixtureRegistry, primitives, withAtoms, withNode, withServing, withShell) +import Fixtures (defaultReduceContext, fixtureLambdas, primitives, withLambdas, withLambdasOf) import GHC.Generics (Generic) +import Lambdas (Lambdas, emptyLambdas, readLambdas) import Matcher (substEmpty) import Morph (ReduceContext (..), emptyState, execBuildTerm, insideUniverse, morph, morph') import Parser (parseExpressionThrows) import Rewriter (Rewritten) import Rule (RuleContext (RuleContext), matchExpressionWithRule') import System.FilePath (makeRelative) +import Tau (seedTaus) import Test.Hspec import Yaml (ExtraArgument (..)) import Yaml qualified -test' :: (Eq a, Show a) => ((Expression, NonEmpty Rewritten) -> Expression -> String -> ReduceContext -> IO ((a, NonEmpty Rewritten), String)) -> [(String, Expression, Expression, a)] -> Spec +test' :: (Eq a, Show a) => ((Expression, NonEmpty Rewritten) -> Expression -> State -> ReduceContext -> IO ((a, NonEmpty Rewritten), State)) -> [(String, Expression, Expression, a)] -> Spec test' func useCases = forM_ useCases $ \(desc, input, expr, output) -> it desc $ do @@ -43,13 +45,13 @@ -- One case of 𝕄, as a pack of 'test-resources/morph-packs' β€” or, for the deep -- walk, of 'test-resources/morph-deep-packs' β€” spells it: the program under -- 'input', wrapped in the fixture object model where 'model' says so and run --- against the fixture Ξ» functions where 'atoms' does, entered at 'location' and --- answering either the program under 'result' or the failure under 'fails'. +-- against the fixture Ξ» functions where 'symbolic' does, entered at 'location' +-- and answering either the program under 'result' or the failure under 'fails'. data MorphPack = MorphPack { location :: Maybe String , input :: String , model :: Maybe Bool - , atoms :: Maybe Bool + , symbolic :: Maybe Bool , partial :: Maybe Bool , result :: Maybe String , fails :: Maybe String @@ -57,36 +59,33 @@ deriving (Generic, Show, FromJSON) -- Morph one such pack and check what it answers, walking every binding where --- 'deep' says so, since that is what tells the two pack directories apart. A --- pack that registers the fixture Ξ» functions fires one under 'node', so it is --- pending where 'node' is not installed. -testMorph :: Registry -> Bool -> FilePath -> Expectation -testMorph registry deep pth = do +-- 'deep' says so, since that is what tells the two pack directories apart. +testMorph :: Lambdas -> Bool -> FilePath -> Expectation +testMorph known deep pth = do MorphPack{..} <- Decode.decodeFileThrow pth expr <- parseExpressionThrows (if model == Just True then primitives input else input) + seedTaus expr loc <- parseExpressionThrows (fromMaybe "Q" location) let ctx = (defaultReduceContext loc) { _deep = deep , _partial = partial == Just True - , _atoms = if atoms == Just True then registry else emptyRegistry + , _symbolic = if symbolic == Just True then known else emptyLambdas } - checked :: Expectation - checked = case (result, fails) of - (Just res, Nothing) -> do - expected <- parseExpressionThrows res - (morphed, _) <- morph expr ctx - morphed `shouldBe` expected - (Nothing, Just message) -> - morph expr ctx `shouldThrow` (\err -> message `isInfixOf` show (err :: SomeException)) - _ -> expectationFailure "The pack holds neither a single 'result' nor a single 'fails'" - if atoms == Just True then withNode checked else checked + case (result, fails) of + (Just res, Nothing) -> do + expected <- parseExpressionThrows res + (morphed, _, _) <- morph expr emptyState ctx + morphed `shouldBe` expected + (Nothing, Just message) -> + morph expr emptyState ctx `shouldThrow` (\err -> message `isInfixOf` show (err :: SomeException)) + _ -> expectationFailure "The pack holds neither a single 'result' nor a single 'fails'" spec :: Spec spec = do - -- Every Ξ» function a case may fire comes from the fixture registry, read - -- once here: phino carries none of its own (see 'Fixtures'). - registry <- runIO fixtureRegistry + -- Every Ξ» function a case may fire comes from the fixture file, read once + -- here: phino carries none of its own (see 'Fixtures'). + known <- runIO fixtureLambdas -- The top-level 𝕄 entry point, the one the 'morph' command runs: it locates -- the subterm, threads the whole input expression as the universe and hands @@ -94,14 +93,14 @@ describe "morph" $ do let resources = "test-resources/morph-packs" packs <- runIO (allPathsIn resources) - forM_ packs (\pth -> it (makeRelative resources pth) (testMorph registry False pth)) + forM_ packs (\pth -> it (makeRelative resources pth) (testMorph known False pth)) -- The chain runs oldest step first and carries the rule that produced the -- step after it, exactly as 'dataize' reports its own, so '--sequence' -- prints both the same way it "reports the chain of steps oldest first" $ do expr <- parseExpressionThrows "[[ D> 00- ]]" - (morphed, chain) <- morph expr (defaultReduceContext ExRoot) + (morphed, chain, _) <- morph expr emptyState (defaultReduceContext ExRoot) morphed `shouldBe` expr map snd chain `shouldBe` [Just "mf", Nothing] map fst chain `shouldBe` [expr, expr] @@ -115,19 +114,18 @@ describe "morph with '_deep'" $ do let resources = "test-resources/morph-deep-packs" packs <- runIO (allPathsIn resources) - forM_ packs (\pth -> it (makeRelative resources pth) (testMorph registry True pth)) + forM_ packs (\pth -> it (makeRelative resources pth) (testMorph known True pth)) -- The walk enters a dispatch through its target and fires the box it finds -- there before 𝕄 is ever asked about the dispatch, while 'ml' demands that -- Ξ» only where the dispatched attribute is none of the box's own (#1187) describe "a dispatch naming an attribute of the formation it stands on" $ it "cannot fire the Ξ» the dispatch does not demand" $ - withShell $ - withServing "printf '{\"id\": %s, \"𝑛\": \"⟦ Ξ” ‍ FF- ⟧\"}\\n' \"$id\"" $ \path -> do - box <- readRegistry path - world <- parseExpressionThrows "[[ foo -> [[ f -> [[ a -> ?, @ -> $.a, L> L_answer ]] ]], x -> Q.foo.f( a -> [[ D> 01- ]] ).@ ]]" - (morphed, _) <- morph world (withAtoms box (defaultReduceContext ExRoot)){_deep = True} - morphed `shouldBe` world + withLambdasOf "- Ξ»: L_answer\n 𝑛: ⟦ Ξ” ‍ FF- ⟧\n" $ \file -> do + box <- readLambdas file + world <- parseExpressionThrows "[[ foo -> [[ f -> [[ a -> ?, @ -> $.a, L> L_answer ]] ]], x -> Q.foo.f( a -> [[ D> 01- ]] ).@ ]]" + (morphed, _, _) <- morph world emptyState (withLambdas box (defaultReduceContext ExRoot)){_deep = True} + morphed `shouldBe` world describe "morph'" $ test' @@ -140,7 +138,7 @@ ( "Q.x (Q -> [[ x -> [[]] ]]) => [[ ρ -> Q ]]" , ExDispatch ExRoot (AtLabel "x") , ExFormation [BiTau (AtLabel "x") (ExFormation [])] - , ExFormation [BiTau AtRho (ExFormation [BiTau (AtLabel "x") (ExFormation [BiVoid AtRho]), BiVoid AtRho])] + , ExFormation [BiTau AtRho ExRoot] ) , -- A void slot fed a non-absolute argument can never be filled, so 'copy' -- cannot fire and the application is a stuck normal form. Before #959, @@ -184,49 +182,12 @@ morph' (ExMeta "unbound", (ExRoot, Nothing) :| []) ExRoot emptyState (defaultReduceContext ExRoot) `shouldThrow` (\e -> "no morphing rule matched" `isInfixOf` show (e :: SomeException)) - -- 'execBuildTerm's "evaluate" and "morph" cases expose 𝔼 and 𝕄 to the - -- matcher's condition path (guards in 'when'/'having'). No built-in rule's - -- guard actually calls either function, so these error paths β€” reachable only - -- by malformed arguments β€” are exercised here directly through the exported - -- 'execBuildTerm', the same way the matcher would call it. - describe "execBuildTerm 'evaluate'" $ do - let univ = ExFormation [] - ctx = withAtoms registry (defaultReduceContext ExRoot) - runEvaluate args = execBuildTerm univ ctx "evaluate" args substEmpty - forM_ - [ - ( "the first argument is not a formation" - , [ArgExpression ExRoot, ArgExpression univ] - , "Function evaluate() expects a formation" - ) - , - ( "the formation has no Ξ» binding at all" - , [ArgExpression (ExFormation []), ArgExpression univ] - , "expects a formation with a" - ) - , - ( "a non-Ξ» formation still has other bindings" - , [ArgExpression (ExFormation [BiVoid AtRho]), ArgExpression univ] - , "expects a formation with a" - ) - , - ( "not given exactly two expression arguments" - , [ArgExpression univ] - , "requires exactly 2 expression arguments" - ) - ] - ( \(desc, args, message) -> - it ("throws when " ++ desc) $ - runEvaluate args `shouldThrow` (\e -> message `isInfixOf` show (e :: SomeException)) - ) - it "evaluates a Ξ»-bearing formation to the atom's normalized result" $ - withNode $ do - let form = ExFormation [BiLambda (Function "L_bytes_not"), BiTau AtRho (ExFormation [BiDelta (BtOne "00")])] - result <- runEvaluate [ArgExpression form, ArgExpression univ] - case result of - TeExpression expr -> expr `shouldBe` dataBytes (BtOne "FF") - _ -> expectationFailure "expected TeExpression" - + -- 'execBuildTerm's "morph" case exposes 𝕄 to the matcher's condition path + -- (guards in 'when'/'having'), the way its "evaluate" case exposes 𝔼 (see + -- 'EvaluateSpec'). No built-in rule's guard actually calls the function, so + -- these error paths β€” reachable only by malformed arguments β€” are exercised + -- here directly through the exported 'execBuildTerm', the same way the + -- matcher would call it. describe "execBuildTerm 'morph'" $ do let univ = ExFormation [] ctx = defaultReduceContext ExRoot @@ -239,25 +200,25 @@ TeExpression expr -> expr `shouldBe` ExFormation [BiDelta (BtOne "00")] _ -> expectationFailure "expected TeExpression" - -- An expression that is not part of the program β€” the operand an atom script - -- asks phino to reduce β€” is bound to a synthetic attribute of the universe and - -- that attribute is what 𝔻 is aimed at. This is what the '--inside' option - -- runs, and what phino did internally while the atoms still lived in the - -- binary. + -- An expression that is not part of the program is bound to a synthetic + -- attribute of the universe and that attribute is what 𝔻 is aimed at. This is + -- what the '--inside' option runs, and what the 'dataize' block of a Ξ» + -- function runs for every operand it names. describe "insideUniverse" $ do let universe = "[[ y -> [[ D> 02- ]] ]]" reduced src = do univ <- parseExpressionThrows universe target <- parseExpressionThrows src (extended, ctx) <- insideUniverse target univ (defaultReduceContext ExRoot) - fst <$> dataize extended ctx + (outcome, _, _) <- dataize extended emptyState ctx + pure outcome it "reduces an expression the program does not contain" $ do value <- reduced "Q.y" value `shouldBe` Dataized (BtOne "02") -- 𝔻 accepts normal forms only, and a dispatch off a formation is not one: -- 'dot' still applies to it. So the expression is normalized first, which - -- is the whole reason an atom script cannot simply splice it into the - -- universe itself. + -- is the whole reason an operand cannot simply be spliced into the universe + -- as it was written. it "normalizes what it is handed before 𝔻 sees it" $ do value <- reduced "[[ x -> [[ D> 01- ]] ]].x" value `shouldBe` Dataized (BtOne "01") @@ -284,7 +245,7 @@ ( "a dispatch over a formation" , ExDispatch ExRoot (AtLabel "x") , ExFormation [BiTau (AtLabel "x") (ExFormation [])] - , ExFormation [BiTau AtRho (ExFormation [BiTau (AtLabel "x") (ExFormation [BiVoid AtRho]), BiVoid AtRho])] + , ExFormation [BiTau AtRho ExRoot] ) ] forM_ cases $ \(desc, input, univ, expected) -> @@ -301,7 +262,7 @@ 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 - asRule r = Yaml.Rule r.name Nothing Nothing r.match ExRoot r.when Nothing Nothing + asRule r = Yaml.Rule r.name Nothing Nothing r.match Nothing ExRoot r.when Nothing Nothing lambdaFormation = ExFormation [BiLambda (Function "L_dummy"), BiVoid AtRho] it "does not fire on a Ξ»-bearing formation dispatch" $ do substs <- matchExpressionWithRule' [substEmpty] (ExDispatch lambdaFormation (AtLabel "x")) (asRule (morphRule "md")) rctx @@ -318,4 +279,4 @@ let base = ExFormation [BiLambda (Function "F")] chain = ExDispatch (ExDispatch (ExDispatch base (AtLabel "a")) (AtLabel "b")) (AtLabel "c") morph' (chain, (ExRoot, Nothing) :| []) ExRoot emptyState (defaultReduceContext ExRoot) - `shouldThrow` (\e -> "Atom 'F' does not exist" `isInfixOf` show (e :: SomeException)) + `shouldThrow` (\e -> "No entry of --symbolic answers the Ξ» function 'F'" `isInfixOf` show (e :: SomeException)) diff --git a/test/ParserSpec.hs b/test/ParserSpec.hs --- a/test/ParserSpec.hs +++ b/test/ParserSpec.hs @@ -71,9 +71,9 @@ ) ) , ("[[]](x -> $, y -> Q)", Just (ExApplication (ExApplication (ExFormation [BiVoid AtRho]) (ArTau (AtLabel "x") ExXi)) (ArTau (AtLabel "y") ExRoot))) - , ("[[!B0, !B1]]", Just (ExFormation [BiMeta "B0", BiMeta "B1"])) + , ("[[!B1, !B2]]", Just (ExFormation [BiMeta "B1", BiMeta "B2"])) , ("[[!B2, !t2 -> $]]", Just (ExFormation [BiMeta "B2", BiTau (AtMeta "t2") ExXi])) - , ("!e0", Just (ExMeta "e0")) + , ("!e1", Just (ExMeta "e1")) , ("!k1", Just (ExMeta "k1")) , ("[[x -> !k1]]", Just (ExFormation [BiTau (AtLabel "x") (ExMeta "k1"), BiVoid AtRho])) , ("[[x -> !e1]]", Just (ExFormation [BiTau (AtLabel "x") (ExMeta "e1"), BiVoid AtRho])) @@ -82,7 +82,7 @@ , ("[[D> 1F-]]", Just (ExFormation [BiDelta (BtOne "1F"), BiVoid AtRho])) , ("[[\n L> Func,\n D> 00-\n]]", Just (ExFormation [BiLambda (Function "Func"), BiDelta (BtOne "00"), BiVoid AtRho])) , ("[[D> 1F-2A-00]]", Just (ExFormation [BiDelta (BtMany ["1F", "2A", "00"]), BiVoid AtRho])) - , ("[[D> !d0]]", Just (ExFormation [BiDelta (BtMeta "d0"), BiVoid AtRho])) + , ("[[D> !d1]]", Just (ExFormation [BiDelta (BtMeta "d1"), BiVoid AtRho])) , ("[[L> Function]]", Just (ExFormation [BiLambda (Function "Function"), BiVoid AtRho])) , ("[[L> !F3]]", Just (ExFormation [BiLambda (FnMeta "F3"), BiVoid AtRho])) , ("[[x() -> [[]] ]]", Just (ExFormation [BiTau (AtLabel "x") (ExFormation [BiVoid AtRho]), BiVoid AtRho])) @@ -104,16 +104,16 @@ ) ) , - ( "!e0(x(^,@) -> [[w -> !e1]])" + ( "!e1(x(^,@) -> [[w -> !e2]])" , Just ( ExApplication - (ExMeta "e0") + (ExMeta "e1") ( ArTau (AtLabel "x") ( ExFormation [ BiVoid AtRho , BiVoid AtPhi - , BiTau (AtLabel "w") (ExMeta "e1") + , BiTau (AtLabel "w") (ExMeta "e2") ] ) ) @@ -192,11 +192,11 @@ ) ) , - ( "[[𝐡1, 𝜏0 -> $, x -> 𝑒1]]" + ( "[[𝐡1, 𝜏1 -> $, x -> 𝑒1]]" , Just ( ExFormation [ BiMeta "B1" - , BiTau (AtMeta "t0") ExXi + , BiTau (AtMeta "t1") ExXi , BiTau (AtLabel "x") (ExMeta "e1") ] ) @@ -210,7 +210,7 @@ , "Q.x(y() -> [[]])" , "Q.x(y(q) -> [[w -> !e]])" , "Q.x(~1(^,@) -> [[]])" - , "Q.x.^.@.!t0" + , "Q.x.^.@.!t1" , "[[x -> y.z]]" , "[[x -> ^, y -> @, z -> !t]]" , "Q.x(a.b.c, Q.a(b), [[]])" @@ -253,7 +253,7 @@ , "Q.x(1, 2, !B)" , "Q.x.Ξ±0" , "Q.x(~1 -> Q.y, x -> 5, !B1)" - , "Q.x(𝐡1, 𝜏0 -> $, x -> 𝑒)" + , "Q.x(𝐡1, 𝜏1 -> $, x -> 𝑒)" , "[[ x -> \"\\uD800\"]]" , "[[ x -> \"\\uDFFF\"]]" , "[[ x -> \"\\uD835\\u0041\"]]" @@ -282,6 +282,17 @@ , ("[[ x -> ]]", "expecting '?', 'βˆ…', or expression head") ] + describe "rejects a meta variable indexed with zero" $ + fails + parseExpression + [ ("!e0", "indexed with zero") + , ("𝑛0", "indexed with zero") + , ("[[ !t0 -> Q ]]", "indexed with zero") + , ("[[ D> 𝛿0 ]]", "indexed with zero") + , ("[[ Ξ» ‍ 𝜎0 ]]", "indexed with zero") + , ("[[ !B ]](α𝑖0 -> !e)", "indexed with zero") + ] + describe "parse packs" $ do packs <- runIO (allPathsIn "test-resources/parser-packs") forM_ @@ -310,10 +321,11 @@ , ("1F-2A-00", Just (BtMany ["1F", "2A", "00"])) , ("01-02-03-04-05", Just (BtMany ["01", "02", "03", "04", "05"])) , ("!d1", Just (BtMeta "d1")) - , ("!d0", Just (BtMeta "d0")) + , ("!d2", Just (BtMeta "d2")) , ("!d_test", Just (BtMeta "d_test")) - , ("Ξ΄1", Just (BtMeta "d1")) - , ("Ξ΄0", Just (BtMeta "d0")) + , ("𝛿1", Just (BtMeta "d1")) + , ("𝛿2", Just (BtMeta "d2")) + , ("Ξ΄0", Nothing) , ("GG-", Nothing) , ("0-", Nothing) , ("000-", Nothing) @@ -332,7 +344,7 @@ , ("ρ -> Q", Just (BiTau AtRho ExRoot)) , ("Ο† -> T", Just (BiTau AtPhi ExTermination)) , ("!t1 -> $", Just (BiTau (AtMeta "t1") ExXi)) - , ("!t0 -> Q", Just (BiTau (AtMeta "t0") ExRoot)) + , ("!t2 -> Q", Just (BiTau (AtMeta "t2") ExRoot)) , ("D> --", Just (BiDelta BtEmpty)) , ("D> 42-", Just (BiDelta (BtOne "42"))) , ("D> 01-02-03", Just (BiDelta (BtMany ["01", "02", "03"]))) @@ -344,11 +356,17 @@ , ("L> AΟ†", Just (BiLambda (Function "AΟ†"))) , ("Ξ» ‍ Test", Just (BiLambda (Function "Test"))) , ("L> !F1", Just (BiLambda (FnMeta "F1"))) - , ("L> !F0", Just (BiLambda (FnMeta "F0"))) + , ("L> !F2", Just (BiLambda (FnMeta "F2"))) , ("Ξ» ‍ 𝑓1", Just (BiLambda (FnMeta "F1"))) , ("L> 𝑓2", Just (BiLambda (FnMeta "F2"))) + , ("L> 𝜎1", Just (BiLambda (FnSymbol 1))) + , ("Ξ» ‍ 𝜎2", Just (BiLambda (FnSymbol 2))) + , ("L> !S1", Just (BiLambda (FnSymbol 1))) + , ("Ξ» ‍ !S2", Just (BiLambda (FnSymbol 2))) + , ("L> 𝜎", Just (BiLambda (FnFresh (Slot "S" 3)))) + , ("Ξ» ‍ !S", Just (BiLambda (FnFresh (Slot "S" 4)))) , ("!B1", Just (BiMeta "B1")) - , ("!B0", Just (BiMeta "B0")) + , ("!B2", Just (BiMeta "B2")) , ("!B_test", Just (BiMeta "B_test")) , ("𝐡1", Just (BiMeta "B1")) , ("𝐡1", Just (BiMeta "B1")) @@ -376,10 +394,10 @@ , ("@", Just AtPhi) , ("Ο†", Just AtPhi) , ("!t1", Just (AtMeta "t1")) - , ("!t0", Just (AtMeta "t0")) + , ("!t2", Just (AtMeta "t2")) , ("!t_test", Just (AtMeta "t_test")) , ("𝜏1", Just (AtMeta "t1")) - , ("𝜏0", Just (AtMeta "t0")) + , ("𝜏2", Just (AtMeta "t2")) , ("a0", Just (AtLabel "a0")) , ("a1", Just (AtLabel "a1")) , ("a123", Just (AtLabel "a123")) @@ -535,10 +553,10 @@ test parseExpression [ ("!e1", Just (ExMeta "e1")) - , ("!e0", Just (ExMeta "e0")) + , ("!e2", Just (ExMeta "e2")) , ("!e_test", Just (ExMeta "e_test")) , ("𝑒1", Just (ExMeta "e1")) - , ("𝑒0", Just (ExMeta "e0")) + , ("𝑒2", Just (ExMeta "e2")) , ("!e1.x", Just (ExDispatch (ExMeta "e1") (AtLabel "x"))) , ("!e1(Q)", Just (ExApplication (ExMeta "e1") (ArAlpha (Alpha 0) ExRoot))) , ("!n1", Just (ExMeta "n1")) @@ -620,7 +638,7 @@ forM_ [ ("exposes an _alpha field parsing an alpha directly", parseMaybe (_alpha phiParser) "~3" `shouldBe` Just (Alpha 3)) , ("exposes an _attribute field parsing an attribute directly", parseMaybe (_attribute phiParser) "foo" `shouldBe` Just (AtLabel "foo")) - , ("exposes an _index field parsing an index meta directly", parseMaybe (_index phiParser) "!i0" `shouldBe` Just (Right "i0")) + , ("exposes an _index field parsing an index meta directly", parseMaybe (_index phiParser) "!i1" `shouldBe` Just (Right "i1")) , ("exposes a _binding field parsing a binding directly", parseMaybe (_binding phiParser) "x -> $" `shouldBe` Just (BiTau (AtLabel "x") ExXi)) , ("exposes an _expression field parsing an expression directly", parseMaybe (_expression phiParser) "Q.x" `shouldBe` Just (ExDispatch ExRoot (AtLabel "x"))) , ("exposes a _string field parsing a quoted string directly", parseMaybe (_string phiParser) "\"hi\"" `shouldBe` Just "hi") diff --git a/test/PrinterSpec.hs b/test/PrinterSpec.hs --- a/test/PrinterSpec.hs +++ b/test/PrinterSpec.hs @@ -62,6 +62,15 @@ it desc (printExpression' expr (SWEET, ASCII, SINGLELINE, defaultMargin) `shouldBe` expected) ) + describe "printExpression with ASCII reads a bytes meta back" $ + forM_ + [("d1", "d1"), ("d_Z-9", "d_Z-9"), ("dbytes", "dbytes")] + ( \(desc, name) -> + it desc $ do + let expr = ExFormation [BiDelta (BtMeta name), BiVoid AtRho] + parseExpression (printExpression' expr (SWEET, ASCII, SINGLELINE, defaultMargin)) `shouldBe` Right expr + ) + describe "printExpression with SWEET UNICODE renders the pretty function meta" $ it "meta lambda becomes 𝑓" $ printExpression' (ExFormation [BiLambda (FnMeta "F")]) (SWEET, UNICODE, SINGLELINE, defaultMargin) `shouldBe` "⟦ Ξ» ‍ 𝑓 ⟧" @@ -296,7 +305,7 @@ [ ("empty bytes", BtEmpty, "--") , ("single byte", BtOne "1F", "1F-") , ("multiple bytes", BtMany ["00", "01", "02"], "00-01-02") - , ("meta bytes", BtMeta "D", "Ξ΄") + , ("meta bytes", BtMeta "D", "𝛿") ] ( \(desc, bts, expected) -> it desc (printBytes bts `shouldBe` expected) @@ -320,7 +329,7 @@ , ("MvExpression", [Subst (Map.singleton (Named "e") (MvExpression ExRoot))], (SWEET, UNICODE, MULTILINE, defaultMargin), "e >> Ξ¦") , ("MvBytes", [Subst (Map.singleton (Named "b") (MvBytes (BtOne "1F")))], (SWEET, UNICODE, MULTILINE, defaultMargin), "b >> 1F-") , ("MvBindings", [Subst (Map.singleton (Named "bnd") (MvBindings [BiVoid (AtLabel "y")]))], (SWEET, UNICODE, MULTILINE, defaultMargin), "bnd >> ⟦ y ↦ βˆ… ⟧") - , ("MvFunction", [Subst (Map.singleton (Named "f") (MvFunction "func"))], (SWEET, UNICODE, MULTILINE, defaultMargin), "f >> func") + , ("MvFunction", [Subst (Map.singleton (Named "f") (MvFunction (Function "func")))], (SWEET, UNICODE, MULTILINE, defaultMargin), "f >> func") , ( "keys of a multi-entry substitution are sorted and each is on its own line" , [Subst (Map.fromList [(Named "a", MvIndex 1), (Named "b", MvIndex 2)])] diff --git a/test/RenderSpec.hs b/test/RenderSpec.hs --- a/test/RenderSpec.hs +++ b/test/RenderSpec.hs @@ -65,7 +65,7 @@ [ ("empty", BT_EMPTY, "--") , ("one", BT_ONE "1F", "1F-") , ("many", BT_MANY ["00", "01", "02"], "00-01-02") - , ("meta", BT_META (META NO_EXCL D "1"), "Ξ΄1") + , ("meta", BT_META (META NO_EXCL D "1"), "𝛿1") , ("piped", BT_PIPED (BT_ONE "1F"), "|1F-|") ] (\(desc, bts, expected) -> it desc (render bts `shouldBe` expected)) @@ -85,8 +85,9 @@ , (I', "i") , (B, "𝐡") , (B', "B") - , (D, "Ξ΄") + , (D, "𝛿") , (D', "\\delta") + , (D'', "d") , (F, "𝑓") , (F', "F") ] @@ -142,8 +143,8 @@ , ("PA_DELTA'", PA_DELTA' (BT_ONE "1F"), "D> 1F-") , ("PA_META_LAMBDA", PA_META_LAMBDA (META NO_EXCL F "n"), "Ξ» ‍ 𝑓n") , ("PA_META_LAMBDA'", PA_META_LAMBDA' (META EXCL F' "n"), "L> !Fn") - , ("PA_META_DELTA", PA_META_DELTA (META NO_EXCL D "n"), "Ξ” ‍ Ξ΄n") - , ("PA_META_DELTA'", PA_META_DELTA' (META EXCL D' "n"), "D> !\\deltan") + , ("PA_META_DELTA", PA_META_DELTA (META NO_EXCL D "n"), "Ξ” ‍ 𝛿n") + , ("PA_META_DELTA'", PA_META_DELTA' (META EXCL D'' "n"), "D> !dn") ] (\(desc, node, expected) -> it desc (render node `shouldBe` expected)) diff --git a/test/RewriterSpec.hs b/test/RewriterSpec.hs --- a/test/RewriterSpec.hs +++ b/test/RewriterSpec.hs @@ -92,7 +92,7 @@ ) ] ( \(desc, rewriteRules, (maxDepth, maxCycles, depthSensitive), expected) -> it desc $ do - let action = rewrite ExRoot rewriteRules (RewriteContext ExRoot maxDepth maxCycles depthSensitive buildTerm MtDisabled Nothing dontSaveStep) + let action = rewrite ExRoot rewriteRules (RewriteContext ExRoot maxDepth maxCycles depthSensitive Nothing buildTerm MtDisabled Nothing dontSaveStep) case expected of Left fragment -> action `shouldThrow` (\exc -> fragment `isInfixOf` show (exc :: SomeException)) Right predicate -> do @@ -149,6 +149,7 @@ repeat' repeat' False + Nothing buildTerm must' Nothing diff --git a/test/RuleSpec.hs b/test/RuleSpec.hs --- a/test/RuleSpec.hs +++ b/test/RuleSpec.hs @@ -89,6 +89,7 @@ Nothing Nothing (ExFormation [BiMeta "B"]) + Nothing (ExMeta "B") Nothing (Just [Yaml.Extra (Yaml.ArgBinding (BiMeta "J")) "join" [Yaml.ArgBinding (BiMeta "B")]]) @@ -101,6 +102,7 @@ Nothing Nothing (ExMeta "e") + Nothing (ExMeta "e") Nothing ( Just @@ -117,6 +119,7 @@ Nothing Nothing (ExFormation [BiTau (AtLabel "x") (ExPhiMeet Nothing 0 (ExMeta "n1")), BiVoid AtRho]) + Nothing (ExMeta "n1") Nothing Nothing @@ -129,6 +132,7 @@ Nothing Nothing (ExFormation [BiTau (AtLabel "x") (ExPhiAgain Nothing 0 (ExMeta "n2")), BiVoid AtRho]) + Nothing (ExMeta "n2") Nothing Nothing diff --git a/test/YamlSpec.hs b/test/YamlSpec.hs --- a/test/YamlSpec.hs +++ b/test/YamlSpec.hs @@ -124,49 +124,49 @@ ( "in 'n-result' of a morphing rule" , failsWith "anonymous meta '!n' cannot be referenced in 'n-result' of rule 'foo'" - (decodeYaml' (inferring "e-match: 𝑒0\nn-result: '𝑛'") :: Either Yaml.ParseException MorphRule) + (decodeYaml' (inferring "e-match: 𝑒2\nn-result: '𝑛'") :: Either Yaml.ParseException MorphRule) ) , ( "in a premise of a morphing rule" , failsWith "anonymous meta '!e' cannot be referenced in 'premises' of rule 'foo'" - (decodeYaml' (inferring "e-match: 𝑒0\nn-result: 𝑛1\npremises:\n - n-result: 𝑛1\n normalize: '𝑒'") :: Either Yaml.ParseException MorphRule) + (decodeYaml' (inferring "e-match: 𝑒2\nn-result: 𝑛1\npremises:\n - n-result: 𝑛1\n normalize: '𝑒'") :: Either Yaml.ParseException MorphRule) ) , ( "in 'when' of a morphing rule" , failsWith "anonymous meta '!e' cannot be referenced in 'when' of rule 'foo'" - (decodeYaml' (inferring "e-match: 𝑒0\nn-result: 𝑛1\nwhen:\n formation: '𝑒'") :: Either Yaml.ParseException MorphRule) + (decodeYaml' (inferring "e-match: 𝑒2\nn-result: 𝑛1\nwhen:\n formation: '𝑒'") :: Either Yaml.ParseException MorphRule) ) , ( "in 'd-result' of a dataization rule" , failsWith "anonymous meta '!d' cannot be referenced in 'd-result' of rule 'foo'" - (decodeYaml' (inferring "e-match: 𝑒0\nd-result: 'Ξ΄'") :: Either Yaml.ParseException DataizeRule) + (decodeYaml' (inferring "e-match: 𝑒2\nd-result: '𝛿'") :: Either Yaml.ParseException DataizeRule) ) , ( "in 'when' of a dataization rule" , failsWith "anonymous meta '!e' cannot be referenced in 'when' of rule 'foo'" - (decodeYaml' (inferring "e-match: 𝑒0\nd-result: Ξ΄0\nwhen:\n formation: '𝑒'") :: Either Yaml.ParseException DataizeRule) + (decodeYaml' (inferring "e-match: 𝑒2\nd-result: 𝛿1\nwhen:\n formation: '𝑒'") :: Either Yaml.ParseException DataizeRule) ) , ( "in a premise of a dataization rule" , failsWith "anonymous meta '!e' cannot be referenced in 'premises' of rule 'foo'" - (decodeYaml' (inferring "e-match: 𝑒0\nd-result: Ξ΄0\npremises:\n - d-result: Ξ΄0\n dataize: '𝑒'") :: Either Yaml.ParseException DataizeRule) + (decodeYaml' (inferring "e-match: 𝑒2\nd-result: 𝛿1\npremises:\n - d-result: 𝛿1\n dataize: '𝑒'") :: Either Yaml.ParseException DataizeRule) ) , ( "in a premise of a contextualization rule" , failsWith "anonymous meta '!e' cannot be referenced in 'premises' of rule 'foo'" - (decodeYaml' (inferring "c-match: π‘˜0\nc-result: 𝑛1\npremises:\n - n-result: 𝑛1\n normalize: '𝑒'") :: Either Yaml.ParseException ContextualizeRule) + (decodeYaml' (inferring "c-match: π‘˜1\nc-result: 𝑛1\npremises:\n - n-result: 𝑛1\n normalize: '𝑒'") :: Either Yaml.ParseException ContextualizeRule) ) , ( "in 'c-result' of a contextualization rule" , failsWith "anonymous meta '!k' cannot be referenced in 'c-result' of rule 'foo'" - (decodeYaml' (inferring "c-match: π‘˜0\nc-result: 'π‘˜'") :: Either Yaml.ParseException ContextualizeRule) + (decodeYaml' (inferring "c-match: π‘˜1\nc-result: 'π‘˜'") :: Either Yaml.ParseException ContextualizeRule) ) ] (\(desc, rejected) -> it ("rejects an anonymous meta " ++ desc) (rejected `shouldBe` True))