1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
exception UnsupportedAst of string
let raise_unsupported_ast (type a) (f : Format.formatter -> a -> unit) (x : a) =
let buf = Buffer.create 16 in
let fmt = Format.formatter_of_buffer buf in
f fmt x;
Format.pp_print_flush fmt ();
raise (UnsupportedAst (Buffer.contents buf))
let raise_unsupported_expr = raise_unsupported_ast (Printast.expression 0)
type 'a index = { index : int } [@@deriving show { with_path = false }]
let get (arr : 'a Arraylist.t) (i : 'a index) : 'a = Arraylist.get arr i.index
type prim = [ `Add ] [@@deriving show { with_path = false }]
type expr =
| App of expr index * expr index
| Int of int
| Lam of string * expr index
| Prim of prim
| Var of string
[@@deriving show { with_path = false }]
type 'a ast = { subexprs : expr Arraylist.t; mutable root : 'a index }
[@@deriving show { with_path = false }]
let get_subexpr (ast : 'a ast) : expr index -> expr = get ast.subexprs
let new_ast () =
{ subexprs = Arraylist.make 0 (Var "<placeholder>"); root = { index = 0 } }
let add_expr_to_ast (ast : 'a ast) : Parsetree.expression -> expr index =
let add (expr : expr) : expr index =
let index = Arraylist.length ast.subexprs in
Arraylist.push ast.subexprs expr;
{ index }
in
let rec loop (expr : Parsetree.expression) : expr index =
match expr.pexp_desc with
| Pexp_apply (f, xs) ->
List.fold_left
(fun f -> function
| Asttypes.Nolabel, x -> add (App (f, loop x))
| _ -> raise_unsupported_expr expr)
(loop f) xs
| Pexp_constant (Pconst_integer (n, None)) -> add (Int (int_of_string n))
| Pexp_fun (Nolabel, None, arg_pat, body) -> (
match arg_pat.ppat_desc with
| Ppat_var { txt = name; _ } -> add (Lam (name, loop body))
| _ -> raise_unsupported_expr expr)
| Pexp_ident { txt = Lident "+"; _ } -> add (Prim `Add)
| Pexp_ident { txt = Lident name; _ } -> add (Var name)
| _ -> raise_unsupported_expr expr
in
loop
let expr_of_parsetree (expr : Parsetree.expression) : expr ast =
let ast = new_ast () in
ast.root <- add_expr_to_ast ast expr;
ast
module Wrap = struct
let expression (pexp_desc : Parsetree.expression_desc) : Parsetree.expression
=
{
pexp_desc;
pexp_loc = Location.none;
pexp_loc_stack = [];
pexp_attributes = [];
}
let ident (name : string) : Longident.t Asttypes.loc =
{ txt = Lident name; loc = Location.none }
let pattern (ppat_desc : Parsetree.pattern_desc) : Parsetree.pattern =
{
ppat_desc;
ppat_loc = Location.none;
ppat_loc_stack = [];
ppat_attributes = [];
}
let var (name : string) : string Asttypes.loc =
{ txt = name; loc = Location.none }
end
let parsetree_of_subexpr (ast : 'a ast) : expr -> Parsetree.expression =
let subexpr = get_subexpr ast in
let list_of_apps expr =
let rec loop = function
| App (f, x) ->
let f, xs = loop (subexpr f) in
(f, x :: xs)
| f -> (f, [])
in
let f, xs = loop expr in
(f, List.rev xs)
in
let rec loop : expr -> Parsetree.expression = function
| App (_, _) as expr ->
let f, xs = list_of_apps expr in
let xs = List.map (fun x -> (Asttypes.Nolabel, loop (subexpr x))) xs in
Wrap.expression (Pexp_apply (loop f, xs))
| Int n ->
Wrap.expression (Pexp_constant (Pconst_integer (Int.to_string n, None)))
| Lam (x, b) ->
Wrap.expression
(Pexp_fun
( Nolabel,
None,
Wrap.pattern (Ppat_var (Wrap.var x)),
loop (subexpr b) ))
| Prim `Add -> Wrap.expression (Pexp_ident (Wrap.ident "+"))
| Var name -> Wrap.expression (Pexp_ident (Wrap.ident name))
in
loop
let parsetree_of_expr (ast : expr ast) : Parsetree.expression =
parsetree_of_subexpr ast (get_subexpr ast ast.root)
|
