Skip to content

Commit 414ae0a

Browse files
engborisengboris
committed
Fix datatype of expr with locations
1 parent c3ed8e6 commit 414ae0a

File tree

3 files changed

+101
-109
lines changed

3 files changed

+101
-109
lines changed

‎bin/sgen.ml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -104,7 +104,7 @@ let watch input_file timeout =
104104
let preprocess_only input_file =
105105
let expr = parse input_file in
106106
let preprocessed = Expr.preprocess expr in
107-
preprocessed |> List.map ~f:Expr.to_string |> String.concat ~sep:"\n"
107+
preprocessed |> List.map ~f:(fun e -> Expr.to_string e.Expr.content) |> String.concat ~sep:"\n"
108108
|> Stdlib.print_endline
109109

110110
let input_file_arg =

‎src/expr.ml‎

Lines changed: 98 additions & 106 deletions
Original file line numberDiff line numberDiff line change
@@ -7,6 +7,12 @@ let ( let* ) x f = Result.bind x ~f
77

88
type ident = string
99

10+
(* Generic type for attaching source locations *)
11+
type 'a loc = {
12+
content : 'a;
13+
loc : source_location option;
14+
}
15+
1016
module Raw = struct
1117
type t =
1218
| Symbol of string
@@ -26,15 +32,13 @@ end
2632
type expr =
2733
| Symbol of string
2834
| Var of ident
29-
| List of expr list
30-
| WithPos of expr * source_location
35+
| List of (expr loc) list
3136

3237
let rec equal_expr e1 e2 =
3338
match (e1, e2) with
3439
| Symbol s1, Symbol s2 -> String.equal s1 s2
3540
| Var v1, Var v2 -> String.equal v1 v2
36-
| List l1, List l2 -> List.equal equal_expr l1 l2
37-
| WithPos (e1', _), e2' | e1', WithPos (e2', _) -> equal_expr e1' e2'
41+
| List l1, List l2 -> List.equal (fun a b -> equal_expr a.content b.content) l1 l2
3842
| _ -> false
3943

4044
let primitive = String.append "%"
@@ -65,58 +69,61 @@ let rec to_string : expr -> string = function
6569
| Symbol s -> s
6670
| Var x -> x
6771
| List es ->
68-
Printf.sprintf "(%s)" (List.map ~f:to_string es |> String.concat ~sep:" ")
69-
| WithPos (e, _) -> to_string e
70-
71-
let rec expand_macro : Raw.t -> expr = function
72-
| Raw.Symbol s -> Symbol s
73-
| Raw.Var x -> Var x
74-
| Raw.String s -> List [ Symbol string_op; Symbol s ]
75-
| Raw.Call e' -> List [ Symbol call_op; expand_macro e' ]
76-
| Raw.Focus e' -> List [ Symbol focus_op; expand_macro e' ]
77-
| Raw.Group es -> List (Symbol group_op :: List.map ~f:expand_macro es)
78-
| Raw.List es -> List (List.map ~f:expand_macro es)
72+
Printf.sprintf "(%s)" (List.map ~f:(fun e -> to_string e.content) es |> String.concat ~sep:" ")
73+
74+
let rec expand_macro : Raw.t -> expr loc = function
75+
| Raw.Symbol s -> { content = Symbol s; loc = None }
76+
| Raw.Var x -> { content = Var x; loc = None }
77+
| Raw.String s -> { content = List [ { content = Symbol string_op; loc = None }; { content = Symbol s; loc = None } ]; loc = None }
78+
| Raw.Call e' ->
79+
let e = expand_macro e' in
80+
{ content = List [ { content = Symbol call_op; loc = None }; e ]; loc = None }
81+
| Raw.Focus e' ->
82+
let e = expand_macro e' in
83+
{ content = List [ { content = Symbol focus_op; loc = None }; e ]; loc = None }
84+
| Raw.Group es ->
85+
{ content = List ({ content = Symbol group_op; loc = None } :: List.map ~f:expand_macro es); loc = None }
86+
| Raw.List es ->
87+
{ content = List (List.map ~f:expand_macro es); loc = None }
7988
| Raw.Cons es -> expand_macro (Raw.ConsWithBase (es, Symbol nil_op))
8089
| Raw.ConsWithBase (es, base) ->
8190
List.fold_left es ~init:(expand_macro base) ~f:(fun acc e ->
82-
List [ Symbol cons_op; expand_macro e; acc ] )
91+
{ content = List [ { content = Symbol cons_op; loc = None }; expand_macro e; acc ]; loc = None } )
8392
| Raw.ConsWithParams (es, ps) ->
84-
List [ Symbol params_op; expand_macro (Cons es); expand_macro (List ps) ]
85-
| Raw.Stack [] -> List []
93+
{ content = List [ { content = Symbol params_op; loc = None }; expand_macro (Cons es); expand_macro (List ps) ]; loc = None }
94+
| Raw.Stack [] -> { content = List []; loc = None }
8695
| Raw.Stack (h :: t) ->
8796
List.fold_left t ~init:(expand_macro h) ~f:(fun acc e ->
88-
List [ expand_macro e; acc ] )
97+
{ content = List [ expand_macro e; acc ]; loc = None } )
8998
| Raw.Positioned (e, start_pos, _) ->
90-
let loc =
99+
let source_loc =
91100
{ filename = start_pos.Lexing.pos_fname
92101
; line = start_pos.Lexing.pos_lnum
93102
; column = start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol + 1
94103
}
95104
in
96-
WithPos (expand_macro e, loc)
105+
let expanded = expand_macro e in
106+
{ expanded with loc = Some source_loc }
97107

