├── .gitattributes ├── .gitignore ├── README.md ├── compile-arith ├── README.md ├── bin │ ├── dune │ └── main.ml ├── dune ├── lib │ ├── anf_lang.ml │ ├── arith.ml │ ├── dune │ ├── stack_lang.ml │ ├── translation.ml │ ├── tree_lang.ml │ ├── tree_lang_lexer.ml │ ├── tree_lang_parser.mly │ ├── tree_to_anf.ml │ ├── tree_to_anf.mli │ ├── tree_to_stack.ml │ └── tree_to_stack.mli └── test │ ├── dune │ ├── properties.ml │ └── tests.t ├── compile-arithcond ├── README.md ├── bin │ ├── dune │ └── main.ml ├── dune ├── lib │ ├── anf_lang.ml │ ├── arith_cond.ml │ ├── dune │ ├── stack_lang.ml │ ├── translation.ml │ ├── tree_lang.ml │ ├── tree_lang_lexer.ml │ ├── tree_lang_parser.mly │ ├── tree_to_anf.ml │ ├── tree_to_anf.mli │ ├── tree_to_stack.ml │ └── tree_to_stack.mli └── test │ ├── dune │ ├── properties.ml │ └── tests.t ├── dune ├── dune-project ├── elab-dependent-sugar ├── README.md ├── core.ml ├── dune ├── lexer.ml ├── main.ml ├── parser.mly ├── surface.ml └── test │ ├── dune │ ├── readme │ └── bools.txt │ └── tests.t ├── elab-dependent ├── README.md ├── core.ml ├── dune ├── lexer.ml ├── main.ml ├── parser.mly ├── surface.ml └── test │ ├── dune │ ├── readme │ └── bools.txt │ └── tests.t ├── elab-record-patching ├── README.md ├── core.ml ├── dune ├── examples │ ├── categories.stdout │ ├── categories.txt │ ├── control.stdout │ ├── control.txt │ ├── dune │ ├── dune_inc.ml │ ├── map.stdout │ └── map.txt ├── lexer.ml ├── main.ml ├── parser.mly ├── surface.ml └── test │ ├── dune │ ├── dune_inc.ml │ ├── eta-conversion.stdout │ ├── eta-conversion.txt │ ├── let-ann-check.stdout │ ├── let-ann-check.txt │ ├── let-ann-infer.stdout │ ├── let-ann-infer.txt │ ├── record-field-puns.stdout │ ├── record-field-puns.txt │ ├── record-proj-singleton.stdout │ ├── record-proj-singleton.txt │ ├── records.stdout │ ├── records.txt │ ├── singleton-check-elim.stdout │ ├── singleton-check-elim.txt │ ├── singleton-check-intro.stdout │ └── singleton-check-intro.txt ├── elab-stlc-abstract ├── README.md ├── core.ml ├── core.mli ├── de_bruijn.ml ├── de_bruijn.mli ├── dune ├── lexer.ml ├── main.ml ├── parser.mly ├── surface.ml └── tests │ ├── dune │ ├── id.txt │ ├── term.txt │ └── tests.t ├── elab-stlc-bidirectional-stratify ├── README.md ├── core.ml ├── dune ├── examples │ ├── dune │ ├── dune_inc.ml │ ├── elephant.stdout │ └── elephant.txt ├── lexer.ml ├── main.ml ├── parser.mly ├── prim.ml ├── surface.ml └── tests.t ├── elab-stlc-bidirectional ├── README.md ├── core.ml ├── dune ├── lexer.ml ├── main.ml ├── parser.mly ├── prim.ml ├── surface.ml └── tests.t ├── elab-stlc-letrec-unification ├── README.md ├── core.ml ├── dune ├── examples │ ├── ackermann.stdout │ ├── ackermann.txt │ ├── dune │ ├── dune_inc.ml │ ├── even-odd.stdout │ ├── even-odd.txt │ ├── factorial.stdout │ ├── factorial.txt │ ├── fibonacci.stdout │ └── fibonacci.txt ├── lexer.ml ├── main.ml ├── parser.mly ├── prim.ml ├── surface.ml └── tests.t ├── elab-stlc-row-unification ├── README.md ├── core.ml ├── dune ├── examples │ ├── dune │ ├── dune_inc.ml │ ├── readme.stdout │ └── readme.txt ├── lexer.ml ├── main.ml ├── parser.mly ├── prim.ml ├── surface.ml └── tests.t ├── elab-stlc-unification ├── README.md ├── core.ml ├── dune ├── examples │ ├── dune │ ├── dune_inc.ml │ ├── readme.stdout │ └── readme.txt ├── lexer.ml ├── main.ml ├── parser.mly ├── prim.ml ├── surface.ml └── tests.t ├── elab-system-f-bidirectional ├── README.md ├── core.ml ├── dune ├── examples │ ├── dune │ ├── dune_inc.ml │ ├── readme.stdout │ ├── readme.txt │ ├── self-application.stdout │ └── self-application.txt ├── lexer.ml ├── main.ml ├── parser.mly ├── prim.ml ├── surface.ml └── tests.t ├── elab-system-f-unification ├── README.md ├── core.ml ├── dune ├── examples │ ├── dune │ ├── dune_inc.ml │ ├── readme.stdout │ ├── readme.txt │ ├── self-application.stdout │ └── self-application.txt ├── lexer.ml ├── main.ml ├── parser.mly ├── prim.ml ├── surface.ml └── tests.t ├── flake.lock ├── flake.nix ├── garden.dot ├── garden.svg ├── lang-datalog ├── README.md ├── datalog.ml ├── dune ├── examples │ ├── airline.datalog │ ├── airline.stdout │ ├── dune │ ├── dune_inc.ml │ ├── genealogy.datalog │ ├── genealogy.stdout │ ├── graph.datalog │ ├── graph.stdout │ ├── languages.datalog │ ├── languages.stdout │ ├── zoo.datalog │ └── zoo.stdout ├── lexer.ml ├── main.ml ├── parser.mly └── test │ ├── dune │ ├── test.t │ └── unrestricted-range.datalog ├── lang-declarative-graphics ├── README.md ├── core │ ├── diagram.ml │ ├── diagram.mli │ ├── diagram_intf.ml │ ├── dune │ ├── svg_diagram.ml │ └── svg_diagram.mli ├── examples │ ├── README.md │ ├── dune │ ├── tree.ml │ └── tree.svg └── jsoo │ ├── canvas_diagram.ml │ ├── canvas_diagram.mli │ ├── dune │ ├── svg_diagram.ml │ └── svg_diagram.mli ├── lang-doc-templates ├── README.md ├── core.ml ├── dune ├── lexer.ml ├── main.ml ├── parser.mly ├── prim.ml ├── surface.ml └── test │ ├── article.stdout │ ├── article.txt │ ├── dune │ ├── dune_inc.ml │ ├── escapes.stdout │ ├── escapes.txt │ ├── lists.stdout │ ├── lists.txt │ ├── nested-quotes.stdout │ ├── nested-quotes.txt │ ├── text.stdout │ ├── text.txt │ ├── unquote-let-params.stdout │ ├── unquote-let-params.txt │ ├── unquote-let.stdout │ ├── unquote-let.txt │ ├── unquote-term.stdout │ └── unquote-term.txt ├── lang-fractal-growth ├── README.md ├── bin │ ├── dune │ └── main.ml ├── dune ├── lib │ ├── dune │ ├── system.ml │ └── systems │ │ ├── algae.ml │ │ ├── algae.mli │ │ ├── binary_tree.ml │ │ ├── binary_tree.mli │ │ ├── cantor_set.ml │ │ ├── cantor_set.mli │ │ ├── filament.ml │ │ ├── filament.mli │ │ ├── koch_island.ml │ │ ├── koch_island.mli │ │ ├── monopodial_inflorence.ml │ │ ├── monopodial_inflorence.mli │ │ ├── parametric.ml │ │ └── parametric.mli └── test │ ├── cli.t │ └── dune ├── lang-fractal-tree-rewriting ├── IDEAS.md ├── README.md ├── dune ├── examples │ ├── binary_tree.ml │ ├── examples.ml │ └── examples.mli ├── index.html ├── index.ml └── system │ ├── system.ml │ ├── system.mli │ └── system_intf.ml ├── lang-lc-interpreters ├── README.md ├── dune ├── lexer.ml ├── main.ml ├── named.ml ├── named_nbe_closures.ml ├── named_nbe_hoas.ml ├── nameless.ml ├── nameless_nbe_closures.ml ├── nameless_nbe_hoas.ml ├── parser.mly ├── unique.ml ├── unique_nbe_closures.ml └── unique_nbe_hoas.ml ├── lang-shader-graphics ├── README.md ├── bin │ ├── dune │ └── main.ml ├── dune ├── examples │ ├── basic.ml │ ├── basic.mli │ ├── dune │ ├── readme.ml │ ├── readme.mli │ └── scene.ml ├── lib │ ├── control │ │ ├── applicative.ml │ │ ├── applicative.mli │ │ ├── applicative_intf.ml │ │ ├── control.ml │ │ ├── functor.ml │ │ ├── functor.mli │ │ ├── functor_intf.ml │ │ ├── monad.ml │ │ ├── monad.mli │ │ └── monad_intf.ml │ ├── cpu.ml │ ├── cpu.mli │ ├── data │ │ ├── data.ml │ │ ├── nat.ml │ │ └── vec.ml │ ├── dune │ ├── glsl.ml │ ├── glsl.mli │ ├── sdf.ml │ ├── shader.ml │ └── shader_intf.ml └── test │ ├── basic.glsl │ ├── basic.png │ ├── cli.t │ ├── dune │ ├── readme.glsl │ └── readme.png ├── opam ├── compile-arith.opam ├── compile-arithcond.opam ├── declarative-graphics.opam ├── elab-dependent-sugar.opam ├── elab-dependent.opam ├── elab-record-patching.opam ├── elab-stlc-abstract.opam ├── elab-stlc-bidirectional-stratify.opam ├── elab-stlc-bidirectional.opam ├── elab-stlc-letrec-unification.opam ├── elab-stlc-row-unification.opam ├── elab-stlc-unification.opam ├── elab-stlc-variant-unification.opam ├── elab-system-f-bidirectional.opam ├── elab-system-f-unification.opam ├── lang-datalog.opam ├── lang-declarative-graphics.opam ├── lang-diagrams.opam ├── lang-doc-templates.opam ├── lang-fractal-growth.opam ├── lang-fractal-tree-rewriting.opam ├── lang-lc-interpreters.opam ├── lang-production-systems.opam ├── lang-shader-graphics.opam ├── lang-tree-rewriting.opam ├── scraps.opam ├── wip-compile-closure-conv.opam ├── wip-compile-stlc.opam ├── wip-compile-stratify.opam ├── wip-compile-uncurry.opam ├── wip-elab-builtins.opam └── wip-lang-browser-experiments.opam └── scraps ├── README.md ├── check_dependent.pl ├── check_stlc_bidir.rs ├── check_stlc_inference_rules.ml ├── check_stlc_inference_rules_bidir.ml ├── compile-arith-rust ├── 00-eval-int.rs ├── 01-eval-int-bool.rs ├── 10-compile-int.rs └── README.md ├── compile-arith-verified ├── ArithExprs.lean └── README.md ├── dune ├── elab_stlc_bidir.rs ├── elab_stlc_gadt.ml ├── elab_stlc_gadt_bidir.ml ├── eval_cek.ml ├── eval_control_flow_cps.ml ├── eval_extensible.ml ├── eval_imp.ml ├── eval_landins_knot.ml ├── eval_stlc_gadt.ml ├── eval_stlc_gadt_globals.ml ├── eval_stlc_gadt_values_closures.ml ├── eval_stlc_gadt_values_hoas.ml ├── eval_triple_store.ml ├── eval_unsure_calculator.ml ├── misc_adt_properties.ml ├── misc_ast_folds.ml ├── misc_ast_submodules.ml ├── misc_effects_build_system.ml ├── misc_effects_come_from.ml ├── misc_effects_state.ml ├── misc_isorecursion_vs_equirecursion.ml ├── misc_option_shapes.ml ├── misc_set_objects.ml ├── parse_sexpr.ml ├── wip-compile-closure-conv ├── README.md ├── bin │ ├── dune │ └── main.ml ├── dune ├── lib │ ├── closure_conv.ml │ ├── dune │ ├── fresh.ml │ ├── lang.ml │ ├── lang__clos.ml │ ├── lang__clos_a.ml │ ├── lang__fun.ml │ ├── lang__fun__lexer.ml │ ├── lang__fun__parser.mly │ ├── lang__fun_a.ml │ ├── lang__lifted_a.ml │ ├── prim.ml │ ├── translation.ml │ ├── translation__fun_a_to_clos_a.ml │ ├── translation__fun_a_to_lifted_a.ml │ ├── translation__fun_to_clos.ml │ └── translation__fun_to_fun_a.ml └── test │ ├── capture-nothing.clos.stdout │ ├── capture-nothing.lifted.stdout │ ├── capture-nothing.txt │ ├── capture-simple.clos.stdout │ ├── capture-simple.lifted.stdout │ ├── capture-simple.txt │ ├── capture-with-local-let.clos.stdout │ ├── capture-with-local-let.lifted.stdout │ ├── capture-with-local-let.txt │ ├── dune │ ├── dune_inc.ml │ ├── multiple-captures-1.clos.stdout │ ├── multiple-captures-1.lifted.stdout │ ├── multiple-captures-1.txt │ ├── multiple-captures-2.clos.stdout │ ├── multiple-captures-2.lifted.stdout │ ├── multiple-captures-2.txt │ ├── multiple-captures-3.clos.stdout │ ├── multiple-captures-3.lifted.stdout │ ├── multiple-captures-3.txt │ ├── partial-application-1.clos.stdout │ ├── partial-application-1.lifted.stdout │ ├── partial-application-1.txt │ ├── partial-application-2.clos.stdout │ ├── partial-application-2.lifted.stdout │ └── partial-application-2.txt ├── wip-compile-stlc ├── README.md ├── anf.ml ├── clos.ml ├── core.ml ├── core_to_anf.ml ├── core_to_monadic.ml ├── dune ├── main.ml ├── monadic.ml ├── name.ml ├── prim.ml ├── surface.ml ├── surface_lexer.ml ├── surface_parser.mly └── symbol.ml ├── wip-compile-stratify ├── README.md ├── core.ml ├── core_rules.ml ├── core_rules.mli ├── core_to_stratified.ml ├── core_to_stratified.mli ├── dune ├── env.ml ├── env.mli ├── main.ml └── stratified.ml ├── wip-compile-uncurry ├── README.md ├── dune └── main.ml └── wip-elab-builtins ├── README.md ├── bin ├── dune └── main.ml ├── lib ├── core.ml ├── core_semantics.ml ├── core_semantics.mli ├── core_syntax.ml ├── dune ├── surface.ml ├── surface_elab.ml ├── surface_elab.mli ├── surface_lexer.mll ├── surface_parser.mly └── surface_syntax.ml └── test ├── cli.t ├── dune └── sample.t ├── main.txt └── run.t /.gitattributes: -------------------------------------------------------------------------------- 1 | # Cram is not yet supported by Github's linguist tool, but it is definitely not 2 | # Raku! For more information see https://github.com/github/linguist/issues/1569 3 | *.t linguist-language=Cram 4 | *.pl linguist-language=Prolog 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | -------------------------------------------------------------------------------- /compile-arith/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name arith) 4 | (package compile-arith) 5 | (libraries 6 | compile-arith 7 | cmdliner 8 | menhirLib 9 | sedlex)) 10 | -------------------------------------------------------------------------------- /compile-arith/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package compile-arith) 3 | (deps %{bin:arith})) 4 | -------------------------------------------------------------------------------- /compile-arith/lib/arith.ml: -------------------------------------------------------------------------------- 1 | (** {0 A compiler for arithmetic expressions} *) 2 | 3 | (** {1 Intermediate languages} *) 4 | 5 | (** Nested arithmetic expressions *) 6 | module Tree_lang = struct 7 | include Tree_lang 8 | 9 | module Lexer = Tree_lang_lexer 10 | module Parser = Tree_lang_parser 11 | end 12 | 13 | (** Stack machine language *) 14 | module Stack_lang = Stack_lang 15 | 16 | (** A-Normal form *) 17 | module Anf_lang = Anf_lang 18 | 19 | 20 | (** {1 Compilation} *) 21 | 22 | module Translation = Translation 23 | 24 | module Tree_to_stack = Tree_to_stack 25 | module Tree_to_anf = Tree_to_anf 26 | -------------------------------------------------------------------------------- /compile-arith/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name arith) 3 | (public_name compile-arith) 4 | (preprocess 5 | (pps sedlex.ppx))) 6 | 7 | (menhir 8 | (modules tree_lang_parser)) 9 | -------------------------------------------------------------------------------- /compile-arith/lib/translation.ml: -------------------------------------------------------------------------------- 1 | (** A translation pass between two languages *) 2 | module type S = sig 3 | 4 | (** The source language *) 5 | type source 6 | 7 | (** The target language *) 8 | type target 9 | 10 | (** The translation pass between the {!source} and {!target} languages *) 11 | val translate : source -> target 12 | 13 | end 14 | -------------------------------------------------------------------------------- /compile-arith/lib/tree_lang.ml: -------------------------------------------------------------------------------- 1 | (** {0 Arithmetic expressions} 2 | 3 | Arithmetic expressions as a tree of nested subexpressions. 4 | *) 5 | 6 | 7 | (** {1 Syntax of arithmetic expressions} *) 8 | 9 | (** Expressions *) 10 | type expr = 11 | | Int of int 12 | | Neg of expr 13 | | Add of expr * expr 14 | | Sub of expr * expr 15 | | Mul of expr * expr 16 | | Div of expr * expr 17 | 18 | (** {2 Constructor functions} *) 19 | 20 | let int i = Int i 21 | let neg e = Neg e 22 | let add e1 e2 = Add (e1, e2) 23 | let sub e1 e2 = Sub (e1, e2) 24 | let mul e1 e2 = Mul (e1, e2) 25 | let div e1 e2 = Div (e1, e2) 26 | 27 | 28 | (** {1 Pretty printing} *) 29 | 30 | let rec pp_expr ppf expr = 31 | pp_add_expr ppf expr 32 | and pp_add_expr ppf = function 33 | | Add (e1, e2) -> Format.fprintf ppf "%a@ +@ %a" pp_mul_expr e1 pp_add_expr e2 34 | | Sub (e1, e2) -> Format.fprintf ppf "%a@ -@ %a" pp_mul_expr e1 pp_add_expr e2 35 | | e -> pp_mul_expr ppf e 36 | and pp_mul_expr ppf = function 37 | | Mul (e1, e2) -> Format.fprintf ppf "%a@ *@ %a" pp_atomic_expr e1 pp_mul_expr e2 38 | | Div (e1, e2) -> Format.fprintf ppf "%a@ /@ %a" pp_atomic_expr e1 pp_mul_expr e2 39 | | e -> pp_atomic_expr ppf e 40 | and pp_atomic_expr ppf = function 41 | | Int i -> Format.fprintf ppf "%d" i 42 | | Neg e -> Format.fprintf ppf "-%a" pp_atomic_expr e 43 | | e -> Format.fprintf ppf "@[<1>(%a)@]" pp_expr e 44 | 45 | 46 | (** Semantics of arithmetic expressions *) 47 | module Semantics = struct 48 | 49 | type value = int 50 | 51 | let rec eval : expr -> value = 52 | function 53 | | Int i -> i 54 | | Neg e -> -(eval e) 55 | | Add (e1, e2) -> eval e1 + eval e2 56 | | Sub (e1, e2) -> eval e1 - eval e2 57 | | Mul (e1, e2) -> eval e1 * eval e2 58 | | Div (e1, e2) -> eval e1 / eval e2 59 | 60 | end 61 | -------------------------------------------------------------------------------- /compile-arith/lib/tree_lang_lexer.ml: -------------------------------------------------------------------------------- 1 | exception Error 2 | 3 | let whitespace = [%sedlex.regexp? Plus (' ' | '\t' | '\r' | '\n')] 4 | let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"] 5 | let digits = [%sedlex.regexp? Plus ('0'..'9')] 6 | 7 | let rec token (lexbuf : Sedlexing.lexbuf) : Tree_lang_parser.token = 8 | match%sedlex lexbuf with 9 | | whitespace -> token lexbuf 10 | | "#" -> line_comment lexbuf 11 | | digits -> NUMBER (int_of_string (Sedlexing.Utf8.lexeme lexbuf)) 12 | | "+" -> ADD 13 | | "*" -> ASTERISK 14 | | "/" -> FORWARD_SLASH 15 | | "-" -> HYPHEN 16 | | "(" -> OPEN_PAREN 17 | | ")" -> CLOSE_PAREN 18 | | eof -> END 19 | | _ -> raise Error 20 | 21 | and line_comment (lexbuf : Sedlexing.lexbuf) : Tree_lang_parser.token = 22 | match%sedlex lexbuf with 23 | | newline -> token lexbuf 24 | | any -> line_comment lexbuf 25 | | eof -> END 26 | | _ -> raise Error 27 | -------------------------------------------------------------------------------- /compile-arith/lib/tree_lang_parser.mly: -------------------------------------------------------------------------------- 1 | %token NUMBER 2 | %token ADD "+" 3 | %token ASTERISK "*" 4 | %token FORWARD_SLASH "/" 5 | %token HYPHEN "-" 6 | %token OPEN_PAREN "(" 7 | %token CLOSE_PAREN ")" 8 | %token END 9 | 10 | %start main 11 | 12 | %% 13 | 14 | let main := 15 | | e = expr; END; 16 | { e } 17 | 18 | let expr := 19 | | add_expr 20 | 21 | let add_expr := 22 | | e1 = mul_expr; "+"; e2 = add_expr; 23 | { Tree_lang.add e1 e2 } 24 | | e1 = mul_expr; "-"; e2 = add_expr; 25 | { Tree_lang.sub e1 e2 } 26 | | mul_expr 27 | 28 | let mul_expr := 29 | | e1 = atomic_expr; "*"; e2 = mul_expr; 30 | { Tree_lang.mul e1 e2 } 31 | | e1 = atomic_expr; "/"; e2 = mul_expr; 32 | { Tree_lang.div e1 e2 } 33 | | atomic_expr 34 | 35 | let atomic_expr := 36 | | "("; e = expr; ")"; 37 | { e } 38 | | i = NUMBER; 39 | { Tree_lang.int i } 40 | | "-"; e = atomic_expr; 41 | { Tree_lang.neg e } 42 | -------------------------------------------------------------------------------- /compile-arith/lib/tree_to_anf.mli: -------------------------------------------------------------------------------- 1 | (** Translation pass between the {!Tree_lang} and {!Anf_lang} *) 2 | 3 | 4 | (** Translate from an arithmetic expression to an ANF expression *) 5 | include Translation.S 6 | with type source = Tree_lang.expr 7 | with type target = Anf_lang.expr 8 | 9 | 10 | (** An environment for constructing ANF expressions *) 11 | module Env : sig 12 | 13 | (** An effectful computation *) 14 | type 'a t 15 | 16 | (** Embed a pure value in a computation *) 17 | val pure : 'a. 'a -> 'a t 18 | 19 | (** Apply the result of a computation to a function *) 20 | val bind : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t 21 | 22 | 23 | (** The type of the continuation *) 24 | type 'a cont = 'a -> Anf_lang.expr 25 | 26 | (** Construct a continuation-passing computation from a function *) 27 | val embed : 'a. 'a cont cont -> 'a t 28 | 29 | (** Run a continuation-passing computation with a final continuation, 30 | returning the result. This is the inverse of {!embed}. *) 31 | val run : 'a. 'a t -> 'a cont cont 32 | 33 | 34 | (** Translate from an arithmetic expression to a computation that constructs 35 | an ANF expression with a continuation. *) 36 | include Translation.S 37 | with type source = Tree_lang.expr 38 | with type target = Anf_lang.comp t 39 | 40 | end 41 | -------------------------------------------------------------------------------- /compile-arith/lib/tree_to_stack.ml: -------------------------------------------------------------------------------- 1 | type source = Tree_lang.expr 2 | type target = Stack_lang.code 3 | 4 | 5 | (** Function composition *) 6 | let ( << ) f g x = f (g x) 7 | 8 | (** Translate an expression, adding it to the continuation of the expression. 9 | The continuation allows us to avoid using list concatenation, which could 10 | lead to exponential blowups during compilation. *) 11 | let rec translate_code : Tree_lang.expr -> Stack_lang.code -> Stack_lang.code = 12 | function 13 | | Tree_lang.Int i -> List.cons (Stack_lang.Int i) 14 | | Tree_lang.Neg e -> translate_code e << List.cons Stack_lang.Neg 15 | | Tree_lang.Add (e1, e2) -> translate_code e1 << translate_code e2 << List.cons Stack_lang.Add 16 | | Tree_lang.Sub (e1, e2) -> translate_code e1 << translate_code e2 << List.cons Stack_lang.Sub 17 | | Tree_lang.Mul (e1, e2) -> translate_code e1 << translate_code e2 << List.cons Stack_lang.Mul 18 | | Tree_lang.Div (e1, e2) -> translate_code e1 << translate_code e2 << List.cons Stack_lang.Div 19 | 20 | 21 | let translate (e : Tree_lang.expr) : Stack_lang.code = 22 | translate_code e [] 23 | -------------------------------------------------------------------------------- /compile-arith/lib/tree_to_stack.mli: -------------------------------------------------------------------------------- 1 | (** Translation pass between the {!Tree_lang} and {!Stack_lang} *) 2 | 3 | include Translation.S 4 | with type source = Tree_lang.expr 5 | with type target = Stack_lang.code 6 | -------------------------------------------------------------------------------- /compile-arith/test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (package compile-arith) 3 | (deps %{bin:arith})) 4 | 5 | (tests 6 | (names properties) 7 | (package compile-arith) 8 | (libraries 9 | compile-arith 10 | alcotest 11 | menhirLib 12 | qcheck 13 | qcheck-core 14 | qcheck-alcotest 15 | sedlex)) 16 | -------------------------------------------------------------------------------- /compile-arithcond/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name arithcond) 4 | (package compile-arithcond) 5 | (libraries 6 | compile-arithcond 7 | cmdliner 8 | menhirLib 9 | sedlex)) 10 | -------------------------------------------------------------------------------- /compile-arithcond/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package compile-arithcond) 3 | (deps %{bin:arithcond})) 4 | -------------------------------------------------------------------------------- /compile-arithcond/lib/arith_cond.ml: -------------------------------------------------------------------------------- 1 | (** {0 A compiler for arithmetic expressions} *) 2 | 3 | (** {1 Intermediate languages} *) 4 | 5 | (** Nested arithmetic expressions *) 6 | module Tree_lang = struct 7 | include Tree_lang 8 | 9 | module Lexer = Tree_lang_lexer 10 | module Parser = Tree_lang_parser 11 | end 12 | 13 | (** Stack machine language *) 14 | module Stack_lang = Stack_lang 15 | 16 | (** A-Normal form *) 17 | module Anf_lang = Anf_lang 18 | 19 | 20 | (** {1 Compilation} *) 21 | 22 | module Translation = Translation 23 | 24 | module Tree_to_stack = Tree_to_stack 25 | module Tree_to_anf = Tree_to_anf 26 | -------------------------------------------------------------------------------- /compile-arithcond/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name arith_cond) 3 | (public_name compile-arithcond) 4 | (preprocess 5 | (pps sedlex.ppx))) 6 | 7 | (menhir 8 | (modules tree_lang_parser)) 9 | -------------------------------------------------------------------------------- /compile-arithcond/lib/translation.ml: -------------------------------------------------------------------------------- 1 | (** A translation pass between two languages *) 2 | module type S = sig 3 | 4 | (** The source language *) 5 | type source 6 | 7 | (** The target language *) 8 | type target 9 | 10 | (** The translation pass between the {!source} and {!target} languages *) 11 | val translate : source -> target 12 | 13 | end 14 | -------------------------------------------------------------------------------- /compile-arithcond/lib/tree_lang_lexer.ml: -------------------------------------------------------------------------------- 1 | exception Error 2 | 3 | let whitespace = [%sedlex.regexp? Plus (' ' | '\t' | '\r' | '\n')] 4 | let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"] 5 | let digits = [%sedlex.regexp? Plus ('0'..'9')] 6 | 7 | let name_start = [%sedlex.regexp? 'a'..'z' | 'A'..'Z'] 8 | let name_continue = [%sedlex.regexp? '-' | '_' | 'a'..'z' | 'A'..'Z' | '0'..'9'] 9 | let name = [%sedlex.regexp? name_start, Star name_continue] 10 | 11 | let rec token (lexbuf : Sedlexing.lexbuf) : Tree_lang_parser.token = 12 | match%sedlex lexbuf with 13 | | whitespace -> token lexbuf 14 | | "#" -> line_comment lexbuf 15 | | digits -> NUMBER (int_of_string (Sedlexing.Utf8.lexeme lexbuf)) 16 | | "else" -> KEYWORD_ELSE 17 | | "false" -> KEYWORD_FALSE 18 | | "if" -> KEYWORD_IF 19 | | "let" -> KEYWORD_LET 20 | | "then" -> KEYWORD_THEN 21 | | "true" -> KEYWORD_TRUE 22 | | name -> NAME (Sedlexing.Utf8.lexeme lexbuf) 23 | | "+" -> ADD 24 | | "*" -> ASTERISK 25 | | ":=" -> COLON_EQUALS 26 | | "=" -> EQUALS 27 | | "/" -> FORWARD_SLASH 28 | | "-" -> HYPHEN 29 | | ";" -> SEMICOLON 30 | | "(" -> OPEN_PAREN 31 | | ")" -> CLOSE_PAREN 32 | | eof -> END 33 | | _ -> raise Error 34 | 35 | and line_comment (lexbuf : Sedlexing.lexbuf) : Tree_lang_parser.token = 36 | match%sedlex lexbuf with 37 | | newline -> token lexbuf 38 | | any -> line_comment lexbuf 39 | | eof -> END 40 | | _ -> raise Error 41 | -------------------------------------------------------------------------------- /compile-arithcond/lib/tree_to_anf.mli: -------------------------------------------------------------------------------- 1 | (** Translation pass between the {!Tree_lang} and {!Anf_lang} *) 2 | 3 | 4 | (** Translate from an arithmetic expression to an ANF expression *) 5 | include Translation.S 6 | with type source = Tree_lang.expr 7 | with type target = Anf_lang.expr 8 | 9 | 10 | (** An environment for constructing ANF expressions *) 11 | module Env : sig 12 | 13 | (** An effectful computation *) 14 | type 'a t 15 | 16 | (** Embed a pure value in a computation *) 17 | val pure : 'a. 'a -> 'a t 18 | 19 | (** Apply the result of a computation to a function *) 20 | val bind : 'a 'b. 'a t -> ('a -> 'b t) -> 'b t 21 | 22 | 23 | (** An environment for mapping bindings in the tree language to atomic 24 | expressions in the ANF language. *) 25 | type env 26 | 27 | (** Any empty environment with no bindings. *) 28 | val empty : env 29 | 30 | (** The type of the continuation *) 31 | type 'a cont = env -> 'a -> Anf_lang.expr 32 | 33 | (** Construct a continuation-passing computation from a function *) 34 | val embed : 'a. 'a cont cont -> 'a t 35 | 36 | (** Run a continuation-passing computation with a final continuation, 37 | returning the result. This is the inverse of {!embed}. *) 38 | val run : 'a. 'a t -> 'a cont cont 39 | 40 | (** Access the current environment *) 41 | val get_env : env t 42 | 43 | (** Get the atom bound for the given variable in the tree language *) 44 | val get_var : Tree_lang.index -> Anf_lang.atom t 45 | 46 | 47 | (** Translate from an arithmetic expression to a computation that constructs 48 | an ANF expression with a continuation. *) 49 | include Translation.S 50 | with type source = Tree_lang.expr 51 | with type target = Anf_lang.comp t 52 | 53 | end 54 | -------------------------------------------------------------------------------- /compile-arithcond/lib/tree_to_stack.ml: -------------------------------------------------------------------------------- 1 | type source = Tree_lang.expr 2 | type target = Stack_lang.code 3 | 4 | 5 | (** Function composition *) 6 | let ( << ) f g x = f (g x) 7 | 8 | (** Translate an expression, adding it to the continuation of the expression. 9 | The continuation allows us to avoid using list concatenation, which could 10 | lead to exponential blowups during compilation. *) 11 | let rec translate_code : Tree_lang.expr -> Stack_lang.code -> Stack_lang.code = 12 | function 13 | | Tree_lang.Var n -> List.cons (Stack_lang.Access n) 14 | | Tree_lang.Let (_, e1, e2) -> 15 | translate_code e1 16 | << List.cons Stack_lang.Begin_let 17 | << translate_code e2 18 | << List.cons Stack_lang.End_let 19 | | Tree_lang.Int i -> List.cons (Stack_lang.Int i) 20 | | Tree_lang.Bool b -> List.cons (Stack_lang.Bool b) 21 | | Tree_lang.Neg e -> translate_code e << List.cons Stack_lang.Neg 22 | | Tree_lang.Add (e1, e2) -> translate_code e1 << translate_code e2 << List.cons Stack_lang.Add 23 | | Tree_lang.Sub (e1, e2) -> translate_code e1 << translate_code e2 << List.cons Stack_lang.Sub 24 | | Tree_lang.Mul (e1, e2) -> translate_code e1 << translate_code e2 << List.cons Stack_lang.Mul 25 | | Tree_lang.Div (e1, e2) -> translate_code e1 << translate_code e2 << List.cons Stack_lang.Div 26 | | Tree_lang.Eq (e1, e2) -> translate_code e1 << translate_code e2 << List.cons Stack_lang.Eq 27 | | Tree_lang.If_then_else(e1, e2, e3) -> 28 | translate_code e1 29 | << List.cons (Stack_lang.Code (translate_code e2 [])) 30 | << List.cons (Stack_lang.Code (translate_code e3 [])) 31 | << List.cons Stack_lang.If_then_else 32 | 33 | 34 | let translate (e : Tree_lang.expr) : Stack_lang.code = 35 | translate_code e [] 36 | -------------------------------------------------------------------------------- /compile-arithcond/lib/tree_to_stack.mli: -------------------------------------------------------------------------------- 1 | (** Translation pass between the {!Tree_lang} and {!Stack_lang} *) 2 | 3 | include Translation.S 4 | with type source = Tree_lang.expr 5 | with type target = Stack_lang.code 6 | -------------------------------------------------------------------------------- /compile-arithcond/test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (package compile-arithcond) 3 | (deps %{bin:arithcond})) 4 | 5 | (tests 6 | (names properties) 7 | (package compile-arithcond) 8 | (libraries 9 | compile-arithcond 10 | alcotest 11 | menhirLib 12 | qcheck 13 | qcheck-core 14 | qcheck-alcotest 15 | sedlex)) 16 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (deps garden.dot) 3 | (action 4 | (with-stdout-to garden.svg.tmp 5 | (run dot -Tsvg garden.dot)))) 6 | 7 | (rule 8 | (alias all) 9 | (action 10 | (cmp garden.svg garden.svg.tmp))) 11 | -------------------------------------------------------------------------------- /elab-dependent-sugar/README.md: -------------------------------------------------------------------------------- 1 | # A small dependently typed language 2 | 3 | - Extends [**elab-dependent**](../elab-dependent) (+ syntax sugar) 4 | 5 | --- 6 | 7 | This is a variant of the [elab-dependent](../elab-dependent/) project with 8 | fancier syntactic sugar for functions and let bindings. See that project’s 9 | README for more details and resources. 10 | 11 | ## Example 12 | 13 | 14 | ``` 15 | let Bool := fun (Out : Type) (true : Out) (false : Out) -> Out; 16 | let true : Bool := fun Out true false => true; 17 | let false : Bool := fun Out true false => false; 18 | 19 | let not (b : Bool) : Bool := 20 | fun (Out : Type) (true : Out) (false : Out) => b Out false true; 21 | 22 | true Bool false 23 | ``` 24 | 25 | ```sh 26 | $ cat ./test/readme/bools.txt | dependent-sugar norm 27 | : 28 | fun (false : fun (Out : Type) (true : Out) (false : Out) -> Out) 29 | (Out : Type) (true : Out) (false : Out) -> Out 30 | := fun false Out true false => false 31 | ``` 32 | -------------------------------------------------------------------------------- /elab-dependent-sugar/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name dependent-sugar) 4 | (package elab-dependent-sugar) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | cmdliner 9 | menhirLib 10 | sedlex)) 11 | 12 | (menhir 13 | (modules parser) 14 | (flags --explain --strict)) 15 | 16 | (mdx 17 | (package elab-dependent-sugar) 18 | (deps %{bin:dependent})) 19 | -------------------------------------------------------------------------------- /elab-dependent-sugar/lexer.ml: -------------------------------------------------------------------------------- 1 | exception Error of [ 2 | | `Unexpected_char 3 | | `Unclosed_block_comment 4 | ] 5 | 6 | let whitespace = [%sedlex.regexp? Plus (' ' | '\t' | '\r' | '\n')] 7 | let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"] 8 | 9 | let name_start = [%sedlex.regexp? 'a'..'z' | 'A'..'Z'] 10 | let name_continue = [%sedlex.regexp? '-' | '_' | 'a'..'z' | 'A'..'Z' | '0'..'9'] 11 | let name = [%sedlex.regexp? name_start, Star name_continue] 12 | 13 | let rec token (lexbuf : Sedlexing.lexbuf) : Parser.token = 14 | match%sedlex lexbuf with 15 | | whitespace -> token lexbuf 16 | | "--" -> line_comment lexbuf 17 | | "/-" -> block_comment lexbuf 0 18 | | "_" -> UNDERSCORE 19 | | "fun" -> KEYWORD_FUN 20 | | "let" -> KEYWORD_LET 21 | | "Type" -> KEYWORD_TYPE 22 | | name -> NAME (Sedlexing.Utf8.lexeme lexbuf) 23 | | ":" -> COLON 24 | | ":=" -> COLON_EQUALS 25 | | "=>" -> EQUALS_GREATER 26 | | "->" -> HYPHEN_GREATER 27 | | ";" -> SEMICOLON 28 | | "(" -> LPAREN 29 | | ")" -> RPAREN 30 | | eof -> END 31 | | _ -> raise (Error `Unexpected_char) 32 | 33 | and line_comment (lexbuf : Sedlexing.lexbuf) : Parser.token = 34 | match%sedlex lexbuf with 35 | | newline -> token lexbuf 36 | | any -> line_comment lexbuf 37 | | eof -> END 38 | | _ -> raise (Error `Unexpected_char) 39 | 40 | and block_comment (lexbuf : Sedlexing.lexbuf) (level : int) : Parser.token = 41 | match%sedlex lexbuf with 42 | | "/-" -> block_comment lexbuf (level + 1) 43 | | "-/" -> if level = 0 then token lexbuf else block_comment lexbuf (level - 1) 44 | | any -> block_comment lexbuf level 45 | | eof -> raise (Error `Unclosed_block_comment) 46 | | _ -> raise (Error `Unexpected_char) 47 | -------------------------------------------------------------------------------- /elab-dependent-sugar/parser.mly: -------------------------------------------------------------------------------- 1 | %token UNDERSCORE "_" 2 | %token KEYWORD_FUN "fun" 3 | %token KEYWORD_LET "let" 4 | %token KEYWORD_TYPE "Type" 5 | %token NAME 6 | %token COLON ":" 7 | %token COLON_EQUALS ":=" 8 | %token EQUALS_GREATER "=>" 9 | %token HYPHEN_GREATER "->" 10 | %token SEMICOLON ";" 11 | 12 | %token LPAREN "(" 13 | %token RPAREN ")" 14 | 15 | %token END 16 | 17 | %start main 18 | 19 | %% 20 | 21 | let main := 22 | | t = located(tm); END; 23 | { t } 24 | 25 | 26 | (* Terms *) 27 | 28 | let tm := 29 | | "let"; p = located(pattern); ps = list(param); t1 = option(":"; t1 = located(tm); { t1 }); ":="; 30 | t2 = located(tm); ";"; t3 = located(tm); 31 | { Surface.Let (p, ps, t1, t2, t3) } 32 | | t1 = located(app_tm); ":"; t2 = located(tm); 33 | { Surface.Ann (t1, t2) } 34 | | t1 = located(app_tm); "->"; t2 = located(tm); 35 | { Surface.Fun_arrow (t1, t2) } 36 | | "fun"; ps = nonempty_list(param); "->"; t = located(tm); 37 | { Surface.Fun_type (ps, t) } 38 | | "fun"; ps = nonempty_list(param); t1 = option(":"; t1 = located(tm); { t1 }); "=>"; t2 = located(tm); 39 | { Surface.Fun_lit (ps, t1, t2) } 40 | | app_tm 41 | 42 | let app_tm := 43 | | t = located(atomic_tm); ts = nonempty_list(located(atomic_tm)); 44 | { Surface.Fun_app (t, ts) } 45 | | atomic_tm 46 | 47 | let atomic_tm := 48 | | n = NAME; 49 | { Surface.Name n } 50 | | "Type"; 51 | { Surface.Univ } 52 | | "("; t = tm; ")"; 53 | { t } 54 | 55 | 56 | (* Binders *) 57 | 58 | let pattern := 59 | | "_"; 60 | { None } 61 | | n = NAME; 62 | { Some n } 63 | 64 | let param := 65 | | "("; p = located(pattern); ":"; t = located(tm); ")"; 66 | { p, Some t } 67 | | p = located(pattern); 68 | { p, None } 69 | 70 | 71 | (* Utilities *) 72 | 73 | let located(X) := 74 | | data = X; 75 | { Surface.{ loc = $loc; data } } 76 | 77 | let nonempty_sequence(T) := 78 | | t = T; option(";"); 79 | { [ t ] } 80 | | t = T; ";"; ts = nonempty_sequence(T); 81 | { t :: ts } 82 | -------------------------------------------------------------------------------- /elab-dependent-sugar/test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (package elab-dependent-sugar) 3 | (deps %{bin:dependent-sugar})) 4 | -------------------------------------------------------------------------------- /elab-dependent-sugar/test/readme/bools.txt: -------------------------------------------------------------------------------- 1 | let Bool := fun (Out : Type) (true : Out) (false : Out) -> Out; 2 | let true : Bool := fun Out true false => true; 3 | let false : Bool := fun Out true false => false; 4 | 5 | let not (b : Bool) : Bool := 6 | fun (Out : Type) (true : Out) (false : Out) => b Out false true; 7 | 8 | true Bool false 9 | -------------------------------------------------------------------------------- /elab-dependent/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name dependent) 4 | (package elab-dependent) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | cmdliner 9 | menhirLib 10 | sedlex)) 11 | 12 | (menhir 13 | (modules parser) 14 | (flags --explain --strict)) 15 | 16 | (mdx 17 | (package elab-dependent) 18 | (deps %{bin:dependent})) 19 | -------------------------------------------------------------------------------- /elab-dependent/lexer.ml: -------------------------------------------------------------------------------- 1 | exception Error of [ 2 | | `Unexpected_char 3 | | `Unclosed_block_comment 4 | ] 5 | 6 | let whitespace = [%sedlex.regexp? Plus (' ' | '\t' | '\r' | '\n')] 7 | let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"] 8 | 9 | let name_start = [%sedlex.regexp? 'a'..'z' | 'A'..'Z'] 10 | let name_continue = [%sedlex.regexp? '-' | '_' | 'a'..'z' | 'A'..'Z' | '0'..'9'] 11 | let name = [%sedlex.regexp? name_start, Star name_continue] 12 | 13 | let rec token (lexbuf : Sedlexing.lexbuf) : Parser.token = 14 | match%sedlex lexbuf with 15 | | whitespace -> token lexbuf 16 | | "--" -> line_comment lexbuf 17 | | "/-" -> block_comment lexbuf 0 18 | | "_" -> UNDERSCORE 19 | | "fun" -> KEYWORD_FUN 20 | | "let" -> KEYWORD_LET 21 | | "Type" -> KEYWORD_TYPE 22 | | name -> NAME (Sedlexing.Utf8.lexeme lexbuf) 23 | | ":" -> COLON 24 | | ":=" -> COLON_EQUALS 25 | | "=>" -> EQUALS_GREATER 26 | | "->" -> HYPHEN_GREATER 27 | | ";" -> SEMICOLON 28 | | "(" -> LPAREN 29 | | ")" -> RPAREN 30 | | eof -> END 31 | | _ -> raise (Error `Unexpected_char) 32 | 33 | and line_comment (lexbuf : Sedlexing.lexbuf) : Parser.token = 34 | match%sedlex lexbuf with 35 | | newline -> token lexbuf 36 | | any -> line_comment lexbuf 37 | | eof -> END 38 | | _ -> raise (Error `Unexpected_char) 39 | 40 | and block_comment (lexbuf : Sedlexing.lexbuf) (level : int) : Parser.token = 41 | match%sedlex lexbuf with 42 | | "/-" -> block_comment lexbuf (level + 1) 43 | | "-/" -> if level = 0 then token lexbuf else block_comment lexbuf (level - 1) 44 | | any -> block_comment lexbuf level 45 | | eof -> raise (Error `Unclosed_block_comment) 46 | | _ -> raise (Error `Unexpected_char) 47 | -------------------------------------------------------------------------------- /elab-dependent/parser.mly: -------------------------------------------------------------------------------- 1 | %token UNDERSCORE "_" 2 | %token KEYWORD_FUN "fun" 3 | %token KEYWORD_LET "let" 4 | %token KEYWORD_TYPE "Type" 5 | %token NAME 6 | %token COLON ":" 7 | %token COLON_EQUALS ":=" 8 | %token EQUALS_GREATER "=>" 9 | %token HYPHEN_GREATER "->" 10 | %token SEMICOLON ";" 11 | 12 | %token LPAREN "(" 13 | %token RPAREN ")" 14 | 15 | %token END 16 | 17 | %start main 18 | 19 | %% 20 | 21 | let main := 22 | | t = located(tm); END; 23 | { t } 24 | 25 | 26 | (* Terms *) 27 | 28 | let tm := 29 | | "let"; p = located(pattern); ":"; t1 = located(tm); ":="; t2 = located(tm); ";"; t3 = located(tm); 30 | { Surface.Let (p, t1, t2, t3) } 31 | | t1 = located(app_tm); ":"; t2 = located(tm); 32 | { Surface.Ann (t1, t2) } 33 | | t1 = located(app_tm); "->"; t2 = located(tm); 34 | { Surface.Fun_arrow (t1, t2) } 35 | | "fun"; ps = nonempty_list(param); "->"; t = located(tm); 36 | { Surface.Fun_type (ps, t) } 37 | | "fun"; ps = nonempty_list(located(pattern)); "=>"; t = located(tm); 38 | { Surface.Fun_lit (ps, t) } 39 | | app_tm 40 | 41 | let app_tm := 42 | | t = located(atomic_tm); ts = nonempty_list(located(atomic_tm)); 43 | { Surface.Fun_app (t, ts) } 44 | | atomic_tm 45 | 46 | let atomic_tm := 47 | | n = NAME; 48 | { Surface.Name n } 49 | | "Type"; 50 | { Surface.Univ } 51 | | "("; t = tm; ")"; 52 | { t } 53 | 54 | 55 | (* Binders *) 56 | 57 | let pattern := 58 | | "_"; 59 | { None } 60 | | n = NAME; 61 | { Some n } 62 | 63 | let param := 64 | | "("; p = located(pattern); ":"; t = located(tm); ")"; 65 | { p, t } 66 | 67 | 68 | (* Utilities *) 69 | 70 | let located(X) := 71 | | data = X; 72 | { Surface.{ loc = $loc; data } } 73 | -------------------------------------------------------------------------------- /elab-dependent/test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (package elab-dependent) 3 | (deps %{bin:dependent})) 4 | -------------------------------------------------------------------------------- /elab-dependent/test/readme/bools.txt: -------------------------------------------------------------------------------- 1 | let Bool : Type := fun (Out : Type) (true : Out) (false : Out) -> Out; 2 | let true : Bool := fun Out true false => true; 3 | let false : Bool := fun Out true false => false; 4 | 5 | let not : Bool -> Bool := fun b => 6 | fun Out true false => b Out false true; 7 | 8 | true Bool false 9 | -------------------------------------------------------------------------------- /elab-record-patching/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name record-patching) 4 | (package elab-record-patching) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | cmdliner 9 | menhirLib 10 | sedlex)) 11 | 12 | (menhir 13 | (modules parser) 14 | (flags --explain --strict)) 15 | -------------------------------------------------------------------------------- /elab-record-patching/examples/categories.stdout: -------------------------------------------------------------------------------- 1 | : Type := 2 | let Category : Type := 3 | { 4 | Ob : Type; 5 | Hom : fun (_ : { S : Ob; T : Ob }) -> Type; 6 | id : fun (A : Ob) -> Hom { S := A; T := A }; 7 | seq : 8 | fun (A : Ob) (B : Ob) (C : Ob) (f : Hom { S := A; T := B }) 9 | (g : Hom { S := B; T := C }) -> Hom { S := A; T := C } 10 | }; 11 | let types : Category := 12 | { 13 | Ob := Type; 14 | Hom := fun params => fun (_ : params.S) -> params.T; 15 | id := fun A a => a; 16 | seq := fun A B C f g a => g (f a) 17 | }; 18 | Type 19 | -------------------------------------------------------------------------------- /elab-record-patching/examples/categories.txt: -------------------------------------------------------------------------------- 1 | let Category := { 2 | Ob : Type; 3 | Hom : { S : Ob; T : Ob } -> Type; 4 | 5 | -- TODO: requires total space conversion like in CoolTT 6 | -- id : fun (A : Ob) -> Hom [ S := A; T := A ]; 7 | -- seq : fun (f : Hom) (g : Hom [ S := f.T ]) -> Hom [ S := f.S; T := g.T ]; 8 | 9 | id : fun (A : Ob) -> Hom { S := A; T := A }; 10 | seq : fun (A : Ob) (B : Ob) (C : Ob) 11 | (f : Hom { S := A; T := B }) 12 | (g : Hom { S := B; T := C }) 13 | -> Hom { S := A; T := C }; 14 | }; 15 | 16 | let types : Category := { 17 | Ob := Type; 18 | Hom := fun params => params.S -> params.T; 19 | id A a := a; 20 | seq A B C f g a := g (f a); 21 | }; 22 | 23 | Type 24 | -------------------------------------------------------------------------------- /elab-record-patching/examples/control.txt: -------------------------------------------------------------------------------- 1 | let Functor := { 2 | T : Type -> Type; 3 | map : fun (A : Type) (B : Type) -> (A -> B) -> T A -> T B; 4 | }; 5 | 6 | let Applicative := { 7 | T : Type -> Type; 8 | functor : Functor [ T := T ]; 9 | pure : fun (A : Type) -> A -> T A; 10 | apply : fun (A : Type) (B : Type) -> T (A -> B) -> T A -> T B; 11 | }; 12 | 13 | let Monad := { 14 | T : Type -> Type; 15 | applicative : Applicative [ T := T ]; 16 | flat-map : fun (A : Type) (B : Type) -> (A -> T B) -> T A -> T B; 17 | }; 18 | 19 | 20 | let Option (A : Type) : Type := 21 | fun (Out : Type) -> { some : A -> Out; none : Out } -> Out; 22 | 23 | let none (A : Type) : Option A := 24 | fun Out cases => cases.none; 25 | let some (A : Type) (a : A) : Option A := 26 | fun Out cases => cases.some a; 27 | 28 | let option-functor : Functor := { 29 | T := Option; 30 | map A B f opt-A := 31 | opt-A (Option B) { 32 | some x := some B (f x); 33 | none := none B; 34 | }; 35 | }; 36 | 37 | let option-applicative : Applicative := { 38 | T := Option; 39 | functor := option-functor; 40 | pure := some; 41 | apply A B opt-f opt-A := 42 | opt-f (Option B) { 43 | some f := option-functor.map A B f opt-A; 44 | none := none B; 45 | }; 46 | }; 47 | 48 | let option-monad : Monad := { 49 | T := Option; 50 | applicative := option-applicative; 51 | flat-map A B f opt-A := 52 | opt-A (Option B) { 53 | some := f; 54 | none := none B; 55 | }; 56 | }; 57 | 58 | 59 | Type 60 | -------------------------------------------------------------------------------- /elab-record-patching/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name dune_inc)) 3 | 4 | (subdir run 5 | (dynamic_include ../generate/dune.inc)) 6 | 7 | (subdir generate 8 | (rule 9 | (deps (glob_files ../*.txt)) 10 | (action 11 | (with-stdout-to dune.inc 12 | (run ../dune_inc.exe))))) 13 | -------------------------------------------------------------------------------- /elab-record-patching/examples/dune_inc.ml: -------------------------------------------------------------------------------- 1 | let bin = "record-patching" 2 | let package = "elab-record-patching" 3 | 4 | let generate_rules base = 5 | Printf.printf 6 | {| 7 | (rule 8 | (with-stdin-from ../%s.txt 9 | (with-stdout-to %s.stdout.tmp 10 | (run %%{bin:%s} elab)))) 11 | |} 12 | base base bin; 13 | Printf.printf 14 | {| 15 | (rule 16 | (alias runtest) 17 | (package %s) 18 | (action 19 | (diff ../%s.stdout %s.stdout.tmp))) 20 | |} 21 | package base base 22 | 23 | let () = 24 | Sys.readdir ".." 25 | |> Array.to_list 26 | |> List.sort String.compare 27 | |> List.filter_map (Filename.chop_suffix_opt ~suffix:".txt") 28 | |> List.iter generate_rules 29 | -------------------------------------------------------------------------------- /elab-record-patching/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name dune_inc)) 3 | 4 | (subdir run 5 | (dynamic_include ../generate/dune.inc)) 6 | 7 | (subdir generate 8 | (rule 9 | (deps (glob_files ../*.txt)) 10 | (action 11 | (with-stdout-to dune.inc 12 | (run ../dune_inc.exe))))) 13 | -------------------------------------------------------------------------------- /elab-record-patching/test/dune_inc.ml: -------------------------------------------------------------------------------- 1 | let bin = "record-patching" 2 | let package = "elab-record-patching" 3 | 4 | let generate_rules base = 5 | Printf.printf 6 | {| 7 | (rule 8 | (with-stdin-from ../%s.txt 9 | (with-stdout-to %s.stdout.tmp 10 | (run %%{bin:%s} elab)))) 11 | |} 12 | base base bin; 13 | Printf.printf 14 | {| 15 | (rule 16 | (alias runtest) 17 | (package %s) 18 | (action 19 | (diff ../%s.stdout %s.stdout.tmp))) 20 | |} 21 | package base base 22 | 23 | let () = 24 | Sys.readdir ".." 25 | |> Array.to_list 26 | |> List.sort String.compare 27 | |> List.filter_map (Filename.chop_suffix_opt ~suffix:".txt") 28 | |> List.iter generate_rules 29 | -------------------------------------------------------------------------------- /elab-record-patching/test/eta-conversion.stdout: -------------------------------------------------------------------------------- 1 | : Type := 2 | let Eq : fun (A : Type) (_ : A) (_ : A) -> Type := 3 | fun A x y => fun (P : fun (_ : A) -> Type) (_ : P x) -> P y; 4 | let refl : fun (A : Type) (x : A) -> Eq A x x := fun A x P px => px; 5 | let eta : Eq (fun (_ : {}) (_ : {}) -> {}) (fun x y => x) (fun x y => x) := 6 | refl (fun (_ : {}) (_ : {}) -> {}) (fun _ _ => {}); 7 | let eta : fun (x : {}) (y : {}) -> Eq {} x y := fun x y => refl {} {}; 8 | let eta : 9 | fun (x : fun (_ : {}) -> {}) (y : fun (_ : {}) -> {}) 10 | -> Eq (fun (_ : {}) -> {}) x y 11 | := fun x y => refl (fun (_ : {}) -> {}) (fun _ => {}); 12 | let eta : 13 | fun (A : Type) (x : fun (_ : A) -> {}) (y : fun (_ : A) -> {}) 14 | -> Eq (fun (_ : A) -> {}) x y 15 | := fun A x y => refl (fun (_ : A) -> {}) (fun _ => {}); 16 | let eta : 17 | fun (A : Type) (B : Type) (r : { x : A; y : B }) 18 | -> Eq { x : A; y : B } r { x := r.x; y := r.y } 19 | := fun A B r => refl { x : A; y : B } r; 20 | let eta : 21 | fun (A : Type) (B : Type) (r : { x : A; y : B }) 22 | -> Eq { x : A; y : B } { x := r.x; y := r.y } r 23 | := fun A B r => refl { x : A; y : B } r; 24 | Type 25 | -------------------------------------------------------------------------------- /elab-record-patching/test/eta-conversion.txt: -------------------------------------------------------------------------------- 1 | let Eq : fun (A : Type) -> A -> A -> Type := 2 | fun A x y => fun (P : A -> Type) -> P x -> P y; 3 | 4 | let refl : fun (A : Type) (x : A) -> Eq A x x := 5 | fun A x P px => px; 6 | 7 | 8 | -------------------------------------------------------------------------------- 9 | -- Eta rules for the unit record 10 | -------------------------------------------------------------------------------- 11 | 12 | let eta : Eq ({} -> {} -> {}) (fun x y => x) (fun x y => x) := 13 | refl ({} -> {} -> {}) (fun _ _ => {}); 14 | 15 | let eta (x : {}) (y : {}) : Eq {} x y := 16 | refl {} {}; 17 | 18 | let eta (x : {} -> {}) (y : {} -> {}) : Eq ({} -> {}) x y := 19 | refl ({} -> {}) (fun _ => {}); 20 | 21 | let eta (A : Type) (x : A -> {}) (y : A -> {}) : Eq (A -> {}) x y := 22 | refl (A -> {}) (fun _ => {}); 23 | 24 | 25 | -------------------------------------------------------------------------------- 26 | -- Eta rules for records 27 | -------------------------------------------------------------------------------- 28 | 29 | let eta (A : Type) (B : Type) (r : { x : A; y : B }) : Eq { x : A; y : B } r { x := r.x; y := r.y } := 30 | refl { x : A; y : B } r; 31 | 32 | let eta (A : Type) (B : Type) (r : { x : A; y : B }) : Eq { x : A; y : B } { x := r.x; y := r.y } r := 33 | refl { x : A; y : B } r; 34 | 35 | 36 | -------------------------------------------------------------------------------- 37 | 38 | 39 | Type 40 | -------------------------------------------------------------------------------- /elab-record-patching/test/let-ann-check.stdout: -------------------------------------------------------------------------------- 1 | : {} := 2 | let Id : Type := fun (A : Type) (_ : A) -> A; 3 | let id : Id := fun A a => a; 4 | id {} {} 5 | -------------------------------------------------------------------------------- /elab-record-patching/test/let-ann-check.txt: -------------------------------------------------------------------------------- 1 | let Id := fun (A : Type) -> A -> A; 2 | 3 | let id : Id := fun A a => a; 4 | 5 | id {} {} 6 | -------------------------------------------------------------------------------- /elab-record-patching/test/let-ann-infer.stdout: -------------------------------------------------------------------------------- 1 | : {} := 2 | let Id : Type := fun (A : Type) (_ : A) -> A; 3 | let id : fun (A : Type) (_ : A) -> A := fun A a => a; 4 | id {} {} 5 | -------------------------------------------------------------------------------- /elab-record-patching/test/let-ann-infer.txt: -------------------------------------------------------------------------------- 1 | let Id := fun (A : Type) -> A -> A; 2 | 3 | let id := (fun A a => a) : Id; 4 | 5 | id {} {} 6 | -------------------------------------------------------------------------------- /elab-record-patching/test/record-field-puns.stdout: -------------------------------------------------------------------------------- 1 | : Type := 2 | let _ : fun (A : Type) (B : Type) -> { A : Type; B : Type } := 3 | fun A B => { A := A; B := B }; 4 | let _ : fun (A : Type) (B : Type) -> { A : Type; B : Type } := 5 | fun A B => { A := A; B := B }; 6 | let _ : fun (A : Type) (B : Type) -> { A : Type; B : Type } := 7 | fun A B => { A := A; B := B }; 8 | Type 9 | -------------------------------------------------------------------------------- /elab-record-patching/test/record-field-puns.txt: -------------------------------------------------------------------------------- 1 | let _ : fun (A : Type) (B : Type) -> { A : Type; B : Type } := 2 | fun A B => { A; B }; 3 | 4 | let _ : fun (A : Type) (B : Type) -> { A : Type; B : Type } := 5 | fun A B => { A := A; B }; 6 | 7 | let _ : fun (A : Type) (B : Type) -> { A : Type; B : Type } := 8 | fun A B => { A; B := B }; 9 | 10 | Type 11 | -------------------------------------------------------------------------------- /elab-record-patching/test/record-proj-singleton.stdout: -------------------------------------------------------------------------------- 1 | : Type := 2 | let _ : fun (A : Type) (x : A) -> A := 3 | fun A x => 4 | let record : { x : A } [= { x := x }] := #sing-intro; 5 | { x := x }.x; 6 | Type 7 | -------------------------------------------------------------------------------- /elab-record-patching/test/record-proj-singleton.txt: -------------------------------------------------------------------------------- 1 | let _ : fun (A : Type) (x : A) -> A := 2 | fun A x => 3 | let record : { x : A } [= { x }] := { x }; 4 | -- ^^^^^ Elaborates to `#sing-intro` 5 | -- when checking `{ x }` against `{ x : A } [= { x }]` 6 | 7 | record.x; 8 | -- ^^^^^^ Elaborates to `{ x }` 9 | 10 | Type 11 | -------------------------------------------------------------------------------- /elab-record-patching/test/records.txt: -------------------------------------------------------------------------------- 1 | let F := { 2 | A : Type; 3 | B : Type; 4 | f : A -> B; 5 | }; 6 | 7 | let patch-1 : F [ B := A ] -> F := fun x => x; 8 | let patch-2 (A : Type) : F [ A := A; B := A ] -> F := fun x => x; 9 | let patch-3 (A : Type) : F [ A := A; B := A; f := fun x => x ] -> F := fun x => x; 10 | let patch-3b (A : Type) : F [ B := A; f := fun x => x; A := A; ] -> F := fun x => x; 11 | let patch-4 (A : Type) : F [ A := A; B := A ] -> F [ B := A ] := fun x => x; 12 | let patch-5 (A : Type) : F [ A := A; B := A ] -> F [ A := A ] := fun x => x; 13 | let patch-6 (C : Type) : F [ A := C; B := C ] -> F [ B := C ] := fun x => x; 14 | 15 | let coerce-missing-1 (C : Type) : F [ A := C; B := C ] := { f := fun x => x }; 16 | let coerce-missing-2 (C : Type) : F [ A := C; B := C; f := fun x => x ] := ({} : {}); 17 | let coerce-missing-3 (C : Type) : F [ A := C; B := C ] := { A := C; f := fun x => x }; 18 | 19 | let record-lit-coerce-1 (B : Type) : { A : Type [= B]; a : B } -> { A : Type; a : A } := 20 | fun r => r; 21 | let record-lit-coerce-2 (B : Type) (b : B) : { A : Type; a : A } := 22 | { A := B; a := b } : { A : Type; a : B }; 23 | 24 | let coerce-missing-patched-fields-1 (A : Type) (B : Type) : { f : A -> B } -> F [ A := A; B := B ] := 25 | fun r => r; 26 | let coerce-missing-patched-fields-2 (A : Type) (B : Type) : { A : Type; f : A -> B } -> F [ B := B ] := 27 | fun r => r; 28 | 29 | Type 30 | -------------------------------------------------------------------------------- /elab-record-patching/test/singleton-check-elim.stdout: -------------------------------------------------------------------------------- 1 | : Type := 2 | let _ : fun (A : Type) (x : A) (sing-x : A [= x]) -> A := 3 | fun A x sing-x => x; 4 | Type 5 | -------------------------------------------------------------------------------- /elab-record-patching/test/singleton-check-elim.txt: -------------------------------------------------------------------------------- 1 | let _ : fun (A : Type) (x : A) (sing-x : A [= x]) -> A := 2 | fun A x sing-x => sing-x; 3 | -- ^^^^^^ Elaborates to `x` when checking `sing-x` against `A` 4 | 5 | Type 6 | -------------------------------------------------------------------------------- /elab-record-patching/test/singleton-check-intro.stdout: -------------------------------------------------------------------------------- 1 | : Type := 2 | let _ : fun (A : Type) (x : A) -> A [= x] := fun A x => #sing-intro; 3 | Type 4 | -------------------------------------------------------------------------------- /elab-record-patching/test/singleton-check-intro.txt: -------------------------------------------------------------------------------- 1 | let _ : fun (A : Type) (x : A) -> A [= x] := 2 | fun A x => x; 3 | -- ^ Elaborates to `#sing-intro x` 4 | -- when coercing from `A` to `A [= x]` 5 | 6 | Type 7 | -------------------------------------------------------------------------------- /elab-stlc-abstract/de_bruijn.ml: -------------------------------------------------------------------------------- 1 | module Size = struct 2 | 3 | type t = int 4 | 5 | let zero = 0 6 | let succ s = s + 1 7 | let to_int s = s 8 | 9 | end 10 | 11 | module Index = struct 12 | 13 | type t = int 14 | 15 | let to_level s i = s - i - 1 16 | let to_int i = i 17 | 18 | end 19 | 20 | module Level = struct 21 | 22 | type t = int 23 | 24 | let next s = s 25 | let to_index s l = s - l - 1 26 | let to_int l = l 27 | 28 | end 29 | 30 | module Env = struct 31 | 32 | type 'a t = 'a list 33 | 34 | let empty (type a) : a t = [] 35 | 36 | let extend (type a) (x : a) (xs : a t) : a t = 37 | x :: xs 38 | 39 | let lookup (type a) (i : Index.t) (xs : a t) : a = 40 | List.nth xs i 41 | 42 | let lookup_opt (type a) (i : Index.t) (xs : a t) : a option = 43 | List.nth_opt xs i 44 | 45 | let size (type a) (xs : a t) : Size.t = 46 | List.length xs 47 | 48 | end 49 | -------------------------------------------------------------------------------- /elab-stlc-abstract/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name stlc-abstract) 4 | (package elab-stlc-abstract) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | menhirLib)) 9 | 10 | (menhir 11 | (modules parser) 12 | (flags --explain --strict)) 13 | -------------------------------------------------------------------------------- /elab-stlc-abstract/lexer.ml: -------------------------------------------------------------------------------- 1 | exception Error of [ 2 | | `Unexpected_char 3 | | `Unclosed_block_comment 4 | ] 5 | 6 | let whitespace = [%sedlex.regexp? Plus (' ' | '\t' | '\r' | '\n')] 7 | let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"] 8 | 9 | let name_start = [%sedlex.regexp? 'a'..'z' | 'A'..'Z'] 10 | let name_continue = [%sedlex.regexp? '-' | '_' | 'a'..'z' | 'A'..'Z' | '0'..'9'] 11 | let name = [%sedlex.regexp? name_start, Star name_continue] 12 | 13 | let rec token (lexbuf : Sedlexing.lexbuf) : Parser.token = 14 | match%sedlex lexbuf with 15 | | whitespace -> token lexbuf 16 | | "--" -> line_comment lexbuf 17 | | "/-" -> block_comment lexbuf 0 18 | | "A" -> KEYWORD_A 19 | | "B" -> KEYWORD_B 20 | | "C" -> KEYWORD_C 21 | | "fun" -> KEYWORD_FUN 22 | | "let" -> KEYWORD_LET 23 | | name -> NAME (Sedlexing.Utf8.lexeme lexbuf) 24 | | ":" -> COLON 25 | | ":=" -> COLON_EQUALS 26 | | "=>" -> EQUALS_GREATER 27 | | "->" -> HYPHEN_GREATER 28 | | ";" -> SEMICOLON 29 | | "(" -> OPEN_PAREN 30 | | ")" -> CLOSE_PAREN 31 | | eof -> END 32 | | _ -> raise (Error `Unexpected_char) 33 | 34 | and line_comment (lexbuf : Sedlexing.lexbuf) : Parser.token = 35 | match%sedlex lexbuf with 36 | | newline -> token lexbuf 37 | | any -> line_comment lexbuf 38 | | eof -> END 39 | | _ -> raise (Error `Unexpected_char) 40 | 41 | and block_comment (lexbuf : Sedlexing.lexbuf) (level : int) : Parser.token = 42 | match%sedlex lexbuf with 43 | | "/-" -> block_comment lexbuf (level + 1) 44 | | "-/" -> if level = 0 then token lexbuf else block_comment lexbuf (level - 1) 45 | | any -> block_comment lexbuf level 46 | | eof -> raise (Error `Unclosed_block_comment) 47 | | _ -> raise (Error `Unexpected_char) 48 | -------------------------------------------------------------------------------- /elab-stlc-abstract/parser.mly: -------------------------------------------------------------------------------- 1 | %token NAME 2 | %token KEYWORD_A "A" 3 | %token KEYWORD_B "B" 4 | %token KEYWORD_C "C" 5 | %token KEYWORD_FUN "fun" 6 | %token KEYWORD_LET "let" 7 | %token COLON ":" 8 | %token COLON_EQUALS ":=" 9 | %token EQUALS_GREATER "=>" 10 | %token HYPHEN_GREATER "->" 11 | %token SEMICOLON ";" 12 | %token OPEN_PAREN "(" 13 | %token CLOSE_PAREN ")" 14 | %token END 15 | 16 | %start main 17 | 18 | %% 19 | 20 | let main := 21 | | e = located(tm); END; 22 | { e } 23 | 24 | 25 | (* Types *) 26 | 27 | let ty := 28 | | ty1 = atomic_ty; "->"; ty2 = ty; 29 | { Surface.Fun_ty (ty1, ty2) } 30 | | atomic_ty 31 | 32 | let atomic_ty := 33 | | "("; ty = ty; ")"; 34 | { ty } 35 | | "A"; 36 | { Surface.A } 37 | | "B"; 38 | { Surface.B } 39 | | "C"; 40 | { Surface.C } 41 | 42 | 43 | (* Terms *) 44 | 45 | let tm := 46 | | "let"; n = located(NAME); ":"; ty = ty; ":="; tm1 = located(tm); ";"; tm2 = located(tm); 47 | { Surface.Let (n, ty, tm1, tm2) } 48 | | "fun"; n = located(NAME); "=>"; tm = located(tm); 49 | { Surface.Fun_lit (n, None, tm) } 50 | | "fun"; "("; n = located(NAME); ":"; ty = ty; ")"; "=>"; tm = located(tm); 51 | { Surface.Fun_lit (n, Some ty, tm) } 52 | | tm = located(app_tm); ":"; ty = ty; 53 | { Surface.Ann (tm, ty) } 54 | | app_tm 55 | 56 | let app_tm := 57 | | tm1 = located(app_tm); tm2 = located(atomic_tm); 58 | { Surface.Fun_app (tm1, tm2) } 59 | | atomic_tm 60 | 61 | let atomic_tm := 62 | | "("; tm = tm; ")"; 63 | { tm } 64 | | n = NAME; 65 | { Surface.Var n } 66 | 67 | 68 | (* Utilities *) 69 | 70 | let located(X) := 71 | | data = X; 72 | { Surface.{ loc = $loc; data } } 73 | -------------------------------------------------------------------------------- /elab-stlc-abstract/tests/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (package elab-stlc-abstract) 3 | (deps 4 | %{bin:stlc-abstract} 5 | (glob_files ./*.txt))) 6 | -------------------------------------------------------------------------------- /elab-stlc-abstract/tests/id.txt: -------------------------------------------------------------------------------- 1 | let id : A -> A := 2 | fun x => x; 3 | 4 | fun (x : A) => 5 | id x 6 | -------------------------------------------------------------------------------- /elab-stlc-abstract/tests/term.txt: -------------------------------------------------------------------------------- 1 | fun (f : A -> B) => fun (a : A) => f a 2 | -------------------------------------------------------------------------------- /elab-stlc-bidirectional-stratify/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name stlc-bidirectional-stratify) 4 | (package elab-stlc-bidirectional-stratify) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | cmdliner 9 | menhirLib)) 10 | 11 | (menhir 12 | (modules parser) 13 | (flags --explain --strict)) 14 | 15 | (mdx 16 | (package elab-stlc-bidirectional-stratify) 17 | (deps %{bin:stlc-bidirectional-stratify})) 18 | 19 | (cram 20 | (package elab-stlc-bidirectional-stratify) 21 | (deps %{bin:stlc-bidirectional-stratify})) 22 | -------------------------------------------------------------------------------- /elab-stlc-bidirectional-stratify/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name dune_inc)) 3 | 4 | (subdir run 5 | (dynamic_include ../generate/dune.inc)) 6 | 7 | (subdir generate 8 | (rule 9 | (deps (glob_files ../*.txt)) 10 | (action 11 | (with-stdout-to dune.inc 12 | (run ../dune_inc.exe))))) 13 | -------------------------------------------------------------------------------- /elab-stlc-bidirectional-stratify/examples/dune_inc.ml: -------------------------------------------------------------------------------- 1 | let bin = "stlc-bidirectional-stratify" 2 | let package = "elab-stlc-bidirectional-stratify" 3 | 4 | let generate_rules base = 5 | Printf.printf 6 | {| 7 | (rule 8 | (with-stdin-from ../%s.txt 9 | (with-stdout-to %s.stdout.tmp 10 | (run %%{bin:%s} elab)))) 11 | |} 12 | base base bin; 13 | Printf.printf 14 | {| 15 | (rule 16 | (alias runtest) 17 | (package %s) 18 | (action 19 | (diff ../%s.stdout %s.stdout.tmp))) 20 | |} 21 | package base base 22 | 23 | let () = 24 | Sys.readdir ".." 25 | |> Array.to_list 26 | |> List.sort String.compare 27 | |> List.filter_map (Filename.chop_suffix_opt ~suffix:".txt") 28 | |> List.iter generate_rules 29 | -------------------------------------------------------------------------------- /elab-stlc-bidirectional-stratify/examples/elephant.stdout: -------------------------------------------------------------------------------- 1 | let grow : Int -> Int := fun (e : Int) => #int-add e 1; 2 | grow 4 : Int 3 | -------------------------------------------------------------------------------- /elab-stlc-bidirectional-stratify/examples/elephant.txt: -------------------------------------------------------------------------------- 1 | let Elephant : Type := Int; 2 | let grow (e : Elephant) : Elephant := e + 1; 3 | grow 4 4 | -------------------------------------------------------------------------------- /elab-stlc-bidirectional-stratify/prim.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Bool_eq 3 | | Int_eq 4 | | Int_add 5 | | Int_sub 6 | | Int_mul 7 | | Int_neg 8 | 9 | let name (prim : t) : string = 10 | match prim with 11 | | Bool_eq -> "bool-eq" 12 | | Int_eq -> "int-eq" 13 | | Int_add -> "int-add" 14 | | Int_sub -> "int-sub" 15 | | Int_mul -> "int-mul" 16 | | Int_neg -> "int-neg" 17 | -------------------------------------------------------------------------------- /elab-stlc-bidirectional/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name stlc-bidirectional) 4 | (package elab-stlc-bidirectional) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | cmdliner 9 | menhirLib)) 10 | 11 | (menhir 12 | (modules parser) 13 | (flags --explain --strict)) 14 | 15 | (mdx 16 | (package elab-stlc-bidirectional) 17 | (deps %{bin:stlc-bidirectional})) 18 | 19 | (cram 20 | (package elab-stlc-bidirectional) 21 | (deps %{bin:stlc-bidirectional})) 22 | -------------------------------------------------------------------------------- /elab-stlc-bidirectional/prim.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Bool_eq 3 | | Int_eq 4 | | Int_add 5 | | Int_sub 6 | | Int_mul 7 | | Int_neg 8 | 9 | let name (prim : t) : string = 10 | match prim with 11 | | Bool_eq -> "bool-eq" 12 | | Int_eq -> "int-eq" 13 | | Int_add -> "int-add" 14 | | Int_sub -> "int-sub" 15 | | Int_mul -> "int-mul" 16 | | Int_neg -> "int-neg" 17 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name stlc-letrec-unification) 4 | (package elab-stlc-letrec-unification) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | cmdliner 9 | menhirLib)) 10 | 11 | (menhir 12 | (modules parser) 13 | (flags --explain --strict)) 14 | 15 | (mdx 16 | (package elab-stlc-letrec-unification) 17 | (deps %{bin:stlc-letrec-unification})) 18 | 19 | (cram 20 | (package elab-stlc-letrec-unification) 21 | (deps %{bin:stlc-letrec-unification})) 22 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/examples/ackermann.stdout: -------------------------------------------------------------------------------- 1 | let succ : Int -> Int := fun (n : Int) => #int-add n 1; 2 | let pred : Int -> Int := fun (n : Int) => #int-sub n 1; 3 | let ack : Int -> Int -> Int := 4 | #fix (ack : Int -> Int -> Int) => 5 | fun (m : Int) => fun (n : Int) => 6 | if #int-eq m 0 then 7 | succ 1 8 | else 9 | if #int-eq n 0 then ack (pred m) 1 else ack (pred m) (ack m (pred n)); 10 | ack 3 4 : Int 11 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/examples/ackermann.txt: -------------------------------------------------------------------------------- 1 | let succ n := n + 1; 2 | let pred n := n - 1; 3 | 4 | let rec ack m n := 5 | if m = 0 then succ 1 else 6 | if n = 0 then ack (pred m) 1 else 7 | ack (pred m) (ack m (pred n)); 8 | 9 | ack 3 4 10 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name dune_inc)) 3 | 4 | (subdir run 5 | (dynamic_include ../generate/dune.inc)) 6 | 7 | (subdir generate 8 | (rule 9 | (deps (glob_files ../*.txt)) 10 | (action 11 | (with-stdout-to dune.inc 12 | (run ../dune_inc.exe))))) 13 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/examples/dune_inc.ml: -------------------------------------------------------------------------------- 1 | let bin = "stlc-letrec-unification" 2 | let package = "elab-stlc-letrec-unification" 3 | 4 | let generate_rules base = 5 | Printf.printf 6 | {| 7 | (rule 8 | (with-stdin-from ../%s.txt 9 | (with-stdout-to %s.stdout.tmp 10 | (run %%{bin:%s} elab)))) 11 | |} 12 | base base bin; 13 | Printf.printf 14 | {| 15 | (rule 16 | (alias runtest) 17 | (package %s) 18 | (action 19 | (diff ../%s.stdout %s.stdout.tmp))) 20 | |} 21 | package base base 22 | 23 | let () = 24 | Sys.readdir ".." 25 | |> Array.to_list 26 | |> List.sort String.compare 27 | |> List.filter_map (Filename.chop_suffix_opt ~suffix:".txt") 28 | |> List.iter generate_rules 29 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/examples/even-odd.stdout: -------------------------------------------------------------------------------- 1 | let $mutual-0 : (Int -> Bool, Int -> Bool) := 2 | #fix ($mutual-0 : (Int -> Bool, Int -> Bool)) => 3 | (fun (n : Int) => 4 | if #int-eq n 0 then true else $mutual-0.1 (#int-sub n 1), 5 | fun (n : Int) => 6 | if #int-eq n 0 then false else $mutual-0.0 (#int-sub n 1)); 7 | $mutual-0.0 6 : Bool 8 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/examples/even-odd.txt: -------------------------------------------------------------------------------- 1 | let rec is-even n := 2 | if n = 0 then true else is-odd (n - 1); 3 | rec is-odd n := 4 | if n = 0 then false else is-even (n - 1); 5 | 6 | is-even 6 7 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/examples/factorial.stdout: -------------------------------------------------------------------------------- 1 | let fact : Int -> Int := 2 | #fix (fact : Int -> Int) => 3 | fun (n : Int) => 4 | if #int-eq n 0 then 1 else #int-mul n (fact (#int-sub n 1)); 5 | fact 5 : Int 6 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/examples/factorial.txt: -------------------------------------------------------------------------------- 1 | let rec fact n := 2 | if n = 0 then 1 else n * fact (n - 1); 3 | 4 | fact 5 5 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/examples/fibonacci.stdout: -------------------------------------------------------------------------------- 1 | let fib : Int -> Int := 2 | #fix (fib : Int -> Int) => 3 | fun (n : Int) => 4 | if #int-eq n 0 then 5 | 0 6 | else 7 | if #int-eq n 1 then 8 | 1 9 | else 10 | #int-add (fib (#int-sub n 1)) (fib (#int-sub n 2)); 11 | fib 9 : Int 12 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/examples/fibonacci.txt: -------------------------------------------------------------------------------- 1 | let rec fib n := 2 | if n = 0 then 0 else 3 | if n = 1 then 1 else 4 | fib (n - 1) + fib (n - 2); 5 | 6 | fib 9 7 | -------------------------------------------------------------------------------- /elab-stlc-letrec-unification/prim.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Bool_eq 3 | | Int_eq 4 | | Int_add 5 | | Int_sub 6 | | Int_mul 7 | | Int_neg 8 | 9 | let name (prim : t) : string = 10 | match prim with 11 | | Bool_eq -> "bool-eq" 12 | | Int_eq -> "int-eq" 13 | | Int_add -> "int-add" 14 | | Int_sub -> "int-sub" 15 | | Int_mul -> "int-mul" 16 | | Int_neg -> "int-neg" 17 | -------------------------------------------------------------------------------- /elab-stlc-row-unification/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name stlc-row-unification) 4 | (package elab-stlc-row-unification) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | cmdliner 9 | menhirLib)) 10 | 11 | (menhir 12 | (modules parser) 13 | (flags --explain --strict)) 14 | 15 | (mdx 16 | (package elab-stlc-row-unification) 17 | (deps %{bin:stlc-row-unification})) 18 | 19 | (cram 20 | (package elab-stlc-row-unification) 21 | (deps %{bin:stlc-row-unification})) 22 | -------------------------------------------------------------------------------- /elab-stlc-row-unification/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name dune_inc)) 3 | 4 | (subdir run 5 | (dynamic_include ../generate/dune.inc)) 6 | 7 | (subdir generate 8 | (rule 9 | (deps (glob_files ../*.txt)) 10 | (action 11 | (with-stdout-to dune.inc 12 | (run ../dune_inc.exe))))) 13 | -------------------------------------------------------------------------------- /elab-stlc-row-unification/examples/dune_inc.ml: -------------------------------------------------------------------------------- 1 | let bin = "stlc-row-unification" 2 | let package = "elab-stlc-row-unification" 3 | 4 | let generate_rules base = 5 | Printf.printf 6 | {| 7 | (rule 8 | (with-stdin-from ../%s.txt 9 | (with-stdout-to %s.stdout.tmp 10 | (run %%{bin:%s} elab)))) 11 | |} 12 | base base bin; 13 | Printf.printf 14 | {| 15 | (rule 16 | (alias runtest) 17 | (package %s) 18 | (action 19 | (diff ../%s.stdout %s.stdout.tmp))) 20 | |} 21 | package base base 22 | 23 | let () = 24 | Sys.readdir ".." 25 | |> Array.to_list 26 | |> List.sort String.compare 27 | |> List.filter_map (Filename.chop_suffix_opt ~suffix:".txt") 28 | |> List.iter generate_rules 29 | -------------------------------------------------------------------------------- /elab-stlc-row-unification/examples/readme.stdout: -------------------------------------------------------------------------------- 1 | let point : Int -> Int -> { x : Int; y : Int } := 2 | fun (x : Int) => fun (y : Int) => { x := x; y := y }; 3 | let add : 4 | { x : Int; y : Int } -> { x : Int; y : Int } -> { x : Int; y : Int } 5 | := 6 | fun (p1 : { x : Int; y : Int }) => fun (p2 : { x : Int; y : Int }) => 7 | point (#int-add p1.x p2.x) (#int-add p1.y p2.y); 8 | let sub : 9 | { x : Int; y : Int } -> { x : Int; y : Int } -> { x : Int; y : Int } 10 | := 11 | fun (p1 : { x : Int; y : Int }) => fun (p2 : { x : Int; y : Int }) => 12 | point (#int-sub p1.x p2.x) (#int-sub p1.y p2.y); 13 | let _ : { x : Int; y : Int } := add (point 1 2) (point 3 4); 14 | let apply : [decr : Int | incr : Int | square : Int] -> Int := 15 | fun (x : [decr : Int | incr : Int | square : Int]) => 16 | match x with 17 | | [decr := x] => #int-sub x 1 18 | | [incr := x] => #int-add x 1 19 | | [square := x] => #int-mul x x 20 | end; 21 | apply ([incr := 1] : [decr : Int | incr : Int | square : Int]) : Int 22 | -------------------------------------------------------------------------------- /elab-stlc-row-unification/examples/readme.txt: -------------------------------------------------------------------------------- 1 | let point x y := 2 | { x := x; y := y }; 3 | 4 | let add p1 p2 := point (p1.x + p2.x) (p1.y + p2.y); 5 | let sub p1 p2 := point (p1.x - p2.x) (p1.y - p2.y); 6 | 7 | let _ := 8 | add (point 1 2) (point 3 4); 9 | 10 | let apply x := 11 | match x with 12 | | [incr := x] => x + 1 13 | | [decr := x] => x - 1 14 | | [square := x] => x * x 15 | end; 16 | 17 | apply [incr := 1] 18 | -------------------------------------------------------------------------------- /elab-stlc-row-unification/prim.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Bool_eq 3 | | Int_eq 4 | | Int_add 5 | | Int_sub 6 | | Int_mul 7 | | Int_neg 8 | 9 | let name (prim : t) : string = 10 | match prim with 11 | | Bool_eq -> "bool-eq" 12 | | Int_eq -> "int-eq" 13 | | Int_add -> "int-add" 14 | | Int_sub -> "int-sub" 15 | | Int_mul -> "int-mul" 16 | | Int_neg -> "int-neg" 17 | -------------------------------------------------------------------------------- /elab-stlc-unification/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name stlc-unification) 4 | (package elab-stlc-unification) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | cmdliner 9 | menhirLib)) 10 | 11 | (menhir 12 | (modules parser) 13 | (flags --explain --strict)) 14 | 15 | (mdx 16 | (package elab-stlc-unification) 17 | (deps %{bin:stlc-unification})) 18 | 19 | (cram 20 | (package elab-stlc-unification) 21 | (deps %{bin:stlc-unification})) 22 | -------------------------------------------------------------------------------- /elab-stlc-unification/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name dune_inc)) 3 | 4 | (subdir run 5 | (dynamic_include ../generate/dune.inc)) 6 | 7 | (subdir generate 8 | (rule 9 | (deps (glob_files ../*.txt)) 10 | (action 11 | (with-stdout-to dune.inc 12 | (run ../dune_inc.exe))))) 13 | -------------------------------------------------------------------------------- /elab-stlc-unification/examples/dune_inc.ml: -------------------------------------------------------------------------------- 1 | let bin = "stlc-unification" 2 | let package = "elab-stlc-unification" 3 | 4 | let generate_rules base = 5 | Printf.printf 6 | {| 7 | (rule 8 | (with-stdin-from ../%s.txt 9 | (with-stdout-to %s.stdout.tmp 10 | (run %%{bin:%s} elab)))) 11 | |} 12 | base base bin; 13 | Printf.printf 14 | {| 15 | (rule 16 | (alias runtest) 17 | (package %s) 18 | (action 19 | (diff ../%s.stdout %s.stdout.tmp))) 20 | |} 21 | package base base 22 | 23 | let () = 24 | Sys.readdir ".." 25 | |> Array.to_list 26 | |> List.sort String.compare 27 | |> List.filter_map (Filename.chop_suffix_opt ~suffix:".txt") 28 | |> List.iter generate_rules 29 | -------------------------------------------------------------------------------- /elab-stlc-unification/examples/readme.stdout: -------------------------------------------------------------------------------- 1 | let foo : Int -> Bool -> Bool -> Bool := 2 | fun (x : Int) => fun (y : Bool) => fun (z : Bool) => 3 | if #int-eq x 0 then y else z; 4 | foo 3 true false : Bool 5 | -------------------------------------------------------------------------------- /elab-stlc-unification/examples/readme.txt: -------------------------------------------------------------------------------- 1 | let foo x y z := 2 | if x = 0 then y else z; 3 | 4 | foo 3 true false 5 | -------------------------------------------------------------------------------- /elab-stlc-unification/prim.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Bool_eq 3 | | Int_eq 4 | | Int_add 5 | | Int_sub 6 | | Int_mul 7 | | Int_neg 8 | 9 | let name (prim : t) : string = 10 | match prim with 11 | | Bool_eq -> "bool-eq" 12 | | Int_eq -> "int-eq" 13 | | Int_add -> "int-add" 14 | | Int_sub -> "int-sub" 15 | | Int_mul -> "int-mul" 16 | | Int_neg -> "int-neg" 17 | -------------------------------------------------------------------------------- /elab-system-f-bidirectional/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name system-f-bidirectional) 4 | (package elab-system-f-bidirectional) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | cmdliner 9 | menhirLib)) 10 | 11 | (menhir 12 | (modules parser) 13 | (flags --explain --strict)) 14 | 15 | (mdx 16 | (package elab-system-f-bidirectional) 17 | (deps %{bin:system-f-bidirectional})) 18 | 19 | (cram 20 | (package elab-system-f-bidirectional) 21 | (deps %{bin:system-f-bidirectional})) 22 | -------------------------------------------------------------------------------- /elab-system-f-bidirectional/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name dune_inc)) 3 | 4 | (subdir run 5 | (dynamic_include ../generate/dune.inc)) 6 | 7 | (subdir generate 8 | (rule 9 | (deps (glob_files ../*.txt)) 10 | (action 11 | (with-stdout-to dune.inc 12 | (run ../dune_inc.exe))))) 13 | -------------------------------------------------------------------------------- /elab-system-f-bidirectional/examples/dune_inc.ml: -------------------------------------------------------------------------------- 1 | let bin = "system-f-bidirectional" 2 | let package = "elab-system-f-bidirectional" 3 | 4 | let generate_rules base = 5 | Printf.printf 6 | {| 7 | (rule 8 | (with-stdin-from ../%s.txt 9 | (with-stdout-to %s.stdout.tmp 10 | (run %%{bin:%s} elab)))) 11 | |} 12 | base base bin; 13 | Printf.printf 14 | {| 15 | (rule 16 | (alias runtest) 17 | (package %s) 18 | (action 19 | (diff ../%s.stdout %s.stdout.tmp))) 20 | |} 21 | package base base 22 | 23 | let () = 24 | Sys.readdir ".." 25 | |> Array.to_list 26 | |> List.sort String.compare 27 | |> List.filter_map (Filename.chop_suffix_opt ~suffix:".txt") 28 | |> List.iter generate_rules 29 | -------------------------------------------------------------------------------- /elab-system-f-bidirectional/examples/readme.stdout: -------------------------------------------------------------------------------- 1 | let id : [a] -> a -> a := fun [a] => fun (x : a) => x; 2 | let always : [a] -> a -> [b] -> b -> a := 3 | fun [a] => fun (x : a) => fun [b] => fun (y : b) => x; 4 | let _ : Int := id [Int] 3; 5 | let _ : [a] -> a -> a := id [[a] -> a -> a] id; 6 | let _ : [a] -> a -> a := always [[a] -> a -> a] id [Int] 3; 7 | let test : ([a] -> a -> a) -> [a] -> a -> a := 8 | fun (f : [a] -> a -> a) => 9 | let _ : Int := f [Int] 3; 10 | let _ : Bool := f [Bool] true; 11 | f [[a] -> a -> a] f; 12 | test (fun [$a] => fun (x : $a) => x) : [a] -> a -> a 13 | -------------------------------------------------------------------------------- /elab-system-f-bidirectional/examples/readme.txt: -------------------------------------------------------------------------------- 1 | let id [a] (x : a) := x; 2 | let always [a] (x : a) [b] (y : b) := x; 3 | 4 | let _ := id [Int] 3; 5 | let _ := id [[a] -> a -> a] id; 6 | let _ := always [[a] -> a -> a] id [Int] 3; 7 | 8 | -- Call a polymorphic argument with different types 9 | let test (f : [a] -> a -> a) : [a] -> a -> a := 10 | let _ := f [Int] 3; -- integers 11 | let _ := f [Bool] true; -- boolean 12 | f [[a] -> a -> a] f; -- itself 13 | 14 | test (fun x => x) 15 | -------------------------------------------------------------------------------- /elab-system-f-bidirectional/examples/self-application.stdout: -------------------------------------------------------------------------------- 1 | let f : ([a] -> a -> a) -> [b] -> b -> b := 2 | fun (id : [a] -> a -> a) => id [[a] -> a -> a] id; 3 | f (fun [$a] => fun (x : $a) => x) [Int] 42 : Int 4 | -------------------------------------------------------------------------------- /elab-system-f-bidirectional/examples/self-application.txt: -------------------------------------------------------------------------------- 1 | let f : ([a] -> a -> a) -> ([b] -> b -> b) := 2 | fun id => id [[a] -> a -> a] id; 3 | 4 | f (fun x => x) [Int] 42 5 | -------------------------------------------------------------------------------- /elab-system-f-bidirectional/prim.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Bool_eq 3 | | Int_eq 4 | | Int_add 5 | | Int_sub 6 | | Int_mul 7 | | Int_neg 8 | 9 | let name (prim : t) : string = 10 | match prim with 11 | | Bool_eq -> "bool-eq" 12 | | Int_eq -> "int-eq" 13 | | Int_add -> "int-add" 14 | | Int_sub -> "int-sub" 15 | | Int_mul -> "int-mul" 16 | | Int_neg -> "int-neg" 17 | -------------------------------------------------------------------------------- /elab-system-f-unification/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name system-f-unification) 4 | (package elab-system-f-unification) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | cmdliner 9 | menhirLib)) 10 | 11 | (menhir 12 | (modules parser) 13 | (flags --explain --strict)) 14 | 15 | (mdx 16 | (package elab-system-f-unification) 17 | (deps %{bin:system-f-unification})) 18 | 19 | (cram 20 | (package elab-system-f-unification) 21 | (deps %{bin:system-f-unification})) 22 | -------------------------------------------------------------------------------- /elab-system-f-unification/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name dune_inc)) 3 | 4 | (subdir run 5 | (dynamic_include ../generate/dune.inc)) 6 | 7 | (subdir generate 8 | (rule 9 | (deps (glob_files ../*.txt)) 10 | (action 11 | (with-stdout-to dune.inc 12 | (run ../dune_inc.exe))))) 13 | -------------------------------------------------------------------------------- /elab-system-f-unification/examples/dune_inc.ml: -------------------------------------------------------------------------------- 1 | let bin = "system-f-unification" 2 | let package = "elab-system-f-unification" 3 | 4 | let generate_rules base = 5 | Printf.printf 6 | {| 7 | (rule 8 | (with-stdin-from ../%s.txt 9 | (with-stdout-to %s.stdout.tmp 10 | (run %%{bin:%s} elab)))) 11 | |} 12 | base base bin; 13 | Printf.printf 14 | {| 15 | (rule 16 | (alias runtest) 17 | (package %s) 18 | (action 19 | (diff ../%s.stdout %s.stdout.tmp))) 20 | |} 21 | package base base 22 | 23 | let () = 24 | Sys.readdir ".." 25 | |> Array.to_list 26 | |> List.sort String.compare 27 | |> List.filter_map (Filename.chop_suffix_opt ~suffix:".txt") 28 | |> List.iter generate_rules 29 | -------------------------------------------------------------------------------- /elab-system-f-unification/examples/readme.stdout: -------------------------------------------------------------------------------- 1 | let id : [a] -> a -> a := fun [a] => fun (x : a) => x; 2 | let always : [a] -> a -> [b] -> b -> a := 3 | fun [a] => fun (x : a) => fun [b] => fun (y : b) => x; 4 | let _ : Int := id [Int] 3; 5 | let _ : [a] -> a -> a := id [[a] -> a -> a] id; 6 | let _ : [a] -> a -> a := always [[a] -> a -> a] id [Int] 3; 7 | let test : ([a] -> a -> a) -> [a] -> a -> a := 8 | fun (f : [a] -> a -> a) => 9 | let _ : Int := f [Int] 3; 10 | let _ : Bool := f [Bool] true; 11 | f [[a] -> a -> a] f; 12 | test (fun [$a] => fun (x : $a) => x) : [a] -> a -> a 13 | -------------------------------------------------------------------------------- /elab-system-f-unification/examples/readme.txt: -------------------------------------------------------------------------------- 1 | let id [a] (x : a) := x; 2 | let always [a] (x : a) [b] (y : b) := x; 3 | 4 | let _ := id 3; 5 | let _ := id id; 6 | let _ := always id 3; 7 | 8 | -- Call a polymorphic argument with different types 9 | let test (f : [a] -> a -> a) : _ := 10 | let _ := f 3; -- integers 11 | let _ := f true; -- boolean 12 | f f; -- itself 13 | 14 | test (fun x => x) 15 | -------------------------------------------------------------------------------- /elab-system-f-unification/examples/self-application.stdout: -------------------------------------------------------------------------------- 1 | let f : ([a] -> a -> a) -> [b] -> b -> b := 2 | fun (id : [a] -> a -> a) => id [[a] -> a -> a] id; 3 | f (fun [$a] => fun (x : $a) => x) [Int] 42 : Int 4 | -------------------------------------------------------------------------------- /elab-system-f-unification/examples/self-application.txt: -------------------------------------------------------------------------------- 1 | let f : ([a] -> a -> a) -> ([b] -> b -> b) := 2 | fun id => id id; 3 | 4 | f (fun x => x) 42 5 | -------------------------------------------------------------------------------- /elab-system-f-unification/prim.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Bool_eq 3 | | Int_eq 4 | | Int_add 5 | | Int_sub 6 | | Int_mul 7 | | Int_neg 8 | 9 | let name (prim : t) : string = 10 | match prim with 11 | | Bool_eq -> "bool-eq" 12 | | Int_eq -> "int-eq" 13 | | Int_add -> "int-add" 14 | | Int_sub -> "int-sub" 15 | | Int_mul -> "int-mul" 16 | | Int_neg -> "int-neg" 17 | -------------------------------------------------------------------------------- /lang-datalog/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name datalog) 4 | (package lang-datalog) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | menhirLib)) 9 | 10 | (menhir 11 | (modules parser) 12 | (flags --explain --strict)) 13 | 14 | (mdx 15 | (package lang-datalog) 16 | (deps %{bin:datalog})) 17 | -------------------------------------------------------------------------------- /lang-datalog/examples/airline.datalog: -------------------------------------------------------------------------------- 1 | % A Miniature Airline - they only have two flights 2 | % 3 | % Illustrating the reduction of n-ary to binary predicates 4 | % 5 | % Example from Chapter 16 of “Symbolic Processing In Pascal” by Manfred von Thun 6 | % 7 | 8 | departure_place(1, "Melbourne"). arrival_place(1, "Honolulu"). 9 | departure_day(1, "Monday"). arrival_day(1, "Tuesday"). 10 | departure_time(1, "h20"). arrival_time(1, "h08"). 11 | 12 | departure_place(2, "Honolulu"). arrival_place(2, "Melbourne"). 13 | departure_day(2, "Thursday"). arrival_day(2, "Friday"). 14 | departure_time(2, "h22"). arrival_time(2, "h10"). 15 | 16 | flight(FlightNumber, DeparturePlace, DepartureDay, DepartureTime, 17 | ArrivalPlace, ArrivalDay, ArrivalTime) <- 18 | departure_place(FlightNumber, DeparturePlace), arrival_place(FlightNumber, ArrivalPlace), 19 | departure_day(FlightNumber, DepartureDay), arrival_day(FlightNumber, ArrivalDay), 20 | departure_time(FlightNumber, DepartureTime), arrival_time(FlightNumber, ArrivalTime). 21 | 22 | % What is the flight departing Honolulu and arriving in Melbourne? 23 | 24 | ? flight(FlightNumber, "Honolulu", DepartureDay, DepartureTime, 25 | "Melbourne", ArrivalDay, ArrivalTime). 26 | 27 | % which flight arrives on a Tuesday? 28 | 29 | ? flight(FlightNumber, DeparturePlace, DepartureDay, DepartureTime, 30 | ArrivalPlace, "Tuesday", ArrivalTime). 31 | 32 | % Which flight arrives on a Thursday? 33 | 34 | ? flight(FlightNumber, DeparturePlace, DepartureDay, DepartureTime, 35 | ArrivalPlace, "Thursday", ArrivalTime). 36 | -------------------------------------------------------------------------------- /lang-datalog/examples/airline.stdout: -------------------------------------------------------------------------------- 1 | ──────────────────────────────────────────────────────────────────────────────── 2 | Knowledge Base 3 | ──────────────────────────────────────────────────────────────────────────────── 4 | departure_place(1, "Melbourne"). 5 | arrival_place(1, "Honolulu"). 6 | departure_day(1, "Monday"). 7 | arrival_day(1, "Tuesday"). 8 | departure_time(1, "h20"). 9 | arrival_time(1, "h08"). 10 | departure_place(2, "Honolulu"). 11 | arrival_place(2, "Melbourne"). 12 | departure_day(2, "Thursday"). 13 | arrival_day(2, "Friday"). 14 | departure_time(2, "h22"). 15 | arrival_time(2, "h10"). 16 | flight(1, "Melbourne", "Monday", "h20", "Honolulu", "Tuesday", "h08"). 17 | flight(2, "Honolulu", "Thursday", "h22", "Melbourne", "Friday", "h10"). 18 | 19 | ──────────────────────────────────────────────────────────────────────────────── 20 | Query Results 21 | ──────────────────────────────────────────────────────────────────────────────── 22 | ? 23 | flight(FlightNumber, "Honolulu", DepartureDay, DepartureTime, "Melbourne", 24 | ArrivalDay, ArrivalTime). 25 | > FlightNumber := 2. 26 | DepartureDay := "Thursday". 27 | DepartureTime := "h22". 28 | ArrivalDay := "Friday". 29 | ArrivalTime := "h10". 30 | yes 31 | 32 | ? 33 | flight(FlightNumber, DeparturePlace, DepartureDay, DepartureTime, 34 | ArrivalPlace, "Tuesday", ArrivalTime). 35 | > FlightNumber := 1. 36 | DeparturePlace := "Melbourne". 37 | DepartureDay := "Monday". 38 | DepartureTime := "h20". 39 | ArrivalPlace := "Honolulu". 40 | ArrivalTime := "h08". 41 | yes 42 | 43 | ? 44 | flight(FlightNumber, DeparturePlace, DepartureDay, DepartureTime, 45 | ArrivalPlace, "Thursday", ArrivalTime). 46 | no 47 | 48 | -------------------------------------------------------------------------------- /lang-datalog/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name dune_inc)) 3 | 4 | (subdir run 5 | (dynamic_include ../generate/dune.inc)) 6 | 7 | (subdir generate 8 | (rule 9 | (deps (glob_files ../*.datalog)) 10 | (action 11 | (with-stdout-to dune.inc 12 | (run ../dune_inc.exe))))) 13 | -------------------------------------------------------------------------------- /lang-datalog/examples/dune_inc.ml: -------------------------------------------------------------------------------- 1 | let bin = "datalog" 2 | let package = "lang-datalog" 3 | 4 | let generate_rules base = 5 | Printf.printf 6 | {| 7 | (rule 8 | (with-stdin-from ../%s.datalog 9 | (with-stdout-to %s.stdout.tmp 10 | (run %%{bin:%s} elab)))) 11 | |} 12 | base base bin; 13 | Printf.printf 14 | {| 15 | (rule 16 | (alias runtest) 17 | (package %s) 18 | (action 19 | (diff ../%s.stdout %s.stdout.tmp))) 20 | |} 21 | package base base 22 | 23 | let () = 24 | Sys.readdir ".." 25 | |> Array.to_list 26 | |> List.sort String.compare 27 | |> List.filter_map (Filename.chop_suffix_opt ~suffix:".datalog") 28 | |> List.iter generate_rules 29 | -------------------------------------------------------------------------------- /lang-datalog/examples/graph.datalog: -------------------------------------------------------------------------------- 1 | % Directed graphs 2 | 3 | path(X, Y) <- edge(X, Y). 4 | path(X, Y) <- edge(X, Z), edge(Z, Y). 5 | 6 | edge(1, 2). 7 | edge(2, 3). 8 | 9 | ? path(3, 1). 10 | ? path(1, 3). 11 | 12 | ? path(Start, 3). 13 | ? path(Start, End). 14 | -------------------------------------------------------------------------------- /lang-datalog/examples/graph.stdout: -------------------------------------------------------------------------------- 1 | ──────────────────────────────────────────────────────────────────────────────── 2 | Knowledge Base 3 | ──────────────────────────────────────────────────────────────────────────────── 4 | edge(1, 2). 5 | edge(2, 3). 6 | path(1, 2). 7 | path(2, 3). 8 | path(1, 3). 9 | 10 | ──────────────────────────────────────────────────────────────────────────────── 11 | Query Results 12 | ──────────────────────────────────────────────────────────────────────────────── 13 | ? path(3, 1). 14 | no 15 | 16 | ? path(1, 3). 17 | yes 18 | 19 | ? path(Start, 3). 20 | > Start := 2. 21 | > Start := 1. 22 | yes 23 | 24 | ? path(Start, End). 25 | > Start := 1. 26 | End := 2. 27 | > Start := 2. 28 | End := 3. 29 | > Start := 1. 30 | End := 3. 31 | yes 32 | 33 | -------------------------------------------------------------------------------- /lang-datalog/examples/languages.datalog: -------------------------------------------------------------------------------- 1 | homepage("OCaml", "https://ocaml.org"). 2 | homepage("Haskell", "https://www.haskell.org/"). 3 | homepage("Standard ML", "https://smlfamily.github.io/"). 4 | 5 | implementation("Haskell", "GHC"). 6 | implementation("Haskell", "GHC"). 7 | implementation("OCaml", "ocamlc"). 8 | implementation("Standard ML", "SML/NJ"). 9 | implementation("Standard ML", "MLton"). 10 | implementation("Standard ML", "MLKit"). 11 | implementation("Standard ML", "Poly/ML"). 12 | 13 | influencedBy("Caml", "ML"). 14 | influencedBy("Haskell", "ISWIM"). 15 | influencedBy("Haskell", "KRC"). 16 | influencedBy("Haskell", "Miranda"). 17 | influencedBy("Haskell", "Standard ML"). 18 | influencedBy("Haskell", "SASL"). 19 | influencedBy("Haskell", "SISAL"). 20 | influencedBy("KRC", "SASL"). 21 | influencedBy("Miranda", "Hope"). 22 | influencedBy("Miranda", "KRC"). 23 | influencedBy("Miranda", "ML"). 24 | influencedBy("ML", "ISWIM"). 25 | influencedBy("OCaml", "Caml"). 26 | influencedBy("SASL", "ISWIM"). 27 | influencedBy("Standard ML", "Hope"). 28 | influencedBy("Standard ML", "ML"). 29 | 30 | influenced(A, B) <- influencedBy(B, A). 31 | 32 | ? influenced("ISWIM", A). 33 | -------------------------------------------------------------------------------- /lang-datalog/parser.mly: -------------------------------------------------------------------------------- 1 | %token LOWER_NAME 2 | %token UPPER_NAME 3 | %token STRING 4 | %token NUMBER 5 | %token COMMA "," 6 | %token DOT "." 7 | %token GREATER_HYPHEN "<-" 8 | %token QUESTION "?" 9 | %token OPEN_PAREN "(" 10 | %token CLOSE_PAREN ")" 11 | %token END 12 | 13 | %start program 14 | 15 | %% 16 | 17 | let program := 18 | | items = list(item); END; 19 | { List.fold_right ( @@ ) items Datalog.{ rules = []; queries = [] } } 20 | 21 | let item := 22 | | q = query; { fun p -> Datalog.{ p with queries = q :: p.queries } } 23 | | r = rule; { fun p -> Datalog.{ p with rules = r :: p.rules } } 24 | 25 | let query := 26 | | "?"; body = separated_list(",", atom); "."; 27 | { body } 28 | 29 | let rule := 30 | | head = atom; "."; 31 | { Datalog.{ head; body = [] } } 32 | | head = atom; "<-"; body = separated_list(",", atom); "."; 33 | { Datalog.{ head; body } } 34 | 35 | let atom := 36 | | name = LOWER_NAME; 37 | { Datalog.{ name; args = [] } } 38 | | name = LOWER_NAME; args = delimited("(", separated_list(",", term) ,")"); 39 | { Datalog.{ name; args } } 40 | 41 | let term := 42 | | v = UPPER_NAME; 43 | { Datalog.Var v } 44 | | c = const; 45 | { Datalog.Const c } 46 | 47 | let const := 48 | | s = STRING; 49 | { Datalog.String s } 50 | | i = NUMBER; 51 | { Datalog.Int i } 52 | -------------------------------------------------------------------------------- /lang-datalog/test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (package lang-datalog) 3 | (deps 4 | %{bin:datalog} 5 | (glob_files ./*.datalog))) 6 | -------------------------------------------------------------------------------- /lang-datalog/test/test.t: -------------------------------------------------------------------------------- 1 | Unrestricted range 2 | $ cat ./unrestricted-range.datalog | datalog 3 | Fatal error: exception Failure("the input program is not range-restricted") 4 | Raised at Stdlib.failwith in file "stdlib.ml", line 29, characters 17-33 5 | Called from Dune__exe__Main in file "lang-datalog/main.ml", line 83, characters 11-38 6 | [2] 7 | -------------------------------------------------------------------------------- /lang-datalog/test/unrestricted-range.datalog: -------------------------------------------------------------------------------- 1 | thing(3). 2 | 3 | foo(X, Y) <- thing(Y). 4 | % ^ error: variable `X` does not appear in the body of the rule 5 | 6 | ? foo(1, 3). 7 | -------------------------------------------------------------------------------- /lang-declarative-graphics/README.md: -------------------------------------------------------------------------------- 1 | # Declarative graphics DSL 2 | 3 | This is domain specific language for drawing 2-dimensional graphics. The goal is 4 | to describe drawings in terms of simple, composable components, with no hidden 5 | drawing state[^1]. 6 | 7 | Used in [**lang-fractal-tree-rewriting**](../lang-fractal-tree-rewriting). 8 | 9 | ## Todo list 10 | 11 | - [x] Embedded DSL 12 | - [ ] External DSL 13 | - [ ] Web playground 14 | 15 | Diagram support 16 | 17 | - [x] 2D diagrams 18 | - [ ] 2D diagrams with envelope-based alignment 19 | - [ ] 2.5D diagrams 20 | - [ ] 3D diagrams 21 | 22 | Additional backends 23 | 24 | - [ ] CPU Backend 25 | - [x] SVG Backend 26 | - [ ] GPU Backend 27 | 28 | ## Related work 29 | 30 | This was inspired the [diagrams][haskell-diagrams] library for Haskell. 31 | A similar library for Elm was described by Pontus Granström in [“Diagrammar: 32 | Simply Make Interactive Diagrams”][diagrammer-talk]. The following Elm packages 33 | were also inspiring: 34 | 35 | - [evancz/elm-graphics](https://github.com/evancz/elm-graphics) ([Docs](https://package.elm-lang.org/packages/evancz/elm-graphics/latest/Collage)) 36 | - [timjs/elm-collage](https://github.com/timjs/elm-collage) ([Docs](https://package.elm-lang.org/packages/timjs/elm-collage/latest/)) 37 | - [vilterp/elm-diagrams](https://github.com/vilterp/elm-diagrams) ([Docs](https://package.elm-lang.org/packages/vilterp/elm-diagrams/latest/)) 38 | 39 | The [pict][racket-pict] library for Racket also implements some similar ideas. 40 | 41 | [^1]: in contrast to imperative drawing APIs like [Processing][processing], 42 | [Cairo][cairo] or [HTML Canvas][html-canvas]. 43 | 44 | [cairo]: https://www.cairographics.org/ 45 | [diagrammer-talk]: https://www.youtube.com/watch?v=gT9Xu-ctNqI 46 | [haskell-diagrams]: https://diagrams.github.io/ 47 | [html-canvas]: https://developer.mozilla.org/en-US/docs/Web/API/Canvas_API 48 | [processing]: https://processing.org 49 | [racket-pict]: https://docs.racket-lang.org/pict 50 | -------------------------------------------------------------------------------- /lang-declarative-graphics/core/diagram.ml: -------------------------------------------------------------------------------- 1 | (** Declarative diagramming API *) 2 | 3 | include Diagram_intf 4 | 5 | module Make (X : Core) : S 6 | with type t = X.t 7 | = struct 8 | 9 | include X 10 | 11 | let stack dias = 12 | List.fold_left over empty dias 13 | 14 | let translate_x dx dia = 15 | translate (dx, 0.0) dia 16 | 17 | let translate_y dy dia = 18 | translate (0.0, dy) dia 19 | 20 | end 21 | -------------------------------------------------------------------------------- /lang-declarative-graphics/core/diagram.mli: -------------------------------------------------------------------------------- 1 | include module type of Diagram_intf 2 | 3 | module Make (X : Core) : S 4 | with type t = X.t 5 | -------------------------------------------------------------------------------- /lang-declarative-graphics/core/diagram_intf.ml: -------------------------------------------------------------------------------- 1 | type style = [`solid | `none] 2 | type vec2 = float * float 3 | 4 | module type Core = sig 5 | 6 | type t 7 | 8 | val over : t -> t -> t 9 | 10 | val empty : t 11 | val circle : diameter:float -> t 12 | val line : vec2 -> vec2 -> t 13 | 14 | val stroke : style -> t -> t 15 | val fill : style -> t -> t 16 | 17 | val rotate : radians:float -> t -> t 18 | val translate : vec2 -> t -> t 19 | val scale : float -> t -> t 20 | 21 | end 22 | 23 | module type S = sig 24 | 25 | include Core 26 | 27 | val stack : t list -> t 28 | 29 | val translate_x : float -> t -> t 30 | val translate_y : float -> t -> t 31 | 32 | end 33 | -------------------------------------------------------------------------------- /lang-declarative-graphics/core/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (library 4 | (name declarative_graphics_core) 5 | (public_name lang-declarative-graphics.core)) 6 | -------------------------------------------------------------------------------- /lang-declarative-graphics/core/svg_diagram.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | include Diagram.S with type t := t 4 | 5 | val run : view_box:(float * float * float * float) -> t -> out_channel -> unit 6 | -------------------------------------------------------------------------------- /lang-declarative-graphics/examples/README.md: -------------------------------------------------------------------------------- 1 | # Examples 2 | 3 | ## Binary tree 4 | 5 | [![Binary tree example](tree.svg)](tree.ml) 6 | -------------------------------------------------------------------------------- /lang-declarative-graphics/examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name tree) 3 | (libraries 4 | lang-declarative-graphics.core)) 5 | 6 | (rule 7 | (with-stdout-to ./tree.svg.tmp 8 | (run ./tree.exe))) 9 | 10 | (rule 11 | (alias runtest) 12 | (package lang-declarative-graphics) 13 | (action 14 | (diff ./tree.svg ./tree.svg.tmp))) 15 | -------------------------------------------------------------------------------- /lang-declarative-graphics/examples/tree.ml: -------------------------------------------------------------------------------- 1 | open Declarative_graphics_core 2 | 3 | let apex_diameter = 3.0 4 | let fork_angle = 45.0 *. Float.pi /. 180.0 5 | let branch_length = 6.0 6 | 7 | let tree (type t) (module D : Diagram.S with type t = t) ~(iters : int) : t = 8 | let rec apex = 9 | D.circle ~diameter:apex_diameter 10 | 11 | and branch ~(iters : int) : t = 12 | let len = branch_length *. Float.pow 2.0 (float_of_int iters) in 13 | D.stack [ 14 | D.line (0.0, 0.0) (0.0, -.len) |> D.stroke `solid; 15 | D.translate_y (-.len) (if iters <= 0 then apex else fork ~iters); 16 | ] 17 | 18 | and fork ~(iters : int) = 19 | D.stack [ 20 | branch ~iters:(iters - 1) |> D.rotate ~radians:(+.fork_angle); 21 | branch ~iters:(iters - 1) |> D.rotate ~radians:(-.fork_angle); 22 | ] 23 | in 24 | 25 | branch ~iters 26 | 27 | let () = 28 | let (width, height) = (400.0, 400.0) in 29 | 30 | tree (module Svg_diagram) ~iters:5 31 | |> Svg_diagram.translate (width /. 2.0, height) 32 | |> Svg_diagram.run ~view_box:(0.0, 0.0, width, height) 33 | |> Printf.printf "%t" 34 | -------------------------------------------------------------------------------- /lang-declarative-graphics/jsoo/canvas_diagram.mli: -------------------------------------------------------------------------------- 1 | (** A declarative version of the Canvas API *) 2 | 3 | module Diagram := Declarative_graphics_core.Diagram 4 | module Html := Js_of_ocaml.Dom_html 5 | module Js := Js_of_ocaml.Js 6 | 7 | type t 8 | 9 | include Diagram.S with type t := t 10 | 11 | (** Render the diagram in the supplied canvas rendering context *) 12 | val run : Html.canvasRenderingContext2D Js.t -> t -> unit 13 | -------------------------------------------------------------------------------- /lang-declarative-graphics/jsoo/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (library 4 | (name declarative_graphics_jsoo) 5 | (public_name lang-declarative-graphics.jsoo) 6 | (libraries 7 | js_of_ocaml 8 | lang-declarative-graphics.core) 9 | (preprocess 10 | (pps js_of_ocaml-ppx))) 11 | -------------------------------------------------------------------------------- /lang-declarative-graphics/jsoo/svg_diagram.mli: -------------------------------------------------------------------------------- 1 | module Diagram := Declarative_graphics_core.Diagram 2 | module Svg := Js_of_ocaml.Dom_svg 3 | module Js := Js_of_ocaml.Js 4 | 5 | type t 6 | 7 | include Diagram.S with type t := t 8 | 9 | val run : Svg.document Js.t -> t -> Svg.svgElement Js.t 10 | -------------------------------------------------------------------------------- /lang-doc-templates/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name doc-templates) 4 | (package lang-doc-templates) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | menhirLib)) 9 | 10 | (menhir 11 | (modules parser) 12 | (flags --explain --strict)) 13 | -------------------------------------------------------------------------------- /lang-doc-templates/test/article.stdout: -------------------------------------------------------------------------------- 1 | 2 | 3 |

