827 lines
31 KiB
OCaml
827 lines
31 KiB
OCaml
(* pa_r.cmo q_MLast.cmo pa_extfun.cmo pr_dump.cmo *)
|
|
(***********************************************************************)
|
|
(* *)
|
|
(* Camlp4 *)
|
|
(* *)
|
|
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
|
|
(* *)
|
|
(* Copyright 2002 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
(* under the terms of the GNU Library General Public License, with *)
|
|
(* the special exception on linking described in file *)
|
|
(* ../../../LICENSE. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
|
|
open Pcaml;
|
|
open Format;
|
|
|
|
type printer_t 'a =
|
|
{ pr_fun : mutable string -> next 'a;
|
|
pr_levels : mutable list (pr_level 'a) }
|
|
and pr_level 'a =
|
|
{ pr_label : string;
|
|
pr_box : formatter -> (formatter -> unit) -> 'a -> unit;
|
|
pr_rules : mutable pr_rule 'a }
|
|
and pr_rule 'a =
|
|
Extfun.t 'a (formatter -> curr 'a -> next 'a -> string -> kont -> unit)
|
|
and curr 'a = formatter -> ('a * string * kont) -> unit
|
|
and next 'a = formatter -> ('a * string * kont) -> unit
|
|
and kont = formatter -> unit;
|
|
|
|
value not_impl name x ppf k =
|
|
let desc =
|
|
if Obj.is_block (Obj.repr x) then
|
|
"tag = " ^ string_of_int (Obj.tag (Obj.repr x))
|
|
else "int_val = " ^ string_of_int (Obj.magic x)
|
|
in
|
|
fprintf ppf "<pr_scheme: not impl: %s; %s>%t" name desc k
|
|
;
|
|
|
|
value pr_fun name pr lab =
|
|
loop False pr.pr_levels where rec loop app =
|
|
fun
|
|
[ [] -> fun ppf (x, dg, k) -> failwith ("unable to print " ^ name)
|
|
| [lev :: levl] ->
|
|
if app || lev.pr_label = lab then
|
|
let next = loop True levl in
|
|
let rec curr ppf (x, dg, k) =
|
|
Extfun.apply lev.pr_rules x ppf curr next dg k
|
|
in
|
|
fun ppf ((x, _, _) as n) -> lev.pr_box ppf (fun ppf -> curr ppf n) x
|
|
else loop app levl ]
|
|
;
|
|
|
|
value rec find_pr_level lab =
|
|
fun
|
|
[ [] -> failwith ("level " ^ lab ^ " not found")
|
|
| [lev :: levl] ->
|
|
if lev.pr_label = lab then lev else find_pr_level lab levl ]
|
|
;
|
|
|
|
value pr_constr_decl = {pr_fun = fun []; pr_levels = []};
|
|
value constr_decl ppf (x, k) = pr_constr_decl.pr_fun "top" ppf (x, "", k);
|
|
pr_constr_decl.pr_fun := pr_fun "constr_decl" pr_constr_decl;
|
|
|
|
value pr_ctyp = {pr_fun = fun []; pr_levels = []};
|
|
pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp;
|
|
value ctyp ppf (x, k) = pr_ctyp.pr_fun "top" ppf (x, "", k);
|
|
|
|
value pr_expr = {pr_fun = fun []; pr_levels = []};
|
|
pr_expr.pr_fun := pr_fun "expr" pr_expr;
|
|
value expr ppf (x, k) = pr_expr.pr_fun "top" ppf (x, "", k);
|
|
|
|
value pr_label_decl = {pr_fun = fun []; pr_levels = []};
|
|
value label_decl ppf (x, k) = pr_label_decl.pr_fun "top" ppf (x, "", k);
|
|
pr_label_decl.pr_fun := pr_fun "label_decl" pr_label_decl;
|
|
|
|
value pr_let_binding = {pr_fun = fun []; pr_levels = []};
|
|
pr_let_binding.pr_fun := pr_fun "let_binding" pr_let_binding;
|
|
value let_binding ppf (x, k) = pr_let_binding.pr_fun "top" ppf (x, "", k);
|
|
|
|
value pr_match_assoc = {pr_fun = fun []; pr_levels = []};
|
|
pr_match_assoc.pr_fun := pr_fun "match_assoc" pr_match_assoc;
|
|
value match_assoc ppf (x, k) = pr_match_assoc.pr_fun "top" ppf (x, "", k);
|
|
|
|
value pr_mod_ident = {pr_fun = fun []; pr_levels = []};
|
|
pr_mod_ident.pr_fun := pr_fun "mod_ident" pr_mod_ident;
|
|
value mod_ident ppf (x, k) = pr_mod_ident.pr_fun "top" ppf (x, "", k);
|
|
|
|
value pr_module_binding = {pr_fun = fun []; pr_levels = []};
|
|
pr_module_binding.pr_fun := pr_fun "module_binding" pr_module_binding;
|
|
value module_binding ppf (x, k) =
|
|
pr_module_binding.pr_fun "top" ppf (x, "", k);
|
|
|
|
value pr_module_expr = {pr_fun = fun []; pr_levels = []};
|
|
pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr;
|
|
value module_expr ppf (x, k) = pr_module_expr.pr_fun "top" ppf (x, "", k);
|
|
|
|
value pr_module_type = {pr_fun = fun []; pr_levels = []};
|
|
pr_module_type.pr_fun := pr_fun "module_type" pr_module_type;
|
|
value module_type ppf (x, k) = pr_module_type.pr_fun "top" ppf (x, "", k);
|
|
|
|
value pr_patt = {pr_fun = fun []; pr_levels = []};
|
|
pr_patt.pr_fun := pr_fun "patt" pr_patt;
|
|
value patt ppf (x, k) = pr_patt.pr_fun "top" ppf (x, "", k);
|
|
|
|
value pr_sig_item = {pr_fun = fun []; pr_levels = []};
|
|
pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item;
|
|
value sig_item ppf (x, k) = pr_sig_item.pr_fun "top" ppf (x, "", k);
|
|
|
|
value pr_str_item = {pr_fun = fun []; pr_levels = []};
|
|
pr_str_item.pr_fun := pr_fun "str_item" pr_str_item;
|
|
value str_item ppf (x, k) = pr_str_item.pr_fun "top" ppf (x, "", k);
|
|
|
|
value pr_type_decl = {pr_fun = fun []; pr_levels = []};
|
|
value type_decl ppf (x, k) = pr_type_decl.pr_fun "top" ppf (x, "", k);
|
|
pr_type_decl.pr_fun := pr_fun "type_decl" pr_type_decl;
|
|
|
|
value pr_type_params = {pr_fun = fun []; pr_levels = []};
|
|
value type_params ppf (x, k) = pr_type_params.pr_fun "top" ppf (x, "", k);
|
|
pr_type_params.pr_fun := pr_fun "type_params" pr_type_params;
|
|
|
|
value pr_with_constr = {pr_fun = fun []; pr_levels = []};
|
|
value with_constr ppf (x, k) = pr_with_constr.pr_fun "top" ppf (x, "", k);
|
|
pr_with_constr.pr_fun := pr_fun "with_constr" pr_with_constr;
|
|
|
|
(* general functions *)
|
|
|
|
value nok ppf = ();
|
|
value ks s k ppf = fprintf ppf "%s%t" s k;
|
|
|
|
value rec list f ppf (l, k) =
|
|
match l with
|
|
[ [] -> k ppf
|
|
| [x] -> f ppf (x, k)
|
|
| [x :: l] -> fprintf ppf "%a@ %a" f (x, nok) (list f) (l, k) ]
|
|
;
|
|
|
|
value rec listwb b f ppf (l, k) =
|
|
match l with
|
|
[ [] -> k ppf
|
|
| [x] -> f ppf ((b, x), k)
|
|
| [x :: l] -> fprintf ppf "%a@ %a" f ((b, x), nok) (listwb "" f) (l, k) ]
|
|
;
|
|
|
|
(* specific functions *)
|
|
|
|
value rec is_irrefut_patt =
|
|
fun
|
|
[ <:patt< $lid:_$ >> -> True
|
|
| <:patt< () >> -> True
|
|
| <:patt< _ >> -> True
|
|
| <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y
|
|
| <:patt< { $list:fpl$ } >> ->
|
|
List.for_all (fun (_, p) -> is_irrefut_patt p) fpl
|
|
| <:patt< ($p$ : $_$) >> -> is_irrefut_patt p
|
|
| <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl
|
|
| <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p
|
|
| <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p
|
|
| <:patt< ~ $_$ >> -> True
|
|
| <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p
|
|
| _ -> False ]
|
|
;
|
|
|
|
value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge;
|
|
|
|
pr_expr_fun_args.val :=
|
|
extfun Extfun.empty with
|
|
[ <:expr< fun [$p$ -> $e$] >> as ge ->
|
|
if is_irrefut_patt p then
|
|
let (pl, e) = expr_fun_args e in
|
|
([p :: pl], e)
|
|
else ([], ge)
|
|
| ge -> ([], ge) ];
|
|
|
|
value sequence ppf (e, k) =
|
|
match e with
|
|
[ <:expr< do { $list:el$ } >> ->
|
|
fprintf ppf "@[<hv>%a@]" (list expr) (el, k)
|
|
| _ -> expr ppf (e, k) ]
|
|
;
|
|
|
|
value string ppf (s, k) = fprintf ppf "\"%s\"%t" s k;
|
|
|
|
value int_repr s =
|
|
if String.length s > 2 && s.[0] = '0' then
|
|
match s.[1] with
|
|
[ 'b' | 'o' | 'x' | 'B' | 'O' | 'X' ->
|
|
"#" ^ String.sub s 1 (String.length s - 1)
|
|
| _ -> s ]
|
|
else s
|
|
;
|
|
|
|
value assoc_left_parsed_op_list = ["+"; "*"; "land"; "lor"; "lxor"];
|
|
value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"];
|
|
value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="];
|
|
|
|
(* extensible pretty print functions *)
|
|
|
|
pr_constr_decl.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ (loc, c, []) ->
|
|
fun ppf curr next dg k -> fprintf ppf "(@[<hv>%s%t@]" c (ks ")" k)
|
|
| (loc, c, tl) ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[<hv>%s@ %a@]" c (list ctyp) (tl, ks ")" k) ]}];
|
|
|
|
pr_ctyp.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ <:ctyp< [ $list:cdl$ ] >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[<hv>sum@ %a@]" (list constr_decl) (cdl, ks ")" k)
|
|
| <:ctyp< { $list:cdl$ } >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "{@[<hv>%a@]" (list label_decl) (cdl, ks "}" k)
|
|
| <:ctyp< ( $list:tl$ ) >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[* @[<hv>%a@]@]" (list ctyp) (tl, ks ")" k)
|
|
| <:ctyp< $t1$ -> $t2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
let tl =
|
|
loop t2 where rec loop =
|
|
fun
|
|
[ <:ctyp< $t1$ -> $t2$ >> -> [t1 :: loop t2]
|
|
| t -> [t] ]
|
|
in
|
|
fprintf ppf "(@[-> @[<hv>%a@]@]" (list ctyp)
|
|
([t1 :: tl], ks ")" k)
|
|
| <:ctyp< $t1$ $t2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
let (t, tl) =
|
|
loop [t2] t1 where rec loop tl =
|
|
fun
|
|
[ <:ctyp< $t1$ $t2$ >> -> loop [t2 :: tl] t1
|
|
| t1 -> (t1, tl) ]
|
|
in
|
|
fprintf ppf "(@[%a@ %a@]" ctyp (t, nok) (list ctyp) (tl, ks ")" k)
|
|
| <:ctyp< $t1$ . $t2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "%a.%a" ctyp (t1, nok) ctyp (t2, k)
|
|
| <:ctyp< $lid:s$ >> | <:ctyp< $uid:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
|
|
| <:ctyp< ' $s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "'%s%t" s k
|
|
| <:ctyp< _ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "_%t" k
|
|
| x ->
|
|
fun ppf curr next dg k -> not_impl "ctyp" x ppf k ]}];
|
|
|
|
pr_expr.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ <:expr< fun [] >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(lambda%t" (ks ")" k)
|
|
| <:expr< fun $lid:s$ -> $e$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(lambda@ %s@;<1 1>%a" s expr (e, ks ")" k)
|
|
| <:expr< fun [ $list:pwel$ ] >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[<hv>lambda_match@ %a@]" (list match_assoc)
|
|
(pwel, ks ")" k)
|
|
| <:expr< match $e$ with [ $list:pwel$ ] >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[<hv>@[<b 2>match@ %a@]@ %a@]" expr (e, nok)
|
|
(list match_assoc) (pwel, ks ")" k)
|
|
| <:expr< try $e$ with [ $list:pwel$ ] >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[<hv>@[<b 2>try@ %a@]@ %a@]" expr (e, nok)
|
|
(list match_assoc) (pwel, ks ")" k)
|
|
| <:expr< let $p1$ = $e1$ in $e2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
let (pel, e) =
|
|
loop [(p1, e1)] e2 where rec loop pel =
|
|
fun
|
|
[ <:expr< let $p1$ = $e1$ in $e2$ >> ->
|
|
loop [(p1, e1) :: pel] e2
|
|
| e -> (List.rev pel, e) ]
|
|
in
|
|
let b =
|
|
match pel with
|
|
[ [_] -> "let"
|
|
| _ -> "let*" ]
|
|
in
|
|
fprintf ppf "(@[@[%s (@[<v>%a@]@]@;<1 2>%a@]" b
|
|
(listwb "" let_binding) (pel, ks ")" nok)
|
|
sequence (e, ks ")" k)
|
|
| <:expr< let $opt:rf$ $list:pel$ in $e$ >> ->
|
|
fun ppf curr next dg k ->
|
|
let b = if rf then "letrec" else "let" in
|
|
fprintf ppf "(@[<hv>%s@ (@[<hv>%a@]@ %a@]" b
|
|
(listwb "" let_binding) (pel, ks ")" nok) expr (e, ks ")" k)
|
|
| <:expr< if $e1$ then $e2$ else () >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(if @[%a@;<1 0>%a@]" expr (e1, nok)
|
|
expr (e2, ks ")" k)
|
|
| <:expr< if $e1$ then $e2$ else $e3$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(if @[%a@ %a@ %a@]" expr (e1, nok)
|
|
expr (e2, nok) expr (e3, ks ")" k)
|
|
| <:expr< do { $list:el$ } >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(begin@;<1 1>@[<hv>%a@]" (list expr) (el, ks ")" k)
|
|
| <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[for %s@ %a@ %a %a@]" i expr (e1, nok)
|
|
expr (e2, nok) (list expr) (el, ks ")" k)
|
|
| <:expr< ($e$ : $t$) >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(:@ %a@ %a" expr (e, nok) ctyp (t, ks ")" k)
|
|
| <:expr< ($list:el$) >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(values @[%a@]" (list expr) (el, ks ")" k)
|
|
| <:expr< { $list:fel$ } >> ->
|
|
fun ppf curr next dg k ->
|
|
let record_binding ppf ((p, e), k) =
|
|
fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k)
|
|
in
|
|
fprintf ppf "{@[<hv>%a@]" (list record_binding) (fel, ks "}" k)
|
|
| <:expr< { ($e$) with $list:fel$ } >> ->
|
|
fun ppf curr next dg k ->
|
|
let record_binding ppf ((p, e), k) =
|
|
fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k)
|
|
in
|
|
fprintf ppf "{@[@[with@ %a@]@ @[%a@]@]" expr (e, nok)
|
|
(list record_binding) (fel, ks "}" k)
|
|
| <:expr< $e1$ := $e2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(:=@;<1 1>%a@;<1 1>%a" expr (e1, nok)
|
|
expr (e2, ks ")" k)
|
|
| <:expr< [$_$ :: $_$] >> as e ->
|
|
fun ppf curr next dg k ->
|
|
let (el, c) =
|
|
make_list e where rec make_list e =
|
|
match e with
|
|
[ <:expr< [$e$ :: $y$] >> ->
|
|
let (el, c) = make_list y in
|
|
([e :: el], c)
|
|
| <:expr< [] >> -> ([], None)
|
|
| x -> ([], Some e) ]
|
|
in
|
|
match c with
|
|
[ None ->
|
|
fprintf ppf "[%a" (list expr) (el, ks "]" k)
|
|
| Some x ->
|
|
fprintf ppf "[%a@ %a" (list expr) (el, ks " ." nok)
|
|
expr (x, ks "]" k) ]
|
|
| <:expr< lazy ($x$) >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[lazy@ %a@]" expr (x, ks ")" k)
|
|
| <:expr< $lid:s$ $e1$ $e2$ >>
|
|
when List.mem s assoc_right_parsed_op_list ->
|
|
fun ppf curr next dg k ->
|
|
let el =
|
|
loop [e1] e2 where rec loop el =
|
|
fun
|
|
[ <:expr< $lid:s1$ $e1$ $e2$ >> when s1 = s ->
|
|
loop [e1 :: el] e2
|
|
| e -> List.rev [e :: el] ]
|
|
in
|
|
fprintf ppf "(@[%s %a@]" s (list expr) (el, ks ")" k)
|
|
| <:expr< $e1$ $e2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
let (f, el) =
|
|
loop [e2] e1 where rec loop el =
|
|
fun
|
|
[ <:expr< $e1$ $e2$ >> -> loop [e2 :: el] e1
|
|
| e1 -> (e1, el) ]
|
|
in
|
|
fprintf ppf "(@[%a@ %a@]" expr (f, nok) (list expr) (el, ks ")" k)
|
|
| <:expr< ~ $s$ : ($e$) >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(~%s@ %a" s expr (e, ks ")" k)
|
|
| <:expr< $e1$ .[ $e2$ ] >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "%a.[%a" expr (e1, nok) expr (e2, ks "]" k)
|
|
| <:expr< $e1$ .( $e2$ ) >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "%a.(%a" expr (e1, nok) expr (e2, ks ")" k)
|
|
| <:expr< $e1$ . $e2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "%a.%a" expr (e1, nok) expr (e2, k)
|
|
| <:expr< $int:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k
|
|
| <:expr< $lid:s$ >> | <:expr< $uid:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
|
|
| <:expr< ` $s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "`%s%t" s k
|
|
| <:expr< $str:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k
|
|
| <:expr< $chr:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k
|
|
| x ->
|
|
fun ppf curr next dg k -> not_impl "expr" x ppf k ]}];
|
|
|
|
pr_label_decl.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ (loc, f, m, t) ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[<hv>%s%t@ %a@]" f
|
|
(fun ppf -> if m then fprintf ppf "@ mutable" else ())
|
|
ctyp (t, ks ")" k) ]}];
|
|
|
|
pr_let_binding.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ (b, (p, e)) ->
|
|
fun ppf curr next dg k ->
|
|
let (pl, e) = expr_fun_args e in
|
|
match pl with
|
|
[ [] ->
|
|
fprintf ppf "(@[<b 1>%s%s%a@ %a@]" b
|
|
(if b = "" then "" else " ") patt (p, nok)
|
|
sequence (e, ks ")" k)
|
|
| _ ->
|
|
fprintf ppf "(@[<b 1>%s%s(%a)@ %a@]" b
|
|
(if b = "" then "" else " ") (list patt) ([p :: pl], nok)
|
|
sequence (e, ks ")" k) ] ]}];
|
|
|
|
pr_match_assoc.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ (p, we, e) ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[%t@ %a@]"
|
|
(fun ppf ->
|
|
match we with
|
|
[ Some e ->
|
|
fprintf ppf "(when@ %a@ %a" patt (p, nok)
|
|
expr (e, ks ")" nok)
|
|
| None -> patt ppf (p, nok) ])
|
|
sequence (e, ks ")" k) ]}];
|
|
|
|
pr_mod_ident.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ [s] ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "%s%t" s k
|
|
| [s :: sl] ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "%s.%a" s curr (sl, "", k)
|
|
| x ->
|
|
fun ppf curr next dg k -> not_impl "mod_ident" x ppf k ]}];
|
|
|
|
pr_module_binding.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ (b, s, me) ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "%s@ %s@ %a" b s module_expr (me, k) ]}];
|
|
|
|
pr_module_expr.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ <:module_expr< functor ($i$ : $mt$) -> $me$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]"
|
|
i module_type (mt, nok) module_expr (me, ks ")" k)
|
|
| <:module_expr< struct $list:sil$ end >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[struct@ @[<hv>%a@]@]" (list str_item)
|
|
(sil, ks ")" k)
|
|
| <:module_expr< $me1$ $me2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[%a@ %a@]" module_expr (me1, nok)
|
|
module_expr (me2, ks ")" k)
|
|
| <:module_expr< $uid:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
|
|
| x ->
|
|
fun ppf curr next dg k -> not_impl "module_expr" x ppf k ]}];
|
|
|
|
pr_module_type.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ <:module_type< functor ($i$ : $mt1$) -> $mt2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]"
|
|
i module_type (mt1, nok) module_type (mt2, ks ")" k)
|
|
| <:module_type< sig $list:sil$ end >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[sig@ @[<hv>%a@]@]" (list sig_item) (sil, ks ")" k)
|
|
| <:module_type< $mt$ with $list:wcl$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[with@;<1 2>@[%a@ (%a@]@]" module_type (mt, nok)
|
|
(list with_constr) (wcl, ks "))" k)
|
|
| <:module_type< $uid:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
|
|
| x ->
|
|
fun ppf curr next dg k -> not_impl "module_type" x ppf k ]}];
|
|
|
|
pr_patt.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ <:patt< $p1$ | $p2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
let (f, pl) =
|
|
loop [p2] p1 where rec loop pl =
|
|
fun
|
|
[ <:patt< $p1$ | $p2$ >> -> loop [p2 :: pl] p1
|
|
| p1 -> (p1, pl) ]
|
|
in
|
|
fprintf ppf "(@[or@ %a@ %a@]" patt (f, nok) (list patt)
|
|
(pl, ks ")" k)
|
|
| <:patt< ($p1$ as $p2$) >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[as@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
|
|
| <:patt< $p1$ .. $p2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[range@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
|
|
| <:patt< [$_$ :: $_$] >> as p ->
|
|
fun ppf curr next dg k ->
|
|
let (pl, c) =
|
|
make_list p where rec make_list p =
|
|
match p with
|
|
[ <:patt< [$p$ :: $y$] >> ->
|
|
let (pl, c) = make_list y in
|
|
([p :: pl], c)
|
|
| <:patt< [] >> -> ([], None)
|
|
| x -> ([], Some p) ]
|
|
in
|
|
match c with
|
|
[ None ->
|
|
fprintf ppf "[%a" (list patt) (pl, ks "]" k)
|
|
| Some x ->
|
|
fprintf ppf "[%a@ %a" (list patt) (pl, ks " ." nok)
|
|
patt (x, ks "]" k) ]
|
|
| <:patt< $p1$ $p2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
let pl =
|
|
loop [p2] p1 where rec loop pl =
|
|
fun
|
|
[ <:patt< $p1$ $p2$ >> -> loop [p2 :: pl] p1
|
|
| p1 -> [p1 :: pl] ]
|
|
in
|
|
fprintf ppf "(@[%a@]" (list patt) (pl, ks ")" k)
|
|
| <:patt< ($p$ : $t$) >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(:@ %a@ %a" patt (p, nok) ctyp (t, ks ")" k)
|
|
| <:patt< ($list:pl$) >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(values @[%a@]" (list patt) (pl, ks ")" k)
|
|
| <:patt< { $list:fpl$ } >> ->
|
|
fun ppf curr next dg k ->
|
|
let record_binding ppf ((p1, p2), k) =
|
|
fprintf ppf "(@[%a@ %a@]" patt (p1, nok) patt (p2, ks ")" k)
|
|
in
|
|
fprintf ppf "(@[<hv>{}@ %a@]" (list record_binding) (fpl, ks ")" k)
|
|
| <:patt< ? $x$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "?%s%t" x k
|
|
| <:patt< ? ($lid:x$ = $e$) >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "(?%s@ %a" x expr (e, ks ")" k)
|
|
| <:patt< $p1$ . $p2$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "%a.%a" patt (p1, nok) patt (p2, k)
|
|
| <:patt< $lid:s$ >> | <:patt< $uid:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
|
|
| <:patt< $str:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k
|
|
| <:patt< $chr:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k
|
|
| <:patt< $int:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k
|
|
| <:patt< $flo:s$ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "%s%t" s k
|
|
| <:patt< _ >> ->
|
|
fun ppf curr next dg k -> fprintf ppf "_%t" k
|
|
| x ->
|
|
fun ppf curr next dg k -> not_impl "patt" x ppf k ]}];
|
|
|
|
pr_sig_item.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ <:sig_item< type $list:tdl$ >> ->
|
|
fun ppf curr next dg k ->
|
|
match tdl with
|
|
[ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k)
|
|
| tdl ->
|
|
fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl)
|
|
(tdl, ks ")" k) ]
|
|
| <:sig_item< exception $c$ of $list:tl$ >> ->
|
|
fun ppf curr next dg k ->
|
|
match tl with
|
|
[ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k)
|
|
| tl ->
|
|
fprintf ppf "(@[@[exception@ %s@]@ %a@]" c
|
|
(list ctyp) (tl, ks ")" k) ]
|
|
| <:sig_item< value $i$ : $t$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[@[value %s@]@ %a@]" i ctyp (t, ks ")" k)
|
|
| <:sig_item< external $i$ : $t$ = $list:pd$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[@[external@ %s@]@ %a@ %a@]" i ctyp (t, nok)
|
|
(list string) (pd, ks ")" k)
|
|
| <:sig_item< module $s$ : $mt$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[@[module@ %s@]@ %a@]" s
|
|
module_type (mt, ks ")" k)
|
|
| <:sig_item< module type $s$ = $mt$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s
|
|
module_type (mt, ks ")" k)
|
|
| <:sig_item< declare $list:s$ end >> ->
|
|
fun ppf curr next dg k ->
|
|
if s = [] then fprintf ppf "; ..."
|
|
else fprintf ppf "%a" (list sig_item) (s, k)
|
|
| MLast.SgUse _ _ _ ->
|
|
fun ppf curr next dg k -> ()
|
|
| x ->
|
|
fun ppf curr next dg k -> not_impl "sig_item" x ppf k ]}];
|
|
|
|
pr_str_item.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ <:str_item< open $i$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(open@ %a" mod_ident (i, ks ")" k)
|
|
| <:str_item< type $list:tdl$ >> ->
|
|
fun ppf curr next dg k ->
|
|
match tdl with
|
|
[ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k)
|
|
| tdl ->
|
|
fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl)
|
|
(tdl, ks ")" k) ]
|
|
| <:str_item< exception $c$ of $list:tl$ >> ->
|
|
fun ppf curr next dg k ->
|
|
match tl with
|
|
[ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k)
|
|
| tl ->
|
|
fprintf ppf "(@[@[exception@ %s@]@ %a@]" c
|
|
(list ctyp) (tl, ks ")" k) ]
|
|
| <:str_item< value $opt:rf$ $list:pel$ >> ->
|
|
fun ppf curr next dg k ->
|
|
let b = if rf then "definerec" else "define" in
|
|
match pel with
|
|
[ [(p, e)] ->
|
|
fprintf ppf "%a" let_binding ((b, (p, e)), k)
|
|
| pel ->
|
|
fprintf ppf "(@[<hv 1>%s*@ %a@]" b (listwb "" let_binding)
|
|
(pel, ks ")" k) ]
|
|
| <:str_item< module $s$ = $me$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(%a" module_binding (("module", s, me), ks ")" k)
|
|
| <:str_item< module type $s$ = $mt$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s
|
|
module_type (mt, ks ")" k)
|
|
| <:str_item< external $i$ : $t$ = $list:pd$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(@[external@ %s@ %a@ %a@]" i ctyp (t, nok)
|
|
(list string) (pd, ks ")" k)
|
|
| <:str_item< $exp:e$ >> ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "%a" expr (e, k)
|
|
| <:str_item< # $s$ $opt:x$ >> ->
|
|
fun ppf curr next dg k ->
|
|
match x with
|
|
[ Some e -> fprintf ppf "; # (%s %a" s expr (e, ks ")" k)
|
|
| None -> fprintf ppf "; # (%s%t" s (ks ")" k) ]
|
|
| <:str_item< declare $list:s$ end >> ->
|
|
fun ppf curr next dg k ->
|
|
if s = [] then fprintf ppf "; ..."
|
|
else fprintf ppf "%a" (list str_item) (s, k)
|
|
| MLast.StUse _ _ _ ->
|
|
fun ppf curr next dg k -> ()
|
|
| x ->
|
|
fun ppf curr next dg k -> not_impl "str_item" x ppf k ]}];
|
|
|
|
pr_type_decl.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ (b, ((_, tn), tp, te, cl)) ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "%t%t@;<1 1>%a"
|
|
(fun ppf ->
|
|
if b <> "" then fprintf ppf "%s@ " b
|
|
else ())
|
|
(fun ppf ->
|
|
match tp with
|
|
[ [] -> fprintf ppf "%s" tn
|
|
| tp -> fprintf ppf "(%s%a)" tn type_params (tp, nok) ])
|
|
ctyp (te, k) ]}];
|
|
|
|
pr_type_params.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ [(s, vari) :: tpl] ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "@ '%s%a" s type_params (tpl, k)
|
|
| [] ->
|
|
fun ppf curr next dg k -> () ]}];
|
|
|
|
pr_with_constr.pr_levels :=
|
|
[{pr_label = "top";
|
|
pr_box ppf f x = fprintf ppf "@[%t@]" f;
|
|
pr_rules =
|
|
extfun Extfun.empty with
|
|
[ MLast.WcTyp _ m tp te ->
|
|
fun ppf curr next dg k ->
|
|
fprintf ppf "(type@ %t@;<1 1>%a"
|
|
(fun ppf ->
|
|
match tp with
|
|
[ [] -> fprintf ppf "%a" mod_ident (m, nok)
|
|
| tp ->
|
|
fprintf ppf "(%a@ %a)" mod_ident (m, nok)
|
|
type_params (tp, nok) ])
|
|
ctyp (te, ks ")" k)
|
|
| x ->
|
|
fun ppf curr next dg k -> not_impl "with_constr" x ppf k ]}];
|
|
|
|
(* main *)
|
|
|
|
value output_string_eval ppf s =
|
|
loop 0 where rec loop i =
|
|
if i == String.length s then ()
|
|
else if i == String.length s - 1 then pp_print_char ppf s.[i]
|
|
else
|
|
match (s.[i], s.[i + 1]) with
|
|
[ ('\\', 'n') -> do { pp_print_char ppf '\n'; loop (i + 2) }
|
|
| (c, _) -> do { pp_print_char ppf c; loop (i + 1) } ]
|
|
;
|
|
|
|
value sep = Pcaml.inter_phrases;
|
|
|
|
value input_source ic len =
|
|
let buff = Buffer.create 20 in
|
|
try
|
|
let rec loop i =
|
|
if i >= len then Buffer.contents buff
|
|
else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) }
|
|
in
|
|
loop 0
|
|
with
|
|
[ End_of_file ->
|
|
let s = Buffer.contents buff in
|
|
if s = "" then
|
|
match sep.val with
|
|
[ Some s -> s
|
|
| None -> "\n" ]
|
|
else s ]
|
|
;
|
|
|
|
value copy_source ppf (ic, first, bp, ep) =
|
|
match sep.val with
|
|
[ Some str ->
|
|
if first then ()
|
|
else if ep == in_channel_length ic then pp_print_string ppf "\n"
|
|
else output_string_eval ppf str
|
|
| None ->
|
|
do {
|
|
seek_in ic bp;
|
|
let s = input_source ic (ep - bp) in pp_print_string ppf s
|
|
} ]
|
|
;
|
|
|
|
value copy_to_end ppf (ic, first, bp) =
|
|
let ilen = in_channel_length ic in
|
|
if bp < ilen then copy_source ppf (ic, first, bp, ilen)
|
|
else pp_print_string ppf "\n"
|
|
;
|
|
|
|
value apply_printer printer ast =
|
|
let ppf = std_formatter in
|
|
if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do {
|
|
let ic = open_in_bin Pcaml.input_file.val in
|
|
try
|
|
let (first, last_pos) =
|
|
List.fold_left
|
|
(fun (first, last_pos) (si, (bp, ep)) ->
|
|
do {
|
|
fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos.Lexing.pos_cnum, bp.Lexing.pos_cnum);
|
|
fprintf ppf "@[%a@]@?" printer (si, nok);
|
|
(False, ep)
|
|
})
|
|
(True, Token.nowhere) ast
|
|
in
|
|
fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos.Lexing.pos_cnum)
|
|
with x ->
|
|
do { fprintf ppf "@."; close_in ic; raise x };
|
|
close_in ic;
|
|
}
|
|
else failwith "not implemented"
|
|
;
|
|
|
|
Pcaml.print_interf.val := apply_printer sig_item;
|
|
Pcaml.print_implem.val := apply_printer str_item;
|
|
|
|
Pcaml.add_option "-l" (Arg.Int (fun x -> set_margin x))
|
|
"<length> Maximum line length for pretty printing.";
|
|
|
|
Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x))
|
|
"<string> Use this string between phrases instead of reading source.";
|