├── .gitignore ├── LICENSE.md ├── README.md ├── dune-project ├── dune-workspace.all ├── ppx ├── binding.ml ├── dune └── quasiquote.ml ├── ppx_stage.opam ├── runtime ├── compat.cppo.ml ├── dune ├── identMap.ml ├── internal.ml └── ppx_stage.ml └── test ├── dune ├── example.expected ├── example.ml ├── mod.expected ├── mod.ml ├── strymonas.ml ├── strymonas_example.expected └── strymonas_example.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | *.install 4 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Stephen Dolan 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | **`ppx_stage`** adds support for staged metaprogramming to OCaml, 2 | allowing type-safe generation, splicing and evaluation of bits of 3 | OCaml source code. `ppx_stage` is heavily inspired by 4 | [MetaOCaml](http://okmij.org/ftp/ML/MetaOCaml.html), and can run many 5 | of the same programs (albeit with a slightly different syntax for 6 | staging). See [test/strymonas.ml](test/strymonas.ml) for a large example. 7 | 8 | Install it with: 9 | 10 | opam pin add ppx_stage git://github.com/stedolan/ppx_stage.git 11 | 12 | After it's installed, you can load it into a standard OCaml toplevel: 13 | 14 | #use "topfind";; 15 | #require "ppx_stage.ppx";; 16 | 17 | `ppx_stage` doesn't need a special compiler switch - it's compatible 18 | with any recent version of OCaml. 19 | 20 | Once it's loaded, you'll be able to use the `[%code ...]` syntax to 21 | construct program fragments: 22 | 23 | # let greeting = [%code print_string "Hello!\n"];; 24 | val greeting : unit Ppx_stage.code = {Ppx_stage.compute = ; source = } 25 | 26 | The default output's pretty ugly, so install a better printer before 27 | going any further: 28 | 29 | # #install_printer Ppx_stage.print;; 30 | # let greeting = [%code print_string "Hello!\n"];; 31 | val greeting : unit Ppx_stage.code = print_string "Hello!" 32 | 33 | Note that it hasn't printed `Hello!` yet: greeting is a value of type 34 | `unit Ppx_stage.code`, which means it's the source code of a program 35 | which, when run, returns `unit`. We can run the program with 36 | `Ppx_stage.run`, and then we'll see the message: 37 | 38 | # Ppx_stage.run greeting;; 39 | Hello! 40 | - : unit = () 41 | 42 | You can think of `[%code ...]` as being like `fun () -> ...`, 43 | producing a value which represents a block of code that has not yet 44 | been run. There are two important differences: first, we can access the 45 | source code of programs built with `[%code ...]` (using `Ppx_stage.print` 46 | to pretty-print it, or using `Ppx_stage.to_parsetree` to get the 47 | raw syntax tree). Secondly, we can splice multiple blocks of code 48 | together using *escapes*. 49 | 50 | 51 | ## Splicing and escapes 52 | 53 | Inside `[%code ...]` blocks, the syntax `[%e ...]` lets you splice in 54 | a piece of code into the middle of a template. For example: 55 | 56 | # let two = [%code 2];; 57 | val two : int Ppx_stage.code = 2 58 | # let three = [%code 1 + [%e two]];; 59 | val three : int Ppx_stage.code = 1 + 2 60 | 61 | The escapes `[%e ...]` (sometimes known as "antiquotations") take a 62 | value of type `'a code`, and splice it into a surrounding piece of 63 | code as an `'a`. 64 | 65 | The expression in the `[%e ...]` is run once, while the program is 66 | being generated, and doesn't form part of the generated code. This 67 | will make more sense with an example: 68 | 69 | # let random_number_code () = Ppx_stage.Lift.int (Random.int 100);; 70 | 71 | Here, `random_number_code ()` produces source code for a random 72 | number, by using `Ppx_stage.Lift.int` to turn an `int` into an `int 73 | code` (Unlike MetaOCaml, `ppx_stage` does not automatically let `'a` 74 | be turned into `'a code` - values from the host program have to be 75 | explicitly lifted if they are used in the generated program). 76 | 77 | We can use escapes to splice `random_number_code ()` into a bigger 78 | program: 79 | 80 | # let p = [%code 2 * [%e random_number_code ()]];; 81 | val p : int Ppx_stage.code = 2 * 17 82 | 83 | When `[%code 2 * [%e random_number_code ()]]` was evaluated, OCaml 84 | first evaluated `random_number_code ()` (which this time returned 85 | `[%code 17]`), and then spliced that into `[%code 2 * [%e ...]]` 86 | giving `[%code 2 * 17]`. The call to `random_number_code ()` isn't 87 | part of `p`: the source code of `p` is the program `2 * 17`, and every 88 | time it runs it produces the same value: 89 | 90 | # Ppx_stage.run p;; 91 | - : int = 34 92 | # Ppx_stage.run p;; 93 | - : int = 34 94 | 95 | We can generate a new program by rerunning `random_number_code ()`: 96 | 97 | # let q = [%code 2 * [%e random_number_code ()]];; 98 | val q : int Ppx_stage.code = 2 * 85 99 | 100 | This second call to `random_number_code ()` returned a different 101 | value, but again `q` returns the same value every time it is run: 102 | 103 | # Ppx_stage.run q;; 104 | - : int = 170 105 | # Ppx_stage.run q;; 106 | - : int = 170 107 | 108 | 109 | ## Binding 110 | 111 | The scopes of variables in stage programs extend into nested escapes 112 | and `[%code ...]` blocks, which is surprisingly useful. Below is a 113 | staged version of `List.map`: 114 | 115 | ``` ocaml 116 | let map f = [%code 117 | let rec go = function 118 | | [] -> [] 119 | | x :: xs -> [%e f [%code x]] :: go xs in 120 | go] 121 | ``` 122 | 123 | The tricky part here is `f [%code x]`: the `x` being passed to `f` 124 | refers to the `x` that was bound by `x :: xs` in the enclosing `[%code 125 | ...]` block. 126 | 127 | The type of this function is worth a close look: 128 | 129 | ``` ocaml 130 | val map : 131 | ('a Ppx_stage.code -> 'b Ppx_stage.code) -> 132 | ('a list -> 'b list) Ppx_stage.code = 133 | ``` 134 | 135 | `map` takes a function from `'a code` to `'b code`, and returns code 136 | for a function from `'a list` to `'b list`. So, the `f` that we pass 137 | to `map` is given code for the current element of the list, and 138 | returns code for its replacement. We can write such an `f` using splicing: 139 | 140 | ``` ocaml 141 | let plus1 x = [%code [%e x] + 1] 142 | ``` 143 | 144 | Then, `map plus1` splices `plus1` into `go`, giving this code: 145 | 146 | ``` ocaml 147 | # map plus1;; 148 | - : (int list -> int list) Ppx_stage.code = 149 | let rec go = function | [] -> [] | x::xs -> (x + 1) :: (go xs) in go 150 | ``` 151 | 152 | This `map` isn't the standard `List.map` function - instead, it's a 153 | template that produces a specialised `map` function, when given the 154 | code for processing each element. 155 | 156 | This style can be used to write efficient libraries that generate 157 | optimised code. For a detailed example, read the paper [Stream Fusion, 158 | to Completeness](https://strymonas.github.io/) (by Oleg Kiselyov, 159 | Aggelos Biboudis, Nick Palladinos and Yannis Smaragdakis), or play 160 | with [their MetaOCaml 161 | library](https://github.com/strymonas/staged-streams.ocaml) or [a port 162 | of it to `ppx_stage`](test/strymonas.ml). 163 | 164 | Code written in this style tends to involve writing many functions 165 | like `plus1`, which map code for a value to code for a result. To make 166 | them a bit less syntactically noisy, `ppx_stage` supports `fun%staged` 167 | as syntactic sugar for the combination of `[%code ...]` and `[%e 168 | ...]`, allowing: 169 | 170 | map (fun%staged x -> x + 1) 171 | 172 | 173 | ## Typing and hygiene 174 | 175 | So far, most of what's been described here could be accomplished with 176 | horrible string concatenation trickery. Two aspects of `ppx_stage` 177 | require a bit more, though: typing and hygiene. 178 | 179 | First, all `[%code ...]` and `[%e ...]` blocks are statically typed: a 180 | value of type `'a code` is the source code of a program producing 181 | `'a`, and if the original program passes the OCaml typechecker, then 182 | it cannot generate ill-typed code. Instead of modifying the 183 | typechecker, this is accomplished by translating each `[%code ...]` 184 | block into a pair of expressions: the first is the body (the `...`), 185 | unmodified except for `[%e ...]` escapes, and the second is code that 186 | produces a syntax tree for the body given syntax trees for the 187 | escapes. This translation is untyped, but by ensuring both half of the 188 | pair represent the same code, we know that if the first passes the 189 | OCaml typechecker then the second generates type-correct code. 190 | 191 | The second issue is hygiene: under certain circumstances, `ppx_stage` 192 | may need to rename variables to prevent undesired shadowing. For 193 | instance, suppose we have a function that produces constant functions 194 | (that is, functions that ignore their argument): 195 | 196 | ``` ocaml 197 | let const v = [%code fun x -> [%e v]] 198 | ``` 199 | 200 | Now suppose we use this as `[%code fun x -> [%e const [%code x]]]`. If 201 | we were to just splice strings together, we might end up with: 202 | 203 | fun x -> fun x -> x 204 | 205 | which is wrong: the variable `x` at the end should refer to the outer 206 | binder, not the one introduced by `const`. Instead, `ppx_stage` 207 | generates this code: 208 | 209 | fun x -> let x''1 = x in fun x -> x''1 210 | 211 | which introduces an alias `x''1` for `x` so that it can be referred to 212 | even when `x` is shadowed. 213 | 214 | ## Polymorphism 215 | 216 | Because of how `ppx_stage` implements staging, some of the usual 217 | difficulties in staging polymorphic functions are avoided. Code like 218 | this works as expected: 219 | 220 | ``` ocaml 221 | # [%code let id x = x in (id 1, id "foo")];; 222 | - : (int * string) Ppx_stage.code = 223 | let id x = x in ((id 1), (id "foo")) 224 | ``` 225 | 226 | There are two subtle restrictions on polymorphism. First, variables bound in 227 | staged programs have monomorphic types in nested `[%code ...]` 228 | expressions. For instance, this code won't compile: 229 | 230 | ``` ocaml 231 | # fun f -> [%code let id x = x in [%e f [%code (id 1, id "foo")]]];; 232 | Error: This expression has type string but an expression was expected of type 233 | int 234 | ``` 235 | 236 | The function `id` is polymorphic, but the use of `id` in the nested 237 | `[%code ...]` block must be monomorphic. 238 | 239 | Second, since splices are translated to applications, code generated 240 | from splices is subject to the (relaxed) value restriction. For 241 | example, the following code is given a non-polymorphic type: 242 | 243 | ```ocaml 244 | # [%code fun x -> [%e [%code x]]];; 245 | - : ('_a -> '_a) Ppx_stage.code = fun x -> x 246 | ``` 247 | 248 | 249 | ## Modules and functors 250 | 251 | *(Support for staged modules and functors is even more experimental 252 | than the rest of `ppx_stage`. Expect breaking changes.)* 253 | 254 | By default, modules definitions are not in scope in `[%code ...]` 255 | blocks and do not appear in staged programs, so the following gives a 256 | type error: 257 | 258 | ``` ocaml 259 | module M : sig 260 | val x : int 261 | end = struct 262 | let x = 42 263 | end 264 | let foo y = [%code M.x + [%e y]] (* Error: M.x not in scope *) 265 | ``` 266 | 267 | To make the definition of `M.x` visible in the staged program, we need 268 | to annotate the module binding, its signature and its definition: 269 | 270 | ``` ocaml 271 | module%code M : sig[@code] 272 | val x : int 273 | end = struct[@code] 274 | let x = 42 275 | end 276 | let foo y = [%code M.x + [%e y]] (* works *) 277 | ``` 278 | 279 | When we print e.g. `foo [%code 10]`, the output will include any 280 | staged module definitions that the result depends on: 281 | 282 | ``` ocaml 283 | module M'1 = struct let x = 42 end 284 | let _ = M'1.x + 10 285 | ``` 286 | 287 | Here, the module `M` has been renamed to `M'1`. In this example, the 288 | renaming is not terribly helpful, but in general the renaming is 289 | necessary to prevent multiple staged modules with the same name being 290 | confused. 291 | 292 | For programs using modules to group and namespace related definitions, 293 | staging just means adding `%code` to module bindings and `[@code]` to 294 | structures (and signatures, if present). To write more advanced staged 295 | programs (e.g. using functors), you need to understand what the 296 | separate annotations do. 297 | 298 | A *staged module* is a module annotated with `[@code]`, which 299 | instructs `ppx_stage` to record the source code as well as the 300 | contents of the module, just like `[%code ...]` does for 301 | expressions. Staged modules have staged signatures, which are also 302 | written with [@code], so we can write: 303 | 304 | ``` 305 | module Staged : sig[@code] 306 | val x : int 307 | end = struct[@code] 308 | let x = 42 309 | end 310 | ``` 311 | 312 | We get a type error if only one of the `[@code]` annotations is 313 | present: staged signatures are different from their unstaged 314 | counterparts. 315 | 316 | A staged module is not automatically made available to staged 317 | expressions using `[%code ...]`. Instead, it must be explicitly 318 | *exported* using the syntax `module%code`: 319 | 320 | ``` ocaml 321 | module%code M = Staged 322 | ``` 323 | 324 | Separating the construction and export of a staged module like this is 325 | important for writing code using functors, when a functor might export 326 | a staged module passed as a parameter. For instance: 327 | 328 | ``` ocaml 329 | module F (A : sig[@code] val x : int end) = struct 330 | module%code A = A 331 | let bigger = [%code A.x + 1] 332 | end 333 | module M = F (struct[@code] let x = 42 end) 334 | ``` 335 | 336 | Note that it is necessary to explicitly export `A` using 337 | `module%code`: functor arguments are not automatically exported, even 338 | if they have staged signatures. 339 | 340 | Printing `M.bigger` produces the following output: 341 | 342 | ``` ocaml 343 | module A'1 = struct let x = 42 end 344 | let _ = A'1.x + 1 345 | ``` 346 | 347 | As well as definitions, functor applications can be staged with 348 | `[@code]`. For instance, this functor accepts a staged module of 349 | signature `Map.OrderedType` and builds a map with that key type: 350 | 351 | ``` ocaml 352 | module MkMap (Key : Map.OrderedType[@code]) = struct 353 | module%code Key = Key 354 | module%code KMap = Map.Make (Key) [@code] 355 | let singleton k v = [%code KMap.singleton [%e k] [%e v]] 356 | end 357 | module StringMap = 358 | MkMap (struct[@code] type t = string let compare = compare end) 359 | ``` 360 | 361 | Printing `StringMap.singleton [%code "hello"] [%code 5]` gives: 362 | 363 | ``` ocaml 364 | module Key'1 = struct type t = string 365 | let compare = compare end 366 | module KMap'1 = (Map.Make)(Key'1) 367 | let _ = KMap'1.singleton "hello" 5 368 | ``` 369 | 370 | 371 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (name ppx_stage) 3 | -------------------------------------------------------------------------------- /dune-workspace.all: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | (context (opam (switch 4.08.1))) 3 | (context (opam (switch 4.09.0))) 4 | (context (opam (switch 4.10.0))) 5 | (context (opam (switch 4.11.1) (merlin))) 6 | -------------------------------------------------------------------------------- /ppx/binding.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree 2 | open Ast_408 3 | 4 | open Asttypes 5 | open Parsetree 6 | open Ast_helper 7 | 8 | type binding_site = Binder of int | Context of int 9 | 10 | module IdentMap = Ppx_stage.IdentMap 11 | type scope = binding_site IdentMap.t 12 | 13 | type hole = int 14 | 15 | type analysis_env = { 16 | bindings : scope; 17 | fresh_binder : unit -> binding_site; 18 | fresh_hole : unit -> hole; 19 | hole_table : (hole, scope * expression) Hashtbl.t 20 | } 21 | 22 | let rec analyse_exp env exp = 23 | analyse_attributes exp.pexp_attributes; 24 | { exp with pexp_desc = analyse_exp_desc env exp.pexp_loc exp.pexp_desc } 25 | 26 | and analyse_exp_desc env loc = function 27 | | Pexp_extension ({txt = "e"; loc}, code) -> 28 | let code = 29 | match code with 30 | | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> 31 | e 32 | | _ -> 33 | raise (Location.(Error (error ~loc ("[%e] expects an expression")))) in 34 | let h = env.fresh_hole () in 35 | Hashtbl.add env.hole_table h (env.bindings, code); 36 | Pexp_ident { txt = Lident ("," ^ string_of_int h); loc } 37 | | Pexp_ident { txt = Lident id; loc } as e -> 38 | begin match IdentMap.find id env.bindings with 39 | | Context c -> 40 | Pexp_ident { txt = Lident (";" ^ string_of_int c); loc } 41 | | Binder _ -> e 42 | | exception Not_found -> e 43 | end 44 | | Pexp_ident { txt = (Ldot _ | Lapply _); _ } as e -> e 45 | | Pexp_constant _ as e -> e 46 | | Pexp_let (isrec, vbs, body) -> 47 | let env' = List.fold_left (fun env {pvb_pat; _} -> 48 | analyse_pat env pvb_pat) env vbs in 49 | let bindings_env = 50 | match isrec with Recursive -> env' | Nonrecursive -> env in 51 | Pexp_let 52 | (isrec, 53 | vbs |> List.map (fun vb -> 54 | analyse_attributes vb.pvb_attributes; 55 | { vb with pvb_expr = analyse_exp bindings_env vb.pvb_expr }), 56 | analyse_exp env' body) 57 | | Pexp_function cases -> 58 | Pexp_function (List.map (analyse_case env) cases) 59 | | Pexp_fun (lbl, opt, pat, body) -> 60 | let env' = analyse_pat env pat in 61 | Pexp_fun (lbl, analyse_exp_opt env opt, pat, analyse_exp env' body) 62 | | Pexp_apply (fn, args) -> 63 | Pexp_apply 64 | (analyse_exp env fn, 65 | args |> List.map (fun (lbl, e) -> lbl, analyse_exp env e)) 66 | | Pexp_match (exp, cases) -> 67 | Pexp_match 68 | (analyse_exp env exp, 69 | List.map (analyse_case env) cases) 70 | | Pexp_try (exp, cases) -> 71 | Pexp_try 72 | (analyse_exp env exp, 73 | List.map (analyse_case env) cases) 74 | | Pexp_tuple exps -> 75 | Pexp_tuple (List.map (analyse_exp env) exps) 76 | | Pexp_construct (ctor, exp) -> 77 | Pexp_construct (ctor, analyse_exp_opt env exp) 78 | | Pexp_variant (lbl, exp) -> 79 | Pexp_variant (lbl, analyse_exp_opt env exp) 80 | | Pexp_record (fields, base) -> 81 | Pexp_record (List.map (fun (l, e) -> l, analyse_exp env e) fields, analyse_exp_opt env base) 82 | | Pexp_field (e, field) -> 83 | Pexp_field (analyse_exp env e, field) 84 | | Pexp_setfield (e, field, v) -> 85 | Pexp_setfield (analyse_exp env e, field, analyse_exp env v) 86 | | Pexp_array exps -> 87 | Pexp_array (List.map (analyse_exp env) exps) 88 | | Pexp_ifthenelse (cond, ift, iff) -> 89 | Pexp_ifthenelse (analyse_exp env cond, analyse_exp env ift, analyse_exp_opt env iff) 90 | | Pexp_sequence (e1, e2) -> 91 | Pexp_sequence (analyse_exp env e1, analyse_exp env e2) 92 | | Pexp_while (cond, body) -> 93 | Pexp_while (analyse_exp env cond, analyse_exp env body) 94 | | Pexp_for (pat, e1, e2, dir, body) -> 95 | let env' = analyse_pat env pat in 96 | Pexp_for (pat, analyse_exp env e1, analyse_exp env e2, dir, analyse_exp env' body) 97 | (* several missing... *) 98 | 99 | 100 | | _ -> raise (Location.(Error (error ~loc ("expression not supported in staged code")))) 101 | 102 | and analyse_exp_opt env = function 103 | | None -> None 104 | | Some e -> Some (analyse_exp env e) 105 | 106 | and analyse_pat env pat = 107 | analyse_attributes pat.ppat_attributes; 108 | analyse_pat_desc env pat.ppat_loc pat.ppat_desc 109 | 110 | and analyse_pat_desc env loc = function 111 | | Ppat_any -> env 112 | | Ppat_var v -> analyse_pat_desc env loc (Ppat_alias (Pat.any (), v)) 113 | | Ppat_alias (pat, v) -> 114 | let env = analyse_pat env pat in 115 | { env with bindings = IdentMap.add v.txt (env.fresh_binder ()) env.bindings } 116 | | Ppat_constant _ -> env 117 | | Ppat_interval _ -> env 118 | | Ppat_tuple pats -> List.fold_left analyse_pat env pats 119 | | Ppat_construct (_loc, None) -> env 120 | | Ppat_construct (_loc, Some pat) -> analyse_pat env pat 121 | | _ -> raise (Location.(Error (error ~loc ("pattern not supported in staged code")))) 122 | 123 | and analyse_case env {pc_lhs; pc_guard; pc_rhs} = 124 | let env' = analyse_pat env pc_lhs in 125 | { pc_lhs; 126 | pc_guard = analyse_exp_opt env' pc_guard; 127 | pc_rhs = analyse_exp env' pc_rhs } 128 | 129 | and analyse_attributes = function 130 | | [] -> () 131 | | {attr_payload=PStr []; _} :: rest -> 132 | analyse_attributes rest 133 | | {attr_name={loc;txt}; _} :: _ -> 134 | raise (Location.(Error (error ~loc ("attribute " ^ txt ^ " not supported in staged code")))) 135 | 136 | 137 | let analyse_binders (context : int IdentMap.t) (e : expression) : 138 | expression * (hole, scope * expression) Hashtbl.t = 139 | let hole_table = Hashtbl.create 20 in 140 | let next_hole = ref 0 in 141 | let fresh_hole () = 142 | incr next_hole; 143 | !next_hole in 144 | let next_binder = ref 0 in 145 | let fresh_binder () = 146 | incr next_binder; 147 | Binder (!next_binder) in 148 | let bindings = IdentMap.map (fun c -> Context c) context in 149 | let e' = analyse_exp { bindings; fresh_binder; fresh_hole; hole_table } e in 150 | e', hole_table 151 | 152 | 153 | 154 | open Ast_mapper 155 | type substitutable = 156 | | SubstContext of int 157 | | SubstHole of int 158 | 159 | let substitute_holes (e : expression) (f : substitutable -> expression) = 160 | let expr mapper pexp = 161 | match pexp.pexp_desc with 162 | | Pexp_ident { txt = Lident v; loc = _ } -> 163 | let id () = int_of_string (String.sub v 1 (String.length v - 1)) in 164 | (match v.[0] with 165 | | ',' -> f (SubstHole (id ())) 166 | | ';' -> f (SubstContext (id ())) 167 | | _ -> pexp) 168 | | _ -> default_mapper.expr mapper pexp in 169 | let mapper = { default_mapper with expr } in 170 | mapper.expr mapper e 171 | 172 | 173 | let module_remapper f = 174 | let rename (id : Longident.t Location.loc) : Longident.t Location.loc = 175 | let rec go : Longident.t -> Longident.t = function 176 | | Lident id -> Lident (f id) 177 | | Ldot (id, x) -> Ldot (go id, x) 178 | | Lapply (idF, idX) -> Lapply (go idF, go idX) in 179 | {id with txt = go id.txt} in 180 | let open Parsetree in 181 | let open Ast_mapper in 182 | let rec expr mapper pexp = 183 | let pexp_desc = match pexp.pexp_desc with 184 | | Pexp_ident id -> 185 | Pexp_ident (rename id) 186 | | Pexp_construct (id, e) -> 187 | Pexp_construct (rename id, expr_opt mapper e) 188 | | Pexp_record (fs, e) -> 189 | let fs = List.map (fun (id, e) -> (rename id, expr mapper e)) fs in 190 | Pexp_record (fs, expr_opt mapper e) 191 | | Pexp_field (e, f) -> 192 | Pexp_field (expr mapper e, rename f) 193 | | Pexp_setfield (e, f, x) -> 194 | Pexp_setfield (expr mapper e, rename f, expr mapper x) 195 | | Pexp_new id -> 196 | Pexp_new (rename id) 197 | | Pexp_open (md, e) -> 198 | Pexp_open ({md with popen_expr = module_expr mapper md.popen_expr }, 199 | expr mapper e) 200 | | _ -> (default_mapper.expr mapper pexp).pexp_desc in 201 | { pexp with pexp_desc } 202 | and expr_opt mapper = function 203 | | None -> None 204 | | Some e -> Some (expr mapper e) 205 | and typ mapper ptyp = 206 | let ptyp_desc = match ptyp.ptyp_desc with 207 | | Ptyp_constr (id, tys) -> 208 | Ptyp_constr (rename id, List.map (typ mapper) tys) 209 | | Ptyp_class (id, tys) -> 210 | Ptyp_class (rename id, List.map (typ mapper) tys) 211 | | _ -> (default_mapper.typ mapper ptyp).ptyp_desc in 212 | { ptyp with ptyp_desc } 213 | and pat mapper ppat = 214 | let ppat_desc = match ppat.ppat_desc with 215 | | Ppat_construct (id, pat) -> 216 | Ppat_construct (rename id, pat_opt mapper pat) 217 | | Ppat_record (fs, flag) -> 218 | let fs = List.map (fun (id, p) -> (rename id, pat mapper p)) fs in 219 | Ppat_record (fs, flag) 220 | | Ppat_type id -> 221 | Ppat_type (rename id) 222 | | Ppat_open (id, p) -> 223 | Ppat_open (rename id, pat mapper p) 224 | | _ -> (default_mapper.pat mapper ppat).ppat_desc in 225 | { ppat with ppat_desc } 226 | and pat_opt mapper = function 227 | | None -> None 228 | | Some p -> Some (pat mapper p) 229 | and module_type mapper pmty = 230 | let pmty_desc = match pmty.pmty_desc with 231 | | Pmty_ident id -> Pmty_ident (rename id) 232 | | Pmty_alias id -> Pmty_alias (rename id) 233 | | _ -> (default_mapper.module_type mapper pmty).pmty_desc in 234 | { pmty with pmty_desc } 235 | and open_description _mapper op = 236 | { op with popen_expr = rename op.popen_expr } 237 | and module_expr mapper pmod = 238 | let pmod_desc = match pmod.pmod_desc with 239 | | Pmod_ident id -> Pmod_ident (rename id) 240 | | _ -> (default_mapper.module_expr mapper pmod).pmod_desc in 241 | { pmod with pmod_desc } 242 | in 243 | { default_mapper with expr; typ; pat; module_type; open_description; module_expr } 244 | -------------------------------------------------------------------------------- /ppx/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_stage_expander) 3 | (public_name ppx_stage.ppx) 4 | (kind ppx_rewriter) 5 | (ppx_runtime_libraries ppx_stage.runtime-lib) 6 | (preprocess 7 | (pps ppx_tools_versioned.metaquot_408)) 8 | (libraries ocaml-migrate-parsetree ppx_tools_versioned ppx_stage.runtime-lib)) 9 | -------------------------------------------------------------------------------- /ppx/quasiquote.ml: -------------------------------------------------------------------------------- 1 | open Migrate_parsetree 2 | 3 | open Ast_408 4 | 5 | open Asttypes 6 | open Parsetree 7 | open Ast_mapper 8 | open Ast_helper 9 | 10 | let mk_ident ?(loc=Location.none) name = 11 | let rec go = function 12 | | [] -> failwith "error: mk_ident []" 13 | | [x] -> Longident.Lident x 14 | | field :: rest -> Longident.Ldot(go rest, field) in 15 | { txt = go (List.rev name); loc } 16 | 17 | module IM = Ppx_stage.IdentMap 18 | 19 | module IntMap = Map.Make (struct type t = int let compare = compare end) 20 | 21 | module StrMap = Map.Make (struct type t = string let compare = compare end) 22 | 23 | type staged_defs = { 24 | modname : Longident.t; 25 | mutable def_list : structure_item list; 26 | mutable num_defs : int 27 | } 28 | 29 | let make_module_renamer names = 30 | Binding.module_remapper (fun s -> 31 | match StrMap.find s names with 32 | | s' -> s' 33 | | exception Not_found -> s) 34 | 35 | let rename_module names mexp = 36 | let m = make_module_renamer names in 37 | m.module_expr m mexp 38 | 39 | let add_structure_item defs s = 40 | defs.num_defs <- defs.num_defs + 1; 41 | defs.def_list <- s :: defs.def_list 42 | 43 | let add_definition defs exp = 44 | let id = defs.num_defs in 45 | defs.num_defs <- id + 1; 46 | let ident = "staged" ^ string_of_int id in 47 | let def = Str.value Nonrecursive [Vb.mk (Pat.var (Location.mknoloc ident)) exp] in 48 | defs.def_list <- def :: defs.def_list; 49 | Exp.ident (Location.mknoloc (Longident.Ldot (defs.modname, ident))) 50 | 51 | let add_defmodule defs (pmod : module_expr) : Parsetree.module_expr = 52 | let id = defs.num_defs in 53 | defs.num_defs <- id + 1; 54 | let ident = "Staged_" ^ string_of_int id in 55 | let def = Str.module_ (Mb.mk (Location.mknoloc ident) pmod) in 56 | defs.def_list <- def :: defs.def_list; 57 | Mod.ident (Location.mknoloc (Longident.Ldot (defs.modname, ident))) 58 | 59 | let collect_definitions defs = 60 | List.rev defs.def_list 61 | 62 | (* FIXME: context_vars assumes same names in staged and top program *) 63 | let rec quasiquote staged_defs modrenamer (context_vars : unit IM.t) _loc expr = 64 | let hole_name h = "hole''_" ^ string_of_int h in 65 | 66 | let context_var_list = 67 | context_vars 68 | |> IM.bindings 69 | |> List.mapi (fun i (name, ()) -> i, name) in 70 | 71 | let context_vars_by_name = 72 | List.fold_left (fun m (i, name) -> IM.add name i m) IM.empty context_var_list in 73 | let context_vars_by_id = 74 | List.fold_left (fun m (i, name) -> IntMap.add i name m) IntMap.empty 75 | context_var_list in 76 | 77 | let exp_with_holes, hole_table = 78 | Binding.analyse_binders context_vars_by_name expr in 79 | let hole_list = Hashtbl.fold (fun k _v ks -> k :: ks) hole_table [] |> List.sort compare in 80 | 81 | let binding_site_names = 82 | Hashtbl.fold (fun _hole (scope, _body) acc -> 83 | IM.fold (fun name site acc -> 84 | match site with 85 | | Binding.Binder site when IntMap.mem site acc -> 86 | (assert (IntMap.find site acc = name); acc) 87 | | Binding.Binder site -> 88 | IntMap.add site name acc 89 | | Binding.Context _ -> 90 | acc 91 | ) scope acc 92 | ) hole_table IntMap.empty in 93 | 94 | let binder_variable_name b = 95 | let name = IntMap.find b binding_site_names in 96 | name ^ "''b" ^ string_of_int b in 97 | 98 | let context_variable_name c = 99 | let name = IntMap.find c context_vars_by_id in 100 | name ^ "''v" ^ string_of_int c in 101 | 102 | let allocate_variables body = 103 | IntMap.fold (fun site name body -> 104 | [%expr let [%p Pat.var (Location.mknoloc (binder_variable_name site))] = Ppx_stage.Internal.fresh_variable [%e Exp.constant (Pconst_string (name, None))] in [%e body]] 105 | ) binding_site_names body in 106 | 107 | let hole_bindings_list h = 108 | let scope, _body = Hashtbl.find hole_table h in 109 | IM.fold (fun _name site acc -> site :: acc) scope [] in 110 | 111 | let contents_name h = 112 | "contents''_" ^ string_of_int h in 113 | 114 | let instantiate_holes body = 115 | List.fold_right (fun hole body -> 116 | let hole_args = 117 | hole_bindings_list hole 118 | |> List.map (function 119 | | Binding.Context _ -> [] 120 | | Binding.Binder b -> 121 | let vare = Exp.ident (mk_ident [binder_variable_name b]) in 122 | let code = [%expr { 123 | Ppx_stage.compute = (fun env -> Ppx_stage.Internal.compute_variable [%e vare] env); 124 | Ppx_stage.source = (fun ren modst -> Ppx_stage.Internal.source_variable [%e vare] ren) 125 | }] in 126 | [Nolabel, code]) 127 | |> List.concat in 128 | let hole_fn = Exp.ident (mk_ident [hole_name hole]) in 129 | let app = match hole_args with [] -> hole_fn | hole_args -> Exp.apply hole_fn hole_args in 130 | [%expr let [%p Pat.var (Location.mknoloc (contents_name hole))] = [%e app] in [%e body]] 131 | ) hole_list body in 132 | 133 | let exp_compute = 134 | Binding.substitute_holes exp_with_holes (function 135 | | SubstContext c -> 136 | (* It is safe to compute context variables in the original 137 | environment, since by definition they do not depend on 138 | recent binders *) 139 | [%expr [%e Exp.ident (mk_ident [context_variable_name c])].Ppx_stage.compute env''] 140 | | SubstHole h -> 141 | let env = 142 | List.fold_left 143 | (fun env (site : Binding.binding_site) -> 144 | match site with 145 | | Context _ -> 146 | (* already in environment *) 147 | env 148 | | Binder b -> 149 | [%expr Ppx_stage.Internal.Environ.add 150 | [%e env] 151 | [%e Exp.ident (mk_ident [binder_variable_name b])] 152 | [%e Exp.ident (mk_ident [IntMap.find b binding_site_names])]]) 153 | [%expr env''] 154 | (hole_bindings_list h) in 155 | [%expr [%e Exp.ident (mk_ident [contents_name h])].Ppx_stage.compute [%e env]]) in 156 | 157 | 158 | let exp_source = 159 | let binary = 160 | Versions.((migrate ocaml_408 ocaml_current).copy_expression exp_with_holes) 161 | |> fun x -> Marshal.to_string x [] in 162 | let marshalled = Exp.constant (Pconst_string (binary, None)) in 163 | let pat_int n = Pat.constant (Pconst_integer (string_of_int n, None)) in 164 | let context_cases = context_var_list |> List.map (fun (c, _name) -> 165 | Exp.case 166 | (Pat.construct 167 | (mk_ident ["Ppx_stage"; "Internal"; "SubstContext"]) 168 | (Some (pat_int c))) 169 | [%expr [%e Exp.ident (mk_ident [context_variable_name c])].Ppx_stage.source ren'' modst'']) in 170 | let hole_cases = hole_list |> List.map (fun h -> 171 | let ren = List.fold_left 172 | (fun exp (site : Binding.binding_site) -> 173 | match site with 174 | | Context _ -> 175 | (* already in environment *) 176 | exp 177 | | Binder b -> 178 | [%expr Ppx_stage.Internal.Renaming.with_renaming 179 | [%e Exp.ident (mk_ident [binder_variable_name b])] 180 | [%e exp]]) 181 | [%expr [%e Exp.ident (mk_ident [contents_name h])].Ppx_stage.source] 182 | (hole_bindings_list h) in 183 | Exp.case 184 | (Pat.construct 185 | (mk_ident ["Ppx_stage"; "Internal"; "SubstHole"]) 186 | (Some (pat_int h))) 187 | [%expr [%e ren] ren'' modst'']) in 188 | let cases = 189 | context_cases @ hole_cases 190 | @ [Exp.case (Pat.any ()) [%expr assert false]] in 191 | [%expr 192 | Ppx_stage.Internal.substitute_holes 193 | (Ppx_stage.Internal.rename_modules_in_exp modst'' modcontext''_ 194 | (Marshal.from_string [%e marshalled] 0)) 195 | [%e Exp.function_ cases]] in 196 | 197 | 198 | let staged_code = 199 | List.fold_right 200 | (fun (ctx, _) code -> 201 | [%expr fun [%p Pat.var (Location.mknoloc (context_variable_name ctx))] -> 202 | [%e code]]) 203 | context_var_list 204 | (List.fold_right 205 | (fun hole code -> 206 | [%expr fun [%p Pat.var (Location.mknoloc (hole_name hole))] -> 207 | [%e code]]) 208 | hole_list 209 | (allocate_variables 210 | (instantiate_holes 211 | [%expr { Ppx_stage.compute = (fun env'' -> [%e exp_compute]); 212 | Ppx_stage.source = (fun ren'' modst'' -> [%e exp_source]) }]))) in 213 | 214 | let staged_code = add_definition staged_defs (modrenamer.expr modrenamer staged_code) in 215 | 216 | let context_contents = 217 | context_var_list |> List.map (fun (_ctx, name) -> 218 | Nolabel, Exp.ident (mk_ident [name]) 219 | ) in 220 | 221 | let hole_contents = 222 | hole_list |> List.map (fun hole -> 223 | let rec gen_hole_body context_vars bindings body = 224 | match bindings with 225 | | [] -> quasiquote_subexps staged_defs modrenamer context_vars body 226 | | Binding.Context _ :: bindings -> 227 | (* context variables are already available *) 228 | gen_hole_body context_vars bindings body 229 | | Binding.Binder b :: bindings -> 230 | let name = IntMap.find b binding_site_names in 231 | gen_hole_body 232 | (IM.add name () context_vars) 233 | bindings 234 | [%expr fun [%p Pat.var (Location.mknoloc name)] -> [%e body]] in 235 | let (_scope, body) = Hashtbl.find hole_table hole in 236 | Nolabel, gen_hole_body context_vars (List.rev (hole_bindings_list hole)) body) in 237 | 238 | (match context_contents @ hole_contents with 239 | | [] -> staged_code 240 | | xs -> Exp.apply staged_code xs) 241 | 242 | and quasiquote_mapper staged_defs modrenamer context_vars = 243 | let expr mapper pexp = 244 | match pexp.pexp_desc with 245 | | Pexp_extension ({ txt = "code"; loc }, code) -> 246 | begin match code with 247 | | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> 248 | quasiquote staged_defs modrenamer context_vars loc e 249 | | _ -> 250 | raise (Location.(Error (error ~loc ("[%code] expects an expression")))) 251 | end 252 | | Pexp_extension ({ txt = "staged"; loc }, func) -> 253 | let rec go context_vars e = 254 | match e.pexp_desc with 255 | | Pexp_fun (lbl, 256 | opt, 257 | ({ ppat_desc = Ppat_var v; _ } as pat), 258 | body) -> 259 | Exp.fun_ ~loc:e.pexp_loc lbl opt pat 260 | (go (IM.add v.txt () context_vars) body) 261 | | Pexp_fun _ 262 | | Pexp_function _ -> 263 | raise (Location.(Error (error ~loc:e.pexp_loc ("only 'fun v ->' is supported in staged functions")))) 264 | | _ -> 265 | quasiquote staged_defs modrenamer context_vars loc e in 266 | begin match func with 267 | | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> 268 | go context_vars e 269 | | _ -> 270 | raise (Location.(Error (error ~loc ("fun%staged expects an expression")))) 271 | end 272 | 273 | | _ -> default_mapper.expr mapper pexp in 274 | 275 | let migrate_module_expr pmod = 276 | (* bit of a hack, o-m-p seems not to provide copy_module_expr *) 277 | let mig = 278 | Versions.((migrate ocaml_408 ocaml_current).copy_structure [Str.mk (Pstr_include (Incl.mk pmod))]) in 279 | match mig with 280 | | [{pstr_desc = Pstr_include m; _}] -> m.pincl_mod 281 | | _ -> failwith "modexpr migration failure" in 282 | 283 | let module_expr mapper = function 284 | (* FIXME: support signatures here *) 285 | | {pmod_attributes = [{attr_name={txt = "code"; _};_}]; _} as pmod -> 286 | let pmod = { pmod with pmod_attributes = [] } in 287 | let marshalled = 288 | Exp.constant (Pconst_string (Marshal.to_string (migrate_module_expr pmod) [], None)) in 289 | add_defmodule staged_defs {pmod with 290 | pmod_attributes = []; 291 | pmod_desc = Pmod_structure ( 292 | Str.mk (Pstr_module (Mb.mk (Location.mknoloc "Staged_module") 293 | (modrenamer.module_expr modrenamer pmod))) 294 | :: [%str 295 | let staged_source : Ppx_stage.staged_module = 296 | Marshal.from_string [%e marshalled] 0])} 297 | | pmod -> default_mapper.module_expr mapper pmod in 298 | 299 | let module_type mapper = function 300 | | {pmty_attributes = [{attr_name={txt = "code"; _}; _}]; _} as pmty -> 301 | {pmty with pmty_attributes = []; pmty_desc = Pmty_signature [ 302 | Sig.module_ (Md.mk (Location.mknoloc "Staged_module") 303 | (Mty.mk (modrenamer.module_type modrenamer pmty).pmty_desc)); 304 | [%sigi: val staged_source : Ppx_stage.staged_module] 305 | ]} 306 | | pmty -> default_mapper.module_type mapper pmty in 307 | 308 | { default_mapper with expr; module_expr; module_type } 309 | 310 | and quasiquote_subexps staged_defs modrenamer context_vars exp = 311 | let mapper = quasiquote_mapper staged_defs modrenamer context_vars in 312 | mapper.expr mapper exp 313 | 314 | 315 | 316 | (* module%code and functors *) 317 | let rec quasiquote_structure 318 | staged_defs 319 | functor_arg_names 320 | module_code_names 321 | str = 322 | let mapper = quasiquote_mapper staged_defs (make_module_renamer module_code_names) IM.empty in 323 | match str with 324 | | [] -> [] 325 | | stri :: rest -> 326 | match stri.pstr_desc with 327 | | Pstr_extension (({txt = "code"; _}, PStr [{pstr_desc = (Pstr_module mb); _}]), _) -> 328 | let staged_modname = mb.pmb_name.txt ^ "_StagedCode_" in 329 | let loc = mb.pmb_loc in 330 | let mexp = mapper.module_expr mapper mb.pmb_expr in 331 | let rec fixup_mexp mexp = 332 | match mexp.pmod_desc with 333 | | Pmod_ident { txt = Ldot (m, f); loc } 334 | when m = staged_defs.modname -> 335 | { mexp with pmod_desc = Pmod_ident 336 | (Location.mkloc (Longident.Lident f) loc) } 337 | | Pmod_constraint (mexp, mty) -> 338 | { mexp with pmod_desc = Pmod_constraint (fixup_mexp mexp, mty) } 339 | | _ -> mexp in 340 | let mexp = rename_module functor_arg_names (fixup_mexp mexp) in 341 | add_structure_item staged_defs 342 | (Str.mk ~loc (Pstr_module 343 | { mb with 344 | pmb_name = Location.mknoloc staged_modname; 345 | pmb_expr = mexp })); 346 | let staged_contents_modname = mb.pmb_name.txt ^ "_StagedCodeContents_" in 347 | add_structure_item staged_defs 348 | (Str.mk ~loc (Pstr_module 349 | (Mb.mk ~loc (Location.mknoloc staged_contents_modname) 350 | (Mod.mk ~loc (Pmod_ident (Location.mkloc 351 | (Longident.Ldot (Longident.Lident staged_modname, 352 | "Staged_module")) loc)))))); 353 | add_structure_item staged_defs [%stri 354 | let modcontext''_ = Ppx_stage.Internal.extend_modcontext 355 | modcontext''_ 356 | [%e Exp.mk (Pexp_constant (Pconst_string (mb.pmb_name.txt, None)))] 357 | [%e Exp.mk (Pexp_ident (Location.mknoloc (Longident.(Ldot (Lident staged_modname, "staged_source")))))]]; 358 | let module_code_names = StrMap.add mb.pmb_name.txt staged_contents_modname module_code_names in 359 | {stri with pstr_desc = Pstr_module {mb with pmb_expr = 360 | Mod.mk (Pmod_ident (Location.mknoloc (Longident.Ldot (staged_defs.modname, staged_contents_modname))))}} 361 | :: quasiquote_structure staged_defs functor_arg_names module_code_names rest 362 | | Pstr_modtype _ -> 363 | add_structure_item staged_defs stri; 364 | stri :: quasiquote_structure staged_defs functor_arg_names module_code_names rest 365 | | Pstr_module mb -> 366 | let rec collect_functors acc modexpr = 367 | match modexpr.pmod_desc with 368 | | Pmod_structure s -> acc, Some s 369 | | Pmod_functor (ident, mty, body) -> 370 | let mty = match mty with 371 | | None -> None 372 | | Some s -> Some (mapper.module_type mapper s) in 373 | collect_functors ((ident, mty) :: acc) body 374 | | _ -> acc, None in 375 | let (functors, body) = collect_functors [] mb.pmb_expr in 376 | begin match body with 377 | | None -> 378 | (* FIXME: does mod renaming happen correctly here? *) 379 | mapper.structure_item mapper stri 380 | :: quasiquote_structure staged_defs functor_arg_names module_code_names rest 381 | | Some body -> 382 | let staged_modname = mb.pmb_name.txt ^ "_Staged_" in 383 | let staged_mod_path = Longident.Ldot (staged_defs.modname, staged_modname) in 384 | let trans_arg ident = 385 | { ident with txt = ident.txt ^ "_StagedArg_" } in 386 | let sub_functor_arg_names = 387 | List.fold_left (fun names (ident, _signature) -> 388 | StrMap.add ident.txt (trans_arg ident).txt names) 389 | functor_arg_names 390 | functors in 391 | let submod = { 392 | modname = 393 | if functors = [] then 394 | staged_mod_path 395 | else 396 | Lident staged_modname; 397 | def_list = []; num_defs = 0 398 | } in 399 | let translated = quasiquote_structure submod sub_functor_arg_names module_code_names body in 400 | let translated = 401 | if functors = [] then translated else 402 | let rec apply_functor_args = function 403 | | [] -> Mod.ident (Location.mknoloc staged_mod_path) 404 | | (ident, _signature) :: rest -> 405 | Mod.mk (Pmod_apply (apply_functor_args rest, 406 | Mod.ident (Location.mknoloc (Longident.Lident ident.txt)))) in 407 | Str.mk (Pstr_module (Mb.mk (Location.mknoloc staged_modname) 408 | (apply_functor_args functors))) :: translated in 409 | let rec replace_functors body = function 410 | | (ident, signature) :: rest -> 411 | (* FIXME rename and process signature *) 412 | replace_functors (Mod.mk (Pmod_functor (ident, signature, body))) rest 413 | | [] -> body in 414 | let staged_mod = 415 | replace_functors 416 | (Mod.mk (Pmod_structure (collect_definitions submod))) 417 | (List.map (fun (ident, signature) -> (trans_arg ident, signature)) functors) in 418 | add_structure_item staged_defs (Str.mk (Pstr_module (Mb.mk (Location.mknoloc staged_modname) staged_mod))); 419 | {stri with pstr_desc = Pstr_module {mb with pmb_expr = 420 | replace_functors (Mod.mk (Pmod_structure translated)) functors}} 421 | :: quasiquote_structure staged_defs functor_arg_names module_code_names rest 422 | end 423 | | _ -> 424 | mapper.structure_item mapper stri 425 | :: quasiquote_structure staged_defs functor_arg_names module_code_names rest 426 | 427 | let apply_staging str = 428 | (* Slightly revolting, but we need to avoid Staged being shadowed by things imported from other modules *) 429 | let modname = "Staged_" ^ string_of_int (Hashtbl.hash str) in 430 | let staged_defs = { 431 | modname = Lident modname; 432 | def_list = []; num_defs = 0 } in 433 | add_structure_item staged_defs [%stri 434 | let modcontext''_ = Ppx_stage.Internal.empty_modcontext]; 435 | let mapped_str = quasiquote_structure staged_defs StrMap.empty StrMap.empty str in 436 | let inserted = collect_definitions staged_defs in 437 | match inserted, mapped_str with 438 | | [], mapped_str -> mapped_str 439 | | inserted, [{pstr_desc = Pstr_eval (e, ats); pstr_loc}] -> 440 | let e' = Exp.letmodule (Location.mknoloc modname) (Mod.structure inserted) e in 441 | [{ pstr_desc = Pstr_eval (e', ats); pstr_loc }] 442 | | inserted, [{pstr_desc = Pstr_value(Nonrecursive, [ vb ]); pstr_loc}] -> 443 | let e' = Exp.letmodule (Location.mknoloc modname) (Mod.structure inserted) vb.pvb_expr in 444 | [{ pstr_desc = Pstr_value(Nonrecursive, [ {vb with pvb_expr = e'} ]); pstr_loc}] 445 | | inserted, mapped_str -> 446 | Str.module_ (Mb.mk (Location.mknoloc modname) (Mod.structure inserted)) :: mapped_str 447 | 448 | let () = 449 | Driver.register ~name:"ppx_stage" Versions.ocaml_408 450 | (fun _config _cookies -> make_top_mapper 451 | ~signature:(fun s -> s) 452 | ~structure:apply_staging) 453 | -------------------------------------------------------------------------------- /ppx_stage.opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "stephen.dolan@cl.cam.ac.uk" 3 | authors: ["Stephen Dolan"] 4 | homepage: "https://github.com/stedolan/ppx_stage" 5 | bug-reports: "https://github.com/stedolan/ppx_stage/issues" 6 | dev-repo: "https://github.com/stedolan/ppx_stage.git" 7 | license: "MIT" 8 | build: 9 | [[ "dune" "build" "-p" name "-j" jobs ]] 10 | available: [ ocaml-version >= "4.08" ] 11 | depends: [ 12 | "dune" {build & >= "2.0"} 13 | "ocaml-migrate-parsetree" 14 | "ppx_tools_versioned" 15 | ] 16 | -------------------------------------------------------------------------------- /runtime/compat.cppo.ml: -------------------------------------------------------------------------------- 1 | open Parsetree 2 | open Ast_helper 3 | 4 | let mk_mb name body = 5 | #if OCAML_VERSION < (4, 10, 0) 6 | Mb.mk (Location.mknoloc name) body 7 | #else 8 | Mb.mk (Location.mknoloc (Some name)) body 9 | #endif 10 | 11 | let pconst_string x = 12 | #if OCAML_VERSION < (4, 11, 0) 13 | Pconst_string (x, None) 14 | #else 15 | Pconst_string (x, Location.none, None) 16 | #endif 17 | -------------------------------------------------------------------------------- /runtime/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_stage) 3 | (public_name ppx_stage.runtime-lib) 4 | (libraries compiler-libs.common)) 5 | 6 | (rule 7 | (targets compat.ml) 8 | (deps compat.cppo.ml) 9 | (action (run %{bin:cppo} %{deps} -V OCAML:%{ocaml_version} -o %{targets}))) 10 | -------------------------------------------------------------------------------- /runtime/identMap.ml: -------------------------------------------------------------------------------- 1 | type ident = string 2 | include Map.Make (struct type t = ident let compare = compare end) 3 | -------------------------------------------------------------------------------- /runtime/internal.ml: -------------------------------------------------------------------------------- 1 | open Asttypes 2 | open Parsetree 3 | open Ast_helper 4 | 5 | 6 | 7 | type dynamic_modcontext = { 8 | used_names : (string, unit) Hashtbl.t; 9 | mods : (int, string * Parsetree.module_expr) Hashtbl.t 10 | } 11 | 12 | 13 | type _ tag = .. 14 | module type T = sig 15 | type a 16 | type _ tag += Tag : a tag 17 | val name : string 18 | end 19 | type 'a variable = (module T with type a = 'a) 20 | 21 | let fresh_variable (type aa) name : aa variable = 22 | (module struct 23 | type a = aa 24 | type _ tag += Tag : a tag 25 | let name = name 26 | end) 27 | 28 | let variable_name (type a) ((module V) : a variable) = V.name 29 | 30 | type (_, _) cmp_result = Eq : ('a, 'a) cmp_result | NotEq : ('a, 'b) cmp_result 31 | let cmp_variable (type a) (type b) : a variable -> b variable -> (a, b) cmp_result = 32 | fun (module A) (module B) -> 33 | match A.Tag with B.Tag -> Eq | _ -> NotEq 34 | 35 | let eq_variable (type a) (type b) : a variable -> b variable -> bool = 36 | fun v1 v2 -> match cmp_variable v1 v2 with Eq -> true | NotEq -> false 37 | 38 | module VarMap (C : sig type 'a t end) : sig 39 | type t 40 | val empty : t 41 | val add : t -> 'a variable -> 'a C.t -> t 42 | val lookup : t -> 'a variable -> 'a C.t option 43 | end = struct 44 | type entry = Entry : 'b variable * 'b C.t -> entry 45 | type t = entry list 46 | let empty = [] 47 | let add m v x = (Entry (v, x) :: m) 48 | let rec lookup : type a . t -> a variable -> a C.t option = 49 | fun m v -> 50 | match m with 51 | | [] -> None 52 | | (Entry (v', x')) :: m -> 53 | match cmp_variable v v' with 54 | | Eq -> Some x' 55 | | NotEq -> lookup m v 56 | end 57 | 58 | module Environ = VarMap (struct type 'a t = 'a end) 59 | 60 | module Renaming = struct 61 | 62 | type entry = Entry : { 63 | var : 'a variable; 64 | mutable aliases : IdentMap.ident list 65 | } -> entry 66 | type t = entry list IdentMap.t 67 | 68 | 69 | let empty = IdentMap.empty 70 | 71 | let with_renaming 72 | (var : 'a variable) 73 | (f : t -> dynamic_modcontext -> expression) 74 | (ren : t) (modst : dynamic_modcontext) : expression = 75 | let entry = Entry { var ; aliases = [] } in 76 | let vname = variable_name var in 77 | let shadowed = try IdentMap.find vname ren with Not_found -> [] in 78 | let result = f (IdentMap.add vname (entry :: shadowed) ren) modst in 79 | match entry with 80 | | Entry { var=_; aliases = []} -> result 81 | | Entry { var=_; aliases } -> 82 | Exp.let_ Nonrecursive 83 | (aliases |> List.map (fun alias -> 84 | Vb.mk 85 | (Pat.var (Location.mknoloc alias)) 86 | (Exp.ident (Location.mknoloc (Longident.Lident vname))) 87 | )) 88 | result 89 | 90 | let lookup (var : 'a variable) (ren : t) = 91 | let vname = variable_name var in 92 | let fail () = 93 | failwith ("Variable " ^ vname ^ " used out of scope") in 94 | 95 | let rec create_alias n = 96 | let alias = vname ^ "''" ^ string_of_int n in 97 | if IdentMap.mem alias ren then 98 | create_alias (n+1) 99 | else 100 | alias in 101 | 102 | let rec find_or_create_alias = function 103 | | [] -> fail () 104 | | (Entry ({var = var'; aliases} as entry)) :: _ when eq_variable var var' -> 105 | (* Even though it was unbound when created, an alias may be shadowed here *) 106 | begin match List.find (fun v -> not (IdentMap.mem v ren)) aliases with 107 | | alias -> 108 | alias 109 | | exception Not_found -> 110 | let alias = create_alias 1 in 111 | entry.aliases <- alias :: aliases; 112 | alias 113 | end 114 | | _ :: rest -> find_or_create_alias rest in 115 | 116 | let bound_name = 117 | match IdentMap.find vname ren with 118 | | exception Not_found -> fail () 119 | | [] -> assert false 120 | | (Entry { var = var' ; _ }) :: _ when eq_variable var var' -> 121 | (* present, not shadowed *) 122 | vname 123 | | _ :: shadowed -> 124 | find_or_create_alias shadowed in 125 | Exp.ident (Location.mknoloc (Longident.Lident bound_name)) 126 | end 127 | 128 | let compute_variable v = 129 | (fun env -> 130 | match Environ.lookup env v with 131 | | Some x -> x 132 | | None -> 133 | failwith ("Variable " ^ variable_name v ^ " used out of scope")) 134 | 135 | let source_variable = Renaming.lookup 136 | 137 | open Ast_mapper 138 | type substitutable = 139 | | SubstContext of int 140 | | SubstHole of int 141 | 142 | let substitute_holes (e : expression) (f : substitutable -> expression) = 143 | let expr mapper pexp = 144 | match pexp.pexp_desc with 145 | | Pexp_ident { txt = Lident v; loc = _ } -> 146 | let id () = int_of_string (String.sub v 1 (String.length v - 1)) in 147 | (match v.[0] with 148 | | ',' -> f (SubstHole (id ())) 149 | | ';' -> f (SubstContext (id ())) 150 | | _ -> pexp) 151 | | _ -> default_mapper.expr mapper pexp in 152 | let mapper = { default_mapper with expr } in 153 | mapper.expr mapper e 154 | 155 | let module_remapper f = 156 | let rename (id : Longident.t Location.loc) : Longident.t Location.loc = 157 | let rec go : Longident.t -> Longident.t = function 158 | | Lident id -> Lident (f id) 159 | | Ldot (id, x) -> Ldot (go id, x) 160 | | Lapply (idF, idX) -> Lapply (go idF, go idX) in 161 | {id with txt = go id.txt} in 162 | let open Parsetree in 163 | let open Ast_mapper in 164 | let rec expr mapper pexp = 165 | let pexp_desc = match pexp.pexp_desc with 166 | | Pexp_ident id -> 167 | Pexp_ident (rename id) 168 | | Pexp_construct (id, e) -> 169 | Pexp_construct (rename id, expr_opt mapper e) 170 | | Pexp_record (fs, e) -> 171 | let fs = List.map (fun (id, e) -> (rename id, expr mapper e)) fs in 172 | Pexp_record (fs, expr_opt mapper e) 173 | | Pexp_field (e, f) -> 174 | Pexp_field (expr mapper e, rename f) 175 | | Pexp_setfield (e, f, x) -> 176 | Pexp_setfield (expr mapper e, rename f, expr mapper x) 177 | | Pexp_new id -> 178 | Pexp_new (rename id) 179 | | Pexp_open (md, e) -> 180 | Pexp_open ({ md with popen_expr = module_expr mapper md.popen_expr }, 181 | expr mapper e) 182 | | _ -> (default_mapper.expr mapper pexp).pexp_desc in 183 | { pexp with pexp_desc } 184 | and expr_opt mapper = function 185 | | None -> None 186 | | Some e -> Some (expr mapper e) 187 | and typ mapper ptyp = 188 | let ptyp_desc = match ptyp.ptyp_desc with 189 | | Ptyp_constr (id, tys) -> 190 | Ptyp_constr (rename id, List.map (typ mapper) tys) 191 | | Ptyp_class (id, tys) -> 192 | Ptyp_class (rename id, List.map (typ mapper) tys) 193 | | _ -> (default_mapper.typ mapper ptyp).ptyp_desc in 194 | { ptyp with ptyp_desc } 195 | and pat mapper ppat = 196 | let ppat_desc = match ppat.ppat_desc with 197 | | Ppat_construct (id, pat) -> 198 | Ppat_construct (rename id, pat_opt mapper pat) 199 | | Ppat_record (fs, flag) -> 200 | let fs = List.map (fun (id, p) -> (rename id, pat mapper p)) fs in 201 | Ppat_record (fs, flag) 202 | | Ppat_type id -> 203 | Ppat_type (rename id) 204 | | Ppat_open (id, p) -> 205 | Ppat_open (rename id, pat mapper p) 206 | | _ -> (default_mapper.pat mapper ppat).ppat_desc in 207 | { ppat with ppat_desc } 208 | and pat_opt mapper = function 209 | | None -> None 210 | | Some p -> Some (pat mapper p) 211 | and module_type mapper pmty = 212 | let pmty_desc = match pmty.pmty_desc with 213 | | Pmty_ident id -> Pmty_ident (rename id) 214 | | Pmty_alias id -> Pmty_alias (rename id) 215 | | _ -> (default_mapper.module_type mapper pmty).pmty_desc in 216 | { pmty with pmty_desc } 217 | and open_description _mapper op = 218 | { op with popen_expr = rename op.popen_expr } 219 | and module_expr mapper pmod = 220 | let pmod_desc = match pmod.pmod_desc with 221 | | Pmod_ident id -> Pmod_ident (rename id) 222 | | _ -> (default_mapper.module_expr mapper pmod).pmod_desc in 223 | { pmod with pmod_desc } 224 | in 225 | { default_mapper with expr; typ; pat; module_type; open_description; module_expr } 226 | 227 | 228 | 229 | module IntMap = Map.Make(struct type t = int let compare = compare end) 230 | module StrMap = Map.Make(struct type t = string let compare = compare end) 231 | 232 | type module_code = { 233 | id : int; 234 | orig_name : string; 235 | source : Parsetree.module_expr; 236 | modcontext : modcontext 237 | } 238 | and modcontext = module_code StrMap.t 239 | 240 | let empty_modcontext = StrMap.empty 241 | let max_mod_id = ref 0 242 | 243 | let extend_modcontext ctx name source : modcontext = 244 | incr max_mod_id; 245 | let md = 246 | { id = !max_mod_id; 247 | orig_name = name; 248 | source; 249 | modcontext = ctx } in 250 | StrMap.add name md ctx 251 | 252 | let rec rename st (mc : modcontext) (s : string) = 253 | match StrMap.find s mc with 254 | | exception Not_found -> s 255 | | md when Hashtbl.mem st.mods md.id -> 256 | fst (Hashtbl.find st.mods md.id) 257 | | md -> 258 | let freshen name = 259 | let rec go i = 260 | let n = name ^ "'" ^ string_of_int i in 261 | if not (Hashtbl.mem st.used_names n) then 262 | (Hashtbl.add st.used_names n (); n) 263 | else 264 | go (i+1) in 265 | go 1 in 266 | let name = freshen md.orig_name in 267 | let mapper = rename_mapper st md.modcontext in 268 | let body = mapper.module_expr mapper md.source in 269 | Hashtbl.add st.mods md.id (name, body); 270 | name 271 | and rename_mapper st mc = module_remapper (rename st mc) 272 | 273 | let rename_modules_in_exp st mc e = 274 | let mapper = rename_mapper st mc in 275 | mapper.expr mapper e 276 | 277 | let generate_source 278 | (f : Renaming.t -> dynamic_modcontext -> Parsetree.expression) 279 | : Parsetree.module_binding list * expression = 280 | let st = { used_names = Hashtbl.create 20; 281 | mods = Hashtbl.create 20 } in 282 | let e = f Renaming.empty st in 283 | let bindings = 284 | Hashtbl.fold (fun k v acc -> (k, v) :: acc) st.mods [] 285 | |> List.sort (fun (id, _) (id', _) -> compare id id') 286 | |> List.map (fun (_id, (name, body)) -> Compat.mk_mb name body) in 287 | bindings, e 288 | 289 | let to_structure (bindings, e) : Parsetree.structure = 290 | List.map (fun mb -> Str.mk (Pstr_module mb)) bindings @ 291 | [Str.mk (Pstr_value (Nonrecursive, [Vb.mk (Pat.any ()) e]))] 292 | -------------------------------------------------------------------------------- /runtime/ppx_stage.ml: -------------------------------------------------------------------------------- 1 | module Internal = Internal 2 | module IdentMap = IdentMap 3 | 4 | type 'a code = { 5 | compute : Internal.Environ.t -> 'a; 6 | source : Internal.Renaming.t -> Internal.dynamic_modcontext -> Parsetree.expression; 7 | } 8 | 9 | let to_parsetree_structure f = 10 | Internal.generate_source f.source 11 | |> Internal.to_structure 12 | 13 | (* let to_parsetree f = f.source Internal.Renaming.empty *) 14 | 15 | let run f = f.compute Internal.Environ.empty 16 | 17 | let print ppf f = 18 | Pprintast.structure ppf (to_parsetree_structure f) 19 | 20 | 21 | 22 | module Lift = struct 23 | open Parsetree 24 | open Ast_helper 25 | 26 | let lift c p = { compute = (fun _env -> c); source = (fun _ren _modst -> p) } 27 | 28 | let int x : int code = 29 | lift x (Exp.constant (Pconst_integer (string_of_int x, None))) 30 | let int32 x : Int32.t code = 31 | lift x (Exp.constant (Pconst_integer (Int32.to_string x, Some 'l'))) 32 | let int64 x : Int64.t code = 33 | lift x (Exp.constant (Pconst_integer (Int64.to_string x, Some 'L'))) 34 | let bool x : bool code = 35 | lift x (Exp.construct (Location.mknoloc (Longident.Lident (string_of_bool x))) None) 36 | let float x : float code = 37 | (* OCaml's string_of_float is a bit broken *) 38 | let s = string_of_float x in 39 | if float_of_string s = x then 40 | lift x (Exp.constant (Pconst_float (s, None))) 41 | else 42 | lift x (Exp.constant (Pconst_float (Printf.sprintf "%h" x, None))) 43 | let string x : string code = 44 | lift x (Exp.constant (Compat.pconst_string x)) 45 | end 46 | 47 | 48 | type staged_module = Parsetree.module_expr 49 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name example) 3 | (modules example) 4 | (preprocess 5 | (pps ppx_stage.ppx))) 6 | 7 | (rule (action (with-stdout-to example.out (run ./example.exe)))) 8 | (rule (alias runtest) (action (diff example.expected example.out))) 9 | 10 | (executable 11 | (name mod) 12 | (modules mod) 13 | (preprocess 14 | (pps ppx_stage.ppx))) 15 | 16 | (rule (action (with-stdout-to mod.out (run ./mod.exe)))) 17 | (rule (alias runtest) (action (diff mod.expected mod.out))) 18 | 19 | (executable 20 | (name strymonas_example) 21 | (modules strymonas strymonas_example) 22 | (flags (:standard -w -8-27)) 23 | (preprocess 24 | (pps ppx_stage.ppx))) 25 | 26 | (rule (action (with-stdout-to strymonas_example.out (run ./strymonas_example.exe)))) 27 | (rule (alias runtest) (action (diff strymonas_example.expected strymonas_example.out))) 28 | -------------------------------------------------------------------------------- /test/example.expected: -------------------------------------------------------------------------------- 1 | STARTUP 2 | EARLY 3 | let _ = (string_of_int (((); 2) + ((); 2))) ^ "hello" (* = "4hello"*) 4 | STAGING 5 | let _ = (fun x -> x) "hello" (* = "hello"*) 6 | module RSet'1 = 7 | struct let rset r v = let vs' = v :: (!r) in r := vs'; vs' end 8 | let _ = RSet'1.rset 9 | let _ = let x = [] in ((2 :: x), ("3" :: x)) 10 | let _ = let f x = x in ((f 2), (f "3")) 11 | module RSet'1 = 12 | struct let rset r v = let vs' = v :: (!r) in r := vs'; vs' end 13 | let _ = 14 | let f () = ref [] in ((RSet'1.rset (f ()) 2), (RSet'1.rset (f ()) "3")) 15 | module Square'1 = struct let square x = x * x end 16 | let _ = fun x -> x * (Square'1.square (x * (Square'1.square (x * 1)))) 17 | let _ = (fun x -> x) 3 18 | let _ = let rec go = function | [] -> [] | x::xs -> (x + 1) :: (go xs) in go 19 | let _ = [42; 42; 42; 42] 20 | -------------------------------------------------------------------------------- /test/example.ml: -------------------------------------------------------------------------------- 1 | let () = Format.printf "STARTUP@." 2 | let unit = [%code ()] 3 | let two = [%code [%e Format.printf "EARLY@."; unit]; 2] 4 | let hello = [%code "hello"] 5 | let asdf = [%code string_of_int ([%e two] + [%e two]) ^ [%e hello] ] 6 | 7 | let print x = 8 | Format.printf "@[%a@] (* = %S*)@." Ppx_stage.print x (Ppx_stage.run x) 9 | 10 | let printc x = 11 | Format.printf "@[%a@]@." Ppx_stage.print x 12 | 13 | 14 | let () = print asdf 15 | 16 | let plus1 = fun%staged x -> x + 1 17 | 18 | let fn () = [%code fun x -> [%e Format.printf "STAGING@."; x]] 19 | 20 | let id2 = [%code [%e fn ()] [%e hello]] 21 | 22 | let () = print id2 23 | 24 | 25 | let beta code = [%code [%e code]] 26 | 27 | let go a _b _c = 28 | [%code let f x = x in f [%e a]] 29 | 30 | 31 | (* 32 | (* MetaOCaml nasty example *) 33 | let c () = 34 | let r = ref [%code fun z -> z] in 35 | let f = [%code fun x -> [%e r := [%code fun y -> x]; [%code 0]]] in 36 | [%code fun x -> [%e f] ([%e !r] 1) ] 37 | 38 | let foo = Ppx_stage.run (c ()) 42 39 | 40 | let () = 41 | Format.printf "[@[%a@]]@." Ppx_stage.print (c ()) 42 | 43 | *) 44 | 45 | (* 46 | let bad () = 47 | let c1 = 48 | let r = ref [%code fun z->z] in 49 | let _ = [%code fun x -> [%e r := [%code fun y -> x ]; [%code 0]]] in 50 | !r in 51 | [%code fun y -> fun x -> [%e c1]] 52 | 53 | let () = 54 | Format.printf "@[%a@]@." Ppx_stage.print (bad ()) 55 | *) 56 | 57 | 58 | module%code RSet = struct[@code] 59 | let rset r v = 60 | let vs' = v :: !r in 61 | r := vs'; 62 | vs' 63 | end 64 | 65 | let () = printc [%code RSet.rset] 66 | 67 | 68 | let () = printc [%code let x = [] in (2 :: x, "3" :: x)] 69 | let () = printc [%code let f = fun x -> x in (f 2, f "3")] 70 | 71 | let () = printc [%code let f = fun () -> ref [] in 72 | (RSet.rset (f ()) 2, RSet.rset (f ()) "3")] 73 | 74 | 75 | 76 | module%code Square = struct[@code] 77 | let square x = x * x 78 | end 79 | 80 | let rec spower n x = 81 | if n = 0 then [%code 1] 82 | else if n mod 2 = 0 then [%code Square.square [%e spower (n/2) x]] 83 | else [%code [%e x] * [%e spower (n-1) x]] 84 | 85 | 86 | let () = printc [%code fun x -> [%e spower 7 [%code x]]] 87 | 88 | let map f = 89 | [%code 90 | let rec go = function 91 | | [] -> [] 92 | | x :: xs -> [%e f [%code x]] :: go xs in 93 | go] 94 | 95 | let nest = [%code fun x -> [%e [%code [%e [%code x]]]]] 96 | let three = [%code [%e nest] 3] 97 | let () = printc three 98 | 99 | let () = printc (map (fun x -> [%code [%e x] + 1])) 100 | 101 | let rec repeat x = function 102 | | 0 -> [%code []] 103 | | n -> [%code [%e x] :: [%e repeat x (n-1)]] 104 | 105 | let () = printc (repeat [%code 42] 4) 106 | 107 | 108 | (* 109 | --> 110 | let map f = 111 | let x₁ = fresh "x" in 112 | let p1 = f x₁ in 113 | (fun γ → 114 | let rec go = function 115 | | [] → [] 116 | | x :: xs → p1 (γ , x₁ := x) :: go xs in 117 | go) 118 | 119 | map : (α code → β code) → (α list → β list) code 120 | 121 | 122 | *) 123 | -------------------------------------------------------------------------------- /test/mod.expected: -------------------------------------------------------------------------------- 1 | module M'1 = struct let x = 42 end 2 | let _ = M'1.x + 10 3 | module X'2 = struct let bar = 42 end 4 | module X'1 = struct type t = int 5 | let compare = compare end 6 | module M'1 = (Map.Make)(X'1) 7 | let _ = M'1.singleton X'2.bar X'2.bar 8 | -------------------------------------------------------------------------------- /test/mod.ml: -------------------------------------------------------------------------------- 1 | module type Y = sig val y : int end 2 | module Foo (X: Map.OrderedType[@code]) (Y : Y) = struct 3 | module%code X = X 4 | module%code M = struct[@code] 5 | let cmp = X.compare 6 | end 7 | let c = M.cmp 8 | let x = [%code M.cmp] 9 | end 10 | 11 | module Bar = struct 12 | module%code A = struct[@code] 13 | let foo = 42 14 | end 15 | let blah = [%code A.foo] 16 | end 17 | 18 | 19 | module Blah : sig[@code] 20 | val x : int 21 | end = struct[@code] 22 | let x = 42 23 | end 24 | 25 | 26 | module%code A = struct[@code] 27 | let foo = 42 28 | end 29 | let blah = [%code A.foo] 30 | 31 | 32 | module%code T = struct[@code] 33 | type t = float 34 | end 35 | 36 | let x : T.t = 42.0 37 | 38 | 39 | module%code M : sig[@code] 40 | val x : int 41 | end = struct[@code] 42 | let x = 10 43 | end 44 | 45 | 46 | module type Blah = sig 47 | val x : int 48 | end 49 | 50 | module Func (X: Map.OrderedType[@code]) (B : Blah) = struct 51 | module%code X = X 52 | module%code M = Map.Make(X)[@code] 53 | let foo e = [%code M.singleton [%e e] [%e e]] 54 | end 55 | 56 | module App = Func (struct[@code] type t = int let compare = compare end) (struct let x = 42 end) 57 | 58 | module%code X = struct[@code] 59 | let bar = 42 60 | end 61 | 62 | 63 | module JAIO =struct 64 | module%code M : sig[@code] 65 | val x : int 66 | end = struct[@code] 67 | let x = 42 68 | end 69 | let foo y = [%code M.x + [%e y]] (* works *) 70 | 71 | let () = Format.printf "%a@." Ppx_stage.print (foo [%code 10]) 72 | end 73 | 74 | let () = Format.printf "%a@." Ppx_stage.print (App.foo [%code X.bar]) 75 | 76 | 77 | (* 78 | scoping error: 79 | 80 | module Bloop (A: Map.OrderedType) = struct 81 | let foo = [%code A.compare] 82 | end 83 | *) 84 | -------------------------------------------------------------------------------- /test/strymonas.ml: -------------------------------------------------------------------------------- 1 | (* 2 | This file is stream_combinators.ml from: 3 | 4 | https://github.com/strymonas/staged-streams.ocaml 5 | 6 | accompanying the paper 7 | 8 | Stream Fusion, to Completeness 9 | Oleg Kiselyov, Aggelos Biboudis, Nick Palladinos, Yannis Smaragdakis 10 | 11 | The only modifications are to the syntax of staging (replacing MetaOCaml's 12 | .<>. and .~() with ppx_stage's [%code] and [%e]), and the import of the 13 | code type below, which is not predefined under ppx_stage. 14 | *) 15 | 16 | type 'a code = 'a Ppx_stage.code 17 | 18 | (* 19 | MIT License 20 | 21 | Copyright (c) 2017 Oleg Kiselyov, Aggelos Biboudis, Nick Palladinos, Yannis Smaragdakis 22 | 23 | Permission is hereby granted, free of charge, to any person obtaining a copy 24 | of this software and associated documentation files (the "Software"), to deal 25 | in the Software without restriction, including without limitation the rights 26 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 27 | copies of the Software, and to permit persons to whom the Software is 28 | furnished to do so, subject to the following conditions: 29 | 30 | The above copyright notice and this permission notice shall be included in all 31 | copies or substantial portions of the Software. 32 | 33 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 34 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 35 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 36 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 37 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 38 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 39 | SOFTWARE. 40 | *) 41 | 42 | 43 | (* This is a pull stream but it is used pretty much like a push stream. 44 | 'a is the type of the eventually produced value, 45 | 's is the overall state. 'a is not necessarily the code type! 46 | It could be a tuple of code types, for example. 47 | 48 | Stream producer is always linear: in the non-terminated state, 49 | when it updates the stream state it always produces a value. 50 | A stream may be either linear (when it is non-nested: bare producer) 51 | or not. Nested streams are non-linear: one update to the outer stream 52 | state may produce 0, 1 or more (nested) stream values. 53 | Linearity here refers to the linear use of stream's continuation. 54 | Filtering is modeled as a nested stream. 55 | 56 | Linear streams have special properties: commute with take and zip, 57 | for example. 58 | 59 | Of the generators, we distinguish indexing generators, which correspond 60 | to the for-loop. The general unfold generator corresponds to the while 61 | loop (or the tail-recursive function). 62 | The loop itself will be generated by 'fold' (as behooves to the pull 63 | stream). We assume that the fold's state is mutable, so we make no provisions 64 | to thread it through in the generator (although we may). 65 | 66 | A note on a possible alternative: turn the transformer of a nested 67 | stream in CPS.: 'b -> ('a stream -> unit code) -> unit code. 68 | Add an alternative for the Singleton producer. Then filter is implemented 69 | as a Nested that inserts the if-statement test and calls the continuation 70 | with the Singleto stream. 71 | 72 | XXX Generalize take_raw along the lines of fold_raw (need to pass 73 | z and the function to update z (with the return type unit code) 74 | and the function to build the term condition (bool code)). Perhaps 75 | z can be included into the closure. Then we can use the same take_raw 76 | to derive both take and takeWhile. 77 | 78 | Incidentally, takeWhile can be expressed in terms of zip_with, 79 | more specifically, zip_with_raw. Perhaps the ordinary take can be dealt 80 | with similarly. This points out the general character of the *_raw functions 81 | and the need to take them seriously. One can say they are the VM that Yannis 82 | likes to talk about. 83 | This is the benefit of staging: we can use abstractions 84 | and not pay for them. 85 | 86 | 87 | In general, we can move regular map, fold, take, etc. in a separate file, 88 | (along with sum and iota and enumFromTo, etc). The latter do not depend 89 | on the stream structure and internals. 90 | *) 91 | 92 | type card_t = AtMost1 | Many 93 | 94 | (* We need the step function in CPS with the code answer type, 95 | so we can do let-insertion 96 | *) 97 | 98 | type ('a,'s) producer_t = 99 | | For of ('a,'s) producer_for 100 | | Unfold of ('a,'s) producer_unfold 101 | and ('a,'s) producer_for = 102 | {upb: 's -> int code; (* exact upper bound *) 103 | index: 's -> int code -> ('a -> unit code) -> unit code} 104 | and ('a,'s) producer_unfold = 105 | {term: 's -> bool code; (* when false, stop *) 106 | card: card_t; 107 | step: 's -> ('a -> unit code) -> unit code} 108 | and 's init = {init : 'w. ('s -> 'w code) -> 'w code} 109 | and 'a producer = 110 | Prod : 's init * ('a,'s) producer_t -> 'a producer 111 | and _ st_stream = 112 | | Linear : 'a producer -> 'a st_stream 113 | | Nested : 'b producer * ('b -> 'a st_stream)-> 'a st_stream 114 | and 'a stream = 'a code st_stream 115 | 116 | 117 | 118 | (* Change the For producer to the general producer *) 119 | let for_unfold : 'a producer -> 'a producer = function 120 | | Prod ({init},For {upb;index}) -> 121 | Prod ({init = fun k -> init @@ fun s0 -> 122 | [%code let i = ref 0 in [%e k ([%code i],s0)]]}, 123 | Unfold {term = (fun (i,s0) -> [%code !([%e i]) <= [%e upb s0]]); 124 | card = Many; 125 | step = (fun (i,s0) k -> 126 | index s0 [%code ! ([%e i])] @@ fun a -> 127 | [%code (incr [%e i]; [%e k a])])}) 128 | | x -> x 129 | 130 | 131 | let of_arr : 'a array code -> 'a stream = fun arr -> 132 | let prod = 133 | Prod ({init = fun k -> [%code let arr = [%e arr] in [%e k [%code arr]]]}, 134 | For {upb = (fun arr -> [%code Array.length [%e arr] - 1]); 135 | index = (fun arr i k -> 136 | [%code let el = ([%e arr]).([%e i]) in [%e k [%code el]]])}) 137 | in 138 | Linear prod 139 | ;; 140 | 141 | 142 | (* This interface is good for functional streams but not for loops *) 143 | let unfold : ('z code -> ('a * 'z) option code) -> 'z code -> 'a stream 144 | = fun p z -> 145 | let prod = 146 | Prod ({init = fun k -> 147 | [%code let s = ref [%e p z] in [%e k [%code s]]]}, 148 | Unfold { 149 | term = (fun s -> [%code ! ([%e s]) <> None]); 150 | card = Many; 151 | step = (fun (s) body -> 152 | [%code match ! ([%e s]) with 153 | Some (el,s') -> [%e s] := [%e p [%code s']]; [%e body [%code el]]])}) 154 | in 155 | Linear prod 156 | 157 | (* Consumer. Only consumer runs the main loop -- or makes it *) 158 | 159 | let rec fold_raw : 'a. ('a -> unit code) -> 'a st_stream -> unit code 160 | = fun consumer -> function 161 | | Linear (Prod ({init},For {upb;index})) -> 162 | init @@ fun sp -> 163 | [%code for i = 0 to [%e upb sp] do 164 | [%e index sp [%code i] @@ consumer] 165 | done] 166 | | Linear (Prod ({init},Unfold {term;card=AtMost1;step})) -> 167 | init @@ fun sp -> 168 | [%code if [%e term sp] then [%e step sp @@ consumer]] 169 | | Linear (Prod ({init},Unfold {term;step;_})) -> 170 | init @@ fun sp -> 171 | [%code while [%e term sp] do 172 | [%e step sp @@ consumer] 173 | done] 174 | | Nested (prod,nestf) -> (* polymorphic recursion *) 175 | fold_raw (fun e -> fold_raw consumer @@ nestf e) (Linear prod) 176 | 177 | let fold : ('z code -> 'a code -> 'z code) -> 'z code -> 'a stream -> 'z code 178 | = fun f z str -> 179 | [%code let s = ref [%e z] in 180 | ([%e fold_raw (fun a -> [%code s := [%e f [%code !s] a]]) str]; !s)] 181 | 182 | let fold_tupled : ('z1 code -> 'a code -> 'z1 code) -> 'z1 code -> 183 | ('z2 code -> 'a code -> 'z2 code) -> 'z2 code -> 184 | 'a stream -> ('z1 * 'z2) code 185 | = fun f1 z1 f2 z2 str -> 186 | [%code let s1 = ref [%e z1] in 187 | let s2 = ref [%e z2] in 188 | ([%e fold_raw (fun a -> [%code begin 189 | s1 := [%e f1 [%code !s1] a]; 190 | s2 := [%e f2 [%code !s2] a] 191 | end ]) str]; (!s1, !s2))] 192 | 193 | (* Transformers *) 194 | (* A general map, used for many things *) 195 | (* We need the mapping function in CPS with the code answer type, 196 | so we can do let-insertion 197 | *) 198 | let rec map_raw : 'a 'b. ('a -> ('b -> unit code) -> unit code) -> 199 | 'a st_stream -> 'b st_stream = 200 | fun tr -> function 201 | | Linear (Prod (init,For ({index;_} as g))) -> 202 | let index s i k = index s i @@ fun e -> tr e k in 203 | Linear (Prod (init, For {g with index})) 204 | | Linear (Prod (init,Unfold ({step;_} as g))) -> 205 | let step s k = step s @@ fun e -> tr e k in 206 | Linear (Prod (init, Unfold {g with step})) 207 | | Nested (prod,nestf) -> 208 | Nested (prod,fun a -> map_raw tr (nestf a)) 209 | 210 | let map : ('a code -> 'b code) -> 'a stream -> 'b stream = 211 | fun f str -> 212 | map_raw (fun a k -> [%code let t = [%e f a] in [%e k [%code t]]]) str 213 | 214 | let rec flat_map_raw : ('a -> 'b st_stream) -> 'a st_stream -> 'b st_stream = 215 | fun tr -> function 216 | | Linear prod -> Nested (prod,tr) 217 | | Nested (prod,nestf) -> Nested (prod,fun a -> flat_map_raw tr @@ nestf a) 218 | 219 | let flat_map : ('a code -> 'b stream) -> 'a stream -> 'b stream = 220 | flat_map_raw 221 | 222 | (* Filter is also implemented via flat_map *) 223 | let filter : ('a code -> bool code) -> 'a stream -> 'a stream = 224 | fun f str -> 225 | let filter_stream a = 226 | Prod ({init = fun k -> k a}, 227 | Unfold {card = AtMost1; 228 | term = f; 229 | step = fun a k -> k a}) 230 | in 231 | flat_map_raw (fun x -> Linear (filter_stream x)) str 232 | 233 | 234 | (* Add a new termination condition. We don't add to AtMost1 streams 235 | since those are always dependent and the termination check is 236 | redundant. 237 | *) 238 | let rec more_termination : bool code -> 'a st_stream -> 'a st_stream = 239 | let rec add_to_producer new_term = function 240 | | Prod (init, Unfold {card=Many;term;step}) -> 241 | let term s = [%code [%e new_term] && [%e term s]] in 242 | Prod (init, Unfold {card=Many;term;step}) 243 | | Prod (_, Unfold {card=AtMost1;_}) as p -> p 244 | | p -> add_to_producer new_term (for_unfold p) in 245 | fun new_term -> function 246 | | Linear p -> Linear (add_to_producer new_term p) 247 | | Nested (p,nestf) -> 248 | Nested (add_to_producer new_term p, 249 | fun a -> more_termination new_term (nestf a)) 250 | 251 | (* type ('a,'b) either = Left of 'a | Right of 'b *) 252 | 253 | (* The nested stream receives the same remcount reference; thus 254 | all streams decrement the same global count. 255 | *) 256 | let take_raw : int code -> 'a st_stream -> 'a st_stream = 257 | let add_nr : 'a. int code -> 'a producer -> (int ref code * 'a) producer = 258 | fun n -> function Prod ({init},Unfold {term;card;step}) -> 259 | let init = fun k -> 260 | init @@ fun s -> [%code let nr = ref [%e n] in [%e k ([%code nr],s)]] 261 | and prod = 262 | Unfold { 263 | card; 264 | (* For filter, we assume that is a dependent stream... *) 265 | term = (fun (nr,s) -> 266 | if card = Many then [%code ! [%e nr] > 0 && [%e term s]] else term s); 267 | step = (fun (nr,s) k -> step s (fun el -> k (nr,el)))} 268 | in Prod ({init},prod) 269 | and update_nr = fun (nr,el) k -> [%code (decr [%e nr]; [%e k el])] 270 | in 271 | fun n -> function 272 | | Linear (Prod (init, For {upb;index})) -> 273 | let upb s = [%code min ([%e n]-1) [%e upb s]] in 274 | Linear (Prod (init, For {upb;index})) 275 | | Linear p -> 276 | map_raw update_nr @@ Linear (add_nr n p) 277 | | Nested (p,nestf) -> 278 | Nested (add_nr n (for_unfold p), 279 | fun (nr,a) -> 280 | map_raw (fun a -> update_nr (nr,a)) @@ 281 | more_termination [%code ! [%e nr] > 0] (nestf a)) 282 | 283 | let take : int code -> 'a stream -> 'a stream = take_raw 284 | 285 | (* Zipping *) 286 | (* When zipping two streams with the step function step1 and step2 287 | (and assuming step1 is at least as long as step2), one may expect 288 | one of the following patterns of calling step1 and step2: 289 | step1 step2 step1 step2 step1 eof-step2 290 | or 291 | step2 step1 step2 step1 eof-step2 292 | We guarantee that step1 and step2 are called in the alternating 293 | pattern: one of the above calling sequences. Which of the two -- is 294 | generally undefined. The programmer has to beware, when step functions 295 | have side-effects. 296 | 297 | Care should be taken when zipping the nested stream with an 298 | ordinary stream. 299 | Another subtle point: we try to make a parallel loop, so to speak. 300 | However, the two streams may advance at different pace: they 301 | may skip at different times. So, if one stream yields an element 302 | and another skips, we should `back up' the element of the first 303 | stream. Since the state is imperative, we can only remember the 304 | element in the putback buffer. This way we make the streams advance 305 | at the same speed. 306 | 307 | XXX Keep in mind the complex cases of zipping: 308 | ofArr ... |> (fun x -> ofArr [|x;x+1;x+2|]) 309 | ofArr ... |> (fun x -> ofArr [|x;x+2|]) 310 | inner streams have different sizes; one one finishes, the second 311 | still has some elements, which should not be lost! 312 | *) 313 | 314 | let rec zip_producer: 'a producer -> 'b producer -> ('a * 'b) producer = 315 | fun p1 p2 -> 316 | match (p1,p2) with 317 | | (Prod (i1,For f1), Prod (i2,For f2)) -> 318 | Prod ( 319 | {init = fun k -> i1.init @@ fun s1 -> i2.init @@ fun s2 -> k (s1,s2)}, 320 | For { 321 | upb = (fun (s1,s2) -> [%code min [%e f1.upb s1] [%e f2.upb s2]]); 322 | index = (fun (s1,s2) i k -> 323 | f1.index s1 i @@ fun e1 -> f2.index s2 i @@ fun e2 -> 324 | k (e1,e2))}) 325 | (* XXX Need a special case for card = AtMost1? *) 326 | 327 | | (Prod (i1,Unfold f1), Prod (i2,Unfold f2)) -> 328 | Prod ( 329 | {init = fun k -> i1.init @@ fun s1 -> i2.init @@ fun s2 -> k (s1,s2)}, 330 | Unfold { 331 | card = Many; 332 | term = (fun (s1,s2) -> [%code [%e f1.term s1] && [%e f2.term s2]]); 333 | step = (fun (s1,s2) k -> 334 | f1.step s1 @@ fun e1 -> f2.step s2 @@ fun e2 -> 335 | k (e1,e2))}) 336 | | (p1,p2) -> zip_producer (for_unfold p1) (for_unfold p2) 337 | 338 | (* A linear stream is a producer *) 339 | (* This is an auxiliary function, and used in specific circumstances. 340 | Although the pattern-matching is not exhaustive, there is no 341 | problem in the circumstances when this function is called. 342 | *) 343 | (* We introduce term1r to hold the value of the termination check 344 | for the current state of stream1. We have to do that check all 345 | the time for the nested substreams comprising stream2. 346 | The termination check may take time and is not necessarily 347 | idempotent. 348 | *) 349 | let push_linear : 'a producer -> ('b producer * ('b -> 'c st_stream)) -> 350 | ('a * 'c) st_stream = 351 | fun (Prod ({init=init1},Unfold {card=Many;term=term1;step=step1})) 352 | (Prod ({init=init2},Unfold p2), nestf2) -> 353 | let init = fun k -> init1 @@ fun s1 -> init2 @@ fun s2 -> 354 | [%code let term1r = ref [%e term1 s1] in [%e k ([%code term1r],s1,s2)]] 355 | and prod = Unfold { 356 | card = Many; 357 | term = (fun (term1r,s1,s2) -> [%code ! [%e term1r] && [%e p2.term s2]]); 358 | step = (fun (term1r,s1,s2) k -> p2.step s2 (fun b -> k (term1r,s1,b)))} 359 | in Nested (Prod ({init},prod), 360 | fun (term1r,s1,b) -> 361 | map_raw (fun c k -> 362 | step1 s1 @@ fun a -> 363 | [%code ([%e term1r] := [%e term1 s1]; [%e k (a,c)])]) @@ 364 | more_termination [%code ! [%e term1r]] (nestf2 b)) 365 | 366 | 367 | (* Make a stream linear. 368 | We have no choice but ro reify the stream: convert to a function 369 | that will, when called, produce the current element and advance the 370 | stream -- or report the end-of-stream. 371 | Befitting the imperative style of our implementation, 372 | the reified stream is an imperative *non-recursive* function, called 373 | adv, of unit->unit type. It reports the result in the mutable cell 374 | curr: after invoking adv (), curr contains either Some el, where 375 | el is the current element of the stream, or None (meaning the stream 376 | is finished). 377 | 378 | Nested streams are also reified to adv-like function. The mutable 379 | variable nadv contains (if not None) the adv function for the inner-most 380 | stream. When called, it places the current stream element in curr. 381 | The nested-stream adv functions may return without setting curr. 382 | They have to be called again. 383 | If the inner stream is finished, the adv function chages nadv to 384 | the adv function of the earlier stream. 385 | Thus we implement a sort of a trampoline mechanism. This is not 386 | actually needed in OCaml (which optimizes tail calls) but may be 387 | needed when the library is ported to other languages, where tail-call 388 | optimization is difficult or unreliable. 389 | *) 390 | 391 | let rec make_linear : 'a st_stream -> 'a producer = function 392 | | Linear prod -> prod 393 | | Nested (Prod (init, For _) as p, nestf) -> 394 | make_linear (Nested (for_unfold p, nestf)) 395 | | Nested (Prod ({init},Unfold {card=Many;term;step}),nestf) -> 396 | (* Make the adv function for the nested stream *) 397 | let rec make_adv : 398 | 'a. (unit -> unit) option ref code -> 399 | ('a -> unit code) -> 'a st_stream -> unit code = 400 | (* Upon return: 401 | - ncurr is set to the current stream value and nadv stack 402 | is possibly updated with the function to call to get next. 403 | - ncurr is set to None; the parent has to repeat 404 | *) 405 | fun nadv k -> function 406 | | Linear prod -> begin match for_unfold prod with 407 | (* Filter *) 408 | | Prod ({init},Unfold {card=AtMost1; term; step}) -> 409 | init @@ fun s -> [%code if [%e term s] then [%e step s k]] 410 | (* Linear nested component *) 411 | (* XXX We can optimize here for the 1st-level stream: 412 | where we know that old_adv in None 413 | *) 414 | | Prod ({init},Unfold {term; step; _}) -> 415 | init @@ fun s -> 416 | [%code let old_adv = ! [%e nadv] in 417 | let adv1 () = 418 | if [%e term s] then [%e step s k] 419 | else [%e nadv] := old_adv 420 | in 421 | [%e nadv] := Some adv1; adv1 ()] 422 | end 423 | | Nested (prod,nestf) -> 424 | make_adv nadv (fun e -> make_adv nadv k @@ nestf e) @@ 425 | Linear prod 426 | in 427 | let init k = 428 | init @@ fun s0 -> 429 | [%code let curr = ref None in (* Current element, if any *) 430 | let nadv = ref None in (* The step of the innermost stream *) 431 | (* This is the adv for the outer stream *) 432 | (* It really tries to obtain the current element 433 | (of the innermost nested stream) and place it to curr. 434 | If curr remains None, the stream is finished. 435 | *) 436 | let adv () = 437 | curr := None; 438 | while !curr = None && (!nadv <> None || [%e term s0]) do 439 | match !nadv with 440 | | Some adv -> adv () 441 | | None -> 442 | [%e step s0 @@ fun e0 -> 443 | make_adv [%code nadv] (fun e -> [%code curr := Some [%e e]]) @@ 444 | nestf e0] 445 | done 446 | in adv (); [%e k ([%code curr],[%code adv])]] 447 | and term (curr,_) = [%code ! [%e curr] <> None] 448 | and step (curr,adv) k = 449 | [%code match ! [%e curr] with Some el -> [%e adv] (); [%e k [%code el]]] 450 | in Prod ({init},Unfold{card=Many;term;step}) 451 | 452 | 453 | (* The dispatcher for zip *) 454 | let rec zip_raw: 'a st_stream -> 'b st_stream -> ('a * 'b) st_stream = 455 | fun str1 str2 -> 456 | match (str1,str2) with 457 | | (Linear prod1, Linear prod2) -> Linear (zip_producer prod1 prod2) 458 | (* Suppose str1 is linear and str2 is not. Linear stream 459 | can always be pushed inside 460 | *) 461 | | (Linear prod1, Nested (prod2,nestf2)) -> 462 | push_linear (for_unfold prod1) (for_unfold prod2,nestf2) 463 | | (Nested (prod1,nestf1), Linear prod2) -> 464 | map_raw (fun (y,x) k -> k (x,y)) @@ 465 | push_linear (for_unfold prod2) (for_unfold prod1,nestf1) 466 | (* If both streams are non-linear, make at least on of them linear *) 467 | | (str1,str2) -> zip_raw (Linear (make_linear str1)) str2 468 | 469 | 470 | let zip_with : ('a code -> 'b code -> 'c code) -> 471 | ('a stream -> 'b stream -> 'c stream) = 472 | fun f str1 str2 -> 473 | map_raw (fun (x,y) k -> k (f x y)) @@ 474 | zip_raw str1 str2 475 | 476 | ;; 477 | -------------------------------------------------------------------------------- /test/strymonas_example.expected: -------------------------------------------------------------------------------- 1 | let _ = 2 | fun arr1 -> 3 | let s = ref [] in 4 | (let s''1 = s in 5 | let arr = arr1 in 6 | let i = ref 0 in 7 | let curr = ref None in 8 | let nadv = ref None in 9 | let adv () = 10 | curr := None; 11 | while 12 | ((!curr) = None) && 13 | (((!nadv) <> None) || 14 | ((!i) <= (min (12 - 1) ((Array.length arr) - 1)))) 15 | do 16 | (match !nadv with 17 | | Some adv -> adv () 18 | | None -> 19 | let el = arr.(!i) in 20 | let t = el * el in 21 | (incr i; 22 | if (t mod 2) = 0 then (let t = t * t in curr := (Some t)))) 23 | done in 24 | adv (); 25 | (let s = ref (Some (1, (1 + 1))) in 26 | let term1r = ref ((!curr) <> None) in 27 | while (!term1r) && ((!s) <> None) do 28 | match !s with 29 | | Some (el, s') -> 30 | (s := (Some (s', (s' + 1))); 31 | (let s = ref (Some ((el + 1), ((el + 1) + 1))) in 32 | let nr = ref 3 in 33 | while (!term1r) && (((!nr) > 0) && ((!s) <> None)) do 34 | match !s with 35 | | Some (el, s') -> 36 | (s := (Some (s', (s' + 1))); 37 | (let el''1 = el in 38 | decr nr; 39 | if (el mod 2) = 0 40 | then 41 | (match !curr with 42 | | Some el -> 43 | (adv (); 44 | term1r := ((!curr) <> None); 45 | s''1 := ((el, el''1) :: (!s''1)))))) 46 | done)) 47 | done)); 48 | !s 49 | let _ = 50 | fun arr1 -> 51 | fun arr2 -> 52 | let s = ref 0 in 53 | (let arr = arr1 in 54 | for i = 0 to (Array.length arr) - 1 do 55 | let el = arr.(i) in 56 | let el''1 = el in 57 | let arr = arr2 in 58 | for i = 0 to (Array.length arr) - 1 do 59 | let el = arr.(i) in let t = el''1 * el in s := ((!s) + t) 60 | done 61 | done); 62 | !s 63 | -------------------------------------------------------------------------------- /test/strymonas_example.ml: -------------------------------------------------------------------------------- 1 | open Strymonas 2 | 3 | let iota n = unfold (fun n -> [%code Some ([%e n],[%e n]+1)]) n 4 | 5 | (* Example from the paper *) 6 | let example arr1 = 7 | zip_with (fun e1 e2 -> [%code ([%e e1],[%e e2])]) 8 | (* First stream to zip *) 9 | (of_arr arr1 10 | |> map (fun x -> [%code [%e x] * [%e x]]) 11 | |> take [%code 12] 12 | |> filter (fun x -> [%code [%e x] mod 2 = 0]) 13 | |> map (fun x -> [%code [%e x] * [%e x]])) 14 | (* Second stream to zip *) 15 | (iota [%code 1] 16 | |> flat_map (fun x -> iota [%code [%e x]+1] |> take [%code 3]) 17 | |> filter (fun x -> [%code [%e x] mod 2 = 0])) 18 | |> fold (fun z a -> [%code [%e a] :: [%e z]]) [%code []] 19 | 20 | let () = 21 | Format.printf 22 | "@[%a@]@." 23 | Ppx_stage.print [%code fun arr1 -> [%e example [%code arr1]]] 24 | 25 | let cart = fun (arr1, arr2) -> 26 | of_arr arr1 27 | |> flat_map (fun x -> 28 | of_arr arr2 |> map (fun y -> [%code [%e x] * [%e y]])) 29 | |> fold (fun z a -> [%code [%e z] + [%e a]]) [%code 0] 30 | 31 | let () = 32 | let c = [%code fun arr1 arr2 -> [%e cart ([%code arr1],[%code arr2 ])]] in 33 | Format.printf 34 | "@[%a@]@." 35 | Ppx_stage.print c 36 | --------------------------------------------------------------------------------