parmatch: split pretty printing out into Printpat
Thomas Refis
Thomas Refis
parent
f1136ad9e7
commit
60c5f6fe91
107
.depend
107
.depend
|
|
@ -261,18 +261,18 @@ typing/oprint.cmi : typing/outcometree.cmi
|
|||
typing/outcometree.cmi : parsing/asttypes.cmi
|
||||
typing/parmatch.cmo : utils/warnings.cmi typing/untypeast.cmi \
|
||||
typing/types.cmi typing/typedtreeIter.cmi typing/typedtree.cmi \
|
||||
typing/subst.cmi typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
|
||||
utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
|
||||
typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
|
||||
typing/btype.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
|
||||
typing/parmatch.cmi
|
||||
typing/subst.cmi typing/printpat.cmi typing/predef.cmi typing/path.cmi \
|
||||
parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \
|
||||
parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
|
||||
utils/config.cmi typing/btype.cmi parsing/asttypes.cmi \
|
||||
parsing/ast_helper.cmi typing/parmatch.cmi
|
||||
typing/parmatch.cmx : utils/warnings.cmx typing/untypeast.cmx \
|
||||
typing/types.cmx typing/typedtreeIter.cmx typing/typedtree.cmx \
|
||||
typing/subst.cmx typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \
|
||||
utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
|
||||
typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
|
||||
typing/btype.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
|
||||
typing/parmatch.cmi
|
||||
typing/subst.cmx typing/printpat.cmx typing/predef.cmx typing/path.cmx \
|
||||
parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \
|
||||
parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
|
||||
utils/config.cmx typing/btype.cmx parsing/asttypes.cmi \
|
||||
parsing/ast_helper.cmx typing/parmatch.cmi
|
||||
typing/parmatch.cmi : typing/types.cmi typing/typedtree.cmi \
|
||||
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
|
||||
typing/env.cmi parsing/asttypes.cmi
|
||||
|
|
@ -294,6 +294,11 @@ typing/primitive.cmx : parsing/parsetree.cmi typing/outcometree.cmi \
|
|||
typing/primitive.cmi
|
||||
typing/primitive.cmi : parsing/parsetree.cmi typing/outcometree.cmi \
|
||||
parsing/location.cmi
|
||||
typing/printpat.cmo : typing/types.cmi typing/typedtree.cmi typing/ident.cmi \
|
||||
parsing/asttypes.cmi typing/printpat.cmi
|
||||
typing/printpat.cmx : typing/types.cmx typing/typedtree.cmx typing/ident.cmx \
|
||||
parsing/asttypes.cmi typing/printpat.cmi
|
||||
typing/printpat.cmi : typing/typedtree.cmi parsing/asttypes.cmi
|
||||
typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \
|
||||
typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
|
||||
typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \
|
||||
|
|
@ -311,12 +316,14 @@ typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \
|
|||
typing/printtyp.cmi : typing/types.cmi typing/path.cmi \
|
||||
typing/outcometree.cmi parsing/longident.cmi typing/ident.cmi \
|
||||
typing/env.cmi parsing/asttypes.cmi
|
||||
typing/printtyped.cmo : typing/typedtree.cmi parsing/printast.cmi \
|
||||
typing/path.cmi utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
|
||||
typing/ident.cmi parsing/asttypes.cmi typing/printtyped.cmi
|
||||
typing/printtyped.cmx : typing/typedtree.cmx parsing/printast.cmx \
|
||||
typing/path.cmx utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
|
||||
typing/ident.cmx parsing/asttypes.cmi typing/printtyped.cmi
|
||||
typing/printtyped.cmo : typing/types.cmi typing/typedtree.cmi \
|
||||
parsing/printast.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \
|
||||
parsing/location.cmi typing/ident.cmi parsing/asttypes.cmi \
|
||||
typing/printtyped.cmi
|
||||
typing/printtyped.cmx : typing/types.cmx typing/typedtree.cmx \
|
||||
parsing/printast.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \
|
||||
parsing/location.cmx typing/ident.cmx parsing/asttypes.cmi \
|
||||
typing/printtyped.cmi
|
||||
typing/printtyped.cmi : typing/typedtree.cmi
|
||||
typing/stypes.cmo : typing/typedtree.cmi typing/printtyp.cmi utils/misc.cmi \
|
||||
parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi
|
||||
|
|
@ -359,25 +366,25 @@ typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \
|
|||
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
|
||||
typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi
|
||||
typing/typecore.cmo : utils/warnings.cmi typing/typetexp.cmi \
|
||||
typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \
|
||||
typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi \
|
||||
typing/primitive.cmi typing/predef.cmi typing/path.cmi \
|
||||
parsing/parsetree.cmi typing/parmatch.cmi typing/oprint.cmi \
|
||||
utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
|
||||
typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \
|
||||
utils/clflags.cmi parsing/builtin_attributes.cmi typing/btype.cmi \
|
||||
parsing/asttypes.cmi parsing/ast_helper.cmi typing/annot.cmi \
|
||||
typing/typecore.cmi
|
||||
typing/types.cmi typing/typeopt.cmi typing/typedtree.cmi \
|
||||
typing/typedecl.cmi typing/subst.cmi typing/stypes.cmi \
|
||||
typing/printtyp.cmi typing/printpat.cmi typing/primitive.cmi \
|
||||
typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \
|
||||
typing/parmatch.cmi typing/oprint.cmi utils/misc.cmi \
|
||||
parsing/longident.cmi parsing/location.cmi typing/ident.cmi \
|
||||
typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi utils/clflags.cmi \
|
||||
parsing/builtin_attributes.cmi typing/btype.cmi parsing/asttypes.cmi \
|
||||
parsing/ast_helper.cmi typing/annot.cmi typing/typecore.cmi
|
||||
typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \
|
||||
typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \
|
||||
typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx \
|
||||
typing/primitive.cmx typing/predef.cmx typing/path.cmx \
|
||||
parsing/parsetree.cmi typing/parmatch.cmx typing/oprint.cmx \
|
||||
utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
|
||||
typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx \
|
||||
utils/clflags.cmx parsing/builtin_attributes.cmx typing/btype.cmx \
|
||||
parsing/asttypes.cmi parsing/ast_helper.cmx typing/annot.cmi \
|
||||
typing/typecore.cmi
|
||||
typing/types.cmx typing/typeopt.cmx typing/typedtree.cmx \
|
||||
typing/typedecl.cmx typing/subst.cmx typing/stypes.cmx \
|
||||
typing/printtyp.cmx typing/printpat.cmx typing/primitive.cmx \
|
||||
typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \
|
||||
typing/parmatch.cmx typing/oprint.cmx utils/misc.cmx \
|
||||
parsing/longident.cmx parsing/location.cmx typing/ident.cmx \
|
||||
typing/env.cmx typing/ctype.cmx typing/cmt_format.cmx utils/clflags.cmx \
|
||||
parsing/builtin_attributes.cmx typing/btype.cmx parsing/asttypes.cmi \
|
||||
parsing/ast_helper.cmx typing/annot.cmi typing/typecore.cmi
|
||||
typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
|
||||
parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
|
||||
typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi
|
||||
|
|
@ -449,11 +456,11 @@ typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
|
|||
typing/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \
|
||||
typing/typedecl.cmi typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi \
|
||||
typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \
|
||||
typing/typeopt.cmi
|
||||
parsing/asttypes.cmi typing/typeopt.cmi
|
||||
typing/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \
|
||||
typing/typedecl.cmx typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx \
|
||||
typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \
|
||||
typing/typeopt.cmi
|
||||
parsing/asttypes.cmi typing/typeopt.cmi
|
||||
typing/typeopt.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
|
||||
bytecomp/lambda.cmi typing/env.cmi
|
||||
typing/types.cmo : typing/primitive.cmi typing/path.cmi \
|
||||
|
|
@ -571,16 +578,16 @@ bytecomp/lambda.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \
|
|||
bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \
|
||||
parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi
|
||||
bytecomp/matching.cmo : typing/types.cmi typing/typeopt.cmi \
|
||||
typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \
|
||||
typing/primitive.cmi typing/predef.cmi typing/path.cmi \
|
||||
typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \
|
||||
typing/typedtree.cmi bytecomp/switch.cmi typing/printpat.cmi \
|
||||
bytecomp/printlambda.cmi typing/primitive.cmi typing/predef.cmi \
|
||||
typing/path.cmi typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \
|
||||
parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \
|
||||
utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \
|
||||
bytecomp/matching.cmi
|
||||
bytecomp/matching.cmx : typing/types.cmx typing/typeopt.cmx \
|
||||
typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \
|
||||
typing/primitive.cmx typing/predef.cmx typing/path.cmx \
|
||||
typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \
|
||||
typing/typedtree.cmx bytecomp/switch.cmx typing/printpat.cmx \
|
||||
bytecomp/printlambda.cmx typing/primitive.cmx typing/predef.cmx \
|
||||
typing/path.cmx typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \
|
||||
parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \
|
||||
utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \
|
||||
bytecomp/matching.cmi
|
||||
|
|
@ -2222,13 +2229,13 @@ toplevel/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \
|
|||
toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \
|
||||
toplevel/opttoploop.cmi toplevel/opttopdirs.cmi utils/misc.cmi \
|
||||
driver/main_args.cmi parsing/location.cmi utils/config.cmi \
|
||||
driver/compplugin.cmi driver/compmisc.cmi driver/compenv.cmi \
|
||||
utils/clflags.cmi toplevel/opttopmain.cmi
|
||||
driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
|
||||
toplevel/opttopmain.cmi
|
||||
toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \
|
||||
toplevel/opttoploop.cmx toplevel/opttopdirs.cmx utils/misc.cmx \
|
||||
driver/main_args.cmx parsing/location.cmx utils/config.cmx \
|
||||
driver/compplugin.cmx driver/compmisc.cmx driver/compenv.cmx \
|
||||
utils/clflags.cmx toplevel/opttopmain.cmi
|
||||
driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
|
||||
toplevel/opttopmain.cmi
|
||||
toplevel/opttopmain.cmi :
|
||||
toplevel/opttopstart.cmo : toplevel/opttopmain.cmi
|
||||
toplevel/opttopstart.cmx : toplevel/opttopmain.cmx
|
||||
|
|
@ -2285,13 +2292,13 @@ toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \
|
|||
toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \
|
||||
toplevel/topdirs.cmi utils/profile.cmi utils/misc.cmi \
|
||||
driver/main_args.cmi parsing/location.cmi utils/config.cmi \
|
||||
driver/compplugin.cmi driver/compmisc.cmi driver/compenv.cmi \
|
||||
utils/clflags.cmi toplevel/topmain.cmi
|
||||
driver/compmisc.cmi driver/compenv.cmi utils/clflags.cmi \
|
||||
toplevel/topmain.cmi
|
||||
toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \
|
||||
toplevel/topdirs.cmx utils/profile.cmx utils/misc.cmx \
|
||||
driver/main_args.cmx parsing/location.cmx utils/config.cmx \
|
||||
driver/compplugin.cmx driver/compmisc.cmx driver/compenv.cmx \
|
||||
utils/clflags.cmx toplevel/topmain.cmi
|
||||
driver/compmisc.cmx driver/compenv.cmx utils/clflags.cmx \
|
||||
toplevel/topmain.cmi
|
||||
toplevel/topmain.cmi :
|
||||
toplevel/topstart.cmo : toplevel/topmain.cmi
|
||||
toplevel/topstart.cmx : toplevel/topmain.cmx
|
||||
|
|
|
|||
7
Makefile
7
Makefile
|
|
@ -104,10 +104,9 @@ TYPING=typing/ident.cmo typing/path.cmo \
|
|||
typing/typedtreeIter.cmo typing/typedtreeMap.cmo \
|
||||
typing/tast_mapper.cmo \
|
||||
typing/cmt_format.cmo typing/untypeast.cmo \
|
||||
typing/includemod.cmo typing/typetexp.cmo typing/parmatch.cmo \
|
||||
typing/stypes.cmo typing/typedecl.cmo typing/typeopt.cmo typing/typecore.cmo \
|
||||
typing/typeclass.cmo \
|
||||
typing/typemod.cmo
|
||||
typing/includemod.cmo typing/typetexp.cmo typing/printpat.cmo \
|
||||
typing/parmatch.cmo typing/stypes.cmo typing/typedecl.cmo typing/typeopt.cmo \
|
||||
typing/typecore.cmo typing/typeclass.cmo typing/typemod.cmo
|
||||
|
||||
COMP=bytecomp/lambda.cmo bytecomp/printlambda.cmo \
|
||||
bytecomp/semantics_of_primitives.cmo \
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ open Typedtree
|
|||
open Lambda
|
||||
open Parmatch
|
||||
open Printf
|
||||
open Printpat
|
||||
|
||||
|
||||
let dbg = false
|
||||
|
|
@ -399,7 +400,7 @@ let pretty_cases cases =
|
|||
(fun (ps,_l) ->
|
||||
List.iter
|
||||
(fun p ->
|
||||
Parmatch.top_pretty Format.str_formatter p ;
|
||||
top_pretty Format.str_formatter p ;
|
||||
prerr_string " " ;
|
||||
prerr_string (Format.flush_str_formatter ()))
|
||||
ps ;
|
||||
|
|
|
|||
|
|
@ -230,152 +230,6 @@ let get_constructor_type_path ty tenv =
|
|||
| Tconstr (path,_,_) -> Ok path
|
||||
| _ -> Inconsistent_environment
|
||||
|
||||
(*************************************)
|
||||
(* Values as patterns pretty printer *)
|
||||
(*************************************)
|
||||
|
||||
open Format
|
||||
;;
|
||||
|
||||
let is_cons = function
|
||||
| {cstr_name = "::"} -> true
|
||||
| _ -> false
|
||||
|
||||
let pretty_const c = match c with
|
||||
| Const_int i -> Printf.sprintf "%d" i
|
||||
| Const_char c -> Printf.sprintf "%C" c
|
||||
| Const_string (s, _) -> Printf.sprintf "%S" s
|
||||
| Const_float f -> Printf.sprintf "%s" f
|
||||
| Const_int32 i -> Printf.sprintf "%ldl" i
|
||||
| Const_int64 i -> Printf.sprintf "%LdL" i
|
||||
| Const_nativeint i -> Printf.sprintf "%ndn" i
|
||||
|
||||
let rec pretty_val ppf v =
|
||||
match v.pat_extra with
|
||||
(cstr, _loc, _attrs) :: rem ->
|
||||
begin match cstr with
|
||||
| Tpat_unpack ->
|
||||
fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
|
||||
| Tpat_constraint _ ->
|
||||
fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem }
|
||||
| Tpat_type _ ->
|
||||
fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
|
||||
| Tpat_open _ ->
|
||||
fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
|
||||
end
|
||||
| [] ->
|
||||
match v.pat_desc with
|
||||
| Tpat_any -> fprintf ppf "_"
|
||||
| Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
|
||||
| Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
|
||||
| Tpat_tuple vs ->
|
||||
fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
|
||||
| Tpat_construct (_, cstr, []) ->
|
||||
fprintf ppf "%s" cstr.cstr_name
|
||||
| Tpat_construct (_, cstr, [w]) ->
|
||||
fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w
|
||||
| Tpat_construct (_, cstr, vs) ->
|
||||
let name = cstr.cstr_name in
|
||||
begin match (name, vs) with
|
||||
("::", [v1;v2]) ->
|
||||
fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
|
||||
| _ ->
|
||||
fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
|
||||
end
|
||||
| Tpat_variant (l, None, _) ->
|
||||
fprintf ppf "`%s" l
|
||||
| Tpat_variant (l, Some w, _) ->
|
||||
fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
|
||||
| Tpat_record (lvs,_) ->
|
||||
let filtered_lvs = List.filter
|
||||
(function
|
||||
| (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
|
||||
| _ -> true) lvs in
|
||||
begin match filtered_lvs with
|
||||
| [] -> fprintf ppf "_"
|
||||
| (_, lbl, _) :: q ->
|
||||
let elision_mark ppf =
|
||||
(* we assume that there is no label repetitions here *)
|
||||
if Array.length lbl.lbl_all > 1 + List.length q then
|
||||
fprintf ppf ";@ _@ "
|
||||
else () in
|
||||
fprintf ppf "@[{%a%t}@]"
|
||||
pretty_lvals filtered_lvs elision_mark
|
||||
end
|
||||
| Tpat_array vs ->
|
||||
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
|
||||
| Tpat_lazy v ->
|
||||
fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
|
||||
| Tpat_alias (v, x,_) ->
|
||||
fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
|
||||
| Tpat_or (v,w,_) ->
|
||||
fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
|
||||
|
||||
and pretty_car ppf v = match v.pat_desc with
|
||||
| Tpat_construct (_,cstr, [_ ; _])
|
||||
when is_cons cstr ->
|
||||
fprintf ppf "(%a)" pretty_val v
|
||||
| _ -> pretty_val ppf v
|
||||
|
||||
and pretty_cdr ppf v = match v.pat_desc with
|
||||
| Tpat_construct (_,cstr, [v1 ; v2])
|
||||
when is_cons cstr ->
|
||||
fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
|
||||
| _ -> pretty_val ppf v
|
||||
|
||||
and pretty_arg ppf v = match v.pat_desc with
|
||||
| Tpat_construct (_,_,_::_)
|
||||
| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
|
||||
| _ -> pretty_val ppf v
|
||||
|
||||
and pretty_or ppf v = match v.pat_desc with
|
||||
| Tpat_or (v,w,_) ->
|
||||
fprintf ppf "%a|@,%a" pretty_or v pretty_or w
|
||||
| _ -> pretty_val ppf v
|
||||
|
||||
and pretty_vals sep ppf = function
|
||||
| [] -> ()
|
||||
| [v] -> pretty_val ppf v
|
||||
| v::vs ->
|
||||
fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs
|
||||
|
||||
and pretty_lvals ppf = function
|
||||
| [] -> ()
|
||||
| [_,lbl,v] ->
|
||||
fprintf ppf "%s=%a" lbl.lbl_name pretty_val v
|
||||
| (_, lbl,v)::rest ->
|
||||
fprintf ppf "%s=%a;@ %a"
|
||||
lbl.lbl_name pretty_val v pretty_lvals rest
|
||||
|
||||
let top_pretty ppf v =
|
||||
fprintf ppf "@[%a@]@?" pretty_val v
|
||||
|
||||
|
||||
let pretty_pat p =
|
||||
top_pretty Format.str_formatter p ;
|
||||
prerr_string (Format.flush_str_formatter ())
|
||||
|
||||
type matrix = pattern list list
|
||||
|
||||
let pretty_line ps =
|
||||
List.iter
|
||||
(fun p ->
|
||||
top_pretty Format.str_formatter p ;
|
||||
prerr_string " <" ;
|
||||
prerr_string (Format.flush_str_formatter ()) ;
|
||||
prerr_string ">")
|
||||
ps
|
||||
|
||||
let pretty_matrix (pss : matrix) =
|
||||
prerr_endline "begin matrix" ;
|
||||
List.iter
|
||||
(fun ps ->
|
||||
pretty_line ps ;
|
||||
prerr_endline "")
|
||||
pss ;
|
||||
prerr_endline "end matrix"
|
||||
|
||||
|
||||
(****************************)
|
||||
(* Utilities for matching *)
|
||||
(****************************)
|
||||
|
|
@ -1931,8 +1785,8 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
|
|||
let errmsg =
|
||||
try
|
||||
let buf = Buffer.create 16 in
|
||||
let fmt = formatter_of_buffer buf in
|
||||
top_pretty fmt v;
|
||||
let fmt = Format.formatter_of_buffer buf in
|
||||
Printpat.top_pretty fmt v;
|
||||
begin match check_partial_all v casel with
|
||||
| None -> ()
|
||||
| Some _ ->
|
||||
|
|
|
|||
|
|
@ -18,12 +18,6 @@ open Asttypes
|
|||
open Typedtree
|
||||
open Types
|
||||
|
||||
val pretty_const : constant -> string
|
||||
val top_pretty : Format.formatter -> pattern -> unit
|
||||
val pretty_pat : pattern -> unit
|
||||
val pretty_line : pattern list -> unit
|
||||
val pretty_matrix : pattern list list -> unit
|
||||
|
||||
val omega : pattern
|
||||
val omegas : int -> pattern list
|
||||
val omega_list : 'a list -> pattern list
|
||||
|
|
|
|||
|
|
@ -0,0 +1,159 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* OCaml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* en Automatique. *)
|
||||
(* *)
|
||||
(* All rights reserved. This file is distributed under the terms of *)
|
||||
(* the GNU Lesser General Public License version 2.1, with the *)
|
||||
(* special exception on linking described in the file LICENSE. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
(* Values as patterns pretty printer *)
|
||||
|
||||
open Asttypes
|
||||
open Typedtree
|
||||
open Types
|
||||
open Format
|
||||
|
||||
let is_cons = function
|
||||
| {cstr_name = "::"} -> true
|
||||
| _ -> false
|
||||
|
||||
let pretty_const c = match c with
|
||||
| Const_int i -> Printf.sprintf "%d" i
|
||||
| Const_char c -> Printf.sprintf "%C" c
|
||||
| Const_string (s, _) -> Printf.sprintf "%S" s
|
||||
| Const_float f -> Printf.sprintf "%s" f
|
||||
| Const_int32 i -> Printf.sprintf "%ldl" i
|
||||
| Const_int64 i -> Printf.sprintf "%LdL" i
|
||||
| Const_nativeint i -> Printf.sprintf "%ndn" i
|
||||
|
||||
let rec pretty_val ppf v =
|
||||
match v.pat_extra with
|
||||
(cstr, _loc, _attrs) :: rem ->
|
||||
begin match cstr with
|
||||
| Tpat_unpack ->
|
||||
fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem }
|
||||
| Tpat_constraint _ ->
|
||||
fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem }
|
||||
| Tpat_type _ ->
|
||||
fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
|
||||
| Tpat_open _ ->
|
||||
fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem }
|
||||
end
|
||||
| [] ->
|
||||
match v.pat_desc with
|
||||
| Tpat_any -> fprintf ppf "_"
|
||||
| Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
|
||||
| Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
|
||||
| Tpat_tuple vs ->
|
||||
fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
|
||||
| Tpat_construct (_, cstr, []) ->
|
||||
fprintf ppf "%s" cstr.cstr_name
|
||||
| Tpat_construct (_, cstr, [w]) ->
|
||||
fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w
|
||||
| Tpat_construct (_, cstr, vs) ->
|
||||
let name = cstr.cstr_name in
|
||||
begin match (name, vs) with
|
||||
("::", [v1;v2]) ->
|
||||
fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2
|
||||
| _ ->
|
||||
fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs
|
||||
end
|
||||
| Tpat_variant (l, None, _) ->
|
||||
fprintf ppf "`%s" l
|
||||
| Tpat_variant (l, Some w, _) ->
|
||||
fprintf ppf "@[<2>`%s@ %a@]" l pretty_arg w
|
||||
| Tpat_record (lvs,_) ->
|
||||
let filtered_lvs = List.filter
|
||||
(function
|
||||
| (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
|
||||
| _ -> true) lvs in
|
||||
begin match filtered_lvs with
|
||||
| [] -> fprintf ppf "_"
|
||||
| (_, lbl, _) :: q ->
|
||||
let elision_mark ppf =
|
||||
(* we assume that there is no label repetitions here *)
|
||||
if Array.length lbl.lbl_all > 1 + List.length q then
|
||||
fprintf ppf ";@ _@ "
|
||||
else () in
|
||||
fprintf ppf "@[{%a%t}@]"
|
||||
pretty_lvals filtered_lvs elision_mark
|
||||
end
|
||||
| Tpat_array vs ->
|
||||
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
|
||||
| Tpat_lazy v ->
|
||||
fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
|
||||
| Tpat_alias (v, x,_) ->
|
||||
fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
|
||||
| Tpat_or (v,w,_) ->
|
||||
fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
|
||||
|
||||
and pretty_car ppf v = match v.pat_desc with
|
||||
| Tpat_construct (_,cstr, [_ ; _])
|
||||
when is_cons cstr ->
|
||||
fprintf ppf "(%a)" pretty_val v
|
||||
| _ -> pretty_val ppf v
|
||||
|
||||
and pretty_cdr ppf v = match v.pat_desc with
|
||||
| Tpat_construct (_,cstr, [v1 ; v2])
|
||||
when is_cons cstr ->
|
||||
fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
|
||||
| _ -> pretty_val ppf v
|
||||
|
||||
and pretty_arg ppf v = match v.pat_desc with
|
||||
| Tpat_construct (_,_,_::_)
|
||||
| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v
|
||||
| _ -> pretty_val ppf v
|
||||
|
||||
and pretty_or ppf v = match v.pat_desc with
|
||||
| Tpat_or (v,w,_) ->
|
||||
fprintf ppf "%a|@,%a" pretty_or v pretty_or w
|
||||
| _ -> pretty_val ppf v
|
||||
|
||||
and pretty_vals sep ppf = function
|
||||
| [] -> ()
|
||||
| [v] -> pretty_val ppf v
|
||||
| v::vs ->
|
||||
fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs
|
||||
|
||||
and pretty_lvals ppf = function
|
||||
| [] -> ()
|
||||
| [_,lbl,v] ->
|
||||
fprintf ppf "%s=%a" lbl.lbl_name pretty_val v
|
||||
| (_, lbl,v)::rest ->
|
||||
fprintf ppf "%s=%a;@ %a"
|
||||
lbl.lbl_name pretty_val v pretty_lvals rest
|
||||
|
||||
let top_pretty ppf v =
|
||||
fprintf ppf "@[%a@]@?" pretty_val v
|
||||
|
||||
|
||||
let pretty_pat p =
|
||||
top_pretty Format.str_formatter p ;
|
||||
prerr_string (Format.flush_str_formatter ())
|
||||
|
||||
type matrix = pattern list list
|
||||
|
||||
let pretty_line ps =
|
||||
List.iter
|
||||
(fun p ->
|
||||
top_pretty Format.str_formatter p ;
|
||||
prerr_string " <" ;
|
||||
prerr_string (Format.flush_str_formatter ()) ;
|
||||
prerr_string ">")
|
||||
ps
|
||||
|
||||
let pretty_matrix (pss : matrix) =
|
||||
prerr_endline "begin matrix" ;
|
||||
List.iter
|
||||
(fun ps ->
|
||||
pretty_line ps ;
|
||||
prerr_endline "")
|
||||
pss ;
|
||||
prerr_endline "end matrix"
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* OCaml *)
|
||||
(* *)
|
||||
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 1996 Institut National de Recherche en Informatique et *)
|
||||
(* en Automatique. *)
|
||||
(* *)
|
||||
(* All rights reserved. This file is distributed under the terms of *)
|
||||
(* the GNU Lesser General Public License version 2.1, with the *)
|
||||
(* special exception on linking described in the file LICENSE. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
|
||||
|
||||
val pretty_const : Asttypes.constant -> string
|
||||
val top_pretty : Format.formatter -> Typedtree.pattern -> unit
|
||||
val pretty_pat : Typedtree.pattern -> unit
|
||||
val pretty_line : Typedtree.pattern list -> unit
|
||||
val pretty_matrix : Typedtree.pattern list list -> unit
|
||||
|
|
@ -5150,7 +5150,7 @@ let report_error env ppf = function
|
|||
"@[%s@ %s@ %a@]"
|
||||
"This match case could not be refuted."
|
||||
"Here is an example of a value that would reach it:"
|
||||
Parmatch.top_pretty pat
|
||||
Printpat.top_pretty pat
|
||||
| Invalid_extension_constructor_payload ->
|
||||
fprintf ppf
|
||||
"Invalid [%%extension_constructor] payload, a constructor is expected."
|
||||
|
|
|
|||
Loading…
Reference in New Issue