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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
(** Copyright 2025-2026, Georgiy Belyanin, Ignat Sergeev *)
(** SPDX-License-Identifier: LGPL-3.0-or-later *)
module Scope = struct
include Set.Make (String)
end
module Ctx = struct
type t =
{ lifts : (Ast.pattern * Ast.pattern list * Ast.expr) list
; symbols : Scope.t
}
let gen ?prefix (ctx : t) =
let prefix = Option.value ~default:"_" prefix in
let v = Scope.cardinal ctx.symbols in
let rec aux off =
let name = String.concat "_" [ prefix; Int.to_string (v + off) ] in
if not (Scope.mem name ctx.symbols) then name else aux (off + 1)
in
aux 0
;;
let rec of_pattern = function
| Ast.PUnit | Plug -> Scope.empty
| Ident s -> Scope.singleton s
| PTuple patterns ->
List.map of_pattern patterns |> List.fold_left Scope.union Scope.empty
;;
let extend pattern (ctx : t) =
let names = of_pattern pattern in
{ ctx with symbols = Scope.union ctx.symbols names }
;;
let lift args body (ctx : t) =
let name = gen ctx in
let v = Ast.var name in
let name = Ast.ident name in
let ctx = extend name ctx in
v, { ctx with lifts = (name, args, body) :: ctx.lifts }
;;
let reset (ctx : t) = { ctx with lifts = [] }
let empty = { lifts = []; symbols = Scope.empty }
end
module State = struct
include State.M (Ctx)
let empty = Ctx.empty
let lift = Ctx.lift
let reset = Ctx.reset
let extend v ctx = put (Ctx.extend v ctx) ()
end
open State
let rec ll = function
| Ast.Const _ as c -> return c
| Var _ as v -> return v
| Tuple exprs ->
let rec ll_list = function
| [] -> return []
| hd :: tl ->
let* hd = ll hd in
let* tl = ll_list tl in
return (hd :: tl)
in
let* exprs = ll_list exprs in
return (Ast.tuple exprs)
| Fun (args', body') ->
let* body' = ll body' in
let* f = lift args' body' in
return f
| App (f, g) ->
let* f = ll f in
let* g = ll g in
let a = Ast.app f g in
return a
| Let (rec_flag, pattern, bind, body) ->
let* () =
match rec_flag with
| Ast.Rec -> extend pattern
| Ast.NonRec -> return ()
in
let* bind = ll bind in
let* () = extend pattern in
let* body = ll body in
let l = Ast.let_ rec_flag pattern bind body in
return l
| Ite (cond_, then_, else_) ->
let* cond_ = ll cond_ in
let* then_ = ll then_ in
let* else_ = ll else_ in
let ite = Ast.ite cond_ then_ else_ in
return ite
;;
let ll =
let ctx = ref empty in
List.concat_map (function Ast.LetDecl (rec_flag, pattern, body) ->
(ctx
:= match rec_flag with
| Ast.Rec -> extend pattern !ctx |> snd
| Ast.NonRec -> !ctx);
let lifts, ctx', body =
match body with
| Fun (args, body) ->
let body, ctx' = ll body !ctx in
ctx'.lifts, ctx', Ast.fun_ args body
| ast ->
let ast, ctx' = ll ast !ctx in
ctx'.lifts, ctx', ast
in
ctx := reset ctx';
ctx := extend pattern !ctx |> snd;
Ast.letdecl rec_flag pattern body
:: List.map
(fun (name, args, body) -> Ast.letdecl Ast.nonrec_ name (Ast.fun_ args body))
lifts
|> List.rev)
;;
let%expect_test "basic" =
let asts =
Fe.parse
{|
let f =
(fun q p ->
(fun q p a b c ->
let g =
(fun a -> fun d -> (+) a d) a
in
let h =
(fun g b -> fun e -> (+) b (g e)) g b
in
let i =
(fun p g h c -> fun f -> (+) ((+) ((+) c (h f)) (g f)) p) p g h c
in
i ((+) ((+) ((+) a b) c) q)) q p)
;;
|}
|> Result.map_error (fun err -> Format.printf "Error %s" err)
|> Result.get_ok
in
Format.printf
"%a"
(Format.pp_print_list ~pp_sep:Format.pp_print_newline Ast.pp_top_level)
(ll asts);
[%expect
{|
let __0 = fun a d -> (+) a d;;
let __2 = fun g b e -> (+) b (g e);;
let __4 = fun p g h c f -> (+) ((+) ((+) c (h f)) (g f)) p;;
let __6 =
fun q p a b c ->
let g =
__0 a
in
let h =
__2 g b
in
let i =
__4 p g h c
in
i ((+) ((+) ((+) a b) c) q)
;;
let f = fun q p -> __6 q p;;
|}]
;;