diff options
Diffstat (limited to 'camlp4/etc/pr_r.ml')
| -rw-r--r-- | camlp4/etc/pr_r.ml | 1898 |
1 files changed, 0 insertions, 1898 deletions
diff --git a/camlp4/etc/pr_r.ml b/camlp4/etc/pr_r.ml deleted file mode 100644 index eb14e73762..0000000000 --- a/camlp4/etc/pr_r.ml +++ /dev/null @@ -1,1898 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -open Pcaml; -open Spretty; - -value not_impl name x = - 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 - HVbox [: `S NO ("<pr_r: not impl: " ^ name ^ "; " ^ desc ^ ">") :] -; - -value gen_where = ref True; -value old_sequences = ref False; -value expand_declare = ref False; - -external is_printable : char -> bool = "is_printable"; - -value char_escaped = - fun - [ '\\' -> "\\\\" - | '\b' -> "\\b" - | '\n' -> "\\n" - | '\r' -> "\\r" - | '\t' -> "\\t" - | c -> - if is_printable c then String.make 1 c - else do { - let n = Char.code c in - let s = String.create 4 in - String.unsafe_set s 0 '\\'; - String.unsafe_set s 1 (Char.unsafe_chr (48 + n / 100)); - String.unsafe_set s 2 (Char.unsafe_chr (48 + n / 10 mod 10)); - String.unsafe_set s 3 (Char.unsafe_chr (48 + n mod 10)); - s - } ] -; - -value rec list elem el k = - match el with - [ [] -> k - | [x] -> [: `elem x k :] - | [x :: l] -> [: `elem x [: :]; list elem l k :] ] -; - -value rec listws elem sep el k = - match el with - [ [] -> k - | [x] -> [: `elem x k :] - | [x :: l] -> [: `elem x [: `sep :]; listws elem sep l k :] ] -; - -value rec listwbws elem b sep el k = - match el with - [ [] -> [: b; k :] - | [x] -> [: `elem b x k :] - | [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ] -; - -value is_infix = - let infixes = Hashtbl.create 73 in - do { - List.iter (fun s -> Hashtbl.add infixes s True) - ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**"; - "="; "=."; "<>"; "<>."; "<"; "<."; ">"; ">."; "<="; "<=."; ">="; ">=."; - "^"; "@"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; - "&&"; "||"; "~-"; "~-."]; - fun s -> try Hashtbl.find infixes s with [ Not_found -> False ] - } -; - -value is_keyword = - let keywords = Hashtbl.create 301 in - do { - List.iter (fun s -> Hashtbl.add keywords s True) - ["!"; "!="; "#"; "&"; "&&"; "'"; "("; ")"; "*"; "**"; "*."; "+"; "+."; - ","; "-"; "-."; "->"; "."; ".."; "/"; "/."; ":"; "::"; ":="; ":>"; - ":]"; ";"; "<"; "<="; "<>"; "="; "=="; ">"; ">="; ">}"; "?"; "@"; "["; - "[:"; "[|"; "]"; "^"; "_"; "`"; "and"; "as"; "asr"; "assert"; "class"; - "constraint"; "declare"; "do"; "done"; "downto"; "else"; "end"; - "exception"; "external"; "for"; "fun"; "functor"; "if"; "in"; - "include"; "inherit"; "initializer"; "land"; "lazy"; "let"; "lor"; - "lsl"; "lsr"; "lxor"; "match"; "method"; "mod"; "module"; "mutable"; - "new"; "object"; "of"; "open"; "parser"; "private"; "rec"; "return"; - "sig"; "struct"; "then"; "to"; "try"; "type"; "value"; "virtual"; - "when"; "where"; "while"; "with"; "{"; "{<"; "|"; "|]"; "||"; "}"; - "~-"; "~-."]; - fun s -> try Hashtbl.find keywords s with [ Not_found -> False ] - } -; - -value has_special_chars v = - match v.[0] with - [ 'a'..'z' | 'A'..'Z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' | - '_' -> - False - | _ -> - if String.length v >= 2 && v.[0] == '<' && - (v.[1] == '<' || v.[1] == ':') - then - False - else True ] -; - -value var_escaped v = - if v = "" then "$lid:\"\"$" - else if has_special_chars v || is_infix v then "\\" ^ v - else if is_keyword v then v ^ "__" - else v -; - -value flag n f = if f then [: `S LR n :] else [: :]; - -(* default global loc *) - -value loc = (0, 0); - -(* extensible printers *) - -value module_type e k = pr_module_type.pr_fun "top" e "" k; -value module_expr e k = pr_module_expr.pr_fun "top" e "" k; -value sig_item x k = pr_sig_item.pr_fun "top" x "" [: `S RO ";"; k :]; -value str_item x k = pr_str_item.pr_fun "top" x "" [: `S RO ";"; k :]; -value expr x k = pr_expr.pr_fun "top" x "" k; -value patt x k = pr_patt.pr_fun "top" x "" k; -value ctyp x k = pr_ctyp.pr_fun "top" x "" k; -value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; -value simple_expr x k = pr_expr.pr_fun "simple" x "" k; -value class_sig_item x k = - pr_class_sig_item.pr_fun "top" x "" [: `S RO ";"; k :] -; -value class_str_item x k = - pr_class_str_item.pr_fun "top" x "" [: `S RO ";"; k :] -; -value class_type x k = pr_class_type.pr_fun "top" x "" k; -value class_expr x k = pr_class_expr.pr_fun "top" x "" k; - - -(* type core *) - -value rec labels loc b vl k = - match vl with - [ [] -> [: b; k :] - | [v] -> - [: `HVbox - [: `HVbox [: :]; `label True b v [: :]; - `LocInfo (snd loc, snd loc) (HVbox k) :] :] - | [v :: l] -> [: `label False b v [: :]; labels loc [: :] l k :] ] -and label is_last b (loc, f, m, t) k = - let m = flag "mutable" m in - let k = [: if is_last then [: :] else [: `S RO ";" :]; k :] in - Hbox - [: `LocInfo loc - (HVbox - [: `HVbox [: b; `S LR f; `S LR ":" :]; - `HVbox [: m; `ctyp t [: :] :] :]); - k :] -; - -value rec ctyp_list tel k = listws ctyp (S LR "and") tel k; - -value rec variants loc b vl k = - match vl with - [ [] -> [: b; k :] - | [v] -> - [: `HVbox - [: `HVbox [: :]; `variant b v [: :]; - `LocInfo (snd loc, snd loc) (HVbox k) :] :] - | [v :: l] -> [: `variant b v [: :]; variants loc [: `S LR "|" :] l k :] ] -and variant b (loc, c, tl) k = - match tl with - [ [] -> HVbox [: `LocInfo loc (HVbox b); `HOVbox [: `S LR c; k :] :] - | _ -> - HVbox - [: `LocInfo loc (HVbox b); - `HOVbox [: `S LR c; `S LR "of"; ctyp_list tl k :] :] ] -; - -value rec row_fields b rfl k = listwbws row_field b (S LR "|") rfl k -and row_field b rf k = - match rf with - [ MLast.RfTag c ao tl -> - let c = "`" ^ c in - match tl with - [ [] -> HVbox [: b; `HOVbox [: `S LR c; k :] :] - | _ -> - let ao = if ao then [: `S LR "&" :] else [: :] in - HVbox - [: b; `HOVbox [: `S LR c; `S LR "of"; ao; ctyp_list tl k :] :] ] - | MLast.RfInh t -> HVbox [: b; `ctyp t k :] ] -; - -(* *) - -value rec class_longident sl k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `class_longident sl k :] - | _ -> HVbox [: `not_impl "class_longident" sl; k :] ] -; - -value rec clty_longident sl k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `clty_longident sl k :] - | _ -> HVbox [: `not_impl "clty_longident" sl; k :] ] -; - -value rec meth_list (ml, v) k = - match (ml, v) with - [ ([f], False) -> [: `field f k :] - | ([], _) -> [: `S LR ".."; k :] - | ([f :: ml], v) -> [: `field f [: `S RO ";" :]; meth_list (ml, v) k :] ] -and field (lab, t) k = - HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t k :] -; - -(* patterns *) - -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< ? $_$ >> -> True - | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | _ -> False ] -; - -value rec get_defined_ident = - fun - [ <:patt< $_$ . $_$ >> -> [] - | <:patt< _ >> -> [] - | <:patt< $lid:x$ >> -> [x] - | <:patt< ($p1$ as $p2$) >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< $int:_$ >> -> [] - | (MLast.PaNativeInt _ _ | MLast.PaInt64 _ _ | MLast.PaInt32 _ _) -> [] - | <:patt< $flo:_$ >> -> [] - | <:patt< $str:_$ >> -> [] - | <:patt< $chr:_$ >> -> [] - | <:patt< [| $list:pl$ |] >> -> List.flatten (List.map get_defined_ident pl) - | <:patt< ($list:pl$) >> -> List.flatten (List.map get_defined_ident pl) - | <:patt< $uid:_$ >> -> [] - | <:patt< ` $_$ >> -> [] - | <:patt< # $list:_$ >> -> [] - | <:patt< $p1$ $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< { $list:lpl$ } >> -> - List.flatten (List.map (fun (lab, p) -> get_defined_ident p) lpl) - | <:patt< $p1$ | $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< $p1$ .. $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< ($p$ : $_$) >> -> get_defined_ident p - | <:patt< ~ $_$ >> -> [] - | <:patt< ~ $_$ : $p$ >> -> get_defined_ident p - | <:patt< ? $_$ >> -> [] - | <:patt< ? $_$ : ($p$) >> -> get_defined_ident p - | <:patt< ? $_$ : ($p$ = $e$) >> -> get_defined_ident p - | <:patt< $anti:p$ >> -> get_defined_ident p ] -; - -value un_irrefut_patt p = - match get_defined_ident p with - [ [] -> (<:patt< _ >>, <:expr< () >>) - | [i] -> (<:patt< $lid:i$ >>, <:expr< $lid:i$ >>) - | il -> - let (upl, uel) = - List.fold_right - (fun i (upl, uel) -> - ([<:patt< $lid:i$ >> :: upl], [<:expr< $lid:i$ >> :: uel])) - il ([], []) - in - (<:patt< ($list:upl$) >>, <:expr< ($list:uel$) >>) ] -; - -(* expressions *) - -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 rec bind_list b pel k = - match pel with - [ [pe] -> let_binding b pe k - | pel -> - Vbox [: `HVbox [: :]; listwbws let_binding b (S LR "and") pel k :] ] -and let_binding b (p, e) k = - let (p, e) = - if is_irrefut_patt p then (p, e) - else - let (up, ue) = un_irrefut_patt p in - (up, <:expr< match $e$ with [ $p$ -> $ue$ ] >>) - in - let loc = - let (bp1, ep1) = MLast.loc_of_patt p in - let (bp2, ep2) = MLast.loc_of_expr e in - (min bp1 bp2, max ep1 ep2) - in - LocInfo loc (BEbox [: let_binding0 [: b; `patt p [: :] :] e [: :]; k :]) -and let_binding0 b e k = - let (pl, e) = expr_fun_args e in - match e with - [ <:expr< let $opt:r$ $lid:f$ = fun [ $list:pel$ ] in $e$ >> - when - let rec call_f = - fun - [ <:expr< $lid:f'$ >> -> f = f' - | <:expr< $e$ $_$ >> -> call_f e - | _ -> False ] - in - gen_where.val && call_f e -> - let (pl1, e1) = expr_fun_args <:expr< fun [ $list:pel$ ] >> in - [: `HVbox [: `HVbox b; `HOVbox (list patt pl [: `S LR "=" :]) :]; - `HVbox - [: `HOVbox - [: `expr e [: :]; `S LR "where"; flag "rec" r; `S LR f; - `HVbox (list patt pl1 [: `S LR "=" :]) :]; - `expr e1 k :] :] - | <:expr< ($e$ : $t$) >> -> - [: `HVbox - [: `HVbox b; `HOVbox (list patt pl [: `S LR ":" :]); - `ctyp t [: `S LR "=" :] :]; - `expr e k :] - | _ -> - [: `HVbox [: `HVbox b; `HOVbox (list patt pl [: `S LR "=" :]) :]; - `expr e k :] ] -and match_assoc_list pwel k = - match pwel with - [ [pwe] -> match_assoc [: `S LR "[" :] pwe [: `S LR "]"; k :] - | pel -> - Vbox - [: `HVbox [: :]; - listwbws match_assoc [: `S LR "[" :] (S LR "|") pel - [: `S LR "]"; k :] :] ] -and match_assoc b (p, w, e) k = - let s = - let (p, k) = - match p with - [ <:patt< ($p$ as $p2$) >> -> (p, [: `S LR "as"; `patt p2 [: :] :]) - | _ -> (p, [: :]) ] - in - match w with - [ Some e1 -> - [: `HVbox - [: `HVbox [: :]; `patt p k; - `HVbox [: `S LR "when"; `expr e1 [: `S LR "->" :] :] :] :] - | _ -> [: `patt p [: k; `S LR "->" :] :] ] - in - HVbox [: b; `HVbox [: `HVbox s; `expr e k :] :] -; - -value label lab = S LR (var_escaped lab); - -value field_expr (lab, e) k = HVbox [: `label lab; `S LR "="; `expr e k :]; - -value rec sequence_loop = - fun - [ [<:expr< let $opt:r$ $list:pel$ in $e$ >>] -> - let el = - match e with - [ <:expr< do { $list:el$ } >> -> el - | _ -> [e] ] - in - let r = flag "rec" r in - [: listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - sequence_loop el :] - | [(<:expr< let $opt:_$ $list:_$ in $_$ >> as e) :: el] -> - [: `simple_expr e [: `S RO ";" :]; sequence_loop el :] - | [e] -> [: `expr e [: :] :] - | [e :: el] -> [: `expr e [: `S RO ";" :]; sequence_loop el :] - | [] -> [: :] ] -; - -value sequence b1 b2 b3 el k = - BEbox - [: `BEbox [: b1; b2; `HVbox [: b3; `S LR "do {" :] :]; - `HVbox [: `HVbox [: :]; sequence_loop el :]; - `HVbox [: `S LR "}"; k :] :] -; - -value rec let_sequence e = - match e with - [ <:expr< do { $list:el$ } >> -> Some el - | <:expr< let $opt:_$ $list:_$ in $e1$ >> -> - match let_sequence e1 with - [ Some _ -> Some [e] - | None -> None ] - | _ -> None ] -; - -value ifbox b1 b2 b3 e k = - if old_sequences.val then HVbox [: `HOVbox [: b1; b2; b3 :]; `expr e k :] - else - match let_sequence e with - [ Some el -> sequence b1 b2 b3 el k - | None -> HVbox [: `BEbox [: b1; b2; b3 :]; `expr e k :] ] -; - -value rec type_params sl k = - list - (fun (s, vari) k -> - let b = - match vari with - [ (True, False) -> [: `S LO "+" :] - | (False, True) -> [: `S LO "-" :] - | _ -> [: :] ] - in - HVbox [: b; `S LO "'"; `S LR s; k :]) - sl k -; - -value constrain (t1, t2) k = - HVbox [: `S LR "constraint"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :] -; - -value type_list b tdl k = - HVbox - [: `HVbox [: :]; - listwbws - (fun b ((_, tn), tp, te, cl) k -> - let tn = var_escaped tn in - HVbox - [: `HVbox [: b; `S LR tn; type_params tp [: `S LR "=" :] :]; - `ctyp te [: :]; list constrain cl k :]) - b (S LR "and") tdl [: :]; - k :] -; - -value external_def s t pl k = - let ls = list (fun s k -> HVbox [: `S LR ("\"" ^ s ^ "\""); k :]) pl k in - HVbox - [: `HVbox [: `S LR "external"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t [: `S LR "="; ls :] :] -; - -value value_description s t k = - HVbox - [: `HVbox [: `S LR "value"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t k :] -; - -value typevar s k = HVbox [: `S LR ("'" ^ s); k :]; - -value rec mod_ident sl k = - match sl with - [ [] -> k - | [s] -> [: `S LR (var_escaped s); k :] - | [s :: sl] -> [: `S LR s; `S NO "."; mod_ident sl k :] ] -; - -value rec module_declaration b mt k = - match mt with - [ <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> -> - module_declaration - [: `HVbox - [: b; - `HVbox - [: `S LO "("; `S LR i; `S LR ":"; - `module_type t [: `S RO ")" :] :] :] :] - mt k - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR ":" :]; `module_type mt [: :] :]; - k :] ] -and module_rec_declaration b (n,mt) k = - HVbox - [: `HVbox - [: b; `S LR n; `S LR ":"; `module_type mt [: :] :]; - k :] -and modtype_declaration s mt k = - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox [: `S LR "module"; `S LR "type"; `S LR s; `S LR "=" :]; - `module_type mt [: :] :]; - k :] -and with_constraints b icl k = - HVbox [: `HVbox [: :]; listwbws with_constraint b (S LR "and") icl k :] -and with_constraint b wc k = - match wc with - [ <:with_constr< type $p$ $list:al$ = $e$ >> -> - let params = - match al with - [ [] -> [: :] - | [s] -> [: `S LO "'"; `S LR (fst s) :] - | sl -> [: `S LO "("; type_params sl [: `S RO ")" :] :] ] - in - HVbox - [: `HVbox - [: `HVbox b; `S LR "type"; params; - mod_ident p [: `S LR "=" :] :]; - `ctyp e k :] - | <:with_constr< module $sl$ = $me$ >> -> - HVbox - [: b; `S LR "module"; mod_ident sl [: `S LR "=" :]; - `module_expr me k :] ] -and module_binding b me k = - match me with - [ <:module_expr< functor ($s$ : $mt$) -> $mb$ >> -> - module_binding - [: `HVbox - [: b; - `HVbox - [: `HVbox [: `S LO "("; `S LR s; `S LR ":" :]; - `module_type mt [: `S RO ")" :] :] :] :] - mb k - | <:module_expr< ( $me$ : $mt$ ) >> -> - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me [: :] :]; - k :] - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR "=" :]; `module_expr me [: :] :]; - k :] ] -and module_rec_binding b (n, mt,me) k = - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR n; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me [: :] :]; - k :] -and class_declaration b ci k = - class_fun_binding - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm :] - ci.MLast.ciExp k -and class_fun_binding b ce k = - match ce with - [ <:class_expr< fun $p$ -> $cfb$ >> -> - class_fun_binding [: b; `patt p [: :] :] cfb k - | ce -> HVbox [: `HVbox [: b; `S LR "=" :]; `class_expr ce k :] ] -and class_type_parameters (loc, tpl) = - match tpl with - [ [] -> [: :] - | tpl -> - [: `S LO "["; listws type_parameter (S RO ",") tpl [: `S RO "]" :] :] ] -and type_parameter tp k = HVbox [: `S LO "'"; `S LR (fst tp); k :] -and simple_expr e k = - match e with - [ <:expr< $lid:_$ >> -> expr e k - | _ -> HVbox [: `S LO "("; `expr e [: `S RO ")"; k :] :] ] -and class_self_patt_opt csp = - match csp with - [ Some p -> HVbox [: `S LO "("; `patt p [: `S RO ")" :] :] - | None -> HVbox [: :] ] -and label lab = S LR (var_escaped lab) -and cvalue b (lab, mf, e) k = - HVbox - [: `HVbox [: b; flag "mutable" mf; `label lab; `S LR "=" :]; `expr e k :] -and fun_binding b fb k = - match fb with - [ <:expr< fun $p$ -> $e$ >> -> fun_binding [: b; `simple_patt p [: :] :] e k - | e -> HVbox [: `HVbox [: b; `S LR "=" :]; `expr e k :] ] -and simple_patt p k = - match p with - [ <:patt< $lid:_$ >> | <:patt< ~ $_$ : $_$ >> | - <:patt< ? $_$ : ($_$ $opt:_$) >> -> patt p k - | _ -> HVbox [: `S LO "("; `patt p [: `S RO ")"; k :] :] ] -and class_signature cs k = - match cs with - [ <:class_type< $list:id$ >> -> clty_longident id k - | <:class_type< $list:id$ [ $list:tl$ ] >> -> - HVbox - [: `clty_longident id [: :]; `S LO "["; - listws ctyp (S RO ",") tl [: `S RO "]"; k :] :] - | <:class_type< object $opt:cst$ $list:csf$ end >> -> - let ep = snd (MLast.loc_of_class_type cs) in - class_self_type [: `S LR "object" :] cst - [: `HVbox - [: `HVbox [: :]; list class_sig_item csf [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | _ -> HVbox [: `not_impl "class_signature" cs; k :] ] -and class_self_type b cst k = - BEbox - [: `HVbox - [: b; - match cst with - [ None -> [: :] - | Some t -> [: `S LO "("; `ctyp t [: `S RO ")" :] :] ] :]; - k :] -and class_description b ci k = - HVbox - [: `HVbox - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm; `S LR ":" :]; - `class_type ci.MLast.ciExp k :] -and class_type_declaration b ci k = - HVbox - [: `HVbox - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm; `S LR "=" :]; - `class_signature ci.MLast.ciExp k :] -; - -pr_module_type.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - fun curr next _ k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt1 [: `S RO ")" :]; `S LR "->" :] - in - [: `head; `module_type mt2 k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt$ with $list:icl$ >> -> - fun curr next _ k -> - [: curr mt "" [: :]; `with_constraints [: `S LR "with" :] icl k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< sig $list:s$ end >> as mt -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_module_type mt) in - [: `BEbox - [: `S LR "sig"; - `HVbox - [: `HVbox [: :]; list sig_item s [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt1$ $mt2$ >> -> - fun curr next _ k -> [: curr mt1 "" [: :]; `next mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt1$ . $mt2$ >> -> - fun curr next _ k -> - [: curr mt1 "" [: `S NO "." :]; `next mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $lid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_type< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_type< ' $s$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ s); k :] - | mt -> - fun curr next _ k -> - [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ]}]; - -pr_module_expr.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< struct $list:s$ end >> as me -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_module_expr me) in - [: `HVbox [: :]; - `HVbox - [: `S LR "struct"; list str_item s [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - fun curr next _ k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt [: `S RO ")" :]; `S LR "->" :] - in - [: `head; curr me "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ $me2$ >> -> - fun curr next _ k -> [: curr me1 "" [: :]; `next me2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ . $me2$ >> -> - fun curr next _ k -> - [: curr me1 "" [: `S NO "." :]; `next me2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_expr< ( $me$ : $mt$ ) >> -> - fun curr next _ k -> - [: `S LO "("; `module_expr me [: `S LR ":" :]; - `module_type mt [: `S RO ")"; k :] :] - | <:module_expr< struct $list:_$ end >> | - <:module_expr< functor ($_$ : $_$) -> $_$ >> | - <:module_expr< $_$ $_$ >> | <:module_expr< $_$ . $_$ >> as me -> - fun curr next _ k -> - [: `S LO "("; `module_expr me [: `S RO ")"; k :] :] ]}]; - -pr_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_sig_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:sig_item< type $list:stl$ >> -> - fun curr next _ k -> [: `type_list [: `S LR "type" :] stl k :] - | <:sig_item< declare $list:s$ end >> -> - fun curr next _ k -> - if expand_declare.val then - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list sig_item s [: :] :] - else - [: `BEbox - [: `S LR "declare"; - `HVbox [: `HVbox [: :]; list sig_item s [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:sig_item< # $_$ $opt:_$ >> as si -> - fun curr next _ k -> [: `not_impl "sig_item1" si :] - | <:sig_item< exception $c$ of $list:tl$ >> -> - fun curr next _ k -> - [: `variant [: `S LR "exception" :] (loc, c, tl) k :] - | <:sig_item< value $s$ : $t$ >> -> - fun curr next _ k -> [: `value_description s t k :] - | <:sig_item< include $mt$ >> -> - fun curr next _ k -> [: `S LR "include"; `module_type mt k :] - | <:sig_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next _ k -> [: `external_def s t pl k :] - | <:sig_item< module $s$ : $mt$ >> -> - fun curr next _ k -> - [: `module_declaration [: `S LR "module"; `S LR s :] mt k :] - | <:sig_item< module rec $list:nmts$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_declaration [: `S LR "module rec" :] (S LR "and") nmts - k :] - | <:sig_item< module type $s$ = $mt$ >> -> - fun curr next _ k -> [: `modtype_declaration s mt k :] - | <:sig_item< open $sl$ >> -> - fun curr next _ k -> [: `S LR "open"; mod_ident sl k :] - | <:sig_item< class $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_description [: `S LR "class" :] (S LR "and") cd - k :] - | <:sig_item< class type $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] - | MLast.SgUse _ _ _ -> - fun curr next _ k -> [: :] ]}]; - -pr_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_str_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:str_item< open $i$ >> -> - fun curr next _ k -> [: `S LR "open"; mod_ident i k :] - | <:str_item< $exp:e$ >> -> - fun curr next _ k -> [: `HVbox [: :]; `expr e k :] - | <:str_item< declare $list:s$ end >> -> - fun curr next _ k -> - if expand_declare.val then - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list str_item s [: :] :] - else - [: `BEbox - [: `S LR "declare"; - `HVbox [: `HVbox [: :]; list str_item s [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:str_item< # $s$ $opt:x$ >> -> - fun curr next _ k -> - let s = - "(* #" ^ s ^ " " ^ - (match x with - [ Some <:expr< $str:s$ >> -> "\"" ^ s ^ "\"" - | _ -> "?" ]) ^ - " *)" - in - [: `S LR s :] - | <:str_item< exception $c$ of $list:tl$ = $b$ >> -> - fun curr next _ k -> - match b with - [ [] -> [: `variant [: `S LR "exception" :] (loc, c, tl) k :] - | _ -> - [: `variant [: `S LR "exception" :] (loc, c, tl) - [: `S LR "=" :]; - mod_ident b k :] ] - | <:str_item< include $me$ >> -> - fun curr next _ k -> [: `S LR "include"; `module_expr me k :] - | <:str_item< type $list:tdl$ >> -> - fun curr next _ k -> [: `type_list [: `S LR "type" :] tdl k :] - | <:str_item< value $opt:rf$ $list:pel$ >> -> - fun curr next _ k -> - [: `bind_list [: `S LR "value"; flag "rec" rf :] pel k :] - | <:str_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next _ k -> [: `external_def s t pl k :] - | <:str_item< module $s$ = $me$ >> -> - fun curr next _ k -> - [: `module_binding [: `S LR "module"; `S LR s :] me k :] - | <:str_item< module rec $list:nmtmes$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_binding [: `S LR "module rec" :] (S LR "and") nmtmes - k :] - | <:str_item< module type $s$ = $mt$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `S LR "module"; `S LR "type"; `S LR s; - `S LR "=" :]; - `module_type mt [: :] :]; - k :] - | <:str_item< class $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_declaration [: `S LR "class" :] (S LR "and") cd - k :] - | <:str_item< class type $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] - | MLast.StUse _ _ _ -> - fun curr next _ k -> [: :] ]}]; - -(* -EXTEND_PRINTER - pr_expr: - [ "top" (fun e x -> LocInfo (MLast.loc_of_expr e) (HOVbox x)) - [ <:expr< let $rec:r$ $p1$ = $e1$ in $e$ >> -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - `let_binding [: `S LR "let"; r :] (p1, e1) - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let $rec:r$ $list:pel$ in $e$ >> -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - `expr e k :] :] ] ] - ; -END; -*) - -pr_expr.pr_levels := - [{pr_label = "top"; pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> -> - fun curr next _ k -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - `let_binding [: `S LR "let"; r :] (p1, e1) - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> - fun curr next _ k -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let module $m$ = $mb$ in $e$ >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - `module_binding - [: `S LR "let"; `S LR "module"; `S LR m :] mb - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< fun [ $list:pel$ ] >> -> - fun curr next _ k -> - match pel with - [ [] -> [: `S LR "fun"; `S LR "[]"; k :] - | [(p, None, e)] -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - [: `BEbox - [: `HOVbox - [: `S LR "fun"; - list patt [p :: pl] [: `S LR "->" :] :]; - `expr e k :] :] - else - [: `HVbox [: `S LR "fun ["; `patt p [: `S LR "->" :] :]; - `expr e [: `S LR "]"; k :] :] - | _ -> - [: `Vbox - [: `HVbox [: :]; `S LR "fun"; - listwbws match_assoc [: `S LR "[" :] (S LR "|") pel - [: `S LR "]"; k :] :] :] ] - | <:expr< match $e$ with $p1$ -> $e1$ >> when is_irrefut_patt p1 -> - fun curr next _ k -> - [: `BEbox - [: `S LR "match"; `expr e [: :]; - `HVbox [: `S LR "with"; `patt p1 [: `S LR "->" :] :] :]; - `expr e1 k :] - | <:expr< match $e$ with [ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox - [: `S LR "match"; `expr e [: :]; `S LR "with"; `S LR "[]"; - k :] :] - | <:expr< match $e$ with [ $list:pel$ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox [: `S LR "match"; `expr e [: :]; `S LR "with" :]; - `match_assoc_list pel k :] - | <:expr< try $e$ with [ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox - [: `S LR "try"; `expr e [: :]; `S LR "with"; `S LR "[]"; - k :] :] - | <:expr< try $e$ with $p1$ -> $e1$ >> when is_irrefut_patt p1 -> - fun curr next _ k -> - [: `BEbox - [: `S LR "try"; `expr e [: :]; - `HVbox [: `S LR "with"; `patt p1 [: `S LR "->" :] :] :]; - `expr e1 k :] - | <:expr< try $e$ with [ $list:pel$ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox [: `S LR "try"; `expr e [: :]; `S LR "with" :]; - `match_assoc_list pel k :] - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - fun curr next _ k -> - let (eel, e) = - elseif e3 where rec elseif e = - match e with - [ <:expr< if $e1$ then $e2$ else $e3$ >> -> - let (eel, e) = elseif e3 in - ([(e1, e2) :: eel], e) - | _ -> ([], e) ] - in - [: `HVbox - [: `HVbox [: :]; - `ifbox [: `S LR "if" :] [: `expr e1 [: :] :] - [: `S LR "then" :] e2 [: :]; - list - (fun (e1, e2) k -> - ifbox [: `HVbox [: `S LR "else"; `S LR "if" :] :] - [: `expr e1 [: :] :] [: `S LR "then" :] e2 k) - eel [: :]; - `ifbox [: `S LR "else" :] [: :] [: :] e k :] :] - | <:expr< do { $list:el$ } >> when old_sequences.val -> - fun curr next _ k -> - let (el, e) = - match List.rev el with - [ [e :: el] -> (List.rev el, e) - | [] -> ([], <:expr< () >>) ] - in - [: `HOVCbox - [: `HVbox [: :]; - `BEbox - [: `S LR "do"; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) - el [: :] :]; - `S LR "return" :]; - `expr e k :] :] - | <:expr< do { $list:el$ } >> -> - fun curr next _ k -> [: `sequence [: :] [: :] [: :] el k :] - | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> - when old_sequences.val -> - fun curr next _ k -> - let d = if d then "to" else "downto" in - [: `BEbox - [: `HOVbox - [: `S LR "for"; `S LR i; `S LR "="; - `expr e1 [: `S LR d :]; - `expr e2 [: `S LR "do" :] :]; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) el - [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> -> - fun curr next _ k -> - let d = if d then "to" else "downto" in - [: `sequence - [: `HOVbox - [: `S LR "for"; `S LR i; `S LR "="; - `expr e1 [: `S LR d :]; `expr e2 [: :] :] :] - [: :] [: :] el k :] - | <:expr< while $e1$ do { $list:el$ } >> when old_sequences.val -> - fun curr next _ k -> - [: `BEbox - [: `BEbox [: `S LR "while"; `expr e1 [: :]; `S LR "do" :]; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) el - [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | <:expr< while $e1$ do { $list:el$ } >> -> - fun curr next _ k -> - [: `sequence [: `S LR "while"; `expr e1 [: :] :] [: :] [: :] el - k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$ := $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR ":=" :]; `expr y k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"||"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "||" :]; curr y "" k :] - | <:expr< $lid:"or"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "||" :]; curr y "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"&&"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "&&" :]; curr y "" k :] - | <:expr< $lid:"&"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "&&" :]; curr y "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "<" | ">" | "<=" | ">=" | ">=." | "=" | "<>" | "==" | "!=" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "^" | "@" -> [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "+" | "+." | "-" | "-." -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "*" | "/" | "*." | "/." | "land" | "lor" | "lxor" | "mod" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "**" | "asr" | "lsl" | "lsr" -> - [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"~-"$ $x$ >> -> - fun curr next _ k -> [: `S LR "-"; curr x "" k :] - | <:expr< $lid:"~-."$ $x$ >> -> - fun curr next _ k -> [: `S LR "-."; curr x "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $int:x$ >> -> fun curr next _ k -> [: `S LR x; k :] - | MLast.ExInt32 _ x -> fun curr next _ k -> [: `S LR (x^"l"); k :] - | MLast.ExInt64 _ x -> fun curr next _ k -> [: `S LR (x^"L"); k :] - | MLast.ExNativeInt _ x -> fun curr next _ k -> [: `S LR (x^"n"); k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "apply"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next _ k -> [: `next e "" k :] - | <:expr< lazy ($x$) >> -> - fun curr next _ k -> [: `S LR "lazy"; `next x "" k :] - | <:expr< assert False >> -> - fun curr next _ k -> [: `S LR "assert"; `S LR "False"; k :] - | <:expr< assert ($e$) >> -> - fun curr next _ k -> [: `S LR "assert"; `next e "" k :] - | <:expr< $lid:n$ $x$ $y$ >> as e -> - fun curr next _ k -> - if is_infix n then [: `next e "" k :] - else [: curr <:expr< $lid:n$ $x$ >> "" [: :]; `next y "" k :] - | <:expr< $x$ $y$ >> -> - fun curr next _ k -> [: curr x "" [: :]; `next y "" k :] - | <:expr< new $list:sl$ >> -> - fun curr next _ k -> [: `S LR "new"; `class_longident sl k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "dot"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$ . ( $y$ ) >> -> - fun curr next _ k -> - [: curr x "" [: :]; `S NO ".("; `expr y [: `S RO ")"; k :] :] - | <:expr< $x$ . [ $y$ ] >> -> - fun curr next _ k -> - [: curr x "" [: :]; `S NO ".["; `expr y [: `S RO "]"; k :] :] - | <:expr< $e1$ . $e2$ >> -> - fun curr next _ k -> [: curr e1 "" [: :]; `S NO "."; curr e2 "" k :] - | <:expr< $e$ # $lab$ >> -> - fun curr next _ k -> [: curr e "" [: :]; `S NO "#"; `label lab; k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "simple"; - pr_box e x = LocInfo (MLast.loc_of_expr e) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) -> - fun curr next _ k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast. ExInt32 _ x -> - fun curr next _ k -> - let x = x^"l" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExInt64 _ x -> - fun curr next _ k -> - let x = x^"L" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExNativeInt _ x -> - fun curr next _ k -> - let x = x^"n" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | <:expr< $str:s$ >> -> - fun curr next _ k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:expr< $chr:c$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ c ^ "'"); k :] - | <:expr< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:expr< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:expr< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :] - | <:expr< ~ $i$ >> -> - fun curr next _ k -> [: `S LR ("~" ^ i); k :] - | <:expr< ~ $i$ : $e$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr e "" k :] - | <:expr< ? $i$ >> -> - fun curr next _ k -> [: `S LR ("?" ^ i); k :] - | <:expr< ? $i$ : $e$ >> -> - fun curr next _ k -> [: `S LO ("?" ^ i ^ ":"); curr e "" k :] - | <:expr< [$_$ :: $_$] >> as e -> - fun curr next _ 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 -> - [: `S LO "["; listws expr (S RO ";") el [: `S RO "]"; k :] :] - | Some x -> - [: `S LO "["; listws expr (S RO ";") el [: `S LR "::" :]; - `expr x [: `S RO "]"; k :] :] ] - | <:expr< [| $list:el$ |] >> -> - fun curr next _ k -> - [: `S LR "[|"; listws expr (S RO ";") el [: `S LR "|]"; k :] :] - | <:expr< { $list:fel$ } >> -> - fun curr next _ k -> - [: `S LO "{"; - listws - (fun (lab, e) k -> - HVbox [: let_binding0 [: `patt lab [: :] :] e k :]) - (S RO ";") fel [: `S RO "}"; k :] :] - | <:expr< { ($e$) with $list:fel$ } >> -> - fun curr next _ k -> - [: `HVbox - [: `S LO "{"; `S LO "("; - `expr e [: `S RO ")"; `S LR "with" :] :]; - listws - (fun (lab, e) k -> - HVbox [: `patt lab [: `S LR "=" :]; `expr e k :]) - (S RO ";") fel [: `S RO "}"; k :] :] - | <:expr< ($e$ : $t$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":" :]; - `ctyp t [: `S RO ")"; k :] :] - | <:expr< ($e$ : $t1$ :> $t2$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":" :]; `ctyp t1 [: `S LR ":>" :]; - `ctyp t2 [: `S RO ")"; k :] :] - | <:expr< ($e$ :> $t2$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":>" :]; - `ctyp t2 [: `S RO ")"; k :] :] - | <:expr< {< >} >> -> fun curr next _ k -> [: `S LR "{< >}"; k :] - | <:expr< {< $list:fel$ >} >> -> - fun curr next _ k -> - [: `S LR "{<"; - listws field_expr (S RO ";") fel [: `S LR ">}"; k :] :] - | <:expr< ($list:el$) >> -> - fun curr next _ k -> - [: `S LO "("; listws expr (S RO ",") el [: `S RO ")"; k :] :] - | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | - <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | - <:expr< $_$ # $_$ >> | - <:expr< fun [ $list:_$ ] >> | <:expr< match $_$ with [ $list:_$ ] >> | - <:expr< try $_$ with [ $list:_$ ] >> | - <:expr< if $_$ then $_$ else $_$ >> | <:expr< do { $list:_$ } >> | - <:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> | - <:expr< while $_$ do { $list:_$ } >> | - <:expr< let $opt:_$ $list:_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >> | - <:expr< new $list:_$ >> as e -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `HVbox [: `S RO ")"; k :] :] :] - | e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}]; - -pr_patt.pr_levels := - [{pr_label = "top"; - pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox [: `HVbox [: :]; x :]); - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ | $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S LR "|" :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ .. $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S NO ".." :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next _ k -> [: `next p "" k :] - | <:patt< $x$ $y$ >> -> - fun curr next _ k -> [: curr x "" [: :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ . $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S NO "." :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = "simple"; - pr_box p x = LocInfo (MLast.loc_of_patt p) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next _ 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 - [: `HOVCbox - [: `S LO "["; - let rec glop pl k = - match pl with - [ [] -> failwith "simple_patt" - | [p] -> - match c with - [ None -> [: `patt p k :] - | Some x -> - [: `patt p [: `S LR "::" :]; `patt x k :] ] - | [p :: pl] -> - [: `patt p [: `S RO ";" :]; glop pl k :] ] - in - glop pl [: `S RO "]"; k :] :] :] - | <:patt< [| $list:pl$ |] >> -> - fun curr next _ k -> - [: `S LR "[|"; listws patt (S RO ";") pl [: `S LR "|]"; k :] :] - | <:patt< { $list:fpl$ } >> -> - fun curr next _ k -> - [: `HVbox - [: `S LO "{"; - listws - (fun (lab, p) k -> - HVbox [: `patt lab [: `S LR "=" :]; `patt p k :]) - (S RO ";") fpl [: `S RO "}"; k :] :] :] - | <:patt< ($list:[p::pl]$) >> -> - fun curr next _ k -> - [: `HOVCbox - [: `S LO "("; - listws patt (S RO ",") [p :: pl] [: `S RO ")"; k :] :] :] - | <:patt< ($p$ : $ct$) >> -> - fun curr next _ k -> - [: `S LO "("; `patt p [: `S LR ":" :]; - `ctyp ct [: `S RO ")"; k :] :] - | <:patt< ($x$ as $y$) >> -> - fun curr next _ k -> - [: `S LO "("; `patt x [: `S LR "as" :]; - `patt y [: `S RO ")"; k :] :] - | ( <:patt< $int:s$ >> | <:patt< $flo:s$ >> ) -> - fun curr next _ k -> [: `S LR s; k :] - | MLast.PaInt32 _ s -> fun curr next _ k -> [: `S LR (s^"l"); k :] - | MLast.PaInt64 _ s -> fun curr next _ k -> [: `S LR (s^"L"); k :] - | MLast.PaNativeInt _ s -> fun curr next _ k -> [: `S LR (s^"n"); k :] - | <:patt< $str:s$ >> -> - fun curr next _ k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:patt< $chr:c$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ c ^ "'"); k :] - | <:patt< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:patt< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:patt< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :] - | <:patt< # $list:sl$ >> -> - fun curr next _ k -> [: `S LO "#"; mod_ident sl k :] - | <:patt< ~ $i$ >> -> - fun curr next _ k -> [: `S LR ("~" ^ i); k :] - | <:patt< ~ $i$ : $p$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr p "" k :] - | <:patt< ? $i$ >> -> - fun curr next _ k -> [: `S LR ("?" ^ i); k :] - | <:patt< ? $i$ : ($p$ : $t$) >> -> - fun curr next _ k -> - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$) >> -> - fun curr next _ k -> - if i = "" then [: `S LO "?"; curr p "" k :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; - `patt p [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$ : $t$ = $e$) >> -> - fun curr next _ k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$ = $e$) >> -> - fun curr next _ k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p [: `S LR "=" :]; - `expr e [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR "=" :]; - `expr e [: `S RO ")"; k :] :] - | <:patt< _ >> -> fun curr next _ k -> [: `S LR "_"; k :] - | <:patt< $_$ $_$ >> | <:patt< $_$ .. $_$ >> | - <:patt< $_$ | $_$ >> as p -> - fun curr next _ k -> - [: `S LO "("; `patt p [: `HVbox [: `S RO ")"; k :] :] :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}]; - -pr_ctyp.pr_levels := - [{pr_label = "top"; pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ == $t2$ >> -> - fun curr next _ k -> - [: curr t1 "" [: `S LR "==" :]; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ as $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S LR "as" :]; `next y "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ! $list:pl$ . $t$ >> -> - fun curr next dg k -> - if pl = [] then [: `ctyp t k :] - else - [: `HVbox [: `S LR "!"; list typevar pl [: `S LR "." :] :]; - `ctyp t k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ -> $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "->" :]; curr y "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ $t2$ >> -> - fun curr next _ k -> [: curr t1 "" [: :]; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ? $lab$ : $t$ >> -> - fun curr next _ k -> - [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :] - | <:ctyp< ~ $lab$ : $t$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ lab ^ ":"); `next t "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ . $t2$ >> -> - fun curr next _ k -> - [: curr t1 "" [: :]; `S NO "."; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = "simple"; - pr_box t x = LocInfo (MLast.loc_of_ctyp t) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ($list:tl$) >> -> - fun curr next _ k -> - [: `S LO "("; listws ctyp (S LR "*") tl [: `S RO ")"; k :] :] - | <:ctyp< '$s$ >> -> - fun curr next _ k -> [: `S LO "'"; `S LR (var_escaped s); k :] - | <:ctyp< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:ctyp< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:ctyp< _ >> -> fun curr next _ k -> [: `S LR "_"; k :] - | <:ctyp< private { $list: ftl$ } >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: `HVbox [:`S LR "private" :]; - `HVbox [: labels loc [:`S LR "{" :] - ftl [: `S LR "}" :] :]; - k :] :] - | <:ctyp< { $list: ftl$ } >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: labels loc [: `S LR "{" :] ftl [: `S LR "}" :]; k :] :] - | <:ctyp< [ $list:ctl$ ] >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: :]; - variants loc [: `S LR "[" :] ctl [: `S LR "]" :]; k :] :] - | <:ctyp< private [ $list:ctl$ ] >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: `S LR "private" :]; - variants loc [: `S LR "[" :] ctl [: `S LR "]" :]; k :] :] - | <:ctyp< [ = $list:rfl$ ] >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[ =" :] rfl [: `S LR "]" :]; k :] :] - | <:ctyp< [ > $list:rfl$ ] >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[ >" :] rfl [: `S LR "]" :]; k :] :] - | <:ctyp< [ < $list:rfl$ > $list:sl$ ] >> -> - fun curr next _ k -> - let k1 = [: `S LR "]" :] in - let k1 = - match sl with - [ [] -> k1 - | l -> - [: `S LR ">"; - list (fun x k -> HVbox [: `S LR x; k :]) l k1 :] ] - in - [: `HVbox - [: `HVbox [: :]; row_fields [: `S LR "[ <" :] rfl k1; - k :] :] - | <:ctyp< # $list:id$ >> -> - fun curr next _ k -> [: `S LO "#"; `class_longident id k :] - | <:ctyp< < > >> -> fun curr next _ k -> [: `S LR "<>"; k :] - | <:ctyp< < $list:ml$ $opt:v$ > >> -> - fun curr next _ k -> - [: `S LR "<"; meth_list (ml, v) [: `S LR ">"; k :] :] - | <:ctyp< $_$ -> $_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< $_$ == $_$ >> | - <:ctyp< $_$ . $_$ >> | <:ctyp< $_$ as $_$ >> | - <:ctyp< ? $_$ : $_$ >> | <:ctyp< ~ $_$ : $_$ >> | - <:ctyp< ! $list:_$ . $_$ >> as t -> - fun curr next _ k -> - [: `S LO "("; `ctyp t [: `HVbox [: `S RO ")"; k :] :] :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}]; - -pr_class_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_sig_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:class_sig_item< type $t1$ = $t2$ >> -> - fun curr next _ k -> - [: `S LR "type"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :] - | <:class_sig_item< declare $list:s$ end >> -> - fun curr next _ k -> [: `HVbox [: :]; list class_sig_item s k :] - | <:class_sig_item< inherit $ce$ >> -> - fun curr next _ k -> [: `S LR "inherit"; `class_type ce k :] - | <:class_sig_item< method $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `label lab; `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method private $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "private"; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< value $opt:mf$ $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "value"; flag "mutable" mf; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method virtual $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method virtual private $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; `S LR "private"; - `label lab; `S LR ":" :]; - `ctyp t k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (MLast.loc_of_class_str_item s) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ MLast.CrDcl _ s -> - fun curr next _ k -> [: `HVbox [: :]; list class_str_item s [: :] :] - | MLast.CrInh _ ce pb -> - fun curr next _ k -> - [: `S LR "inherit"; `class_expr ce [: :]; - match pb with - [ Some i -> [: `S LR "as"; `S LR i :] - | _ -> [: :] ]; - k :] - | MLast.CrVal _ lab mf e -> - fun curr next _ k -> - [: `cvalue [: `S LR "value" :] (lab, mf, e) k :] - | MLast.CrVir _ lab pf t -> - fun curr next _ k -> - [: `S LR "method"; `S LR "virtual"; flag "private" pf; `label lab; - `S LR ":"; `ctyp t k :] - | MLast.CrMth _ lab pf fb None -> - fun curr next _ k -> - [: `fun_binding - [: `S LR "method"; flag "private" pf; `label lab :] fb k :] - | MLast.CrMth _ lab pf fb (Some t) -> - fun curr next dg k -> - [: `HOVbox - [: `S LR "method"; flag "private" pf; `label lab; `S LR ":"; - `ctyp t [: `S LR "=" :] :]; - `expr fb k :] - | MLast.CrCtr _ t1 t2 -> - fun curr next _ k -> - [: `HVbox [: `S LR "type"; `ctyp t1 [: `S LR "=" :] :]; - `ctyp t2 k :] - | MLast.CrIni _ se -> - fun curr next _ k -> [: `S LR "initializer"; `expr se k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_type.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CtFun _ t ct -> - fun curr next _ k -> - [: `S LR "["; `ctyp t [: `S LR "]"; `S LR "->" :]; - `class_type ct k :] - | ct -> fun curr next _ k -> [: `class_signature ct k :] ]}]; - -pr_class_expr.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeFun _ p ce -> - fun curr next _ k -> - [: `S LR "fun"; `simple_patt p [: `S LR "->" :]; - `class_expr ce k :] - | MLast.CeLet _ rf lb ce -> - fun curr next _ k -> - [: `Vbox - [: `HVbox [: :]; - `bind_list [: `S LR "let"; flag "rec" rf :] lb - [: `S LR "in" :]; - `class_expr ce k :] :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeApp _ ce e -> - fun curr next _ k -> [: curr ce "" [: :]; `simple_expr e k :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeCon _ ci [] -> - fun curr next _ k -> [: `class_longident ci k :] - | MLast.CeCon _ ci ctcl -> - fun curr next _ k -> - [: `class_longident ci [: :]; `S LO "["; - listws ctyp (S RO ",") ctcl [: `S RO "]"; k :] :] - | MLast.CeStr _ csp cf as ce -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_class_expr ce) in - [: `BEbox - [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; - `HVbox - [: `HVbox [: :]; list class_str_item cf [: :]; - `LocInfo (ep, ep) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | MLast.CeTyc _ ce ct -> - fun curr next _ k -> - [: `S LO "("; `class_expr ce [: `S LR ":" :]; - `class_type ct [: `S RO ")"; k :] :] - | MLast.CeFun _ _ _ as ce -> - fun curr next _ k -> - [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :] - | ce -> fun curr next _ k -> [: `not_impl "class_expr" ce; k :] ]}]; - -value output_string_eval oc s = - loop 0 where rec loop i = - if i == String.length s then () - else if i == String.length s - 1 then output_char oc s.[i] - else - match (s.[i], s.[i + 1]) with - [ ('\\', 'n') -> do { output_char oc '\n'; loop (i + 2) } - | (c, _) -> do { output_char oc c; loop (i + 1) } ] -; - -value maxl = ref 78; -value sep = Pcaml.inter_phrases; -value ncip = ref True; - -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 ic oc first bp ep = - match sep.val with - [ Some str -> - if first then () - else if ep == in_channel_length ic then output_string oc "\n" - else output_string_eval oc str - | None -> - do { - seek_in ic bp; - let s = input_source ic (ep - bp) in - output_string oc s - } ] -; - -value copy_to_end ic oc first bp = - let ilen = in_channel_length ic in - if bp < ilen then copy_source ic oc first bp ilen else output_string oc "\n" -; - -module Buff = - struct - value buff = ref (String.create 80); - value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } - ; - value mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len - else add_rec (store len s.[i]) (succ i) - ; - value get len = String.sub buff.val 0 len; - end -; - -value extract_comment strm = - let rec find_comm nl_bef tab_bef = - parser - [ [: `'('; a = find_star nl_bef tab_bef :] -> a - | [: `' '; s :] -> find_comm nl_bef (tab_bef + 1) s - | [: `'\t'; s :] -> find_comm nl_bef (tab_bef + 8) s - | [: `'\n'; s :] -> find_comm (nl_bef + 1) 0 s - | [: `_; s :] -> find_comm 0 0 s - | [: :] -> ("", nl_bef, tab_bef) ] - and find_star nl_bef tab_bef = - parser - [ [: `'*'; a = insert (Buff.mstore 0 "(*") :] -> (a, nl_bef, tab_bef) - | [: a = find_comm 0 0 :] -> a ] - and insert len = - parser - [ [: `'*'; a = rparen (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert len s - | [: `'\t'; s :] -> insert (Buff.mstore len (String.make 8 ' ')) s - | [: `x; s :] -> insert (Buff.store len x) s - | [: :] -> "" ] - and rparen len = - parser - [ [: `')'; s :] -> while_space (Buff.store len ')') s - | [: a = insert len :] -> a ] - and while_space len = - parser - [ [: `' '; a = while_space (Buff.store len ' ') :] -> a - | [: `'\t'; a = while_space (Buff.mstore len (String.make 8 ' ')) :] -> a - | [: `'\n'; a = while_space (Buff.store len '\n') :] -> a - | [: `'('; a = find_star_again len :] -> a - | [: :] -> Buff.get len ] - and find_star_again len = - parser - [ [: `'*'; a = insert (Buff.mstore len "(*") :] -> a - | [: :] -> Buff.get len ] - and find_star2 len = - parser - [ [: `'*'; a = insert2 (Buff.store len '*') :] -> a - | [: :] -> len ] - and insert2 len = - parser - [ [: `'*'; a = rparen2 (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert2 len s - | [: `x; s :] -> insert2 (Buff.store len x) s - | [: :] -> 0 ] - and rparen2 len = - parser - [ [: `')' :] -> Buff.store len ')' - | [: a = insert2 len :] -> a ] - in - find_comm 0 0 strm -; - -value get_no_comment _ _ = ("", 0, 0, 0); - -value get_comment ic beg len = - do { - seek_in ic beg; - let strm = - Stream.from (fun i -> if i >= len then None else Some (input_char ic)) - in - let (s, nl_bef, tab_bef) = extract_comment strm in - (s, nl_bef, tab_bef, Stream.count strm) - } -; - -value apply_printer printer ast = - let oc = - match Pcaml.output_file.val with - [ Some f -> open_out_bin f - | None -> stdout ] - in - let cleanup () = - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - in - let pr_ch = output_char oc in - let pr_str = output_string oc in - let pr_nl () = output_char oc '\n' in - if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { - let ic = open_in_bin Pcaml.input_file.val in - let getcom = - if not ncip.val && sep.val = None then get_comment ic - else get_no_comment - in - try - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - copy_source ic oc first last_pos bp; - flush oc; - print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp - (printer si [: :]); - flush oc; - (False, ep) - }) - (True, 0) ast - in - do { copy_to_end ic oc first last_pos; flush oc } - with x -> - do { close_in ic; cleanup (); raise x }; - close_in ic; - cleanup () - } - else do { - List.iter - (fun (si, _) -> - do { - print_pretty pr_ch pr_str pr_nl "" "" maxl.val get_no_comment 0 - (printer si [: :]); - match sep.val with - [ Some str -> output_string_eval oc str - | None -> output_char oc '\n' ]; - flush oc - }) - ast; - cleanup () - } -; - -Pcaml.print_interf.val := apply_printer sig_item; -Pcaml.print_implem.val := apply_printer str_item; - -Pcaml.add_option "-l" (Arg.Int (fun x -> maxl.val := x)) - "<length> Maximum line length for pretty printing."; - -Pcaml.add_option "-sep_src" (Arg.Unit (fun () -> sep.val := None)) - "Read source file for text between phrases (default)."; - -Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) - "<string> Use this string between phrases instead of reading source."; - -Pcaml.add_option "-no_where" (Arg.Clear gen_where) - "Dont generate \"where\" statements"; - -Pcaml.add_option "-cip" (Arg.Clear ncip) "Add comments in phrases."; - -Pcaml.add_option "-ncip" (Arg.Set ncip) "No comments in phrases (default)."; - -Pcaml.add_option "-old_seq" (Arg.Set old_sequences) - "Pretty print with old syntax for sequences."; - -Pcaml.add_option "-exp_dcl" (Arg.Set expand_declare) - "Expand the \"declare\" items."; - -Pcaml.add_option "-tc" (Arg.Clear ncip) - "Deprecated since version 3.05; equivalent to -cip."; |