(* 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.";