├── .dockerignore ├── .gitignore ├── test ├── dune └── tests.ml ├── bin ├── dune └── main.ml ├── lib ├── dune ├── open_func.ml ├── open_func.mli ├── base.ml ├── extensions.ml ├── article.ml └── string.ml ├── Dockerfile ├── .github └── workflows │ └── ci.yaml ├── dune-project ├── document_calculus.opam ├── LICENSE-MIT ├── document_calculus.opam.locked ├── README.md └── LICENSE-APACHE /.dockerignore: -------------------------------------------------------------------------------- 1 | .gitignore -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.tar.gz -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name tests) 3 | (libraries document_calculus)) 4 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (public_name document_calculus) 3 | (name main) 4 | (libraries document_calculus)) -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name document_calculus) 3 | (libraries ppx_deriving.std bindlib) 4 | (preprocess (pps ppx_deriving.show))) 5 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam:ubuntu-22.04-ocaml-4.13 2 | 3 | # Copy files over w/ correct permissions 4 | USER root 5 | COPY . /app 6 | RUN chown opam /app 7 | USER opam 8 | WORKDIR /app 9 | 10 | # Install dependencies 11 | RUN opam install . --deps-only --locked -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | push: 5 | branches: [ "main" ] 6 | pull_request: 7 | branches: [ "main" ] 8 | 9 | jobs: 10 | tests: 11 | name: Tests 12 | runs-on: ubuntu-latest 13 | steps: 14 | - uses: actions/checkout@v3 15 | - name: Install OCaml 16 | uses: ocaml/setup-ocaml@v2 17 | with: 18 | ocaml-compiler: 4.13.1 19 | - name: Install dependencies 20 | run: opam install . --deps-only --with-test 21 | - name: Run tests 22 | run: opam exec -- dune test 23 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.6) 2 | 3 | (name document_calculus) 4 | 5 | (generate_opam_files true) 6 | 7 | (source 8 | (github cognitive-engineering-lab/document-calculus)) 9 | 10 | (authors "Will Crichton") 11 | 12 | (maintainers "Will Crichton") 13 | 14 | (license "MIT" "Apache-2.0") 15 | 16 | (documentation https://url/to/documentation) 17 | 18 | (package 19 | (name document_calculus) 20 | (synopsis "Accompanying materials for \"A Core Calculus for Documents\" (Crichton and Krishnamurthi 2024)") 21 | (depends ocaml dune ppx_deriving bindlib)) -------------------------------------------------------------------------------- /lib/open_func.ml: -------------------------------------------------------------------------------- 1 | (* See open_func.mli for documentation.*) 2 | 3 | exception Missing_case 4 | 5 | module type FuncSig = sig 6 | type input 7 | type output 8 | end 9 | 10 | module Make(F : FuncSig) = struct 11 | type func = F.input -> F.output 12 | 13 | let f_cell : func ref = ref (fun _ -> raise Missing_case) 14 | 15 | let register (f : func) : unit = 16 | let prev = !f_cell in 17 | f_cell := fun t -> try f t with Match_failure _ -> prev t 18 | 19 | let call (x : F.input) : F.output = !f_cell x 20 | end 21 | 22 | let noop _ = raise (Match_failure ("", 0, 0)) -------------------------------------------------------------------------------- /bin/main.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-unused-open"] 2 | 3 | (* A testing ground. Fill me in and run: 4 | $ dune exec bin/main.exe *) 5 | 6 | open Document_calculus.Base 7 | open Document_calculus.String 8 | open Bindlib 9 | 10 | let main () = 11 | let open DStrLit in 12 | let open DStrProg in 13 | register_dstrlit (); 14 | register_dstrprog (); 15 | 16 | let e = _Concat (_EString "hello") (_EString " world") in 17 | assert (Type.eq (Expr.typecheck_top (_EString "sup")) TString); 18 | Printf.printf "A sample program:\n %s\n\n" (Expr.show (unbox e)); 19 | 20 | let e' = Expr.eval_top e in 21 | Printf.printf "It evaluates to:\n %s\n" (Expr.show e') 22 | 23 | let () = main () -------------------------------------------------------------------------------- /document_calculus.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: 4 | "Accompanying materials for \"A Core Calculus for Documents\" (Crichton and Krishnamurthi 2024)" 5 | maintainer: ["Will Crichton"] 6 | authors: ["Will Crichton"] 7 | license: ["MIT" "Apache-2.0"] 8 | homepage: "https://github.com/cognitive-engineering-lab/document-calculus" 9 | doc: "https://url/to/documentation" 10 | bug-reports: 11 | "https://github.com/cognitive-engineering-lab/document-calculus/issues" 12 | depends: [ 13 | "ocaml" 14 | "dune" {>= "3.6"} 15 | "ppx_deriving" 16 | "bindlib" 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: 34 | "git+https://github.com/cognitive-engineering-lab/document-calculus.git" 35 | -------------------------------------------------------------------------------- /LICENSE-MIT: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. -------------------------------------------------------------------------------- /document_calculus.opam.locked: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "document_calculus" 3 | version: "~dev" 4 | synopsis: 5 | "Accompanying materials for \"A Core Calculus for Documents\" (Crichton and Krishnamurthi 2024)" 6 | maintainer: "Will Crichton" 7 | authors: "Will Crichton" 8 | license: ["MIT" "Apache-2.0"] 9 | homepage: "https://github.com/cognitive-engineering-lab/document-calculus" 10 | doc: "https://url/to/documentation" 11 | bug-reports: 12 | "https://github.com/cognitive-engineering-lab/document-calculus/issues" 13 | depends: [ 14 | "base-bigarray" {= "base"} 15 | "base-threads" {= "base"} 16 | "base-unix" {= "base"} 17 | "bindlib" {= "6.0.0"} 18 | "cppo" {= "1.6.9"} 19 | "dune" {= "3.8.2"} 20 | "ocaml" {= "4.13.1"} 21 | "ocaml-base-compiler" {= "4.13.1"} 22 | "ocaml-compiler-libs" {= "v0.12.4"} 23 | "ocaml-config" {= "2"} 24 | "ocaml-options-vanilla" {= "1"} 25 | "ocamlfind" {= "1.9.6"} 26 | "ppx_derivers" {= "1.2.1"} 27 | "ppx_deriving" {= "5.2.1"} 28 | "ppxlib" {= "0.30.0"} 29 | "result" {= "1.5"} 30 | "sexplib0" {= "v0.16.0"} 31 | "stdlib-shims" {= "0.3.0"} 32 | ] 33 | build: [ 34 | ["dune" "subst"] {dev} 35 | [ 36 | "dune" 37 | "build" 38 | "-p" 39 | name 40 | "-j" 41 | jobs 42 | "@install" 43 | "@runtest" {with-test} 44 | "@doc" {with-doc} 45 | ] 46 | ] 47 | dev-repo: 48 | "git+https://github.com/cognitive-engineering-lab/document-calculus.git" -------------------------------------------------------------------------------- /lib/open_func.mli: -------------------------------------------------------------------------------- 1 | (* This module provides an implementation of "open functions", or 2 | functions whose behavior can be provided in pieces. *) 3 | 4 | (* This describes the input and output types of the open function. *) 5 | module type FuncSig = sig 6 | type input 7 | type output 8 | end 9 | 10 | exception Missing_case 11 | 12 | (* Creates a new open function for the given function signature. *) 13 | module Make(F : FuncSig) : sig 14 | type func = F.input -> F.output 15 | 16 | (* Registers a new case for the open function. This is a mutating operation -- 17 | you cannot undo it! 18 | 19 | The provided case should raise a Match_failure if it cannot handle 20 | a given input. 21 | 22 | The open function will call the cases in the order they are registered, 23 | so be careful to register them in the right order. 24 | 25 | Partial cases are most convenient to write with the -partial-match warning 26 | disabled, and leave OCaml to raise a Match_failure as normal. *) 27 | val register : func -> unit 28 | 29 | (* Calls the open function on a given input. 30 | 31 | This iterates through each registered case and returns its output 32 | if it does not raise a Match_failure. 33 | 34 | If no cases provide a value, then this raises the Missing_case exception. *) 35 | val call : F.input -> F.output 36 | end 37 | 38 | (* A convenient helper for not handling any cases. *) 39 | val noop : 'a -> 'b -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # A Core Calculus for Documents 2 | 3 | This repository contains the accompanying artifact for the POPL'24 paper "A Core Calculus for Documents" (Crichton and Krishnamurthi). 4 | 5 | ## Overview 6 | 7 | The core contribution of our paper is a formal model of document languages. This model extends System F with the concept of templates. We provide static and dynamic semantics for templates, and we also model various run-time extensions to the system such as reference labeling and reactivity. 8 | 9 | This artifact implements each aspect of the model in OCaml. Our main goal in the implementation is to *correctly* and *clearly* implement the model. Then this model can facilitate authors of document languages to pick and choose ideas that are relevant to their setting, especially those less familiar with PL theory notation. Each of the source files has been liberally commented to explain the purpose of the code, and to point a reader to the relevant pieces. 10 | 11 | **Claims:** Sections 3, 4, and 5 all contain elements that are implemented in the artifact. See "Evaluation Instructions" below for details on which modules correspond to which subsections. 12 | 13 | ## Getting Started 14 | 15 | ### From Docker 16 | 17 | If you are downloading a Docker image from Zenodo, first: make sure to pick the image that corresponds to your architecture. That's `arm64` for an ARM machine (e.g., an M-series Mac), and `amd64` otherwise. 18 | 19 | Then run the following command, replacing `` with either `arm64` or `amd64`: 20 | 21 | ``` 22 | docker load -i document-calculus-popl24-.tar.gz 23 | ``` 24 | 25 | Then start the image and run the tests as follows: 26 | 27 | ``` 28 | $ docker run -ti document-calculus-popl24: bash 29 | opam@4fb288bee717:/app$ opam exec -- dune test 30 | ``` 31 | 32 | ### From Source 33 | 34 | #### I'm in a hurry 35 | 36 | You need [opam]. Run this script: 37 | 38 | ``` 39 | opam switch create 4.13.1 --yes 40 | eval $(opam env --switch=4.13.1) 41 | opam install . --deps-only --locked --yes 42 | opam exec -- dune test 43 | ``` 44 | 45 | #### I have some time 46 | 47 | In greater detail: first, you need the OCaml package manager [opam]. This artifact was last tested with opam version 2.1.3. 48 | 49 | Then, you need OCaml. This artifact was last tested with OCaml version 4.13.1. You can install the version by running: 50 | 51 | ``` 52 | opam switch create 4.13.1 53 | ``` 54 | 55 | Then install the project's dependencies by running: 56 | 57 | ``` 58 | opam install . --deps-only --locked 59 | ``` 60 | 61 | Finally, make sure the tests pass by running: 62 | 63 | ``` 64 | opam exec -- dune test 65 | ``` 66 | 67 | ## Evaluation Instructions 68 | 69 | To evaluate this artifact, you should check that the paper representation of the model matches the OCaml representation of the model. I recommend doing so in the following order: 70 | 71 | * Section 3.1.1: the `DStrLit` module in `lib/string.ml`. 72 | * Section 3.1.2: the `DStrProg` module in `lib/string.ml`. 73 | * Section 3.1.3: the `DStrTLit` module in `lib/string.ml`. 74 | * Section 3.1.4: the `DStrTProg` module in `lib/string.ml`. 75 | * Section 3.2.1: has no implementation in the code. 76 | * Section 3.2.2: the `DArtProg` module in `lib/article.ml`. 77 | * Section 3.2.3: has no implementation in the code. 78 | * Section 3.2.4: the `DArtTProg` module and the `DArtTProgNested` module in `lib/article.ml`, and the `Node` module in `lib/extensions.ml`. 79 | * Section 4.1: the `References` module in `lib/extensions.ml`. 80 | * Section 4.2: the `Reforestation` module in `lib/extensions.ml`. 81 | * Section 4.3: the `Reactivity` module in `lib/extensions.ml`. 82 | * Section 5.1: the `typecheck_template` functions in `lib/string.ml` and `lib/article.ml`. 83 | 84 | ## Additional Artifact Details 85 | 86 | The main source files are all in `lib/`. The other files correspond to these categories: 87 | 88 | ### Tests 89 | 90 | To test that the artifact has no basic errors, we have written a number of unit tests in `test/tests.ml`. You can run these tests with the following command: 91 | 92 | ``` 93 | opam exec -- dune test 94 | ``` 95 | 96 | You can also edit `tests.ml` and add your own test if you want. 97 | 98 | ### Playground 99 | 100 | We have provided a `bin/main.ml` file for playing around with the library. 101 | There is already a sample program there you can run, like this: 102 | 103 | ``` 104 | $ opam exec -- dune exec bin/main.exe 105 | A sample program: 106 | "hello" + " world" 107 | 108 | It evaluates to: 109 | "hello world" 110 | ``` 111 | 112 | You can try modifying `main.ml` and rerunning it with different programs. 113 | 114 | [opam]: https://opam.ocaml.org/doc/Install.html -------------------------------------------------------------------------------- /lib/base.ml: -------------------------------------------------------------------------------- 1 | exception Undefined_behavior 2 | exception Not_desugared 3 | exception Type_error of string 4 | 5 | let box_list l = List.fold_right 6 | (Bindlib.box_apply2 (fun x xs -> x :: xs)) 7 | l 8 | (Bindlib.box []) 9 | 10 | module Type = struct 11 | type t = .. 12 | type ctx_elem = .. 13 | type ctx = ctx_elem list 14 | type var = t Bindlib.var 15 | type 'a binder = ('a, t) Bindlib.binder 16 | 17 | module Show = Open_func.Make(struct 18 | type input = Bindlib.ctxt * t 19 | type output = string 20 | end) 21 | 22 | module Eq = Open_func.Make(struct 23 | type input = t * t 24 | type output = bool 25 | end) 26 | 27 | module Lift = Open_func.Make(struct 28 | type input = t 29 | type output = t Bindlib.box 30 | end) 31 | 32 | module type Fragment = sig 33 | val eq_type : Eq.func 34 | val lift_type : Lift.func 35 | val show_type : Show.func 36 | end 37 | 38 | let register (module F: Fragment) = 39 | Eq.register F.eq_type; 40 | Lift.register F.lift_type; 41 | Show.register F.show_type 42 | 43 | let eq t1 t2 = Eq.call (t1, t2) 44 | let unbox_eq t1 t2 = eq (Bindlib.unbox t1) (Bindlib.unbox t2) 45 | let show_ctx = Show.call 46 | let show t = Show.call (Bindlib.empty_ctxt, t) 47 | let lift = Lift.call 48 | end 49 | 50 | let () = Type.Eq.register (fun (_, _) -> false) 51 | 52 | module Expr = struct 53 | type t = .. 54 | type var = t Bindlib.var 55 | type 'a binder = ('a, t) Bindlib.binder 56 | 57 | module Eval = Open_func.Make(struct 58 | type input = t 59 | type output = t 60 | end) 61 | 62 | module Desugar = Open_func.Make(struct 63 | type input = t 64 | type output = t Bindlib.box 65 | end) 66 | 67 | module Show = Open_func.Make(struct 68 | type input = Bindlib.ctxt * t 69 | type output = string 70 | end) 71 | 72 | module Eq = Open_func.Make(struct 73 | type input = t * t 74 | type output = bool 75 | end) 76 | 77 | module Lift = Open_func.Make(struct 78 | type input = t 79 | type output = t Bindlib.box 80 | end) 81 | 82 | module Typecheck = Open_func.Make(struct 83 | type input = Type.ctx * t 84 | type output = Type.t Bindlib.box 85 | end) 86 | 87 | module type Fragment = sig 88 | val desugar_expr : Desugar.func 89 | val typecheck : Typecheck.func 90 | val lift_expr : Lift.func 91 | val eval : Eval.func 92 | val show_expr : Show.func 93 | val eq_expr : Eq.func 94 | end 95 | 96 | let register (module F: Fragment) = 97 | Desugar.register F.desugar_expr; 98 | Typecheck.register F.typecheck; 99 | Lift.register F.lift_expr; 100 | Eval.register F.eval; 101 | Show.register F.show_expr; 102 | Eq.register F.eq_expr 103 | 104 | let eval = Eval.call 105 | let desugar = Desugar.call 106 | let show_ctx = Show.call 107 | let show t = Show.call (Bindlib.empty_ctxt, t) 108 | let lift = Lift.call 109 | let typecheck = Typecheck.call 110 | let eq e1 e2 = Eq.call (e1, e2) 111 | 112 | let typecheck_top e = Bindlib.unbox (typecheck ([], Bindlib.unbox e)) 113 | let eval_top e = eval (Bindlib.unbox e) 114 | let desugar_eval e = eval (Bindlib.unbox (desugar e) ) 115 | end 116 | 117 | module Template = struct 118 | type part = .. 119 | type t = part list 120 | type 'a binder = ('a, t) Bindlib.binder 121 | 122 | module Desugar_part = Open_func.Make(struct 123 | type input = Type.t * part 124 | type output = Expr.t Bindlib.box 125 | end) 126 | 127 | module Desugar_in_context = Open_func.Make(struct 128 | type input = Type.t * part * t 129 | type output = Expr.t Bindlib.box 130 | end) 131 | 132 | module Typecheck_part = Open_func.Make(struct 133 | type input = Type.ctx * part 134 | type output = Type.t Bindlib.box 135 | end) 136 | 137 | module Typecheck_in_context = Open_func.Make(struct 138 | type input = Type.ctx * part * t 139 | type output = Type.t Bindlib.box 140 | end) 141 | 142 | module Lift_part = Open_func.Make(struct 143 | type input = part 144 | type output = part Bindlib.box 145 | end) 146 | 147 | module Show = Open_func.Make(struct 148 | type input = part 149 | type output = string 150 | end) 151 | 152 | module type Fragment = sig 153 | val desugar_tpart : Desugar_part.func 154 | val desugar_tpart_in_context : Desugar_in_context.func 155 | val typecheck_tpart : Typecheck_part.func 156 | val typecheck_tpart_in_context : Typecheck_in_context.func 157 | val lift_part : Lift_part.func 158 | val show_template : Show.func 159 | end 160 | 161 | let register (module F: Fragment) = 162 | Desugar_part.register F.desugar_tpart; 163 | Desugar_in_context.register F.desugar_tpart_in_context; 164 | Typecheck_part.register F.typecheck_tpart; 165 | Typecheck_in_context.register F.typecheck_tpart_in_context; 166 | Lift_part.register F.lift_part; 167 | Show.register F.show_template 168 | 169 | let desugar_part = Desugar_part.call 170 | let desugar_in_context = Desugar_in_context.call 171 | let typecheck_part = Typecheck_part.call 172 | let typecheck_in_context = Typecheck_in_context.call 173 | let lift_part = Lift_part.call 174 | 175 | let _Template = box_list 176 | 177 | let lift ps = _Template (List.map lift_part ps) 178 | 179 | let show = Show.call 180 | end 181 | 182 | 183 | -------------------------------------------------------------------------------- /test/tests.ml: -------------------------------------------------------------------------------- 1 | open Document_calculus.Base 2 | open Document_calculus.String 3 | open Bindlib 4 | open Document_calculus.Article 5 | open Document_calculus.Extensions 6 | 7 | let main () = 8 | (*** DStrLit tests ***) 9 | let open DStrLit in 10 | register_dstrlit (); 11 | assert (Type.eq (Expr.typecheck_top (_EString "sup")) TString); 12 | assert (Expr.eq (Expr.eval (EString "sup")) (EString "sup")); 13 | 14 | 15 | (*** DStrProg tests ***) 16 | let open DStrProg in 17 | let open Prelude in 18 | register_dstrprog() ; 19 | assert (Expr.eval (Concat (EString "hello", EString " world")) = (EString "hello world")); 20 | let x = mkefree "x" in 21 | let e = ( 22 | _Let x (_EString "a") 23 | (_Concat (_Var x) (_Concat (_EString "b") (_Var x)))) in 24 | assert (Type.eq (Expr.typecheck_top e) TString); 25 | assert (Expr.eq (Expr.eval_top e) (EString "aba")); 26 | 27 | let e = with_prelude (_EString "") in 28 | assert (Type.eq (Expr.typecheck_top e) TString); 29 | 30 | 31 | (*** DStrTLit tests ***) 32 | let open DStrTLit in 33 | let open Template in 34 | register_dstrtlit (); 35 | let world = mkefree "world" in 36 | let e = ( 37 | _Let world (_EString " World") 38 | (_StrTmpl (_Template [_TplStr "Hello"; _TplExpr (_Var world)]))) in 39 | assert (Type.eq (Expr.typecheck_top (desugar_with_prelude e)) TString); 40 | assert (Type.eq (Expr.typecheck_top (with_prelude e)) TString); 41 | assert (Expr.eq (Expr.eval_top (desugar_with_prelude e)) (EString "Hello World")); 42 | 43 | 44 | (*** DStrTProg tests ***) 45 | let open DStrTProg in 46 | register_dstrtprog (); 47 | let e = ( 48 | _StrTmpl (_Template [ 49 | _TplForeach 50 | (list _TString [_EString "a"; _EString "b"]) 51 | _TString 52 | x 53 | (_Template [_TplExpr (_Var x); _TplStr "c"]) 54 | ]) 55 | ) in 56 | assert (Type.eq (Expr.typecheck_top (desugar_with_prelude e)) TString); 57 | assert (Type.eq (Expr.typecheck_top (with_prelude e)) TString); 58 | assert (Expr.eq (Expr.eval_top (desugar_with_prelude e)) (EString "acbc")); 59 | 60 | 61 | (*** DArtTProg tests ***) 62 | let open DArtProg in 63 | let open DArtTProg in 64 | register_darttprog (); 65 | let mk_tpl textfn = _Template [_TplNode "p" [] (_Template [ 66 | _TplStr "Hello"; 67 | _TplSet world (textfn (_EString "World")); 68 | _TplExpr (_Var world); 69 | _TplForeach 70 | (list _TString [_EString "?"; _EString "!"]) 71 | _TString 72 | x 73 | (_Template [_TplNode "bold" [] (_Template [_TplExpr (textfn (_Var x))])]); 74 | ])] in 75 | let e = _TreeTmpl (mk_tpl text) in 76 | let expected = Expr.eval_top (desugar_with_prelude (nodelist [node (_EString "p") (nil tyattr) (nodelist [ 77 | text (_EString "Hello"); text (_EString "World"); 78 | node (_EString "bold") (nil tyattr) (nodelist [text (_EString "?")]); 79 | node (_EString "bold") (nil tyattr) (nodelist [text (_EString "!")]) 80 | ])])) in 81 | assert (Type.eq (Expr.typecheck_top (desugar_with_prelude e)) (unbox (tylist tynode))); 82 | assert (Type.eq (Expr.typecheck_top (with_prelude e)) (unbox (tylist tynode))); 83 | assert (Expr.eq (Expr.eval_top (desugar_with_prelude e)) expected); 84 | 85 | 86 | (*** DArtTProgNested tests ***) 87 | let open DArtTProgNested in 88 | register_dartprognested (); 89 | let e = _FragTpl (mk_tpl ftext) in 90 | assert (Type.eq (Expr.typecheck_top (desugar_with_prelude e)) (unbox (tylist tynode))); 91 | assert (Type.eq (Expr.typecheck_top (with_prelude e)) (unbox (tylist tynode))); 92 | assert (Expr.eq (Expr.eval_top (desugar_with_prelude e)) expected); 93 | 94 | 95 | (*** References extension tests ***) 96 | let open Node in 97 | let open References in 98 | let mk_doc id = NNode("article", [], [ 99 | NNode ("ref", [("target", id)], []); 100 | NNode ("section", [("id", "intro")], [ 101 | NNode ("h1", [], [NText "Introduction"]); 102 | NNode ("section", [("id", "contributions")], []); 103 | NNode ("section", [("id", "caveats")], []) 104 | ]); 105 | NNode ("section", [("id", "discussion")], []); 106 | ]) in 107 | assert (section_ids (mk_doc "") = [ 108 | ("intro", [1]); 109 | ("contributions", [1; 1]); 110 | ("caveats", [2; 1]); 111 | ("discussion", [2]) 112 | ]); 113 | 114 | let d = mk_doc "intro" in 115 | assert (valid (section_ids d) d); 116 | let d = mk_doc "foobar" in 117 | assert (not (valid (section_ids d) d)); 118 | 119 | let d = mk_doc "caveats" in 120 | let d' = replace_refs (section_ids d) d in 121 | assert (match d' with NNode ("article", _, NText "1.2" :: _) -> true | _ -> false); 122 | 123 | 124 | (*** Reforestation extension tests ***) 125 | let open Reforestation in 126 | let d = [ 127 | NText "hello"; 128 | NText "world"; 129 | NText "\n\n"; 130 | NText "middle"; 131 | NNode ("h1", [], [NText "header"]); 132 | NText "postscript" 133 | ] in 134 | assert (reforest d [] = [ 135 | NNode ("para", [], [NText "hello"; NText "world"]); 136 | NNode ("para", [], [NText "middle"]); 137 | NNode ("h1", [], [NNode ("para", [], [NText "header"])]); 138 | NNode ("para", [], [NText "postscript"]) 139 | ]); 140 | 141 | 142 | (*** Reactive extension tests ***) 143 | let open Reactivity in 144 | let open T in 145 | let counter child = 146 | let id = gen_comp_id () in 147 | let init p = (List.assoc "mark" p, "") in 148 | let update s (p, c) = 149 | if s = "click" then (p, p ^ c) else (p, c) in 150 | let view (_, c) = child c in 151 | {id; init; update; view} in 152 | let v0 = 153 | let inner_ctr = counter (fun c -> RText c) in 154 | RInstance 155 | (instantiate (counter (fun c -> 156 | RNode ("para", [], [ 157 | RText c; 158 | RInstance (instantiate inner_ctr [("mark", "@")]) 159 | ]))) 160 | [("mark", "|")]) in 161 | 162 | let a0 = doc_view v0 in 163 | assert (a0 = NNode ("para", [], [NText ""; NText ""])); 164 | 165 | let v1 = doc_step [(0, "click")] v0 in 166 | let a1 = doc_view v1 in 167 | assert (a1 = NNode ("para", [], [NText ""; NText "@"])); 168 | 169 | let v2 = doc_step [(1, "click")] v1 in 170 | let a2 = doc_view v2 in 171 | assert (a2 = NNode ("para", [], [NText "|"; NText "@"])); 172 | 173 | () 174 | 175 | 176 | let () = main () -------------------------------------------------------------------------------- /lib/extensions.ml: -------------------------------------------------------------------------------- 1 | (* This module implements the extensions to the document calculus. 2 | 3 | These extensions operate mostly in "user space" rather than at the language level, 4 | so it's clearer to implement the extensions shallowly within OCaml rather than 5 | deeply in System F. *) 6 | 7 | 8 | (* These type definitions are the same as the DArtTProgNested in article.ml, 9 | but much more readable thanks to OCaml's syntax and sugar. 10 | 11 | See Section 3.4.2 for the formal model of these types. *) 12 | module Node = struct 13 | type 'a struct_node = string * (string * string) list * 'a 14 | [@@deriving show] 15 | 16 | type t = NText of string | NNode of t list struct_node 17 | [@@deriving show] 18 | 19 | type 'a fragment = FBase of 'a | FList of 'a fragment list 20 | type fnode = FText of string | FNode of fnode fragment struct_node 21 | 22 | let rec elim_frags (f : fnode fragment) : t list = 23 | match f with 24 | | FBase base -> (match base with 25 | | FText s -> [NText s] 26 | | FNode (tag, attrs, children) -> [NNode (tag, attrs, elim_frags children)]) 27 | | FList list -> List.concat (List.map elim_frags list) 28 | end 29 | 30 | 31 | (* Implementation of Section 4.1. Automatically generates section numbers 32 | and reference labels from the document structure, and checks for invalid 33 | references. *) 34 | module References = struct 35 | type id_ctxt = (string * int list) list 36 | [@@deriving show] 37 | 38 | let rec section_ids_at_depth (n : Node.t) (d : int list) : id_ctxt * int list = 39 | let (k, ks) = match d with 40 | | [] -> failwith "section_ids_at_depth: empty depth" 41 | | k :: ks -> (k, ks) in 42 | match n with 43 | | NText _ -> ([], k :: ks) 44 | | NNode (tag, attrs, children) -> 45 | (match (tag, List.assoc_opt "id" attrs) with 46 | | ("section", Some id) -> 47 | let ctx = section_ids_at_depth_list children (1 :: k :: ks) in 48 | ((id, k :: ks) :: ctx, (k + 1) :: ks) 49 | | _ -> 50 | let ctx = section_ids_at_depth_list children (k :: ks) in 51 | (ctx, k :: ks)) 52 | and section_ids_at_depth_list children d = 53 | let (ctx, _) = List.fold_left (fun (ctx, d) n' -> 54 | let (ctx', d') = section_ids_at_depth n' d in 55 | (ctx @ ctx', d')) ([], d) children in 56 | ctx 57 | 58 | let section_ids (n : Node.t) : id_ctxt = 59 | let (ctx, _) = section_ids_at_depth n [1] in ctx 60 | 61 | let rec valid (ctx : id_ctxt) (n : Node.t) : bool = 62 | match n with 63 | | NText _ -> true 64 | | NNode (tag, attrs, children) -> 65 | (match (tag, List.assoc_opt "target" attrs) with 66 | | ("ref", Some id) -> List.mem_assoc id ctx 67 | | _ -> List.for_all (valid ctx) children) 68 | 69 | let section_number_to_string (n : int list) : string = 70 | Stdlib.String.concat "." (List.map string_of_int (List.rev n)) 71 | 72 | let rec replace_refs (ctx : id_ctxt) (n : Node.t) : Node.t = 73 | match n with 74 | | NText s -> NText s 75 | | NNode (tag, attrs, children) -> 76 | (match (tag, List.assoc_opt "target" attrs) with 77 | | ("ref", Some id) -> NText (section_number_to_string (List.assoc id ctx)) 78 | | _ -> NNode (tag, attrs, List.map (replace_refs ctx) children)) 79 | end 80 | 81 | (* Implementation of Section 4.2. Converts a document from a pre-forested 82 | intermediate representation into the final format by breaking newlines 83 | into paragraphs. *) 84 | module Reforestation = struct 85 | let is_block tag = List.mem tag ["section"; "para"; "h1"] 86 | 87 | let rec reforest (ns : Node.t list) (par : Node.t list) : Node.t list = 88 | let flush_par = Node.NNode ("para", [], List.rev par) in 89 | match ns with 90 | | [] -> [flush_par] 91 | | n :: ns' -> 92 | (match n with 93 | | NText "\n\n" -> flush_par :: reforest ns' [] 94 | | NText s -> reforest ns' (NText s :: par) 95 | | NNode (tag, attrs, children) -> 96 | if is_block tag then 97 | flush_par :: NNode (tag, attrs, reforest children []) :: reforest ns' [] 98 | else 99 | reforest ns' (NNode (tag, attrs, children) :: par)) 100 | end 101 | 102 | (* Implementation of Section 4.3. Defines a simple virtual DOM with 103 | stateful components, along with functions to update the tree with signals 104 | and then convert it to a final article. *) 105 | module Reactivity = struct 106 | type signal = string 107 | type comp_id = int 108 | type inst_id = int 109 | 110 | (* Technical note: we need a recursive module so we can define 111 | mutually recursive types where one of them involves a module (i.e., Instance). *) 112 | module rec T : sig 113 | (* A component is a tree node with persistent state. *) 114 | type ('props, 'state) component = { 115 | (* Initialization function converts properties to state. *) 116 | init : 'props -> 'state; 117 | 118 | (* Update function changes state in response to a signal. *) 119 | update : signal -> 'state -> 'state; 120 | 121 | (* View function converts the state into a virtual DOM tree (including components). *) 122 | view : 'state -> T.rnode; 123 | 124 | (* Internal identifier used to determine whether two components are the same. *) 125 | id : comp_id; 126 | } 127 | 128 | (* An instance is a realization of a component with a particular set of 129 | properties and state. 130 | 131 | Note that we have to make Instance a module so we can use it as an existential 132 | type, i.e. to erase its props/state types and allow the component tree 133 | to hold many component instances of different types. *) 134 | module type Instance = sig 135 | type props 136 | type state 137 | 138 | val id : inst_id 139 | val com : (props, state) T.component 140 | val props : props 141 | val state : state 142 | val node : T.rnode 143 | end 144 | 145 | type defprops = (string * string) list 146 | module type JsonPropInstance = Instance with type props = defprops 147 | 148 | (* The type of the virtual DOM. Basically a document tree with instances. *) 149 | type rnode = 150 | | RText of string 151 | | RNode of rnode list Node.struct_node 152 | | RInstance of (module T.JsonPropInstance) 153 | end = T 154 | open T 155 | 156 | (* Creates a new instance by erasing its types. *) 157 | let erase_instance (type a) (type b) (id : inst_id) (com : (a, b) component) (props : a) (state : b) (node: rnode) : (module Instance with type props = a) = 158 | (module struct 159 | type props = a 160 | type state = b 161 | 162 | let id = id 163 | let com = com 164 | let props = props 165 | let state = state 166 | let node = node 167 | end) 168 | 169 | (* Generates a new instance ID from a hidden counter. *) 170 | let gen_inst_id : unit -> inst_id = 171 | let counter = ref 0 in 172 | fun () -> 173 | let id = !counter in 174 | counter := id + 1; 175 | id 176 | 177 | (* Generates a new component ID from a hidden counter. *) 178 | let gen_comp_id : unit -> comp_id = 179 | let counter = ref 0 in 180 | fun () -> 181 | let id = !counter in 182 | counter := id + 1; 183 | id 184 | 185 | (* Creates a new instance from a component definition and a set of properties. *) 186 | let instantiate (type a) (type b) (com : (a, b) component) (props : a) : (module Instance with type props = a) = 187 | let state = com.init props in 188 | let node = com.view state in 189 | let id = gen_inst_id () in 190 | erase_instance id com props state node 191 | 192 | (* A representation of user-provided events. *) 193 | type signal_map = (inst_id * signal) list 194 | 195 | (* Steps a VDOM tree to a new VDOM tree given the input signals. *) 196 | let rec doc_step (signals : signal_map) (n : rnode) : rnode = 197 | match n with 198 | | RText _ -> n 199 | | RNode (tag, attrs, children) -> 200 | let children' = List.map (doc_step signals) children in 201 | RNode (tag, attrs, children') 202 | | RInstance (module I) -> 203 | (match List.assoc_opt I.id signals with 204 | | Some signal -> 205 | let state' = I.com.update signal I.state in 206 | let node' = I.com.view state' in 207 | RInstance (erase_instance I.id I.com I.props state' (reconcile signals I.node node')) 208 | | None -> 209 | RInstance (erase_instance I.id I.com I.props I.state (doc_step signals I.node))) 210 | 211 | (* Reconciles two trees, persisting components from the old tree when applicable. *) 212 | and reconcile (signals : signal_map) (n : rnode) (n' : rnode) : rnode = 213 | match (n, n') with 214 | | (RNode (tag, attrs, children), RNode (tag', attrs', children')) -> 215 | if tag = tag' && attrs = attrs' && List.length children = List.length children' then 216 | let children'' = List.map2 (reconcile signals) children children' in 217 | RNode (tag, attrs, children'') 218 | else 219 | n' 220 | | (RInstance (module I), RInstance (module I')) -> 221 | if I.com.id = I'.com.id && I.props = I'.props then 222 | doc_step signals n 223 | else 224 | n' 225 | | _ -> n' 226 | 227 | (* Converts a VDOM tree into a normal document tree, i.e. removing instances. *) 228 | let rec doc_view (n : rnode) : Node.t = 229 | match n with 230 | | RText s -> NText s 231 | | RNode (tag, attrs, children) -> 232 | NNode (tag, attrs, List.map doc_view children) 233 | | RInstance (module I) -> doc_view I.node 234 | end -------------------------------------------------------------------------------- /lib/article.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-partial-match"] 2 | 3 | (* This module provides the D^Article levels of the document calculus.contents 4 | 5 | Note: we do not implement an OCaml model for D^Article_Lit or D^Article_TLit, 6 | as neither have any actual implementation details. 7 | *) 8 | 9 | open Base 10 | open String 11 | open Bindlib 12 | 13 | (* D^Article_Prog level of the document calculus. 14 | Adds a standard library of node types for attributed, tagged trees. 15 | Does not require any changes to the language. *) 16 | module DArtProg = struct 17 | open DStrLit 18 | open DStrProg 19 | open Prelude 20 | 21 | (* Type of node attributes. *) 22 | let tyattr = _TProd _TString _TString 23 | 24 | (* Type of the interior of a node. *) 25 | let tystructnode ty = _TProd _TString (_TProd (tylist tyattr) ty) 26 | 27 | (* Type of a document node. *) 28 | let tynode = 29 | let node = mktfree "node" in 30 | _TRec node (_TSum _TString (tystructnode (tylist (_TVar node)))) 31 | 32 | (* The recursive type unfolded. *) 33 | let tynodebody = _TSum _TString (tystructnode (tylist tynode)) 34 | 35 | let nodelist = list tynode 36 | 37 | (* Constructors for text nodes and recursive nodes. *) 38 | let text e = _Fold tynode (_Inject Left tynodebody e) 39 | let node nt at e = _Fold tynode (_Inject Right tynodebody (_Pair nt (_Pair at e))) 40 | end 41 | 42 | (* D^Article_TProg level of the document calculus. 43 | Adds tree templates with support for all the template parts in D^String_TProg. *) 44 | module DArtTProg = struct 45 | open DStrLit 46 | open DStrProg 47 | open DArtProg 48 | open DStrTLit 49 | open Prelude 50 | 51 | (* We extend the template language with attributes nodes. In a concrete syntax, you 52 | might write one like: Hello world! *) 53 | type Template.part += 54 | TplNode of string * (string * Expr.t) list * Template.t 55 | 56 | (* We extend the expression language with tree templates, which are like 57 | string templates but they desugar to trees instead of strings. *) 58 | type Expr.t += 59 | TreeTmpl of Template.t 60 | 61 | (* Smart constructors for Bindlib. *) 62 | let _TplNode : string -> (string * Expr.t box) list -> Template.t box -> Template.part box = 63 | fun nt attrs children -> 64 | let (keys, vals) = List.split attrs in 65 | box_apply2 (fun vals children -> 66 | let attrs = List.combine keys vals in 67 | TplNode (nt, attrs, children) 68 | ) (box_list vals) children 69 | let _TreeTmpl : Template.t box -> Expr.t box = box_apply (fun t -> TreeTmpl t) 70 | 71 | (* Desugaring a tree template does not require adding a join, 72 | unlike desugaring a string template. *) 73 | let desugar_expr = function 74 | | TreeTmpl t -> desugar_template (unbox tynode, t) 75 | 76 | let desugar_attrs at = 77 | (list tyattr (List.map (fun (k, v) -> _Pair (_EString k) (Expr.desugar v)) at)) 78 | 79 | (* This is where our TplCtx type comes into play. When we see a TplStr, 80 | we know to make it a node rather than a plain string 81 | if we're in a `tynode` context. *) 82 | let desugar_tpart (ty, p) = 83 | let in_ctx = Type.eq ty (unbox tynode) in 84 | match p with 85 | | TplStr s when in_ctx -> text (_EString s) 86 | | TplNode (tag, attrs, children) when in_ctx -> 87 | node 88 | (_EString tag) 89 | (desugar_attrs attrs) 90 | (desugar_template (ty, children)) 91 | 92 | let typecheck (ctx, e) = match e with 93 | | TreeTmpl tpl -> 94 | let t = (typecheck_template (TplCtx tynode :: ctx, tpl)) in 95 | if Type.unbox_eq t (tylist tynode) then tylist tynode 96 | else raise (Type_error "tree template") 97 | 98 | let typecheck_tpart (ctx, p) = 99 | let ty = ctx_tpl_ty ctx in 100 | match p with 101 | | TplNode (_, attrs, children) -> 102 | List.iter (fun (_, v) -> 103 | if not (Type.unbox_eq (Expr.typecheck (ctx, v)) ty) then 104 | raise (Type_error "attrs")) 105 | attrs; 106 | if Type.unbox_eq (typecheck_template (ctx, children)) (tylist ty) then ty 107 | else raise (Type_error "children") 108 | 109 | (* Boring code. *) 110 | 111 | let show_template = function 112 | | TplNode (nt, _, kt) -> Printf.sprintf "<%s>%s" nt (show_ttext kt) nt 113 | 114 | let show_expr (_ctx, e) = match e with 115 | | TreeTmpl kt -> show_ttext kt 116 | 117 | let eval = function 118 | | TreeTmpl _ -> raise Not_desugared 119 | 120 | let lift_expr = function 121 | | TreeTmpl _ -> raise Not_desugared 122 | 123 | let lift_part = function 124 | | TplNode (tag, attrs, t) -> 125 | box_apply (fun t -> TplNode (tag, attrs, t)) (Template.lift t) 126 | 127 | let eq_expr = function 128 | | (TreeTmpl _, _) | (_, TreeTmpl _) -> raise Not_desugared 129 | 130 | let desugar_tpart_in_context = Open_func.noop 131 | let typecheck_tpart_in_context = Open_func.noop 132 | end 133 | let register_darttprog () = 134 | Expr.register (module DArtTProg); 135 | Template.register (module DArtTProg) 136 | 137 | (* Implementation of the "fragment" strategy for D^Article_TProg. *) 138 | module DArtTProgNested = struct 139 | open DStrLit 140 | open DStrTLit 141 | open DStrProg 142 | open DArtTProg 143 | open DStrTProg 144 | open DArtProg 145 | open Prelude 146 | 147 | (* Add a new FragTpl expression which is like TreeTpl but uses the alternative 148 | desugaring strategy. It still desugars to terms of the same type. *) 149 | type Expr.t += 150 | | FragTpl of Template.t 151 | 152 | let _FragTpl = box_apply (fun t -> FragTpl t) 153 | 154 | (* Lots of type definitions... it's a little obscured due to the embedding 155 | in System F. To see a clearer presentation, either: 156 | - Check out the symbolic formalism in Section 3.2.4 of the paper. 157 | - Check out extensions.ml for a shallow OCaml embedding. 158 | (The code below was largely transliterated from the other OCaml code.) *) 159 | let tree = mktfree "tree" 160 | let tyfrag t = _TRec tree (_TSum t (tylist (_TVar tree))) 161 | let tyfragbody t = _TSum t (tylist (tyfrag t)) 162 | 163 | let fragbase t e = _Fold (tyfrag t) (_Inject Left (tyfragbody t) e) 164 | let fraglist t e = _Fold (tyfrag t) (_Inject Right (tyfragbody t) e) 165 | 166 | let fnode = mktfree "fnode" 167 | let tyfnode = _TRec fnode (_TSum _TString (tystructnode (tyfrag (_TVar fnode)))) 168 | let tyfnodebody = _TSum _TString (tystructnode (tyfrag tyfnode)) 169 | 170 | let tynodetree = tyfrag tyfnode 171 | 172 | let ftext e = fragbase tyfnode (_Fold tyfnode (_Inject Left tyfnodebody e)) 173 | let fnode nt at e = fragbase tyfnode (_Fold tyfnode (_Inject Right tyfnodebody (_Pair nt (_Pair at e)))) 174 | 175 | let elim_fragsv = mkefree "elim_frags" 176 | let elim_frags = 177 | let (fl, base, textv, nd, listv) = (mkefree "fl", mkefree "base", mkefree "text", mkefree "nd", mkefree "list") in 178 | _Fix elim_fragsv (_TFun tynodetree (tylist tynode)) (lam1 fl tynodetree ( 179 | _Case 180 | (_Unfold tynodetree (_Var fl)) 181 | base 182 | (_Case 183 | (_Unfold tyfnode (_Var base)) 184 | textv (list tynode [text (_Var textv)]) 185 | nd (list tynode [ 186 | node 187 | (_Project (_Var nd) Left) 188 | (_Project (_Project (_Var nd) Right) Left) 189 | (app1 (_Var elim_fragsv) (_Project (_Project (_Var nd) Right) Right))])) 190 | listv 191 | (flatten tynode 192 | (foreach tynodetree (tylist tynode) (_Var elim_fragsv) (_Var listv))))) 193 | 194 | let desugar_template_elems_as_fraglist t = 195 | fraglist tyfnode (desugar_template (unbox tynodetree, t)) 196 | 197 | let desugar_expr = function FragTpl t -> app1 elim_frags (desugar_template_elems_as_fraglist t) 198 | 199 | (* Override "default" desugaring for non-fragment templates *) 200 | let desugar_tpart_in_context (ty, lt, lts) = 201 | let in_ctx = Type.eq ty (unbox tynodetree) in 202 | match lt with 203 | | TplForeach _ | TplIf _ when in_ctx -> 204 | cons (Type.lift ty) (Template.desugar_part (ty, lt)) (desugar_template (ty, lts)) 205 | 206 | let desugar_tpart (ty, p) = 207 | let in_ctx = Type.eq ty (unbox tynodetree) in 208 | match p with 209 | | TplStr s when in_ctx -> ftext (_EString s) 210 | | TplNode (tag, attrs, t) when in_ctx -> 211 | fnode (_EString tag) (desugar_attrs attrs) (desugar_template_elems_as_fraglist t) 212 | | TplForeach (e, xty, t) when in_ctx -> 213 | let (x, t) = unbind t in 214 | fraglist tyfnode ( 215 | foreach (Type.lift xty) (Type.lift ty) (lam1 x (Type.lift xty) (desugar_template_elems_as_fraglist t)) (Expr.desugar e)) 216 | | TplIf (e, t1, t2) when in_ctx -> 217 | if_ (Expr.desugar e) (desugar_template_elems_as_fraglist t1) (desugar_template_elems_as_fraglist t2) 218 | 219 | let typecheck (ctx, e) = match e with FragTpl t -> 220 | if Type.unbox_eq (typecheck_template (TplCtx tynodetree :: ctx, t)) (tylist tynodetree) then tylist tynode 221 | else raise (Type_error "tree template") 222 | 223 | let lift_expr = function 224 | | FragTpl _ -> raise Not_desugared 225 | let eq_expr = function 226 | | (FragTpl _, _) | (_, FragTpl _) -> raise Not_desugared 227 | 228 | let eval = Open_func.noop 229 | let show_expr = Open_func.noop 230 | let subst_expr = Open_func.noop 231 | let show_template = Open_func.noop 232 | let typecheck_tpart = Open_func.noop 233 | let lift_part = Open_func.noop 234 | let typecheck_tpart_in_context = Open_func.noop 235 | end 236 | let register_dartprognested () = 237 | Expr.register (module DArtTProgNested); 238 | Template.register (module DArtTProgNested) -------------------------------------------------------------------------------- /LICENSE-APACHE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS -------------------------------------------------------------------------------- /lib/string.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-partial-match"] 2 | 3 | (* This module provides the D^String levels of the document calculus. 4 | I recommend skipping to DStrTLit if you want to see the interesting parts. *) 5 | 6 | open Base 7 | open Bindlib 8 | 9 | (* D^String_Lit level of the document calculus. 10 | String literals are the only kind of expression, and strings are the only kind of type. *) 11 | module DStrLit = struct 12 | (* We add string expressions and string types. *) 13 | type Expr.t += 14 | | EString of string 15 | type Type.t += 16 | | TString 17 | 18 | (* We use Bindlib to handle binding. 19 | This requires special constructor functions for all syntax elements, 20 | which are prefixed with an underscore. *) 21 | let _EString : string -> Expr.t box = fun s -> box (EString s) 22 | let _TString = box TString 23 | 24 | (* The eval and typecheck functions are straightforward. *) 25 | let eval = function 26 | | EString s -> EString s 27 | let typecheck (_, e) = match e with 28 | | EString _ -> _TString 29 | 30 | (* Many other functions that you can ignore. 31 | Some of these will be useful later, but for now we are just 32 | defining the uninteresting case of strings. *) 33 | 34 | let show_expr (_, e) = match e with 35 | | EString s -> Printf.sprintf "\"%s\"" s 36 | let show_type (_, ty) = match ty with 37 | | TString -> "string" 38 | let desugar_expr = function 39 | | EString s -> _EString s 40 | let lift_expr = function 41 | | EString s -> _EString s 42 | let lift_type = function 43 | | TString -> _TString 44 | let eq_expr = function 45 | | (EString s1, EString s2) -> s1 = s2 46 | let eq_type = function 47 | | (TString, TString) -> true 48 | end 49 | 50 | (* Call this function to load this language fragment into the open functions. *) 51 | let register_dstrlit () = 52 | Type.register (module DStrLit); 53 | Expr.register (module DStrLit) 54 | 55 | 56 | (* D^String_Prog level of the document calculus. 57 | An implementation of the static and dynamic semantics for System F with a base type of strings. *) 58 | module DStrProg = struct 59 | open DStrLit 60 | 61 | type dir = Left | Right 62 | 63 | (* Add all of System F's expressions... *) 64 | type Expr.t += 65 | | Concat of Expr.t * Expr.t 66 | | Let of Expr.t * Expr.t Expr.binder 67 | | Fix of Type.t * Expr.t Expr.binder 68 | | Var of Expr.var 69 | | Inject of dir * Type.t * Expr.t 70 | | Case of { 71 | expr: Expr.t; 72 | left: Expr.t Expr.binder; 73 | right: Expr.t Expr.binder; 74 | } 75 | | Lambda of Type.t * Expr.t Expr.binder 76 | | App of Expr.t * Expr.t 77 | | Unit 78 | | Pair of Expr.t * Expr.t 79 | | Project of Expr.t * dir 80 | | Fold of Type.t * Expr.t 81 | | Unfold of Type.t * Expr.t 82 | | TyLambda of Type.t Expr.binder 83 | | TyApp of Expr.t * Type.t 84 | | Pack of Type.t * Expr.t * Type.t 85 | | Unpack of Expr.t * (Expr.t, (Type.t, Expr.t) binder) binder 86 | 87 | (* ... and types ... *) 88 | type Type.t += 89 | | TFun of Type.t * Type.t 90 | | TProd of Type.t * Type.t 91 | | TSum of Type.t * Type.t 92 | | TUnit 93 | | TForall of Type.t Type.binder 94 | | TExists of Type.t Type.binder 95 | | TRec of Type.t Type.binder 96 | | TVar of Type.var 97 | 98 | (* ... and type context elements. *) 99 | type Type.ctx_elem += 100 | | BoundVar of Expr.var * Type.t box 101 | | BoundTypeVar of Type.var 102 | 103 | (* The code below is a relatively rote implementation of System F. 104 | It mostly looks like you would find in e.g. TAPL. 105 | Most of the idiosyncracies (like the huge number of constructor functions) 106 | are due to requirements of Bindlib. *) 107 | 108 | let mkefree = new_var (fun x -> Var x) 109 | let mktfree = new_var (fun x -> TVar x) 110 | 111 | let _Var : Expr.t var -> Expr.t box = 112 | box_var 113 | let _Concat : Expr.t box -> Expr.t box -> Expr.t box = 114 | box_apply2 (fun a b -> Concat (a, b)) 115 | let _Let : Expr.t var -> Expr.t box -> Expr.t box -> Expr.t box = 116 | fun x e1 e2 -> box_apply2 (fun e1 e2 -> Let (e1, e2)) e1 (bind_var x e2) 117 | let _App : Expr.t box -> Expr.t box -> Expr.t box = 118 | box_apply2 (fun a b -> App (a, b)) 119 | let _Lambda : Expr.t var -> Type.t box -> Expr.t box -> Expr.t box = 120 | fun x t e -> box_apply2 (fun t e -> Lambda (t, e)) t (bind_var x e) 121 | let _TyLambda : Type.t var -> Expr.t box -> Expr.t box = 122 | fun a e -> box_apply (fun e -> TyLambda e) (bind_var a e) 123 | let _TyApp : Expr.t box -> Type.t box -> Expr.t box = 124 | box_apply2 (fun e t -> TyApp (e, t)) 125 | let _Unit : Expr.t box = 126 | box Unit 127 | let _Pair : Expr.t box -> Expr.t box -> Expr.t box = 128 | box_apply2 (fun a b -> Pair (a, b)) 129 | let _Project : Expr.t box -> dir -> Expr.t box = 130 | fun e d -> box_apply (fun e -> Project (e, d)) e 131 | let _Fold : Type.t box -> Expr.t box -> Expr.t box = 132 | box_apply2 (fun t e -> Fold (t, e)) 133 | let _Unfold : Type.t box -> Expr.t box -> Expr.t box = 134 | box_apply2 (fun t e -> Unfold (t, e)) 135 | let _Fix : Expr.t var -> Type.t box -> Expr.t box -> Expr.t box = 136 | fun x t e -> box_apply2 (fun t e -> Fix (t, e)) t (bind_var x e) 137 | let _Pack : Type.t box -> Expr.t box -> Type.t box -> Expr.t box = 138 | box_apply3 (fun t1 e t2 -> Pack (t1, e, t2)) 139 | let _Unpack : Expr.t var -> Type.t var -> Expr.t box -> Expr.t box -> Expr.t box = 140 | fun x a e1 e2 -> box_apply2 (fun e1 e2 -> Unpack (e1, e2)) e1 (bind_var x (bind_var a e2)) 141 | let _Inject : dir -> Type.t box -> Expr.t box -> Expr.t box = 142 | fun d t e -> box_apply2 (fun t e -> Inject (d, t, e)) t e 143 | let _Case : Expr.t box -> Expr.t var -> Expr.t box -> Expr.t var -> Expr.t box -> Expr.t box = 144 | fun expr x left y right -> 145 | box_apply3 (fun expr left right -> Case {expr; left; right}) expr (bind_var x left) (bind_var y right) 146 | 147 | let _TUnit : Type.t box = box TUnit 148 | let _TProd : Type.t box -> Type.t box -> Type.t box = 149 | box_apply2 (fun a b -> TProd (a, b)) 150 | let _TSum : Type.t box -> Type.t box -> Type.t box = 151 | box_apply2 (fun a b -> TSum (a, b)) 152 | let _TFun : Type.t box -> Type.t box -> Type.t box = 153 | box_apply2 (fun a b -> TFun (a, b)) 154 | let _TForall : Type.t var -> Type.t box -> Type.t box = 155 | fun a t -> box_apply (fun t -> TForall t) (bind_var a t) 156 | let _TRec : Type.t var -> Type.t box -> Type.t box = 157 | fun a t -> box_apply (fun t -> TRec t) (bind_var a t) 158 | let _TExists : Type.t var -> Type.t box -> Type.t box = 159 | fun a t -> box_apply (fun t -> TExists t) (bind_var a t) 160 | let _TVar : Type.t var -> Type.t box = 161 | box_var 162 | 163 | let eval = function 164 | | Concat (e1, e2) -> 165 | let (EString s1, EString s2) = (Expr.eval e1, Expr.eval e2) in 166 | EString (s1 ^ s2) 167 | | Let (e1, e2) -> Expr.eval (subst e2 (Expr.eval e1)) 168 | | Fix (t, e) -> Expr.eval (subst e (Fix (t, e))) 169 | | Var _ -> raise Undefined_behavior 170 | | Inject (dir, t, e) -> Inject (dir, t, Expr.eval e) 171 | | Case {expr; left; right} -> 172 | let (Inject (dir, _, e)) = Expr.eval expr in 173 | Expr.eval (subst 174 | (match dir with Left -> left | Right -> right) 175 | e) 176 | | Lambda (t, e) -> Lambda (t, e) 177 | | App (e1, e2) -> 178 | let Lambda (_, e) = Expr.eval e1 in 179 | let e2' = Expr.eval e2 in 180 | Expr.eval (subst e e2') 181 | | Unit -> Unit 182 | | Pair (e1, e2) -> Pair (Expr.eval e1, Expr.eval e2) 183 | | Project (e, d) -> 184 | let Pair (v1, v2) = Expr.eval e in 185 | (match d with Left -> v1 | Right -> v2) 186 | | Fold (t, e) -> Fold (t, Expr.eval e) 187 | | Unfold (_, e) -> 188 | let Fold (_, e) = Expr.eval e in 189 | e 190 | | TyLambda e -> TyLambda e 191 | | TyApp (e, t) -> 192 | let TyLambda e = Expr.eval e in 193 | Expr.eval (subst e t) 194 | | Pack (t1, e, t2) -> Pack (t1, Expr.eval e, t2) 195 | | Unpack (e1, e2) -> 196 | let Pack (t, v, _) = Expr.eval e1 in 197 | Expr.eval (subst (subst e2 v) t) 198 | 199 | let eq_type = function 200 | | (TFun (t1, t2), TFun (t1', t2')) -> Type.eq t1 t1' && Type.eq t2 t2' 201 | | (TProd (t1, t2), TProd (t1', t2')) -> Type.eq t1 t1' && Type.eq t2 t2' 202 | | (TSum (t1, t2), TSum (t1', t2')) -> Type.eq t1 t1' && Type.eq t2 t2' 203 | | (TUnit, TUnit) -> true 204 | | (TForall t1, TForall t2) -> eq_binder Type.eq t1 t2 205 | | (TExists t1, TExists t2) -> eq_binder Type.eq t1 t2 206 | | (TRec t1, TRec t2) -> eq_binder Type.eq t1 t2 207 | | (TVar x, TVar y) -> eq_vars x y 208 | 209 | let eq_expr = function 210 | | (Concat (e1, e2), Concat (e1', e2')) -> Expr.eq e1 e1' && Expr.eq e2 e2' 211 | | (Let (e1, e2), Let (e1', e2')) -> Expr.eq e1 e1' && eq_binder Expr.eq e2 e2' 212 | | (Fix (t, e), Fix (t', e')) -> Type.eq t t' && eq_binder Expr.eq e e' 213 | | (Var x, Var y) -> eq_vars x y 214 | | (Inject (d, t, e), Inject (d', t', e')) -> d = d' && Type.eq t t' && Expr.eq e e' 215 | | (Case {expr; left; right}, Case {expr = expr'; left = left'; right = right'}) -> 216 | Expr.eq expr expr' && eq_binder Expr.eq left left' && eq_binder Expr.eq right right' 217 | | (Lambda (t, e), Lambda (t', e')) -> Type.eq t t' && eq_binder Expr.eq e e' 218 | | (App (e1, e2), App (e1', e2')) -> Expr.eq e1 e1' && Expr.eq e2 e2' 219 | | (Unit, Unit) -> true 220 | | (Pair (e1, e2), Pair (e1', e2')) -> Expr.eq e1 e1' && Expr.eq e2 e2' 221 | | (Project (e, d), Project (e', d')) -> Expr.eq e e' && d = d' 222 | | (Fold (t, e), Fold (t', e')) -> Type.eq t t' && Expr.eq e e' 223 | | (Unfold (t, e), Unfold (t', e')) -> Type.eq t t' && Expr.eq e e' 224 | | (TyLambda e, TyLambda e') -> eq_binder Expr.eq e e' 225 | | (TyApp (e, t), TyApp (e', t')) -> Expr.eq e e' && Type.eq t t' 226 | | (Pack (t1, e, t2), Pack (t1', e', t2')) -> Type.eq t1 t1' && Expr.eq e e' && Type.eq t2 t2' 227 | | (Unpack (e1, e2), Unpack (e1', e2')) -> Expr.eq e1 e1' && eq_binder (eq_binder Expr.eq) e2 e2' 228 | 229 | let show_dir = function Left -> "l" | Right -> "r" 230 | 231 | let show_expr (ctx, e) = match e with 232 | | Concat (e1, e2) -> Printf.sprintf "%s + %s" (Expr.show_ctx (ctx, e1)) (Expr.show_ctx (ctx, e2)) 233 | | Let (e1, e2) -> 234 | let (x, e2, ctx) = unbind_in ctx e2 in 235 | Printf.sprintf "let %s = %s in\n%s" 236 | (name_of x) 237 | (Expr.show_ctx (ctx, e1)) 238 | (Expr.show_ctx (ctx, e2)) 239 | | Fix (t, e) -> 240 | let (x, e, ctx) = unbind_in ctx e in 241 | Printf.sprintf "fix (%s : %s). %s" 242 | (name_of x) 243 | (Type.show_ctx (ctx, t)) 244 | (Expr.show_ctx (ctx, e)) 245 | | Var x -> name_of x 246 | | Inject (d, t, e) -> 247 | Printf.sprintf "in%s(%s as %s)" (show_dir d) (Expr.show_ctx (ctx, e)) (Type.show_ctx (ctx, t)) 248 | | Case {expr; left; right} -> 249 | let (x, left, ctx) = unbind_in ctx left in 250 | let (y, right, ctx) = unbind_in ctx right in 251 | Printf.sprintf "case %s of inl(%s) -> %s | inr(%s) -> %s" 252 | (Expr.show_ctx (ctx, expr)) 253 | (name_of x) (Expr.show_ctx (ctx, left)) 254 | (name_of y) (Expr.show_ctx (ctx, right)) 255 | | Lambda (t, e) -> 256 | let (x, e, ctx) = unbind_in ctx e in 257 | Printf.sprintf " fun (%s:%s). %s" 258 | (name_of x) 259 | (Type.show_ctx (ctx, t)) 260 | (Expr.show_ctx (ctx, e)) 261 | | App (e1, e2) -> Printf.sprintf "%s %s" (Expr.show_ctx (ctx, e1)) (Expr.show_ctx (ctx, e2)) 262 | | Pair (e1, e2) -> Printf.sprintf "(%s, %s)" (Expr.show_ctx (ctx, e1)) (Expr.show_ctx (ctx, e2)) 263 | | Project (e, d) -> Printf.sprintf "%s.%s" (Expr.show_ctx (ctx, e)) (show_dir d) 264 | | Fold (t, e) -> 265 | (match t with 266 | (* | TRec ("list", _) -> 267 | let Inject (d, _, e) = e in 268 | (match d with 269 | | Left -> "[]" 270 | | Right -> 271 | let Pair (e1, e2) = e in 272 | Printf.sprintf "%s :: %s" (Expr.show_ctx (ctx, e1)) (Expr.show_ctx (ctx, e2))) 273 | | TRec ("node", _) -> 274 | let Inject (d, _, e) = e in 275 | (match d with 276 | | Left -> Printf.sprintf "%s" (Expr.show_ctx (ctx, e)) 277 | | Right -> 278 | let Pair(nt, children) = e in 279 | Printf.sprintf "<%s>%s" (Expr.show_ctx (ctx, nt)) (Expr.show_ctx (ctx, children)) (Expr.show_ctx (ctx, nt))) *) 280 | | _ -> Printf.sprintf "fold %s as (%s)" (Expr.show_ctx (ctx, e)) (Type.show_ctx (ctx, t))) 281 | | Unfold (t, e) -> Printf.sprintf "unfold %s from (%s)" (Expr.show_ctx (ctx, e)) (Type.show_ctx (ctx, t) ) 282 | | TyLambda e -> 283 | let (x, e, ctx) = unbind_in ctx e in 284 | Printf.sprintf "tfun %s -> %s" (name_of x) (Expr.show_ctx (ctx, e)) 285 | | TyApp (e, t) -> Printf.sprintf "%s[%s]" (Expr.show_ctx (ctx, e)) (Type.show_ctx (ctx, t)) 286 | | Unit -> "()" 287 | 288 | let show_type (ctx, t) = match t with 289 | | TFun (t1, t2) -> Printf.sprintf "(%s -> %s)" (Type.show_ctx (ctx, t1)) (Type.show_ctx (ctx, t2)) 290 | | TProd (t1, t2) -> Printf.sprintf "%s * %s" (Type.show_ctx (ctx, t1)) (Type.show_ctx (ctx, t2)) 291 | | TSum (t1, t2) -> Printf.sprintf "%s + %s" (Type.show_ctx (ctx, t1)) (Type.show_ctx (ctx, t2)) 292 | | TUnit -> "unit" 293 | | TForall t -> 294 | let (x, t, ctx) = unbind_in ctx t in 295 | Printf.sprintf "forall %s. %s" (name_of x) (Type.show_ctx (ctx, t)) 296 | | TRec t -> 297 | let (x, t, ctx) = unbind_in ctx t in 298 | if (name_of x) = "list" then 299 | let TSum (_, TProd (t', _)) = t in 300 | Printf.sprintf "%s list" (Type.show_ctx (ctx, t')) 301 | else 302 | Printf.sprintf "rec %s. %s" (name_of x) (Type.show_ctx (ctx, t)) 303 | | TVar x -> name_of x 304 | 305 | let typecheck (ctx, e) = match e with 306 | | Concat (e1, e2) -> 307 | let (t1, t2) = (Expr.typecheck (ctx, e1), (Expr.typecheck (ctx, e2))) in 308 | (match (unbox t1, unbox t2) with 309 | | (TString, TString) -> _TString 310 | | _ -> raise (Type_error "concat")) 311 | | Let (e1, e2) -> 312 | let t1 = Expr.typecheck (ctx, e1) in 313 | let (x, e2') = unbind e2 in 314 | Expr.typecheck ((BoundVar (x, t1)) :: ctx, e2') 315 | | Fix (t, e) -> 316 | let (x, e') = unbind e in 317 | Expr.typecheck ((BoundVar (x, Type.lift t)) :: ctx, e') 318 | | Var x -> 319 | let ty_opt = List.find_map (fun elem -> match elem with 320 | | BoundVar (y, t) -> 321 | if eq_vars x y then Some t else None 322 | | _ -> None) ctx in 323 | (match ty_opt with 324 | | Some ty -> ty 325 | | None -> raise (Type_error (Printf.sprintf "Var: %s" (name_of x)))) 326 | | Inject (dir, t, e') -> 327 | let t' = Expr.typecheck (ctx, e') in 328 | let t'' = (match (dir, t) with 329 | | (Left, TSum (t'', _)) -> t'' 330 | | (Right, TSum (_, t'')) -> t'' 331 | | _ -> raise (Type_error (Printf.sprintf "inject: not a sum: %s" (Expr.show e)))) in 332 | if Type.eq (unbox t') t'' then Type.lift t 333 | else raise (Type_error (Printf.sprintf "inject: %s != %s" (Type.show (unbox t')) (Type.show t''))) 334 | | Case {expr; left; right} -> 335 | let t = Expr.typecheck (ctx, expr) in 336 | (match unbox t with 337 | | TSum (t1, t2) -> 338 | let (x, left') = unbind left in 339 | let (y, right') = unbind right in 340 | let t1' = Expr.typecheck ((BoundVar (x, Type.lift t1)) :: ctx, left') in 341 | let t2' = Expr.typecheck ((BoundVar (y, Type.lift t2)) :: ctx, right') in 342 | if Type.unbox_eq t1' t2' then t1' 343 | else raise (Type_error (Printf.sprintf "case: %s != %s" (Type.show (unbox t1')) (Type.show (unbox t2')))) 344 | | _ -> raise (Type_error "case")) 345 | | Lambda (t, e) -> 346 | let (x, e') = unbind e in 347 | let t' = Expr.typecheck ((BoundVar (x, Type.lift t)) :: ctx, e') in 348 | _TFun (Type.lift t) t' 349 | | App (e1, e2) -> 350 | let t1 = Expr.typecheck (ctx, e1) in 351 | let t2 = Expr.typecheck (ctx, e2) in 352 | (match unbox t1 with 353 | | TFun (t1', t1'') -> 354 | if Type.eq t1' (unbox t2) then (Type.lift t1'') 355 | else raise (Type_error (Printf.sprintf "app: %s : %s != %s : %s" (Expr.show e1) (Type.show t1') (Expr.show e2) (Type.show (unbox t2)))) 356 | | _ -> raise (Type_error "app")) 357 | | Pair (e1, e2) -> 358 | let t1 = Expr.typecheck (ctx, e1) in 359 | let t2 = Expr.typecheck (ctx, e2) in 360 | _TProd t1 t2 361 | | Project (e, d) -> 362 | let t = Expr.typecheck (ctx, e) in 363 | (match unbox t with 364 | | TProd (t1, t2) -> Type.lift (match d with Left -> t1 | Right -> t2) 365 | | _ -> raise (Type_error (Printf.sprintf "project from non-product: %s" (Type.show (unbox t))))) 366 | | Fold (t, e) -> 367 | let TRec t0 = t in 368 | let t2 = Expr.typecheck (ctx, e) in 369 | let t3 = subst t0 t in 370 | if Type.eq (unbox t2) t3 then Type.lift t 371 | else raise (Type_error (Printf.sprintf "fold: %s != %s" (Type.show (unbox t2)) (Type.show t3))) 372 | | Unfold (t, e) -> 373 | let TRec t0 = t in 374 | let t1 = Expr.typecheck (ctx, e) in 375 | if Type.eq t (unbox t1) then Type.lift (subst t0 t) 376 | else raise (Type_error "unfold") 377 | | TyLambda e -> 378 | let (alpha, e') = unbind e in 379 | let t = Expr.typecheck ((BoundTypeVar alpha) :: ctx, e') in 380 | _TForall alpha t 381 | | TyApp (e, t) -> 382 | let t0 = Expr.typecheck (ctx, e) in 383 | (match (unbox t0) with 384 | | TForall t1 -> Type.lift (subst t1 t) 385 | | _ -> raise (Type_error "tyapp")) 386 | | Unit -> _TUnit 387 | | Pack (t1, e, t2ex) -> 388 | let TExists t2 = t2ex in 389 | if Type.eq (unbox (Expr.typecheck (ctx, e))) (subst t2 t1) then Type.lift t2ex 390 | else raise (Type_error "pack") 391 | | Unpack (e1, e2) -> 392 | (match unbox (Expr.typecheck (ctx, e1)) with 393 | | TExists t0 -> 394 | let (alpha, t1) = unbind t0 in 395 | let (x, e3) = unbind e2 in 396 | let ctx' = (BoundTypeVar alpha) :: (BoundVar (x, Type.lift t1)) :: ctx in 397 | Expr.typecheck (ctx', (subst e3 (TVar alpha))) 398 | | _ -> raise (Type_error "unpack")) 399 | 400 | let desugar_expr = function 401 | | Concat (e1, e2) -> _Concat (Expr.desugar e1) (Expr.desugar e2) 402 | | Let (e1, e2) -> 403 | let (x, e2) = unbind e2 in 404 | _Let x (Expr.desugar e1) (Expr.desugar e2) 405 | | Fix (t, e) -> 406 | let (x, e) = unbind e in 407 | _Fix x (Type.lift t) (Expr.desugar e) 408 | | Var x -> _Var x 409 | | Inject (dir, t, e) -> _Inject dir (Type.lift t) (Expr.desugar e) 410 | | Case {expr; left; right} -> 411 | let (x, left) = unbind left in 412 | let (y, right) = unbind right in 413 | _Case (Expr.desugar expr) x (Expr.desugar left) y (Expr.desugar right) 414 | | Lambda (t, e) -> 415 | let (x, e) = unbind e in 416 | _Lambda x (Type.lift t) (Expr.desugar e) 417 | | App (e1, e2) -> 418 | _App (Expr.desugar e1) (Expr.desugar e2) 419 | | Pair (e1, e2) -> 420 | _Pair (Expr.desugar e1) (Expr.desugar e2) 421 | | Project (e, n) -> 422 | _Project (Expr.desugar e) n 423 | | Fold (t, e) -> 424 | _Fold (Type.lift t) (Expr.desugar e) 425 | | Unfold (t, e) -> 426 | _Unfold (Type.lift t) (Expr.desugar e) 427 | | TyLambda e -> 428 | let (x, e) = unbind e in 429 | _TyLambda x (Expr.desugar e) 430 | | TyApp (e, t) -> 431 | _TyApp (Expr.desugar e) (Type.lift t) 432 | | Unit -> _Unit 433 | | Pack (t1, e, t2) -> 434 | _Pack (Type.lift t1) (Expr.desugar e) (Type.lift t2) 435 | | Unpack (e1, e2) -> 436 | let (x, e2') = unbind e2 in 437 | let (a, e2'') = unbind e2' in 438 | _Unpack x a (Expr.desugar e1) (Expr.desugar e2'') 439 | 440 | let lift_type = function 441 | | TFun (t1, t2) -> _TFun (Type.lift t1) (Type.lift t2) 442 | | TProd (t1, t2) -> _TProd (Type.lift t1) (Type.lift t2) 443 | | TSum (t1, t2) -> _TSum (Type.lift t1) (Type.lift t2) 444 | | TUnit -> _TUnit 445 | | TForall t -> box_apply (fun t -> TForall t) (box_binder Type.lift t) 446 | | TExists t -> box_apply (fun t -> TExists t) (box_binder Type.lift t) 447 | | TRec t -> box_apply (fun t -> TRec t) (box_binder Type.lift t) 448 | | TVar x -> box_var x 449 | 450 | let lift_expr = function 451 | | Concat (e1, e2) -> _Concat (Expr.lift e1) (Expr.lift e2) 452 | | Let (e1, e2) -> box_apply2 (fun e1 e2 -> Let (e1, e2)) (Expr.lift e1) (box_binder Expr.lift e2) 453 | | Fix (t, e) -> box_apply2 (fun t e -> Fix (t, e)) (Type.lift t) (box_binder Expr.lift e) 454 | | Var x -> box_var x 455 | | Inject (d, t, e) -> _Inject d (Type.lift t) (Expr.lift e) 456 | | Case {expr; left; right} -> 457 | box_apply3 (fun expr left right -> Case {expr; left; right}) (Expr.lift expr) (box_binder Expr.lift left) (box_binder Expr.lift right) 458 | | Lambda (t, e) -> box_apply2 (fun t e -> Lambda (t, e)) (Type.lift t) (box_binder Expr.lift e) 459 | | App (e1, e2) -> _App (Expr.lift e1) (Expr.lift e2) 460 | | Pair (e1, e2) -> _Pair (Expr.lift e1) (Expr.lift e2) 461 | | Project (e, d) -> _Project (Expr.lift e) d 462 | | Fold (t, e) -> _Fold (Type.lift t) (Expr.lift e) 463 | | Unfold (t, e) -> _Unfold (Type.lift t) (Expr.lift e) 464 | | TyLambda e -> box_apply (fun e -> TyLambda e) (box_binder Expr.lift e) 465 | | TyApp (e, t) -> _TyApp (Expr.lift e) (Type.lift t) 466 | | Unit -> _Unit 467 | | Pack (t1, e, t2) -> _Pack (Type.lift t1) (Expr.lift e) (Type.lift t2) 468 | | Unpack (e1, e2) -> 469 | box_apply2 (fun e1 e2 -> Unpack (e1, e2)) (Expr.lift e1) (box_binder (box_binder Expr.lift) e2) 470 | end 471 | 472 | let register_dstrprog () = 473 | Expr.register (module DStrProg); 474 | Type.register (module DStrProg) 475 | 476 | (* A body of helper functions for constructing DStrProg terms, 477 | as well as a standard library of types (like list) and functions (like map, join). *) 478 | module Prelude = struct 479 | open DStrLit 480 | open DStrProg 481 | 482 | let app1 f x = _App f x 483 | let app2 f x y = _App (_App f x) y 484 | let app3 f x y z = _App (_App (_App f x) y) z 485 | 486 | let tyapp1 f x = _TyApp f x 487 | let tyapp2 f x y = _TyApp (_TyApp f x) y 488 | 489 | let lam1 x t e = _Lambda x t e 490 | let lam2 x t1 y t2 e = _Lambda x t1 (_Lambda y t2 e) 491 | let lam3 x t1 y t2 z t3 e = _Lambda x t1 (_Lambda y t2 (_Lambda z t3 e)) 492 | 493 | let tylam1 x e = _TyLambda x e 494 | let tylam2 x y e = _TyLambda x (_TyLambda y e) 495 | 496 | let tya = mktfree "a" 497 | let tva = _TVar tya 498 | let tyb = mktfree "b" 499 | let tvb = _TVar tyb 500 | 501 | let eunit = _Unit 502 | 503 | let tybool = _TSum _TUnit _TUnit 504 | let false_ = _Inject Right tybool eunit 505 | let true_ = _Inject Left tybool eunit 506 | let ignore = mkefree "_" 507 | let if_ expr then_ else_ = _Case expr ignore then_ ignore else_ 508 | 509 | let tylist = mktfree "list" 510 | let tylist t = _TRec tylist (_TSum _TUnit (_TProd t (_TVar tylist))) 511 | let tylistbody t = _TSum _TUnit (_TProd t (tylist t)) 512 | 513 | let vnil = mkefree "nil" 514 | let enil = _TyLambda tya (_Fold (tylist tva) (_Inject Left (tylistbody tva) eunit)) 515 | let nil t = tyapp1 enil t 516 | 517 | let x = mkefree "x" 518 | let y = mkefree "y" 519 | let f = mkefree "f" 520 | let l = mkefree "l" 521 | let z = mkefree "z" 522 | let xs = mkefree "xs" 523 | let econs = 524 | tylam1 tya ( 525 | lam2 x tva y (tylist tva) 526 | (_Fold (tylist tva) (_Inject Right (tylistbody tva) (_Pair (_Var x) (_Var y))))) 527 | let vcons = mkefree "cons" 528 | let cons a = app2 (tyapp1 econs a) 529 | 530 | let vfold = mkefree "fold" 531 | 532 | let efold = 533 | let fty = _TFun tva (_TFun tvb tvb) in 534 | let ty = _TFun fty (_TFun tvb (_TFun (tylist tva) tvb)) in 535 | let cell = mkefree "cell" in 536 | tylam2 tya tyb 537 | (_Fix vfold ty 538 | (lam3 f fty z tvb l (tylist tva) 539 | (_Case 540 | (_Unfold (tylist tva) (_Var l)) 541 | ignore (_Var z) 542 | cell 543 | (app2 (_Var f) 544 | (_Project (_Var cell) Left) 545 | (app3 (_Var vfold) 546 | (_Var f) 547 | (_Var z) 548 | (_Project (_Var cell) Right)))))) 549 | 550 | let fold a b = app3 (tyapp2 (_Var vfold) a b) 551 | 552 | let vappend = mkefree "append" 553 | let eappend = tylam1 tya (lam2 x (tylist tva) y (tylist tva) ( 554 | fold tva (tylist tva) (tyapp1 (_Var vcons) tva) 555 | (_Var y) 556 | (_Var x) 557 | )) 558 | let vflatten = mkefree "flatten" 559 | let eflatten = tylam1 tya (lam1 x (tylist (tylist tva)) ( 560 | fold (tylist tva) (tylist tva) 561 | (tyapp1 (_Var vappend) tva) 562 | (nil tva) 563 | (_Var x) 564 | )) 565 | let vforeach = mkefree "foreach" 566 | let eforeach = tylam2 tya tyb (lam2 f (_TFun tva tvb) l (tylist tva) ( 567 | fold tva (tylist tvb) 568 | (lam2 x tva xs (tylist tvb) 569 | (cons tvb (app1 (_Var f) (_Var x)) (_Var xs))) 570 | (nil tvb) 571 | (_Var l) 572 | )) 573 | 574 | let vjoin = mkefree "join" 575 | let ejoin = lam1 l (tylist _TString) ( 576 | fold _TString _TString 577 | (lam2 x _TString y _TString (_Concat (_Var x) (_Var y))) 578 | (_EString "") 579 | (_Var l) 580 | ) 581 | 582 | let prelude = [ 583 | (vnil, enil); 584 | (vcons, econs); 585 | (vfold, efold); 586 | (vappend, eappend); 587 | (vflatten, eflatten); 588 | (vforeach, eforeach); 589 | (vjoin, ejoin) 590 | ] 591 | 592 | let join = app1 (_Var vjoin) 593 | let append a = app2 (tyapp1 (_Var vappend) a) 594 | let flatten a = app1 (tyapp1 (_Var vflatten) a) 595 | let foreach a b = app2 (tyapp2 (_Var vforeach) a b) 596 | let list a l = List.fold_right (cons a) l (nil a) 597 | 598 | let with_prelude e = List.fold_right (fun (v, f) e -> _Let v f e) prelude e 599 | let desugar_with_prelude e = with_prelude (Expr.desugar (unbox e)) 600 | end 601 | 602 | (* D^String_TLit level of the document calculus. 603 | Adds the simplest kind of template: string template literals. *) 604 | module DStrTLit = struct 605 | open DStrLit 606 | open Prelude 607 | 608 | (* A template is composed of parts. The base parts are strings and expressions. 609 | Note that Template.t = Template.part list. *) 610 | type Template.part += 611 | | TplStr of string 612 | | TplExpr of Expr.t 613 | 614 | (* A template is embedded within a string template expression. *) 615 | type Expr.t += 616 | | StrTmpl of Template.t 617 | 618 | (* The kind of template being type-checked is added to the type context. 619 | For now we just have string templates, but later we will add trees. *) 620 | type Type.ctx_elem += 621 | | TplCtx of Type.t box 622 | 623 | (* Bindlib constructors for each syntax element. *) 624 | let _TplStr s = box (TplStr s) 625 | let _TplExpr = box_apply (fun e -> TplExpr e) 626 | 627 | let _StrTmpl = box_apply (fun t -> StrTmpl t) 628 | 629 | (* These desugaring functions define the semantics of templates 630 | by translating them into the core expression language. *) 631 | 632 | (* A template desugars to a list of its desugared parts. 633 | This is specifically NOT implemented with a List.map because 634 | some template parts (like set-bindings) do not appear as values. *) 635 | let desugar_template (t_tcx, tpl) = match tpl with 636 | | [] -> nil (Type.lift t_tcx) 637 | | lt :: lts -> Template.desugar_in_context (t_tcx, lt, lts) 638 | 639 | (* The baseline inductive case is that {|p :: ps|} -> {|p|} :: {|ps|}. *) 640 | let desugar_tpart_in_context (t_tcx, p, ps) = 641 | cons (Type.lift t_tcx) (Template.desugar_part (t_tcx, p)) (desugar_template (t_tcx, ps)) 642 | 643 | let desugar_tpart (t_tcx, p) = match (t_tcx, p) with 644 | (* A template string desugars into a plain string 645 | when in the context of a string template.*) 646 | | (TString, TplStr s) -> _EString s 647 | (* An expression is just recursively desugared. *) 648 | | (_, TplExpr e) -> Expr.desugar e 649 | 650 | (* When embedded into an expression, a string template is desugared 651 | by wrapping it in a join to convert the list into a string. *) 652 | let desugar_expr = function 653 | | StrTmpl t -> join (desugar_template (TString, t)) 654 | 655 | (* Finds the current template context in the type context. *) 656 | let ctx_tpl_ty ctx = List.find_map 657 | (fun elem -> match elem with TplCtx t -> Some t | _ -> None) 658 | ctx |> Option.get 659 | 660 | (* Typechecking is defined in a similar style as desugaring. *) 661 | let typecheck_template (ctx, tpl) = 662 | let t_tcx = ctx_tpl_ty ctx in 663 | match tpl with 664 | (* A template should desugar to a term of type `ty list` 665 | where `ty` comes from the template context. *) 666 | | [] -> tylist t_tcx 667 | | p :: ps -> Template.typecheck_in_context (ctx, p, ps) 668 | 669 | let typecheck_tpart (ctx, p) = 670 | let t_tcx = ctx_tpl_ty ctx in 671 | match p with 672 | (* The type of template strings is determined by context. *) 673 | | TplStr _ -> t_tcx 674 | (* The type of interpolated expressions must match the context. *) 675 | | TplExpr e -> 676 | if Type.eq (unbox (Expr.typecheck (ctx, e))) (unbox t_tcx) then t_tcx 677 | else raise (Type_error "typecheck_tpart") 678 | 679 | (* Template parts should have the same type as the template list type. *) 680 | let typecheck_tpart_in_context (ctx, p, ps) = 681 | let t_tcx = ctx_tpl_ty ctx in 682 | if Type.eq (unbox (Template.typecheck_part (ctx, p))) (unbox t_tcx) then typecheck_template (ctx, ps) 683 | else raise (Type_error "typecheck_tpart_in_context") 684 | 685 | let typecheck (ctx, e) = match e with 686 | (* String templates should desugar to terms of type `string list`. *) 687 | | StrTmpl tpl -> 688 | let t = typecheck_template (TplCtx _TString :: ctx, tpl) in 689 | if Type.unbox_eq t (tylist _TString) then _TString 690 | else raise (Type_error "typecheck") 691 | 692 | (* Boring code. *) 693 | 694 | let lift_part = function 695 | | TplStr s -> _TplStr s 696 | | TplExpr e -> _TplExpr (Expr.lift e) 697 | 698 | let eval = function 699 | | StrTmpl _ -> raise Not_desugared 700 | 701 | let lift_expr = function 702 | | StrTmpl _ -> raise Not_desugared 703 | 704 | let subst_expr (_, _, e2) = match e2 with 705 | | StrTmpl _ -> raise Not_desugared 706 | 707 | let show_ttext kt = (Stdlib.String.concat "" (List.map Template.show kt)) 708 | 709 | let show_expr (_ctx, e) = match e with 710 | | StrTmpl kt -> Printf.sprintf "`%s`" (show_ttext kt) 711 | 712 | let eq_expr = function 713 | | (StrTmpl _, _) | (_, StrTmpl _) -> raise Not_desugared 714 | 715 | let show_template = function 716 | | TplStr s -> s 717 | | TplExpr e -> Printf.sprintf "{%s}" (Expr.show e) 718 | end 719 | 720 | let register_dstrtlit () = 721 | Expr.register (module DStrTLit); 722 | Template.register (module DStrTLit) 723 | 724 | (* D^String_TProg level of the document calculus. 725 | Adds set, foreach, if, and splice as template parts. 726 | Implements the splicing-based approach to handling nested lists. *) 727 | module DStrTProg = struct 728 | open DStrProg 729 | open DStrTLit 730 | open Prelude 731 | 732 | type Template.part += 733 | (* Note that we cannot use a Bindlib binder for TplSet because the terms 734 | bound under the TplSet are adjacent to, not under, the set-binding. *) 735 | | TplSet of Expr.var * Expr.t 736 | (* But we can express the binding structure of TplForeach. *) 737 | | TplForeach of Expr.t * Type.t * Expr.t Template.binder 738 | | TplIf of Expr.t * Template.t * Template.t 739 | | TplSplice of Expr.t 740 | 741 | (* Smart constructors for Bindlib. *) 742 | let _TplSet : Expr.var -> Expr.t box -> Template.part box = 743 | fun x -> box_apply (fun e -> TplSet (x, e)) 744 | let _TplForeach : Expr.t box -> Type.t box -> Expr.var -> Template.t box -> Template.part box = 745 | fun e xty x t -> box_apply3 (fun e xty t -> TplForeach (e, xty, t)) e xty (bind_var x t) 746 | let _TplIf : Expr.t box -> Template.t box -> Template.t box -> Template.part box = 747 | box_apply3 (fun e t1 t2 -> TplIf (e, t1, t2)) 748 | let _TplSplice : Expr.t box -> Template.part box = 749 | box_apply (fun e -> TplSplice e) 750 | 751 | (* The desugaring as described in Section 3.1.4 of the paper. *) 752 | let desugar_tpart_in_context (t_tcx, p, ps) = match p with 753 | (* {| set x = e; ...ps |} --> let x = e in {| ps |} *) 754 | | TplSet (x, e) -> 755 | _Let x (Expr.desugar e) (desugar_template (t_tcx, ps)) 756 | 757 | (* {| splice e; ...ps |} --> e @ {| ps |} *) 758 | | TplSplice e -> 759 | append (Type.lift t_tcx) (Expr.desugar e) (desugar_template (t_tcx, ps)) 760 | 761 | (* Note that foreach/if desugarings are context-insensitive *except* that they desugar 762 | to a splice, which *is* context-sensitive. *) 763 | 764 | (* {| T-foreach e : t . tpl |} --> splice (E-foreach e : t . splice {| tpl |}) *) 765 | | TplForeach (e, t, tpl) -> 766 | let (x, tpl) = unbind tpl in 767 | let t' = 768 | _TplSplice ( 769 | flatten (Type.lift t_tcx) 770 | (foreach (Type.lift t) (tylist (Type.lift t_tcx)) 771 | (lam1 x (Type.lift t) (desugar_template (t_tcx, tpl))) 772 | (Expr.desugar e))) in 773 | Template.desugar_in_context (t_tcx, unbox t', ps) 774 | 775 | (* {| T-if e { tpl1 } else { tpl2 } |} --> E-if e { {| tpl1 |} else { {| tpl2 |} }*) 776 | | TplIf (e, tpl1, tpl2) -> 777 | let tpl' = _TplSplice ( 778 | if_ (Expr.desugar e) 779 | (desugar_template (t_tcx, tpl1)) 780 | (desugar_template (t_tcx, tpl2))) in 781 | Template.desugar_in_context (t_tcx, unbox tpl', ps) 782 | 783 | (* The typing judgment as described in Section 5.1 of the paper. *) 784 | let typecheck_tpart_in_context (ctx, p, ps) = 785 | let t_tcx = ctx_tpl_ty ctx in 786 | match p with 787 | | TplSet (x, e) -> 788 | let ety = Expr.typecheck (ctx, e) in 789 | typecheck_template (BoundVar (x, ety) :: ctx, ps) 790 | | TplSplice e -> 791 | let ety = Expr.typecheck (ctx, e) in 792 | if Type.unbox_eq ety (tylist t_tcx) then typecheck_template (ctx, ps) 793 | else raise (Type_error "typecheck_tpart_in_context") 794 | | TplForeach (e, t, tpl) -> 795 | let (x, tpl) = unbind tpl in 796 | let t_e = Expr.typecheck (ctx, e) in 797 | let t' = typecheck_template (BoundVar (x, (Type.lift t)) :: ctx, tpl) in 798 | if Type.unbox_eq t_e (tylist (Type.lift t)) && 799 | Type.unbox_eq t' (tylist t_tcx) 800 | then typecheck_template (ctx, ps) 801 | else raise (Type_error "typecheck_tpart_in_context") 802 | | TplIf (e, tpl1, tpl2) -> 803 | let t_e = Expr.typecheck (ctx, e) in 804 | let t1' = typecheck_template (ctx, tpl1) in 805 | let t2' = typecheck_template (ctx, tpl2) in 806 | if Type.unbox_eq t_e tybool && 807 | Type.unbox_eq t1' (tylist t_tcx) && 808 | Type.unbox_eq t2' (tylist t_tcx) 809 | then typecheck_template (ctx, ps) 810 | else raise (Type_error "typecheck_tpart_in_context") 811 | 812 | (* Boring code. *) 813 | 814 | let show_template = function 815 | | TplForeach (e1, t, kt) -> 816 | let (x, kt) = unbind kt in 817 | Printf.sprintf "{{ foreach (%s : %s) in %s }} %s {{ endforeach }}" (name_of x) (Type.show t) (Expr.show e1) (show_ttext kt) 818 | | TplSet (x, e) -> Printf.sprintf "{{ %s = %s }}" (name_of x) (Expr.show e) 819 | | TplSplice e -> Printf.sprintf ",@%s" (Expr.show e) 820 | 821 | let lift_part = function 822 | | TplSet (x, e) -> _TplSet x (Expr.lift e) 823 | | TplForeach (e, t, kt) -> 824 | let (x, kt) = unbind kt in 825 | _TplForeach (Expr.lift e) (Type.lift t) x (Template.lift kt) 826 | | TplIf (e, t1, t2) -> _TplIf (Expr.lift e) (Template.lift t1) (Template.lift t2) 827 | | TplSplice e -> _TplSplice (Expr.lift e) 828 | 829 | let typecheck_tpart = Open_func.noop 830 | 831 | let desugar_tpart = Open_func.noop 832 | end 833 | 834 | let register_dstrtprog () = 835 | Template.register (module DStrTProg) --------------------------------------------------------------------------------