├── .gitignore ├── .header ├── .ocamlinit ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── data ├── kernel.json └── notebook1.ipynb ├── doc └── examples.adoc ├── dune-project ├── src ├── cli │ ├── dune │ └── stimsym_cli.ml ├── core │ ├── Base_types.ml │ ├── Bit_set.ml │ ├── Bit_set.mli │ ├── Builtins.ml │ ├── Builtins.mli │ ├── Builtins_advanced.ml │ ├── Builtins_advanced.mli │ ├── Completion.ml │ ├── Completion.mli │ ├── Document.ml │ ├── Document.mli │ ├── Eval.ml │ ├── Eval.mli │ ├── Expr.ml │ ├── Expr.mli │ ├── Hash.ml │ ├── Hash.mli │ ├── Lexer.mll │ ├── Lexer_full_form.mli │ ├── Lexer_full_form.mll │ ├── Parse_loc.ml │ ├── Parse_loc.mli │ ├── Parser.mly │ ├── Pattern.ml │ ├── Pattern.mli │ ├── Printer.ml │ ├── Printer.mli │ ├── Slice.ml │ ├── Slice.mli │ ├── Stimsym.ml │ ├── Subst.ml │ ├── Subst.mli │ └── dune └── server │ ├── dune │ └── stimsym_server.ml ├── stimsym-server.opam ├── stimsym.opam └── tests ├── dune └── run_tests.ml /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | .*.swo 3 | _build 4 | *.native 5 | *.byte 6 | .session 7 | TAGS 8 | *.docdir 9 | setup.* 10 | qtest* 11 | *.html 12 | .merlin 13 | *.install 14 | -------------------------------------------------------------------------------- /.header: -------------------------------------------------------------------------------- 1 | (* This file is free software. See file "license" for more details. *) 2 | -------------------------------------------------------------------------------- /.ocamlinit: -------------------------------------------------------------------------------- 1 | #use "topfind";; 2 | #require "containers";; 3 | #require "containers.unix";; 4 | #require "containers.data";; 5 | #require "sequence";; 6 | #require "zarith";; 7 | #directory "_build/src/core";; 8 | #load "stimsym.cma";; 9 | 10 | open Stimsym;; 11 | 12 | #install_printer Expr.pp;; 13 | 14 | module E = Expr;; 15 | 16 | print_endline "define expr_of_string";; 17 | let expr_of_string s = 18 | let buf = Lexing.from_string s in 19 | Parser.parse_expr Lexer.token buf;; 20 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh 3 | script: bash -ex .travis-docker.sh 4 | services: 5 | - docker 6 | env: 7 | global: 8 | - PINS="stimsym:." 9 | - DISTRO="ubuntu-16.04" 10 | matrix: 11 | - PACKAGE="stimsym" OCAML_VERSION="4.03" 12 | #- PACKAGE="stimsym" OCAML_VERSION="4.04" 13 | - PACKAGE="stimsym" OCAML_VERSION="4.06" 14 | #- PACKAGE="stimsym" OCAML_VERSION="4.07" 15 | - PACKAGE="stimsym" OCAML_VERSION="4.08" 16 | - PACKAGE="stimsym" OCAML_VERSION="4.09" 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Simon Cruanes 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | Redistributions of source code must retain the above copyright notice, this 8 | list of conditions and the following disclaimer. Redistributions in binary 9 | form must reproduce the above copyright notice, this list of conditions and 10 | the following disclaimer in the documentation and/or other materials 11 | provided with the distribution. 12 | 13 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 14 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 15 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 16 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 17 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 18 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 19 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 20 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 21 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 22 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 23 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | all: build test 3 | 4 | build: 5 | @dune build @install 6 | 7 | clean: 8 | @dune clean 9 | 10 | test: 11 | @dune runtest 12 | 13 | watch: 14 | @dune build @install -w 15 | 16 | jupyter: 17 | cd data; jupyter-notebook notebook1.ipynb 18 | 19 | KERNEL_DIR=$${HOME}/.local/share/jupyter/kernels/stimsym/ 20 | 21 | install_kernel: 22 | mkdir -p $(KERNEL_DIR) 23 | cp data/kernel.json $(KERNEL_DIR)/ 24 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Stimsym [![build status](https://travis-ci.org/c-cube/stimsym.svg?branch=master)](https://travis-ci.org/c-cube/stimsym) 2 | 3 | Rewrite system designed for symbolic manipulations and maximal expressiveness. 4 | 5 | Why?! Well, I see that Mathematica as a symbolic language has a lot of 6 | nice features, and is rooted in term rewriting. However, because of 7 | its price and closedness, I started this small project. The goal is certainly 8 | not to reimplement all the complex mathematical primitives of Mathematica; 9 | instead, I just want a terse, powerful language in a sandbox (here, a Jupyter 10 | notebook or a CLI interface). 11 | 12 | I drew a lot of inspiration from https://github.com/jyh1/mmaclone/, which 13 | was also my reference for operator priorities for the expression parser. 14 | Stimsym is not yet feature complete (it lacks AC matching, among others, 15 | for now), but it has a Jupyter interface and I believe the architecture might 16 | scale a bit better if lots of primitives were added. Most of the code 17 | for the Jupyter frontend is adapted from 18 | [IOCaml](https://github.com/andrewray/iocaml) 19 | so as to use `lwt-zmq` and work with Jupyter 4. 20 | 21 | ## Build 22 | 23 | I recommend using [opam](https://opam.ocaml.org). The following will 24 | clone this repository, and use opam to install the dependencies and 25 | the program itself 26 | 27 | ``` 28 | git clone https://github.com/c-cube/stimsym.git 29 | cd stimsym 30 | opam pin add -k git -n stimsym 31 | opam install stimsym 32 | ``` 33 | 34 | For the jupyter frontend, some more dependencies are needed (see 'opam' to 35 | see which one exactly, but it should be something along: 36 | `opam install zmq atdgen yojson uuidm lwt lwt-zmq`). 37 | 38 | ## Usage 39 | 40 | Once installed, you can either use the simple command line interface: 41 | 42 | ```mathematica 43 | $ stimsym_cli 44 | > 1+1 45 | 2 46 | > f[1,2,g[3],4,5] //. f[l1__,l2__,g[x_],r__] :> h[r,x,l2,l1] 47 | h[4,5,3,2,1] 48 | > {f[a],f[b],f[c],f[d]} //. f[x_] /; ((x===a)||(x===c)) :> g[x] 49 | List[g[a],f[b],g[c],f[d]] 50 | ``` 51 | 52 | ### Some Examples 53 | 54 | See [the list of commented examples](doc/examples.adoc) to 55 | get an idea of how to use Stimsym. 56 | The file 'tests/run_tests.ml' also contains a lot of small test cases. 57 | 58 | Some notebooks can be found on 59 | the [gallery branch](https://github.com/c-cube/stimsym/tree/gallery), 60 | including [an improved version of the examples](https://github.com/c-cube/stimsym/blob/gallery/data/notebook_examples.ipynb). 61 | 62 | ### Jupyter Interface 63 | 64 | Use the (experimental) library 65 | [jupyter-kernel](https://github.com/ocaml-jupyter/jupyter-kernel). 66 | Recommended way is 67 | `jupyter kernelspec install data/ --name=stimsym --user --replace` 68 | You can also copy manually 'data/kernel.json' into the directory 69 | `~/.local/share/jupyter/kernels/stimsym`. 70 | 71 | ``` 72 | mkdir -p ~/.local/share/jupyter/kernels/stimsym 73 | cp data/kernel.json ~/.local/share/jupyter/kernels/stimsym/ 74 | 75 | opam pin add -k git jupyter-kernel https://github.com/ocaml-jupyter/jupyter-kernel.git 76 | ``` 77 | 78 | Start the jupyter notebook with `jupyter-notebook`; 79 | you can find a sample notebook in 'data/notebook1.ipynb'. The `make jupyter` 80 | target will open the sample notebook. 81 | 82 | ## License 83 | 84 | BSD license, you can modify as you like. Contributions are welcome. 85 | 86 | ## Hacking 87 | 88 | Almost everything in the language itself can be found in `src/core/Expr.ml`, 89 | `src/core/Eval.ml{,i}` and `src/core/Pattern.ml{,i}`; 90 | the primitives are in `src/core/Builtins.ml`. 91 | The rest is about parsing, CLI, jupyter frontend, etc. The code is relatively 92 | naive and will certainly not perform well, and there is a lot of room for 93 | algorithmic improvement. 94 | 95 | If (who knows?) you are interested in hacking on this in any way, do not 96 | hesitate to contact me or just say "hi" on IRC. I'd be interested in 97 | discussing or helping. 98 | 99 | ## Why the name? 100 | 101 | It is a reference to Dan Simmons' _Hyperion_ series of books, with the 102 | suffix "sym" altered because, hey, we're doing _symbolic_ stuff around here! 103 | 104 | -------------------------------------------------------------------------------- /data/kernel.json: -------------------------------------------------------------------------------- 1 | { 2 | "argv": 3 | ["stimsym_server", 4 | "--connection-file", 5 | "{connection_file}" 6 | ], 7 | "interrupt_mode": "message", 8 | "display_name": "Stimsym", 9 | "language": "stimsym" 10 | } 11 | -------------------------------------------------------------------------------- /data/notebook1.ipynb: -------------------------------------------------------------------------------- 1 | { 2 | "cells": [ 3 | { 4 | "cell_type": "code", 5 | "execution_count": 1, 6 | "metadata": {}, 7 | "outputs": [ 8 | { 9 | "data": { 10 | "text/plain": [ 11 | "2\n" 12 | ] 13 | }, 14 | "execution_count": 1, 15 | "metadata": {}, 16 | "output_type": "execute_result" 17 | } 18 | ], 19 | "source": [ 20 | "1+1" 21 | ] 22 | }, 23 | { 24 | "cell_type": "code", 25 | "execution_count": 2, 26 | "metadata": {}, 27 | "outputs": [ 28 | { 29 | "data": { 30 | "text/plain": [ 31 | "{{1,2,3}}\n" 32 | ] 33 | }, 34 | "execution_count": 2, 35 | "metadata": {}, 36 | "output_type": "execute_result" 37 | } 38 | ], 39 | "source": [ 40 | "{{1,2,3}}" 41 | ] 42 | }, 43 | { 44 | "cell_type": "code", 45 | "execution_count": 3, 46 | "metadata": {}, 47 | "outputs": [ 48 | { 49 | "data": { 50 | "text/plain": [ 51 | "h[4,5,3,2,1]\n" 52 | ] 53 | }, 54 | "execution_count": 3, 55 | "metadata": {}, 56 | "output_type": "execute_result" 57 | } 58 | ], 59 | "source": [ 60 | "f[1,2,g[3],4,5] //. f[l1__,l2__,g[x_],r__] :> h[r,x,l2,l1]" 61 | ] 62 | }, 63 | { 64 | "cell_type": "code", 65 | "execution_count": 4, 66 | "metadata": {}, 67 | "outputs": [ 68 | { 69 | "data": { 70 | "text/plain": [ 71 | "{b}\n" 72 | ] 73 | }, 74 | "execution_count": 4, 75 | "metadata": {}, 76 | "output_type": "execute_result" 77 | } 78 | ], 79 | "source": [ 80 | "f[g[a1,b,c1],h[a2,b,c2]] //. f[g[___,x_,___],h[___,y_,___]] /; x===y :> {x}" 81 | ] 82 | }, 83 | { 84 | "cell_type": "code", 85 | "execution_count": 5, 86 | "metadata": {}, 87 | "outputs": [], 88 | "source": [ 89 | "(* the bubble sort rule *)\n", 90 | "sortRule := {x___,y_,z_,k___}/;(y>z) :> {x,z,y,k}" 91 | ] 92 | }, 93 | { 94 | "cell_type": "code", 95 | "execution_count": 6, 96 | "metadata": {}, 97 | "outputs": [ 98 | { 99 | "data": { 100 | "text/plain": [ 101 | "{26,44,47,48,49,49,50,51,59,64,67,71,71,73,96}\n" 102 | ] 103 | }, 104 | "execution_count": 6, 105 | "metadata": {}, 106 | "output_type": "execute_result" 107 | } 108 | ], 109 | "source": [ 110 | "{64, 44, 71, 48, 96, 47, 59, 71, 73, 51, 67, 50, 26, 49, 49}//.sortRule" 111 | ] 112 | }, 113 | { 114 | "cell_type": "code", 115 | "execution_count": 7, 116 | "metadata": {}, 117 | "outputs": [ 118 | { 119 | "data": { 120 | "text/plain": [ 121 | "Sat[{a->True,b->True,c->True,d->False}]\n" 122 | ] 123 | }, 124 | "execution_count": 7, 125 | "metadata": {}, 126 | "output_type": "execute_result" 127 | } 128 | ], 129 | "source": [ 130 | "res1 = SatSolve[a&&b && (!a || c||d) && !d];\n", 131 | "res1" 132 | ] 133 | }, 134 | { 135 | "cell_type": "code", 136 | "execution_count": 8, 137 | "metadata": {}, 138 | "outputs": [ 139 | { 140 | "data": { 141 | "text/plain": [ 142 | "{a,b,c}\n" 143 | ] 144 | }, 145 | "execution_count": 8, 146 | "metadata": {}, 147 | "output_type": "execute_result" 148 | } 149 | ], 150 | "source": [ 151 | "(* extract the true atoms using a comprehension *)\n", 152 | "{x :: Sat[{m___}]<-res1,(x_->True)<<-m}" 153 | ] 154 | }, 155 | { 156 | "cell_type": "code", 157 | "execution_count": 9, 158 | "metadata": { 159 | "scrolled": true 160 | }, 161 | "outputs": [ 162 | { 163 | "data": { 164 | "text/plain": [ 165 | "Unsat[]\n" 166 | ] 167 | }, 168 | "execution_count": 9, 169 | "metadata": {}, 170 | "output_type": "execute_result" 171 | } 172 | ], 173 | "source": [ 174 | "SatSolve[a&&b&&(!a||!b)]" 175 | ] 176 | }, 177 | { 178 | "cell_type": "code", 179 | "execution_count": 10, 180 | "metadata": { 181 | "scrolled": true 182 | }, 183 | "outputs": [ 184 | { 185 | "data": { 186 | "text/html": [ 187 | "

SatSolve

`SatSolve[form]` calls a SAT solver on the formula given as parameter. The formula is reduced to CNF automatically before calling Minisat.

If Minisat is not installed, this does not reduce.

Returns either `Sat[{m___}]` where `m` is the model, as a list of bindings `Atom -> True` or `Atom -> False`, or Unsat[].

example

The following call will return `Unsat[]`.

`SatSolve[(A || B)&& (!A || B) && !B]`

example

The following call will return `Sat[A -> False,B->True]`, containing a model for each atom appearing in the formulas.

`SatSolve[And[A || B,!A]]`

