let pp_odn ?(opened_modules=[]) fmt t =
let opened_modules =
List.sort
(fun mod1 mod2 -> String.length mod2 - String.length mod1)
opened_modules
in
let pp_list pp_elem lst_sep fmt =
function
| [] ->
()
| hd :: tl ->
pp_elem fmt hd;
List.iter
(fun e ->
fprintf fmt lst_sep;
pp_elem fmt e)
tl
in
let pp_print_id fmt id =
let chop_opened_module str =
try
let str_len =
String.length str
in
let matching_opened_mod =
List.find
(fun opened_mod ->
let opened_mod_len =
String.length opened_mod
in
if opened_mod_len + 1 <= str_len then
(opened_mod = String.sub str 0 opened_mod_len)
&&
str.[opened_mod_len] = '.'
else
false)
opened_modules
in
let chop_prefix_len =
(String.length matching_opened_mod) + 1
in
String.sub str chop_prefix_len (str_len - chop_prefix_len)
with Not_found ->
str
in
pp_print_string fmt (chop_opened_module id)
in
let rec pp_odn_aux fmt =
function
| REC (mod_nm, flds) ->
begin
match flds with
| (hd_fld, hd_e) :: tl ->
begin
let pp_field fmt (fld, e) =
fprintf fmt
"@[<hv 2>%a =@ %a@];@ "
pp_print_id fld
pp_odn_aux e
in
fprintf fmt "@[{@[<hv 2>@,";
pp_field fmt (mod_nm^"."^hd_fld, hd_e);
List.iter (pp_field fmt) tl;
fprintf fmt "@]@,}@]"
end
| [] ->
fprintf fmt "{}"
end
| LST lst ->
fprintf fmt "@[[@[<hv 2>@,%a@]@,]@]"
(pp_list pp_odn_aux ";@ ") lst
| STR str ->
fprintf fmt "%S" str
| VRT (nm, []) ->
pp_print_id fmt nm
| VRT (nm, lst) ->
fprintf fmt
"@[<hv 2>%a@ %a@]"
pp_print_id nm
pp_odn_aux (TPL lst)
| BOO b ->
pp_print_bool fmt b
| TPL [] ->
pp_print_string fmt "()"
| TPL [(FLT _) as v]
| TPL [(INT _) as v]
| TPL [(STR _) as v]
| TPL [(REC _) as v]
| TPL [(LST _) as v]
| TPL [(BOO _) as v]
| TPL [UNT as v]
| TPL [(VAR _) as v] ->
pp_odn_aux fmt v
| TPL lst ->
fprintf fmt
"@[<hv 2>(%a)@]"
(pp_list pp_odn_aux ",@ ") lst
| UNT ->
pp_print_string fmt "()"
| FLT f ->
pp_print_float fmt f
| INT i ->
pp_print_int fmt i
| APP (fnm, named_args, args) ->
fprintf fmt
"@[<hv 2>%a%a%a@]"
pp_print_id fnm
(pp_list
(fun fmt (nm, e) ->
fprintf fmt "@ ~%s:%a" nm pp_odn_aux e) "")
named_args
(pp_list
(fun fmt e ->
fprintf fmt "@ %a" pp_odn_aux e) "")
args
| VAR nm ->
pp_print_id fmt nm
| PVR (nm, None) ->
pp_print_id fmt ("`"^nm)
| PVR (nm, Some tpl) ->
fprintf fmt
"@[<hv 2>`%a@ %a@]"
pp_print_id nm
pp_odn_aux tpl
in
pp_odn_aux fmt t