Skip to content

Commit

Permalink
Upgrade
Browse files Browse the repository at this point in the history 
Signed-off-by: Jeremie Dimino <[email protected]>
  • Loading branch information
@jeremiedimino
jeremiedimino committed Dec 9, 2019
1 parent 7ef0b53 commit 9650262
Show file tree
Hide file tree
Showing 5 changed files with 133 additions and 143 deletions.
2 changes: 1 addition & 1 deletion .ocamlformat
View file
Original file line number Diff line number Diff line change
@@ -1 +1 @@
version=0.11.0
version=0.12
3 changes: 1 addition & 2 deletions dune-project
View file
Original file line number Diff line number Diff line change
@@ -1,8 +1,7 @@
(lang dune 1.11)
(lang dune 2.0)
(name ocaml-syntax-shims)

(generate_opam_files true)
(using fmt 1.2)

(license "MIT")
(maintainers [email protected])
Expand Down
2 changes: 1 addition & 1 deletion ocaml-syntax-shims.opam
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,7 @@ homepage: "https://github.com/ocaml-ppx/ocaml-syntax-shims"
doc: "https://ocaml-ppx.github.io/ocaml-syntax-shims/"
bug-reports: "https://github.com/ocaml-ppx/ocaml-syntax-shims/issues"
depends: [
"dune" {>= "1.11"}
"dune" {>= "2.0"}
"ocaml" {>= "4.02.3"}
]
build: [
Expand Down
257 changes: 127 additions & 130 deletions src/pp.real.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,11 +16,7 @@ module Wrap_lexer = struct
lexbuf.lex_curr_p <- loc.loc_end

let encode_op (tok : Parser.token) op =
( match tok with
| LET -> "let__"
| AND -> "and__"
| _ -> assert false )
^ op
(match tok with LET -> "let__" | AND -> "and__" | _ -> assert false) ^ op

let pending = Queue.create ()

Expand All @@ -35,46 +31,45 @@ module Wrap_lexer = struct
if not (Queue.is_empty pending) then (
let tok, loc = Queue.pop pending in
restore_loc lb loc;
tok
) else
tok )
else
match lexer lb with
| (LET | AND) as tok ->
let loc = save_loc lb in
( match Let_trail.op lb with
| None -> ()
| Some op -> register_custom_operator tok op loc (save_loc lb) );
restore_loc lb loc;
tok
let loc = save_loc lb in
( match Let_trail.op lb with
| None -> ()
| Some op -> register_custom_operator tok op loc (save_loc lb) );
restore_loc lb loc;
tok
| LPAREN ->
let loc1 = save_loc lb in
let tok2 = lexer lb in
let loc2 = save_loc lb in
let tok, loc =
match tok2 with
| LET
|AND -> (
match Let_trail.op lb with
| None ->
add (tok2, loc2);
(Parser.LPAREN, loc1)
| Some op -> (
let loc3 = save_loc lb in
match lexer lb with
| RPAREN ->
( LIDENT (encode_op tok2 op)
, { loc2 with loc_end = loc3.loc_end } )
| tok4 ->
let loc4 = save_loc lb in
let loc1 = save_loc lb in
let tok2 = lexer lb in
let loc2 = save_loc lb in
let tok, loc =
match tok2 with
| LET | AND -> (
match Let_trail.op lb with
| None ->
add (tok2, loc2);
(Parser.LPAREN, loc1)
| Some op -> (
let loc3 = save_loc lb in
match lexer lb with
| RPAREN ->
( LIDENT (encode_op tok2 op),
{ loc2 with loc_end = loc3.loc_end } )
| tok4 ->
let loc4 = save_loc lb in
add (tok2, loc2);
add (tok4, loc4);
register_custom_operator tok2 op loc2 loc3;
(LPAREN, loc1) ) )
| _ ->
add (tok2, loc2);
add (tok4, loc4);
register_custom_operator tok2 op loc2 loc3;
(LPAREN, loc1) ) )
| _ ->
add (tok2, loc2);
(LPAREN, loc1)
in
restore_loc lb loc;
tok
(LPAREN, loc1)
in
restore_loc lb loc;
tok
| tok -> tok