Document template language

4 | 5 |

6 | Hello ${place}! 7 |

8 | 9 |

10 | This is a document template language that elaborates to a typed lambda 11 | calculus. 12 |

13 | 14 |

Thoughts

15 | 16 |

17 | Designing a nice concrete syntax is hard. Trying to make it not too ad-hoc and 18 | hard to parse, and extensible over time, while remaining lightweight and 19 | pleasant to use. 20 |

21 | -------------------------------------------------------------------------------- /lang-doc-templates/test/article.txt: -------------------------------------------------------------------------------- 1 | ${let place := "world"} 2 | 3 | ${heading1 "Document template language"} 4 | 5 | ${para " 6 | Hello ${place}! 7 | "} 8 | 9 | ${para " 10 | This is a document template language that elaborates to a typed lambda 11 | calculus. 12 | "} 13 | 14 | ${heading2 "Thoughts"} 15 | 16 | ${para " 17 | Designing a nice concrete syntax is hard. Trying to make it not too ad-hoc and 18 | hard to parse, and extensible over time, while remaining lightweight and 19 | pleasant to use. 20 | "} 21 | -------------------------------------------------------------------------------- /lang-doc-templates/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name dune_inc)) 3 | 4 | (subdir run 5 | (dynamic_include ../generate/dune.inc)) 6 | 7 | (subdir generate 8 | (rule 9 | (deps (glob_files ../*.txt)) 10 | (action 11 | (with-stdout-to dune.inc 12 | (run ../dune_inc.exe))))) 13 | -------------------------------------------------------------------------------- /lang-doc-templates/test/dune_inc.ml: -------------------------------------------------------------------------------- 1 | let bin = "doc-templates" 2 | let package = "lang-doc-templates" 3 | 4 | let generate_rules base = 5 | Printf.printf 6 | {| 7 | (rule 8 | (with-stdin-from ../%s.txt 9 | (with-stdout-to %s.stdout.tmp 10 | (run %%{bin:%s})))) 11 | |} 12 | base base bin; 13 | Printf.printf 14 | {| 15 | (rule 16 | (alias runtest) 17 | (package %s) 18 | (action 19 | (diff ../%s.stdout %s.stdout.tmp))) 20 | |} 21 | package base base 22 | 23 | let () = 24 | Sys.readdir ".." 25 | |> Array.to_list 26 | |> List.sort String.compare 27 | |> List.filter_map (Filename.chop_suffix_opt ~suffix:".txt") 28 | |> List.iter generate_rules 29 | -------------------------------------------------------------------------------- /lang-doc-templates/test/escapes.stdout: -------------------------------------------------------------------------------- 1 | Testing some escapes: 2 | 3 | - back-slash: \. 4 | - dollar sign: $. 5 | - quotation mark: ". 6 | 7 | - newline: 8 | . 9 | - tab: . 10 | -------------------------------------------------------------------------------- /lang-doc-templates/test/escapes.txt: -------------------------------------------------------------------------------- 1 | Testing some escapes: 2 | 3 | - back-slash: \\. 4 | - dollar sign: \$. 5 | - quotation mark: \". 6 | 7 | - newline: \n. 8 | - tab: \t. 9 | -------------------------------------------------------------------------------- /lang-doc-templates/test/lists.stdout: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /lang-doc-templates/test/lists.txt: -------------------------------------------------------------------------------- 1 | ${let tags : List Text := [ 2 | "foo", 3 | "bar", 4 | ]} 5 | -------------------------------------------------------------------------------- /lang-doc-templates/test/nested-quotes.stdout: -------------------------------------------------------------------------------- 1 | Hello, how are you doing? 2 | 3 | Nice to meet you. 4 | -------------------------------------------------------------------------------- /lang-doc-templates/test/nested-quotes.txt: -------------------------------------------------------------------------------- 1 | ${ 2 | $"Hello, how are ${ "you" } doing?" 3 | } 4 | 5 | ${ "Nice to meet" + " " + "you." } 6 | -------------------------------------------------------------------------------- /lang-doc-templates/test/text.stdout: -------------------------------------------------------------------------------- 1 | Hello world! 2 | -------------------------------------------------------------------------------- /lang-doc-templates/test/text.txt: -------------------------------------------------------------------------------- 1 | Hello world! 2 | -------------------------------------------------------------------------------- /lang-doc-templates/test/unquote-let-params.stdout: -------------------------------------------------------------------------------- 1 | 2 | 3 | Hello world! 4 | -------------------------------------------------------------------------------- /lang-doc-templates/test/unquote-let-params.txt: -------------------------------------------------------------------------------- 1 | ${let greet (place : Text) := 2 | $"Hello ${place}!" 3 | } 4 | 5 | ${greet "world"} 6 | -------------------------------------------------------------------------------- /lang-doc-templates/test/unquote-let.stdout: -------------------------------------------------------------------------------- 1 | 2 | 3 | Hello world! 4 | -------------------------------------------------------------------------------- /lang-doc-templates/test/unquote-let.txt: -------------------------------------------------------------------------------- 1 | ${let place := "world"} 2 | 3 | Hello ${place}! 4 | -------------------------------------------------------------------------------- /lang-doc-templates/test/unquote-term.stdout: -------------------------------------------------------------------------------- 1 | Ahoy there! 2 | -------------------------------------------------------------------------------- /lang-doc-templates/test/unquote-term.txt: -------------------------------------------------------------------------------- 1 | ${ "Ahoy there!" } 2 | -------------------------------------------------------------------------------- /lang-fractal-growth/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name fractal-growth) 4 | (package lang-fractal-growth) 5 | (libraries 6 | lang-fractal-growth 7 | cmdliner)) 8 | -------------------------------------------------------------------------------- /lang-fractal-growth/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package lang-fractal-growth) 3 | (deps %{bin:fractal-growth})) 4 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name fractal_growth) 3 | (public_name lang-fractal-growth)) 4 | 5 | (include_subdirs qualified) 6 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/system.ml: -------------------------------------------------------------------------------- 1 | (** Signature of a deterministic, context-free L-System *) 2 | module type Grammar = sig 3 | 4 | (** Alphabet of symbols for this system *) 5 | type symbol 6 | 7 | (** The initial state of the system *) 8 | val axiom : symbol list 9 | 10 | (** Production rules defining how symbols will be replaced *) 11 | val rules : symbol -> symbol list 12 | 13 | end 14 | 15 | 16 | (** Derived utility functions for working with L-systems *) 17 | module Util (G : Grammar) : sig 18 | 19 | (** Apply the rewrite rules in parallel *) 20 | val step : G.symbol list -> G.symbol list 21 | 22 | (** Unfold a list of productions *) 23 | val generate : G.symbol list -> G.symbol list Seq.t 24 | 25 | end = struct 26 | 27 | let step = 28 | List.concat_map G.rules 29 | 30 | let generate w = 31 | Seq.unfold (fun w -> Some (w, step w)) w 32 | 33 | end 34 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/algae.ml: -------------------------------------------------------------------------------- 1 | (** Based on Figure 1.3 in “The Algorithmic Beauty of Plants” *) 2 | 3 | 4 | (* $MDX part-begin=grammar *) 5 | (** Cytological state of a cell *) 6 | type symbol = 7 | | A (** Long cell, ready to divide *) 8 | | B (** Short cell *) 9 | 10 | let axiom = 11 | [B] (* Seed with a small cell *) 12 | 13 | let rules = 14 | function 15 | | A -> [A; B] (* Divide *) 16 | | B -> [A] (* Grow *) 17 | (* $MDX part-end *) 18 | 19 | 20 | (** {1 String interpretation} *) 21 | 22 | let string_of_symbol = 23 | function 24 | | A -> "a" 25 | | B -> "b" 26 | 27 | let string_of_word w = 28 | List.map string_of_symbol w 29 | |> String.concat "" 30 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/algae.mli: -------------------------------------------------------------------------------- 1 | (** {0 Model of the growth of Algae} *) 2 | 3 | (** Lindenmayer's original L-system for modelling the growth of algae. *) 4 | 5 | (** Alphabet of symbols for this system *) 6 | type symbol 7 | 8 | include System.Grammar 9 | with type symbol := symbol 10 | (** @open *) 11 | 12 | 13 | (** {1 String interpretation} *) 14 | 15 | (** Convert a symbol to a string *) 16 | val string_of_symbol : symbol -> string 17 | 18 | (** Convert a word to a string *) 19 | val string_of_word : symbol list -> string 20 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/binary_tree.ml: -------------------------------------------------------------------------------- 1 | (** From the {{: https://en.wikipedia.org/wiki/L-system#Example_2:_Fractal_(binary)_tree} 2 | L-system page} on Wikipedia. *) 3 | 4 | 5 | type symbol = 6 | | Apex 7 | | Branch 8 | | Push 9 | | Pop 10 | 11 | let axiom = [Apex] 12 | 13 | let rules = 14 | function 15 | | Branch -> [Branch; Branch] (* Grow the branch *) 16 | | Apex -> [Branch; Push; Apex; Pop; Apex] (* Split a bud into a branch and two buds *) 17 | (* TODO: Terminal symbols *) 18 | | s -> [s] 19 | 20 | 21 | let string_of_symbol = 22 | function 23 | | Apex -> "0" 24 | | Branch -> "1" 25 | | Push -> "[" 26 | | Pop -> "]" 27 | 28 | let string_of_word w = 29 | List.map string_of_symbol w 30 | |> String.concat "" 31 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/binary_tree.mli: -------------------------------------------------------------------------------- 1 | (** A fractal binary tree *) 2 | 3 | (** Alphabet of symbols for this system *) 4 | type symbol 5 | 6 | include System.Grammar 7 | with type symbol := symbol 8 | (** @open *) 9 | 10 | 11 | (** {1 String interpretation} *) 12 | 13 | (** Convert a symbol to a string *) 14 | val string_of_symbol : symbol -> string 15 | 16 | (** Convert a word to a string *) 17 | val string_of_word : symbol list -> string 18 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/cantor_set.ml: -------------------------------------------------------------------------------- 1 | (** From the {{: https://en.wikipedia.org/wiki/L-system#Example_2:_Fractal_(binary)_command} 2 | L-system page} on Wikipedia. *) 3 | 4 | 5 | (** Drawing command *) 6 | type symbol = 7 | | Draw (** Draw forward *) 8 | | Move (** Move forward *) 9 | 10 | let axiom = [Draw] 11 | 12 | let rules = 13 | function 14 | | Draw -> [Draw; Move; Draw] 15 | | Move -> [Move; Move; Move] 16 | 17 | 18 | let string_of_symbol = 19 | function 20 | | Draw -> "A" 21 | | Move -> "B" 22 | 23 | let string_of_word w = 24 | List.map string_of_symbol w 25 | |> String.concat "" 26 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/cantor_set.mli: -------------------------------------------------------------------------------- 1 | (** Cantor’s fractal set *) 2 | 3 | (** Alphabet of symbols for this system *) 4 | type symbol 5 | 6 | include System.Grammar 7 | with type symbol := symbol 8 | (** @open *) 9 | 10 | 11 | (** {1 String interpretation} *) 12 | 13 | (** Convert a symbol to a string *) 14 | val string_of_symbol : symbol -> string 15 | 16 | (** Convert a word to a string *) 17 | val string_of_word : symbol list -> string 18 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/filament.ml: -------------------------------------------------------------------------------- 1 | (** Based on Equation 1.1 in “The Algorithmic Beauty of Plants” *) 2 | 3 | 4 | (* $MDX part-begin=grammar *) 5 | (** Cytological state of a cell *) 6 | type size = 7 | | A (** Long cell, ready to divide *) 8 | | B (** Short cell *) 9 | 10 | (** Where new cells will be produced *) 11 | type polarity = 12 | | L (** Divide to the left *) 13 | | R (** Divide to the right *) 14 | 15 | (** The state of a cell in a filament of Anabaena catenula *) 16 | type symbol = size * polarity 17 | 18 | let axiom = [A, R] 19 | 20 | let rules = 21 | function 22 | | A, R -> [A, L; B, R] (* Divide right *) 23 | | A, L -> [B, L; A, R] (* Divide left *) 24 | | B, R -> [A, R] (* Grow right *) 25 | | B, L -> [A, L] (* Grow left *) 26 | (* $MDX part-end *) 27 | 28 | 29 | let string_of_symbol = 30 | function 31 | | A, R -> "(-->)" 32 | | B, R -> "(->)" 33 | | A, L -> "(<--)" 34 | | B, L -> "(<-)" 35 | 36 | let string_of_word w = 37 | List.map string_of_symbol w 38 | |> String.concat "" 39 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/filament.mli: -------------------------------------------------------------------------------- 1 | (** {0 Model of Anabaena catenula}*) 2 | 3 | (** Development of a multicelluar filament in the blue-green bactieria, 4 | {{: https://en.wikipedia.org/wiki/Anabaena} Anabaena catenula}. *) 5 | 6 | (** Alphabet of symbols for this system *) 7 | type symbol 8 | 9 | include System.Grammar 10 | with type symbol := symbol 11 | (** @open *) 12 | 13 | 14 | (** {1 String interpretation} *) 15 | 16 | (** Convert a symbol to a string *) 17 | val string_of_symbol : symbol -> string 18 | 19 | (** Convert a word to a string *) 20 | val string_of_word : symbol list -> string 21 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/koch_island.ml: -------------------------------------------------------------------------------- 1 | (** Based on Figure 1.6 in “The Algorithmic Beauty of Plants” *) 2 | 3 | 4 | (** Turtle command *) 5 | type symbol = 6 | | Left (** Turn left by an angle {i δ} *) 7 | | Right (** Turn right by an angle {i δ} *) 8 | | Line (** Move forward a distance {i d}, drawing a line *) 9 | 10 | (** Start with a square *) 11 | let axiom = [ 12 | Line; Right; 13 | Line; Right; 14 | Line; Right; 15 | Line; 16 | ] 17 | 18 | let rules = 19 | function 20 | (* Grow a branch for each line on the predecessor *) 21 | | Line -> 22 | [ 23 | Line; Right; Line; Left; Line; Left; Line; 24 | Line; Right; Line; Right; Line; Left; Line; 25 | ] 26 | (* TODO: Terminal symbols *) 27 | | s -> [s] 28 | 29 | 30 | let string_of_symbol = 31 | function 32 | | Left -> "+" 33 | | Right -> "-" 34 | | Line -> "F" 35 | 36 | let string_of_word w = 37 | List.map string_of_symbol w 38 | |> String.concat "" 39 | 40 | (* TODO: Graphical interpretation? *) 41 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/koch_island.mli: -------------------------------------------------------------------------------- 1 | (** Quadratic {{: https://en.wikipedia.org/wiki/Koch_snowflake} Koch island} *) 2 | 3 | (** Alphabet of symbols for this system *) 4 | type symbol 5 | 6 | include System.Grammar 7 | with type symbol := symbol 8 | (** @open *) 9 | 10 | 11 | (** {1 String interpretation} *) 12 | 13 | (** Convert a symbol to a string *) 14 | val string_of_symbol : symbol -> string 15 | 16 | (** Convert a word to a string *) 17 | val string_of_word : symbol list -> string 18 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/monopodial_inflorence.ml: -------------------------------------------------------------------------------- 1 | (** From section 3.5 of {{: http://algorithmicbotany.org/papers/cpfg.agtive99.html} 2 | “An L-System-Based Plant Modeling Language”} *) 3 | 4 | (** The development of an individual flower *) 5 | module Flower = struct 6 | 7 | (** The state of a flower *) 8 | type symbol = 9 | | Bud 10 | | Blossom 11 | | Fruit 12 | 13 | let axiom = 14 | [Bud; Blossom; Fruit] 15 | 16 | let rules = 17 | function 18 | | Bud -> [Blossom] 19 | | Blossom -> [Fruit] 20 | (* TODO: Terminal symbols *) 21 | | s -> [s] 22 | 23 | 24 | let string_of_symbol = 25 | function 26 | | Bud -> "A" 27 | | Blossom -> "B" 28 | | Fruit -> "C" 29 | 30 | let string_of_word w = 31 | List.map string_of_symbol w 32 | |> String.concat "" 33 | 34 | (* TODO: Graphical interpretation? *) 35 | 36 | end 37 | 38 | 39 | (** The state of a stem *) 40 | type symbol = 41 | | Apex (** The apex, or terminal bud *) 42 | | Stem (** An internode/stem in the inflorence *) 43 | (* TODO: Sub-L-systems *) 44 | | Flower of Flower.symbol 45 | 46 | let symbol_of_flower s = 47 | Flower s 48 | 49 | 50 | let axiom = 51 | [Apex] 52 | 53 | let rules = 54 | function 55 | | Apex -> [Stem; Flower Bud; Apex] 56 | (* TODO: Sub-L-systems *) 57 | | Flower s -> List.map symbol_of_flower (Flower.rules s) 58 | (* TODO: Terminal symbols *) 59 | | s -> [s] 60 | 61 | 62 | let string_of_symbol = 63 | function 64 | | Apex -> "A" 65 | | Stem -> "I" 66 | | Flower s -> String.concat "" ["["; Flower.string_of_symbol s; "]"] 67 | 68 | let string_of_word w = 69 | List.map string_of_symbol w 70 | |> String.concat "" 71 | 72 | (* TODO: Graphical interpretation? *) 73 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/monopodial_inflorence.mli: -------------------------------------------------------------------------------- 1 | (** The development of a {{: https://en.wikipedia.org/wiki/Inflorescence} 2 | monopodial inflorescence} *) 3 | 4 | 5 | (** The development of an individual flower *) 6 | module Flower : sig 7 | 8 | (** Alphabet of symbols for this system *) 9 | type symbol 10 | 11 | include System.Grammar 12 | with type symbol := symbol 13 | (** @open *) 14 | 15 | 16 | (** {1 String interpretation} *) 17 | 18 | (** Convert a symbol to a string *) 19 | val string_of_symbol : symbol -> string 20 | 21 | (** Convert a word to a string *) 22 | val string_of_word : symbol list -> string 23 | 24 | end 25 | 26 | 27 | (** Alphabet of symbols for this system *) 28 | type symbol 29 | 30 | (** Convert a flower to a symbol *) 31 | val symbol_of_flower : Flower.symbol -> symbol 32 | 33 | include System.Grammar 34 | with type symbol := symbol 35 | (** @open *) 36 | 37 | 38 | (** {1 String interpretation} *) 39 | 40 | (** Convert a symbol to a string *) 41 | val string_of_symbol : symbol -> string 42 | 43 | (** Convert a word to a string *) 44 | val string_of_word : symbol list -> string 45 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/parametric.ml: -------------------------------------------------------------------------------- 1 | (** Based on Equation 1.7 in “The Algorithmic Beauty of Plants” *) 2 | 3 | (* Note that parametric L-Systems fall out of OCaml’s algebraic datatypes and 4 | pattern guards. No additional features are required! *) 5 | 6 | 7 | type symbol = 8 | | A of int * int 9 | | B of int 10 | | C 11 | 12 | let axiom = [B 2; A (4, 4)] 13 | 14 | let rules = 15 | function 16 | | A (x, y) when y <= 3 -> [A (x * 2, x + y)] 17 | | A (x, y) (* y > 3 *) -> [B x; A (x / y, 0)] 18 | | B x when x < 1 -> [C] 19 | | B x (* x >= 1 *) -> [B (x - 1)] 20 | | C -> [C] 21 | 22 | 23 | let string_of_symbol = 24 | (* FIXME: could do with some spaces and/or punctuation between symbols *) 25 | function 26 | | A (x, y) -> Format.sprintf "A(%i, %i)" x y 27 | | B x -> Format.sprintf "B(%i)" x 28 | | C -> "C" 29 | 30 | let string_of_word w = 31 | List.map string_of_symbol w 32 | |> String.concat " " 33 | -------------------------------------------------------------------------------- /lang-fractal-growth/lib/systems/parametric.mli: -------------------------------------------------------------------------------- 1 | (** An example of a simple, parametric L-System *) 2 | 3 | (** Alphabet of symbols for this system *) 4 | type symbol 5 | 6 | include System.Grammar 7 | with type symbol := symbol 8 | (** @open *) 9 | 10 | 11 | (** {1 String interpretation} *) 12 | 13 | (** Convert a symbol to a string *) 14 | val string_of_symbol : symbol -> string 15 | 16 | (** Convert a word to a string *) 17 | val string_of_word : symbol list -> string 18 | -------------------------------------------------------------------------------- /lang-fractal-growth/test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (package lang-fractal-growth) 3 | (deps %{bin:fractal-growth})) 4 | -------------------------------------------------------------------------------- /lang-fractal-tree-rewriting/README.md: -------------------------------------------------------------------------------- 1 | # Plant growth DSL 2 | 3 | This is a plant growth DSL based on tree rewriting. 4 | 5 | ```command 6 | $ dune build lang-fractal-tree-rewriting 7 | $ python -m http.server 8000 --bind localhost --directory _build/default/lang-fractal-tree-rewriting 8 | ``` 9 | 10 | Then navigate to . 11 | 12 | ## Todo list 13 | 14 | Language features 15 | 16 | - [x] Deterministic systems 17 | - [ ] Nondeterministic systems 18 | - [ ] Stochastic systems 19 | - [ ] Context-sensitive systems 20 | 21 | Language tooling 22 | 23 | - [x] Internal DSL 24 | - [ ] External DSL 25 | - [ ] Web Playground 26 | - [ ] Component library 27 | - [ ] Render components and transitions separately 28 | - [ ] Rule stepper 29 | -------------------------------------------------------------------------------- /lang-fractal-tree-rewriting/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (alias 4 | (name lang-fractal-tree-rewriting) 5 | (package lang-fractal-tree-rewriting)) 6 | 7 | (alias 8 | (name all) 9 | (package lang-fractal-tree-rewriting) 10 | (deps 11 | (glob_files *.html) 12 | index.bc.js)) 13 | 14 | (executable 15 | (name index) 16 | (modes js) 17 | (libraries 18 | lang-declarative-graphics.core 19 | lang-declarative-graphics.jsoo 20 | js_of_ocaml) 21 | (preprocess 22 | (pps js_of_ocaml-ppx))) 23 | -------------------------------------------------------------------------------- /lang-fractal-tree-rewriting/examples/examples.ml: -------------------------------------------------------------------------------- 1 | module Binary_tree = System.Deterministic.Make (Binary_tree) 2 | -------------------------------------------------------------------------------- /lang-fractal-tree-rewriting/examples/examples.mli: -------------------------------------------------------------------------------- 1 | (** Example systems *) 2 | 3 | module Binary_tree : System.Deterministic.S 4 | -------------------------------------------------------------------------------- /lang-fractal-tree-rewriting/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Fractal binary tree 7 | 8 | 9 | 10 |

Fractal binary tree

11 |

An example of a fractal binary tree, rendered using HTML canvas.

12 | 
13 | type tree :=
14 |   | .apex
15 |   | .fork(tree, tree)
16 |   | .branch(tree)
17 | 
18 | def axiom :=
19 |   .apex
20 | 
21 | def rules :=
22 |   | .apex        -> .branch(.fork(.apex, .apex))
23 |   | .branch(...) -> .branch(.branch(...))
24 | 
25 | def apex-diameter := 3px
26 | def fork-angle := 45deg
27 | def branch-length := 6px
28 | 
29 | def draw :=
30 |   | .apex ->
31 |       circle apex-diameter
32 |   | .fork(tree1..., tree2...) ->
33 |       stack [
34 |         rotate (+fork-angle) (tree2...),
35 |         rotate (-fork-angle) (tree2...),
36 |       ]
37 |   | .branch(...) ->
38 |       stack [
39 |         line (0.0, 0.0) (0.0, -branch-length),
40 |         translate-y (-branch-length) ...,
41 |       ]
42 |
43 |
44 | 45 | 46 | -------------------------------------------------------------------------------- /lang-fractal-tree-rewriting/index.ml: -------------------------------------------------------------------------------- 1 | module Canvas_diagram = Declarative_graphics_jsoo.Canvas_diagram 2 | module Dom = Js_of_ocaml.Dom 3 | module Html = Js_of_ocaml.Dom_html 4 | module Js = Js_of_ocaml.Js 5 | 6 | let canvas_width = 400.0 7 | let canvas_height = 400.0 8 | 9 | let start (_ : (#Html.event as 'b) Js.t) : bool Js.t = begin 10 | (* Initialise canvas and 2D drawing context *) 11 | let canvas = Html.createCanvas Html.document in 12 | let ctx = canvas##getContext Html._2d_ in 13 | Dom.appendChild (Html.getElementById "tree") canvas; 14 | 15 | (* Set display size in CSS pixels *) 16 | canvas##.style##.width := Js.string ((canvas_width |> Float.to_int |> Int.to_string) ^ "px"); 17 | canvas##.style##.height := Js.string ((canvas_height |> Float.to_int |> Int.to_string) ^ "px"); 18 | 19 | (* Set the actual size in memory *) 20 | let scale = Html.window##.devicePixelRatio in 21 | canvas##.width := int_of_float (canvas_width *. Js.to_float scale); 22 | canvas##.height := int_of_float (canvas_height *. Js.to_float scale); 23 | 24 | (* Normalise the coordinate system to CSS pixels *) 25 | ctx##scale scale scale; 26 | 27 | (* TODO: stepper *) 28 | 29 | (* Draw the tree *) 30 | Examples.Binary_tree.(render (module Canvas_diagram) (grow 5)) 31 | |> Canvas_diagram.translate (canvas_width *. 0.5, canvas_height) 32 | |> Canvas_diagram.run ctx; 33 | 34 | Js._false 35 | end 36 | 37 | let () = 38 | Html.window##.onload := Html.handler start 39 | -------------------------------------------------------------------------------- /lang-fractal-tree-rewriting/system/system.ml: -------------------------------------------------------------------------------- 1 | (** Parallel tree rewriting systems *) 2 | 3 | open Declarative_graphics_core 4 | 5 | module Deterministic = struct 6 | 7 | module type Core = System_intf.Deterministic.Core 8 | module type S = System_intf.Deterministic.S 9 | 10 | module Make (X : Core) : S 11 | with type t = X.t 12 | = struct 13 | 14 | include X 15 | 16 | let rec step tree = 17 | rules step tree 18 | 19 | let grow ?(axiom = axiom) (iters : int) : t = 20 | let rec go iters tree = 21 | if iters < 0 then tree else 22 | (go [@tailcall]) (iters - 1) (step tree) 23 | in 24 | go iters axiom 25 | 26 | let generations ?(axiom = axiom) () = 27 | Seq.unfold (fun t -> Some (t, step t)) axiom 28 | 29 | let render (type d) (module D : Diagram.S with type t = d) : t -> d = 30 | let draw = draw (module D) in 31 | let rec render (tree : t) : d = 32 | draw render tree 33 | in 34 | render 35 | 36 | end 37 | 38 | end 39 | -------------------------------------------------------------------------------- /lang-fractal-tree-rewriting/system/system.mli: -------------------------------------------------------------------------------- 1 | module Deterministic : sig 2 | 3 | module type Core = System_intf.Deterministic.Core 4 | module type S = System_intf.Deterministic.S 5 | 6 | module Make (X : Core) : S 7 | with type t = X.t 8 | 9 | end 10 | -------------------------------------------------------------------------------- /lang-fractal-tree-rewriting/system/system_intf.ml: -------------------------------------------------------------------------------- 1 | open Declarative_graphics_core 2 | 3 | module Deterministic = struct 4 | 5 | module type Core = sig 6 | 7 | type t 8 | 9 | val axiom : t 10 | val rules : (t -> t) -> t -> t 11 | val draw : 'd. (module Diagram.S with type t = 'd) -> (t -> 'd) -> t -> 'd 12 | 13 | end 14 | 15 | module type S = sig 16 | 17 | include Core 18 | 19 | val step : t -> t 20 | val grow : ?axiom:t -> int -> t 21 | val generations : ?axiom:t -> unit -> t Seq.t 22 | val render : 'd. (module Diagram.S with type t = 'd) -> t -> 'd 23 | 24 | end 25 | 26 | end 27 | -------------------------------------------------------------------------------- /lang-lc-interpreters/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name name-binding-comparison) 4 | (package lang-lc-interpreters) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | menhirLib)) 9 | 10 | (menhir 11 | (modules parser) 12 | (flags --explain --strict)) 13 | -------------------------------------------------------------------------------- /lang-lc-interpreters/lexer.ml: -------------------------------------------------------------------------------- 1 | exception Error of [ 2 | | `Unexpected_char 3 | | `Unclosed_block_comment 4 | ] 5 | 6 | let whitespace = [%sedlex.regexp? Plus (' ' | '\t' | '\r' | '\n')] 7 | let newline = [%sedlex.regexp? '\r' | '\n' | "\r\n"] 8 | 9 | let name_start = [%sedlex.regexp? 'a'..'z' | 'A'..'Z'] 10 | let name_continue = [%sedlex.regexp? '-' | '_' | 'a'..'z' | 'A'..'Z' | '0'..'9'] 11 | let name = [%sedlex.regexp? name_start, Star name_continue] 12 | 13 | let rec token (lexbuf : Sedlexing.lexbuf) : Parser.token = 14 | match%sedlex lexbuf with 15 | | whitespace -> token lexbuf 16 | | "--" -> line_comment lexbuf 17 | | "/-" -> block_comment lexbuf 0 18 | | "fun" -> KEYWORD_FUN 19 | | "let" -> KEYWORD_LET 20 | | name -> NAME (Sedlexing.Utf8.lexeme lexbuf) 21 | | ":=" -> COLON_EQUALS 22 | | "=>" -> EQUALS_GREATER 23 | | ";" -> SEMICOLON 24 | | "(" -> OPEN_PAREN 25 | | ")" -> CLOSE_PAREN 26 | | eof -> END 27 | | _ -> raise (Error `Unexpected_char) 28 | 29 | and line_comment (lexbuf : Sedlexing.lexbuf) : Parser.token = 30 | match%sedlex lexbuf with 31 | | newline -> token lexbuf 32 | | any -> line_comment lexbuf 33 | | eof -> END 34 | | _ -> raise (Error `Unexpected_char) 35 | 36 | and block_comment (lexbuf : Sedlexing.lexbuf) (level : int) : Parser.token = 37 | match%sedlex lexbuf with 38 | | "/-" -> block_comment lexbuf (level + 1) 39 | | "-/" -> if level = 0 then token lexbuf else block_comment lexbuf (level - 1) 40 | | any -> block_comment lexbuf level 41 | | eof -> raise (Error `Unclosed_block_comment) 42 | | _ -> raise (Error `Unexpected_char) 43 | -------------------------------------------------------------------------------- /lang-lc-interpreters/main.ml: -------------------------------------------------------------------------------- 1 | (* TODO: entrypoint *) 2 | 3 | (* NOTE: Tempory re-exports to ensure modules are typechecked *) 4 | 5 | module Lexer = Lexer 6 | module Parser = Parser 7 | 8 | module type Lang = sig 9 | 10 | type expr 11 | 12 | val to_named : expr -> Named.expr 13 | val of_named : Named.expr -> expr 14 | val alpha_equiv : expr -> expr -> bool 15 | val normalise : expr -> expr 16 | 17 | end 18 | [@@warning "-unused-value-declaration"] 19 | 20 | 21 | module Named : Lang 22 | with type expr = Named.expr 23 | = struct 24 | include Named 25 | let to_named = Fun.id 26 | let of_named = Fun.id 27 | end 28 | 29 | module Named_nbe_closures : Lang = struct 30 | include Named_nbe_closures 31 | let to_named = Fun.id 32 | let of_named = Fun.id 33 | let normalise = normalise [] 34 | end 35 | 36 | module Named_nbe_hoas : Lang = struct 37 | include Named_nbe_hoas 38 | let to_named = Fun.id 39 | let of_named = Fun.id 40 | let normalise = normalise [] 41 | end 42 | 43 | 44 | module Nameless : Lang = Nameless 45 | 46 | module Nameless_nbe_closures : Lang = struct 47 | include Nameless_nbe_closures 48 | let normalise = normalise [] 49 | end 50 | 51 | module Nameless_nbe_hoas : Lang = struct 52 | include Nameless_nbe_hoas 53 | let normalise = normalise [] 54 | end 55 | 56 | 57 | module Unique : Lang = Unique 58 | 59 | module Unique_nbe_closures : Lang = struct 60 | include Unique_nbe_closures 61 | let normalise = normalise Id.Map.empty 62 | end 63 | 64 | module Unique_nbe_hoas : Lang = struct 65 | include Unique_nbe_hoas 66 | let normalise = normalise Id.Map.empty 67 | end 68 | -------------------------------------------------------------------------------- /lang-lc-interpreters/parser.mly: -------------------------------------------------------------------------------- 1 | %token NAME 2 | %token KEYWORD_FUN "fun" 3 | %token KEYWORD_LET "let" 4 | %token COLON_EQUALS ":=" 5 | %token EQUALS_GREATER "=>" 6 | %token SEMICOLON ";" 7 | %token OPEN_PAREN "(" 8 | %token CLOSE_PAREN ")" 9 | %token END 10 | 11 | %start main 12 | 13 | %% 14 | 15 | let main := 16 | | e = expr; END; 17 | { e } 18 | 19 | let expr := 20 | | "let"; n = NAME; ":="; e1 = expr; ";"; e2 = expr; 21 | { Named.Let (n, e1, e2) } 22 | | "fun"; n = NAME; "=>"; e = expr; 23 | { Named.Fun_lit (n, e) } 24 | | app_expr 25 | 26 | let app_expr := 27 | | e1 = app_expr; e2 = atomic_expr; 28 | { Named.Fun_app (e1, e2) } 29 | | atomic_expr 30 | 31 | let atomic_expr := 32 | | "("; e = expr; ")"; 33 | { e } 34 | | n = NAME; 35 | { Named.Var n } 36 | -------------------------------------------------------------------------------- /lang-shader-graphics/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name shader-graphics) 4 | (package lang-shader-graphics) 5 | (libraries 6 | lang-shader-graphics 7 | lang-shader-graphics.examples 8 | 9 | cmdliner)) 10 | -------------------------------------------------------------------------------- /lang-shader-graphics/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package lang-shader-graphics)) 3 | -------------------------------------------------------------------------------- /lang-shader-graphics/examples/basic.mli: -------------------------------------------------------------------------------- 1 | (** A basic scene, implemented using signed distance fields. *) 2 | 3 | module Make : Scene.F 4 | -------------------------------------------------------------------------------- /lang-shader-graphics/examples/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name shader_graphics_examples) 3 | (public_name lang-shader-graphics.examples) 4 | (libraries lang-shader-graphics)) 5 | -------------------------------------------------------------------------------- /lang-shader-graphics/examples/readme.ml: -------------------------------------------------------------------------------- 1 | open Shader_graphics.Data 2 | 3 | module Monad = Shader_graphics.Control.Monad 4 | 5 | module Cpu = Shader_graphics.Cpu 6 | module Glsl = Shader_graphics.Glsl 7 | module Sdf = Shader_graphics.Sdf 8 | module Shader = Shader_graphics.Shader 9 | 10 | module Make (L : Shader.S) = struct 11 | 12 | open Sdf.Make (L) 13 | 14 | (** An environment with access to a 2D coordinate. *) 15 | module Env = Monad.Reader.Function (struct 16 | type t = vec2f repr 17 | end) 18 | 19 | (* Bring notations into scope *) 20 | open L.O 21 | open Env.O 22 | 23 | 24 | (* $MDX part-begin=scene *) 25 | (** A scene to render, assuming UV coordinates in (-0.5, 0.5) *) 26 | let scene : (vec3f repr) Env.t = 27 | (* Some shapes defined using signed distance functions *) 28 | let* s1 = circle !!0.3 |> move (L.vec2 !!0.0 !!0.0) in 29 | let* s2 = square !!0.2 |> move (L.vec2 !!0.2 !!0.0) in 30 | 31 | (* Combine the two shapes, meeting at a rounded edge *) 32 | let shape = union_round s1 s2 !!0.05 in 33 | 34 | (* Colours to use in the background and foreground *) 35 | let background_color = L.vec3 !!0.35 !!0.45 !!0.50 in 36 | let shape_color = L.vec3 !!1.0 !!1.0 !!1.0 in 37 | 38 | (* The final output colour to render at the current UV coordinate. *) 39 | Env.pure (background_color |> overlay ~shape:shape ~color:shape_color) 40 | (* $MDX part-end *) 41 | 42 | 43 | (** The scene, rendered as a function from pixel positions to colours. *) 44 | let image ~dimensions ~position : vec3f repr = 45 | scene (L.normalise_coords ~dimensions ~position) 46 | 47 | end 48 | -------------------------------------------------------------------------------- /lang-shader-graphics/examples/readme.mli: -------------------------------------------------------------------------------- 1 | (** The code example from the readme. *) 2 | 3 | module Make : Scene.F 4 | -------------------------------------------------------------------------------- /lang-shader-graphics/examples/scene.ml: -------------------------------------------------------------------------------- 1 | open Shader_graphics.Data 2 | 3 | module Shader = Shader_graphics.Shader 4 | 5 | (** Construct a scene for a shader language *) 6 | module type F = functor (S : Shader.S) -> sig 7 | 8 | (** Build an image for the shader language [S] *) 9 | val image : dimensions:vec2f S.repr -> position:vec2f S.repr -> vec3f S.repr 10 | 11 | end 12 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/control/applicative.ml: -------------------------------------------------------------------------------- 1 | include Applicative_intf 2 | 3 | module Make (X : Core) : S 4 | with type 'a t = 'a X.t 5 | = struct 6 | 7 | include X 8 | include Functor.Make (X) 9 | 10 | let ( <*> ) = apply 11 | 12 | let both x1 x2 = 13 | map (fun x1 x2 -> (x1, x2)) x1 <*> x2 14 | 15 | let map0 = pure 16 | let map1 = map 17 | let map2 f x1 x2 = map1 f x1 <*> x2 18 | let map3 f x1 x2 x3 = map2 f x1 x2 <*> x3 19 | let map4 f x1 x2 x3 x4 = map3 f x1 x2 x3 <*> x4 20 | 21 | module O = struct 22 | 23 | include O 24 | 25 | let ( <*> ) = ( <*> ) 26 | let ( and+ ) = ( both ) 27 | 28 | end 29 | 30 | end 31 | 32 | module Compose (F : S) (G : S) = Make (struct 33 | 34 | include Functor.Compose (F) (G) 35 | 36 | let pure x = F.pure (G.pure x) 37 | let apply f x = F.apply (F.map G.apply f) x 38 | 39 | end) 40 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/control/applicative.mli: -------------------------------------------------------------------------------- 1 | module type Core = Applicative_intf.Core 2 | module type S = Applicative_intf.S 3 | 4 | module Make (X : Core) : S 5 | with type 'a t = 'a X.t 6 | 7 | (** The composition of two applicative functors *) 8 | module Compose (F : S) (G : S) : S 9 | with type 'a t = 'a G.t F.t 10 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/control/applicative_intf.ml: -------------------------------------------------------------------------------- 1 | module type Core = sig 2 | 3 | type 'a t 4 | 5 | include Functor.Core with type 'a t := 'a t 6 | 7 | val pure : 'a. 'a -> 'a t 8 | (** Embed a pure value in [t] *) 9 | 10 | val apply : 'a 'b. ('a -> 'b) t -> 'a t -> 'b t 11 | (** Apply a function embedded in [t] to a value embedded in [t] *) 12 | 13 | end 14 | 15 | (** Applicative functors 16 | 17 | This can be seen as a generalisation of the {!Functor.S} signature, but 18 | where {!Functor.S.map} can take any number of arguments. 19 | 20 | Applicatives can also be viewed as a restricted form of the {!Monad.S} signature, 21 | where one computation cannot depend on the result of another computation. 22 | For this reason applicatives are a useful way of describing effects that can be parallelised. 23 | *) 24 | module type S = sig 25 | 26 | include Core 27 | 28 | include Functor.S with type 'a t := 'a t 29 | 30 | val both : 'a 'b. 'a t -> 'b t -> ('a * 'b) t 31 | 32 | val map0 : 'a. 'a -> 'a t 33 | val map1 : 'a 'b. ('a -> 'b) -> 'a t -> 'b t 34 | val map2 : 'a 'b 'c. ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t 35 | val map3 : 'a 'b 'c 'd. ('a -> 'b -> 'c -> 'd) -> 'a t -> 'b t -> 'c t -> 'd t 36 | val map4 : 'a 'b 'c 'd 'e. ('a -> 'b -> 'c -> 'd -> 'e) -> 'a t -> 'b t -> 'c t -> 'd t -> 'e t 37 | 38 | (** Convenience operators *) 39 | module O : sig 40 | 41 | include module type of O 42 | 43 | val ( let+ ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t 44 | (** Alias for {!map} *) 45 | 46 | val ( and+ ) : 'a 'b. 'a t -> 'b t -> ('a * 'b) t 47 | (** Alias for {!both} *) 48 | 49 | val ( <*> ) : 'a 'b. ('a -> 'b) t -> 'a t -> 'b t 50 | (** Alias for {!apply} *) 51 | 52 | end 53 | 54 | end 55 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/control/control.ml: -------------------------------------------------------------------------------- 1 | module Functor = Functor 2 | module Applicative = Applicative 3 | module Monad = Monad 4 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/control/functor.ml: -------------------------------------------------------------------------------- 1 | include Functor_intf 2 | 3 | module Make (X : Core) : S 4 | with type 'a t = 'a X.t 5 | = struct 6 | 7 | include X 8 | 9 | let void_left : type a b. a -> b t -> a t = 10 | fun x f -> map (Fun.const x) f 11 | 12 | let void_right : type a b. b t -> a -> a t = 13 | fun f x -> map (Fun.const x) f 14 | 15 | module O = struct 16 | 17 | let ( let+ ) t f = map f t 18 | let ( >|= ) t f = map f t 19 | let ( <$> ) = map 20 | let ( <$ ) = void_left 21 | let ( $> ) = void_right 22 | 23 | end 24 | 25 | end 26 | 27 | module Compose (F : S) (G : S) = Make (struct 28 | 29 | type 'a t = 'a G.t F.t 30 | 31 | let map f x = F.map (G.map f) x 32 | 33 | end) 34 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/control/functor.mli: -------------------------------------------------------------------------------- 1 | module type Core = Functor_intf.Core 2 | module type S = Functor_intf.S 3 | 4 | module Make (X : Core) : S 5 | with type 'a t = 'a X.t 6 | 7 | (** The composition of two functors *) 8 | module Compose (F : S) (G : S) : S 9 | with type 'a t = 'a G.t F.t 10 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/control/functor_intf.ml: -------------------------------------------------------------------------------- 1 | module type Core = sig 2 | 3 | type 'a t 4 | 5 | val map : 'a 'b. ('a -> 'b) -> ('a t -> 'b t) 6 | (** Turn a function of type ['a -> 'b] into a function of type 7 | ['a t -> 'b t]. *) 8 | 9 | (** {1 Laws} 10 | 11 | - Identity: [map Fun.id = Fun.id] 12 | - Composition: [map (f >> g) = map f >> map g] 13 | *) 14 | 15 | end 16 | 17 | (** A type constructor ['a t] that supports a mapping operation [map]. *) 18 | module type S = sig 19 | (** This is technically an “endofunctor” between the ‘category’ of OCaml 20 | types and functions. *) 21 | 22 | include Core 23 | 24 | val void_left : 'a 'b. 'a -> 'b t -> 'a t 25 | val void_right : 'a 'b. 'b t -> 'a -> 'a t 26 | 27 | (** Convenience operators *) 28 | module O : sig 29 | 30 | val ( let+ ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t 31 | val ( >|= ) : 'a 'b. 'a t -> ('a -> 'b) -> 'b t 32 | val ( <$> ) : 'a 'b. ('a -> 'b) -> 'a t -> 'b t 33 | val ( <$ ) : 'a 'b. 'a -> 'b t -> 'a t 34 | val ( $> ) : 'a 'b. 'b t -> 'a -> 'a t 35 | 36 | end 37 | 38 | end 39 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/control/monad.mli: -------------------------------------------------------------------------------- 1 | module type Core = Monad_intf.Core 2 | module type S = Monad_intf.S 3 | 4 | module Make (X : Core) : S 5 | with type 'a t = 'a X.t 6 | 7 | module Reader : sig 8 | 9 | module type S = Monad_intf.Reader.S 10 | 11 | (** A reader implemented for functions *) 12 | module Function (V : sig type t end) : S 13 | with type value = V.t 14 | with type 'a t = V.t -> 'a 15 | 16 | (** A reader with an abstract implementation *) 17 | module Make (V : sig type t end) : S 18 | with type value = V.t 19 | 20 | end 21 | 22 | module State : sig 23 | 24 | module type S = Monad_intf.State.S 25 | 26 | (** A state monad implemented for functions *) 27 | module Function (V : sig type t end) : S 28 | with type state = V.t 29 | with type 'a t = V.t -> 'a * V.t 30 | 31 | (** A state monad with an abstract implementation *) 32 | module Make (V : sig type t end) : S 33 | with type state = V.t 34 | 35 | end 36 | 37 | (** Operations on the output (returned value) of a function *) 38 | module Output (Input : sig type t end) : S 39 | with type 'a t = Input.t -> 'a 40 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/cpu.mli: -------------------------------------------------------------------------------- 1 | (** {0 CPU based shader language} *) 2 | 3 | (** This implements a shader language natively in OCaml. This is useful for 4 | testing the shader language and SDFs without needing to interface with 5 | graphics APIs. It could also be useful for implementing constant folding 6 | optimisations in the future. *) 7 | 8 | open Data 9 | 10 | 11 | include Shader.S with type 'a repr = 'a 12 | 13 | (** An image shader to be run on the CPU. The function takes a pixel (fragment) 14 | coordinate as an argument and returns the color that should be rendered at 15 | that pixel. *) 16 | type image_shader = vec2f repr -> vec3f repr 17 | 18 | (** Render the shader sequentially on the CPU to a PPM image file, using a 19 | coordinate system that starts from the bottom-left corner of the screen 20 | for compatibility with OpenGL and Vulkan style shaders. *) 21 | val render_ppm : width:int -> height:int -> image_shader -> unit 22 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/data/data.ml: -------------------------------------------------------------------------------- 1 | (** {0 Common storage types used in GPU shader languages} *) 2 | 3 | module Nat = Nat 4 | module Vec = Vec 5 | 6 | (** {1 Fixed-size vectors} *) 7 | 8 | type ('s, 'n) vec = ('s, 'n) Vec.t 9 | 10 | type 'n vecf = (float, 'n) vec 11 | 12 | (** {2 Vectors of a given size} *) 13 | 14 | type 's vec1 = ('s, Nat.n1) vec 15 | type 's vec2 = ('s, Nat.n2) vec 16 | type 's vec3 = ('s, Nat.n3) vec 17 | type 's vec4 = ('s, Nat.n4) vec 18 | 19 | type vec1f = Nat.n1 vecf 20 | type vec2f = Nat.n2 vecf 21 | type vec3f = Nat.n3 vecf 22 | type vec4f = Nat.n4 vecf 23 | 24 | (** {2 Vectors that are greater than or equal to a given size} *) 25 | 26 | type ('s, 'n) vec_ge1 = ('s, 'n Nat.ge1) vec 27 | type ('s, 'n) vec_ge2 = ('s, 'n Nat.ge2) vec 28 | type ('s, 'n) vec_ge3 = ('s, 'n Nat.ge3) vec 29 | type ('s, 'n) vec_ge4 = ('s, 'n Nat.ge4) vec 30 | 31 | type 'n vec_ge1f = ('n Nat.ge1) vecf 32 | type 'n vec_ge2f = ('n Nat.ge2) vecf 33 | type 'n vec_ge3f = ('n Nat.ge3) vecf 34 | type 'n vec_ge4f = ('n Nat.ge4) vecf 35 | 36 | 37 | (** {1 Fixed-size matrices} *) 38 | 39 | type 's mat2 = ('s vec2) vec2 40 | type 's mat3 = ('s vec3) vec3 41 | type 's mat4 = ('s vec4) vec4 42 | 43 | type mat2f = float mat2 44 | type mat3f = float mat3 45 | type mat4f = float mat4 46 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/data/nat.ml: -------------------------------------------------------------------------------- 1 | (** Type level natural numbers *) 2 | 3 | (** A type that represents the number zero, i.e. [0] *) 4 | type zero = private Z 5 | 6 | (** A type that represents the successor of ['n], i.e. ['n + 1] *) 7 | type 'n succ = private Succ of 'n 8 | 9 | (** {2 Natural number constants} *) 10 | 11 | type n0 = zero 12 | type n1 = n0 succ 13 | type n2 = n1 succ 14 | type n3 = n2 succ 15 | type n4 = n3 succ 16 | 17 | (** {2 Greater-than or equal to constants} *) 18 | 19 | (** These are useful for expressing the idea that a number must be at least a 20 | certian natural number *) 21 | 22 | type 'n ge1 = 'n succ 23 | type 'n ge2 = 'n succ ge1 24 | type 'n ge3 = 'n succ ge2 25 | type 'n ge4 = 'n succ ge3 26 | -------------------------------------------------------------------------------- /lang-shader-graphics/lib/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (library 4 | (name shader_graphics) 5 | (public_name lang-shader-graphics)) 6 | 7 | (env 8 | (dev 9 | ; see `ocamlc -warn-help` for information on warnings 10 | (flags (:standard -w -unused-constructor 11 | -w -unused-type-declaration 12 | -w -unused-value-declaration)))) 13 | -------------------------------------------------------------------------------- /lang-shader-graphics/test/basic.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brendanzab/language-garden/e7ae8cc240552b6d1b892109cefe5380095d1ea2/lang-shader-graphics/test/basic.png -------------------------------------------------------------------------------- /lang-shader-graphics/test/cli.t: -------------------------------------------------------------------------------- 1 | Usage error 2 | $ shader-graphics 3 | shader-graphics: required COMMAND name is missing, must be one of 'compile', 'list' or 'render'. 4 | Usage: shader-graphics COMMAND … 5 | Try 'shader-graphics --help' for more information. 6 | [124] 7 | 8 | List scenes 9 | $ shader-graphics list 10 | basic 11 | readme 12 | -------------------------------------------------------------------------------- /lang-shader-graphics/test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (package lang-shader-graphics) 3 | (deps %{bin:shader-graphics})) 4 | 5 | (rule 6 | (with-stdout-to basic.glsl.tmp 7 | (run %{bin:shader-graphics} compile --scene=basic))) 8 | 9 | (rule 10 | (alias runtest) 11 | (package lang-shader-graphics) 12 | (action (diff basic.glsl 13 | basic.glsl.tmp))) 14 | 15 | (rule 16 | (with-stdout-to basic.png.tmp 17 | (pipe-stdout 18 | (run %{bin:shader-graphics} render --scene=basic) 19 | (run pnmtopng)))) 20 | 21 | (rule 22 | (alias runtest) 23 | (package lang-shader-graphics) 24 | (action (cmp basic.png 25 | basic.png.tmp))) 26 | 27 | 28 | (rule 29 | (with-stdout-to readme.glsl.tmp 30 | (run %{bin:shader-graphics} compile --scene=readme))) 31 | 32 | (rule 33 | (alias runtest) 34 | (package lang-shader-graphics) 35 | (action (diff readme.glsl 36 | readme.glsl.tmp))) 37 | 38 | (rule 39 | (with-stdout-to readme.png.tmp 40 | (pipe-stdout 41 | (run %{bin:shader-graphics} render --scene=readme) 42 | (run pnmtopng)))) 43 | 44 | (rule 45 | (alias runtest) 46 | (package lang-shader-graphics) 47 | (action (cmp readme.png 48 | readme.png.tmp))) 49 | -------------------------------------------------------------------------------- /lang-shader-graphics/test/readme.glsl: -------------------------------------------------------------------------------- 1 | // The main entrypoint of the shader. 2 | // 3 | // Copy and paste this into https://www.shadertoy.com/new to see the output. 4 | void mainImage(out vec4 fragColor, in vec2 fragCoord) { 5 | vec3 t0 = vec3(1., 1., 1.); 6 | vec3 t1 = vec3(0.35, 0.45, 0.5); 7 | vec2 t2 = iResolution.xy; 8 | vec2 t3 = fragCoord / t2; 9 | vec2 t4 = t3 - 0.5; 10 | float t5 = t4.x; 11 | float t6 = t2.x; 12 | float t7 = t2.y; 13 | float t8 = t6 / t7; 14 | float t9 = t5 * t8; 15 | float t10 = t4.y; 16 | vec2 t11 = vec2(t9, t10); 17 | vec2 t12 = vec2(0., 0.); 18 | vec2 t13 = t11 - t12; 19 | float t14 = length(t13); 20 | float t15 = t14 - 0.3; 21 | vec2 t16 = vec2(0.2, 0.); 22 | vec2 t17 = t11 - t16; 23 | vec2 t18 = abs(t17); 24 | float t19 = t18.x; 25 | float t20 = t18.y; 26 | float t21 = max(t19, t20); 27 | float t22 = t21 - 0.2; 28 | float t23 = min(t15, t22); 29 | float t24 = max(0.05, t23); 30 | float t25 = 0.05 - t15; 31 | float t26 = 0.05 - t22; 32 | vec2 t27 = vec2(t25, t26); 33 | vec2 t28 = max(t27, t12); 34 | float t29 = length(t28); 35 | float t30 = t24 - t29; 36 | float t31 = step(0., t30); 37 | vec3 t32 = mix(t0, t1, t31); 38 | 39 | // Set the color of the current pixel 40 | fragColor = vec4(t32, 1.0); 41 | } 42 | -------------------------------------------------------------------------------- /lang-shader-graphics/test/readme.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/brendanzab/language-garden/e7ae8cc240552b6d1b892109cefe5380095d1ea2/lang-shader-graphics/test/readme.png -------------------------------------------------------------------------------- /opam/compile-arith.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "alcotest" {>= "1.8" & with-test} 9 | "cmdliner" {>= "1.3"} 10 | "mdx" {>= "2.4.1" & with-test} 11 | "menhir" {>= "20240715" & build} 12 | "menhirLib" {>= "20240715"} 13 | "qcheck" {>= "0.22" & with-test} 14 | "qcheck-core" {>= "0.22" & with-test} 15 | "qcheck-alcotest" {>= "0.22" & with-test} 16 | "sedlex" {>= "3.3"} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 34 | -------------------------------------------------------------------------------- /opam/compile-arithcond.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "alcotest" {>= "1.8" & with-test} 9 | "cmdliner" {>= "1.3"} 10 | "mdx" {>= "2.4.1" & with-test} 11 | "menhir" {>= "20240715" & build} 12 | "menhirLib" {>= "20240715"} 13 | "qcheck" {>= "0.22" & with-test} 14 | "qcheck-core" {>= "0.22" & with-test} 15 | "qcheck-alcotest" {>= "0.22" & with-test} 16 | "sedlex" {>= "3.3"} 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {dev} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 34 | -------------------------------------------------------------------------------- /opam/declarative-graphics.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "js_of_ocaml-compiler" {>= "5.8.2"} 9 | "js_of_ocaml" {>= "5.8.2"} 10 | "js_of_ocaml-ppx" {>= "5.8.2"} 11 | "odoc" {with-doc} 12 | ] 13 | build: [ 14 | ["dune" "subst"] {dev} 15 | [ 16 | "dune" 17 | "build" 18 | "-p" 19 | name 20 | "-j" 21 | jobs 22 | "@install" 23 | "@runtest" {with-test} 24 | "@doc" {with-doc} 25 | ] 26 | ] 27 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 28 | -------------------------------------------------------------------------------- /opam/elab-dependent-sugar.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/elab-dependent.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/elab-record-patching.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/elab-stlc-abstract.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "menhir" {>= "20240715" & build} 9 | "menhirLib" {>= "20240715"} 10 | "sedlex" {>= "3.3"} 11 | "odoc" {with-doc} 12 | ] 13 | build: [ 14 | ["dune" "subst"] {dev} 15 | [ 16 | "dune" 17 | "build" 18 | "-p" 19 | name 20 | "-j" 21 | jobs 22 | "@install" 23 | "@runtest" {with-test} 24 | "@doc" {with-doc} 25 | ] 26 | ] 27 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 28 | -------------------------------------------------------------------------------- /opam/elab-stlc-bidirectional-stratify.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/elab-stlc-bidirectional.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/elab-stlc-letrec-unification.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/elab-stlc-row-unification.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/elab-stlc-unification.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/elab-stlc-variant-unification.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/elab-system-f-bidirectional.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/elab-system-f-unification.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/lang-datalog.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "menhir" {>= "20240715" & build} 9 | "menhirLib" {>= "20240715"} 10 | "mdx" {>= "2.4.1" & with-test} 11 | "sedlex" {>= "3.3"} 12 | "odoc" {with-doc} 13 | ] 14 | build: [ 15 | ["dune" "subst"] {dev} 16 | [ 17 | "dune" 18 | "build" 19 | "-p" 20 | name 21 | "-j" 22 | jobs 23 | "@install" 24 | "@runtest" {with-test} 25 | "@doc" {with-doc} 26 | ] 27 | ] 28 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 29 | -------------------------------------------------------------------------------- /opam/lang-declarative-graphics.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "js_of_ocaml-compiler" {>= "5.8.2"} 9 | "js_of_ocaml" {>= "5.8.2"} 10 | "js_of_ocaml-ppx" {>= "5.8.2"} 11 | "odoc" {with-doc} 12 | ] 13 | build: [ 14 | ["dune" "subst"] {dev} 15 | [ 16 | "dune" 17 | "build" 18 | "-p" 19 | name 20 | "-j" 21 | jobs 22 | "@install" 23 | "@runtest" {with-test} 24 | "@doc" {with-doc} 25 | ] 26 | ] 27 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 28 | -------------------------------------------------------------------------------- /opam/lang-diagrams.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "js_of_ocaml" {>= "5.8.2"} 9 | "js_of_ocaml-ppx" {>= "5.8.2"} 10 | "odoc" {with-doc} 11 | ] 12 | build: [ 13 | ["dune" "subst"] {dev} 14 | [ 15 | "dune" 16 | "build" 17 | "-p" 18 | name 19 | "-j" 20 | jobs 21 | "@install" 22 | "@runtest" {with-test} 23 | "@doc" {with-doc} 24 | ] 25 | ] 26 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 27 | -------------------------------------------------------------------------------- /opam/lang-doc-templates.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "menhir" {>= "20240715" & build} 9 | "menhirLib" {>= "20240715"} 10 | "mdx" {>= "2.4.1" & with-test} 11 | "sedlex" {>= "3.3"} 12 | "odoc" {with-doc} 13 | ] 14 | build: [ 15 | ["dune" "subst"] {dev} 16 | [ 17 | "dune" 18 | "build" 19 | "-p" 20 | name 21 | "-j" 22 | jobs 23 | "@install" 24 | "@runtest" {with-test} 25 | "@doc" {with-doc} 26 | ] 27 | ] 28 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 29 | -------------------------------------------------------------------------------- /opam/lang-fractal-growth.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "mdx" {>= "2.4.1" & with-test} 10 | "odoc" {with-doc} 11 | ] 12 | build: [ 13 | ["dune" "subst"] {dev} 14 | [ 15 | "dune" 16 | "build" 17 | "-p" 18 | name 19 | "-j" 20 | jobs 21 | "@install" 22 | "@runtest" {with-test} 23 | "@doc" {with-doc} 24 | ] 25 | ] 26 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 27 | -------------------------------------------------------------------------------- /opam/lang-fractal-tree-rewriting.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "lang-declarative-graphics" 9 | "js_of_ocaml-compiler" {>= "5.8.2"} 10 | "js_of_ocaml" {>= "5.8.2"} 11 | "js_of_ocaml-ppx" {>= "5.8.2"} 12 | "odoc" {with-doc} 13 | ] 14 | build: [ 15 | ["dune" "subst"] {dev} 16 | [ 17 | "dune" 18 | "build" 19 | "-p" 20 | name 21 | "-j" 22 | jobs 23 | "@install" 24 | "@runtest" {with-test} 25 | "@doc" {with-doc} 26 | ] 27 | ] 28 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 29 | -------------------------------------------------------------------------------- /opam/lang-lc-interpreters.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "menhir" {>= "20240715" & build} 9 | "menhirLib" {>= "20240715"} 10 | "sedlex" {>= "3.3"} 11 | "odoc" {with-doc} 12 | ] 13 | build: [ 14 | ["dune" "subst"] {dev} 15 | [ 16 | "dune" 17 | "build" 18 | "-p" 19 | name 20 | "-j" 21 | jobs 22 | "@install" 23 | "@runtest" {with-test} 24 | "@doc" {with-doc} 25 | ] 26 | ] 27 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 28 | -------------------------------------------------------------------------------- /opam/lang-production-systems.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "js_of_ocaml-compiler" {>= "5.8.2"} 9 | "js_of_ocaml" {>= "5.8.2"} 10 | "js_of_ocaml-ppx" {>= "5.8.2"} 11 | "odoc" {with-doc} 12 | ] 13 | build: [ 14 | ["dune" "subst"] {dev} 15 | [ 16 | "dune" 17 | "build" 18 | "-p" 19 | name 20 | "-j" 21 | jobs 22 | "@install" 23 | "@runtest" {with-test} 24 | "@doc" {with-doc} 25 | ] 26 | ] 27 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 28 | -------------------------------------------------------------------------------- /opam/lang-shader-graphics.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "mdx" {>= "2.4.1" & with-test} 10 | "odoc" {with-doc} 11 | ] 12 | build: [ 13 | ["dune" "subst"] {dev} 14 | [ 15 | "dune" 16 | "build" 17 | "-p" 18 | name 19 | "-j" 20 | jobs 21 | "@install" 22 | "@runtest" {with-test} 23 | "@doc" {with-doc} 24 | ] 25 | ] 26 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 27 | -------------------------------------------------------------------------------- /opam/lang-tree-rewriting.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "js_of_ocaml-compiler" {>= "5.8.2"} 9 | "js_of_ocaml" {>= "5.8.2"} 10 | "js_of_ocaml-ppx" {>= "5.8.2"} 11 | "odoc" {with-doc} 12 | ] 13 | build: [ 14 | ["dune" "subst"] {dev} 15 | [ 16 | "dune" 17 | "build" 18 | "-p" 19 | name 20 | "-j" 21 | jobs 22 | "@install" 23 | "@runtest" {with-test} 24 | "@doc" {with-doc} 25 | ] 26 | ] 27 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 28 | -------------------------------------------------------------------------------- /opam/scraps.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "odoc" {with-doc} 9 | ] 10 | build: [ 11 | ["dune" "subst"] {dev} 12 | [ 13 | "dune" 14 | "build" 15 | "-p" 16 | name 17 | "-j" 18 | jobs 19 | "@install" 20 | "@runtest" {with-test} 21 | "@doc" {with-doc} 22 | ] 23 | ] 24 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 25 | -------------------------------------------------------------------------------- /opam/wip-compile-closure-conv.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "sedlex" {>= "3.3"} 13 | "odoc" {with-doc} 14 | ] 15 | build: [ 16 | ["dune" "subst"] {dev} 17 | [ 18 | "dune" 19 | "build" 20 | "-p" 21 | name 22 | "-j" 23 | jobs 24 | "@install" 25 | "@runtest" {with-test} 26 | "@doc" {with-doc} 27 | ] 28 | ] 29 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 30 | -------------------------------------------------------------------------------- /opam/wip-compile-stlc.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "menhir" {>= "20240715" & build} 9 | "menhirLib" {>= "20240715"} 10 | "mdx" {>= "2.4.1" & with-test} 11 | "sedlex" {>= "3.3"} 12 | "odoc" {with-doc} 13 | ] 14 | build: [ 15 | ["dune" "subst"] {dev} 16 | [ 17 | "dune" 18 | "build" 19 | "-p" 20 | name 21 | "-j" 22 | jobs 23 | "@install" 24 | "@runtest" {with-test} 25 | "@doc" {with-doc} 26 | ] 27 | ] 28 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 29 | -------------------------------------------------------------------------------- /opam/wip-compile-stratify.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "odoc" {with-doc} 9 | ] 10 | build: [ 11 | ["dune" "subst"] {dev} 12 | [ 13 | "dune" 14 | "build" 15 | "-p" 16 | name 17 | "-j" 18 | jobs 19 | "@install" 20 | "@runtest" {with-test} 21 | "@doc" {with-doc} 22 | ] 23 | ] 24 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 25 | -------------------------------------------------------------------------------- /opam/wip-compile-uncurry.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "odoc" {with-doc} 9 | ] 10 | build: [ 11 | ["dune" "subst"] {dev} 12 | [ 13 | "dune" 14 | "build" 15 | "-p" 16 | name 17 | "-j" 18 | jobs 19 | "@install" 20 | "@runtest" {with-test} 21 | "@doc" {with-doc} 22 | ] 23 | ] 24 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 25 | -------------------------------------------------------------------------------- /opam/wip-elab-builtins.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "cmdliner" {>= "1.3"} 9 | "menhir" {>= "20240715" & build} 10 | "menhirLib" {>= "20240715"} 11 | "mdx" {>= "2.4.1" & with-test} 12 | "odoc" {with-doc} 13 | ] 14 | build: [ 15 | ["dune" "subst"] {dev} 16 | [ 17 | "dune" 18 | "build" 19 | "-p" 20 | name 21 | "-j" 22 | jobs 23 | "@install" 24 | "@runtest" {with-test} 25 | "@doc" {with-doc} 26 | ] 27 | ] 28 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 29 | -------------------------------------------------------------------------------- /opam/wip-lang-browser-experiments.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | authors: ["Brendan Zabarauskas"] 4 | homepage: "https://github.com/brendanzab/language-garden" 5 | bug-reports: "https://github.com/brendanzab/language-garden/issues" 6 | depends: [ 7 | "dune" {>= "3.16"} 8 | "lang-diagrams" 9 | "js_of_ocaml-compiler" {>= "5.8.2"} 10 | "js_of_ocaml" {>= "5.8.2"} 11 | "js_of_ocaml-ppx" {>= "5.8.2"} 12 | "odoc" {with-doc} 13 | ] 14 | build: [ 15 | ["dune" "subst"] {dev} 16 | [ 17 | "dune" 18 | "build" 19 | "-p" 20 | name 21 | "-j" 22 | jobs 23 | "@install" 24 | "@runtest" {with-test} 25 | "@doc" {with-doc} 26 | ] 27 | ] 28 | dev-repo: "git+https://github.com/brendanzab/language-garden.git" 29 | -------------------------------------------------------------------------------- /scraps/compile-arith-rust/00-eval-int.rs: -------------------------------------------------------------------------------- 1 | // Syntax 2 | 3 | pub enum Expr { 4 | Int(i32), 5 | Neg(Box), 6 | Add(Box, Box), 7 | Mul(Box, Box), 8 | } 9 | 10 | // Semantics 11 | 12 | pub type Value = i32; 13 | 14 | pub fn eval(expr: &Expr) -> Value { 15 | match expr { 16 | Expr::Int(i) => *i, 17 | Expr::Neg(e) => -eval(e), 18 | Expr::Add(e1, e2) => eval(e1) + eval(e2), 19 | Expr::Mul(e1, e2) => eval(e1) * eval(e2), 20 | } 21 | } -------------------------------------------------------------------------------- /scraps/compile-arith-rust/01-eval-int-bool.rs: -------------------------------------------------------------------------------- 1 | // Syntax 2 | 3 | pub enum Expr { 4 | Int(i32), 5 | Bool(bool), 6 | Neg(Box), 7 | Add(Box, Box), 8 | Sub(Box, Box), 9 | Mul(Box, Box), 10 | Eq(Box, Box), 11 | And(Box, Box), 12 | } 13 | 14 | // Semantics 15 | 16 | #[derive(PartialEq)] 17 | pub enum Value { 18 | Int(i32), 19 | Bool(bool), 20 | } 21 | 22 | pub fn eval(expr: &Expr) -> Value { 23 | match expr { 24 | Expr::Int(i) => Value::Int(*i), 25 | Expr::Bool(b) => Value::Bool(*b), 26 | Expr::Neg(e) => Value::Int(-eval_int(e)), 27 | Expr::Add(e1, e2) => Value::Int(eval_int(e1) + eval_int(e2)), 28 | Expr::Sub(e1, e2) => Value::Int(eval_int(e1) - eval_int(e2)), 29 | Expr::Mul(e1, e2) => Value::Int(eval_int(e1) * eval_int(e2)), 30 | Expr::Eq(e1, e2) => Value::Bool(eval(e1) == eval(e2)), 31 | Expr::And(e1, e2) => Value::Bool(eval_bool(e1) && eval_bool(e2)), 32 | } 33 | } 34 | 35 | fn eval_int(expr: &Expr) -> i32 { 36 | match eval(expr) { 37 | Value::Int(i) => i, 38 | _ => panic!("expected int"), 39 | } 40 | } 41 | 42 | fn eval_bool(expr: &Expr) -> bool { 43 | match eval(expr) { 44 | Value::Bool(b) => b, 45 | _ => panic!("expected bool"), 46 | } 47 | } -------------------------------------------------------------------------------- /scraps/compile-arith-rust/README.md: -------------------------------------------------------------------------------- 1 | # Arithmetic expression evaluators and compilers in Rust. 2 | 3 | See . 4 | -------------------------------------------------------------------------------- /scraps/compile-arith-verified/README.md: -------------------------------------------------------------------------------- 1 | # Formally verified compilation and decompilation of arithmetic expressions 2 | 3 | A proof of the correctness of an arithmetic expression compiler and decompiler in Lean 4. 4 | 5 | Ported from [expcompile.v], which is part of Derek Dreyer and Gert Smolka's 6 | [course material]. 7 | 8 | *This was originally posted at [ArithExprs.lean](https://gist.github.com/brendanzab/232379f8d82852c2a831bfefb99fff5a).* 9 | 10 | [expcompile.v]: https://www.ps.uni-saarland.de/courses/sem-ws17/expcompile.v 11 | [course material]: https://courses.ps.uni-saarland.de/sem_ws1718/3/Resources 12 | -------------------------------------------------------------------------------- /scraps/dune: -------------------------------------------------------------------------------- 1 | (executable (name parse_sexpr)) 2 | 3 | (executable (name eval_cek)) 4 | (executable (name eval_control_flow_cps)) 5 | (executable (name eval_extensible)) 6 | (executable (name eval_imp)) 7 | (executable (name eval_landins_knot)) 8 | (executable (name eval_stlc_gadt)) 9 | (executable (name eval_stlc_gadt_values_hoas)) 10 | (executable (name eval_stlc_gadt_values_closures)) 11 | (executable (name eval_stlc_gadt_globals)) 12 | (executable (name eval_triple_store)) 13 | (executable (name eval_unsure_calculator)) 14 | 15 | (executable (name check_stlc_inference_rules)) 16 | (executable (name check_stlc_inference_rules_bidir)) 17 | 18 | (executable (name elab_stlc_gadt)) 19 | (executable (name elab_stlc_gadt_bidir)) 20 | 21 | (executable (name misc_adt_properties)) 22 | (executable (name misc_ast_folds)) 23 | (executable (name misc_ast_submodules)) 24 | (executable (name misc_effects_build_system)) 25 | (executable (name misc_effects_come_from)) 26 | (executable (name misc_effects_state)) 27 | (executable (name misc_isorecursion_vs_equirecursion)) 28 | (executable (name misc_option_shapes)) 29 | (executable (name misc_set_objects)) 30 | -------------------------------------------------------------------------------- /scraps/eval_landins_knot.ml: -------------------------------------------------------------------------------- 1 | (** Demonstration of Landin’s Knot, an approach to encoding general recursion 2 | using higher-order references and backpatching. 3 | 4 | {{: https://doi.org/10.1093/comjnl/6.4.308} The Mechanical Evaluation of Expressions} 5 | *) 6 | 7 | [@@@warning "-unused-value-declaration"] 8 | 9 | let knot (type a b) (f : (a -> b) -> a -> b) : a -> b = 10 | let recur = ref (fun _ -> assert false) in (* create a reference to be used inside the recursive function *) 11 | let fix = f (fun x -> !recur x) in (* create the recursive function *) 12 | recur := fix; (* backpatch the recursive function to call itself *) 13 | fix (* return the recursive function *) 14 | 15 | let fact : int -> int = 16 | knot @@ fun fact x -> 17 | match x with 18 | | 0 -> 1 19 | | x -> x * fact (x - 1) 20 | 21 | let length (type a) : a list -> int = 22 | knot @@ fun size xs -> 23 | match xs with 24 | | [] -> 0 25 | | _ :: xs -> 1 + size xs 26 | 27 | let () = 28 | Seq.ints 0 |> Seq.take 10 |> Seq.iter @@ fun x -> 29 | Printf.printf "fact %i = %i\n" x (fact x) 30 | -------------------------------------------------------------------------------- /scraps/eval_stlc_gadt.ml: -------------------------------------------------------------------------------- 1 | (** A well-typed lambda calculus evaluator using GADTs. *) 2 | 3 | type ('ctx, 'a) index = 4 | | Stop : ('a * 'ctx, 'a) index 5 | | Pop : ('ctx, 'a) index -> ('b * 'ctx, 'a) index 6 | 7 | type ('ctx, 'a) expr = 8 | | Let : ('ctx, 'a) expr * ('a * 'ctx, 'b) expr -> ('ctx, 'b) expr 9 | | Var : ('ctx, 'a) index -> ('ctx, 'a) expr 10 | | Fun_abs : ('a * 'ctx, 'b) expr -> ('ctx, 'a -> 'b) expr 11 | | Fun_app : ('ctx, 'a -> 'b) expr * ('ctx, 'a) expr -> ('ctx, 'b) expr 12 | 13 | type 'ctx env = 14 | | [] : unit env 15 | | ( :: ) : 'a * 'ctx env -> ('a * 'ctx) env 16 | 17 | let rec lookup : type ctx a. (ctx, a) index -> ctx env -> a = 18 | fun x env -> 19 | match x, env with 20 | | Stop, v :: _ -> v 21 | | Pop x, _ :: env -> lookup x env 22 | 23 | let rec eval : type ctx a. ctx env -> (ctx, a) expr -> a = 24 | fun env expr -> 25 | match expr with 26 | | Let (def, body) -> eval (eval env def :: env) body 27 | | Var x -> lookup x env 28 | | Fun_abs body -> fun x -> eval (x :: env) body 29 | | Fun_app (fn, arg) -> (eval env fn) (eval env arg) 30 | 31 | let () = begin 32 | 33 | print_string "Running tests ..."; 34 | 35 | assert (eval [] (Fun_abs (Var Stop)) 1 = 1); 36 | assert (eval [] (Fun_abs (Fun_abs (Var (Pop Stop)))) "hello" 4 = "hello"); 37 | assert (eval ["hello"] (Fun_app (Fun_abs (Fun_abs (Var (Pop Stop))), Var Stop)) 4 = "hello"); 38 | assert (eval [2; "hello"] (Let (Var (Pop Stop), Var Stop)) = "hello"); 39 | 40 | print_string " ok!\n"; 41 | 42 | end 43 | -------------------------------------------------------------------------------- /scraps/misc_ast_folds.ml: -------------------------------------------------------------------------------- 1 | (** Folding over an AST using recursion schemes (a response to 2 | https://bsky.app/profile/bandukwala.me/post/3liwrjfotek2a). 3 | *) 4 | 5 | [@@@warning "-unused-value-declaration"] 6 | 7 | module Expr = struct 8 | 9 | module Layer = struct 10 | 11 | type 'a t = 12 | | Mul of 'a * 'a 13 | | Add of 'a * 'a 14 | | Int of int 15 | 16 | let map (f : 'a -> 'b) (layer : 'a t) : 'b t = 17 | match layer with 18 | | Mul (x, y) -> Mul (f x, f y) 19 | | Add (x, y) -> Add (f x, f y) 20 | | Int x -> Int x 21 | 22 | end 23 | 24 | type t = { 25 | layer : t Layer.t; 26 | } 27 | 28 | (* See https://hackage.haskell.org/package/recursion-schemes-5.2.3/docs/Data-Functor-Foldable.html#v:fold *) 29 | let rec fold (f : 'a Layer.t -> 'a) (expr : t) : 'a = 30 | f (Layer.map (fold f) expr.layer) 31 | 32 | end 33 | -------------------------------------------------------------------------------- /scraps/misc_effects_come_from.ml: -------------------------------------------------------------------------------- 1 | (** COMEFROM in OCaml, implemented with algebraic effects and handlers. 2 | Based on https://effekt-lang.org/examples/comefrom.html 3 | *) 4 | 5 | module Come_from () : sig 6 | 7 | val label : unit -> unit (* Label *) 8 | val try_with : ?label:(unit -> unit (* e *)) -> (unit -> 'a (* Label *)) -> 'a (* e *) 9 | 10 | end = struct 11 | 12 | type 'a Effect.t += Label : unit Effect.t 13 | 14 | let label () = Effect.perform Label 15 | 16 | let try_with ?(label = label) f = 17 | try f () with 18 | | effect Label, k -> 19 | Effect.Deep.continue k (label ()) 20 | 21 | end 22 | 23 | module Come_from0 = Come_from () 24 | module Come_from1 = Come_from () 25 | module Come_from2 = Come_from () 26 | 27 | let hello_world () : unit (* Come_from0.Label, Come_from1.Label, Come_from2.Label *) = 28 | Come_from0.label (); 29 | Printf.printf "Hello\n"; 30 | Come_from1.label (); 31 | Printf.printf "World\n"; 32 | Come_from2.label () 33 | 34 | let ( let* ) = ( @@ ) 35 | 36 | let () = 37 | let* () = Come_from0.try_with ~label:(fun () -> Printf.printf "Came from 0\n") in 38 | let* () = Come_from1.try_with ~label:(fun () -> Printf.printf "Came from 1\n") in 39 | let* () = Come_from2.try_with ~label:(fun () -> Printf.printf "Came from 2\n") in 40 | hello_world () 41 | -------------------------------------------------------------------------------- /scraps/misc_effects_state.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-unused-value-declaration"] 2 | 3 | module State (A : sig type t end) : sig 4 | 5 | type t = A.t 6 | 7 | val set : t -> unit 8 | val get : unit -> t 9 | 10 | val modify : (t -> t) -> unit 11 | 12 | val run : init:t -> (unit -> 'a) -> 'a 13 | val try_with : ?set:(t -> unit) -> ?get:(unit -> t) -> (unit -> 'a) -> 'a 14 | 15 | end = struct 16 | 17 | type t = A.t 18 | 19 | type _ Effect.t += 20 | | Set : t -> unit Effect.t 21 | | Get : t Effect.t 22 | 23 | let set x = Effect.perform (Set x) 24 | let get () = Effect.perform Get 25 | 26 | let modify f = set (f (get ())) 27 | 28 | let run ~(init : t) f = 29 | let open Effect.Deep in 30 | 31 | let curr = ref init in 32 | try f () with 33 | | effect (Set x), k -> curr := x; continue k () 34 | | effect Get, k -> continue k !curr 35 | 36 | let try_with ?(set = set) ?(get = get) f = 37 | let open Effect.Deep in 38 | 39 | try f () with 40 | | effect (Set x), k -> continue k (set x) 41 | | effect Get, k -> continue k (get ()) 42 | 43 | end 44 | 45 | let ( let@ ) = ( @@ ) 46 | 47 | let () = 48 | let module S = State (String) in 49 | let@ () = S.run ~init:"hello" in 50 | S.modify (fun x -> x ^ " world!"); 51 | print_string (S.get ()) 52 | -------------------------------------------------------------------------------- /scraps/misc_isorecursion_vs_equirecursion.ml: -------------------------------------------------------------------------------- 1 | (** Comparing isorecursive variant types with equirecursive variant types in OCaml.*) 2 | 3 | [@@@warning "-unused-value-declaration"] 4 | [@@@warning "-unused-constructor"] 5 | 6 | module type Isorecursive = sig 7 | 8 | type t 9 | type 'a layer 10 | 11 | val roll : t layer -> t 12 | val unroll : t -> t layer 13 | 14 | end 15 | 16 | module List1 (A : sig type t end) : Isorecursive = struct 17 | 18 | type 'a layer = 19 | | Cons of A.t * 'a 20 | | Nil of 'a 21 | 22 | (* Nominal variants are isorecursive, so the recursion must be 23 | guarded with a constructor *) 24 | 25 | type t = Fix of t layer 26 | 27 | let roll : t layer -> t = fun x -> Fix x 28 | let unroll : t -> t layer = fun (Fix x) -> x 29 | 30 | end 31 | 32 | module List2 (A : sig type t end) : Isorecursive = struct 33 | 34 | type 'a layer = [ 35 | | `Cons of A.t * 'a 36 | | `Nil of 'a 37 | ] 38 | 39 | (* Polymorphic variants are equirecursive, so unguarded 40 | recursion in type aliases is allowed *) 41 | 42 | type t = t layer 43 | 44 | (* Equirecursion means that roll and unroll are the identity function *) 45 | 46 | let roll : t layer -> t = Fun.id 47 | let unroll : t -> t layer = Fun.id 48 | 49 | end 50 | -------------------------------------------------------------------------------- /scraps/misc_option_shapes.ml: -------------------------------------------------------------------------------- 1 | (** Exposing introduction and elimination forms for variant types, without 2 | exposing the underlying representation. 3 | 4 | Inspired by https://okmij.org/ftp/tagless-final/datatypes.html 5 | *) 6 | 7 | [@@@warning "-unused-value-declaration"] 8 | 9 | module Option = struct 10 | 11 | type 'a shape = [ 12 | | `Some of 'a 13 | | `None 14 | ] 15 | 16 | module type S = sig 17 | 18 | type 'a t 19 | 20 | val intro : 'a shape -> 'a t 21 | val elim : 'a t -> ('a shape -> 'b) -> 'b 22 | 23 | end 24 | 25 | module Impl1 : S = struct 26 | 27 | type 'a t = 'a shape 28 | 29 | let intro opt = opt 30 | let elim x k = k x 31 | 32 | end 33 | 34 | module Impl2 : S = struct 35 | 36 | type 'a t = 37 | | Some of 'a 38 | | None 39 | 40 | let intro = function 41 | | `Some x -> Some x 42 | | `None -> None 43 | 44 | let elim = function 45 | | Some x -> fun k -> k (`Some x) 46 | | None -> fun k -> k `None 47 | 48 | end 49 | 50 | (* TODO: Impl that uses Stdlib.Obj *) 51 | 52 | end 53 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name closure-conv) 4 | (package wip-compile-closure-conv) 5 | (libraries 6 | wip-compile-closure-conv 7 | cmdliner 8 | menhirLib 9 | sedlex)) 10 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/dune: -------------------------------------------------------------------------------- 1 | (mdx 2 | (package wip-compile-closure-conv) 3 | (deps %{bin:closure-conv})) 4 | 5 | (env 6 | (dev 7 | ; see `ocamlc -warn-help` for information on warnings 8 | (flags (:standard -w -unused-constructor 9 | -w -unused-value-declaration)))) 10 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/lib/closure_conv.ml: -------------------------------------------------------------------------------- 1 | module Lang = Lang 2 | module Translation = Translation 3 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name closure_conv) 3 | (public_name wip-compile-closure-conv) 4 | (preprocess 5 | (pps sedlex.ppx))) 6 | 7 | (menhir 8 | (modules lang__fun__parser)) 9 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/lib/fresh.ml: -------------------------------------------------------------------------------- 1 | (** {0 Fresh variable generation} *) 2 | 3 | (** A fresh variable generator *) 4 | module type S = sig 5 | 6 | (** Globally unique id *) 7 | type t = private int 8 | 9 | (** Returns a fresh id *) 10 | val fresh : string -> t 11 | 12 | (** Total ordering of ids *) 13 | val compare : t -> t -> int 14 | 15 | (** Convert an id to an integer *) 16 | val to_int : t -> int 17 | 18 | (** Recover the name that an id was generated with (not guaranteed to be unique) *) 19 | val name : t -> string 20 | 21 | end 22 | 23 | (** Build a new namespace of globally unique ids *) 24 | module Make () : S = struct 25 | 26 | type t = int 27 | 28 | (** Fresh variable state *) 29 | let next_id = ref 0 30 | 31 | (** For storing the variable names *) 32 | module Id_map = Map.Make (Int) 33 | 34 | (** A global store of variable names. This might not be an ideal approach 35 | more long-running compilers (it’s a memory leak), but it saves us having 36 | to cart around the names separately. *) 37 | let names = ref Id_map.empty 38 | 39 | let fresh name = 40 | let id = !next_id in 41 | incr next_id; 42 | names := Id_map.add id name !names; 43 | id 44 | 45 | let compare = Int.compare 46 | 47 | let to_int id = id 48 | 49 | let name id = Id_map.find id !names 50 | 51 | end 52 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/lib/lang.ml: -------------------------------------------------------------------------------- 1 | (** {0 Intermediate languages} *) 2 | 3 | (** {1 Languages using nameless variables} *) 4 | 5 | (** Simply typed lambda calculus *) 6 | module Fun = struct 7 | 8 | include Lang__fun 9 | 10 | module Lexer = Lang__fun__lexer 11 | module Parser = Lang__fun__parser 12 | 13 | end 14 | 15 | (** Closure converted language *) 16 | module Clos = Lang__clos 17 | 18 | 19 | (** {1 Alpha-renamed languages} *) 20 | 21 | (** Simply typed lambda calculus (alpha-renamed) *) 22 | module Fun_a = Lang__fun_a 23 | 24 | (** Closure converted language (alpha-renamed) *) 25 | module Clos_a = Lang__clos_a 26 | 27 | (** Lambda lifted language (alpha-renamed) *) 28 | module Lifted_a = Lang__lifted_a 29 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/lib/prim.ml: -------------------------------------------------------------------------------- 1 | (** {0 Primitive operations} 2 | 3 | These operations are shared between the different intermediate languages. 4 | *) 5 | 6 | type t = [ 7 | | `Neg 8 | | `Add 9 | | `Sub 10 | | `Mul 11 | ] 12 | 13 | let to_string : t -> string = 14 | function 15 | | `Neg -> "neg" 16 | | `Add -> "add" 17 | | `Sub -> "sub" 18 | | `Mul -> "mul" 19 | 20 | 21 | (* TODO: define evaluation of primitives once in this module *) 22 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/lib/translation.ml: -------------------------------------------------------------------------------- 1 | (** {0 Translation passes} *) 2 | 3 | (** Alpha renaming translation *) 4 | module Fun_to_fun_a = Translation__fun_to_fun_a 5 | 6 | (** Typed closure conversion on nameless terms *) 7 | module Fun_to_clos = Translation__fun_to_clos 8 | 9 | (** Typed closure conversion on alpha renamed terms *) 10 | module Fun_a_to_clos_a = Translation__fun_a_to_clos_a 11 | 12 | (** Typed lambda lifting on alpha renamed terms *) 13 | module Fun_a_to_lifted_a = Translation__fun_a_to_lifted_a 14 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/lib/translation__fun_to_fun_a.ml: -------------------------------------------------------------------------------- 1 | (** {0 Alpha-renaming translation} 2 | 3 | This translation assigns unique names to each variable binding as a way to 4 | simplify later compilation passes. 5 | *) 6 | 7 | module Fun = Lang.Fun 8 | module Fun_a = Lang.Fun_a 9 | 10 | 11 | (** {1 Translation} *) 12 | 13 | let rec translate env : Fun.tm -> Fun_a.tm = 14 | function 15 | | Var index -> Var (List.nth env index) 16 | | Let (def_name, def_ty, def, body) -> 17 | let def_var = Fun_a.Var.fresh def_name in 18 | let def = translate env def in 19 | let body = translate (def_var :: env) body in 20 | Let (def_var, def_ty, def, body) 21 | | Bool_lit b -> Bool_lit b 22 | | Int_lit i -> Int_lit i 23 | | Prim_app (prim, args) -> 24 | let args = List.map (translate env) args in 25 | Prim_app (prim, args) 26 | | Fun_lit (param_name, param_ty, body) -> 27 | let param_var = Fun_a.Var.fresh param_name in 28 | let body = translate (param_var :: env) body in 29 | Fun_lit (param_var, param_ty, body) 30 | | Fun_app (head, arg) -> 31 | let head = translate env head in 32 | let arg = translate env arg in 33 | Fun_app (head, arg) 34 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/capture-nothing.clos.stdout: -------------------------------------------------------------------------------- 1 | let a : Int := 1; 2 | let f : Int -> Int := clos(fun (env : ()) (x : Int) => x, ()); 3 | f 100 4 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/capture-nothing.lifted.stdout: -------------------------------------------------------------------------------- 1 | def f0↑ (env1 : ()) (x2 : Int) := x2; 2 | let a0 : Int := 1; 3 | f0↑ () 100 4 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/capture-nothing.txt: -------------------------------------------------------------------------------- 1 | let a : Int := 1; 2 | let f : Int -> Int := 3 | fun (x : Int) => x; 4 | 5 | f 100 6 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/capture-simple.clos.stdout: -------------------------------------------------------------------------------- 1 | let a : Int := 1; 2 | let f : Int -> Int := clos(fun (env : (Int,)) (x : Int) => env.0, (a,)); 3 | f 100 4 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/capture-simple.lifted.stdout: -------------------------------------------------------------------------------- 1 | def f0↑ (env1 : (Int,)) (x2 : Int) := env1.0; 2 | let a0 : Int := 1; 3 | f0↑ (a0,) 100 4 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/capture-simple.txt: -------------------------------------------------------------------------------- 1 | let a : Int := 1; 2 | let f : Int -> Int := 3 | fun (x : Int) => a; 4 | 5 | f 100 6 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/capture-with-local-let.clos.stdout: -------------------------------------------------------------------------------- 1 | let a : Int := 1; 2 | let f : Int -> Int := 3 | clos( 4 | fun (env : (Int,)) (x : Int) => let y : Int := #add x env.0; #add y 3, 5 | (a,) 6 | ); 7 | f 100 8 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/capture-with-local-let.lifted.stdout: -------------------------------------------------------------------------------- 1 | def f0↑ (env1 : (Int,)) (x2 : Int) := 2 | let y3 : Int := #add x2 env1.0; 3 | #add y3 3; 4 | let a0 : Int := 1; 5 | f0↑ (a0,) 100 6 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/capture-with-local-let.txt: -------------------------------------------------------------------------------- 1 | let a : Int := 1; 2 | let f : Int -> Int := 3 | fun (x : Int) => 4 | let y : Int := x + a; 5 | y + 3; 6 | 7 | f 100 8 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name dune_inc)) 3 | 4 | (subdir run 5 | (dynamic_include ../generate/dune.inc)) 6 | 7 | (subdir generate 8 | (rule 9 | (deps (glob_files ../*.txt)) 10 | (action 11 | (with-stdout-to dune.inc 12 | (run ../dune_inc.exe))))) 13 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/dune_inc.ml: -------------------------------------------------------------------------------- 1 | let bin = "closure-conv" 2 | let package = "wip-compile-closure-conv" 3 | 4 | let generate_rules base = 5 | Printf.printf 6 | {| 7 | (rule 8 | (with-stdin-from ../%s.txt 9 | (with-stdout-to %s.clos.stdout.tmp 10 | (run %%{bin:%s} compile --target=clos)))) 11 | |} 12 | base base bin; 13 | Printf.printf 14 | {| 15 | (rule 16 | (alias runtest) 17 | (package %s) 18 | (action 19 | (diff ../%s.clos.stdout %s.clos.stdout.tmp))) 20 | |} 21 | package base base; 22 | 23 | Printf.printf 24 | {| 25 | (rule 26 | (with-stdin-from ../%s.txt 27 | (with-stdout-to %s.lifted.stdout.tmp 28 | (run %%{bin:%s} compile --target=lifted)))) 29 | |} 30 | base base bin; 31 | Printf.printf 32 | {| 33 | (rule 34 | (alias runtest) 35 | (package %s) 36 | (action 37 | (diff ../%s.lifted.stdout %s.lifted.stdout.tmp))) 38 | |} 39 | package base base 40 | 41 | let () = 42 | Sys.readdir ".." 43 | |> Array.to_list 44 | |> List.sort String.compare 45 | |> List.filter_map (Filename.chop_suffix_opt ~suffix:".txt") 46 | |> List.iter generate_rules 47 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/multiple-captures-1.clos.stdout: -------------------------------------------------------------------------------- 1 | let x : Int := 1; 2 | let y : Int := 2; 3 | let z : Int := 3; 4 | let f : Int -> Int -> Int := 5 | clos(fun (env : (Int, Int)) (w : Int) => #add env.0 (#add env.1 w), (x, y)); 6 | f 100 7 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/multiple-captures-1.lifted.stdout: -------------------------------------------------------------------------------- 1 | def f0↑ (env3 : (Int, Int)) (w4 : Int) := #add env3.0 (#add env3.1 w4); 2 | let x0 : Int := 1; 3 | let y1 : Int := 2; 4 | let z2 : Int := 3; 5 | f0↑ (x0, y1) 100 6 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/multiple-captures-1.txt: -------------------------------------------------------------------------------- 1 | let x : Int := 1; 2 | let y : Int := 2; 3 | let z : Int := 3; 4 | let f : Int -> Int -> Int := 5 | fun (w : Int) => x + y + w; 6 | 7 | f 100 8 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/multiple-captures-2.clos.stdout: -------------------------------------------------------------------------------- 1 | let a : Int := 2; 2 | let b : Int := 4; 3 | let c : Int := 7; 4 | let d : Int := 8; 5 | clos(fun (env : (Int, Int)) (x : Int) => #add (#mul env.0 x) env.1, (a, c)) 6 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/multiple-captures-2.lifted.stdout: -------------------------------------------------------------------------------- 1 | def anon0↑ (env4 : (Int, Int)) (x5 : Int) := #add (#mul env4.0 x5) env4.1; 2 | let a0 : Int := 2; 3 | let b1 : Int := 4; 4 | let c2 : Int := 7; 5 | let d3 : Int := 8; 6 | clos(anon0↑, (a0, c2)) 7 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/multiple-captures-2.txt: -------------------------------------------------------------------------------- 1 | let a : Int := 2; 2 | let b : Int := 4; 3 | let c : Int := 7; 4 | let d : Int := 8; 5 | 6 | fun (x : Int) => 7 | a * x + c 8 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/multiple-captures-3.clos.stdout: -------------------------------------------------------------------------------- 1 | let a : Int := 2; 2 | let b : Int := 5; 3 | let f : Int -> Int -> Int := 4 | clos( 5 | fun (env : (Int, Int)) (x : Int) => 6 | clos( 7 | fun (env : (Int, Int, Int)) (y : Int) => 8 | #add (#mul env.0 env.2) (#mul env.1 y), 9 | (env.0, env.1, x) 10 | ), 11 | (a, b) 12 | ); 13 | f 7 3 14 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/multiple-captures-3.lifted.stdout: -------------------------------------------------------------------------------- 1 | def anon0↑ (env4 : (Int, Int, Int)) (y5 : Int) := 2 | #add (#mul env4.0 env4.2) (#mul env4.1 y5); 3 | def f1↑ (env2 : (Int, Int)) (x3 : Int) := 4 | clos(anon0↑, (env2.0, env2.1, x3)); 5 | let a0 : Int := 2; 6 | let b1 : Int := 5; 7 | f1↑ (a0, b1) 7 3 8 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/multiple-captures-3.txt: -------------------------------------------------------------------------------- 1 | let a : Int := 2; 2 | let b : Int := 5; 3 | let f : Int -> Int -> Int := 4 | fun (x : Int) => fun (y : Int) => 5 | a * x + b * y; 6 | 7 | f 7 3 8 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/partial-application-1.clos.stdout: -------------------------------------------------------------------------------- 1 | let h : (Int -> Int) -> Int := 2 | clos(fun (env : ()) (x : Int -> Int) => x 7, ()); 3 | let g : Int := 4 | clos( 5 | fun (env : ((Int -> Int) -> Int,)) (a : Int) => 6 | let f : Int -> Int := 7 | clos(fun (env : (Int,)) (b : Int) => #add env.0 b, (a,)); 8 | env.0 f, 9 | (h,) 10 | ); 11 | g 12 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/partial-application-1.lifted.stdout: -------------------------------------------------------------------------------- 1 | def h0↑ (env0 : ()) (x1 : Int -> Int) := x1 7; 2 | def f1↑ (env4 : (Int,)) (b5 : Int) := #add env4.0 b5; 3 | def g2↑ (env2 : ((Int -> Int) -> Int,)) (a3 : Int) := 4 | env2.0 clos(f1↑, (a3,)); 5 | clos(g2↑, (clos(h0↑, ()),)) 6 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/partial-application-1.txt: -------------------------------------------------------------------------------- 1 | let h : (Int -> Int) -> Int := 2 | fun (x : Int -> Int) => x 7; 3 | 4 | let g : Int := 5 | fun (a : Int) => 6 | let f : Int -> Int := 7 | fun (b : Int) => a + b; 8 | h f; 9 | -- ^ lambda lifting would fail here 10 | -- too few arguments, so requires a closure 11 | -- see: https://www.cse.chalmers.se/edu/year/2011/course/CompFun/lecture2.pdf#page=21 12 | 13 | g 14 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/partial-application-2.clos.stdout: -------------------------------------------------------------------------------- 1 | let add-captured : Int -> Int := 2 | let x : Int := 5; 3 | let add-x : Int -> Int := 4 | clos(fun (env : (Int,)) (y : Int) => #add env.0 y, (x,)); 5 | add-x; 6 | #add (add-captured 3) 4 7 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/partial-application-2.lifted.stdout: -------------------------------------------------------------------------------- 1 | def add-x0↑ (env1 : (Int,)) (y2 : Int) := #add env1.0 y2; 2 | let add-captured3 : Int -> Int := let x0 : Int := 5; clos(add-x0↑, (x0,)); 3 | #add (add-captured3 3) 4 4 | -------------------------------------------------------------------------------- /scraps/wip-compile-closure-conv/test/partial-application-2.txt: -------------------------------------------------------------------------------- 1 | let add-captured : Int -> Int := 2 | let x : Int := 5; 3 | let add-x : Int -> Int := 4 | fun (y : Int) => x + y; 5 | 6 | add-x; 7 | 8 | add-captured 3 + 4 9 | -------------------------------------------------------------------------------- /scraps/wip-compile-stlc/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name stlc) 4 | (package wip-compile-stlc) 5 | (preprocess 6 | (pps sedlex.ppx)) 7 | (libraries 8 | menhirLib)) 9 | 10 | (menhir 11 | (modules surface_parser) 12 | (flags --explain --strict)) 13 | -------------------------------------------------------------------------------- /scraps/wip-compile-stlc/main.ml: -------------------------------------------------------------------------------- 1 | module Surface_lexer = Surface_lexer 2 | module Surface_parser = Surface_parser 3 | module Surface = Surface 4 | 5 | let _compile_anf (expr : Surface.expr) : Anf.expr = 6 | let expr, _ty = Surface.elab_infer [] expr in 7 | expr 8 | |> Core_to_anf.translate 9 | (* TODO: Add more passes here *) 10 | 11 | let _compile_monadic (expr : Surface.expr) : Monadic.expr = 12 | let expr, _ty = Surface.elab_infer [] expr in 13 | expr 14 | |> Core_to_monadic.translate 15 | (* TODO: Add more passes here *) 16 | -------------------------------------------------------------------------------- /scraps/wip-compile-stlc/name.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | User of string 3 | | Machine of string 4 | 5 | let pp ppf name = 6 | match name with 7 | | User name -> Format.fprintf ppf "%s" name 8 | | Machine name -> Format.fprintf ppf "$%s" name 9 | -------------------------------------------------------------------------------- /scraps/wip-compile-stlc/prim.ml: -------------------------------------------------------------------------------- 1 | type ty = 2 | | Bool_ty 3 | | Int_ty 4 | 5 | type value = 6 | | Bool_lit of bool 7 | | Int_lit of int 8 | 9 | type t = 10 | | Bool_eq 11 | | Bool_not 12 | | Int_eq 13 | | Int_add 14 | | Int_sub 15 | | Int_mul 16 | | Int_neg 17 | 18 | let name (prim : t) : string = 19 | match prim with 20 | | Bool_eq -> "bool-eq" 21 | | Bool_not -> "bool-not" 22 | | Int_eq -> "int-eq" 23 | | Int_add -> "int-add" 24 | | Int_sub -> "int-sub" 25 | | Int_mul -> "int-mul" 26 | | Int_neg -> "int-neg" 27 | 28 | let ty (prim : t) : ty list * ty = 29 | match prim with 30 | | Bool_eq -> [Bool_ty; Bool_ty], Bool_ty 31 | | Bool_not -> [Bool_ty], Bool_ty 32 | | Int_eq -> [Int_ty; Int_ty], Bool_ty 33 | | Int_add -> [Int_ty; Int_ty], Int_ty 34 | | Int_sub -> [Int_ty; Int_ty], Int_ty 35 | | Int_mul -> [Int_ty; Int_ty], Int_ty 36 | | Int_neg -> [Int_ty], Int_ty 37 | 38 | let app (prim : t) : value list -> value = 39 | match prim with 40 | | Bool_eq -> fun[@warning "-partial-match"] [Bool_lit x; Bool_lit y] -> Bool_lit (x = y) 41 | | Bool_not -> fun[@warning "-partial-match"] [Bool_lit x] -> Bool_lit (not x) 42 | | Int_eq -> fun[@warning "-partial-match"] [Int_lit x; Int_lit y] -> Bool_lit (x = y) 43 | | Int_add -> fun[@warning "-partial-match"] [Int_lit x; Int_lit y] -> Int_lit (x + y) 44 | | Int_sub -> fun[@warning "-partial-match"] [Int_lit x; Int_lit y] -> Int_lit (x - y) 45 | | Int_mul -> fun[@warning "-partial-match"] [Int_lit x; Int_lit y] -> Int_lit (x * y) 46 | | Int_neg -> fun[@warning "-partial-match"] [Int_lit x] -> Int_lit (-x) 47 | -------------------------------------------------------------------------------- /scraps/wip-compile-stlc/symbol.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | 3 | type t = private int 4 | 5 | val fresh : unit -> t 6 | val equal : t -> t -> bool 7 | val compare : t -> t -> int 8 | val to_int : t -> int 9 | 10 | end 11 | 12 | module Make () : S = struct 13 | 14 | type t = int 15 | 16 | let next_id = ref 0 17 | 18 | let fresh () = 19 | let id = !next_id in 20 | incr next_id; 21 | id 22 | 23 | let equal = Int.equal 24 | let compare = Int.compare 25 | let to_int id = id 26 | 27 | end 28 | -------------------------------------------------------------------------------- /scraps/wip-compile-stratify/README.md: -------------------------------------------------------------------------------- 1 | # Stratifying a dependently typed lambda calculus 2 | 3 | > NOTE: A work in progress! 4 | 5 | This aims to demonstrate how to compile a dependently typed language with first 6 | class types into a language that is stratified into terms, types, and kinds. 7 | This could be useful as part of compiling a dependently typed language into a 8 | language that lacks dependent types. 9 | 10 | In the elaborator of dependently typed programming languages it is common to 11 | work with a single AST for terms in the core language, stratified using universe 12 | levels. This is convenient for implementing elaborators, but in order to make 13 | compilation easier it can be beneficial to “stratify” these layers explicitly in 14 | the syntax. 15 | 16 | The stratified language is pretty close to the _CC_ language that is used as a 17 | source language in [“Singleton types here, singleton types there, singleton types 18 | everywhere”](https://doi.org/10.1145/1707790.1707792) by Monnier and Haguenauer, 19 | but omitting the `(Kscm, Kind)` rule from the pure type system, along with the 20 | `Πk:u.κ` production from the stratified language (in order to avoid introducing 21 | impredicativity). 22 | 23 | ## Todo list 24 | 25 | - [ ] surface language 26 | - [ ] parser 27 | - [ ] elaborator 28 | - [ ] stratify connectives 29 | - [x] dependent function types 30 | - [ ] dependent record types 31 | - [ ] primitive numbers 32 | - [ ] phase separation translation 33 | -------------------------------------------------------------------------------- /scraps/wip-compile-stratify/core_to_stratified.mli: -------------------------------------------------------------------------------- 1 | (** {0 Translation from the core language to the stratified language} *) 2 | 3 | (** Translation context *) 4 | module Context : sig 5 | 6 | type t 7 | val empty : t 8 | 9 | end 10 | 11 | (** A translated term *) 12 | type tm = [ 13 | | `Tm2 of Stratified.Syntax.tm2 (** Level 2 terms *) 14 | | `Tm1 of Stratified.Syntax.tm1 (** Level 1 terms *) 15 | | `Tm0 of Stratified.Syntax.tm0 (** Level 0 terms *) 16 | ] 17 | 18 | (** An error that was encountered during translation. This should only ever 19 | be raised if an ill-typed core term was supplied to [translate]. *) 20 | exception Error of string 21 | 22 | (** Translate a term from the core language to a term in the stratified language *) 23 | val translate : Context.t -> Core.Syntax.tm -> tm 24 | -------------------------------------------------------------------------------- /scraps/wip-compile-stratify/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name stratify) 4 | (package wip-compile-stratify)) 5 | -------------------------------------------------------------------------------- /scraps/wip-compile-stratify/env.ml: -------------------------------------------------------------------------------- 1 | type _ index = int 2 | type _ level = int 3 | type _ size = int 4 | 5 | type (_, 'a) t = 'a list 6 | 7 | let empty = [] 8 | 9 | let bind_entry x env = 10 | x :: env 11 | 12 | let lookup x env = 13 | List.nth env x 14 | 15 | let size env = 16 | List.length env 17 | 18 | let entry_index a env = 19 | let rec go i = function 20 | | [] -> None 21 | | x :: env -> if x = a then Some i else go (i + 1) env in 22 | go 0 env 23 | 24 | let empty_size = 0 25 | 26 | let bind_level size = 27 | size + 1 28 | 29 | let next_level size = 30 | size 31 | 32 | let level_to_index size level = 33 | size - level - 1 34 | -------------------------------------------------------------------------------- /scraps/wip-compile-uncurry/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name uncurry) 4 | (package wip-compile-uncurry)) 5 | 6 | (env 7 | (dev 8 | ; see `ocamlc -warn-help` for information on warnings 9 | (flags (:standard -w -unused-constructor 10 | -w -unused-type-declaration 11 | -w -unused-value-declaration)))) 12 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/README.md: -------------------------------------------------------------------------------- 1 | # Elaboration with built-in types and operations 2 | 3 | > NOTE: A work in progress! 4 | 5 | An experiment into implementing elaboration with built-in types and operations. 6 | 7 | Adding built-ins/primitives to a language is a common source of frustration and 8 | confusion. It’s easy to fall into cycles of trying one approach, and then 9 | another, and failing to make progress. The goal of this project is to attempt to 10 | explore this design problem in a more isolated fashion. 11 | 12 | ## Todo list 13 | 14 | - [x] initial hard-coded primitives 15 | - [ ] operations 16 | - [ ] glued eval for nicer errors 17 | - [ ] figure out nomenclature: built-ins, primitives, lang-items, pervasives, externs 18 | - [ ] declare literals 19 | - [ ] declare operators 20 | - [ ] external types and operations 21 | 22 | ## Resources and inspiration 23 | 24 | - [Agda Language Reference: Built-ins](https://agda.readthedocs.io/en/latest/language/built-ins.html) 25 | - [Agda Language Reference: Postulates](https://agda.readthedocs.io/en/latest/language/postulates.html) 26 | - [Rust Unstable Book: Lang items](https://doc.rust-lang.org/beta/unstable-book/language-features/lang-items.html) 27 | - [F*'s `primitive_step` type](https://github.com/FStarLang/FStar/blob/60b3e5a4d382406e99529950927cbcfbbd5f310b/src/typechecker/FStar.TypeChecker.Cfg.fsti#L89-L98) 28 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (public_name builtins) 4 | (package wip-elab-builtins) 5 | (libraries 6 | wip-elab-builtins 7 | cmdliner)) 8 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/bin/main.ml: -------------------------------------------------------------------------------- 1 | (** {0 Compiler CLI} *) 2 | 3 | module Surface = Elab_builtins.Surface 4 | module Core = Elab_builtins.Core 5 | 6 | 7 | (** Helper functions *) 8 | 9 | let print_error (pos : Lexing.position) message = 10 | Printf.eprintf "%s:%d:%d: %s\n" 11 | pos.pos_fname 12 | pos.pos_lnum 13 | (pos.pos_cnum - pos.pos_bol) 14 | message 15 | 16 | let parse_module filename in_channel = 17 | let lexbuf = Lexing.from_channel in_channel in 18 | Lexing.set_filename lexbuf filename; 19 | try 20 | Surface.Parser.main Surface.Lexer.token lexbuf 21 | with 22 | | Surface.Lexer.Error -> 23 | let pos = Lexing.lexeme_start_p lexbuf in 24 | print_error pos "unexpected character"; 25 | exit 1 26 | | Surface.Parser.Error -> 27 | let pos = Lexing.lexeme_start_p lexbuf in 28 | print_error pos "syntax error"; 29 | exit 1 30 | 31 | 32 | (** {1 Subcommands} *) 33 | 34 | let elab_cmd () : unit = 35 | let items = parse_module "" stdin in 36 | let context = Surface.Elab.initial_context in 37 | let items = Surface.Elab.elab_items context items in 38 | items |> List.iter (function 39 | | Core.Syntax.Def { label; ty; tm } -> 40 | Format.printf "def %s : %a := %a;\n" 41 | label 42 | Core.Syntax.pp_tm ty 43 | Core.Syntax.pp_tm tm) 44 | 45 | 46 | (** {1 CLI options} *) 47 | 48 | let cmd = 49 | let open Cmdliner in 50 | 51 | Cmd.group (Cmd.info (Filename.basename Sys.argv.(0))) [ 52 | Cmd.v (Cmd.info "elab" ~doc:"elaborate a module from standard input") 53 | Term.(const elab_cmd $ const ()); 54 | (* TODO: `norm` command *) 55 | ] 56 | 57 | 58 | (** {1 Main entrypoint} *) 59 | 60 | let () = 61 | Printexc.record_backtrace true; 62 | exit (Cmdliner.Cmd.eval cmd) 63 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/lib/core.ml: -------------------------------------------------------------------------------- 1 | (** The core language *) 2 | 3 | module Syntax = Core_syntax 4 | module Semantics = Core_semantics 5 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/lib/core_semantics.mli: -------------------------------------------------------------------------------- 1 | type value = 2 | | Neutral of head * elim list 3 | 4 | | Type 5 | 6 | | Bool_type 7 | | I32_type 8 | | I64_type 9 | | F64_type 10 | 11 | | Bool_lit of bool 12 | | I32_lit of int32 13 | | I64_lit of int64 14 | | F64_lit of float 15 | 16 | and head = Item_var of string 17 | and elim = | 18 | 19 | val eval : (string -> value) -> Core_syntax.tm -> value 20 | 21 | val quote : value -> Core_syntax.tm 22 | 23 | val is_convertible : value -> value -> bool 24 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/lib/core_syntax.ml: -------------------------------------------------------------------------------- 1 | type tm = 2 | | Item_var of string 3 | 4 | | Type 5 | 6 | | Bool_type 7 | | I32_type 8 | | I64_type 9 | | F64_type 10 | 11 | | Bool_lit of bool 12 | | I32_lit of int32 13 | | I64_lit of int64 14 | | F64_lit of float 15 | 16 | type item = 17 | | Def of { label : string; ty : tm; tm : tm } 18 | 19 | 20 | let pp_tm ppf = 21 | function 22 | | Item_var name -> Format.pp_print_string ppf name 23 | 24 | | Type -> Format.pp_print_string ppf "builtin.Type" 25 | 26 | | Bool_type -> Format.pp_print_string ppf "builtin.Bool" 27 | | I32_type -> Format.pp_print_string ppf "builtin.I32" 28 | | I64_type -> Format.pp_print_string ppf "builtin.I64" 29 | | F64_type -> Format.pp_print_string ppf "builtin.F64" 30 | 31 | | Bool_lit true -> Format.pp_print_string ppf "builtin.true" 32 | | Bool_lit false -> Format.pp_print_string ppf "builtin.false" 33 | | I32_lit x -> Format.pp_print_int ppf (Int32.to_int x) 34 | | I64_lit x -> Format.pp_print_int ppf (Int64.to_int x) 35 | | F64_lit x -> Format.pp_print_float ppf x 36 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name elab_builtins) 3 | (public_name wip-elab-builtins)) 4 | 5 | (menhir 6 | (modules surface_parser) 7 | (flags --explain --strict)) 8 | 9 | (ocamllex surface_lexer) 10 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/lib/surface.ml: -------------------------------------------------------------------------------- 1 | (** The surface language *) 2 | 3 | module Syntax = Surface_syntax 4 | module Parser = Surface_parser 5 | module Lexer = Surface_lexer 6 | module Elab = Surface_elab 7 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/lib/surface_elab.mli: -------------------------------------------------------------------------------- 1 | type context 2 | 3 | val initial_context : context 4 | 5 | val elab_items : context -> Surface_syntax.item list -> Core_syntax.item list 6 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/lib/surface_lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Surface_parser 3 | 4 | exception Error 5 | } 6 | 7 | let newline = '\n' 8 | let whitespace = [' ' '\t'] 9 | let comment = "--" [^ '\n']* newline 10 | let ident = ['a'-'z' 'A'-'Z']['-' '_' 'a'-'z' 'A'-'Z' '0'-'9']* 11 | let digit = ['0'-'9'] 12 | let digits = digit+ 13 | 14 | rule token = parse 15 | | whitespace { token lexbuf } 16 | | newline { Lexing.new_line lexbuf; token lexbuf } 17 | | comment { Lexing.new_line lexbuf; token lexbuf } 18 | | "def" { KEYWORD_DEF } 19 | | "use" { KEYWORD_USE } 20 | | ident as n { NAME n } 21 | | digits as n { NUMBER n } 22 | | ":" { COLON } 23 | | ":=" { COLON_EQUALS } 24 | | "." { FULL_STOP } 25 | | "-" { HYPHEN } 26 | | "+" { PLUS } 27 | | ";" { SEMICOLON } 28 | | eof { END } 29 | | _ { raise Error } 30 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/lib/surface_parser.mly: -------------------------------------------------------------------------------- 1 | %token KEYWORD_DEF "def" 2 | %token KEYWORD_USE "use" 3 | %token NAME 4 | %token NUMBER 5 | %token COLON ":" 6 | %token COLON_EQUALS ":=" 7 | %token FULL_STOP "." 8 | %token HYPHEN "-" 9 | %token PLUS "+" 10 | %token SEMICOLON ";" 11 | 12 | %token LPAREN "(" 13 | %token RPAREN ")" 14 | 15 | %token END 16 | 17 | %start main 18 | 19 | %% 20 | 21 | let main := 22 | | is = list(item); END; 23 | { is } 24 | 25 | let item := 26 | | "use"; path = separated_nonempty_list(".", NAME); ";"; 27 | { Surface_syntax.Use { path } } 28 | | "def"; label = NAME; ty = option(":"; t = tm; { t }); ":="; tm = tm; ";"; 29 | { Surface_syntax.Def { label; ty; tm } } 30 | 31 | let tm := 32 | | lhs = atomic_tm; "+"; rhs = tm; 33 | { Surface_syntax.Binop (lhs, Surface_syntax.Add, rhs) } 34 | | lhs = atomic_tm; "-"; rhs = tm; 35 | { Surface_syntax.Binop (lhs, Surface_syntax.Sub, rhs) } 36 | | t = atomic_tm; 37 | { t } 38 | 39 | let atomic_tm := 40 | | "("; t = tm; ")"; 41 | { t } 42 | | path = separated_nonempty_list(".", NAME); 43 | { Surface_syntax.Path path } 44 | | num = NUMBER; 45 | { Surface_syntax.Num_lit num } 46 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/lib/surface_syntax.ml: -------------------------------------------------------------------------------- 1 | type binop = 2 | | Add 3 | | Sub 4 | 5 | type tm = 6 | | Path of string list 7 | | Num_lit of string 8 | | Binop of tm * binop * tm 9 | 10 | type item = 11 | | Use of { path : string list } 12 | | Def of { label : string; ty : tm option; tm : tm } 13 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/test/cli.t: -------------------------------------------------------------------------------- 1 | Usage 2 | $ builtins 3 | builtins: required COMMAND name is missing, must be 'elab'. 4 | Usage: builtins COMMAND … 5 | Try 'builtins --help' for more information. 6 | [124] 7 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/test/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (package wip-elab-builtins) 3 | (deps %{bin:builtins})) 4 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/test/sample.t/main.txt: -------------------------------------------------------------------------------- 1 | def Type := builtin.Type; 2 | 3 | def Bool : Type := builtin.Bool; 4 | def true : Bool := builtin.true; 5 | def false : Bool := builtin.false; 6 | 7 | def I32 : Type := builtin.I32; 8 | def I64 : Type := builtin.I64; 9 | def F64 : Type := builtin.F64; 10 | 11 | def one : I32 := 1; 12 | -------------------------------------------------------------------------------- /scraps/wip-elab-builtins/test/sample.t/run.t: -------------------------------------------------------------------------------- 1 | Test main.txt 2 | $ cat main.txt | builtins elab 3 | def Type : builtin.Type := builtin.Type; 4 | def Bool : Type := builtin.Bool; 5 | def true : Bool := builtin.true; 6 | def false : Bool := builtin.false; 7 | def I32 : Type := builtin.I32; 8 | def I64 : Type := builtin.I64; 9 | def F64 : Type := builtin.F64; 10 | def one : I32 := 1; 11 | --------------------------------------------------------------------------------