98-
let rec replace_id (var_from : ident) replacement expr =
99-
match expr with
100-
| Var x when String.equal x var_from -> replacement
108+
let rec replace_id (var_from : ident) replacement (expr : expr loc) : expr loc =
109+
match expr.content with
110+
| Var x when String.equal x var_from -> { replacement with loc = expr.loc }
101111
| Symbol _ | Var _ -> expr
102-
| List exprs -> List (List.map exprs ~f:(replace_id var_from replacement))
103-
| WithPos (e, loc) -> WithPos (replace_id var_from replacement e, loc)
112+
| List exprs -> { content = List (List.map exprs ~f:(replace_id var_from replacement)); loc = expr.loc }
104113

105-
let unfold_decl_def (macro_env : (string * (string list * expr list)) list)
114+
let unfold_decl_def (macro_env : (string * (string list * (expr loc) list)) list)
106115
exprs =
107-
let rec process_expr (env, acc) = function
108-
| WithPos (e, loc) ->
109-
let env', result = process_expr (env, []) e in
110-
(env', List.map result ~f:(fun r -> WithPos (r, loc)) @ acc)
111-
| List (Symbol "new-declaration" :: List (Symbol macro_name :: args) :: body)
116+
let rec process_expr (env, acc) (expr : expr loc) =
117+
match expr.content with
118+
| List ({ content = Symbol "new-declaration"; _ } :: { content = List ({ content = Symbol macro_name; _ } :: args); _ } :: body)
112119
->
113120
let var_args =
114-
List.map args ~f:(function
121+
List.map args ~f:(fun arg -> match arg.content with
115122
| Var x -> x
116123
| _ -> failwith "error: syntax declaration must contain variables" )
117124
in
118125
((macro_name, (var_args, body)) :: env, acc)
119-
| List (Symbol macro_name :: call_args) as expr -> (
126+
| List ({ content = Symbol macro_name; _ } :: call_args) -> (
120127
match List.Assoc.find env macro_name ~equal:String.equal with
121128
| Some (formal_params, body) ->
122129
if List.length formal_params <> List.length call_args then
@@ -126,16 +133,16 @@ let unfold_decl_def (macro_env : (string * (string list * expr list)) list)
126133
(List.length formal_params)
127134
(List.length call_args) )
128135
else
129-
let apply_substitution expr =
130-
List.fold_left (List.zip_exn formal_params call_args) ~init:expr
136+
let apply_substitution e =
137+
List.fold_left (List.zip_exn formal_params call_args) ~init:e
131138
~f:(fun acc (param, arg) -> replace_id param arg acc )
132139
in
133140
let expanded = List.map body ~f:apply_substitution |> List.rev in
134141
(env, expanded @ acc)
135142
| None -> (env, expr :: acc) )
136-
| expr -> (env, expr :: acc)
143+
| _ -> (env, expr :: acc)
137144
in
138-
List.fold_left exprs ~init:(macro_env, []) ~f:process_expr |> snd |> List.rev
145+
List.fold_left exprs ~init:(macro_env, []) ~f:(fun (env, acc) e -> process_expr (env, acc) e) |> snd |> List.rev
139146

140147
(* ---------------------------------------
141148
Constellation of Expr
@@ -152,49 +159,45 @@ let rec ray_of_expr : expr -> (ray, expr_err) Result.t = function
152159
| Var "_" -> to_var ("_" ^ fresh_placeholder ()) |> Result.return
153160
| Var s -> to_var s |> Result.return
154161
| List [] -> Error EmptyRay
155-
| List (Symbol h :: t) ->
156-
let* args = List.map ~f:ray_of_expr t |> Result.all in
162+
| List ({ content = Symbol h; _ } :: t) ->
163+
let* args = List.map ~f:(fun e -> ray_of_expr e.content) t |> Result.all in
157164
to_func (symbol_of_str h, args) |> Result.return
158165
| List (_ :: _) as e -> Error (NonConstantRayHeader (to_string e))
159-
| WithPos (e, _) -> ray_of_expr e
160166

161167
let bans_of_expr ban_exprs : (ban list, expr_err) Result.t =
162168
let rec ban_of_expr = function
163-
| List [ Symbol op; expr1; expr2 ] when String.equal op ineq_op ->
164-
let* ray1 = ray_of_expr expr1 in
165-
let* ray2 = ray_of_expr expr2 in
169+
| List [ { content = Symbol op; _ }; expr1; expr2 ] when String.equal op ineq_op ->
170+
let* ray1 = ray_of_expr expr1.content in
171+
let* ray2 = ray_of_expr expr2.content in
166172
Ineq (ray1, ray2) |> Result.return
167-
| List [ Symbol op; expr1; expr2 ] when String.equal op incomp_op ->
168-
let* ray1 = ray_of_expr expr1 in
169-
let* ray2 = ray_of_expr expr2 in
173+
| List [ { content = Symbol op; _ }; expr1; expr2 ] when String.equal op incomp_op ->
174+
let* ray1 = ray_of_expr expr1.content in
175+
let* ray2 = ray_of_expr expr2.content in
170176
Incomp (ray1, ray2) |> Result.return
171-
| WithPos (e, _) -> ban_of_expr e
172177
| invalid_expr -> Error (InvalidBan (to_string invalid_expr))
173178
in
174-
List.map ban_exprs ~f:ban_of_expr |> Result.all
179+
List.map ban_exprs ~f:(fun e -> ban_of_expr e.content) |> Result.all
175180

176181
let rec raylist_of_expr expr : (ray list, expr_err) Result.t =
177182
match expr with
178183
| Symbol k when String.equal k nil_op -> Ok []
179184
| Symbol _ | Var _ ->
180185
let* ray = ray_of_expr expr in
181186
Ok [ ray ]
182-
| List [ Symbol op; head; tail ] when String.equal op cons_op ->
183-
let* head_ray = ray_of_expr head in
184-
let* tail_rays = raylist_of_expr tail in
187+
| List [ { content = Symbol op; _ }; head; tail ] when String.equal op cons_op ->
188+
let* head_ray = ray_of_expr head.content in
189+
let* tail_rays = raylist_of_expr tail.content in
185190
Ok (head_ray :: tail_rays)
186-
| WithPos (e, _) -> raylist_of_expr e
187191
| invalid -> Error (InvalidRaylist (to_string invalid))
188192

189193
let rec star_of_expr : expr -> (Marked.star, expr_err) Result.t = function
190-
| List [ Symbol k; s ] when equal_string k focus_op ->
191-
let* ss = star_of_expr s in
194+
| List [ { content = Symbol k; _ }; s ] when equal_string k focus_op ->
195+
let* ss = star_of_expr s.content in
192196
ss |> Marked.remove |> Marked.make_state |> Result.return
193-
| List [ Symbol k; s; List ps ] when equal_string k params_op ->
194-
let* content = raylist_of_expr s in
197+
| List [ { content = Symbol k; _ }; s; { content = List ps; _ } ] when equal_string k params_op ->
198+
let* content = raylist_of_expr s.content in
195199
let* bans = bans_of_expr ps in
196200
Marked.Action { content; bans } |> Result.return
197-
| WithPos (e, _) -> star_of_expr e
198201
| e ->
199202
let* content = raylist_of_expr e in
200203
Marked.Action { content; bans = [] } |> Result.return
@@ -207,14 +210,13 @@ let rec constellation_of_expr :
207210
| Var x ->
208211
[ Marked.Action { content = [ var (x, None) ]; bans = [] } ]
209212
|> Result.return
210-
| List [ Symbol s; h; t ] when equal_string s cons_op ->
211-
let* sh = star_of_expr h in
212-
let* ct = constellation_of_expr t in
213+
| List [ { content = Symbol s; _ }; h; t ] when equal_string s cons_op ->
214+
let* sh = star_of_expr h.content in
215+
let* ct = constellation_of_expr t.content in
213216
Ok (sh :: ct)
214217
| List g ->
215218
let* rg = ray_of_expr (List g) in
216219
[ Marked.Action { content = [ rg ]; bans = [] } ] |> Result.return
217-
| WithPos (e, _) -> constellation_of_expr e
218220

219221
(* ---------------------------------------
220222
Stellogen expr of Expr
@@ -227,34 +229,33 @@ let rec sgen_expr_of_expr expr : (sgen_expr, expr_err) Result.t =
227229
| Var _ | Symbol _ ->
228230
let* ray = ray_of_expr expr in
229231
Raw [ Action { content = [ ray ]; bans = [] } ] |> Result.return
230-
| List (Symbol op :: _) when String.equal op params_op ->
232+
| List ({ content = Symbol op; _ } :: _) when String.equal op params_op ->
231233
let* star = star_of_expr expr in
232234
Raw [ star ] |> Result.return
233-
| List (Symbol op :: _) when String.equal op cons_op ->
235+
| List ({ content = Symbol op; _ } :: _) when String.equal op cons_op ->
234236
let* star = star_of_expr expr in
235237
Raw [ star ] |> Result.return
236-
| List [ Symbol op; arg ] when String.equal op call_op ->
237-
let* ray = ray_of_expr arg in
238+
| List [ { content = Symbol op; _ }; arg ] when String.equal op call_op ->
239+
let* ray = ray_of_expr arg.content in
238240
Call ray |> Result.return
239-
| List [ Symbol op; arg ] when String.equal op focus_op ->
240-
let* sgen_expr = sgen_expr_of_expr arg in
241+
| List [ { content = Symbol op; _ }; arg ] when String.equal op focus_op ->
242+
let* sgen_expr = sgen_expr_of_expr arg.content in
241243
Focus sgen_expr |> Result.return
242-
| List (Symbol op :: args) when String.equal op group_op ->
243-
let* sgen_exprs = List.map args ~f:sgen_expr_of_expr |> Result.all in
244+
| List ({ content = Symbol op; _ } :: args) when String.equal op group_op ->
245+
let* sgen_exprs = List.map args ~f:(fun e -> sgen_expr_of_expr e.content) |> Result.all in
244246
Group sgen_exprs |> Result.return
245-
| List (Symbol "process" :: args) ->
246-
let* sgen_exprs = List.map args ~f:sgen_expr_of_expr |> Result.all in
247+
| List ({ content = Symbol "process"; _ } :: args) ->
248+
let* sgen_exprs = List.map args ~f:(fun e -> sgen_expr_of_expr e.content) |> Result.all in
247249
Process sgen_exprs |> Result.return
248-
| List (Symbol "interact" :: args) ->
249-
let* sgen_exprs = List.map args ~f:sgen_expr_of_expr |> Result.all in
250+
| List ({ content = Symbol "interact"; _ } :: args) ->
251+
let* sgen_exprs = List.map args ~f:(fun e -> sgen_expr_of_expr e.content) |> Result.all in
250252
Exec (false, Group sgen_exprs) |> Result.return
251-
| List (Symbol "fire" :: args) ->
252-
let* sgen_exprs = List.map args ~f:sgen_expr_of_expr |> Result.all in
253+
| List ({ content = Symbol "fire"; _ } :: args) ->
254+
let* sgen_exprs = List.map args ~f:(fun e -> sgen_expr_of_expr e.content) |> Result.all in
253255
Exec (true, Group sgen_exprs) |> Result.return
254-
| List [ Symbol "eval"; arg ] ->
255-
let* sgen_expr = sgen_expr_of_expr arg in
256+
| List [ { content = Symbol "eval"; _ }; arg ] ->
257+
let* sgen_expr = sgen_expr_of_expr arg.content in
256258
Eval sgen_expr |> Result.return
257-
| WithPos (e, _) -> sgen_expr_of_expr e
258259
| List _ as list_expr ->
259260
let* constellation = constellation_of_expr list_expr in
260261
Raw constellation |> Result.return
@@ -263,37 +264,28 @@ let rec sgen_expr_of_expr expr : (sgen_expr, expr_err) Result.t =
263264
Stellogen program of Expr
264265
--------------------------------------- *)
265266

266-
let rec decl_of_expr : expr -> (declaration, expr_err) Result.t = function
267-
| WithPos (List [ Symbol op; expr1; expr2 ], loc)
267+
let rec decl_of_expr (expr : expr loc) : (declaration, expr_err) Result.t =
268+
match expr.content with
269+
| List [ { content = Symbol op; _ }; expr1; expr2 ]
268270
when String.equal op expect_op ->
269-
let* sgen_expr1 = sgen_expr_of_expr expr1 in
270-
let* sgen_expr2 = sgen_expr_of_expr expr2 in
271-
Expect (sgen_expr1, sgen_expr2, const "default", Some loc) |> Result.return
272-
| WithPos (List [ Symbol op; expr1; expr2; message ], loc)
271+
let* sgen_expr1 = sgen_expr_of_expr expr1.content in
272+
let* sgen_expr2 = sgen_expr_of_expr expr2.content in
273+
Expect (sgen_expr1, sgen_expr2, const "default", expr.loc) |> Result.return
274+
| List [ { content = Symbol op; _ }; expr1; expr2; message ]
273275
when String.equal op expect_op ->
274-
let* sgen_expr1 = sgen_expr_of_expr expr1 in
275-
let* sgen_expr2 = sgen_expr_of_expr expr2 in
276-
let* message_ray = ray_of_expr message in
277-
Expect (sgen_expr1, sgen_expr2, message_ray, Some loc) |> Result.return
278-
| WithPos (e, _) -> decl_of_expr e
279-
| List [ Symbol op; identifier; value ] when String.equal op def_op ->
280-
let* id_ray = ray_of_expr identifier in
281-
let* value_expr = sgen_expr_of_expr value in
276+
let* sgen_expr1 = sgen_expr_of_expr expr1.content in
277+
let* sgen_expr2 = sgen_expr_of_expr expr2.content in
278+
let* message_ray = ray_of_expr message.content in
279+
Expect (sgen_expr1, sgen_expr2, message_ray, expr.loc) |> Result.return
280+
| List [ { content = Symbol op; _ }; identifier; value ] when String.equal op def_op ->
281+
let* id_ray = ray_of_expr identifier.content in
282+
let* value_expr = sgen_expr_of_expr value.content in
282283
Def (id_ray, value_expr) |> Result.return
283-
| List [ Symbol "show"; arg ] ->
284-
let* sgen_expr = sgen_expr_of_expr arg in
284+
| List [ { content = Symbol "show"; _ }; arg ] ->
285+
let* sgen_expr = sgen_expr_of_expr arg.content in
285286
Show sgen_expr |> Result.return
286-
| List [ Symbol op; expr1; expr2 ] when String.equal op expect_op ->
287-
let* sgen_expr1 = sgen_expr_of_expr expr1 in
288-
let* sgen_expr2 = sgen_expr_of_expr expr2 in
289-
Expect (sgen_expr1, sgen_expr2, const "default", None) |> Result.return
290-
| List [ Symbol op; expr1; expr2; message ] when String.equal op expect_op ->
291-
let* sgen_expr1 = sgen_expr_of_expr expr1 in
292-
let* sgen_expr2 = sgen_expr_of_expr expr2 in
293-
let* message_ray = ray_of_expr message in
294-
Expect (sgen_expr1, sgen_expr2, message_ray, None) |> Result.return
295-
| List [ Symbol "use"; path ] ->
296-
let* path_ray = ray_of_expr path in
287+
| List [ { content = Symbol "use"; _ }; path ] ->
288+
let* path_ray = ray_of_expr path.content in
297289
Use path_ray |> Result.return
298290
| invalid -> Error (InvalidDeclaration (to_string invalid))
299291

‎src/sgen_eval.ml‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -222,12 +222,12 @@ let rec eval_sgen_expr (env : env) :
222222
^ string_of_constellation (Marked.remove_all e)
223223
^ " is not a ray." ) )
224224

225-
and expr_of_ray = function
225+
and expr_of_ray : ray -> Expr.expr = function
226226
| Var (x, None) -> Expr.Var x
227227
| Var (x, Some i) -> Expr.Var (x ^ Int.to_string i)
228228
| Func (pf, []) -> Symbol (string_of_polsym pf)
229229
| Func (pf, args) ->
230-
Expr.List (Symbol (string_of_polsym pf) :: List.map ~f:expr_of_ray args)
230+
Expr.List ({ Expr.content = Symbol (string_of_polsym pf); loc = None } :: List.map ~f:(fun r -> { Expr.content = expr_of_ray r; loc = None }) args)
231231

232232
let rec eval_decl env : declaration -> (env, err) Result.t = function
233233
| Def (identifier, expr) -> Ok { objs = add_obj env identifier expr }

0 commit comments

Comments
 (0)