let () = Lexer.set_preprocessor (fun () -> Queue.clear pending) wrap
Expand All @@ -97,74 +92,76 @@ module Map_ast = struct
let expr =
match expr.pexp_desc with
| Pexp_let (rf, (vb :: _ as vbs), body) -> (
match get_op vb with
| None -> expr
| Some op ->
if rf = Recursive then
Location.raise_errorf ~loc:expr.pexp_loc
"Custom 'let' operators cannot be recursive";
let patts, exprs =
List.map vbs ~f:(fun vb ->
let { pvb_pat = patt
; pvb_expr = expr
; pvb_attributes = attrs
; pvb_loc = loc
match get_op vb with
| None -> expr
| Some op ->
if rf = Recursive then
Location.raise_errorf ~loc:expr.pexp_loc
"Custom 'let' operators cannot be recursive";
let patts, exprs =
List.map vbs ~f:(fun vb ->
let {
pvb_pat = patt;
pvb_expr = expr;
pvb_attributes = attrs;
pvb_loc = loc;
} =
vb
in
( match attrs with
| [] -> ()
| ({ loc; _ }, _) :: _ ->
Location.raise_errorf ~loc
"This attribute will be discarded" );
let op =
match get_op vb with
| Some op ->
Hashtbl.remove custom_operators vb.pvb_loc.loc_start;
op
| None ->
Location.raise_errorf ~loc
"Custom 'and' operator expected, got stantard 'and' \
keyword"
in
(patt, (loc, op, expr)))
|> List.split
in
let patt =
List.fold_left (List.tl patts) ~init:(List.hd patts)
~f:(fun acc patt ->
let loc = patt.ppat_loc in
Pat.tuple ~loc [ acc; patt ])
in
let vars =
List.mapi exprs ~f:(fun i _ ->
Printf.sprintf "__future_syntax__%d__" i)
in
let pvars =
List.map2 vars patts ~f:(fun v p ->
let loc = { p.ppat_loc with loc_ghost = true } in
Pat.var ~loc { txt = v; loc })
in
let evars =
List.map2 vars exprs ~f:(fun v (_, _, e) ->
let loc = { e.pexp_loc with loc_ghost = true } in
Exp.ident ~loc { txt = Lident v; loc })
in
let expr =
List.fold_left2 (List.tl evars) (List.tl exprs)
~init:(List.hd evars) ~f:(fun acc var (loc, op, _) ->
Exp.apply ~loc op [ (nolabel, acc); (nolabel, var) ])
in
let body =
let loc = expr.pexp_loc in
Exp.apply ~loc op
[ (nolabel, expr)
; (nolabel, Exp.fun_ ~loc nolabel None patt body)
]
in
List.fold_right2 pvars exprs ~init:body
~f:(fun var (loc, _, expr) acc ->
Exp.let_ Nonrecursive ~loc [ Vb.mk ~loc var expr ] acc) )
vb
in
( match attrs with
| [] -> ()
| ({ loc; _ }, _) :: _ ->
Location.raise_errorf ~loc
"This attribute will be discarded" );
let op =
match get_op vb with
| Some op ->
Hashtbl.remove custom_operators vb.pvb_loc.loc_start;
op
| None ->
Location.raise_errorf ~loc
"Custom 'and' operator expected, got stantard \
'and' keyword"
in
(patt, (loc, op, expr)))
|> List.split
in
let patt =
List.fold_left (List.tl patts) ~init:(List.hd patts)
~f:(fun acc patt ->
let loc = patt.ppat_loc in
Pat.tuple ~loc [ acc; patt ])
in
let vars =
List.mapi exprs ~f:(fun i _ ->
Printf.sprintf "__future_syntax__%d__" i)
in
let pvars =
List.map2 vars patts ~f:(fun v p ->
let loc = { p.ppat_loc with loc_ghost = true } in
Pat.var ~loc { txt = v; loc })
in
let evars =
List.map2 vars exprs ~f:(fun v (_, _, e) ->
let loc = { e.pexp_loc with loc_ghost = true } in
Exp.ident ~loc { txt = Lident v; loc })
in
let expr =
List.fold_left2 (List.tl evars) (List.tl exprs)
~init:(List.hd evars) ~f:(fun acc var (loc, op, _) ->
Exp.apply ~loc op [ (nolabel, acc); (nolabel, var) ])
in
let body =
let loc = expr.pexp_loc in
Exp.apply ~loc op
[
(nolabel, expr);
(nolabel, Exp.fun_ ~loc nolabel None patt body);
]
in
List.fold_right2 pvars exprs ~init:body
~f:(fun var (loc, _, expr) acc ->
Exp.let_ Nonrecursive ~loc [ Vb.mk ~loc var expr ] acc) )
| _ -> expr
in
super.expr self expr
Expand All @@ -174,8 +171,7 @@ module Map_ast = struct
let map f ast =
let ast = f mapper ast in
let fail _ (loc, _) =
Location.raise_errorf ~loc
"Invalid use of custom 'let' or 'and' operator"
Location.raise_errorf ~loc "Invalid use of custom 'let' or 'and' operator"
in
Hashtbl.iter fail custom_operators;
ast
Expand All @@ -194,22 +190,22 @@ let process_file fn ~magic ~parse ~print ~map ~mk_ext =
with exn -> (
match error_of_exn exn with
| Some error ->
if !dump_ast then
[ mk_ext ?loc:None ?attrs:None (Ast_mapper.extension_of_error error) ]
else (
Location.report_error Format.err_formatter error;
exit 1
)
if !dump_ast then
[
mk_ext ?loc:None ?attrs:None (Ast_mapper.extension_of_error error);
]
else (
Location.report_error Format.err_formatter error;
exit 1 )
| None -> raise exn )
in
if !dump_ast then (
set_binary_mode_out stdout true;
output_string stdout magic;
output_value stdout fn;
output_value stdout ast;
flush stdout
) else
Format.printf "%a@?" print ast
flush stdout )
else Format.printf "%a@?" print ast