example

  • Find a model of `a&&b` and extract the value of `a` in the model using `Let`:

    `Let[{___,a->r_,___}<<-SatSolve[a&&b],r]`

  • also check that the model reduces the formula to `True`:

    `Let[Sat[m_]<-SatSolve[a&&b], a&&b//. m]`

  • convert the model into (possibly negated) atoms:

    Let[Sat[m_]<-SatSolve[a&&b,!c], m//.{(x_->False):>!x, (x_->True):>x}]

    (yield `{a,b,!c}`)

requires

`minisat` must be on the $PATH

\n" 188 | ] 189 | }, 190 | "metadata": {}, 191 | "output_type": "display_data" 192 | } 193 | ], 194 | "source": [ 195 | "Doc[SatSolve]" 196 | ] 197 | }, 198 | { 199 | "cell_type": "code", 200 | "execution_count": 11, 201 | "metadata": {}, 202 | "outputs": [ 203 | { 204 | "data": { 205 | "text/plain": [ 206 | "True\n" 207 | ] 208 | }, 209 | "execution_count": 11, 210 | "metadata": {}, 211 | "output_type": "execute_result" 212 | } 213 | ], 214 | "source": [ 215 | "Let[Sat[m_]<-SatSolve[a&&b], a&&b//. m]" 216 | ] 217 | }, 218 | { 219 | "cell_type": "code", 220 | "execution_count": null, 221 | "metadata": {}, 222 | "outputs": [], 223 | "source": [] 224 | } 225 | ], 226 | "metadata": { 227 | "kernelspec": { 228 | "display_name": "Stimsym", 229 | "language": "stimsym", 230 | "name": "stimsym" 231 | }, 232 | "language_info": { 233 | "codemirror_mode": "mathematica", 234 | "file_extension": ".txt", 235 | "mimetype": "text", 236 | "name": "stimsym", 237 | "version": "0.1.0" 238 | } 239 | }, 240 | "nbformat": 4, 241 | "nbformat_minor": 1 242 | } 243 | -------------------------------------------------------------------------------- /doc/examples.adoc: -------------------------------------------------------------------------------- 1 | = Examples 2 | :toc: macro 3 | 4 | All the examples can be run in `stimsym_cli` or in the notebook. 5 | 6 | toc::[] 7 | 8 | == The Basics 9 | 10 | Stimsym is a **symbolic** language, where we manipulate expressions, not 11 | simply values. `a+b` is just an expression that evaluates to itself, since 12 | we do not know a concrete value for `a` or for `b`. 13 | Similarly, `f[a,b]` is the application of the function `f` to arguments `a,b`. 14 | Since `f` is not defined, the application does not evaluate, and it's fine! 15 | 16 | ---- 17 | > 1 + 2 18 | 3 19 | > 1 + a + 2 20 | 3+a 21 | > f[a,b,c] 22 | f[a,b,c] 23 | > f[a,1+2+c] 24 | f[a,3+c] 25 | ---- 26 | 27 | We can define (partially) a function using `:=`. 28 | There is no static typing, and no need to defined a function on all its 29 | possible arguments: 30 | 31 | ---- 32 | > f[x_,0] := x 33 | > f[a, 0] 34 | a 35 | > f[b] (* no rule matches *) 36 | f[b] 37 | > f[a, 42] 38 | f[a,42] 39 | > f[a,0+0] 40 | a 41 | ---- 42 | 43 | In this definition, you might have noticed how `x` appears with 44 | the +++_+++ on the left, but not on the right. 45 | +++x_+++ is actually a **blank pattern**: it matches any expression (any cargument) 46 | and binds the argument to the variable `x`. 47 | So, +++g[x_,y_] := 2 x + y+++ defines `g` as a function that takes any two 48 | expressions and sums them after doubling the first one: `g[10,3]` will be `23`. 49 | More complicated **patterns** will only match some expressions 50 | (see <>). 51 | 52 | Expressions are built from the following ingredients: 53 | 54 | integers:: `1`, `-2`, `1234542452626246246225114787` (arbitrary precision) 55 | rationals:: `1/2`, `-5/10`, etc. 56 | strings:: `"ab cd"`, `"f[a]"`, `"1+1"` 57 | symbols:: any string composed of alphanumeric objects 58 | builtins:: many builtin functions, such as `Plus`. They often have 59 | a shortcut representation, e.g. `Plus[a,b,c]` is `a+b+c+`, `Times[a,2]` is `a 2`, etc. 60 | applications:: `expr[expr,expr,…]` applies the first expression to 61 | a sequence of arguments. 62 | `f[]` applies `f` to 0 arguments; 63 | `f[a]` applies `f` to `a`; 64 | `f[a][b,c]` applies `f[a]` to arguments `b, c`. 65 | 66 | The primary container is the **list**, denoted `List[a,b,c]` or `{a,b,c}`. 67 | However, it is possible to store elements under any symbol that is 68 | not defined: 69 | 70 | ---- 71 | > {{a},{b,1+1}} 72 | {{a},{b,2}} 73 | > SomeSymbol[a,b,c] 74 | SomeSymbol[a,b,c] 75 | ---- 76 | 77 | == Rewriting 78 | 79 | The primary operation for evaluating expressions is **rewriting**. 80 | Every definition (`pattern := expr`) defines a rule that rewrites 81 | anything matching the pattern, to the expression. 82 | 83 | Some expressions define "local" rewriting rules: 84 | 85 | - `pattern -> expr` evaluates `expr` first, then defines the rule 86 | mapping anything matching `pattern` to the evaluated expression. 87 | This is typically only useful if `pattern` binds no variables (e.g. 88 | if `pattern` is a constant) 89 | - `pattern :> expr` maps anything matching `pattern` to `expr`. 90 | Here, `expr` is only evaluated once the pattern matches. 91 | For instance, +++f[x_] :> x+2+++ will rewrite `f[1]` to `3`, 92 | `f[98]` to `100`, etc. 93 | 94 | The following operators rewrite expressions using local rules: 95 | 96 | - `expr //. rules` 97 | (where `rules` is either one rule, or a list of rules) 98 | rewrite `expr` with the rules until no rule applies anymore. 99 | For example, 100 | + 101 | ---- 102 | > g[f[f[f[a]]]] //. {f[x_]:> x, g[x_] :> h[x]} 103 | h[a] 104 | > f[f[f[a]]] //. {f[x_]:> g[x], g[x_] :> h[x]} 105 | h[h[h[a]]] 106 | ---- 107 | 108 | - `expr /. rules` 109 | (where `rules` is either one rule, or a list of rules) 110 | rewrite `expr` with the rules, but each sub-expression is rewritten 111 | at most once: 112 | + 113 | ---- 114 | > f[f[f[a]]] /. {f[x_]:> g[x], g[x_] :> h[x]} 115 | g[g[g[a]]] 116 | ---- 117 | 118 | 119 | [[patterns]] 120 | == Patterns 121 | 122 | blank pattern:: 123 | +++_+++ matches anything. +++x_+++ matches anything and binds `x` to it. 124 | blank non empty sequence:: 125 | +++__+++ matches any non-empty **sequence** of arguments: 126 | +++f[a, y__] := {y}+++ will trigger on any expression `f[a,…]` and match `y` with 127 | the `…`. 128 | + 129 | ---- 130 | > f[a,y__] := {y} 131 | > f[a,b,c,d] 132 | {b,c,d} 133 | > f[a] (* does not match *) 134 | f[a] 135 | > f[b,c,d] 136 | f[b,c,d] 137 | ---- 138 | 139 | blank sequence:: 140 | +++___+++ matches any **sequence** of arguments, including an empty one: 141 | +++f[a, y___] := {y}+++ is very similar to +++f[a,y__] := {y}+++ 142 | but will also reduce `f[a]` to `{}`. 143 | 144 | test pattern:: 145 | `p?f` is a pattern that matches any expression `e` against `p`, but 146 | only if `f[e]` reduces to `True`. 147 | Typically, +++_?IntegerQ+++ matches any integer, +++_?RationalQ+++ 148 | any rational (or integer). 149 | 150 | conditional pattern:: 151 | A pattern `p /; expr` matches the same expressions as `p` (where `p` 152 | is a pattern), but only if `expr` evaluates to `True`. 153 | The test `expr` is expected to reduce to `True` or `False`; 154 | otherwise the evaluation fails. 155 | This is more powerful, but more verbose, than a test pattern: 156 | +++_?IntegerQ+++ can be expressed as +++x_ /; IntegerQ[x]+++. 157 | + 158 | More advanced example involving both a test and a conditional 159 | (because the condition `a+2==3` does not reduce to a boolean, 160 | we guard +++x_+++ with an `IntegerQ` test): 161 | + 162 | ---- 163 | > {1,2,a,4} /. (x_?IntegerQ /; (x+2 == 3) :> success[x]) 164 | {success[1],2,a,4} 165 | ---- 166 | 167 | A funny example of rewriting is the following bubble sort (not efficient, 168 | but compact). 169 | It repeatedly rewrites the list `l` using the rule 170 | +++{x___,y_,z_,k___}/;(y>z) :> {x,z,y,k}+++, which finds two elements `y` 171 | and `z` in a list, with `y>z`, and swaps them. 172 | Note how +++x___+++ and +++k___+++ capture the other elements of the list. 173 | 174 | ---- 175 | > sort[l_] := l //. {x___,y_,z_,k___}/;(y>z) :> {x,z,y,k} 176 | > sort[{64,44,71,48,96,47,59,71,73,51,67,50,26,49,49}] 177 | {26,44,47,48,49,49,50,51,59,64,67,71,71,73,96} 178 | ---- 179 | 180 | == Some primitives 181 | 182 | Stimsym is certainly not a (usable) computer algebra system, but it provides 183 | a few builtin operators. 184 | 185 | ---- 186 | > a===a (* syntactic equality *) 187 | True 188 | > a===b 189 | False 190 | > 10>5==5<=7 (* chain of tests *) 191 | True 192 | > a==a (* does not reduce *) 193 | a==a 194 | > a==a a==a5,b->10} 197 | True 198 | > 2^10 199 | 1024 200 | > 6! (* factorial *) 201 | 120 202 | > a&&b || !c (* bool expressions *) 203 | a&&b||!c 204 | ---- 205 | 206 | Some handy functions: 207 | 208 | FullForm:: 209 | shows the unsugared expression, very convenient for understanding 210 | some quirks of the parser: 211 | + 212 | ---- 213 | > FullForm[a&&b||!c] 214 | Or[And[a,b],Not[c]] 215 | ---- 216 | 217 | Nest:: 218 | + 219 | ---- 220 | > Nest[f,a,10] 221 | f[f[f[f[f[f[f[f[f[f[a]]]]]]]]]] 222 | > (f^10)[a] (* short for Nest *) 223 | f[f[f[f[f[f[f[f[f[f[a]]]]]]]]]] 224 | ---- 225 | 226 | Hold:: 227 | blocks evaluation of its arguments. 228 | + 229 | ---- 230 | > Hold[1+1] 231 | Hold[1+1] 232 | ---- 233 | 234 | == Sequence 235 | 236 | The special symbol `Sequence` has the special property that 237 | it "flattens" when it appears in a list of arguments (or a list): 238 | 239 | ---- 240 | > Sequence[a,b] 241 | Sequence[a,b] 242 | > f[a,Sequence[b,c],d] 243 | f[a,b,c,d] 244 | > {Sequence[1,2],Sequence[3,4],5} 245 | {1,2,3,4,5} 246 | ---- 247 | 248 | [[comprehension]] 249 | == Comprehensions 250 | 251 | Stimsym emphasizes functional programming and pure expressions. 252 | Instead of loops, it provides a powerful **comprehension** mechanism. 253 | A comprehension expression has the form `expr ::cond1, cond2, …`, 254 | a bit similar to python's `expr for … if …` construct. 255 | Conditions are evaluated left-to-right, and have one of the forms: 256 | 257 | - +++pattern <- expr+++, will match `pattern` against `expr` 258 | and bind variables of `pattern` in the remaining (right-side) conditions 259 | 260 | - +++pattern <<- expr+++, will match `pattern` against every expressions 261 | immediately beneath `expr`, 262 | and bind variables of `pattern` in the remaining (right-side) conditions. 263 | + 264 | For example, +++f[x_] <<- {1,f[2],3,f[4]}+++ will match +++f[x_]+++ with 265 | each element of the list in a backtracking fashion. 266 | First, it will try to match against `1`, fail, then `f[2]`, succeed in 267 | binding +++x_ <- 2+++, _evaluate the remaining conditions_, 268 | then backtrack, fail against 3, succeed against `f[4]`, 269 | evaluate the remaining conditions with +++x_ <- 4+++, and terminate. 270 | 271 | - `expr`, where the expression will be evaluated with the current bindings, 272 | and evaluation continues only if `expr` reduces to `True`. 273 | This is used to add tests, a bit like `bar` in 274 | python's `expr for x in foo if bar`. 275 | 276 | Note that matching a pattern against an expression can return several results. 277 | For instance, +++x_+y_ <- a+b+++ will yield `x=a,y=b` and `x=b,y=a`. 278 | In a comprehension, both choices will be considered and returned, 279 | like clauses in Prolog. 280 | 281 | The following expression computes the cartesian product of two lists: 282 | 283 | ---- 284 | > Product[l1_,l2_] := {{x,y} :: x_<<- l1, y_ <<- l2} 285 | > Product[{1,2,3},{a,b,c}] 286 | {{1,a},{1,b},{1,c},{2,a},{2,b},{2,c},{3,a},{3,b},{3,c}} 287 | ---- 288 | 289 | A comprehension returns a `Sequence`, so it flattens under any 290 | other symbol (such as `{}`). 291 | 292 | == `Let`-binding 293 | 294 | Very similar to the comprehension, `Let` is an interesting variation. 295 | Its full form is `Let[cond1,…,condn, expr]` where the conditions are 296 | similar to those in <>, but it only returns the first 297 | successful `expr` and discards the other choices. 298 | If there is no successful answer (corresponding to an empty comprehension) 299 | then evaluation fails. 300 | 301 | ---- 302 | > Let[x_<-1, y_<-2, 2 x+y] 303 | 4 304 | > Let[x_+y_ <- a+b, f[x,y]] 305 | f[a,b] 306 | > {f[x,y]:: x_+y_ <-a+b} (* contrast with that *) 307 | {f[a,b],f[b,a]} 308 | > Let[x_?IntegerQ <- a, x] (* no answer -> failure! *) 309 | evaluation failed: 310 | no match for `Let` 311 | ---- 312 | 313 | == Anonymous functions 314 | 315 | There is a way to denote simple anonymous functions using the postfix `&` 316 | operator and `#1`, `#2`, … for arguments. `#0` is the whole sequence 317 | of elements. 318 | 319 | ---- 320 | > (#1 &)[a,b,c] 321 | a 322 | > (f[#1,{#0}]&)[a,b,c] 323 | f[a,{a,b,c}] 324 | > (Plus[#0]!&)[1,2,3] (* sum, then factorial *) 325 | 720 326 | ---- 327 | 328 | == Inline Documentation: `Doc` 329 | 330 | Evaluating `Doc[f]` where `f` is a builtin symbol will display the 331 | corresponding documentation: 332 | 333 | ---- 334 | > Doc[Plus] 335 | ================================================== 336 | 337 | # Plus 338 | 339 | Addition operator. Associative, Commutative, with regular evaluation on 340 | numbers. 341 | neutral element:: 342 | 0 343 | infix form:: 344 | `a + b + c + d` 345 | ================================================== 346 | ---- 347 | 348 | 349 | == Larger Examples 350 | 351 | enumerate the way to split a sum in one atom + 2 sub-sums:: 352 | + 353 | To do so, we match `a+b+c+d` with the pattern `x_+y__+z__`, 354 | where `y` and `z` match non-empty sequences. 355 | Using the <> mechanism, we build a term 356 | `f[x,{y},{z}]` for each result of this matching, and wrap 357 | the result in a list. 358 | + 359 | ---- 360 | > {f[x,{y},{z}] :: x_+y__+z__<-a+b+c+d} 361 | {f[a,{c,b},{d}], 362 | f[a,{d,b},{c}], 363 | f[a,{b},{d,c}], 364 | f[a,{d,c},{b}], 365 | f[a,{c},{d,b}], 366 | f[a,{d},{c,b}], 367 | f[b,{c,a},{d}], 368 | f[b,{d,a},{c}], 369 | f[b,{a},{d,c}], 370 | f[b,{d,c},{a}], 371 | f[b,{c},{d,a}], 372 | f[b,{d},{c,a}], 373 | f[c,{b,a},{d}], 374 | f[c,{d,a},{b}], 375 | f[c,{a},{d,b}], 376 | f[c,{d,b},{a}], 377 | f[c,{b},{d,a}], 378 | f[c,{d},{b,a}], 379 | f[d,{b,a},{c}], 380 | f[d,{c,a},{b}], 381 | f[d,{a},{c,b}], 382 | f[d,{c,b},{a}], 383 | f[d,{b},{c,a}], 384 | f[d,{c},{b,a}]} 385 | ---- 386 | + 387 | compute `3!!!`:: 388 | + 389 | we compute `(fun x -> x!)` (i.e. `(#! &)`) 390 | composed 3 times with itself (`^3`) and then applied to 3. 391 | + 392 | ---- 393 | > ((#!&)^3)[3] 394 | 2601218943565795100204903227081043611191521875016945785727541837850835631156947382240678577958130457082619920575892247259536641565162052015873791984587740832529105244690388811884123764341191951045505346658616243271940197113909845536727278537099345629855586719369774070003700430783758997420676784016967207846280629229032107161669867260548988445514257193985499448939594496064045132362140265986193073249369770477606067680670176491669403034819961881455625195592566918830825514942947596537274845624628824234526597789737740896466553992435928786212515967483220976029505696699927284670563747137533019248313587076125412683415860129447566011455420749589952563543068288634631084965650682771552996256790845235702552186222358130016700834523443236821935793184701956510729781804354173890560727428048583995919729021726612291298420516067579036232337699453964191475175567557695392233803056825308599977441675784352815913461340394604901269542028838347101363733824484506660093348484440711931292537694657354337375724772230181534032647177531984537341478674327048457983786618703257405938924215709695994630557521063203263493209220738320923356309923267504401701760572026010829288042335606643089888710297380797578013056049576342838683057190662205291174822510536697756603029574043387983471518552602805333866357139101046336419769097397432285994219837046979109956303389604675889865795711176566670039156748153115943980043625399399731203066490601325311304719028898491856203766669164468791125249193754425845895000311561682974304641142538074897281723375955380661719801404677935614793635266265683339509760000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 395 | ---- 396 | 397 | union in comprehension:: 398 | + 399 | ---- 400 | > f[Set[RangeSeq[i]]:: i_<<-Range[10]] 401 | f[Set[0], 402 | Set[0,1], 403 | Set[0,1,2], 404 | Set[0,1,2,3], 405 | Set[0,1,2,3,4], 406 | Set[0,1,2,3,4,5], 407 | Set[0,1,2,3,4,5,6], 408 | Set[0,1,2,3,4,5,6,7], 409 | Set[0,1,2,3,4,5,6,7,8], 410 | Set[0,1,2,3,4,5,6,7,8,9], 411 | Set[0,1,2,3,4,5,6,7,8,9,10]] 412 | 413 | > Union[Set[RangeSeq[i]]:: i_<<-Range[10]] 414 | Set[0,1,2,3,4,5,6,7,8,9,10] 415 | ---- 416 | 417 | 418 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (name stimsym) 3 | (using menhir 1.0) 4 | -------------------------------------------------------------------------------- /src/cli/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name stimsym_cli) 3 | (public_name stimsym_cli) 4 | (package stimsym) 5 | (libraries stimsym linenoise)) 6 | -------------------------------------------------------------------------------- /src/cli/stimsym_cli.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 CLI entry point} *) 5 | 6 | open Stimsym 7 | 8 | type config = { 9 | verbose: bool; 10 | } 11 | 12 | type mime_view = 13 | | Mime_xdg_open of string (* extension *) 14 | | Mime_unknown 15 | 16 | let mime_classify (m:Expr.mime_content): mime_view = match m.Expr.mime_ty with 17 | | "image/png" -> Mime_xdg_open ".png" 18 | | "image/svg" -> Mime_xdg_open ".svg" 19 | | _ -> Mime_unknown 20 | 21 | (* try to display the given mime type *) 22 | let display_mime (m:Expr.mime_content): unit = match mime_classify m with 23 | | Mime_xdg_open ext -> 24 | CCIO.File.with_temp ~prefix:"stimsym_cli" ~suffix:ext 25 | (fun file -> 26 | CCIO.with_out file 27 | (fun oc -> output_string oc m.Expr.mime_data; flush oc); 28 | let p = CCUnix.call_full "xdg-open '%s'" file in 29 | ignore p#errcode); 30 | () 31 | | Mime_unknown -> 32 | Format.printf "" 33 | m.Expr.mime_ty (String.length m.Expr.mime_data) 34 | 35 | (* completion callback *) 36 | let completion str (lnoise:LNoise.completions): unit = 37 | let {Completion.start;l;_} = 38 | Completion.complete str ~cursor_pos:(String.length str) 39 | in 40 | List.iter 41 | (fun c -> 42 | let prefix = String.sub str 0 start in 43 | LNoise.add_completion lnoise (prefix ^ c.Completion.text)) 44 | l 45 | 46 | let pp_rule out n = 47 | Format.fprintf out "%s@," (String.make n '=') 48 | 49 | let rec main_loop ~config () = 50 | match LNoise.linenoise "> " with 51 | | None -> () 52 | | Some res when String.trim res = "" -> main_loop ~config () 53 | | Some res -> 54 | let buf = Lexing.from_string res in 55 | ignore (LNoise.history_add res); 56 | Parse_loc.set_file buf ""; 57 | begin match Parser.parse_expr Lexer.token buf with 58 | | e -> 59 | if config.verbose then ( 60 | Format.printf "parsed: @[%a@]@." Expr.pp_full_form e; 61 | ); 62 | begin 63 | try 64 | let e', docs = Eval.eval_full e in 65 | if not (Expr.equal e' Builtins.null) then ( 66 | Format.printf "@[%a@]@." Expr.pp e'; 67 | ); 68 | List.iter 69 | (function 70 | | Eval.Print_doc doc -> 71 | Format.printf "%a@.%a@.%a@." pp_rule 50 Document.pp doc pp_rule 50 72 | | Eval.Print_mime m -> display_mime m) 73 | docs 74 | with 75 | | Stack_overflow -> 76 | Format.printf "stack overflow.@."; 77 | | Eval.Eval_fail msg -> 78 | Format.printf "evaluation failed:@ %s@." msg; 79 | end 80 | | exception e -> 81 | Format.printf "error: %s@." (Printexc.to_string e); 82 | end; 83 | main_loop ~config () 84 | 85 | let history_file = 86 | try Some (Filename.concat (Sys.getenv "HOME") ".rewrite-history") 87 | with _ -> None 88 | 89 | let () = 90 | Stimsym.init(); 91 | let verbose = ref false in 92 | Arg.parse 93 | [ "-v", Arg.Set verbose, " enable verbose output"; 94 | "--verbose", Arg.Set verbose, " enable verbose output"; 95 | "--trace", Arg.Unit (fun () -> Eval.set_eval_debug true), " enable tracing of evaluation"; 96 | ] 97 | (fun _ -> ()) 98 | "./cli [options] 99 | 100 | A simple command-line REPL for rewriting expressions. 101 | "; 102 | let config = { 103 | verbose= !verbose; 104 | } in 105 | ignore (LNoise.history_set ~max_length:1000); 106 | LNoise.set_completion_callback completion; 107 | CCOpt.iter (fun f -> ignore (LNoise.history_load ~filename:f)) history_file; 108 | if config.verbose then ( 109 | Builtins.log_ := (fun s -> print_endline ("log: " ^ s)); 110 | ); 111 | main_loop ~config (); 112 | CCOpt.iter (fun f -> ignore (LNoise.history_save ~filename:f)) history_file; 113 | () 114 | 115 | -------------------------------------------------------------------------------- /src/core/Base_types.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Basic Types} *) 5 | 6 | module Properties = Bit_set.Make(struct end) 7 | 8 | type mime_content = { 9 | mime_ty: string; 10 | mime_data: string; 11 | mime_base64: bool; 12 | } 13 | 14 | type eval_side_effect = 15 | | Print_doc of Document.t 16 | | Print_mime of mime_content 17 | 18 | type const = { 19 | cst_name: string; 20 | cst_id: int; 21 | mutable cst_properties: Properties.t; 22 | mutable cst_rules: def list; 23 | mutable cst_doc: Document.t; 24 | mutable cst_printer: (int * const_printer) option; 25 | mutable cst_display : mime_printer option; 26 | } 27 | 28 | and expr = 29 | | Const of const 30 | | App of expr * expr array 31 | | Z of Z.t 32 | | Q of Q.t 33 | | String of string 34 | | Reg of int (* only in rules RHS *) 35 | 36 | and const_printer = const -> (int -> expr CCFormat.printer) -> expr array CCFormat.printer 37 | 38 | (* (partial) definition of a symbol *) 39 | and def = 40 | | Rewrite of rewrite_rule 41 | | Fun of prim_fun 42 | 43 | and rewrite_rule = { 44 | rr_pat: pattern; 45 | rr_pat_as_expr: expr; 46 | rr_rhs: expr; 47 | } 48 | 49 | and pattern = 50 | | P_const of const 51 | | P_z of Z.t 52 | | P_q of Q.t 53 | | P_string of string 54 | | P_app of pattern * pattern array 55 | | P_blank of const option (* anything, or anything with the given head *) 56 | | P_blank_sequence of const option (* >= 1 elements *) 57 | | P_blank_sequence_null of const option (* >= 0 elements *) 58 | | P_fail 59 | | P_bind of int * pattern 60 | (* match, then bind register *) 61 | | P_check_same of int * pattern 62 | (* match, then check syntactic equality with content of register *) 63 | | P_alt of pattern list 64 | | P_app_slice of pattern * slice_pattern (* for slices *) 65 | | P_app_slice_unordered of pattern * slice_unordered_pattern 66 | | P_conditional of pattern * expr (* pattern if condition *) 67 | | P_test of pattern * expr (* `p?t` pattern + test on value *) 68 | 69 | and slice_pattern = 70 | | SP_vantage of slice_pattern_vantage 71 | | SP_pure of pattern list * int (* only sequence/sequencenull; min size *) 72 | 73 | (* a subtree used for associative pattern matching *) 74 | and slice_pattern_vantage = { 75 | sp_min_size: int; (* minimum length of matched slice *) 76 | sp_left: slice_pattern; (* matches left slice *) 77 | sp_vantage: pattern; (* match this unary pattern first *) 78 | sp_right: slice_pattern; (* matches right slice *) 79 | } 80 | 81 | and slice_unordered_pattern = 82 | | SUP_vantage of pattern * slice_unordered_pattern * int (* pattern to match first, rec, min size *) 83 | | SUP_pure of pattern list * int (* only sequence/null; min size *) 84 | 85 | and binding_seq_body_item = 86 | | Comp_match of pattern * expr 87 | | Comp_match1 of pattern * expr 88 | | Comp_test of expr 89 | 90 | and binding_seq = { 91 | comp_body: binding_seq_body_item list; 92 | comp_yield: expr; 93 | } 94 | 95 | (* TODO? *) 96 | and prim_fun_args = eval_state 97 | 98 | and prim_fun = prim_fun_args -> expr -> expr option 99 | 100 | (* function using for tracing evaluation *) 101 | and trace_fun = expr -> expr -> unit 102 | 103 | (* state for evaluation *) 104 | and eval_state = { 105 | mutable st_iter_count: int; 106 | (* number of iterations *) 107 | mutable st_rules: rewrite_rule list; 108 | (* permanent list of rules *) 109 | st_effects: (eval_side_effect Stack.t) option; 110 | (* temporary messages *) 111 | mutable st_trace: trace_fun; 112 | (* called on intermediate forms *) 113 | } 114 | 115 | (* custom display for expressions *) 116 | and mime_printer = expr -> mime_content list 117 | -------------------------------------------------------------------------------- /src/core/Bit_set.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Bit Field} *) 4 | 5 | exception TooManyFields 6 | exception Frozen 7 | 8 | let max_width = Sys.word_size - 2 9 | 10 | module type S = sig 11 | type t = private int 12 | (** Generative type of bitfields. Each instantiation of the functor 13 | should create a new, incompatible type *) 14 | 15 | val empty : t 16 | (** Empty bitfields (all bits 0) *) 17 | 18 | type field 19 | 20 | val get : field -> t -> bool 21 | (** Get the value of this field *) 22 | 23 | val set : field -> bool -> t -> t 24 | (** Set the value of this field *) 25 | 26 | val mk_field : unit -> field 27 | (** Make a new field *) 28 | 29 | val freeze : unit -> unit 30 | (** Prevent new fields from being added. From now on, creating 31 | a field will raise Frozen *) 32 | 33 | val total_width : unit -> int 34 | (** Current width of the bitfield *) 35 | end 36 | 37 | let rec all_bits_ acc w = 38 | if w=0 then acc 39 | else 40 | let acc = acc lor (1 lsl w-1) in 41 | all_bits_ acc (w-1) 42 | 43 | (*$T 44 | all_bits_ 0 1 = 1 45 | all_bits_ 0 2 = 3 46 | all_bits_ 0 3 = 7 47 | all_bits_ 0 4 = 15 48 | *) 49 | 50 | (* increment and return previous value *) 51 | let get_then_incr n = 52 | let x = !n in 53 | incr n; 54 | x 55 | 56 | let get_then_add n offset = 57 | let x = !n in 58 | n := !n + offset; 59 | x 60 | 61 | module Make(X : sig end) : S = struct 62 | type t = int 63 | 64 | let empty = 0 65 | 66 | let width_ = ref 0 67 | let frozen_ = ref false 68 | 69 | type field = int (* a mask *) 70 | 71 | let get field x = (x land field) <> 0 72 | 73 | let set field b x = 74 | if b then x lor field else x land (lnot field) 75 | 76 | let mk_field () = 77 | if !frozen_ then raise Frozen; 78 | let n = get_then_incr width_ in 79 | if n > max_width then raise TooManyFields; 80 | let mask = 1 lsl n in 81 | mask 82 | 83 | let freeze () = frozen_ := true 84 | 85 | let total_width () = !width_ 86 | end 87 | -------------------------------------------------------------------------------- /src/core/Bit_set.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software, part of containers. See file "license" for more details. *) 2 | 3 | (** {1 Bit Field} 4 | 5 | This module defines efficient bitfields 6 | up to 30 or 62 bits (depending on the architecture) in 7 | a relatively type-safe way. 8 | *) 9 | 10 | exception TooManyFields 11 | (** Raised when too many fields are packed into one bitfield *) 12 | 13 | exception Frozen 14 | (** Raised when a frozen bitfield is modified *) 15 | 16 | val max_width : int 17 | (** System-dependent maximum width for a bitfield, typically 30 or 62 *) 18 | 19 | (** {2 Bitfield Signature} *) 20 | module type S = sig 21 | type t = private int 22 | (** Generative type of bitfields. Each instantiation of the functor 23 | should create a new, incompatible type *) 24 | 25 | val empty : t 26 | (** Empty bitfields (all bits 0) *) 27 | 28 | type field 29 | 30 | val get : field -> t -> bool 31 | (** Get the value of this field *) 32 | 33 | val set : field -> bool -> t -> t 34 | (** Set the value of this field *) 35 | 36 | val mk_field : unit -> field 37 | (** Make a new field *) 38 | 39 | val freeze : unit -> unit 40 | (** Prevent new fields from being added. From now on, creating 41 | a field will raise Frozen *) 42 | 43 | val total_width : unit -> int 44 | (** Current width of the bitfield *) 45 | end 46 | 47 | (** Create a new bitfield type *) 48 | module Make(X : sig end) : S 49 | -------------------------------------------------------------------------------- /src/core/Builtins.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Builtin Functions} *) 5 | 6 | type t = Expr.t 7 | (** A builtin is just a constant expression *) 8 | 9 | exception Eval_does_not_apply 10 | (** Raised internally when an evaluation function does not apply to 11 | the arguments *) 12 | 13 | (** a function definition. Takes [self_cst, eval_fun, t] and evaluates [t] 14 | into [None] (fail) or [Some t'] *) 15 | type fun_def = Expr.const -> Expr.prim_fun_args -> Expr.t -> Expr.t option 16 | 17 | val make : 18 | ?doc:Document.t -> 19 | ?printer:int * Expr.const_printer -> 20 | ?display:Expr.mime_printer -> 21 | ?fields:Expr.Properties.field list -> 22 | ?funs:fun_def list -> 23 | ?rules:(Expr.const -> t * t) list -> 24 | string -> t 25 | (** [make s] makes a new constant and sets some options/handlers on it *) 26 | 27 | val const_is_builtin : Expr.const -> bool 28 | 29 | val hold : t 30 | val full_form : t 31 | val blank : t 32 | val blank_seq : t 33 | val blank_null_seq : t 34 | val sequence : t 35 | val pattern : t 36 | val pattern_test : t 37 | val same_q : t 38 | val assign : t 39 | val assign_delayed : t 40 | val rule : t 41 | val rule_delayed : t 42 | val condition : t 43 | val replace_all : t 44 | val replace_repeated : t 45 | val alternatives : t 46 | val compound_expr : t 47 | val head : t 48 | val length : t (* number of immediate arguments *) 49 | 50 | val slot : t 51 | val function_ : t 52 | 53 | val true_ : t 54 | val false_ : t 55 | val if_ : t 56 | val match_ : t 57 | val match_l : t 58 | val matches : t 59 | 60 | val and_ : t 61 | val or_ : t 62 | val not_ : t 63 | 64 | val plus : t 65 | val times : t 66 | val div : t 67 | val mod_ : t 68 | val max : t 69 | val min : t 70 | val factorial : t 71 | val power : t 72 | 73 | val list : t 74 | val set : t 75 | 76 | val union : t 77 | val inter : t 78 | 79 | val random : t 80 | val floor : t 81 | val ceil : t 82 | 83 | val match_bind : t 84 | val match_bind1 : t 85 | val comprehension : t 86 | val let_ : t 87 | val fixpoint : t 88 | 89 | val clear : t 90 | 91 | val set_attributes : t 92 | val remove_attributes : t 93 | val get_attributes : t 94 | val clear_attributes : t 95 | 96 | val equal : t 97 | val not_equal : t 98 | val less : t 99 | val greater : t 100 | val less_equal : t 101 | val greater_equal : t 102 | val inequality : t 103 | 104 | val integer_q : t 105 | val rational_q : t 106 | val true_q : t 107 | 108 | val trace : t 109 | val print : t 110 | val null : t 111 | val doc : t 112 | 113 | val nest : t 114 | val range_seq : t 115 | val range : t 116 | 117 | val all_builtins : unit -> t list 118 | 119 | val complete_symbol : string -> t list 120 | (** Completion of the given identifier prefix using builtins *) 121 | 122 | (**/**) 123 | val log_: (string->unit) ref 124 | val log : string -> unit 125 | val logf : ('a, unit, string, unit) format4 -> 'a 126 | (**/**) 127 | -------------------------------------------------------------------------------- /src/core/Builtins_advanced.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software. See file "license" for more details. *) 2 | 3 | (** {1 More Advanced Builtins} *) 4 | 5 | module E = Expr 6 | module B = Builtins 7 | 8 | module E_tbl = E.Tbl 9 | 10 | type t = B.t 11 | 12 | module Sat_solve = struct 13 | type form = 14 | | And of form array 15 | | Or of form array 16 | | True 17 | | False 18 | | Not of form 19 | | Atom of E.t 20 | 21 | let not_ = function 22 | | True -> False 23 | | False -> True 24 | | Not a -> a 25 | | f -> Not f 26 | 27 | type atom = { 28 | a_expr: E.t; 29 | a_int: int; (* the corresponding atom for the SAT solver *) 30 | } 31 | 32 | type lit = atom * bool 33 | type clause = lit list 34 | 35 | type res = 36 | | Unsat 37 | | Sat of lit list 38 | 39 | let rec as_form (e:E.t): form = match e with 40 | | E.Const {E.cst_name="True";_} -> True 41 | | E.Const {E.cst_name="False";_} -> False 42 | | E.App (E.Const {E.cst_name="And";_}, a)-> 43 | And (Array.map as_form a) 44 | | E.App (E.Const {E.cst_name="Or";_}, a)-> 45 | Or (Array.map as_form a) 46 | | E.App (E.Const {E.cst_name="Rule";_}, [| a; b |])-> 47 | (* implication *) 48 | Or [| not_ (as_form a); as_form b |] 49 | | E.App (E.Const {E.cst_name="Not";_}, [| f |])-> 50 | not_ (as_form f) 51 | | E.App (E.Const {E.cst_name="Not";_}, _)-> 52 | raise B.Eval_does_not_apply 53 | | _ -> Atom e 54 | 55 | type cnf_state = { 56 | cnf_arg: E.prim_fun_args; 57 | cnf_tbl: atom E_tbl.t; 58 | mutable cnf_count: int; (* for allocating new symbols *) 59 | cnf_rev: (int, atom) Hashtbl.t; (* retrieve atom by index *) 60 | } 61 | 62 | (* expr -> atom *) 63 | let get_atom_ st (e:E.t): atom = 64 | try E_tbl.find st.cnf_tbl e 65 | with Not_found -> 66 | let n = st.cnf_count in 67 | st.cnf_count <- n+1; 68 | let a = {a_expr=e; a_int=n} in 69 | Hashtbl.add st.cnf_rev n a; 70 | E_tbl.add st.cnf_tbl e a; 71 | a 72 | 73 | (* all the ways to pick one element in each list *) 74 | let array_prod (a:'a list array) : 'a list Iter.t = 75 | let rec aux i k = 76 | if i=Array.length a then k [] 77 | else ( 78 | List.iter (fun x -> aux (i+1) (fun tail -> k (x::tail))) a.(i) 79 | ) 80 | in 81 | aux 0 82 | 83 | let cnf (st:cnf_state) (f:form): clause list = 84 | let rec nnf (f:form): form = match f with 85 | | Atom _ | Not (Atom _) -> f 86 | | True | False -> f 87 | | Not True -> False 88 | | Not False -> True 89 | | Not (Not f) -> nnf f 90 | | Not (And a) -> Or (Array.map nnf_neg a) 91 | | Not (Or a) -> And (Array.map nnf_neg a) 92 | | And a -> And (Array.map nnf a) 93 | | Or a -> Or (Array.map nnf a) 94 | and nnf_neg f = match f with 95 | | Not a -> nnf a 96 | | _ -> nnf (not_ f) 97 | in 98 | (* precond: in NNF *) 99 | let rec aux_cnf f = match f with 100 | | Atom a -> [[get_atom_ st a, true]] 101 | | True -> [] 102 | | False -> [[]] 103 | | Not (Atom a) -> [[get_atom_ st a, false]] 104 | | Not _ -> assert false 105 | | Or a -> 106 | (* TODO: tseitin transformation *) 107 | let a = Array.map aux_cnf a in 108 | array_prod a 109 | |> Iter.map List.flatten 110 | |> Iter.to_rev_list 111 | | And a -> 112 | Array.map aux_cnf a |> Array.to_list |> List.flatten 113 | in 114 | f |> nnf |> aux_cnf 115 | 116 | let print_problem st (out:out_channel) (pb:clause list) = 117 | Printf.fprintf out "p cnf %d %d\n" st.cnf_count (List.length pb); 118 | List.iter 119 | (fun c -> 120 | List.iter 121 | (fun ({a_int=i;_},b) -> Printf.fprintf out "%s%d " (if b then "" else "-") i) 122 | c; 123 | Printf.fprintf out "0\n") 124 | pb; 125 | flush out 126 | 127 | let parse_res st (out:string list): res = match out with 128 | | ["UNSAT"] -> Unsat 129 | | ["SAT"; model] -> 130 | let model = 131 | model 132 | |> CCString.Split.list_cpy ~by:" " 133 | |> CCList.filter_map 134 | (fun i -> 135 | let i = int_of_string i in 136 | if i<>0 then 137 | try 138 | let a = Hashtbl.find st.cnf_rev (abs i) in 139 | Some (a, i>0) 140 | with Not_found -> None 141 | else None) 142 | in 143 | Sat model 144 | | _ -> 145 | Eval.prim_failf st.cnf_arg "could not parse minisat's output:\n`%s`\n" 146 | (String.concat "\n" out) 147 | 148 | let call_ (st:cnf_state) (pb:clause list): res = 149 | CCIO.File.with_temp ~prefix:"stimsym" ~suffix:".cnf" 150 | (fun file_in -> 151 | CCIO.File.with_temp ~prefix:"stimsym_out" ~suffix:".res" 152 | (fun file_out -> 153 | CCIO.with_out file_in (fun oc -> print_problem st oc pb); 154 | let limit = 30 in 155 | let cmd = 156 | Printf.sprintf "minisat -cpu-lim=%d %s %s" limit file_in file_out 157 | in 158 | B.logf "call minisat with `%s`\n" cmd; 159 | let p = CCUnix.call_full "%s" cmd in 160 | let err = p#errcode in 161 | begin match err with 162 | | 10 -> B.log "should return sat\n" 163 | | 20 -> B.log "should return unsat\n" 164 | | n -> B.logf "unknown return: %d\n" n 165 | end; 166 | let out = CCIO.with_in file_out CCIO.read_lines_l in 167 | parse_res st out 168 | )) 169 | 170 | let call (st:cnf_state) (pb:clause list): res = 171 | if List.exists (function [] -> true | _ -> false) pb 172 | then Unsat 173 | else 174 | try call_ st pb 175 | with e -> 176 | Eval.prim_failf st.cnf_arg 177 | "error while calling minisat:@ %s" (Printexc.to_string e) 178 | 179 | let eval _ arg e = match e with 180 | | E.App (_, [| form |]) -> 181 | let st = { 182 | cnf_arg=arg; 183 | cnf_count=1; 184 | cnf_tbl=E_tbl.create 64; 185 | cnf_rev=Hashtbl.create 64; 186 | } in 187 | let clauses = cnf st (as_form form) in 188 | B.logf "call solver with %d clauses\n" (List.length clauses); 189 | let res = match call st clauses with 190 | | Unsat -> E.app (E.const_of_string "Unsat") [| |] 191 | | Sat m -> 192 | let m = 193 | Array.of_list m 194 | |> Array.map 195 | (fun (a,sign) -> 196 | E.app B.rule [| a.a_expr; if sign then B.true_ else B.false_ |]) 197 | |> E.app B.list 198 | in 199 | E.app (E.const_of_string "Sat") [| m |] 200 | in 201 | Some res 202 | | _ -> raise B.Eval_does_not_apply 203 | end 204 | 205 | (* TODO: optional timeout *) 206 | 207 | let sat_solve = 208 | B.make "SatSolve" 209 | ~funs:[Sat_solve.eval] 210 | ~doc:[ 211 | `S "SatSolve"; 212 | `P "`SatSolve[form]` calls a SAT solver on the formula given \ 213 | as parameter. The formula is reduced to CNF automatically \ 214 | before calling Minisat."; 215 | `P "If Minisat is not installed, this does not reduce."; 216 | `P "Returns either `Sat[{m___}]` where `m` is the model, as a \ 217 | list of bindings `Atom -> True` or `Atom -> False`, \ 218 | or Unsat[]."; 219 | (* TODO: update once we have typing? *) 220 | `I ("example", [ 221 | `P "The following call will return `Unsat[]`."; 222 | `Pre "`SatSolve[(A || B)&& (!A || B) && !B]`"; 223 | ]); 224 | `I ("example", [ 225 | `P "The following call will return `Sat[A -> False,B->True]`, \ 226 | containing a model for each atom appearing in the formulas."; 227 | `Pre "`SatSolve[And[A || B,!A]]`"; 228 | ]); 229 | `I ("example", [`L [ 230 | [`P "Find a model of `a&&b` and extract the value of `a` in the \ 231 | model using `Let`:"; 232 | `Pre "`Let[{___,a->r_,___}<<-SatSolve[a&&b],r]`"]; 233 | [`P "also check that the model reduces the formula to `True`:"; 234 | `Pre "`Let[Sat[m_]<-SatSolve[a&&b], a&&b//. m]`"]; 235 | [`P "convert the model into (possibly negated) atoms:"; 236 | `Pre "Let[Sat[m_]<-SatSolve[a&&b,!c], m//.{(x_->False):>!x, (x_->True):>x}]"; 237 | `P "(yield `{a,b,!c}`)"] 238 | ]]); 239 | `I ("requires", [`P "`minisat` must be on the $PATH"]); 240 | ] 241 | 242 | module Graph = struct 243 | (* convenient representation *) 244 | type t = { 245 | vertices: E.t array; 246 | edges: E.t list E.Tbl.t; 247 | } 248 | 249 | let make vertices (edges:E.t array): t = 250 | let tbl = E.Tbl.create 32 in 251 | Array.iter 252 | (function 253 | | E.App (E.Const {E.cst_name="Rule";_}, [| lhs; rhs |]) -> 254 | let l = E.Tbl.get_or ~default:[] tbl lhs in 255 | E.Tbl.replace tbl lhs (rhs :: l) 256 | | _ -> raise B.Eval_does_not_apply) 257 | edges; 258 | { vertices; edges=tbl } 259 | 260 | let as_graph g = 261 | CCGraph.of_fun (fun v -> E.Tbl.get_or ~default:[] g.edges v) 262 | 263 | let pp_dot out (g:t): unit = 264 | let fmt = Format.formatter_of_out_channel out in 265 | let attrs_v v = [`Label (E.to_string v); `Shape "box"] in 266 | let attrs_e _ = [] in 267 | Format.fprintf fmt "%a@." 268 | (CCGraph.Dot.pp_all 269 | ~eq:E.equal ~name:"some_graph" 270 | ~attrs_v ~attrs_e 271 | ~tbl:(CCGraph.mk_table ~eq:E.equal ~hash:E.hash 32) 272 | ~graph:(as_graph g)) 273 | (Iter.of_array g.vertices) 274 | 275 | let get_png (g:t): E.mime_content = 276 | B.log "get png for graph...\n"; 277 | CCIO.File.with_temp ~prefix:"stimsym_graph" ~suffix:".dot" 278 | (fun dot_file -> 279 | (* write file, then invoke `dot` *) 280 | B.logf "try to serialise graph into %S" dot_file; 281 | CCIO.with_out dot_file (fun oc -> pp_dot oc g); 282 | let p = CCUnix.call_full "dot '%s' -Tpng " dot_file in 283 | let _ = p#errcode in 284 | let data = p#stdout in 285 | B.logf "got png (%d bytes)\n" (String.length data); 286 | {E.mime_data=data; mime_ty="image/png"; mime_base64=true}) 287 | 288 | let display e = match e with 289 | | E.App (_, 290 | [| E.App (E.Const {E.cst_name="List";_}, vertices); 291 | E.App (E.Const {E.cst_name="List";_}, edges) 292 | |]) -> 293 | [make vertices edges |> get_png] 294 | | _ -> [] 295 | 296 | let eval _ _ e = match e with 297 | | E.App (hd, [| E.App (E.Const {E.cst_name=("List"|"Set");_}, edges) |]) -> 298 | (* convert to the canonical form *) 299 | let vertices = 300 | Iter.of_array edges 301 | |> Iter.flat_map_l 302 | (function 303 | | E.App (E.Const {E.cst_name="Rule";_}, [| lhs; rhs |]) -> 304 | [lhs;rhs] 305 | | _ -> raise B.Eval_does_not_apply) 306 | |> E.Tbl.of_iter_count 307 | |> E.Tbl.keys_list 308 | |> Array.of_list 309 | in 310 | Some (E.app hd [| E.app B.list vertices; E.app B.list edges |]) 311 | | E.App (hd, [| vertices; E.App (E.Const {E.cst_name="Set";_}, edges) |]) -> 312 | (* normalize Set to List *) 313 | Some (E.app hd [| vertices; E.app B.list edges |]) 314 | | E.App (hd, [| E.App (E.Const {E.cst_name="Set";_}, vertices); edges |]) -> 315 | (* normalize Set to List *) 316 | Some (E.app hd [| E.app B.list vertices; edges |]) 317 | | _ -> raise B.Eval_does_not_apply 318 | end 319 | 320 | let graph = 321 | B.make "Graph" ~funs:[Graph.eval] ~display:Graph.display 322 | ~doc:[ 323 | `S "Graph"; 324 | `P "A directed graph structure."; 325 | `P "`Graph[{a->b,…}]` builds a graph from a list of edges."; 326 | `P "`Graph[Set[a->b,…]]` builds a graph from a set of edges."; 327 | `P "`Graph[{a,b,c},{a->b,…}]` builds a graph from a list of vertices \ 328 | and a list of edges."; 329 | `P "The graph has a graphical display in the notebook."; 330 | `I ("example", [ 331 | `P "a simple 2-layers graph"; 332 | `Pre "Graph[{i->j :: i_<<- {1,2,3,4}, j_<<-{a,b,c,d}}]"; 333 | ]); 334 | ] 335 | 336 | module Tree_form = struct 337 | type t = E.t 338 | 339 | type vertex = 340 | | V of E.t * t array 341 | | L of E.t 342 | 343 | let as_vertex (e:E.t): vertex = match e with 344 | | E.Z _ | E.Q _ | E.String _ | E.Const _ | E.Reg _ -> L e 345 | | E.App (E.Const {E.cst_name="Blank" | "BlankSequence" | "BlankNullSequence";_}, _) -> 346 | L e 347 | | E.App (f, a) -> V (f, a) 348 | 349 | let as_graph = 350 | CCGraph.make 351 | (fun e -> match as_vertex e with 352 | | L _ -> Iter.empty 353 | | V(_,a) -> Iter.of_array_i a) 354 | 355 | let pp_dot out (g:t): unit = 356 | let fmt = Format.formatter_of_out_channel out in 357 | let attrs_v v = match as_vertex v with 358 | | L v -> [`Label (E.to_string_compact v); `Shape "box"] 359 | | V (hd,_) -> 360 | [`Label (E.to_string_compact hd); `Shape "box"] 361 | in 362 | let attrs_e i = [`Label (string_of_int i)] in 363 | Format.fprintf fmt "%a@." 364 | (CCGraph.Dot.pp_all 365 | ~eq:E.equal ~name:"some_graph" 366 | ~attrs_v ~attrs_e 367 | ~tbl:(CCGraph.mk_table ~eq:E.equal ~hash:E.hash 32) 368 | ~graph:as_graph) 369 | (Iter.return g) 370 | 371 | let get_png (g:t): E.mime_content = 372 | B.logf "get png for tree_form `%s`...\n" (E.to_string_compact g); 373 | CCIO.File.with_temp ~prefix:"stimsym_graph" ~suffix:".dot" 374 | (fun dot_file -> 375 | (* write file, then invoke `dot` *) 376 | CCIO.with_out dot_file (fun oc -> pp_dot oc g); 377 | let p = CCUnix.call_full "dot '%s' -Tpng " dot_file in 378 | let _ = p#errcode in 379 | let data = p#stdout in 380 | B.logf "got png (%d bytes)\n" (String.length data); 381 | {E.mime_data=data; mime_ty="image/png"; mime_base64=true}) 382 | end 383 | 384 | let tree_form = 385 | B.make "TreeForm" ~display:(fun e -> [Tree_form.get_png e]) 386 | ~doc:[ 387 | `S "TreeForm"; 388 | `P "Displays an expression as a graph."; 389 | `P "Sub-nodes are shared."; 390 | `I ("example", [ 391 | `Pre "`TreeForm[Let[t_ <- (f^5)[a], t //. f[x_] :> g[x,h[x]]]]`"; 392 | `P "displays a nested expression as a graph" 393 | ]) 394 | ] 395 | 396 | let init() = () 397 | -------------------------------------------------------------------------------- /src/core/Builtins_advanced.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 More Advanced Builtins} *) 5 | 6 | type t = Builtins.t 7 | 8 | val sat_solve : t 9 | (** Call a sat solver on the given arguments *) 10 | 11 | val graph : t 12 | (** Graph structure and display *) 13 | 14 | val tree_form : t 15 | (** Display the structure of a term *) 16 | 17 | val init : unit -> unit 18 | -------------------------------------------------------------------------------- /src/core/Completion.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Completion} *) 5 | 6 | module E = Expr 7 | 8 | type completion = { 9 | text: string; (* the completed text *) 10 | summary: string option; (* short description of this particular completion *) 11 | } 12 | 13 | type 'a within_ctx = { 14 | start: int; (* offset at which completion starts *) 15 | stop: int; (* offset at which completion ends *) 16 | l : 'a list; 17 | } 18 | 19 | (* find if there is a part of [str.[0 .. cursor_pos]] 20 | that looks like the beginning of an identifier. 21 | returns [start, chunk, stop] where 22 | [s[..start] ^ chunk ^ s[end..] = s] *) 23 | let find_suffix_id ~cursor_pos (s:string): (int * string * int) option = 24 | let is_ok_char = 25 | function 'A'..'Z' | 'a'..'z' | '0'..'9' -> true | _ -> false 26 | in 27 | let len = min cursor_pos (String.length s) in 28 | let i = ref (len-1) in 29 | while !i >= 0 && is_ok_char s.[!i] do decr i done; 30 | incr i; (* revert last choice *) 31 | if len - !i >= 1 32 | then ( 33 | let chunk = String.sub s !i (len - !i) in 34 | Some (!i, chunk, len) 35 | ) else None 36 | 37 | (* completion based on builtins' names *) 38 | let complete_builtin partial_id : E.Cst.t list = 39 | Builtins.complete_symbol partial_id 40 | |> CCList.filter_map 41 | (function 42 | | E.Const c -> Some c 43 | | _ -> None) 44 | 45 | (* completion based on every symbol but builtins *) 46 | let complete_all partial_id : E.Cst.t list = 47 | Expr.Cst.complete partial_id 48 | |> List.filter (fun c -> not (Builtins.const_is_builtin c)) 49 | 50 | let find_constants ?(exact=false) s ~cursor_pos : _ within_ctx = 51 | match find_suffix_id ~cursor_pos s with 52 | | None -> {start=0;stop=0;l=[]} 53 | | Some (start,partial_id,stop) -> 54 | let l = 55 | List.rev_append (complete_builtin partial_id) (complete_all partial_id) 56 | in 57 | let l = 58 | if exact then List.filter (fun e -> e.E.cst_name = partial_id) l 59 | else l 60 | in 61 | {start;stop;l} 62 | 63 | let complete s ~cursor_pos : completion within_ctx = 64 | let wctx = find_constants s ~cursor_pos in 65 | let l = 66 | List.rev_map 67 | (fun c -> 68 | let text = c.E.cst_name in 69 | let summary = None in (* TODO? *) 70 | { text; summary }) 71 | wctx.l 72 | in 73 | {wctx with l} 74 | -------------------------------------------------------------------------------- /src/core/Completion.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Completion} *) 5 | 6 | type completion = { 7 | text: string; (* the completed text *) 8 | summary: string option; (* short description of this particular completion *) 9 | } 10 | 11 | type 'a within_ctx = { 12 | start: int; (* offset at which completion starts *) 13 | stop: int; (* offset at which completion ends *) 14 | l : 'a list; 15 | } 16 | 17 | (* find constants that correspond to this position *) 18 | val find_constants : ?exact:bool -> string -> cursor_pos:int -> Expr.Cst.t within_ctx 19 | 20 | (* completions based on constants that can complete to this position *) 21 | val complete : string -> cursor_pos:int -> completion within_ctx 22 | -------------------------------------------------------------------------------- /src/core/Document.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Simple Formatted Document} *) 5 | 6 | module Fmt = CCFormat 7 | 8 | type block = 9 | [ `S of string (* section *) 10 | | `P of string (* paragraph *) 11 | | `Pre of string (* formatted paragraph *) 12 | | `I of string * t (* indented doc with header *) 13 | | `L of t list (* list of items *) 14 | ] 15 | 16 | and t = block list 17 | 18 | let section s = `S s 19 | let paragraph s = `P s 20 | let paragraph_f s = CCFormat.ksprintf ~f:paragraph s 21 | let indent i j = `I (i,j) 22 | let pre s = `Pre s 23 | let pre_f s = CCFormat.ksprintf ~f:pre s 24 | let sub l = `Sub l 25 | let list l = `L l 26 | 27 | let rec pp out (l:t) = 28 | Fmt.fprintf out "@[%a@]" (Fmt.list ~sep:Fmt.(return "@,") pp_block) l 29 | 30 | and pp_block out : block -> unit = function 31 | | `S sec -> Fmt.fprintf out "# @[%s@]@," sec 32 | | `P msg -> Fmt.fprintf out "@[%a@]" Format.pp_print_text msg 33 | | `Pre msg -> Fmt.fprintf out "%s" msg 34 | | `I (head, body) -> 35 | Fmt.fprintf out "@[%s::@ %a@]" head pp body 36 | | `L l -> 37 | let pp_item out x = Fmt.fprintf out "@[<2>- %a@]" pp x in 38 | Fmt.fprintf out "@[%a@]" (Fmt.list ~sep:Fmt.(return "@,") pp_item) l 39 | 40 | let to_string = Fmt.to_string pp 41 | -------------------------------------------------------------------------------- /src/core/Document.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Simple Formatted Document} *) 5 | 6 | type block = 7 | [ `S of string (* section *) 8 | | `P of string (* paragraph *) 9 | | `Pre of string (* formatted paragraph *) 10 | | `I of string * t (* indented block with header *) 11 | | `L of t list (* list of items *) 12 | ] 13 | 14 | and t = block list 15 | 16 | val section : string -> block 17 | val paragraph : string -> block 18 | val paragraph_f : ('a, Format.formatter, unit, block) format4 -> 'a 19 | val pre : string -> block 20 | val pre_f : ('a, Format.formatter, unit, block) format4 -> 'a 21 | val list : t list -> block 22 | val indent : string -> t -> block 23 | 24 | val pp : t CCFormat.printer 25 | (** Regular pretty printer *) 26 | 27 | val to_string : t -> string 28 | -------------------------------------------------------------------------------- /src/core/Eval.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software. See file "license" for more details. *) 2 | 3 | (** {1 Evaluation} *) 4 | 5 | open Base_types 6 | 7 | module Fmt = CCFormat 8 | module E = Expr 9 | 10 | type eval_side_effect = Base_types.eval_side_effect = 11 | | Print_doc of Document.t 12 | | Print_mime of mime_content 13 | 14 | let def_fun f = Fun f 15 | 16 | let def_rule ~lhs ~rhs = 17 | try 18 | let r = Pattern.compile_rule lhs rhs in 19 | Result.Ok (Rewrite r) 20 | with Pattern.Invalid_rule str -> 21 | Result.Error str 22 | 23 | exception Eval_fail of string 24 | 25 | let () = Printexc.register_printer 26 | (function 27 | | Eval_fail s -> 28 | Some ("evaluation failed:\n" ^ s) 29 | | _ -> None) 30 | 31 | let eval_fail msg = raise (Eval_fail msg) 32 | let eval_failf msg = Fmt.ksprintf msg ~f:eval_fail 33 | 34 | 35 | (* set of definitions and rules we can use for rewriting *) 36 | type rewrite_set = 37 | | RS_empty 38 | | RS_add_rules of rewrite_rule list * rewrite_set 39 | | RS_add_defs of def list * rewrite_set 40 | 41 | let rs_of_st st: rewrite_set = RS_add_rules (st.st_rules, RS_empty) 42 | 43 | let rs_of_cst st c: rewrite_set = RS_add_defs (c.cst_rules, rs_of_st st) 44 | 45 | let pp_slice out s = 46 | Format.fprintf out "[@[%a@]]" 47 | (Slice.print E.pp_full_form) s 48 | 49 | let debug_on_ : bool ref = ref false 50 | 51 | (* tracing evaluation *) 52 | let debug_eval_ k = 53 | if !debug_on_ 54 | then ( 55 | k (fun msg -> 56 | Format.kfprintf (fun out -> Format.fprintf out "@.") Format.std_formatter msg) 57 | ) 58 | 59 | let set_eval_debug b = debug_on_ := b 60 | 61 | (* @raise No_head if there is no head *) 62 | let rec pattern_head (p:pattern): const = match p with 63 | | P_const c -> c 64 | | P_z _ | P_q _ | P_string _ 65 | | P_blank None | P_blank_sequence None | P_blank_sequence_null None | P_fail 66 | -> raise E.No_head 67 | | P_blank (Some c) | P_blank_sequence (Some c) | P_blank_sequence_null (Some c) -> 68 | c 69 | | P_app_slice (f,_) | P_app_slice_unordered (f,_) | P_app (f,_) 70 | -> pattern_head f 71 | | P_bind (_,p') 72 | | P_conditional (p',_) 73 | | P_test (p',_) 74 | | P_check_same (_,p') -> pattern_head p' 75 | | P_alt [] -> raise E.No_head 76 | | P_alt (x::tail) -> 77 | begin match pattern_head x with 78 | | c -> c 79 | | exception E.No_head -> pattern_head (P_alt tail) 80 | end 81 | 82 | let true_ = E.const_of_string "True" 83 | let false_ = E.const_of_string "False" 84 | let sequence = E.const_of_string "Sequence" 85 | 86 | let sequence_of_array (a:E.t array) = E.app sequence a 87 | let sequence_of_slice (a:E.t Slice.t) = sequence_of_array (Slice.copy a) 88 | 89 | let equal_with (subst:Subst.t) a b: bool = 90 | let rec eq_aux a b = match a, b with 91 | | Z n1, Z n2 -> Z.equal n1 n2 92 | | Z z, Q q 93 | | Q q, Z z -> Q.equal q (Q.of_bigint z) 94 | | Q n1, Q n2 -> Q.equal n1 n2 95 | | String s1, String s2 -> s1=s2 96 | | Const c1, Const c2 -> c1.cst_id = c2.cst_id 97 | | App (f1,a1), App (f2,a2) -> 98 | Array.length a1=Array.length a2 && 99 | eq_aux f1 f2 && 100 | CCArray.equal eq_aux a1 a2 101 | | Reg i, Reg j when i=j -> true 102 | | Reg i, _ -> 103 | (* lookup *) 104 | begin match Subst.get i subst with 105 | | None -> false 106 | | Some a' -> eq_aux a' b 107 | end 108 | | _, Reg j -> 109 | (* lookup *) 110 | begin match Subst.get j subst with 111 | | None -> false 112 | | Some b' -> eq_aux a b' 113 | end 114 | | Z _, _ | Q _, _ | String _, _ | Const _, _ | App _, _ 115 | -> false 116 | in 117 | eq_aux a b 118 | 119 | (* return all the matches of [pat] against [e], modifying [st] 120 | every time in a backtracking way *) 121 | let rec match_ (st:eval_state) (subst:Subst.t) (pat:pattern) (e:E.t)(yield:Subst.t -> unit): unit = 122 | debug_eval_ (fun k->k "@[<2>match @[%a@]@ with: @[%a@]@ subst: @[%a@]@]" 123 | Pattern.pp pat E.pp_full_form e Subst.pp subst); 124 | begin match pat, e with 125 | | P_z a, Z b -> if Z.equal a b then yield subst 126 | | P_q a, Q b -> if Q.equal a b then yield subst 127 | | P_q a, Z b -> if Q.equal a (Q.of_bigint b) then yield subst 128 | | P_z a, Q b -> if Q.equal (Q.of_bigint a) b then yield subst 129 | | P_string a, String b -> if a=b then yield subst 130 | | P_const c, Const d -> if E.Cst.equal c d then yield subst 131 | | P_blank None, _ -> yield subst 132 | | P_blank (Some c), App (Const c', _) -> 133 | if E.Cst.equal c c' then yield subst 134 | | P_blank (Some _), _ -> () 135 | | P_bind (i, P_blank None), _ -> 136 | (* easy case: bind [i] *) 137 | assert (not (Subst.mem i subst)); 138 | let subst = Subst.add i e subst in 139 | yield subst 140 | | P_bind (i, sub_pat), _ -> 141 | match_ st subst sub_pat e 142 | (fun subst -> 143 | assert (not (Subst.mem i subst)); 144 | (* bind [i] *) 145 | let subst = Subst.add i e subst in 146 | yield subst) 147 | | P_check_same (i, sub_pat), _ -> 148 | match_ st subst sub_pat e 149 | (fun subst -> 150 | (* get current binding for [i] *) 151 | let other = Subst.get_exn i subst in 152 | debug_eval_ 153 | (fun k->k "(@[<2>check_same@ %a@ %a@])" E.pp_full_form e E.pp_full_form other); 154 | if E.equal e other then yield subst) 155 | | P_app (hd, args), App (hd', args') 156 | when Array.length args = Array.length args' -> 157 | match_ st subst hd hd' 158 | (fun subst -> match_arrays st subst args args' 0 yield) 159 | | P_app_slice (hd, tree), App (hd', args) -> 160 | (* slice matching *) 161 | match_ st subst hd hd' 162 | (fun subst -> match_slices st subst tree (Slice.full args) yield) 163 | | P_app_slice_unordered (hd, tree), App (hd', args) -> 164 | (* commutative slice matching *) 165 | match_ st subst hd hd' 166 | (fun subst -> match_slices_unordered st subst tree (Array.to_list args) yield) 167 | | P_conditional (p', cond), _ -> 168 | match_ st subst p' e 169 | (fun subst -> 170 | if check_cond st subst cond then yield subst) 171 | | P_test (p', test), _ -> 172 | (* match [p'] with [e], then check if [test[e] --> True] *) 173 | match_ st subst p' e 174 | (fun subst -> 175 | if check_cond st Subst.empty (E.app test [| e |]) 176 | then yield subst) 177 | | P_fail, _ -> () 178 | | P_alt l, _ -> match_alt st subst l e yield 179 | | P_z _, _ 180 | | P_q _, _ 181 | | P_const _, _ 182 | | P_string _, _ 183 | | P_app_slice _, _ 184 | | P_app_slice_unordered _, _ 185 | | P_app _, _ 186 | | P_blank_sequence _, _ 187 | | P_blank_sequence_null _, _ 188 | -> () (* fail *) 189 | end 190 | 191 | (* match arrays pairwise *) 192 | and match_arrays st subst a b (i:int) yield: unit = 193 | if i = Array.length a then ( 194 | assert (i = Array.length b); 195 | yield subst 196 | ) else 197 | match_ st subst a.(i) b.(i) 198 | (fun subst -> 199 | match_arrays st subst a b (i+1) yield 200 | ) 201 | 202 | (* try alternatives *) 203 | and match_alt st subst (l:pattern list) e yield: unit = 204 | List.iter (fun pat -> match_ st subst pat e yield) l 205 | 206 | (* check if [cond --> true] *) 207 | and check_cond st (subst:Subst.t)(cond:E.t): bool = 208 | let cond' = Subst.apply subst cond in 209 | begin match eval_rec st cond' with 210 | | Const {cst_name="True";_} -> true 211 | | Const {cst_name="False";_} -> false 212 | | cond' -> 213 | eval_failf 214 | "@[<2>expected True/False,@ but condition `@[%a@]`@ \ 215 | reduces to `@[%a@]`@ in subst %a@]" 216 | E.pp_full_form cond E.pp_full_form cond' Subst.pp subst 217 | end 218 | 219 | (* match tree [ap] to slice [slice] *) 220 | and match_slices st subst (ap:slice_pattern) (slice:E.t Slice.t) yield: unit = 221 | match ap with 222 | | SP_vantage apv -> match_sp_vantage st subst apv slice yield 223 | | SP_pure (l,_) -> match_sp_pure st subst l slice yield 224 | 225 | and match_sp_vantage st subst (apv:slice_pattern_vantage) slice yield = 226 | debug_eval_ (fun k->k "@[<2>match_sp_vantage st @[%a@]@ slice @[%a@]@]" 227 | Pattern.pp apv.sp_vantage pp_slice slice); 228 | (* check that there are enough elements *) 229 | let n = Slice.length slice in 230 | if apv.sp_min_size > n then () 231 | else ( 232 | (* the range in which we can match [ap.sp_vantage] safely *) 233 | let min, max = 234 | Pattern.sp_slice_min_size apv.sp_left, 235 | n - Pattern.sp_slice_min_size apv.sp_right 236 | in 237 | for vantage_idx = min to max-1 do 238 | (* try with this index *) 239 | debug_eval_ (fun k->k 240 | "@[match_sp_vantage st@ at idx %d,@ pat @[%a@]@ \ 241 | (min %d, max %d, slice @[%a@])@]" 242 | vantage_idx Pattern.pp apv.sp_vantage min max pp_slice slice); 243 | match_ st subst apv.sp_vantage (Slice.get slice vantage_idx) 244 | (fun subst -> 245 | let slice_left = Slice.sub slice 0 vantage_idx in 246 | match_slices st subst apv.sp_left slice_left 247 | (fun subst -> 248 | let slice_right = 249 | Slice.sub slice (vantage_idx+1) (n-vantage_idx-1) 250 | in 251 | match_slices st subst apv.sp_right slice_right yield)) 252 | done 253 | ) 254 | 255 | and match_sp_pure st subst (l:pattern list) slice yield = 256 | let n = Slice.length slice in 257 | begin match l, n with 258 | | [], 0 -> yield subst 259 | | [], _ -> () (* fail to match some elements *) 260 | | [p], _ -> 261 | (* match [p] with the whole slice *) 262 | match_pat_slice st subst p slice yield 263 | | p1 :: tail, _ -> 264 | (* cut [slice] into two parts, one to be matched with [p1], 265 | the rest with [tail] 266 | TODO a bit too naive, use info about min length *) 267 | for i=0 to n do 268 | let slice1 = Slice.sub slice 0 i in 269 | match_pat_slice st subst p1 slice1 270 | (fun subst -> 271 | let slice2 = Slice.sub slice i (n-i) in 272 | match_sp_pure st subst tail slice2 yield) 273 | done 274 | end 275 | 276 | (* match tree [ap] to slice [slice] *) 277 | and match_slices_unordered st subst (p:slice_unordered_pattern) (slice:E.t list) yield: unit = 278 | match p with 279 | | SUP_vantage (p,next,min_size) -> 280 | match_sup_vantage st subst p next min_size slice yield 281 | | SUP_pure (pats,_) -> 282 | match_sup_pure st subst pats slice yield 283 | 284 | and match_sup_vantage st subst p next min_size slice yield = 285 | (* check that there are enough elements *) 286 | let n = List.length slice in 287 | if min_size > n then () 288 | else ( 289 | (* try to match [p] against all elements of [slice], one by one. 290 | [left]: elements we tried against [e] already, kept for [next] 291 | [right]: elements still not tried *) 292 | let rec aux left right = match right with 293 | | [] -> () 294 | | e :: right_tail -> 295 | debug_eval_ (fun k->k 296 | "@[match_sup_vantage st@ pat @[%a@]@ at @[%a@]@]" 297 | Pattern.pp p (Fmt.Dump.list E.pp_full_form) right); 298 | (* try [e] *) 299 | match_ st subst p e 300 | (fun subst -> 301 | match_slices_unordered st subst next 302 | (List.rev_append left right_tail) yield); 303 | (* avoid [e] *) 304 | aux (e :: left) right_tail 305 | in 306 | aux [] slice 307 | ) 308 | 309 | and match_sup_pure st subst (l:pattern list) slice yield = 310 | begin match l, slice with 311 | | [], [] -> yield subst 312 | | [], _ -> () (* fail to match some elements *) 313 | | [p], _ -> 314 | (* match [p] with the whole slice *) 315 | match_pat_slice st subst p (Slice.of_list slice) yield 316 | | p1 :: tail, _ -> 317 | (* match [p1] with a subset of [slice]. This is going to be expensive. 318 | TODO: use min size information… *) 319 | let rec aux left_in left_out right = match right with 320 | | [] -> 321 | (* match [left_in] with [p1]; then match [left_out] with [tail] *) 322 | match_pat_slice st subst p1 (Slice.of_list left_in) 323 | (fun subst -> 324 | match_sup_pure st subst tail left_out yield) 325 | | e :: right_tail -> 326 | (* try with [e] in the list *) 327 | aux (e::left_in) left_out right_tail; 328 | aux left_in (e::left_out) right_tail; 329 | in 330 | aux [] [] slice 331 | end 332 | 333 | (* check that [c] is the head of all elements of the slice *) 334 | and check_head_slice (c:const) (slice:_ Slice.t): bool = 335 | Slice.for_all 336 | (function 337 | | App (Const c', _) -> E.Cst.equal c c' 338 | | _ -> false) 339 | slice 340 | 341 | (* match [p] with the whole slice, if possible *) 342 | and match_pat_slice st subst (p:pattern) slice yield = 343 | let n = Slice.length slice in 344 | begin match p with 345 | | P_blank_sequence None -> 346 | if n>0 then yield subst (* yield if non empty slice *) 347 | | P_blank_sequence (Some c) -> 348 | if n>0 && check_head_slice c slice then yield subst 349 | | P_blank_sequence_null None -> yield subst (* always matches *) 350 | | P_blank_sequence_null (Some c) -> 351 | if check_head_slice c slice then yield subst 352 | | P_alt [] -> () 353 | | P_alt (p1::tail) -> 354 | (* try alternatives *) 355 | match_pat_slice st subst p1 slice yield; 356 | match_pat_slice st subst (P_alt tail) slice yield 357 | | P_check_same (i, p') -> 358 | (* check that [i] corresponds to [Sequence[slice]] *) 359 | let e_slice = lazy (sequence_of_slice slice) in 360 | match_pat_slice st subst p' slice 361 | (fun subst -> 362 | (* get current binding for [i] *) 363 | let other = Subst.get_exn i subst in 364 | debug_eval_ 365 | (fun k->k "(@[<2>check_same@ %a@ %a@])" 366 | E.pp_full_form (Lazy.force e_slice) E.pp_full_form other); 367 | if E.equal (Lazy.force e_slice) other then yield subst) 368 | | P_bind (i, p') -> 369 | (* bind [i] to [Sequence[slice]] *) 370 | match_pat_slice st subst p' slice 371 | (fun subst -> 372 | let subst = Subst.add i (sequence_of_slice slice) subst in 373 | yield subst) 374 | | P_conditional (p', cond) -> 375 | match_pat_slice st subst p' slice 376 | (fun subst -> 377 | if check_cond st subst cond then yield subst) 378 | | P_test (p', test) -> 379 | match_pat_slice st subst p' slice 380 | (fun subst -> 381 | if Slice.for_all 382 | (fun arg -> check_cond st Subst.empty (E.app test [| arg |])) 383 | slice 384 | then yield subst) 385 | | P_fail -> () 386 | | P_blank _ | P_q _ | P_z _ | P_string _ | P_app _ 387 | | P_const _ | P_app_slice _ | P_app_slice_unordered _ 388 | -> 389 | if n=1 then ( 390 | (* non-sequence pattern, match against the only element *) 391 | match_ st subst p (Slice.get slice 0) yield 392 | ) 393 | end 394 | 395 | and eval_rec (st:eval_state) e = 396 | (* debug_eval_ (fun k->k "@[<2>eval_rec @[%a@]@]" E.pp_full_form e); *) 397 | match e with 398 | | App (Const {cst_name="CompoundExpression";_}, ([| |] | [| _ |])) -> assert false 399 | | App (Const {cst_name="CompoundExpression";_}, args) -> 400 | (* sequence of `a;b;c…`. Return same as last expression *) 401 | let rec aux i = 402 | if i+1 = Array.length args 403 | then eval_rec st args.(i) 404 | else ( 405 | let _ = eval_rec st args.(i) in 406 | aux (i+1) 407 | ) 408 | in 409 | aux 0 410 | | App (Const {cst_name="ReplaceAll";_}, [| a; b |]) -> 411 | (* TODO: move into builtins *) 412 | (* first, eval both *) 413 | let a = eval_rec st a in 414 | let b = eval_rec st b in 415 | (* rewrite [a] with rules in [b], until fixpoint *) 416 | let rules = term_as_rules st b in 417 | debug_eval_ 418 | (fun k->k "(@[replace_all@ %a@ rules: (@[%a@])@])" 419 | E.pp_full_form a (Fmt.list Pattern.pp_rule) rules); 420 | let a = rewrite_rec st ~steps:`Once rules a in 421 | eval_rec st a 422 | | App (Const {cst_name="ReplaceRepeated";_}, [| a; b |]) -> 423 | (* first, eval both *) 424 | let a = eval_rec st a in 425 | let b = eval_rec st b in 426 | (* rewrite [a] with rules in [b], until fixpoint *) 427 | let rules = term_as_rules st b in 428 | debug_eval_ 429 | (fun k->k "(@[replace_repeated@ %a@ rules: (@[%a@])@])" 430 | E.pp_full_form a (Fmt.list Pattern.pp_rule) rules); 431 | let a = rewrite_rec st ~steps:`Repeated rules a in 432 | eval_rec st a 433 | | App (Const {cst_name="Comprehension";_}, args) when Array.length args>0 -> 434 | (* sequence binding_seq. First evaluate all terms but the first 435 | one, then compile into a binding_seq *) 436 | (* TODO: use `;` instead. Move all this into CompoundExpression, 437 | make comprehension a thin rule `a::b -> CollectSeq[a;b]`? *) 438 | let args = 439 | Array.mapi (fun i arg -> if i>0 then eval_rec st arg else arg) args 440 | in 441 | begin match Pattern.compile_binding_seq ~ret:`First args with 442 | | Result.Ok c -> eval_comprehension st e c 443 | | Result.Error msg -> 444 | eval_failf "@[<2>could not evaluate@ `%a`@ reason: %s@]" E.pp e msg 445 | end 446 | | App (Const {cst_name="Let";_}, args) when Array.length args>0 -> 447 | (* sequence of bindings. First evaluate all terms but the first 448 | one, then compile into a binding_seq *) 449 | let args = 450 | Array.mapi (fun i arg -> if i+1 eval_let st e c 454 | | Result.Error msg -> 455 | eval_failf "@[<2>could not evaluate@ `%a`@ reason: %s@]" E.pp e msg 456 | end 457 | | App (Const {cst_name="AssignDelayed";_}, [| a; b |]) -> 458 | (* lazy set: add rewrite rule [a :> b] to the definitions of [head a] *) 459 | begin match E.head a with 460 | | c -> 461 | let rule = Pattern.compile_rule a b in 462 | E.Cst.add_def (Rewrite rule) c 463 | | exception E.No_head -> 464 | eval_failf "cannot assign to %a" E.pp_full_form a 465 | end; 466 | E.null 467 | | App (Const {cst_name="Assign";_}, [| a; b |]) -> 468 | (* eager set: eval [b], then add [a :> b] to the defs of [head a] *) 469 | let b = eval_rec st b in 470 | begin match E.head a with 471 | | c -> 472 | let rule = Pattern.compile_rule a b in 473 | E.Cst.add_def (Rewrite rule) c; 474 | | exception E.No_head -> 475 | eval_failf "cannot assign to %a" E.pp_full_form a 476 | end; 477 | b 478 | | App (App (Const {cst_name="Function";_}, [| body |]) as hd, args) -> 479 | (* evaluate args, then apply function *) 480 | let args = eval_args_of st hd args in 481 | eval_beta_reduce st e body args 482 | | App (hd, args) -> 483 | let hd = eval_rec st hd in 484 | (* evaluate arguments, but only if [hd] allows it *) 485 | let args = eval_args_of st hd args in 486 | let t' = E.app_flatten hd args in 487 | begin match t' with 488 | | App (Const c as hd, 489 | [| App (Const {cst_name="List";_} as list_, args) |]) 490 | when E.Cst.get_field E.field_listable c -> 491 | (* TODO: should work even with multiple arguments, some of which are lists *) 492 | (* distribute [hd] on the list and evaluate it *) 493 | let args = Array.map (fun a -> eval_rec st (E.app hd [| a |])) args in 494 | (* return the list of results *) 495 | let e' = E.app_flatten list_ args in 496 | st.st_trace e e'; 497 | e' 498 | | App (hd, _) -> 499 | begin 500 | try 501 | let c = Expr.head hd in 502 | (* try every definition of [c] in addition to global rules *) 503 | try_defs st t' (rs_of_cst st c) 504 | with Expr.No_head -> 505 | try_defs st t' (rs_of_st st) 506 | end 507 | | _ -> 508 | (* just try the global rewrite rules *) 509 | try_defs st t' (rs_of_st st) 510 | end 511 | | Reg _ -> e (* cannot evaluate *) 512 | | Z _ 513 | | Q _ 514 | | String _ -> 515 | (* try global rules *) 516 | try_defs st e (rs_of_st st) 517 | | Const c -> 518 | (* [c] might have a definition *) 519 | try_defs st e (rs_of_cst st c) 520 | 521 | and term_as_rule st e : rewrite_rule = match e with 522 | | App (Const {cst_name="Rule";_}, [| lhs; rhs |]) -> 523 | let rhs = eval_rec st rhs in 524 | Pattern.compile_rule lhs rhs 525 | | App (Const {cst_name="RuleDelayed";_}, [| lhs; rhs |]) -> 526 | Pattern.compile_rule lhs rhs 527 | | _ -> eval_failf "cannot interpret `@[%a@]` as a rule" E.pp_full_form e 528 | 529 | and term_as_rules st e: rewrite_rule list = match e with 530 | | App (Const {cst_name="List";_}, args) -> 531 | CCList.init (Array.length args) (fun i -> term_as_rule st args.(i)) 532 | | _ -> [term_as_rule st e] 533 | 534 | (* eval arguments [args], depending on whether the attributes 535 | of [hd] allow it *) 536 | and eval_args_of (st:eval_state) hd args = match hd with 537 | | Const c when E.Cst.get_field E.field_hold_all c -> 538 | (* hold: stop evaluation *) 539 | args 540 | | Const c when E.Cst.get_field E.field_hold_first c -> 541 | Array.mapi 542 | (fun i a -> if i=0 then a else eval_rec st a) 543 | args 544 | | Const c when E.Cst.get_field E.field_hold_rest c -> 545 | Array.mapi 546 | (fun i a -> if i>0 then a else eval_rec st a) 547 | args 548 | | _ -> 549 | (* debug_eval_ (fun k->k "eval_args %a" (Fmt.array E.pp) args); *) 550 | Array.map (eval_rec st) args 551 | 552 | (* try rules [rules] and definitions [defs] one by one, until one matches *) 553 | and try_defs (st:eval_state) t (rs:rewrite_set) = match rs with 554 | | RS_empty -> t 555 | | RS_add_defs ([], rs') 556 | | RS_add_rules ([], rs') -> try_defs st t rs' 557 | | RS_add_rules (r :: rules_trail, rs') -> 558 | try_rule st t r (RS_add_rules (rules_trail, rs')) 559 | | RS_add_defs (Rewrite r :: trail, rs') -> 560 | try_rule st t r (RS_add_defs (trail, rs')) 561 | | RS_add_defs (Fun f :: trail, rs') -> 562 | begin match f st t with 563 | | None -> try_defs st t (RS_add_defs (trail, rs')) 564 | | Some t' -> 565 | st.st_iter_count <- st.st_iter_count + 1; 566 | st.st_trace t t'; 567 | eval_rec st t' 568 | end 569 | 570 | and try_rule st t rule (rs:rewrite_set) = 571 | let subst_opt = 572 | match_ st Subst.empty rule.rr_pat t |> Iter.head 573 | in 574 | begin match subst_opt with 575 | | None -> try_defs st t rs 576 | | Some subst -> 577 | let t' = Subst.apply subst rule.rr_rhs in 578 | st.st_iter_count <- st.st_iter_count + 1; 579 | st.st_trace t t'; 580 | eval_rec st t' 581 | end 582 | 583 | (* beta-reduction of given function expression *) 584 | and eval_beta_reduce st e fun_body args = 585 | let rec replace (t:expr): expr = match t with 586 | | Reg _ -> assert false 587 | | App (Const {cst_name="Function"; _}, _) -> 588 | t (* do not enter functions *) 589 | | App (Const {cst_name="Slot";_}, [| Z n |]) -> 590 | (* slot substitution *) 591 | let i = Z.to_int n in 592 | if i < 0 then eval_failf "invalid slot `%d`: must be >= 0" i; 593 | if i > Array.length args then ( 594 | eval_failf "invalid slot `%d`: not enough arguments" i; 595 | ); 596 | (* dereference argument *) 597 | if i=0 598 | then sequence_of_array args 599 | else args.(i-1) 600 | | Const _ | Z _ | Q _ | String _ -> t 601 | | App (hd, args) -> 602 | E.app_flatten (replace hd) (Array.map replace args) 603 | in 604 | let e' = replace fun_body in 605 | st.st_trace e e'; 606 | eval_rec st e' 607 | 608 | and eval_bindings st subst (l:binding_seq_body_item list): Subst.t Iter.t = 609 | let open Iter.Infix in 610 | match l with 611 | | [] -> Iter.return subst 612 | | op :: tail -> 613 | eval_binding st subst op >>= fun subst -> eval_bindings st subst tail 614 | 615 | and eval_binding st subst (op:binding_seq_body_item): Subst.t Iter.t = 616 | let open Iter.Infix in 617 | let eval_subst subst t = Subst.apply subst t |> eval_rec st in 618 | match op with 619 | | Comp_test t -> 620 | let t' = Subst.apply subst t |> eval_rec st in 621 | begin match t' with 622 | | Const {cst_name="True";_} -> Iter.return subst 623 | | _ -> Iter.empty 624 | end 625 | | Comp_match (pat, rhs) -> 626 | match_ st subst pat (eval_subst subst rhs) 627 | | Comp_match1 (pat, rhs) -> 628 | let rhs' = eval_subst subst rhs in 629 | (* match each subterm of [rhs] with [pat] *) 630 | begin match rhs' with 631 | | App (_, args) -> 632 | Iter.of_array args 633 | >>= fun sub_rhs -> 634 | match_ st subst pat sub_rhs 635 | | _ -> Iter.empty 636 | end 637 | 638 | (* evaluate a comprehension *) 639 | and eval_comprehension st e (c:binding_seq) = 640 | let eval_subst subst t = Subst.apply subst t |> eval_rec st in 641 | (* recurse through the body *) 642 | let e' = 643 | eval_bindings st Subst.empty c.comp_body 644 | |> Iter.map (fun subst -> eval_subst subst c.comp_yield) 645 | |> Iter.to_list 646 | |> Array.of_list 647 | |> E.app_flatten sequence 648 | in 649 | st.st_trace e e'; 650 | e' 651 | 652 | (* let is like a binding_seq, but we only return the first result *) 653 | and eval_let st e (c:binding_seq) = 654 | let eval_subst subst t = Subst.apply subst t |> eval_rec st in 655 | (* recurse through the body *) 656 | let e' = 657 | eval_bindings st Subst.empty c.comp_body 658 | |> Iter.map (fun subst -> eval_subst subst c.comp_yield) 659 | |> Iter.head 660 | |> (function 661 | | Some t -> t 662 | | None -> eval_failf "no match for `Let`") 663 | in 664 | st.st_trace e e'; 665 | e' 666 | 667 | (* rewrite term [e] recursively using [rules]. 668 | Do not evaluate. *) 669 | and rewrite_rec st ~(steps:[`Once|`Repeated]) (rules:rewrite_rule list)(e:expr): expr = 670 | let rec aux (e:expr): expr = match e with 671 | | Reg _ -> e 672 | | Z _ | Q _ | String _ | Const _ -> 673 | try_rewrite_with e rules 674 | | App (hd, args) -> 675 | let hd = aux hd in 676 | let args = Array.map aux args in 677 | let e = E.app hd args in 678 | try_rewrite_with e rules 679 | and try_rewrite_with e (l:rewrite_rule list): expr = match l with 680 | | [] -> e 681 | | r :: tail -> 682 | let subst_opt = 683 | match_ st Subst.empty r.rr_pat e |> Iter.head 684 | in 685 | begin match subst_opt with 686 | | None -> try_rewrite_with e tail 687 | | Some subst -> 688 | let e' = Subst.apply subst r.rr_rhs in 689 | st.st_trace e e'; 690 | begin match steps with 691 | | `Once -> e' 692 | | `Repeated -> aux e' (* rewrite again *) 693 | end 694 | end 695 | in 696 | aux e 697 | 698 | let create_eval_state ~buf () : eval_state = { 699 | st_iter_count=0; 700 | st_rules=[]; 701 | st_effects=buf; 702 | st_trace=(fun _ _ ->()); 703 | } 704 | 705 | let eval e = 706 | let st = create_eval_state ~buf:None () in 707 | eval_rec st e 708 | 709 | let eval_full e : E.t * eval_side_effect list = 710 | let q = Stack.create() in 711 | let st = create_eval_state ~buf:(Some q) () in 712 | let e' = eval_rec st e in 713 | let effects = Iter.of_stack q |> Iter.to_rev_list in 714 | (* also check if there is a custom display *) 715 | let e_display = match e' with 716 | | Const {cst_display=Some f;_} 717 | | App (Const {cst_display=Some f;_}, _) -> 718 | f e' |> List.map (fun d -> Print_mime d) 719 | | _ -> [] 720 | in 721 | e', e_display @ effects 722 | 723 | (* primitive API *) 724 | 725 | let prim_eval = eval_rec 726 | let prim_fail _ = eval_fail 727 | let prim_failf _ msg = eval_failf msg 728 | 729 | let prim_with_trace st trace f = 730 | let old = st.st_trace in 731 | st.st_trace <- trace; 732 | CCFun.finally 733 | ~h:(fun () -> st.st_trace <- old) 734 | ~f 735 | 736 | let prim_write_doc st = match st.st_effects with 737 | | None -> (fun _ -> ()) 738 | | Some q -> fun msg -> Stack.push (Print_doc (Lazy.force msg)) q 739 | 740 | let prim_print st m = prim_write_doc st (Lazy.from_val [Document.paragraph m]) 741 | 742 | let prim_term_as_rule = term_as_rule 743 | let prim_term_as_rules = term_as_rules 744 | let prim_match_ = match_ 745 | 746 | let prim_printf st = match st.st_effects with 747 | | None -> (fun msg -> Format.ikfprintf (fun _ -> ()) Format.str_formatter msg) 748 | | Some _ -> 749 | fun msg -> Fmt.ksprintf msg ~f:(fun msg -> prim_print st msg) 750 | 751 | let prim_write_mime st = match st.st_effects with 752 | | None -> (fun _ -> ()) 753 | | Some q -> fun (lazy m) -> Stack.push (Print_mime m) q 754 | -------------------------------------------------------------------------------- /src/core/Eval.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software. See file "license" for more details. *) 2 | 3 | (** {1 Evaluation} *) 4 | 5 | open Base_types 6 | 7 | val def_rule : lhs:expr -> rhs:expr -> (def,string) Result.result 8 | (** [def_rule lhs rhs] makes a proper rewrite rule *) 9 | 10 | val def_fun : prim_fun -> def 11 | (** Make a definition from a primitive function *) 12 | 13 | exception Eval_fail of string 14 | 15 | type eval_side_effect = Base_types.eval_side_effect = 16 | | Print_doc of Document.t 17 | | Print_mime of mime_content 18 | 19 | val eval : expr -> expr 20 | 21 | val eval_full : expr -> expr * eval_side_effect list 22 | (** @returns the normal form, and messages printed in the mean time *) 23 | 24 | (**/**) 25 | val set_eval_debug: bool -> unit 26 | 27 | val prim_eval : prim_fun_args -> expr -> expr 28 | (** Evaluation function to be called by primitives *) 29 | 30 | val prim_with_trace : prim_fun_args -> trace_fun -> (unit -> 'a) -> 'a 31 | (** Set [trace] functions during call to function, then restore old one *) 32 | 33 | val prim_fail : prim_fun_args -> string -> 'a 34 | (** To be called by primitives on failure *) 35 | 36 | val prim_match_ : prim_fun_args -> Subst.t -> Pattern.t -> expr -> Subst.t Iter.t 37 | 38 | val prim_term_as_rule : prim_fun_args -> expr -> Expr.rewrite_rule 39 | 40 | val prim_term_as_rules : prim_fun_args -> expr -> Expr.rewrite_rule list 41 | 42 | val prim_failf : prim_fun_args -> ('a, Format.formatter, unit, 'b) format4 -> 'a 43 | 44 | val prim_write_doc : prim_fun_args -> Document.t lazy_t -> unit 45 | 46 | val prim_print : prim_fun_args -> string -> unit 47 | 48 | val prim_printf : prim_fun_args -> ('a, Format.formatter, unit, unit) format4 -> 'a 49 | 50 | val prim_write_mime : prim_fun_args -> mime_content lazy_t -> unit 51 | 52 | (**/**) 53 | -------------------------------------------------------------------------------- /src/core/Expr.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software. See file "license" for more details. *) 2 | 3 | (** {1 Expressions} *) 4 | 5 | module Fmt = CCFormat 6 | include Base_types 7 | 8 | let field_protected = Properties.mk_field() 9 | let field_builtin = Properties.mk_field() 10 | let field_hold_all = Properties.mk_field() 11 | let field_hold_first = Properties.mk_field() 12 | let field_hold_rest = Properties.mk_field() 13 | let field_orderless = Properties.mk_field() 14 | let field_no_flatten = Properties.mk_field() 15 | let field_flatten = Properties.mk_field() 16 | let field_one_identity = Properties.mk_field() 17 | let field_listable = Properties.mk_field () 18 | let field_no_duplicates = Properties.mk_field() 19 | let () = Properties.freeze() 20 | 21 | (** {2 Basics} *) 22 | 23 | type t = Base_types.expr = 24 | | Const of const 25 | | App of t * t array 26 | | Z of Z.t 27 | | Q of Q.t 28 | | String of string 29 | | Reg of int 30 | 31 | exception Print_default 32 | 33 | module Str_tbl = CCHashtbl.Make(struct 34 | type t = string 35 | let equal (a:string) b = a=b 36 | let hash (a:string) = Hashtbl.hash a 37 | end) 38 | 39 | (* perfect sharing of constants *) 40 | type bank = { 41 | by_name: t Str_tbl.t; (* name -> const *) 42 | mutable const_id: int; (* unique name *) 43 | } 44 | 45 | let bank : bank = { 46 | by_name = Str_tbl.create 1_024; 47 | const_id = 0; 48 | } 49 | 50 | let const c = Const c 51 | 52 | let const_of_string name = 53 | try Str_tbl.find bank.by_name name 54 | with Not_found -> 55 | let c = Const { 56 | cst_name=name; 57 | cst_properties=Properties.empty; 58 | cst_id= bank.const_id; 59 | cst_rules=[]; 60 | cst_doc=[]; 61 | cst_printer=None; 62 | cst_display=None; 63 | } in 64 | bank.const_id <- bank.const_id + 1; 65 | Str_tbl.add bank.by_name name c; 66 | c 67 | 68 | let app hd args = App (hd, args) 69 | 70 | let null = const_of_string "Null" 71 | 72 | let app_l head args = app head (Array.of_list args) 73 | 74 | let z n = Z n 75 | 76 | let q n = Q n 77 | 78 | let string s = String s 79 | 80 | let reg i = Reg i 81 | 82 | let of_int i = Z (Z.of_int i) 83 | 84 | let of_int_ratio a b = Q (Q.of_ints a b) 85 | 86 | let of_float x = Q (Q.of_float x) 87 | 88 | (** {2 Constants} *) 89 | 90 | exception No_head 91 | 92 | let rec head = function 93 | | Const c -> c 94 | | App (hd, _) -> head hd 95 | | Z _ | Q _ | String _ | Reg _ -> raise No_head 96 | 97 | module Cst = struct 98 | type t = const 99 | 100 | let equal a b = a.cst_id = b.cst_id 101 | let hash a = Hash.int a.cst_id 102 | 103 | let get_field f c = Properties.get f c.cst_properties 104 | 105 | let set_field f b c = c.cst_properties <- Properties.set f b c.cst_properties 106 | 107 | let add_def d c = match d with 108 | | Rewrite {rr_pat=P_const c'; _} when equal c c' -> 109 | c.cst_rules <- [d] (* shadowing *) 110 | | _ -> c.cst_rules <- d :: c.cst_rules 111 | 112 | let clear_defs c = c.cst_rules <- [] 113 | 114 | let set_doc d c = c.cst_doc <- d 115 | let get_doc c = c.cst_doc 116 | 117 | let set_printer i f c = c.cst_printer <- Some (i,f) 118 | let set_display f c = c.cst_display <- Some f 119 | 120 | let complete s : t list = 121 | Str_tbl.values bank.by_name 122 | |> Iter.filter_map 123 | (function 124 | | Const c when CCString.prefix ~pre:s c.cst_name -> Some c 125 | | _ -> None) 126 | |> Iter.to_rev_list 127 | |> List.sort (fun c1 c2 -> String.compare c1.cst_name c2.cst_name) 128 | end 129 | 130 | let const_of_string_with ~f name = 131 | let c = const_of_string name in 132 | begin match c with 133 | | Const r -> f r; 134 | | App _ | Z _ | Q _ | String _ | Reg _ -> assert false 135 | end; 136 | c 137 | 138 | let rec compare a b = 139 | let to_int_ = function 140 | | Z _ -> 1 141 | | Q _ -> 2 142 | | String _ -> 3 143 | | Const _ -> 4 144 | | App _ -> 5 145 | | Reg _ -> 6 146 | in 147 | begin match a, b with 148 | | Z a, Z b -> Z.compare a b 149 | | Q a, Q b -> Q.compare a b 150 | | String a, String b -> String.compare a b 151 | | Const a, Const b -> CCInt.compare a.cst_id b.cst_id 152 | | App (fa, la), App (fb, lb) -> 153 | let c = compare fa fb in 154 | if c<>0 then c 155 | else CCArray.compare compare la lb 156 | | Reg i, Reg j -> CCInt.compare i j 157 | | Z _, _ 158 | | Q _, _ 159 | | String _, _ 160 | | Const _, _ 161 | | App _, _ 162 | | Reg _, _ 163 | -> CCInt.compare (to_int_ a) (to_int_ b) 164 | end 165 | 166 | let app_flatten hd args = 167 | let as_sub = match hd with 168 | | Const c when Cst.get_field field_flatten c -> 169 | (function 170 | | App (Const {cst_name="Sequence";_}, sub) -> Some sub 171 | | App (Const c', sub) when Cst.equal c c' -> Some sub 172 | | _ -> None) 173 | | _ -> 174 | (function 175 | | App (Const {cst_name="Sequence";_}, sub) -> Some sub 176 | | _ -> None) 177 | in 178 | (* splicing *) 179 | let must_splice, res_len = 180 | Array.fold_left 181 | (fun (must_split,len) arg -> match as_sub arg with 182 | | Some sub -> 183 | true, len+Array.length sub 184 | | _ -> must_split, len+1) 185 | (false,0) args 186 | and can_flatten = match hd with 187 | | Const c when Cst.get_field field_no_flatten c -> false 188 | | _ -> true 189 | and is_orderless = match hd with 190 | | Const c -> Cst.get_field field_orderless c 191 | | _ -> false 192 | in 193 | let new_args = if can_flatten && must_splice then ( 194 | let args_flat = Array.make res_len null in 195 | (* make a flattened array *) 196 | let len' = 197 | Array.fold_left 198 | (fun offset arg -> match as_sub arg with 199 | | Some sub -> 200 | Array.blit sub 0 args_flat offset (Array.length sub); 201 | offset + Array.length sub 202 | | _ -> 203 | args_flat.(offset) <- arg; 204 | offset + 1) 205 | 0 args 206 | in 207 | assert (len' = res_len); 208 | if is_orderless then Array.sort compare args_flat; 209 | args_flat 210 | ) else if can_flatten && is_orderless then ( 211 | CCArray.sorted compare args (* sorted copy *) 212 | ) else args 213 | in 214 | begin match hd, new_args with 215 | | Const c, [| arg |] when Cst.get_field field_one_identity c -> 216 | arg (* f[x]==x *) 217 | | _ -> 218 | App (hd, new_args) 219 | end 220 | 221 | (** {2 Comparisons} *) 222 | 223 | let rec equal a b = match a, b with 224 | | Z n1, Z n2 -> Z.equal n1 n2 225 | | Z z, Q q 226 | | Q q, Z z -> Q.equal q (Q.of_bigint z) 227 | | Q n1, Q n2 -> Q.equal n1 n2 228 | | String s1, String s2 -> s1=s2 229 | | Const c1, Const c2 -> Cst.equal c1 c2 230 | | App (f1,a1), App (f2,a2) -> 231 | Array.length a1=Array.length a2 && 232 | equal f1 f2 && 233 | CCArray.equal equal a1 a2 234 | | Reg i, Reg j when i=j -> true 235 | | Z _, _ | Q _, _ | String _, _ | Const _, _ | App _, _ | Reg _, _ 236 | -> false 237 | 238 | (* hash up to a given depth *) 239 | let rec hash_limit n t = 240 | if n=0 then 0x42 241 | else match t with 242 | | Reg i -> Hash.int i 243 | | Z n -> Z.hash n 244 | | Q n -> Q.to_string n |> Hash.string 245 | | String s -> Hash.string s 246 | | Const c -> Cst.hash c 247 | | App (f, a) -> 248 | Hash.combine3 0x11 249 | (hash_limit (n-1) f) 250 | (Hash.array (hash_limit (n-1)) a) 251 | 252 | let hash t = hash_limit 5 t 253 | 254 | module As_key = struct 255 | type t = expr 256 | let equal = equal 257 | let hash = hash 258 | let compare = compare 259 | end 260 | 261 | module Tbl = CCHashtbl.Make(As_key) 262 | module Map = CCMap.Make(As_key) 263 | module Set = CCSet.Make(As_key) 264 | 265 | (** {2 IO} *) 266 | 267 | let rec pp_full_form out (t:t) = match t with 268 | | Const {cst_name; _} -> Format.pp_print_string out cst_name 269 | | App (head, args) -> 270 | Format.fprintf out "@[<2>%a[@[%a@]]@]" 271 | pp_full_form head (Fmt.array ~sep:Fmt.(return ",@,") pp_full_form) args 272 | | Z n -> Z.pp_print out n 273 | | Q n -> Q.pp_print out n 274 | | String s -> Format.fprintf out "%S" s 275 | | Reg i -> Format.fprintf out "Reg[%d]" i 276 | 277 | let to_string_compact t = 278 | let buf = Buffer.create 32 in 279 | let rec aux t = match t with 280 | | Const {cst_name; _} -> Buffer.add_string buf cst_name 281 | | App (head, args) -> 282 | aux head; 283 | Buffer.add_char buf '['; 284 | Array.iteri 285 | (fun i t' -> 286 | if i>0 then Buffer.add_char buf ','; 287 | aux t') 288 | args; 289 | Buffer.add_char buf ']'; 290 | | Z n -> Z.bprint buf n 291 | | Q n -> Q.bprint buf n 292 | | String s -> 293 | Buffer.add_char buf '"'; 294 | Buffer.add_string buf (String.escaped s); 295 | Buffer.add_char buf '"'; 296 | | Reg _ -> assert false 297 | in 298 | aux t; 299 | Buffer.contents buf 300 | 301 | let pp out (t:t) = 302 | let rec pp prec out t = match t with 303 | | App (Const {cst_name="FullForm";_}, [|t|]) -> pp_full_form out t 304 | | Const ({cst_printer=Some (_, pp_special); _} as c) 305 | | App (Const ({cst_printer=Some (_, pp_special); _} as c), [||]) -> 306 | pp_const_custom pp_special c [||] out () 307 | | App (Const ({cst_printer=Some (prec', pp_special); _} as c), args) -> 308 | if prec' > prec 309 | then pp_const_custom pp_special c args out () 310 | else Fmt.within "(" ")" (pp_const_custom pp_special c args) out () 311 | | Const {cst_name; _} -> Format.pp_print_string out cst_name 312 | | App (head, args) -> pp_default out (head, args) 313 | | Z n -> Z.pp_print out n 314 | | Q n -> Q.pp_print out n 315 | | String s -> Format.fprintf out "%S" s 316 | | Reg i -> Format.fprintf out "Reg[%d]" i 317 | and pp_default out (head, args) = 318 | Format.fprintf out "@[<2>%a[@[%a@]]@]" 319 | (pp 0) head (Fmt.array ~sep:Fmt.(return ",@,") (pp 0)) args 320 | and pp_const_custom pp_special c args out () = 321 | try pp_special c pp out args 322 | with Print_default -> 323 | if args=[||] 324 | then Format.pp_print_string out c.cst_name 325 | else pp_default out (const c, args) 326 | in 327 | begin match t with 328 | | Const {cst_name="Null";_} -> () (* do not print toplevel "null" *) 329 | | _ -> pp 0 out t 330 | end 331 | 332 | let to_string t = Fmt.to_string pp t 333 | 334 | exception Parse_error of string 335 | let parse_error msg = raise (Parse_error msg) 336 | let parse_errorf msg = CCFormat.ksprintf ~f:parse_error msg 337 | 338 | let parse_full_form lexbuf: t = 339 | let open Lexer_full_form in 340 | let r = ref (token lexbuf) in 341 | let junk() = r := token lexbuf in 342 | let rec parse_top () = match !r with 343 | | T_EOI -> parse_error "unexpected EOI" 344 | | T_OPEN -> parse_error "unexpected `[`" 345 | | T_CLOSE -> parse_error "unexpected `]`" 346 | | T_COMMA -> parse_error "unexpected `,`" 347 | | T_STRING s -> junk(); string s 348 | | T_INT n -> junk(); z (Z.of_string n) 349 | | T_RAT n -> junk(); q (Q.of_string n) 350 | | T_ATOM x -> 351 | let t = const_of_string x in 352 | junk(); 353 | parse_applications t 354 | 355 | and parse_applications f = 356 | match !r with 357 | | T_OPEN -> 358 | junk(); 359 | let l = parse_list [] in 360 | parse_applications (app_l f l) 361 | | T_EOI | T_CLOSE | T_COMMA -> f 362 | | T_ATOM _ -> parse_errorf "unexpected atom after `%a`" pp_full_form f 363 | | T_INT _ -> parse_errorf "unexpected integer after `%a`" pp_full_form f 364 | | T_RAT _ -> parse_errorf "unexpected rational after `%a`" pp_full_form f 365 | | T_STRING _ -> parse_errorf "unexpected string after `%a`" pp_full_form f 366 | 367 | and parse_list acc = match !r with 368 | | T_CLOSE -> junk(); List.rev acc 369 | | T_EOI -> parse_errorf "unexpected EOI" 370 | | T_COMMA -> parse_errorf "unexpected comma" 371 | | _ -> 372 | let t = parse_top () in 373 | match !r with 374 | | T_CLOSE -> junk(); List.rev (t::acc) 375 | | T_COMMA -> junk(); parse_list (t :: acc) 376 | | _ -> parse_error "was expecting a comma" 377 | in 378 | parse_top () 379 | 380 | let of_string_full_form_exn s = 381 | let lexbuf = Lexing.from_string s in 382 | parse_full_form lexbuf 383 | 384 | let of_string_full_form s = 385 | try Result.Ok (of_string_full_form_exn s) 386 | with e -> Result.Error (Printexc.to_string e) 387 | 388 | 389 | -------------------------------------------------------------------------------- /src/core/Expr.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Expressions} 5 | 6 | The main data structure *) 7 | 8 | module Properties = Base_types.Properties 9 | 10 | val field_protected : Properties.field 11 | (** Cannot modify the evaluation function of this constant *) 12 | 13 | val field_builtin : Properties.field (* builtin symbol *) 14 | val field_hold_all : Properties.field 15 | val field_hold_first : Properties.field 16 | val field_hold_rest : Properties.field 17 | val field_orderless : Properties.field 18 | val field_no_flatten : Properties.field (* no flatten of arguments, even sequence *) 19 | val field_flatten : Properties.field 20 | val field_one_identity : Properties.field 21 | val field_listable : Properties.field (* thread through lists *) 22 | val field_no_duplicates : Properties.field (* no duplicate arguments *) 23 | 24 | (* (partial) definition of a symbol *) 25 | type def = Base_types.def 26 | 27 | type rewrite_rule = Base_types.rewrite_rule 28 | 29 | type const = Base_types.const = { 30 | cst_name: string; 31 | cst_id: int; 32 | mutable cst_properties: Properties.t; 33 | mutable cst_rules: def list; 34 | mutable cst_doc: Document.t; 35 | mutable cst_printer: (int * const_printer) option; 36 | mutable cst_display : mime_printer option; 37 | } 38 | 39 | and t = Base_types.expr = 40 | | Const of const 41 | | App of t * t array 42 | | Z of Z.t 43 | | Q of Q.t 44 | | String of string 45 | | Reg of int 46 | 47 | (* custom printer for a constant *) 48 | and const_printer = 49 | Base_types.const -> (int -> t CCFormat.printer) -> t array CCFormat.printer 50 | 51 | and mime_content = Base_types.mime_content = { 52 | mime_ty: string; 53 | mime_data: string; 54 | mime_base64: bool; 55 | } 56 | 57 | (* custom display for expressions *) 58 | and mime_printer = t -> mime_content list 59 | 60 | exception Print_default 61 | (** Used in {!const_printer} to indicate that default printing should be preferred *) 62 | 63 | type prim_fun_args = Base_types.prim_fun_args 64 | 65 | type prim_fun = prim_fun_args -> t -> t option 66 | (** takes a context for loading variables, a term [t], return [Some t'] 67 | if it reduces [t] to [t'] *) 68 | 69 | (** {2 Basics} *) 70 | 71 | val const : const -> t 72 | 73 | val const_of_string : string -> t 74 | 75 | val const_of_string_with : f:(const -> unit) -> string -> t 76 | 77 | val z : Z.t -> t 78 | 79 | val q : Q.t -> t 80 | 81 | val string : string -> t 82 | 83 | val of_int : int -> t 84 | 85 | val of_int_ratio : int -> int -> t 86 | 87 | val of_float : float -> t 88 | 89 | val app : t -> t array -> t 90 | 91 | val app_flatten : t -> t array -> t 92 | (** Same as {!app}, but "inlines" arguments of the shape [Flatten[x1...xn]] 93 | into the list of arguments *) 94 | 95 | val app_l : t -> t list -> t 96 | 97 | val equal : t -> t -> bool 98 | (** Syntactic deep equality ("SameQ") *) 99 | 100 | val compare : t -> t -> int 101 | (** Syntactic ordering, compatible with {!equal} *) 102 | 103 | val hash : t -> int 104 | (** Hash *) 105 | 106 | module Tbl : CCHashtbl.S with type key = t 107 | module Map : CCMap.S with type key = t 108 | module Set : CCSet.S with type elt = t 109 | 110 | (** {2 Constants} *) 111 | 112 | exception No_head 113 | 114 | val head : t -> const 115 | (** Head constant. 116 | @raise No_head if the head is a primitive (int,rat,string) *) 117 | 118 | module Cst : sig 119 | type t = const 120 | 121 | val equal : t -> t -> bool 122 | 123 | val hash : t -> int 124 | 125 | val set_field : Properties.field -> bool -> t -> unit 126 | 127 | val get_field : Properties.field -> t -> bool 128 | 129 | val add_def : def -> t -> unit 130 | 131 | val clear_defs : t -> unit 132 | (** remove all definitions *) 133 | 134 | val set_printer : int -> const_printer -> t -> unit 135 | 136 | val set_display : mime_printer -> t -> unit 137 | 138 | val set_doc : Document.t -> t -> unit 139 | 140 | val get_doc : t -> Document.t 141 | 142 | val complete : string -> t list 143 | end 144 | 145 | val null : t 146 | 147 | (** {2 IO} *) 148 | 149 | val pp_full_form : t CCFormat.printer 150 | (** Printer without any fancy display, just serialize the raw structure *) 151 | 152 | val to_string_compact : t -> string 153 | (** Compact, easy to parser display using FullForm *) 154 | 155 | val pp : t CCFormat.printer 156 | (** Nice printer *) 157 | 158 | val to_string : t -> string 159 | (** Nice multi-line printer using {!pp} *) 160 | 161 | exception Parse_error of string 162 | 163 | val of_string_full_form : string -> (t, string) Result.result 164 | (** parse the given string into a term, in the fullform syntax, 165 | or return [Error msg] *) 166 | 167 | val of_string_full_form_exn : string -> t 168 | (** Unsafe version of {!of_string_full_form}. 169 | @raise Parse_error if it cannot parse *) 170 | 171 | (**/**) 172 | val reg : int -> t 173 | (**/**) 174 | -------------------------------------------------------------------------------- /src/core/Hash.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | type 'a t = 'a -> int 5 | 6 | let bool b = if b then 1 else 2 7 | 8 | let int i = i land max_int 9 | 10 | let string (s:string) = Hashtbl.hash s 11 | 12 | let combine f a b = Hashtbl.seeded_hash a (f b) 13 | 14 | let combine2 a b = Hashtbl.seeded_hash a b 15 | 16 | let combine3 a b c = 17 | combine2 a b 18 | |> combine2 c 19 | 20 | let combine4 a b c d = 21 | combine2 a b 22 | |> combine2 c 23 | |> combine2 d 24 | 25 | let pair f g (x,y) = combine2 (f x) (g y) 26 | 27 | let opt f = function 28 | | None -> 42 29 | | Some x -> combine2 43 (f x) 30 | 31 | let list f l = List.fold_left (combine f) 0x42 l 32 | let array f l = Array.fold_left (combine f) 0x42 l 33 | let seq f seq = 34 | let h = ref 0x43 in 35 | seq (fun x -> h := combine f !h x); 36 | !h 37 | 38 | let poly x = Hashtbl.hash x 39 | -------------------------------------------------------------------------------- /src/core/Hash.mli: -------------------------------------------------------------------------------- 1 | (* This file is free software. See file "license" for more details. *) 2 | 3 | type 'a t = 'a -> int 4 | 5 | val bool : bool t 6 | val int : int t 7 | val string : string t 8 | val combine : 'a t -> int -> 'a -> int 9 | 10 | val pair : 'a t -> 'b t -> ('a * 'b) t 11 | 12 | val opt : 'a t -> 'a option t 13 | val list : 'a t -> 'a list t 14 | val array : 'a t -> 'a array t 15 | val seq : 'a t -> 'a Iter.t t 16 | 17 | val combine2 : int -> int -> int 18 | val combine3 : int -> int -> int -> int 19 | val combine4 : int -> int -> int -> int -> int 20 | 21 | val poly : 'a t 22 | (** the regular polymorphic hash function *) 23 | -------------------------------------------------------------------------------- /src/core/Lexer.mll: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | { 5 | open Parser (* tokens *) 6 | 7 | let cntspace b = 8 | let s = Lexing.lexeme b in 9 | CCString.iter (fun c -> if c='\n' then Lexing.new_line b) s 10 | 11 | let slot_int s = 12 | assert (s.[0] = '#'); 13 | if String.length s>1 14 | then if s.[1] = '#' then 0 else int_of_string (String.sub s 1 1) 15 | else 1 (* default *) 16 | } 17 | 18 | let comment_body = [ ^ '*' ] | ('*' [^ ')']) 19 | let comment = "(*" comment_body* "*)" 20 | 21 | let quoted_string_char = [^ '"' '\\' ] | "\\\\" | "\\\"" 22 | let quoted_string = '"' quoted_string_char* '"' 23 | 24 | let zero_numeric = '0' 25 | let non_zero_numeric = ['1' - '9'] 26 | let numeric = ['0' - '9'] 27 | 28 | let dot_decimal = '.' numeric + 29 | let positive_decimal = non_zero_numeric numeric* 30 | let decimal = zero_numeric | positive_decimal 31 | let unsigned_integer = decimal 32 | let signed_integer = '-' unsigned_integer 33 | let integer = signed_integer | unsigned_integer 34 | 35 | let decimal_fraction = decimal dot_decimal 36 | let unsigned_rational = decimal '/' positive_decimal 37 | let signed_rational = '-' unsigned_rational 38 | let rational = signed_rational | unsigned_rational 39 | 40 | let lower_alpha = ['a' - 'z'] 41 | let upper_alpha = ['A' - 'Z'] 42 | let alpha_numeric = lower_alpha | upper_alpha | numeric | '_' 43 | let symbol = (lower_alpha | upper_alpha) (lower_alpha | upper_alpha | numeric)* 44 | 45 | let slot = '#' ['0' - '9' '#']? 46 | 47 | let space = ['\n' '\t' ' '] | comment 48 | 49 | rule token = parse 50 | | space* eof { cntspace lexbuf; EOI } 51 | | rational { RAT_LIT (Lexing.lexeme lexbuf) } 52 | | integer { INT_LIT (Lexing.lexeme lexbuf) } 53 | | quoted_string { STRING_LIT (Lexing.lexeme lexbuf) } 54 | | space+ { cntspace lexbuf; SPACE } 55 | | '[' space* { cntspace lexbuf; LEFT_BRACKET } 56 | | space* ']' { cntspace lexbuf; RIGHT_BRACKET } 57 | | '(' space* { cntspace lexbuf; LEFT_PAREN } 58 | | space* ')' { cntspace lexbuf; RIGHT_PAREN } 59 | | '{' space* { cntspace lexbuf; LEFT_BRACE } 60 | | space* '}' { cntspace lexbuf; RIGHT_BRACE } 61 | | space* "&" space* { cntspace lexbuf; ANCHOR } 62 | | space* ',' space* { cntspace lexbuf; COMMA } 63 | | space* ":=" space* { cntspace lexbuf; O_SET_DELAYED } 64 | | space* "=" space* { cntspace lexbuf; O_SET } 65 | | space* "===" space* { cntspace lexbuf; O_SAME_Q } 66 | | space* ":=" space* { cntspace lexbuf; O_SET_DELAYED } 67 | | space* "->" space* { cntspace lexbuf; O_RULE } 68 | | space* ":>" space* { cntspace lexbuf; O_RULE_DELAYED } 69 | | space* "|" space* { cntspace lexbuf; O_ALTERNATIVE } 70 | | space* '!' { cntspace lexbuf; O_BANG } 71 | | space* "||" space* { cntspace lexbuf; O_OR } 72 | | space* "&&" space* { cntspace lexbuf; O_AND } 73 | | space* "/." space* { cntspace lexbuf; O_REPLACE_ALL } 74 | | space* "//." space* { cntspace lexbuf; O_REPLACE_REPEATED } 75 | | space* "/;" space* { cntspace lexbuf; O_CONDITION } 76 | | space* "?" space* { cntspace lexbuf; O_TEST } 77 | | ':' { O_PATTERN } 78 | | space* ';' space* { cntspace lexbuf; O_SEMI_COLON } 79 | | space* '+' space* { cntspace lexbuf; O_PLUS } 80 | | space* '/' space* { cntspace lexbuf; O_DIV } 81 | | space* '^' space* { cntspace lexbuf; O_POWER } 82 | | space* "<-" space* { cntspace lexbuf; O_MATCH_BIND } 83 | | space* "<<-" space* { cntspace lexbuf; O_MATCH_BIND1 } 84 | | space* "::" space* { cntspace lexbuf; O_COMPREHENSION } 85 | | space* "==" space* { cntspace lexbuf; O_EQUAL } 86 | | space* "!=" space* { cntspace lexbuf; O_NOT_EQUAL } 87 | | space* "<" space* { cntspace lexbuf; O_LESS } 88 | | space* "<=" space* { cntspace lexbuf; O_LESS_EQUAL } 89 | | space* ">" space* { cntspace lexbuf; O_GREATER } 90 | | space* ">=" space* { cntspace lexbuf; O_GREATER_EQUAL } 91 | | "___" { O_BLANK_NULL_SEQ } 92 | | "__" { O_BLANK_SEQ } 93 | | "_" { O_BLANK } 94 | | symbol { SYMBOL (Lexing.lexeme lexbuf) } 95 | | slot { SLOT (Lexing.lexeme lexbuf |> slot_int) } 96 | | _ as c 97 | { Parse_loc.parse_errorf_buf lexbuf "lexer failed on char '%c'" c } 98 | -------------------------------------------------------------------------------- /src/core/Lexer_full_form.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | type token = 5 | | T_EOI 6 | | T_OPEN 7 | | T_CLOSE 8 | | T_COMMA 9 | | T_INT of string 10 | | T_RAT of string 11 | | T_STRING of string 12 | | T_ATOM of string 13 | 14 | val token : Lexing.lexbuf -> token 15 | -------------------------------------------------------------------------------- /src/core/Lexer_full_form.mll: -------------------------------------------------------------------------------- 1 | 2 | 3 | (* This file is free software. See file "license" for more details. *) 4 | 5 | { 6 | type token = 7 | | T_EOI 8 | | T_OPEN 9 | | T_CLOSE 10 | | T_COMMA 11 | | T_INT of string 12 | | T_RAT of string 13 | | T_STRING of string 14 | | T_ATOM of string 15 | } 16 | 17 | let quoted_string_char = [^ '"' '\\' ] | "\\\\" | "\\\"" 18 | let quoted_string = '"' quoted_string_char* '"' 19 | 20 | let zero_numeric = '0' 21 | let non_zero_numeric = ['1' - '9'] 22 | let numeric = ['0' - '9'] 23 | 24 | let dot_decimal = '.' numeric + 25 | let positive_decimal = non_zero_numeric numeric* 26 | let decimal = zero_numeric | positive_decimal 27 | let unsigned_integer = decimal 28 | let signed_integer = '-' unsigned_integer 29 | let integer = signed_integer | unsigned_integer 30 | 31 | let decimal_fraction = decimal dot_decimal 32 | let unsigned_rational = decimal '/' positive_decimal 33 | let signed_rational = '-' unsigned_rational 34 | let rational = signed_rational | unsigned_rational 35 | 36 | let lower_alpha = ['a' - 'z'] 37 | let upper_alpha = ['A' - 'Z'] 38 | let alpha_numeric = lower_alpha | upper_alpha | numeric | '_' 39 | let symbol = (lower_alpha | upper_alpha) (lower_alpha | upper_alpha | numeric)* 40 | 41 | let space = ['\n' '\t' ' '] 42 | 43 | rule token = parse 44 | | space { token lexbuf } 45 | | eof { T_EOI } 46 | | rational { T_RAT (Lexing.lexeme lexbuf) } 47 | | integer { T_INT (Lexing.lexeme lexbuf) } 48 | | quoted_string { T_STRING (Lexing.lexeme lexbuf) } 49 | | ',' { T_COMMA } 50 | | '[' { T_OPEN } 51 | | ']' { T_CLOSE } 52 | | symbol { T_ATOM (Lexing.lexeme lexbuf) } 53 | | _ as c 54 | { Parse_loc.parse_errorf_buf lexbuf "lexer failed on char '%c'" c } 55 | -------------------------------------------------------------------------------- /src/core/Parse_loc.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Location in a file} *) 5 | 6 | type t = { 7 | file : string; 8 | start_line : int; 9 | start_column : int; 10 | stop_line : int; 11 | stop_column : int; 12 | } 13 | 14 | let mk file start_line start_column stop_line stop_column = 15 | { file; start_line; start_column; stop_line; stop_column; } 16 | 17 | let mk_pair file (a,b)(c,d) = mk file a b c d 18 | 19 | let mk_pos start stop = 20 | let open Lexing in 21 | mk 22 | start.pos_fname 23 | start.pos_lnum (start.pos_cnum - start.pos_bol) 24 | stop.pos_lnum (stop.pos_cnum - stop.pos_bol) 25 | 26 | let equal = (=) 27 | let hash : t -> int = CCHash.poly 28 | 29 | let _min_pos (l1,c1) (l2,c2) = 30 | if l1 = l2 31 | then l1, min c1 c2 32 | else if l1 < l2 33 | then l1, c1 34 | else l2, c2 35 | 36 | let _max_pos (l1,c1) (l2,c2) = 37 | if l1 = l2 38 | then l1, max c1 c2 39 | else if l1 < l2 40 | then l2, c2 41 | else l1, c1 42 | 43 | let combine p1 p2 = 44 | let start_line, start_column = 45 | _min_pos (p1.start_line, p1.start_column) (p2.start_line, p2.start_column) 46 | in 47 | let stop_line, stop_column = 48 | _max_pos (p1.stop_line, p1.stop_column) (p2.stop_line, p2.stop_column) 49 | in 50 | { file=p1.file; start_line; start_column; stop_line; stop_column; } 51 | 52 | let rec combine_list l = match l with 53 | | [] -> raise (Invalid_argument "Location.combine_list") 54 | | [p] -> p 55 | | p1::((_ ::_) as l') -> 56 | let p' = combine_list l' in 57 | combine p1 p' 58 | 59 | let smaller p ~than = 60 | (p.start_line > than.start_line 61 | || (p.start_line = than.start_line && p.start_column >= than.start_column)) 62 | && 63 | (p.stop_line < than.stop_line 64 | || (p.stop_line = than.stop_line && p.stop_column <= than.stop_column)) 65 | 66 | let pp out pos = 67 | if pos.start_line = pos.stop_line 68 | then 69 | Format.fprintf out "file '%s': line %d, col %d to %d" 70 | pos.file pos.start_line pos.start_column pos.stop_column 71 | else 72 | Format.fprintf out "file '%s': line %d, col %d to line %d, col %d" 73 | pos.file 74 | pos.start_line pos.start_column 75 | pos.stop_line pos.stop_column 76 | 77 | let to_string = CCFormat.to_string pp 78 | 79 | let pp_opt out = function 80 | | None -> Format.fprintf out "" 81 | | Some pos -> pp out pos 82 | 83 | let to_string_opt = CCFormat.to_string pp_opt 84 | 85 | (** {2 Lexbuf} *) 86 | 87 | let set_file buf filename = 88 | let open Lexing in 89 | buf.lex_curr_p <- {buf.lex_curr_p with pos_fname=filename;}; 90 | () 91 | 92 | let get_file buf = 93 | let open Lexing in 94 | buf.lex_curr_p.pos_fname 95 | 96 | let of_lexbuf lexbuf = 97 | let start = Lexing.lexeme_start_p lexbuf in 98 | let end_ = Lexing.lexeme_end_p lexbuf in 99 | let s_l = start.Lexing.pos_lnum in 100 | let s_c = start.Lexing.pos_cnum - start.Lexing.pos_bol in 101 | let e_l = end_.Lexing.pos_lnum in 102 | let e_c = end_.Lexing.pos_cnum - end_.Lexing.pos_bol in 103 | let file = start.Lexing.pos_fname in 104 | mk file s_l s_c e_l e_c 105 | 106 | (** {2 Error} *) 107 | 108 | exception Parse_error of t * string 109 | 110 | let () = Printexc.register_printer 111 | (function 112 | | Parse_error (loc, msg) -> 113 | Some (CCFormat.sprintf "parse error at %a:@ %s" pp loc msg) 114 | | _ -> None) 115 | 116 | let parse_error loc msg = raise (Parse_error (loc, msg)) 117 | 118 | let parse_errorf loc msg = 119 | CCFormat.ksprintf ~f:(parse_error loc) msg 120 | 121 | let parse_error_buf lexbuf msg = 122 | let loc = of_lexbuf lexbuf in 123 | parse_error loc msg 124 | 125 | let parse_errorf_buf lexbuf msg = 126 | CCFormat.ksprintf ~f:(parse_error_buf lexbuf) msg 127 | -------------------------------------------------------------------------------- /src/core/Parse_loc.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Location in a file} *) 5 | 6 | (** {2 Location} *) 7 | 8 | type t = { 9 | file : string; 10 | start_line : int; 11 | start_column : int; 12 | stop_line : int; 13 | stop_column : int; 14 | } 15 | 16 | val mk : string -> int -> int -> int -> int -> t 17 | 18 | val mk_pair : string -> (int * int) -> (int * int) -> t 19 | 20 | val mk_pos : Lexing.position -> Lexing.position -> t 21 | (** Use the two positions of lexbufs. The file of the first lexbuf is used *) 22 | 23 | val combine : t -> t -> t 24 | (** Position that spans the two given positions. The file is assumed to be 25 | the same in both case, and is chosen from one of the two positions. *) 26 | 27 | val combine_list : t list -> t 28 | (** N-ary version of {!combine}. 29 | @raise Invalid_argument if the list is empty *) 30 | 31 | val smaller : t -> than:t -> bool 32 | (** [smaller p ~than] is true if [p] is included in [than], ie 33 | [p] is a sub-location of [than] (interval inclusion) *) 34 | 35 | val pp : t CCFormat.printer 36 | 37 | val to_string : t -> string 38 | 39 | val pp_opt : t option CCFormat.printer 40 | 41 | val to_string_opt : t option -> string 42 | 43 | (** {2 Lexbuf} 44 | 45 | Utils to set/get the file in a lexbuf *) 46 | 47 | val set_file : Lexing.lexbuf -> string -> unit 48 | (** Change the file name used for positions in this lexbuf *) 49 | 50 | val get_file : Lexing.lexbuf -> string 51 | (** Obtain the filename *) 52 | 53 | val of_lexbuf : Lexing.lexbuf -> t 54 | (** Recover a position from a lexbuf *) 55 | 56 | (** {2 Error} *) 57 | 58 | exception Parse_error of t * string 59 | 60 | val parse_error : t -> string -> _ 61 | 62 | val parse_errorf : t -> ('a, Format.formatter, unit, 'b) format4 -> 'a 63 | 64 | val parse_error_buf : Lexing.lexbuf -> string -> _ 65 | 66 | val parse_errorf_buf : Lexing.lexbuf -> ('a, Format.formatter, unit, 'b) format4 -> 'a 67 | -------------------------------------------------------------------------------- /src/core/Parser.mly: -------------------------------------------------------------------------------- 1 | 2 | 3 | %{ 4 | (* This file is free software. See file "license" for more details. *) 5 | 6 | (** Main parser *) 7 | 8 | module L = Parse_loc 9 | module E = Expr 10 | module B = Builtins 11 | 12 | (* remove quote from some symbols *) 13 | let remove_quotes s = 14 | assert (s.[0] = '"' && s.[String.length s - 1] = '"'); 15 | String.sub s 1 (String.length s - 2) 16 | %} 17 | 18 | %token EOI 19 | 20 | %token LEFT_BRACKET 21 | %token RIGHT_BRACKET 22 | %token LEFT_PAREN 23 | %token RIGHT_PAREN 24 | %token LEFT_BRACE 25 | %token RIGHT_BRACE 26 | %token COMMA 27 | %token SPACE 28 | 29 | %token SLOT 30 | %token ANCHOR 31 | 32 | %token SYMBOL 33 | %token STRING_LIT 34 | %token INT_LIT 35 | %token RAT_LIT 36 | 37 | %token O_ALTERNATIVE 38 | 39 | %token O_SET 40 | %token O_SET_DELAYED 41 | %token O_RULE 42 | %token O_RULE_DELAYED 43 | %token O_REPLACE_ALL 44 | %token O_REPLACE_REPEATED 45 | %token O_PATTERN 46 | %token O_CONDITION 47 | %token O_TEST 48 | %token O_BLANK 49 | %token O_BLANK_SEQ 50 | %token O_BLANK_NULL_SEQ 51 | %token O_SAME_Q 52 | %token O_SEMI_COLON 53 | 54 | %token O_MATCH_BIND 55 | %token O_MATCH_BIND1 56 | %token O_COMPREHENSION 57 | 58 | %token O_PLUS 59 | %token O_DIV 60 | %token O_POWER 61 | 62 | %token O_EQUAL 63 | %token O_NOT_EQUAL 64 | %token O_LESS 65 | %token O_LESS_EQUAL 66 | %token O_GREATER 67 | %token O_GREATER_EQUAL 68 | 69 | %token O_AND 70 | %token O_OR 71 | %token O_BANG 72 | 73 | %start parse_expr 74 | 75 | %% 76 | 77 | skip_space: 78 | | {} 79 | | SPACE {} 80 | 81 | parse_expr: e=expr EOI { e } 82 | 83 | expr: skip_space e=expr_nospace skip_space { e } 84 | 85 | expr_nospace: 86 | | e=comprehension_expr { e } 87 | | error 88 | { 89 | let loc = L.mk_pos $startpos $endpos in 90 | Parse_loc.parse_error loc "expected expression" } 91 | 92 | comprehension_expr: 93 | | e=compound_expr { e } 94 | | e=compound_expr 95 | O_COMPREHENSION 96 | l=separated_nonempty_list(COMMA, set_expr) 97 | { E.app_l B.comprehension (e::l) } 98 | 99 | compound_expr: 100 | | e=set_expr { e } 101 | | e=set_expr O_SEMI_COLON l=separated_nonempty_list(O_SEMI_COLON, compound_expr_elt) 102 | { E.app_l B.compound_expr (e::l) } 103 | 104 | compound_expr_elt: 105 | | { B.null } 106 | | e=set_expr { e } 107 | 108 | set_expr: 109 | | e = set_expr_rhs { e } 110 | | a=pattern_expr O_SET b=set_expr_rhs 111 | { E.app_l B.assign [a;b] } 112 | | a=pattern_expr O_SET_DELAYED b=set_expr_rhs 113 | { E.app_l B.assign_delayed [a;b] } 114 | | a=pattern_expr O_MATCH_BIND b=set_expr_rhs 115 | { E.app_l B.match_bind [a;b] } 116 | | a=pattern_expr O_MATCH_BIND1 b=set_expr_rhs 117 | { E.app_l B.match_bind1 [a;b] } 118 | 119 | set_expr_rhs: 120 | | e=replace_expr { e } 121 | | e=rule_expr { e } 122 | | e=pattern_expr { e } 123 | 124 | replace_expr: 125 | | a=pattern_expr O_REPLACE_ALL b=set_expr_rhs 126 | { E.app_l B.replace_all [a;b] } 127 | | a=pattern_expr O_REPLACE_REPEATED b=set_expr_rhs 128 | { E.app_l B.replace_repeated [a;b] } 129 | 130 | rule_expr: 131 | | a=pattern_expr O_RULE b=set_expr_rhs 132 | { E.app_l B.rule [a;b] } 133 | | a=pattern_expr O_RULE_DELAYED b=set_expr_rhs 134 | { E.app_l B.rule_delayed [a;b] } 135 | 136 | pattern_expr: 137 | | e=alternative_expr { e } 138 | | x=SYMBOL O_PATTERN e=alternative_expr 139 | { E.app_l B.pattern [E.const_of_string x; e] } 140 | | a=pattern_expr O_CONDITION b=same_expr 141 | { E.app_l B.condition [a;b] } 142 | 143 | alternative_expr: 144 | | a=fun_expr { a } 145 | | a=fun_expr O_ALTERNATIVE 146 | b=separated_nonempty_list(O_ALTERNATIVE,fun_expr) 147 | { E.app_l B.alternatives (a::b) } 148 | 149 | fun_expr: 150 | | e=same_expr { e } 151 | | e=same_expr ANCHOR { E.app B.function_ [| e |] } 152 | 153 | same_expr: 154 | | e=or_expr { e } 155 | | a=or_expr O_SAME_Q b=separated_nonempty_list(O_SAME_Q, or_expr) 156 | { E.app_l B.same_q (a::b) } 157 | 158 | or_expr: 159 | | e=and_expr { e } 160 | | a=and_expr O_OR b=separated_nonempty_list(O_OR, and_expr) 161 | { E.app_l B.or_ (a::b) } 162 | 163 | and_expr: 164 | | e=not_expr { e } 165 | | a=not_expr O_AND b=separated_nonempty_list(O_AND, not_expr) 166 | { E.app_l B.and_ (a::b) } 167 | 168 | not_expr: 169 | | e=ineq_expr { e } 170 | | O_BANG skip_space e=not_expr { E.app_l B.not_ [e] } 171 | 172 | %inline ineq_op: 173 | | O_EQUAL { B.equal } 174 | | O_NOT_EQUAL { B.not_equal } 175 | | O_LESS { B.less } 176 | | O_LESS_EQUAL { B.less_equal } 177 | | O_GREATER { B.greater } 178 | | O_GREATER_EQUAL { B.greater_equal } 179 | 180 | ineq_expr: 181 | | l=ineq_expr_l 182 | { match l with 183 | | [] -> assert false 184 | | [e] -> e 185 | | l -> E.app_l B.inequality (List.rev l) } 186 | 187 | ineq_expr_l: 188 | | e=sum_expr { [e] } 189 | | a=ineq_expr_l op=ineq_op b=sum_expr { b :: op :: a } 190 | 191 | sum_expr: 192 | | e=prod_expr { e } 193 | | a=prod_expr 194 | O_PLUS 195 | l=separated_nonempty_list(O_PLUS,prod_expr) 196 | { E.app_l B.plus (a::l) } 197 | 198 | prod_expr: 199 | | l=prod_expr_l 200 | { match l with 201 | | [] -> assert false 202 | | [e] -> e 203 | | _ -> E.app_l B.times l } 204 | 205 | prod_expr_l: 206 | | e=power_expr { [e] } 207 | | a=power_expr SPACE b=prod_expr_l { a::b } 208 | 209 | power_expr: 210 | | e=div_expr { e } 211 | | e=div_expr O_POWER n=app_expr_nospace 212 | { E.app B.power [| e; n |] } 213 | 214 | div_expr: 215 | | e=factorial_expr { e } 216 | | a=factorial_expr O_DIV b=factorial_expr { E.app B.div [| a; b |] } 217 | 218 | factorial_expr: 219 | | e=app_expr_nospace { e } 220 | | e=factorial_expr O_BANG { E.app_l B.factorial [e] } 221 | 222 | app_expr_nospace: 223 | | e=test_expr_nospace { e } 224 | | hd=app_expr_nospace 225 | LEFT_BRACKET 226 | args=separated_list(COMMA,expr) 227 | RIGHT_BRACKET 228 | { E.app_l hd args } 229 | 230 | test_expr_nospace: 231 | | e=atomic_expr_nospace { e } 232 | | e=app_expr_nospace O_TEST t=app_expr_nospace 233 | { E.app B.pattern_test [| e; t |] } 234 | 235 | %inline blank: 236 | | O_BLANK t=SYMBOL { E.app_l B.blank [E.const_of_string t] } 237 | | O_BLANK_SEQ t=SYMBOL { E.app_l B.blank_seq [E.const_of_string t] } 238 | | O_BLANK_NULL_SEQ t=SYMBOL { E.app_l B.blank_null_seq [E.const_of_string t] } 239 | | O_BLANK { E.app_l B.blank [] } 240 | | O_BLANK_SEQ { E.app_l B.blank_seq [] } 241 | | O_BLANK_NULL_SEQ { E.app_l B.blank_null_seq [] } 242 | 243 | atomic_expr_nospace: 244 | | LEFT_PAREN e=expr_nospace RIGHT_PAREN { e } 245 | | LEFT_BRACE l=separated_list(COMMA,expr) RIGHT_BRACE 246 | { E.app_l B.list l } 247 | | a=SYMBOL b=blank 248 | { E.app_l B.pattern [E.const_of_string a; b] } 249 | | n=SLOT { E.app B.slot [| E.z (Z.of_int n) |] } 250 | | b=blank { b } 251 | | t=SYMBOL { E.const_of_string t } 252 | | n=INT_LIT { E.z (Z.of_string n) } 253 | | n=RAT_LIT { E.q (Q.of_string n) } 254 | | s=STRING_LIT { E.string (remove_quotes s) } 255 | 256 | 257 | %% 258 | -------------------------------------------------------------------------------- /src/core/Pattern.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software. See file "license" for more details. *) 2 | 3 | (** {1 Patterns} *) 4 | 5 | include Base_types 6 | 7 | type t = Base_types.pattern 8 | 9 | module E = Expr 10 | module Fmt = CCFormat 11 | 12 | (** {2 IO} *) 13 | 14 | let rec pp out (p:pattern) = match p with 15 | | P_const {cst_name; _} -> Format.pp_print_string out cst_name 16 | | P_app (head, args) -> 17 | Format.fprintf out "@[<2>%a[@[%a@]]@]" 18 | pp head (Fmt.array ~sep:Fmt.(return ",@,") pp) args 19 | | P_app_slice (head, arg) -> 20 | Format.fprintf out "@[<2>%a[@[%a@]]@]" 21 | pp head pp_slice_pattern arg 22 | | P_app_slice_unordered (head, arg) -> 23 | Format.fprintf out "@[<2>%a[@[%a@]]@]" 24 | pp head pp_sup arg 25 | | P_z n -> Z.pp_print out n 26 | | P_q n -> Q.pp_print out n 27 | | P_string s -> Format.fprintf out "%S" s 28 | | P_blank c -> Fmt.fprintf out "Blank[%a]" pp_blank_arg c 29 | | P_blank_sequence c -> Fmt.fprintf out "BlankSequence[%a]" pp_blank_arg c 30 | | P_blank_sequence_null c -> Fmt.fprintf out "BlankNullSequence[%a]" pp_blank_arg c 31 | | P_fail -> Fmt.string out "Fail[]" 32 | | P_alt ([] | [_]) -> assert false 33 | | P_alt l -> 34 | Format.fprintf out "(@[%a@])" 35 | (Fmt.list ~sep:Fmt.(return "|@,") pp) l 36 | | P_bind (i,p) -> Format.fprintf out "Pattern[%d,@[%a@]]" i pp p 37 | | P_check_same (i,p) -> Format.fprintf out "CheckSame[%d,@[%a@]]" i pp p 38 | | P_conditional (p,cond) -> 39 | Format.fprintf out "Condition[@[%a,@,%a@]]" pp p E.pp_full_form cond 40 | | P_test (p,test) -> 41 | Fmt.fprintf out "PatternTest[@[%a,@,%a@]]" pp p E.pp_full_form test 42 | 43 | and pp_blank_arg out = function 44 | | None -> () 45 | | Some {cst_name;_} -> Fmt.string out cst_name 46 | 47 | and pp_slice_pattern out = function 48 | | SP_vantage apv -> 49 | Format.fprintf out "[@[<2>%a,@,vantage(@[%a@]),@,%a@]]" 50 | pp_slice_pattern apv.sp_left 51 | pp apv.sp_vantage pp_slice_pattern apv.sp_right 52 | | SP_pure (l,_) -> 53 | Format.fprintf out "[@[%a@]]" (Fmt.list pp) l 54 | 55 | and pp_sup out = function 56 | | SUP_vantage (p, sub, _) -> 57 | Format.fprintf out "[@[<2>vantage(@[%a@]),@,%a@]]" pp p pp_sup sub 58 | | SUP_pure (l,_) -> 59 | Format.fprintf out "[@[%a@]]" (Fmt.list pp) l 60 | 61 | let pp_binding_seq out (c:binding_seq) = 62 | let pp_body out = function 63 | | Comp_match (pat,e) -> 64 | Format.fprintf out "@[%a@,<-%a@]" 65 | pp pat E.pp_full_form e 66 | | Comp_match1 (pat,e) -> 67 | Format.fprintf out "@[%a@,<<-%a@]" 68 | pp pat E.pp_full_form e 69 | | Comp_test e -> E.pp_full_form out e 70 | in 71 | Format.fprintf out "Comprehension[@[%a,@,@[%a@]@]]" 72 | E.pp_full_form c.comp_yield 73 | (Fmt.list ~sep:Fmt.(return ",@,") pp_body) c.comp_body 74 | 75 | let pp_rule out (r:rewrite_rule): unit = 76 | Format.fprintf out "@[%a @<1>→@ %a@]" pp r.rr_pat E.pp_full_form r.rr_rhs 77 | 78 | let pp_def out = function 79 | | Rewrite r -> pp_rule out r 80 | | Fun _ -> Fmt.string out "" 81 | 82 | (** {2 Compilation} *) 83 | 84 | exception Invalid_rule of string 85 | 86 | let invalid_rule msg = raise (Invalid_rule msg) 87 | let invalid_rulef msg = Fmt.ksprintf msg ~f:invalid_rule 88 | 89 | let rec matches_slice (p:pattern): bool = match p with 90 | | P_blank_sequence _ | P_blank_sequence_null _ -> true 91 | | P_alt l -> List.exists matches_slice l 92 | | P_bind (_, sub_p) 93 | | P_conditional (sub_p, _) 94 | | P_test (sub_p,_) 95 | | P_check_same (_, sub_p) -> matches_slice sub_p 96 | | P_blank _ -> false 97 | | P_q _ | P_z _ | P_string _ | P_app _ | P_const _ | P_fail 98 | | P_app_slice _ | P_app_slice_unordered _ 99 | -> false 100 | 101 | let matches_single p = not (matches_slice p) 102 | 103 | (* 0 or 1, depending on whether the pattern can be Null *) 104 | let rec pat_slice_min_size (p:pattern): int = match p with 105 | | P_blank_sequence _ -> 1 106 | | P_blank_sequence_null _ -> 0 107 | | P_alt [] -> assert false 108 | | P_alt (x::l) -> 109 | List.fold_left (fun n p -> min n (pat_slice_min_size p)) (pat_slice_min_size x) l 110 | | P_bind (_, sub_p) 111 | | P_conditional (sub_p, _) 112 | | P_test (sub_p,_) 113 | | P_check_same (_, sub_p) -> pat_slice_min_size sub_p 114 | | P_blank _ | P_q _ | P_z _ | P_string _ | P_app _ | P_const _ 115 | | P_fail | P_app_slice _ | P_app_slice_unordered _ 116 | -> 1 117 | 118 | let sp_slice_min_size (ap:slice_pattern): int = match ap with 119 | | SP_vantage apv -> apv.sp_min_size 120 | | SP_pure (_,i) -> i 121 | 122 | let sup_slice_min_size (ap:slice_unordered_pattern): int = match ap with 123 | | SUP_vantage (_,_,i) -> i 124 | | SUP_pure (_,i) -> i 125 | 126 | module Pat_compile = struct 127 | type state = { 128 | tbl: (string, int) Hashtbl.t; 129 | (* var name -> register *) 130 | surrounding: string Stack.t; 131 | (* variables bound in superterms, to avoid cyclical substitutions *) 132 | } 133 | 134 | let create() : state = { 135 | tbl = Hashtbl.create 12; 136 | surrounding=Stack.create(); 137 | } 138 | 139 | (* convert [t] into a proper pattern *) 140 | let rec tr_pattern st t = match t with 141 | | Const c -> P_const c 142 | | String s -> P_string s 143 | | Z n -> P_z n 144 | | Q n -> P_q n 145 | | App (Const {cst_name="Blank";_},[||]) -> P_blank None 146 | | App (Const {cst_name="Blank";_},[|Const c|]) -> P_blank (Some c) 147 | | App (Const {cst_name="BlankSequence";_},[||]) -> P_blank_sequence None 148 | | App (Const {cst_name="BlankSequence";_},[|Const c|]) -> P_blank_sequence (Some c) 149 | | App (Const {cst_name="BlankNullSequence";_},[||]) -> P_blank_sequence_null None 150 | | App (Const {cst_name="BlankNullSequence";_},[|Const c|]) -> P_blank_sequence_null (Some c) 151 | | App (Const {cst_name="Pattern";_}, 152 | [| Const {cst_name=x;_}; sub |]) -> 153 | (* [x] on the stack -> failure, would lead to cyclical subst *) 154 | if Iter.of_stack st.surrounding |> Iter.mem x then ( 155 | invalid_rulef "variable `%s` cannot appear in its own pattern" x 156 | ); 157 | (* compute pattern itself *) 158 | let sub_p = match sub with 159 | | App (Const {cst_name="Blank";_}, [||]) -> P_blank None (* trivial case *) 160 | | _ -> 161 | Stack.push x st.surrounding; 162 | CCFun.finally2 ~h:(fun () -> ignore (Stack.pop st.surrounding)) 163 | tr_pattern st sub 164 | in 165 | begin match CCHashtbl.get st.tbl x with 166 | | None -> 167 | (* bind content of sub to [i] *) 168 | let i = Hashtbl.length st.tbl in 169 | Hashtbl.add st.tbl x i; 170 | P_bind (i, sub_p) 171 | | Some i -> 172 | (* already bound, check SameQ *) 173 | P_check_same (i, sub_p) 174 | end 175 | | App (Const {cst_name="Alternatives";_}, [| |]) -> P_fail 176 | | App (Const {cst_name="Alternatives";_}, [| p |]) -> tr_pattern st p 177 | | App (Const {cst_name="Alternatives";_}, a) -> 178 | let l = CCList.init (Array.length a) (fun i -> tr_pattern st a.(i)) in 179 | P_alt l 180 | | App (Const {cst_name="Condition";_}, [| p; cond |]) -> 181 | let p = tr_pattern st p in 182 | let cond = tr_term st cond in (* replace variables, etc. in condition *) 183 | (* TODO: check vars(cond) ⊆ vars(p) *) 184 | P_conditional (p, cond) 185 | | App (Const {cst_name="PatternTest";_}, [| p; test |]) -> 186 | let p = tr_pattern st p in 187 | let test = tr_term st test in 188 | P_test (p, test) 189 | | App (hd, args) -> 190 | let hd_pat = tr_pattern st hd in 191 | let args = Array.map (tr_pattern st) args in 192 | (* TODO: orderless matching is not necessary slice-oriented, 193 | we should mix both *) 194 | begin match hd with 195 | | Const c when E.Cst.get_field E.field_orderless c && args<>[||]-> 196 | (* unordered slice match *) 197 | let sup = sup_of_pats (Array.to_list args) in 198 | P_app_slice_unordered (hd_pat, sup) 199 | | _ when CCArray.exists matches_slice args -> 200 | (* slice match *) 201 | let ap = ap_of_pats (Slice.full args) in 202 | P_app_slice (hd_pat, ap) 203 | | _ -> 204 | (* otherwise, match structurally *) 205 | P_app (hd_pat, args) 206 | end 207 | | Reg _ -> assert false 208 | 209 | (* convert variables in [t] into registers *) 210 | and tr_term st t = match t with 211 | | Z _ | Q _ | String _ -> t 212 | | App (hd, args) -> 213 | let hd = tr_term st hd in 214 | let args = Array.map (tr_term st) args in 215 | E.app hd args 216 | | Reg _ -> assert false 217 | | Const {cst_name;_} -> 218 | begin match CCHashtbl.get st.tbl cst_name with 219 | | None -> t 220 | | Some i -> E.reg i (* lookup *) 221 | end 222 | 223 | (* build an associative pattern tree out of this list of patterns *) 224 | and ap_of_pats (a:pattern Slice.t): slice_pattern = 225 | let n = Slice.length a in 226 | if n=0 then SP_pure ([],0) 227 | else ( 228 | (* TODO: refine this, e.g. with a "specificity" score that 229 | is higher when the pattern is more specific (low for Blank, high 230 | for constant applications, literals, etc.) and pick the most 231 | specific non-slice pattern as vantage point *) 232 | (* try to find a vantage point *) 233 | begin match Slice.find_idx matches_single a with 234 | | Some (i, vantage) -> 235 | (* recurse in left and right parts of the pattern *) 236 | let left = ap_of_pats (Slice.sub a 0 i) in 237 | let right = ap_of_pats (Slice.sub a (i+1) (n-i-1)) in 238 | let sp_min_size = 239 | pat_slice_min_size vantage + 240 | sp_slice_min_size left + 241 | sp_slice_min_size right 242 | in 243 | SP_vantage { 244 | sp_vantage=vantage; 245 | sp_left=left; 246 | sp_right=right; 247 | sp_min_size; 248 | } 249 | | None -> 250 | (* pure pattern: only slice-matching patterns *) 251 | let l = Slice.copy a |> Array.to_list in 252 | let min_size = 253 | List.fold_left 254 | (fun acc p -> acc+pat_slice_min_size p) 0 l 255 | in 256 | SP_pure (l, min_size) 257 | end 258 | ) 259 | 260 | (* build an associative pattern tree out of this list of patterns *) 261 | and sup_of_pats (l:pattern list): slice_unordered_pattern = 262 | begin match CCList.find_idx matches_single l with 263 | | Some (i, vantage) -> 264 | let l' = CCList.remove_at_idx i l in 265 | let sup = sup_of_pats l' in 266 | let min_size = pat_slice_min_size vantage + sup_slice_min_size sup in 267 | SUP_vantage (vantage, sup, min_size) 268 | | None -> 269 | (* pure pattern: only slice-matching patterns *) 270 | let min_size = 271 | List.fold_left 272 | (fun acc p -> acc+pat_slice_min_size p) 0 l 273 | in 274 | SUP_pure (l, min_size) 275 | end 276 | 277 | let extract_cond (e:E.t) : E.t * E.t option = match e with 278 | | App (Const {cst_name="Condition";_}, [| a; cond |]) -> 279 | a, Some cond 280 | | _ -> e, None 281 | end 282 | 283 | let compile (e:E.t): pattern option = 284 | let st = Pat_compile.create() in 285 | try Some (Pat_compile.tr_pattern st e) 286 | with _ -> None 287 | 288 | (* raise Invalid_rule if cannot compile *) 289 | let compile_rule (lhs:E.t) (rhs:E.t): rewrite_rule = 290 | let st = Pat_compile.create() in 291 | let pat = Pat_compile.tr_pattern st lhs in 292 | let rhs, cond = Pat_compile.extract_cond rhs in 293 | let rhs = Pat_compile.tr_term st rhs in 294 | (* FIXME rr_pat_as_expr in case of condition *) 295 | let rr_pat = match cond with 296 | | None -> pat 297 | | Some cond -> 298 | let cond = Pat_compile.tr_term st cond in 299 | P_conditional (pat, cond) 300 | in 301 | {rr_pat; rr_pat_as_expr=lhs; rr_rhs=rhs } 302 | 303 | exception Invalid_binding_seq of string 304 | 305 | let invalid_binding_seq msg = raise (Invalid_binding_seq msg) 306 | 307 | let compile_binding_seq_body (s:E.t Slice.t) (ret:E.t): binding_seq = 308 | let st = Pat_compile.create() in 309 | (* evaluation order matters *) 310 | let body = 311 | Slice.fold_left 312 | (fun acc sub -> 313 | begin match sub with 314 | | App (Const {cst_name="MatchBind";_}, [| pat; rhs |]) -> 315 | let pat = Pat_compile.tr_pattern st pat in 316 | let rhs = Pat_compile.tr_term st rhs in 317 | Comp_match (pat,rhs) :: acc 318 | | App (Const {cst_name="MatchBind1";_}, [| pat; rhs |]) -> 319 | let pat = Pat_compile.tr_pattern st pat in 320 | let rhs = Pat_compile.tr_term st rhs in 321 | Comp_match1 (pat,rhs) :: acc 322 | | _ -> 323 | let t = Pat_compile.tr_term st sub in 324 | Comp_test t :: acc 325 | end) 326 | [] 327 | s 328 | in 329 | let ret = Pat_compile.tr_term st ret in 330 | { comp_yield=ret; comp_body=List.rev body } 331 | 332 | let compile_binding_seq ~ret (args:E.t array): (binding_seq,string) Result.result = 333 | try 334 | let n = Array.length args in 335 | match args, ret with 336 | | [||], _ -> Result.Error "need at least 2 arguments" 337 | | _, `First -> 338 | let ret = args.(0) in 339 | let body = Slice.make args 1 ~len:(n-1) in 340 | let c = compile_binding_seq_body body ret in 341 | Result.Ok c 342 | | _, `Last -> 343 | let ret = args.(n-1) in 344 | let body = Slice.make args 0 ~len:(n-1) in 345 | let c = compile_binding_seq_body body ret in 346 | Result.Ok c 347 | with 348 | | Invalid_binding_seq msg -> Result.Error msg 349 | -------------------------------------------------------------------------------- /src/core/Pattern.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Patterns} *) 5 | 6 | open Base_types 7 | 8 | type t = Base_types.pattern 9 | 10 | (** {2 IO} *) 11 | 12 | val pp : t CCFormat.printer 13 | val pp_rule : rewrite_rule CCFormat.printer 14 | 15 | (** {2 Compilation} *) 16 | 17 | exception Invalid_rule of string 18 | exception Invalid_binding_seq of string 19 | 20 | val matches_slice : t -> bool 21 | 22 | val compile : expr -> t option 23 | 24 | val compile_rule : expr -> expr -> rewrite_rule 25 | 26 | val sp_slice_min_size : slice_pattern -> int 27 | 28 | val sup_slice_min_size : slice_unordered_pattern -> int 29 | 30 | val compile_binding_seq : 31 | ret:[< `First | `Last ] -> 32 | expr array -> 33 | (binding_seq, string) Result.result 34 | 35 | -------------------------------------------------------------------------------- /src/core/Printer.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Main Printer} *) 5 | 6 | (* TODO: traverse expr, flattening terms, with special syntax, etc. *) 7 | let pp = Expr.pp_full_form 8 | 9 | (* TODO: if we traverse [FullForm[...]] we switch to full form printing *) 10 | 11 | -------------------------------------------------------------------------------- /src/core/Printer.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Main Printer} *) 5 | 6 | val pp : Expr.t CCFormat.printer 7 | 8 | -------------------------------------------------------------------------------- /src/core/Slice.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Array Slice} *) 5 | 6 | type 'a t = { 7 | arr : 'a array; 8 | i : int; (** Start index (included) *) 9 | j : int; (** Stop index (excluded) *) 10 | } 11 | 12 | let empty = { 13 | arr = [||]; 14 | i = 0; 15 | j = 0; 16 | } 17 | 18 | let make arr i ~len = 19 | if i<0||i+len > Array.length arr then invalid_arg "Slice.make"; 20 | { arr; i; j=i+len; } 21 | 22 | let of_slice (arr,i,len) = make arr i ~len 23 | 24 | let to_slice a = a.arr, a.i, a.j-a.i 25 | 26 | let full arr = { arr; i=0; j=Array.length arr; } 27 | 28 | let of_list l = 29 | let a = Array.of_list l in 30 | full a 31 | 32 | let get a i = 33 | let j = a.i + i in 34 | if i<0 || j>=a.j then invalid_arg "Slice.get"; 35 | a.arr.(j) 36 | 37 | let underlying a = a.arr 38 | 39 | let length a = a.j - a.i 40 | 41 | let copy a = Array.sub a.arr a.i (length a) 42 | 43 | let sub a i len = make a.arr (a.i + i) ~len 44 | 45 | let rec _find f a i j = 46 | if i = j then None 47 | else match f i a.(i) with 48 | | Some _ as res -> res 49 | | None -> _find f a (i+1) j 50 | 51 | let find_idx p a = 52 | _find (fun i x -> if p x then Some (i-a.i,x) else None) a.arr a.i a.j 53 | 54 | let print ?(sep=", ") pp_item fmt a = 55 | let _print ~sep pp_item fmt a i j = 56 | for k = i to j - 1 do 57 | if k > i then (Format.pp_print_string fmt sep; Format.pp_print_cut fmt ()); 58 | pp_item fmt a.(k) 59 | done 60 | in 61 | _print ~sep pp_item fmt a.arr a.i a.j 62 | 63 | let iter f a = 64 | for k = a.i to a.j-1 do f a.arr.(k) done 65 | 66 | let fold_left f acc a = 67 | let acc = ref acc in 68 | for k = a.i to a.j-1 do 69 | acc := f !acc a.arr.(k); 70 | done; 71 | !acc 72 | 73 | exception Local_exit 74 | 75 | let for_all p a = 76 | try iter (fun x->if not (p x) then raise Local_exit) a; true 77 | with Local_exit -> false 78 | -------------------------------------------------------------------------------- /src/core/Slice.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Array Slice} *) 5 | 6 | type 'a t 7 | (** A slice is an array, an offset, and a length *) 8 | 9 | val length : _ t -> int 10 | 11 | val make : 'a array -> int -> len:int -> 'a t 12 | (** Create a slice. 13 | @raise Invalid_argument if the slice isn't valid *) 14 | 15 | val of_slice : ('a array * int * int) -> 'a t 16 | (** Make a sub-array from a triple [(arr, i, len)] where [arr] is the array, 17 | [i] the offset in [arr], and [len] the number of elements of the slice. 18 | @raise Invalid_argument if the slice isn't valid (See {!make}) *) 19 | 20 | val of_list : 'a list -> 'a t 21 | 22 | val to_slice : 'a t -> ('a array * int * int) 23 | (** Convert into a triple [(arr, i, len)] where [len] is the length of 24 | the subarray of [arr] starting at offset [i] *) 25 | 26 | val full : 'a array -> 'a t 27 | (** Slice that covers the full array *) 28 | 29 | val underlying : 'a t -> 'a array 30 | (** Underlying array (shared). Modifying this array will modify the slice *) 31 | 32 | val get : 'a t -> int -> 'a 33 | 34 | val copy : 'a t -> 'a array 35 | (** Copy into a new array *) 36 | 37 | val sub : 'a t -> int -> int -> 'a t 38 | (** Sub-slice *) 39 | 40 | val find_idx : ('a -> bool) -> 'a t -> (int * 'a) option 41 | (** [find_idx p x] returns [Some (i,x)] where [x] is the [i]-th element of [l], 42 | and [p x] holds. Otherwise returns [None] *) 43 | 44 | val iter : ('a -> unit) -> 'a t -> unit 45 | 46 | val fold_left : ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b 47 | 48 | val for_all : ('a -> bool) -> 'a t -> bool 49 | 50 | val print : ?sep:string -> (Format.formatter -> 'a -> unit) -> 51 | Format.formatter -> 'a t -> unit 52 | (** Print an array of items with printing function *) 53 | -------------------------------------------------------------------------------- /src/core/Stimsym.ml: -------------------------------------------------------------------------------- 1 | 2 | module Document = Document 3 | module Completion = Completion 4 | module Eval = Eval 5 | module Expr = Expr 6 | module Parser = Parser 7 | module Printer = Printer 8 | module Subst = Subst 9 | module Builtins = Builtins 10 | module Builtins_advanced = Builtins_advanced 11 | module Lexer = Lexer 12 | module Parse_loc = Parse_loc 13 | 14 | let init () = 15 | ignore (Sys.opaque_identity Builtins_advanced.init ()) 16 | -------------------------------------------------------------------------------- /src/core/Subst.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Substitutions} *) 5 | 6 | open Base_types 7 | 8 | module E = Expr 9 | module IntMap = CCMap.Make(CCInt) 10 | module Fmt = CCFormat 11 | 12 | type t = expr IntMap.t 13 | let empty = IntMap.empty 14 | let is_empty = IntMap.is_empty 15 | let add = IntMap.add 16 | let mem = IntMap.mem 17 | let get = IntMap.get 18 | 19 | let pp out (s:t) = 20 | Format.fprintf out "{@[%a@]}" 21 | (IntMap.pp ~pp_start:(Fmt.return "") ~pp_stop:(Fmt.return "") Fmt.int E.pp_full_form) s 22 | 23 | let get_exn i s = 24 | try IntMap.find i s 25 | with Not_found -> 26 | invalid_arg (Fmt.sprintf "could not find %d in %a" i pp s) 27 | 28 | let rec apply_rec (s:t) (t:expr): expr = match t with 29 | | Reg i -> 30 | begin match IntMap.get i s with 31 | | None -> assert false 32 | | Some u -> u 33 | end 34 | | Const _ | Z _ | Q _ | String _ -> t 35 | | App (hd, args) -> 36 | E.app_flatten (apply_rec s hd) (Array.map (apply_rec s) args) 37 | 38 | let apply subst e = 39 | if is_empty subst 40 | then e 41 | else apply_rec subst e 42 | -------------------------------------------------------------------------------- /src/core/Subst.mli: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Substitutions} *) 5 | 6 | open Base_types 7 | 8 | type t 9 | val empty : t 10 | val is_empty : t -> bool 11 | val add : int -> expr -> t -> t 12 | val mem : int -> t -> bool 13 | val get : int -> t -> expr option 14 | val get_exn : int -> t -> expr 15 | val apply : t -> expr -> expr 16 | val pp : t CCFormat.printer 17 | -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name stimsym) 3 | (public_name stimsym) 4 | ;(modules (:standard \ Base_types)) ; TODO: only hide this 5 | (flags :standard -warn-error -3-32) 6 | (libraries bytes result containers iter zarith unix containers.unix 7 | containers-data)) 8 | 9 | (ocamllex Lexer Lexer_full_form) 10 | 11 | (menhir 12 | (modules Parser)) 13 | -------------------------------------------------------------------------------- /src/server/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name stimsym_server) 3 | (public_name stimsym_server) 4 | (package stimsym-server) 5 | (libraries stimsym jupyter-kernel unix threads tyxml logs)) 6 | -------------------------------------------------------------------------------- /src/server/stimsym_server.ml: -------------------------------------------------------------------------------- 1 | (* This file is free software. See file "license" for more details. *) 2 | 3 | (** {1 Notebook interface} *) 4 | 5 | open Stimsym 6 | 7 | module H = Tyxml.Html 8 | module C = Jupyter_kernel.Client 9 | module Main = Jupyter_kernel.Client_main 10 | module Log = (val Logs.src_log (Logs.Src.create "stimsym")) 11 | 12 | (** {2 Execution of queries} *) 13 | 14 | (* display a document as HTML *) 15 | let html_of_doc : Document.t -> [ H.h1 l 18 | | 2 -> H.h2 l 19 | | 3 -> H.h3 l 20 | | 4 -> H.h4 l 21 | | 5 -> H.h5 l 22 | | n when n>=6 -> H.h6 l 23 | | _ -> assert false 24 | in 25 | let rec aux ~depth doc = 26 | H.div (List.map (aux_block ~depth) doc) 27 | and aux_block ~depth (b:Document.block) = 28 | let h = match b with 29 | | `S s -> mk_header ~depth [H.txt s] 30 | | `P s -> H.p [H.txt s] 31 | | `Pre s -> H.pre [H.txt s] 32 | | `L l -> 33 | H.ul (List.map (fun sub -> H.li [aux ~depth sub]) l) 34 | | `I (s,sub) -> 35 | let depth = depth+1 in 36 | H.div ( 37 | mk_header ~depth [H.txt s] :: List.map (aux_block ~depth) sub 38 | ) 39 | in 40 | H.div [h] 41 | in 42 | aux ~depth:3 43 | 44 | let mime_of_html (h:_ H.elt) : C.mime_data = 45 | let s = CCFormat.sprintf "%a@." (H.pp_elt ()) h in 46 | {C.mime_type="text/html"; mime_content=s; mime_b64=false} 47 | 48 | let mime_of_txt (s:string) : C.mime_data = 49 | {C.mime_type="text/plain"; mime_content=s; mime_b64=false} 50 | 51 | (* blocking function *) 52 | let run_ count str : C.Kernel.exec_status_ok C.or_error = 53 | let buf = Lexing.from_string str in 54 | Parse_loc.set_file buf ("cell_" ^ string_of_int count); 55 | begin match Parser.parse_expr Lexer.token buf with 56 | | e -> 57 | Log.debug (fun k->k "parsed: @[%a@]@." Expr.pp_full_form e); 58 | begin 59 | try 60 | let e', effects = Eval.eval_full e in 61 | let res = 62 | if Expr.equal Builtins.null e' 63 | then None 64 | else Some (CCFormat.sprintf "@[%a@]@." Expr.pp e') 65 | and actions = 66 | List.map 67 | (function 68 | | Eval.Print_doc d -> 69 | C.Kernel.Mime [d |> html_of_doc |> mime_of_html] 70 | | Eval.Print_mime {Expr.mime_ty;mime_data;mime_base64} -> 71 | C.Kernel.mime ~base64:mime_base64 ~ty:mime_ty mime_data) 72 | effects 73 | in 74 | Result.Ok (C.Kernel.ok ~actions res) 75 | with 76 | | Stack_overflow -> 77 | Result.Error "stack overflow." 78 | | Eval.Eval_fail msg -> 79 | Result.Error 80 | (CCFormat.sprintf "evaluation failed: %s@." msg) 81 | end 82 | | exception e -> 83 | Result.Error 84 | (CCFormat.sprintf "error: %s@." (Printexc.to_string e)) 85 | end 86 | 87 | (* auto-completion *) 88 | let complete pos str = 89 | let start, stop, l = 90 | if pos > String.length str then 0,0, [] 91 | else ( 92 | let {Completion.start;stop;l} = Completion.complete ~cursor_pos:pos str in 93 | start, stop, List.map (fun c -> c.Completion.text) l 94 | ) 95 | in 96 | let c = { 97 | C.Kernel.completion_matches=l; 98 | completion_start=start; completion_end=stop; 99 | } in 100 | c 101 | 102 | (* inspection *) 103 | let inspect (r:C.Kernel.inspect_request) : (C.Kernel.inspect_reply_ok, string) result = 104 | let {C.Kernel.ir_code=c; ir_cursor_pos=pos; ir_detail_level=lvl} = r in 105 | Log.debug (fun k->k "inspection request %s :pos %d :lvl %d" c pos lvl); 106 | let cl = Completion.find_constants ~exact:true c ~cursor_pos:pos in 107 | let r = match cl.Completion.l with 108 | | [e] -> 109 | let txt = mime_of_txt @@ Document.to_string @@ Expr.Cst.get_doc e in 110 | let html = Expr.Cst.get_doc e |> html_of_doc |> mime_of_html in 111 | {C.Kernel.iro_status="ok"; iro_found=true; iro_data=[txt;html]} 112 | | _ -> 113 | (* not found *) 114 | {C.Kernel.iro_status="ok"; iro_found=false; iro_data=[]} 115 | in 116 | Result.Ok r 117 | 118 | (* is the block of code complete? 119 | TODO: a way of asking the parser if it failed because of EOI/unbalanced []*) 120 | let is_complete _ = Lwt.return C.Kernel.Is_complete 121 | 122 | let () = 123 | Builtins.log_ := (fun s -> Log.debug (fun k->k "%s" s)) 124 | 125 | let kernel : C.Kernel.t = 126 | C.Kernel.make 127 | ~banner:"Stimsym" 128 | ~exec:(fun ~count msg -> Lwt.return (run_ count msg)) 129 | ~is_complete 130 | ~history:(fun _ -> Lwt.return []) 131 | ~inspect:(fun r -> Lwt.return (inspect r)) 132 | ~language:"stimsym" 133 | ~language_version:[0;1;0] 134 | ~codemirror_mode:"mathematica" 135 | ~complete: (fun ~pos msg -> Lwt.return (complete pos msg)) 136 | () 137 | 138 | let setup_logs () = 139 | Logs.set_reporter (Logs.format_reporter ()); 140 | Logs.set_level ~all:true (Some Logs.Debug); 141 | begin match Sys.getenv "STIMSYM_LOG" with 142 | | "debug" -> Logs.set_level ~all:true (Some Logs.Debug) 143 | | "info" -> Logs.set_level ~all:true (Some Logs.Info) 144 | | "error" -> Logs.set_level ~all:true (Some Logs.Error) 145 | | "warning" -> Logs.set_level ~all:true (Some Logs.Warning) 146 | | s -> failwith ("unknown log level: " ^ s) 147 | | exception _ -> () 148 | end 149 | 150 | (* main *) 151 | 152 | let () = 153 | setup_logs (); 154 | Stimsym.init(); 155 | let config = Main.mk_config ~usage:"stimsym" () in 156 | Lwt_main.run (Main.main ~config ~kernel) 157 | -------------------------------------------------------------------------------- /stimsym-server.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "stimsym-server" 3 | version: "dev" 4 | author: "Simon Cruanes" 5 | maintainer: "simon.cruanes.2007@m4x.org" 6 | synopsis: "Rewrite system designed for symbolic manipulations and maximal expressiveness (Jupyter kernel)" 7 | build: [ 8 | ["dune" "build" "@install" "-p" name "-j" jobs] 9 | ["dune" "build" "@doc" "-p" name] {with-doc} 10 | ["dune" "runtest" "-p" name] {with-test} 11 | ] 12 | depends: [ 13 | "dune" {>= "1.0"} 14 | "base-bytes" 15 | "result" 16 | "containers" { >= "3.0" & < "4.0" } 17 | "stimsym" 18 | "iter" 19 | "ocaml" {>= "4.03.0"} 20 | "jupyter-kernel" { >= "0.6" & < "0.8" } 21 | "tyxml" 22 | "logs" 23 | ] 24 | tags: [ "rewriting" "cas" "logic" "mathematica" "jupyter" ] 25 | homepage: "https://github.com/c-cube/stimsym/" 26 | dev-repo: "git+https://github.com/c-cube/stimsym.git" 27 | bug-reports: "https://github.com/c-cube/stimsym/issues/" 28 | -------------------------------------------------------------------------------- /stimsym.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "stimsym" 3 | version: "dev" 4 | author: "Simon Cruanes" 5 | maintainer: "simon.cruanes.2007@m4x.org" 6 | synopsis: "Rewrite system designed for symbolic manipulations and maximal expressiveness" 7 | build: [ 8 | ["dune" "build" "@install" "-p" name "-j" jobs] 9 | ["dune" "build" "@doc" "-p" name] {with-doc} 10 | ["dune" "runtest" "-p" name] {with-test} 11 | ] 12 | depends: [ 13 | "dune" {>= "1.1"} 14 | "containers" { >= "3.0" & < "4.0" } 15 | "containers-data" { >= "3.0" & < "4.0" } 16 | "iter" 17 | "linenoise" 18 | "base-unix" 19 | "zarith" 20 | "menhir" 21 | "ocaml" { >= "4.03" } 22 | "ounit2" {with-test} 23 | ] 24 | tags: [ "rewriting" "cas" "logic" "mathematica" "jupyter" ] 25 | homepage: "https://github.com/c-cube/stimsym/" 26 | dev-repo: "git+https://github.com/c-cube/stimsym.git" 27 | bug-reports: "https://github.com/c-cube/stimsym/issues/" 28 | -------------------------------------------------------------------------------- /tests/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name run_tests) 3 | (libraries stimsym ounit2)) 4 | 5 | (alias 6 | (name runtest) 7 | (deps 8 | (:< run_tests.exe)) 9 | (action 10 | (run %{<} -runner sequential))) 11 | -------------------------------------------------------------------------------- /tests/run_tests.ml: -------------------------------------------------------------------------------- 1 | 2 | (* This file is free software. See file "license" for more details. *) 3 | 4 | (** {1 Test Suite} *) 5 | 6 | open Stimsym 7 | open OUnit2 8 | 9 | let mk_name prefix line = Printf.sprintf "%s_line_%d" prefix line 10 | 11 | (** {2 Parser} *) 12 | 13 | exception Test_fail of string 14 | 15 | let () = Printexc.register_printer 16 | (function 17 | | Test_fail s -> Some s 18 | | _ -> None) 19 | 20 | let test_parser line a b : test = 21 | mk_name "ok" line >:: (fun _ -> 22 | let buf = Lexing.from_string a in 23 | try 24 | let e = Parser.parse_expr Lexer.token buf in 25 | OUnit.assert_equal ~cmp:CCString.equal ~printer:CCFun.id 26 | b (Expr.to_string_compact e) 27 | with Parse_loc.Parse_error (_,s) -> 28 | let msg = 29 | CCFormat.sprintf "failed to parse `%s`:@ %s@ (expected: `%s`)" a s b 30 | in 31 | raise (Test_fail msg) 32 | ) 33 | 34 | let test_parser_fail line a : test = 35 | mk_name "fail" line >:: (fun _ -> 36 | let buf = Lexing.from_string a in 37 | try 38 | let _ = Parser.parse_expr Lexer.token buf in 39 | OUnit.assert_failure (Printf.sprintf "should have failed to parse %S" a) 40 | with e -> 41 | OUnit.assert_bool 42 | (Printf.sprintf "properly failed to parse %S with exn %s" a (Printexc.to_string e)) 43 | true 44 | ) 45 | 46 | let suite_parser = 47 | "parser" >::: [ 48 | test_parser __LINE__ "f" "f"; 49 | test_parser __LINE__ "f[]" "f[]"; 50 | test_parser __LINE__ "f[a,b,c]" "f[a,b,c]"; 51 | test_parser __LINE__ "a+b" "Plus[a,b]"; 52 | test_parser __LINE__ "a+b+c+d" "Plus[a,b,c,d]"; 53 | test_parser __LINE__ "f[a+b+c,d]" "f[Plus[a,b,c],d]"; 54 | test_parser __LINE__ "3/2" "3/2"; 55 | test_parser __LINE__ "6/4" "3/2"; 56 | test_parser __LINE__ "\"abc\"" "\"abc\""; 57 | test_parser __LINE__ "\"abc d\"" "\"abc d\""; 58 | test_parser_fail __LINE__ "f[a+b+,d]"; 59 | test_parser_fail __LINE__ "+ +"; 60 | test_parser __LINE__ 61 | "f[g[h[i[j[k,l]+m],n,o+p+(q)]]]+r" 62 | "Plus[f[g[h[i[Plus[j[k,l],m]],n,Plus[o,p,q]]]],r]"; 63 | test_parser __LINE__ "{1,2,3}" "List[1,2,3]"; 64 | test_parser __LINE__ "{1,{2},{3,a+0}}" "List[1,List[2],List[3,Plus[a,0]]]"; 65 | test_parser __LINE__ "{}" "List[]"; 66 | test_parser __LINE__ "{a, b,c,d+e+1 + 3}" "List[a,b,c,Plus[d,e,1,3]]"; 67 | test_parser __LINE__ " { a, b,c,d +e+1 +3 }" "List[a,b,c,Plus[d,e,1,3]]"; 68 | test_parser __LINE__ " { a, b,c,d +e +1 + 3 } " "List[a,b,c,Plus[d,e,1,3]]"; 69 | test_parser __LINE__ " a + (* coucou lol *) b" "Plus[a,b]"; 70 | test_parser __LINE__ " (*foo *) 1" "1"; 71 | test_parser __LINE__ "2 (*why hello*) b" "Times[2,b]"; 72 | test_parser __LINE__ "_" "Blank[]"; 73 | test_parser __LINE__ "_a" "Blank[a]"; 74 | test_parser __LINE__ "a_b" "Pattern[a,Blank[b]]"; 75 | test_parser __LINE__ "a__b" "Pattern[a,BlankSequence[b]]"; 76 | test_parser __LINE__ "a___b" "Pattern[a,BlankNullSequence[b]]"; 77 | test_parser __LINE__ "a___" "Pattern[a,BlankNullSequence[]]"; 78 | test_parser __LINE__ "___" "BlankNullSequence[]"; 79 | test_parser __LINE__ "a b c" "Times[a,b,c]"; 80 | test_parser __LINE__ "a b (c+d) " "Times[a,b,Plus[c,d]]"; 81 | test_parser __LINE__ "f[a b, c+d e + 1]" "f[Times[a,b],Plus[c,Times[d,e],1]]"; 82 | test_parser __LINE__ 83 | "a_|f[b__]|c " 84 | "Alternatives[Pattern[a,Blank[]],f[Pattern[b,BlankSequence[]]],c]"; 85 | test_parser __LINE__ "a ___b" "Times[a,BlankNullSequence[b]]"; 86 | test_parser __LINE__ "a ___ b" "Times[a,BlankNullSequence[],b]"; 87 | test_parser __LINE__ "f[a_] = b " "Assign[f[Pattern[a,Blank[]]],b]"; 88 | test_parser __LINE__ 89 | "f[a_|foo] := b[c] d+f " 90 | "AssignDelayed[f[Alternatives[Pattern[a,Blank[]],foo]],Plus[Times[b[c],d],f]]"; 91 | test_parser __LINE__ "f[a_] = b " "Assign[f[Pattern[a,Blank[]]],b]"; 92 | test_parser __LINE__ "f[a_] :> g[a,a]" "RuleDelayed[f[Pattern[a,Blank[]]],g[a,a]]"; 93 | test_parser __LINE__ "f[x] -> g[x,a]" "Rule[f[x],g[x,a]]"; 94 | test_parser __LINE__ "f[x]:> g[x,a]" "RuleDelayed[f[x],g[x,a]]"; 95 | test_parser __LINE__ "f[x]->g[x,a]" "Rule[f[x],g[x,a]]"; 96 | test_parser __LINE__ "f[x]:> g[x]+ h[x] 3" "RuleDelayed[f[x],Plus[g[x],Times[h[x],3]]]"; 97 | test_parser __LINE__ "f[a==b==c,1]" "f[Inequality[a,Equal,b,Equal,c],1]"; 98 | test_parser __LINE__ 99 | "1==a>=b a===b===c" "Rule[f,SameQ[a,b,c]]"; 107 | test_parser __LINE__ "a!" "Factorial[a]"; 108 | test_parser __LINE__ "a!+b" "Plus[Factorial[a],b]"; 109 | test_parser __LINE__ "a! b" "Times[Factorial[a],b]"; 110 | test_parser __LINE__ "! a + b ! c" "Not[Plus[a,Times[Factorial[b],c]]]"; 111 | test_parser __LINE__ "a/; b" "Condition[a,b]"; 112 | test_parser __LINE__ "f[a_]/; b" "Condition[f[Pattern[a,Blank[]]],b]"; 113 | test_parser __LINE__ "a_/; b :> a+1" "RuleDelayed[Condition[Pattern[a,Blank[]],b],Plus[a,1]]"; 114 | test_parser __LINE__ 115 | "a_[_|__]/; b===1 :> a+1" 116 | "RuleDelayed[Condition[Pattern[a,Blank[]][Alternatives[Blank[],BlankSequence[]]]\ 117 | ,SameQ[b,1]],Plus[a,1]]"; 118 | test_parser __LINE__ 119 | "t:f[_,_]/;t==1 :> g[t]" 120 | "RuleDelayed[Condition[Pattern[t,f[Blank[],Blank[]]],Inequality[t,Equal,1]],g[t]]"; 121 | test_parser __LINE__ 122 | "t:f[x___] :> g[t,x]" 123 | "RuleDelayed[Pattern[t,f[Pattern[x,BlankNullSequence[]]]],g[t,x]]"; 124 | test_parser __LINE__ "f[a] /. {x,y,z}" "ReplaceAll[f[a],List[x,y,z]]"; 125 | test_parser __LINE__ "f[a] //. {x,y,z} d" "ReplaceRepeated[f[a],Times[List[x,y,z],d]]"; 126 | test_parser __LINE__ 127 | "f[a,b+c d!] //. {f[x,y,z___] :> f[x y,z]}" 128 | "ReplaceRepeated[f[a,Plus[b,Times[c,Factorial[d]]]],\ 129 | List[RuleDelayed[f[x,y,Pattern[z,BlankNullSequence[]]],f[Times[x,y],z]]]]"; 130 | test_parser __LINE__ "a := b; c" "CompoundExpression[AssignDelayed[a,b],c]"; 131 | test_parser __LINE__ "a/; test := b ; c" "CompoundExpression[AssignDelayed[Condition[a,test],b],c]"; 132 | test_parser __LINE__ "a := b :> c; d//.e" 133 | "CompoundExpression[AssignDelayed[a,RuleDelayed[b,c]],ReplaceRepeated[d,e]]"; 134 | test_parser __LINE__ "#1" "Slot[1]"; 135 | test_parser __LINE__ "#1 #2" "Times[Slot[1],Slot[2]]"; 136 | test_parser __LINE__ "(#1 + #2[#0])&" "Function[Plus[Slot[1],Slot[2][Slot[0]]]]"; 137 | test_parser __LINE__ "f = a; 1+#2&" 138 | "CompoundExpression[Assign[f,a],Function[Plus[1,Slot[2]]]]"; 139 | test_parser __LINE__ "a;b;c" "CompoundExpression[a,b,c]"; 140 | test_parser __LINE__ "a;b;c;" "CompoundExpression[a,b,c,Null]"; 141 | test_parser __LINE__ "a;" "CompoundExpression[a,Null]"; 142 | test_parser __LINE__ "({#0}&)+#1&" 143 | "Function[Plus[Function[List[Slot[0]]],Slot[1]]]"; 144 | test_parser __LINE__ "a<-b" "MatchBind[a,b]"; 145 | test_parser __LINE__ "a_<-b+c" "MatchBind[Pattern[a,Blank[]],Plus[b,c]]"; 146 | test_parser __LINE__ "a<<-b" "MatchBind1[a,b]"; 147 | test_parser __LINE__ "a_<<-b+c" "MatchBind1[Pattern[a,Blank[]],Plus[b,c]]"; 148 | test_parser __LINE__ "{a<-b,c<<-d }" "List[MatchBind[a,b],MatchBind1[c,d]]"; 149 | test_parser __LINE__ 150 | "{f[x] :: x_<<-{1}, y_<-b, t}" 151 | "List[Comprehension[f[x],MatchBind1[Pattern[x,Blank[]],List[1]],MatchBind[Pattern[y,Blank[]],b],t]]"; 152 | test_parser __LINE__ "_?IntegerQ" "PatternTest[Blank[],IntegerQ]"; 153 | test_parser __LINE__ 154 | "f[_]?(#===f[a]&)" 155 | "PatternTest[f[Blank[]],Function[SameQ[Slot[1],f[a]]]]"; 156 | test_parser __LINE__ "a^b" "Power[a,b]"; 157 | test_parser __LINE__ "x a^b" "Times[x,Power[a,b]]"; 158 | test_parser __LINE__ "x a^b c" "Times[x,Power[a,b],c]"; 159 | test_parser __LINE__ "a b/c" "Times[a,Div[b,c]]"; 160 | test_parser __LINE__ "a b/c d" "Times[a,Div[b,c],d]"; 161 | ] 162 | 163 | (** {2 Printer} *) 164 | 165 | let test_printer ?(strip_space=false) line a b : test = 166 | mk_name "same" line >:: (fun _ -> 167 | let buf = Lexing.from_string a in 168 | try 169 | let e = Parser.parse_expr Lexer.token buf in 170 | let res = Expr.to_string e in 171 | let res = 172 | if strip_space 173 | then CCString.filter (function ' '|'\n' -> false | _ -> true) res 174 | else res 175 | in 176 | OUnit.assert_equal ~cmp:CCString.equal ~printer:CCFun.id b res 177 | with Parse_loc.Parse_error (_,s) -> 178 | let msg = 179 | CCFormat.sprintf "failed to parse `%s`:@ %s@ (expected: `%s`)" a s b 180 | in 181 | raise (Test_fail msg) 182 | ) 183 | 184 | let test_printer_same line a = test_printer line a a 185 | 186 | let suite_printer = 187 | "printer" >::: [ 188 | test_printer_same __LINE__ "1+2"; 189 | test_printer __LINE__ "1+(2 3)" "1+2 3"; 190 | test_printer_same __LINE__ "1+f[x,y]"; 191 | test_printer_same __LINE__ "{{1},{2+3,f[{4}]}}"; 192 | test_printer_same __LINE__ "f"; 193 | test_printer_same __LINE__ "f[]"; 194 | test_printer_same __LINE__ "f[a,b,c]"; 195 | test_printer_same __LINE__ "a+b"; 196 | test_printer_same __LINE__ "a+b+c+d"; 197 | test_printer_same __LINE__ "f[a+b+c,d]"; 198 | test_printer_same __LINE__ "3/2"; 199 | test_printer __LINE__ 200 | "f[g[h[i[j[k,l]+m],n,o+p+(q)]]]+r" 201 | "f[g[h[i[j[k,l]+m],n,o+p+q]]]+r"; 202 | test_printer_same __LINE__ "{1,2,3}"; 203 | test_printer_same __LINE__ "{1,{2},{3,a+0}}"; 204 | test_printer_same __LINE__ "{}"; 205 | test_printer __LINE__ "{a, b,c,d+e+1 + 3}" "{a,b,c,d+e+1+3}"; 206 | test_printer __LINE__ " { a, b,c,d +e+1 +3 }" "{a,b,c,d+e+1+3}"; 207 | test_printer __LINE__ " { a, b,c,d +e +1 + 3 } " "{a,b,c,d+e+1+3}"; 208 | test_printer __LINE__ " a + (* coucou lol *) b" "a+b"; 209 | test_printer __LINE__ " (*foo *) 1" "1"; 210 | test_printer __LINE__ "2 (*why hello*) b" "2 b"; 211 | test_printer_same __LINE__ "_"; 212 | (* TODO: what to do there? 213 | test_printer_same __LINE__ "_a"; 214 | test_printer_same __LINE__ "a_b"; 215 | test_printer_same __LINE__ "a__b"; 216 | test_printer_same __LINE__ "a___b"; 217 | test_printer_same __LINE__ "a ___b"; 218 | *) 219 | test_printer_same __LINE__ "a___"; 220 | test_printer_same __LINE__ "___"; 221 | test_printer_same __LINE__ "a b c"; 222 | test_printer __LINE__ "a b (c+d) " "a b (c+d)"; 223 | test_printer __LINE__ "f[a b, c+d e + 1]" "f[a b,c+d e+1]"; 224 | test_printer_same __LINE__ "a_|f[b__]|c"; 225 | test_printer_same __LINE__ "a ___ b"; 226 | test_printer __LINE__ "f[a_]=b " "f[a_]=b"; 227 | test_printer __LINE__ 228 | "f[a_|foo]:=b[c] d+f " 229 | "f[a_|foo]:=b[c] d+f"; 230 | test_printer __LINE__ ~strip_space:true 231 | "FullForm[1==a>=ba+1"; 245 | test_printer_same __LINE__ "f[a] /. {x,y,z}"; 246 | test_printer_same __LINE__ "f[a] //. {x,y,z} d"; 247 | test_printer_same __LINE__ "f[a,b+c d!] //. {f[x,y,z___]:>f[x y,z]}"; 248 | test_printer_same __LINE__ "f[a_]=b"; 249 | test_printer_same __LINE__ "f[a_]:>g[a,a]"; 250 | test_printer_same __LINE__ "f[x]->g[x,a]"; 251 | test_printer_same __LINE__ "f[x]:>g[x,a]"; 252 | test_printer_same __LINE__ "f[x]->g[x,a]"; 253 | test_printer_same __LINE__ "f[x]:>g[x]+h[x] 3"; 254 | test_printer_same __LINE__ "f->a===b===c"; 255 | test_printer_same __LINE__ "f[a==b==c,1]"; 256 | test_printer __LINE__ 257 | "Comprehension[f[x,y],MatchBind[g[x_],g[a]],MatchBind1[y_,{1,2,3,4}]]" 258 | "(f[x,y] :: g[x_] <- g[a],y_ <<- {1,2,3,4})"; 259 | (* TODO 260 | test_printer_same __LINE__ 261 | "1==a>=b a+1" 266 | "RuleDelayed[Condition[Pattern[a,Blank[]][Alternatives[Blank[],BlankSequence[]]]\ 267 | ,SameQ[b,1]],Plus[a,1]]"; 268 | test_printer_same __LINE__ 269 | "t:f[_,_]/;t==1 :> g[t]" 270 | "RuleDelayed[Condition[Pattern[t,f[Blank[],Blank[]]],Inequality[t,Equal,1]],g[t]]"; 271 | test_printer_same __LINE__ 272 | "t:f[x___] :> g[t,x]" 273 | "RuleDelayed[Pattern[t,f[Pattern[x,BlankNullSequence[]]]],g[t,x]]"; 274 | *) 275 | ] 276 | 277 | (** {2 Eval} *) 278 | 279 | let mk_eval line a b : test = 280 | mk_name "ok" line >:: (fun _ -> 281 | try 282 | let buf = Lexing.from_string a in 283 | let e = Parser.parse_expr Lexer.token buf in 284 | let e = Eval.eval e in 285 | OUnit.assert_equal ~cmp:CCString.equal ~printer:CCFun.id 286 | b (CCFormat.to_string Expr.pp_full_form e) 287 | with Parse_loc.Parse_error (_,s) -> 288 | let msg = 289 | CCFormat.sprintf "failed to parse `%s`:@ %s" a s 290 | in 291 | raise (Test_fail msg) 292 | ) 293 | 294 | let suite_eval = 295 | "eval" >::: [ 296 | mk_eval __LINE__ "1+2" "3"; 297 | mk_eval __LINE__ "f[1+2,a,b]" "f[3,a,b]"; 298 | mk_eval __LINE__ "f[g[1+2],a,b]" "f[g[3],a,b]"; 299 | mk_eval __LINE__ "f[a+b+1+c+2+d+3]" "f[Plus[6,a,b,c,d]]"; 300 | mk_eval __LINE__ "f[Hold[1+2],3]" "f[Hold[Plus[1,2]],3]"; 301 | mk_eval __LINE__ "f[2/3+1/3]" "f[1]"; 302 | mk_eval __LINE__ "{1,{a,1+0+b},{3,a+0}}" "List[1,List[a,Plus[1,b]],List[3,a]]"; 303 | mk_eval __LINE__ "f[a+1+b+2/3+c,1/34+d]" "f[Plus[5/3,a,b,c],Plus[1/34,d]]"; 304 | mk_eval __LINE__ "f[a+b+2+c,d]" "f[Plus[2,a,b,c],d]"; 305 | mk_eval __LINE__ "f[10 2+3,a b c]" "f[23,Times[a,b,c]]"; 306 | mk_eval __LINE__ 307 | "f[10 a+3 b+c+0,a (b+ c)] " 308 | "f[Plus[c,Times[3,b],Times[10,a]],Times[a,Plus[b,c]]]"; 309 | mk_eval __LINE__ "0!" "1"; 310 | mk_eval __LINE__ "5!" "120"; 311 | mk_eval __LINE__ "10!" "3628800"; 312 | mk_eval __LINE__ "(foo[x_] := g[x]); foo[a]" "g[a]"; 313 | mk_eval __LINE__ "(foo[x_] := Sequence[x,x]); g[foo[a]]" "g[a,a]"; 314 | mk_eval __LINE__ 315 | "(Plus[S[x_],y_] := S[Plus[x,y]]); (Plus[0,y_] := y); Plus[S[S[0]],a]" 316 | "S[S[a]]"; 317 | mk_eval __LINE__ "Plus[Nest[S,0,10],Nest[S,0,10]] === Nest[S,0,20]" "True"; 318 | mk_eval __LINE__ 319 | "(Mult[S[x_],y_] := Plus[Mult[x,y],y]); (Mult[0,y_] := 0); Mult[S[0],a]" 320 | "a"; 321 | mk_eval __LINE__ "Mult[Nest[S,0,10],Nest[S,0,10]] === Nest[S,0,100]" "True"; 322 | mk_eval __LINE__ "(test1 = 1); f[test1]" "f[1]"; 323 | mk_eval __LINE__ "f[a] //. {a->b}" "f[b]"; 324 | mk_eval __LINE__ "f[a] //. {a->b,b->c}" "f[c]"; 325 | mk_eval __LINE__ "{a,b,c} //. {b->2}" "List[a,2,c]"; 326 | mk_eval __LINE__ "{1,2,3} //. {2->a}" "List[1,a,3]"; 327 | mk_eval __LINE__ "f[1,2,g[3],4,5] //. f[l__,g[x_],r__] :> h[r,x,l]" "h[4,5,3,1,2]"; 328 | mk_eval __LINE__ "f[1,2,g[3],4,5] //. f[l1__,l2__,g[x_],r__] :> h[r,x,l2,l1]" "h[4,5,3,2,1]"; 329 | mk_eval __LINE__ 330 | "f[1,2,2,g[2],2,2,g[3],4,5] //. f[l1__,l2__,g[x_],r__] :> h[r,x,l2,last[l1]]" 331 | "h[2,2,g[3],4,5,2,2,2,last[1]]"; 332 | mk_eval __LINE__ 333 | "f[1,2,2,g[2],2,2,g[3],4,5] //. f[l1___,l2__,g[x_],r__] :> h[r,x,l2,last[l1]]" 334 | "h[2,2,g[3],4,5,2,1,2,2,last[]]"; 335 | mk_eval __LINE__ 336 | "f[g[a1,b,c1],h[a2,b,c2]] //. f[g[___,x_,___],h[___,x_,___]] :> {x}" 337 | "List[b]"; 338 | mk_eval __LINE__ 339 | "f[g[a1,b,c1],h[a2,b,c2]] //. f[g[___,x__,___],h[___,x__,___]] :> {x}" 340 | "List[b]"; 341 | mk_eval __LINE__ 342 | "{f[a],f[b],f[c],f[d]} //. f[x_] /; ((x===a)||(x===c)) :> g[x]" 343 | "List[g[a],f[b],g[c],f[d]]"; 344 | mk_eval __LINE__ 345 | "{f[a],f[b],f[c],f[d]} //. f[x_] :> g[x] /; ((x===a)||(x===c))" 346 | "List[g[a],f[b],g[c],f[d]]"; 347 | mk_eval __LINE__ "{1,2,3} /. x_?IntegerQ:>{x}/; x==2" "List[1,List[2],3]"; 348 | mk_eval __LINE__ 349 | "f[g[a1,b,c1],h[a2,b,c2]] //. f[g[___,x_,___],h[___,y_,___]] /; x===y :> {x}" 350 | "List[b]"; 351 | mk_eval __LINE__ 352 | "sortRule := {x___,y_,z_,k___}/;(y>z) :> {x,z,y,k} ; \ 353 | {64, 44, 71, 48, 96, 47, 59, 71, 73, 51, 67, 50, 26, 49, 49}//.sortRule" 354 | "List[26,44,47,48,49,49,50,51,59,64,67,71,71,73,96]"; 355 | mk_eval __LINE__ "1<2<3<4" "True"; 356 | mk_eval __LINE__ "1<2<3>4" "False"; 357 | mk_eval __LINE__ "4>2==1+1<3" "True"; 358 | mk_eval __LINE__ "(1+#1&)[41]" "42"; 359 | mk_eval __LINE__ "(1+#&)[41,0]" "42"; 360 | mk_eval __LINE__ "({#0}&)[a,b,c,d]" "List[a,b,c,d]"; 361 | mk_eval __LINE__ "Nest[f[#1,#1]&,a,2]" "f[f[a,a],f[a,a]]"; 362 | mk_eval __LINE__ "Nest[f[#1,#1]&,a,3]" "f[f[f[a,a],f[a,a]],f[f[a,a],f[a,a]]]"; 363 | mk_eval __LINE__ 364 | "Comprehension[f[x],x_<<-{1,2,3,4}]" 365 | "Sequence[f[1],f[2],f[3],f[4]]"; 366 | mk_eval __LINE__ 367 | "{Comprehension[f[x],x_<<-{1,2,3,4}]}" 368 | "List[f[1],f[2],f[3],f[4]]"; 369 | mk_eval __LINE__ 370 | "Comprehension[f[x,y],g[x_]<-g[a],y_<<-{1,2,3,4}]" 371 | "Sequence[f[a,1],f[a,2],f[a,3],f[a,4]]"; 372 | mk_eval __LINE__ 373 | "Comprehension[f[x,y],g[x_]<<-{a,g[b],c,g[d]},y_<<-{1,2+x,3}]" 374 | "Sequence[f[b,1],f[b,Plus[2,b]],f[b,3],f[d,1],f[d,Plus[2,d]],f[d,3]]"; 375 | mk_eval __LINE__ "{f[x y] :: x_<<-{1,2,3,4,5}, y_<-3, x+y<7}" "List[f[3],f[6],f[9]]"; 376 | mk_eval __LINE__ "Range[5]" "List[0,1,2,3,4,5]"; 377 | mk_eval __LINE__ "Range[2,5]" "List[2,3,4,5]"; 378 | mk_eval __LINE__ "Range[1]" "List[0,1]"; 379 | mk_eval __LINE__ "Range[-1]" "List[]"; 380 | mk_eval __LINE__ "Range[2,9,3]" "List[2,5,8]"; 381 | mk_eval __LINE__ "Range[10,5,-1]" "List[10,9,8,7,6,5]"; 382 | mk_eval __LINE__ "Range[Range[3]]" "List[List[0],List[0,1],List[0,1,2],List[0,1,2,3]]"; 383 | mk_eval __LINE__ "a+(b+(c+d))" "Plus[a,b,c,d]"; 384 | mk_eval __LINE__ "Nest[#+1&,a,3]" "Plus[3,a]"; 385 | mk_eval __LINE__ "Let[x_<-1,f[x]]" "f[1]"; 386 | mk_eval __LINE__ "Let[x_<-1,y_<<-{1,2,3},x+y==3,f[y]]" "f[2]"; 387 | mk_eval __LINE__ "Let[{___,___}<-{},1]" "1"; 388 | mk_eval __LINE__ 389 | "Inits[l_] := {x :: {x___,___}<-l}; Inits[{1,2,3,4}]" 390 | "List[1,1,2,1,2,3,1,2,3,4]"; 391 | mk_eval __LINE__ 392 | "Perms[{}] := {{}}; \ 393 | Perms[{x_,r___}] := { {l1,x,l2} :: {l1___,l2___} <<- Perms[{r}]}; \ 394 | Perms[{1,2,3}] === {{1,2,3},{2,1,3},{2,3,1},{1,3,2},{3,1,2},{3,2,1}}" 395 | "True"; 396 | mk_eval __LINE__ "IntegerQ[1]" "True"; 397 | mk_eval __LINE__ "IntegerQ[1/2]" "False"; 398 | mk_eval __LINE__ "IntegerQ[a]" "False"; 399 | mk_eval __LINE__ "RationalQ[1]" "True"; 400 | mk_eval __LINE__ "RationalQ[1/2]" "True"; 401 | mk_eval __LINE__ "RationalQ[a]" "False"; 402 | mk_eval __LINE__ "TrueQ[True]" "True"; 403 | mk_eval __LINE__ "TrueQ[1]" "False"; 404 | mk_eval __LINE__ "TrueQ[1/2]" "False"; 405 | mk_eval __LINE__ "TrueQ[a]" "False"; 406 | mk_eval __LINE__ "f[Plus[a,Plus[b,c]]]" "f[Plus[a,b,c]]"; 407 | mk_eval __LINE__ "f[Sequence[a,Sequence[b,c]]]" "f[a,b,c]"; 408 | mk_eval __LINE__ "Head[f[a,b,c]]" "f"; 409 | mk_eval __LINE__ "Head[f]" "Head[f]"; 410 | mk_eval __LINE__ "Length[f[a,b,c]]" "3"; 411 | mk_eval __LINE__ "Length[f]" "Length[f]"; 412 | mk_eval __LINE__ "Ceil[1/2]" "1"; 413 | mk_eval __LINE__ "Ceil[-1/2]" "0"; 414 | mk_eval __LINE__ "Floor[1/2]" "0"; 415 | mk_eval __LINE__ "Floor[-1/2]" "-1"; 416 | mk_eval __LINE__ "Ceil[0]==Floor[0]==0" "True"; 417 | mk_eval __LINE__ "{f[],g[]} //. {_f -> a}" "List[a,g[]]"; 418 | mk_eval __LINE__ "f[PatternTest[x_,IntegerQ]] := a; {f[b],f[1],f[1/2]}" "List[f[b],a,f[1/2]]"; 419 | mk_eval __LINE__ "f[__g] := check; {f[g[1],g[],h],f[g[],g[]],f[],f[a,g[]]}" 420 | "List[f[g[1],g[],h],check,f[],f[a,g[]]]"; 421 | mk_eval __LINE__ "f[___g] := check; {f[g[1],g[],h],f[g[],g[]],f[],f[a,g[]]}" 422 | "List[f[g[1],g[],h],check,check,f[a,g[]]]"; 423 | mk_eval __LINE__ "f[a] /. f[x_] :> f[f[x]]" "f[f[a]]"; 424 | mk_eval __LINE__ "Plus[a]" "a"; 425 | mk_eval __LINE__ "Times[a]" "a"; 426 | mk_eval __LINE__ "a+b+c /. (b+___)->top" "top"; 427 | mk_eval __LINE__ "a+b+c+d+b /. (b+d+r___):>{r}" "List[a,b,c]"; 428 | mk_eval __LINE__ 429 | "SetAttributes[fcom,Orderless]; fcom[0,r___] := fcom[r]; fcom[1,2,0,3,a]" 430 | "fcom[1,2,3,a]"; 431 | mk_eval __LINE__ "Power[f_,n_?IntegerQ][x_]:=Nest[f,x,n]; Power[f,3][a]" "f[f[f[a]]]"; 432 | mk_eval __LINE__ "Power[f,5][a]" "f[f[f[f[f[a]]]]]"; 433 | mk_eval __LINE__ "Power[2,10]" "1024"; 434 | mk_eval __LINE__ "Power[1/2,10]" "1/1024"; 435 | mk_eval __LINE__ 436 | "((f^3)[a]) //. f[x_] :> g[x,x]" 437 | "g[g[g[a,a],g[a,a]],g[g[a,a],g[a,a]]]"; 438 | mk_eval __LINE__ "Set[1,2,3,2,4]" "Set[1,2,3,4]"; 439 | mk_eval __LINE__ "Set[]" "Set[]"; 440 | mk_eval __LINE__ 441 | "Fixpoint[(Set[x:: y_<<- #1, x_<<-Range[y]]&), Set[5]]" 442 | "Set[0,1,2,3,4,5]"; 443 | mk_eval __LINE__ "Union[]" "Set[]"; 444 | mk_eval __LINE__ "Union[a]" "a"; 445 | mk_eval __LINE__ 446 | "Union[Set[1,2,3],Set[2,3,4],Set[5,7]]" 447 | "Set[1,2,3,4,5,7]"; 448 | mk_eval __LINE__ 449 | "Union[Set[x::x_<<-Range[i]]:: i_<<-Range[10]]" 450 | "Set[0,1,2,3,4,5,6,7,8,9,10]"; 451 | mk_eval __LINE__ 452 | "Inter[Set[1,2,3],Set[2,3,4,5,6],Set[4,5]]" 453 | "Set[]"; 454 | mk_eval __LINE__ 455 | "Inter[Set[1,2,3,4],Set[2,3,4,5,6],Set[4,5]]" 456 | "Set[4]"; 457 | mk_eval __LINE__ "Matches[_,a]" "True"; 458 | mk_eval __LINE__ "Matches[b,a]" "False"; 459 | mk_eval __LINE__ "Matches[a+___,1+a]" "True"; 460 | mk_eval __LINE__ "Match[f[a],{f[_,_]:>b,f[x_]:>x+1}]" "Plus[1,a]"; 461 | mk_eval __LINE__ "Match[g[a],{f[_,_]:>b,f[x_]:>x+1,r_:>else[r]}]" "else[g[a]]"; 462 | mk_eval __LINE__ "MatchL[f[a],{f[_,_]:>b,f[x_]:>x+1}]" "Plus[1,a]"; 463 | mk_eval __LINE__ 464 | "MatchL[f[a],{f[_,_]:>b,f[x_]:>x+1,r_:>else[r]}]" 465 | "Sequence[Plus[1,a],else[f[a]]]"; 466 | mk_eval __LINE__ 467 | "Times[MatchL[a+b+c,x_+y__:>f[x,Plus[y]]]]" 468 | "Times[f[a,Plus[b,c]],f[b,Plus[a,c]],f[c,Plus[a,b]]]"; 469 | mk_eval __LINE__ 470 | "Set[MatchL[1+a+b+c,{_?IntegerQ+r__:>f[r], _+r__:>g[r]}]]" 471 | "Set[f[a,b,c],g[1,a,b],g[1,a,c],g[1,b,c],g[a,b,c]]"; 472 | mk_eval __LINE__ "Let[x_ <- 2,4/x]" "2"; 473 | mk_eval __LINE__ "Mod[3,3]" "0"; 474 | mk_eval __LINE__ "Mod[5,3]" "2"; 475 | mk_eval __LINE__ "Min[3,2]" "2"; 476 | mk_eval __LINE__ "Max[a,4,10,b,c]" "Max[10,a,b,c]"; 477 | mk_eval __LINE__ "{x:: x_ <<- Sequence[1,2,3]}" "List[1,2,3]"; 478 | ] 479 | 480 | (** {2 Main} *) 481 | 482 | let suite = 483 | "stimsym" >::: [ 484 | suite_parser; 485 | suite_eval; 486 | suite_printer; 487 | ] 488 | 489 | let () = 490 | let _ = OUnit2.run_test_tt_main suite in 491 | () 492 | --------------------------------------------------------------------------------