let process_file fn =
let ext =
Expand All @@ -219,23 +215,24 @@ let process_file fn =
in
match ext with
| ".ml" ->
process_file fn ~magic:Config.ast_impl_magic_number
~parse:Parse.implementation ~print:Pprintast.structure
~map:Map_ast.structure ~mk_ext:Ast_helper.Str.extension
process_file fn ~magic:Config.ast_impl_magic_number
~parse:Parse.implementation ~print:Pprintast.structure
~map:Map_ast.structure ~mk_ext:Ast_helper.Str.extension
| ".mli" ->
process_file fn ~magic:Config.ast_intf_magic_number ~parse:Parse.interface
~print:Pprintast.signature ~map:Map_ast.signature
~mk_ext:Ast_helper.Sig.extension
process_file fn ~magic:Config.ast_intf_magic_number ~parse:Parse.interface
~print:Pprintast.signature ~map:Map_ast.signature
~mk_ext:Ast_helper.Sig.extension
| _ ->
Printf.eprintf "%s: Don't know what to do with %s.\n%!" prog_name fn;
exit 2
Printf.eprintf "%s: Don't know what to do with %s.\n%!" prog_name fn;
exit 2

let () =
let args =
Arg.align
[ ( "-dump-ast"
, Arg.Set dump_ast
, " Output a binary AST rather than a pretty-printed source file" )
[
( "-dump-ast",
Arg.Set dump_ast,
" Output a binary AST rather than a pretty-printed source file" );
]
in
let usage = Printf.sprintf "Usage: %s [-dump-ast] FILES" prog_name in
Expand Down
12 changes: 3 additions & 9 deletions test/test.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,9 +3,7 @@ let ( let+ ) x f = `Let (x, f)
let ( and+ ) a b = `And (a, b)

let t =
let+ x = 1
and+ y = 2
and+ z = 3 in
let+ x = 1 and+ y = 2 and+ z = 3 in
(x, y, z)

let () =
Expand All @@ -22,12 +20,8 @@ let ( and+ ) a b = (a, b)
let () =
let q1 = Queue.create () in
let q2 = Queue.create () in
let () = Queue.add 1 q1
and () = Queue.add 2 q1
and () = Queue.add 3 q1 in
let+ () = Queue.add 1 q2
and+ () = Queue.add 2 q2
and+ () = Queue.add 3 q2 in
let () = Queue.add 1 q1 and () = Queue.add 2 q1 and () = Queue.add 3 q1 in
let+ () = Queue.add 1 q2 and+ () = Queue.add 2 q2 and+ () = Queue.add 3 q2 in
let l1 = Queue.fold (fun l x -> x :: l) [] q1 in
let l2 = Queue.fold (fun l x -> x :: l) [] q2 in
assert (l1 = l2)

0 comments on commit 9650262

Please sign in to comment.