Some expressions remain to be pretty-printed.
Fixed a bug in the semantic action of the parser for record updates.
This commit is contained in:
Christian Rinderknecht
parent
262f34f214
commit
85aa1a21d1
@ -640,7 +640,7 @@ update_record:
|
|||||||
lbrace = $1;
|
lbrace = $1;
|
||||||
record = $2;
|
record = $2;
|
||||||
kwd_with = $3;
|
kwd_with = $3;
|
||||||
updates = {value = {compound = Braces($1,$5);
|
updates = {value = {compound = Braces (ghost, ghost);
|
||||||
ne_elements;
|
ne_elements;
|
||||||
terminator};
|
terminator};
|
||||||
region = cover $3 $5};
|
region = cover $3 $5};
|
||||||
|
|||||||
@ -1,415 +1,412 @@
|
|||||||
[@@@warning "-42"]
|
[@@@warning "-42"]
|
||||||
|
|
||||||
open AST
|
open AST
|
||||||
module Region = Simple_utils.Region
|
module Region = Simple_utils.Region
|
||||||
open! Region
|
open! Region
|
||||||
open! PPrint
|
open! PPrint
|
||||||
|
|
||||||
let paragraph (s : string) = flow (break 1) (words s)
|
let paragraph (s : string) = flow (break 1) (words s)
|
||||||
|
|
||||||
let rec make ast =
|
let rec make ast =
|
||||||
let app decl = group (pp_declaration decl) in
|
let app decl = group (pp_declaration decl) in
|
||||||
separate_map (hardline ^^ hardline) app (Utils.nseq_to_list ast.decl)
|
separate_map (hardline ^^ hardline) app (Utils.nseq_to_list ast.decl)
|
||||||
|
|
||||||
and pp_declaration = function
|
and pp_declaration = function
|
||||||
Let decl -> pp_let_decl decl
|
Let decl -> pp_let_decl decl
|
||||||
| TypeDecl decl -> pp_type_decl decl
|
| TypeDecl decl -> pp_type_decl decl
|
||||||
|
|
||||||
and pp_let_decl Region.{value; _} =
|
and pp_let_decl Region.{value; _} =
|
||||||
let _, rec_opt, binding, attr = value in
|
let _, rec_opt, binding, attr = value in
|
||||||
let rec_doc =
|
let rec_doc =
|
||||||
match rec_opt with
|
match rec_opt with
|
||||||
None -> empty
|
None -> empty
|
||||||
| Some _ -> string " rec" in
|
| Some _ -> string "rec " in
|
||||||
let binding = pp_let_binding binding
|
let binding = pp_let_binding binding
|
||||||
and attr = pp_attributes attr
|
and attr = pp_attributes attr
|
||||||
in string "let" ^^ rec_doc ^/^ binding ^/^ attr
|
in string "let " ^^ rec_doc ^^ binding ^/^ attr
|
||||||
|
|
||||||
and pp_attributes attr =
|
and pp_attributes attr =
|
||||||
let sep = string ";" ^^ break 1 in
|
let sep = string ";" ^^ break 1 in
|
||||||
let make s = string "[@@" ^^ string s.value ^^ string "]"
|
let make s = string "[@@" ^^ string s.value ^^ string "]"
|
||||||
in separate_map sep make attr
|
in separate_map sep make attr
|
||||||
|
|
||||||
and pp_ident Region.{value; _} = string value
|
and pp_ident Region.{value; _} = string value
|
||||||
|
|
||||||
and pp_string s = pp_ident s
|
and pp_string s = pp_ident s
|
||||||
|
|
||||||
and pp_let_binding (binding : let_binding) =
|
and pp_let_binding (binding : let_binding) =
|
||||||
let {binders; lhs_type; let_rhs; _} = binding in
|
let {binders; lhs_type; let_rhs; _} = binding in
|
||||||
let patterns = Utils.nseq_to_list binders in
|
let patterns = Utils.nseq_to_list binders in
|
||||||
let patterns = flow (break 1) (List.map pp_pattern patterns) in
|
let patterns = nest 2 (separate_map (break 1) pp_pattern patterns) in
|
||||||
let lhs_type =
|
let lhs_type =
|
||||||
match lhs_type with
|
match lhs_type with
|
||||||
None -> empty
|
None -> empty
|
||||||
| Some (_, t_expr) -> string " :" ^/^ pp_type_expr t_expr in
|
| Some (_,e) -> prefix 2 1 (string " :") (pp_type_expr e)
|
||||||
let let_rhs = pp_expr let_rhs in
|
in patterns ^^ lhs_type ^^ string " ="
|
||||||
patterns ^^ lhs_type ^^ string " =" ^/^ let_rhs
|
^^ group (nest 2 (break 1 ^^ pp_expr let_rhs))
|
||||||
|
|
||||||
and pp_pattern = function
|
and pp_pattern = function
|
||||||
PConstr p -> pp_pconstr p
|
PConstr p -> pp_pconstr p
|
||||||
| PUnit _ -> string "()"
|
| PUnit _ -> string "()"
|
||||||
| PFalse _ -> string "false"
|
| PFalse _ -> string "false"
|
||||||
| PTrue _ -> string "true"
|
| PTrue _ -> string "true"
|
||||||
| PVar v -> pp_ident v
|
| PVar v -> pp_ident v
|
||||||
| PInt i -> pp_int i
|
| PInt i -> pp_int i
|
||||||
| PNat n -> pp_nat n
|
| PNat n -> pp_nat n
|
||||||
| PBytes b -> pp_bytes b
|
| PBytes b -> pp_bytes b
|
||||||
| PString s -> pp_string s
|
| PString s -> pp_string s
|
||||||
| PWild _ -> string "_"
|
| PWild _ -> string "_"
|
||||||
| PList l -> pp_plist l
|
| PList l -> pp_plist l
|
||||||
| PTuple t -> pp_ptuple t
|
| PTuple t -> pp_ptuple t
|
||||||
| PPar p -> pp_ppar p
|
| PPar p -> pp_ppar p
|
||||||
| PRecord r -> pp_precord r
|
| PRecord r -> pp_precord r
|
||||||
| PTyped t -> pp_ptyped t
|
| PTyped t -> pp_ptyped t
|
||||||
|
|
||||||
and pp_pconstr = function
|
and pp_pconstr = function
|
||||||
PNone _ -> string "None"
|
PNone _ -> string "None"
|
||||||
| PSomeApp p -> pp_patt_some p
|
| PSomeApp p -> pp_patt_some p
|
||||||
| PConstrApp a -> pp_patt_c_app a
|
| PConstrApp a -> pp_patt_c_app a
|
||||||
|
|
||||||
and pp_patt_c_app Region.{value; _} =
|
and pp_patt_c_app Region.{value; _} =
|
||||||
match value with
|
match value with
|
||||||
constr, None -> pp_ident constr
|
constr, None -> pp_ident constr
|
||||||
| constr, Some pat -> pp_ident constr ^^ pp_pattern pat
|
| constr, Some pat -> pp_ident constr ^^ pp_pattern pat
|
||||||
|
|
||||||
and pp_patt_some Region.{value; _} =
|
and pp_patt_some Region.{value; _} =
|
||||||
string "Some" ^/^ pp_pattern (snd value)
|
string "Some" ^/^ pp_pattern (snd value)
|
||||||
|
|
||||||
and pp_int Region.{value; _} =
|
and pp_int Region.{value; _} =
|
||||||
string (Z.to_string (snd value))
|
string (Z.to_string (snd value))
|
||||||
|
|
||||||
and pp_nat Region.{value; _} =
|
and pp_nat Region.{value; _} =
|
||||||
string (Z.to_string (snd value) ^ "n")
|
string (Z.to_string (snd value) ^ "n")
|
||||||
|
|
||||||
and pp_bytes Region.{value; _} =
|
and pp_bytes Region.{value; _} =
|
||||||
string ("0x" ^ Hex.show (snd value))
|
string ("0x" ^ Hex.show (snd value))
|
||||||
|
|
||||||
and pp_ppar Region.{value; _} =
|
and pp_ppar Region.{value; _} =
|
||||||
let {inside; _} = value in
|
string "(" ^^ nest 1 (pp_pattern value.inside ^^ string ")")
|
||||||
string "(" ^^ pp_pattern inside ^^ string ")"
|
|
||||||
|
and pp_plist = function
|
||||||
and pp_plist = function
|
PListComp cmp -> pp_list_comp cmp
|
||||||
PListComp cmp -> pp_list_comp cmp
|
| PCons cons -> pp_cons cons
|
||||||
| PCons cons -> pp_cons cons
|
|
||||||
|
and pp_list_comp e =
|
||||||
and pp_list_comp e =
|
string "[" ^^ pp_injection pp_pattern e ^^ string "]"
|
||||||
string "[" ^^ pp_injection pp_pattern e ^^ string "]"
|
|
||||||
|
and pp_cons Region.{value; _} =
|
||||||
and pp_cons Region.{value; _} =
|
let patt1, _, patt2 = value in
|
||||||
let patt1, _, patt2 = value in
|
pp_pattern patt1 ^^ string " ::" ^/^ pp_pattern patt2
|
||||||
pp_pattern patt1 ^^ string " ::" ^/^ pp_pattern patt2
|
|
||||||
|
and pp_ptuple Region.{value; _} =
|
||||||
and pp_ptuple Region.{value; _} =
|
let cmp = Utils.nsepseq_to_list value in
|
||||||
let cmp = Utils.nsepseq_to_list value in
|
let sep = string "," ^^ break 1 in
|
||||||
let sep = string "," ^^ break 1 in
|
separate_map sep pp_pattern cmp
|
||||||
separate_map sep pp_pattern cmp
|
|
||||||
|
and pp_precord fields = pp_ne_injection pp_field_pattern fields
|
||||||
and pp_precord Region.{value; _} =
|
|
||||||
let fields = value.ne_elements in
|
and pp_field_pattern Region.{value; _} =
|
||||||
let fields = Utils.nsepseq_to_list fields in
|
let {field_name; pattern; _} = value in
|
||||||
let sep = string ";" ^^ break 1 in
|
prefix 2 1 (pp_ident field_name ^^ string " =") (pp_pattern pattern)
|
||||||
let fields = separate_map sep pp_field_pattern fields
|
|
||||||
in string "{" ^^ fields ^^ string "}"
|
and pp_ptyped Region.{value; _} =
|
||||||
|
let {pattern; type_expr; _} = value in
|
||||||
and pp_field_pattern Region.{value; _} =
|
group (pp_pattern pattern ^^ string " :" ^/^ pp_type_expr type_expr)
|
||||||
let {field_name; pattern; _} = value in
|
|
||||||
pp_ident field_name ^^ string " =" ^/^ pp_pattern pattern
|
and pp_type_decl decl =
|
||||||
|
let {name; type_expr; _} = decl.value in
|
||||||
and pp_ptyped Region.{value; _} =
|
(* let padding = match type_expr with TSum _ -> 0 | _ -> 1 in*)
|
||||||
let {pattern; type_expr; _} = value in
|
string "type " ^^ string name.value ^^ string " ="
|
||||||
pp_pattern pattern ^^ string " :" ^/^ pp_type_expr type_expr
|
^^ group (nest 2 (break 1 ^^ pp_type_expr type_expr))
|
||||||
|
|
||||||
and pp_type_decl decl =
|
and pp_expr = function
|
||||||
let {name; type_expr; _} = decl.value in
|
ECase e -> pp_case_expr e
|
||||||
string "type " ^^ string name.value ^^ string " ="
|
| ECond e -> pp_cond_expr e
|
||||||
^^ group (nest 2 (break 1 ^^ pp_type_expr type_expr))
|
| EAnnot e -> pp_annot_expr e
|
||||||
|
| ELogic e -> pp_logic_expr e
|
||||||
and pp_expr = function
|
| EArith e -> pp_arith_expr e
|
||||||
ECase e -> pp_case_expr e
|
| EString e -> pp_string_expr e
|
||||||
| ECond e -> pp_cond_expr e
|
| EList e -> pp_list_expr e
|
||||||
| EAnnot e -> pp_annot_expr e
|
| EConstr e -> pp_constr_expr e
|
||||||
| ELogic e -> pp_logic_expr e
|
| ERecord e -> pp_record_expr e
|
||||||
| EArith e -> pp_arith_expr e
|
| EProj e -> pp_projection e
|
||||||
| EString e -> pp_string_expr e
|
| EUpdate e -> pp_update e
|
||||||
| EList e -> pp_list_expr e
|
| EVar v -> pp_ident v
|
||||||
| EConstr e -> pp_constr_expr e
|
| ECall e -> pp_call_expr e
|
||||||
| ERecord e -> pp_record_expr e
|
| EBytes e -> pp_bytes e
|
||||||
| EProj e -> pp_projection e
|
| EUnit _ -> string "()"
|
||||||
| EUpdate e -> pp_update e
|
| ETuple e -> pp_tuple_expr e
|
||||||
| EVar v -> pp_ident v
|
| EPar e -> pp_par_expr e
|
||||||
| ECall e -> pp_call_expr e
|
| ELetIn e -> pp_let_in e
|
||||||
| EBytes e -> pp_bytes e
|
| EFun e -> pp_fun e
|
||||||
| EUnit _ -> string "()"
|
| ESeq e -> pp_seq e
|
||||||
| ETuple e -> pp_tuple_expr e
|
|
||||||
| EPar e -> pp_par_expr e
|
and pp_case_expr Region.{value; _} =
|
||||||
| ELetIn e -> pp_let_in e
|
let {expr; cases; _} = value in
|
||||||
| EFun e -> pp_fun e
|
string "match " ^^ pp_expr expr ^/^ string "with" ^/^ pp_cases cases
|
||||||
| ESeq e -> pp_seq e
|
|
||||||
|
and pp_cases Region.{value; _} =
|
||||||
and pp_case_expr Region.{value; _} =
|
let cases = Utils.nsepseq_to_list value
|
||||||
let {expr; cases; _} = value in
|
and sep = break 1 ^^ string "| "
|
||||||
string "match " ^^ pp_expr expr ^/^ string "with" ^/^ pp_cases cases
|
in separate_map sep pp_clause cases
|
||||||
|
|
||||||
and pp_cases Region.{value; _} =
|
and pp_clause Region.{value; _} =
|
||||||
let cases = Utils.nsepseq_to_list value
|
let {pattern; rhs; _} = value in
|
||||||
and sep = break 1 ^^ string "| "
|
pp_pattern pattern ^^ string " ->" ^/^ pp_expr rhs
|
||||||
in separate_map sep pp_clause cases
|
|
||||||
|
and pp_cond_expr Region.{value; _} =
|
||||||
and pp_clause Region.{value; _} =
|
let {test; ifso; kwd_else; ifnot; _} = value in
|
||||||
let {pattern; rhs; _} = value in
|
let if_then = string "if " ^^ pp_expr test
|
||||||
pp_pattern pattern ^^ string " ->" ^/^ pp_expr rhs
|
^/^ string "then " ^^ pp_expr ifso in
|
||||||
|
if kwd_else#is_ghost then if_then
|
||||||
and pp_cond_expr Region.{value; _} =
|
else if_then ^/^ string "else " ^^ pp_expr ifnot
|
||||||
let {test; ifso; kwd_else; ifnot; _} = value in
|
|
||||||
let if_then = string "if " ^^ pp_expr test
|
and pp_annot_expr Region.{value; _} =
|
||||||
^/^ string "then " ^^ pp_expr ifso in
|
let expr, _, type_expr = value.inside in
|
||||||
if kwd_else#is_ghost then if_then
|
string "(" ^^ pp_expr expr ^^ string " :"
|
||||||
else if_then ^/^ string "else " ^^ pp_expr ifnot
|
^/^ pp_type_expr type_expr ^^ string ")"
|
||||||
|
|
||||||
and pp_annot_expr Region.{value; _} =
|
and pp_logic_expr = function
|
||||||
let expr, _, type_expr = value.inside in
|
BoolExpr e -> pp_bool_expr e
|
||||||
string "(" ^^ pp_expr expr ^^ string " :"
|
| CompExpr e -> pp_comp_expr e
|
||||||
^/^ pp_type_expr type_expr ^^ string ")"
|
|
||||||
|
and pp_bool_expr = function
|
||||||
and pp_logic_expr = function
|
Or e -> pp_bin_op "||" e
|
||||||
BoolExpr e -> pp_bool_expr e
|
| And e -> pp_bin_op "&&" e
|
||||||
| CompExpr e -> pp_comp_expr e
|
| Not e -> pp_un_op "not" e
|
||||||
|
| True _ -> string "true"
|
||||||
and pp_bool_expr = function
|
| False _ -> string "false"
|
||||||
Or e -> pp_bin_op "||" e
|
|
||||||
| And e -> pp_bin_op "&&" e
|
and pp_bin_op op Region.{value; _} =
|
||||||
| Not e -> pp_un_op "not" e
|
let {arg1; arg2; _} = value
|
||||||
| True _ -> string "true"
|
in pp_expr arg1 ^/^ string (op ^ " ") ^^ pp_expr arg2
|
||||||
| False _ -> string "false"
|
|
||||||
|
and pp_un_op op Region.{value; _} =
|
||||||
and pp_bin_op op Region.{value; _} =
|
string (op ^ " ") ^^ pp_expr value.arg
|
||||||
let {arg1; arg2; _} = value
|
|
||||||
in pp_expr arg1 ^/^ string (op ^ " ") ^^ pp_expr arg2
|
and pp_comp_expr = function
|
||||||
|
Lt e -> pp_bin_op "<" e
|
||||||
and pp_un_op op Region.{value; _} =
|
| Leq e -> pp_bin_op "<=" e
|
||||||
string (op ^ " ") ^^ pp_expr value.arg
|
| Gt e -> pp_bin_op ">" e
|
||||||
|
| Geq e -> pp_bin_op ">=" e
|
||||||
and pp_comp_expr = function
|
| Equal e -> pp_bin_op "=" e
|
||||||
Lt e -> pp_bin_op "<" e
|
| Neq e -> pp_bin_op "<>" e
|
||||||
| Leq e -> pp_bin_op "<=" e
|
|
||||||
| Gt e -> pp_bin_op ">" e
|
and pp_arith_expr = function
|
||||||
| Geq e -> pp_bin_op ">=" e
|
Add e -> pp_bin_op "+" e
|
||||||
| Equal e -> pp_bin_op "=" e
|
| Sub e -> pp_bin_op "-" e
|
||||||
| Neq e -> pp_bin_op "<>" e
|
| Mult e -> pp_bin_op "*" e
|
||||||
|
| Div e -> pp_bin_op "/" e
|
||||||
and pp_arith_expr = function
|
| Mod e -> pp_bin_op "mod" e
|
||||||
Add e -> pp_bin_op "+" e
|
| Neg e -> string "-" ^^ pp_expr e.value.arg
|
||||||
| Sub e -> pp_bin_op "-" e
|
| Int e -> pp_int e
|
||||||
| Mult e -> pp_bin_op "*" e
|
| Nat e -> pp_nat e
|
||||||
| Div e -> pp_bin_op "/" e
|
| Mutez e -> pp_mutez e
|
||||||
| Mod e -> pp_bin_op "mod" e
|
|
||||||
| Neg e -> string "-" ^^ pp_expr e.value.arg
|
and pp_mutez Region.{value; _} =
|
||||||
| Int e -> pp_int e
|
Z.to_string (snd value) ^ "mutez" |> string
|
||||||
| Nat e -> pp_nat e
|
|
||||||
| Mutez e -> pp_mutez e
|
and pp_string_expr = function
|
||||||
|
Cat e -> pp_bin_op "^" e
|
||||||
and pp_mutez Region.{value; _} =
|
| String e -> pp_string e
|
||||||
Z.to_string (snd value) ^ "mutez" |> string
|
|
||||||
|
and pp_list_expr = function
|
||||||
and pp_string_expr = function
|
ECons e -> pp_bin_op "::" e
|
||||||
Cat e -> pp_bin_op "^" e
|
| EListComp e -> pp_injection pp_expr e
|
||||||
| String e -> pp_string e
|
|
||||||
|
and pp_injection :
|
||||||
and pp_list_expr = function
|
'a.('a -> document) -> 'a injection Region.reg -> document =
|
||||||
ECons e -> pp_bin_op "::" e
|
fun printer Region.{value; _} ->
|
||||||
| EListComp e -> pp_injection pp_expr e
|
let {compound; elements; terminator} = value in
|
||||||
|
let sep = ";" in
|
||||||
and pp_injection :
|
let sep_doc = string sep ^^ break 1 in
|
||||||
'a.('a -> document) -> 'a injection Region.reg -> document =
|
let elements = Utils.sepseq_to_list elements in
|
||||||
fun printer Region.{value; _} ->
|
let elements = separate_map sep_doc printer elements in
|
||||||
let {compound; elements; terminator} = value in
|
let doc =
|
||||||
let sep = ";" in
|
match pp_compound compound with
|
||||||
let sep_doc = string sep ^^ break 1 in
|
None -> elements
|
||||||
let elements = Utils.sepseq_to_list elements in
|
| Some (opening, closing) ->
|
||||||
let elements = separate_map sep_doc printer elements in
|
string opening ^^ elements ^^ string closing
|
||||||
let doc =
|
in match terminator with
|
||||||
match pp_compound compound with
|
None -> doc
|
||||||
None -> elements
|
| Some _ -> doc ^^ string sep
|
||||||
| Some (opening, closing) ->
|
|
||||||
string opening ^^ elements ^^ string closing
|
and pp_compound = function
|
||||||
in match terminator with
|
BeginEnd (start, _) ->
|
||||||
None -> doc
|
if start#is_ghost then None else Some ("begin","end")
|
||||||
| Some _ -> doc ^^ string sep
|
| Braces (start, _) ->
|
||||||
|
if start#is_ghost then None else Some ("{","}")
|
||||||
and pp_compound = function
|
| Brackets (start, _) ->
|
||||||
BeginEnd (start, _) ->
|
if start#is_ghost then None else Some ("[","]")
|
||||||
if start#is_ghost then None else Some ("begin","end")
|
|
||||||
| Braces (start, _) ->
|
and pp_constr_expr = function
|
||||||
if start#is_ghost then None else Some ("{","}")
|
ENone _ -> string "None"
|
||||||
| Brackets (start, _) ->
|
| ESomeApp a -> pp_some a
|
||||||
if start#is_ghost then None else Some ("[","]")
|
| EConstrApp a -> pp_constr_app a
|
||||||
|
|
||||||
and pp_constr_expr = function
|
and pp_some Region.{value=_, e; _} = string "Some" ^/^ pp_expr e
|
||||||
ENone _ -> string "None"
|
|
||||||
| ESomeApp a -> pp_some a
|
and pp_constr_app Region.{value; _} =
|
||||||
| EConstrApp a -> pp_constr_app a
|
let constr, arg = value in
|
||||||
|
let constr = string constr.value in
|
||||||
and pp_some Region.{value=_, e; _} = string "Some" ^/^ pp_expr e
|
match arg with
|
||||||
|
None -> constr
|
||||||
and pp_constr_app Region.{value; _} =
|
| Some e -> constr ^/^ pp_expr e
|
||||||
let constr, arg = value in
|
|
||||||
let constr = string constr.value in
|
and pp_record_expr ne_inj = pp_ne_injection pp_field_assign ne_inj
|
||||||
match arg with
|
|
||||||
None -> constr
|
and pp_field_assign Region.{value; _} =
|
||||||
| Some e -> constr ^/^ pp_expr e
|
let {field_name; field_expr; _} = value in
|
||||||
|
prefix 2 1 (pp_ident field_name ^^ string " =") (pp_expr field_expr)
|
||||||
and pp_record_expr ne_inj = pp_ne_injection pp_field_assign ne_inj
|
|
||||||
|
and pp_ne_injection :
|
||||||
and pp_field_assign Region.{value; _} =
|
'a.('a -> document) -> 'a ne_injection Region.reg -> document =
|
||||||
let {field_name; field_expr; _} = value in
|
fun printer Region.{value; _} ->
|
||||||
pp_ident field_name ^^ string " =" ^/^ pp_expr field_expr
|
let {compound; ne_elements; _} = value in
|
||||||
|
let elements = pp_nsepseq ";" printer ne_elements in
|
||||||
and pp_ne_injection :
|
match pp_compound compound with
|
||||||
'a.('a -> document) -> 'a ne_injection Region.reg -> document =
|
None -> elements
|
||||||
fun printer Region.{value; _} ->
|
| Some (opening, closing) ->
|
||||||
let {compound; ne_elements; terminator} = value in
|
string opening ^^ nest 1 elements ^^ string closing
|
||||||
let elements = pp_nsepseq ";" printer ne_elements in
|
|
||||||
let doc =
|
and pp_nsepseq :
|
||||||
match pp_compound compound with
|
'a.string ->
|
||||||
None -> elements
|
('a -> document) ->
|
||||||
| Some (opening, closing) ->
|
('a, Region.t) Utils.nsepseq ->
|
||||||
string opening ^^ elements ^^ string closing
|
document =
|
||||||
in match terminator with
|
fun sep printer elements ->
|
||||||
None -> doc
|
let elems = Utils.nsepseq_to_list elements
|
||||||
| Some _ -> doc ^^ string ";"
|
and sep = string sep ^^ break 1
|
||||||
|
in separate_map sep printer elems
|
||||||
and pp_nsepseq :
|
|
||||||
'a.string ->
|
and pp_nseq : 'a.('a -> document) -> 'a Utils.nseq -> document =
|
||||||
('a -> document) ->
|
fun printer (head, tail) ->
|
||||||
('a, Region.t) Utils.nsepseq ->
|
separate_map (break 1) printer (head::tail)
|
||||||
document =
|
|
||||||
fun sep printer elements ->
|
and pp_projection Region.{value; _} =
|
||||||
let elems = Utils.nsepseq_to_list elements
|
let {struct_name; field_path; _} = value in
|
||||||
and sep = string sep ^^ break 1
|
let fields = Utils.nsepseq_to_list field_path
|
||||||
in separate_map sep printer elems
|
and sep = string "." ^^ break 0 in
|
||||||
|
let fields = separate_map sep pp_selection fields in
|
||||||
and pp_nseq : 'a.('a -> document) -> 'a Utils.nseq -> document =
|
pp_ident struct_name ^^ string "." ^^ break 0 ^^ fields
|
||||||
fun printer (head, tail) ->
|
|
||||||
separate_map (break 1) printer (head::tail)
|
and pp_selection = function
|
||||||
|
FieldName v -> string v.value
|
||||||
and pp_projection Region.{value; _} =
|
| Component cmp -> cmp.value |> snd |> Z.to_string |> string
|
||||||
let {struct_name; field_path; _} = value in
|
|
||||||
let fields = Utils.nsepseq_to_list field_path
|
and pp_update Region.{value; _} =
|
||||||
and sep = string "." ^^ break 0 in
|
let {record; updates; _} = value in
|
||||||
let fields = separate_map sep pp_selection fields in
|
let updates = pp_ne_injection pp_field_path_assign updates
|
||||||
pp_ident struct_name ^^ string "." ^^ break 0 ^^ fields
|
and record = pp_path record in
|
||||||
|
string "{" ^^ record ^^ string " with"
|
||||||
and pp_selection = function
|
^^ nest 2 (break 1 ^^ updates ^^ string "}")
|
||||||
FieldName v -> string v.value
|
|
||||||
| Component cmp -> cmp.value |> snd |> Z.to_string |> string
|
and pp_field_path_assign Region.{value; _} =
|
||||||
|
let {field_path; field_expr; _} = value in
|
||||||
and pp_update Region.{value; _} =
|
let path = pp_nsepseq "." pp_ident field_path
|
||||||
let {record; updates; _} = value in
|
in prefix 2 1 (path ^^ string " =") (pp_expr field_expr)
|
||||||
let updates = pp_ne_injection pp_field_path_assign updates
|
|
||||||
and record = pp_path record in
|
and pp_path = function
|
||||||
string "{" ^^ record ^/^ string "with" ^/^ updates ^^ string "}"
|
Name v -> pp_ident v
|
||||||
|
| Path p -> pp_projection p
|
||||||
and pp_field_path_assign Region.{value; _} =
|
|
||||||
let {field_path; field_expr; _} = value in
|
and pp_call_expr Region.{value; _} =
|
||||||
let path = pp_nsepseq "." pp_ident field_path
|
let lambda, arguments = value in
|
||||||
in path ^^ string " =" ^/^ pp_expr field_expr
|
pp_expr lambda ^/^ pp_nseq pp_expr arguments
|
||||||
|
|
||||||
and pp_path = function
|
and pp_tuple_expr Region.{value; _} =
|
||||||
Name v -> pp_ident v
|
pp_nsepseq "," pp_expr value
|
||||||
| Path p -> pp_projection p
|
|
||||||
|
and pp_par_expr Region.{value; _} =
|
||||||
and pp_call_expr Region.{value; _} =
|
string "(" ^^ pp_expr value.inside ^^ string ")"
|
||||||
let lambda, arguments = value in
|
|
||||||
pp_expr lambda ^/^ pp_nseq pp_expr arguments
|
and pp_let_in Region.{value; _} =
|
||||||
|
let {binding; kwd_rec; body; attributes; _} = value in
|
||||||
and pp_tuple_expr Region.{value; _} =
|
let binding = pp_let_binding binding
|
||||||
pp_nsepseq "," pp_expr value
|
and body = pp_expr body
|
||||||
|
and attr = pp_attributes attributes in
|
||||||
and pp_par_expr Region.{value; _} =
|
let rec_doc = match kwd_rec with
|
||||||
string "(" ^^ pp_expr value.inside ^^ string ")"
|
None -> empty
|
||||||
|
| Some _ -> string " rec"
|
||||||
and pp_let_in Region.{value; _} =
|
in string "let" ^^ rec_doc ^/^ binding
|
||||||
let {binding; kwd_rec; body; attributes; _} = value in
|
^/^ string "in" ^/^ body ^/^ attr
|
||||||
let binding = pp_let_binding binding
|
|
||||||
and body = pp_expr body
|
and pp_fun Region.{value; _} =
|
||||||
and attr = pp_attributes attributes in
|
let {binders; lhs_type; body; _} = value in
|
||||||
let rec_doc = match kwd_rec with
|
let binders = pp_nseq pp_pattern binders
|
||||||
None -> empty
|
and annot = match lhs_type with
|
||||||
| Some _ -> string " rec"
|
None -> empty
|
||||||
in string "let" ^^ rec_doc ^/^ binding
|
| Some (_,e) -> string ": " ^/^ pp_type_expr e
|
||||||
^/^ string "in" ^/^ body ^/^ attr
|
and body = pp_expr body in
|
||||||
|
string "fun " ^^ binders ^^ annot ^^ string " ->" ^/^ body
|
||||||
and pp_fun Region.{value; _} =
|
|
||||||
let {binders; lhs_type; body; _} = value in
|
and pp_seq e = pp_injection pp_expr e
|
||||||
let binders = pp_nseq pp_pattern binders
|
|
||||||
and annot = match lhs_type with
|
and pp_type_expr = function
|
||||||
None -> empty
|
TProd t -> pp_cartesian t
|
||||||
| Some (_,e) -> string ": " ^/^ pp_type_expr e
|
| TSum t -> pp_variants t
|
||||||
and body = pp_expr body in
|
| TRecord t -> pp_fields t
|
||||||
string "fun " ^^ binders ^^ annot ^^ string " ->" ^/^ body
|
| TApp t -> pp_type_app t
|
||||||
|
| TFun t -> pp_fun_type t
|
||||||
and pp_seq e = pp_injection pp_expr e
|
| TPar t -> pp_type_par t
|
||||||
|
| TVar t -> pp_ident t
|
||||||
and pp_type_expr = function
|
| TString s -> pp_string s
|
||||||
TProd t -> pp_cartesian t
|
|
||||||
| TSum t -> pp_variants t
|
and pp_cartesian Region.{value; _} =
|
||||||
| TRecord t -> pp_fields t
|
let head, tail = value in
|
||||||
| TApp t -> pp_type_app t
|
let rec app = function
|
||||||
| TFun t -> pp_fun_type t
|
[] -> empty
|
||||||
| TPar t -> pp_type_par t
|
| [e] -> group (break 1 ^^ pp_type_expr e)
|
||||||
| TVar t -> pp_ident t
|
| e::items ->
|
||||||
| TString s -> pp_string s
|
group (break 1 ^^ pp_type_expr e ^^ string " *") ^^ app items
|
||||||
|
in pp_type_expr head ^^ string " *" ^^ app (List.map snd tail)
|
||||||
and pp_cartesian Region.{value; _} =
|
|
||||||
let head, tail = value in
|
and pp_variants Region.{value; _} =
|
||||||
let rec app = function
|
let head, tail = value in
|
||||||
[] -> empty
|
let head = pp_variant head in
|
||||||
| [e] -> group (break 1 ^^ pp_type_expr e)
|
let rest = List.map snd tail in
|
||||||
| e::items ->
|
let app variant = break 1 ^^ string "| " ^^ pp_variant variant
|
||||||
group (break 1 ^^ pp_type_expr e ^^ string " *") ^^ app items
|
in ifflat head (string " " ^^ head)
|
||||||
in pp_type_expr head ^^ string " *" ^^ app (List.map snd tail)
|
^^ concat_map app rest
|
||||||
|
|
||||||
and pp_variants Region.{value; _} =
|
and pp_variant Region.{value; _} =
|
||||||
let variants = Utils.nsepseq_to_list value
|
let {constr; arg} = value in
|
||||||
in separate_map (break 1) pp_variant variants
|
match arg with
|
||||||
|
None -> pp_ident constr
|
||||||
and pp_variant Region.{value; _} =
|
| Some (_, t_expr) ->
|
||||||
let {constr; arg} = value in
|
prefix 4 1 (pp_ident constr ^^ string " of") (pp_type_expr t_expr)
|
||||||
string "| " ^^
|
|
||||||
match arg with
|
and pp_fields fields = pp_ne_injection pp_field_decl fields
|
||||||
None -> pp_ident constr
|
|
||||||
| Some (_, t_expr) ->
|
and pp_field_decl Region.{value; _} =
|
||||||
prefix 4 1 (pp_ident constr ^^ string " of") (pp_type_expr t_expr)
|
let {field_name; field_type; _} = value in
|
||||||
|
let name = pp_ident field_name in
|
||||||
and pp_fields fields =
|
let t_expr = pp_type_expr field_type
|
||||||
let fields = pp_ne_injection pp_field_decl fields
|
in prefix 2 1 (name ^^ string " :") t_expr
|
||||||
in string "{" ^^ fields ^^ string "}"
|
|
||||||
|
and pp_type_app Region.{value; _} =
|
||||||
and pp_field_decl Region.{value; _} =
|
let ctor, tuple = value in
|
||||||
let {field_name; field_type; _} = value in
|
pp_type_tuple tuple ^^ string " " ^^ pp_type_constr ctor
|
||||||
let name = pp_ident field_name in
|
|
||||||
let t_expr = pp_type_expr field_type
|
and pp_type_tuple Region.{value; _} =
|
||||||
in name ^^ string " :" ^/^ t_expr
|
let {inside; _} = value in
|
||||||
|
let head, tail = inside in
|
||||||
and pp_type_app Region.{value; _} =
|
if tail = [] then pp_type_expr head
|
||||||
let ctor, tuple = value in
|
else
|
||||||
pp_type_tuple tuple ^^ string " " ^^ pp_type_constr ctor
|
let rec app = function
|
||||||
|
[] -> empty
|
||||||
and pp_type_tuple Region.{value; _} =
|
| [e] -> group (break 1 ^^ pp_type_expr e)
|
||||||
let {inside; _} = value in
|
| e::items ->
|
||||||
match inside with
|
group (break 1 ^^ pp_type_expr e ^^ string ",") ^^ app items in
|
||||||
t_expr, [] -> pp_type_expr t_expr
|
let components =
|
||||||
| seq -> let sep = group (string "," ^^ break 1) in
|
pp_type_expr head ^^ string "," ^^ app (List.map snd tail)
|
||||||
let lst = Utils.nsepseq_to_list seq in
|
in string "(" ^^ nest 1 components ^^ string ")"
|
||||||
let cmp = separate_map sep pp_type_expr lst
|
|
||||||
in string "(" ^^ cmp ^^ string ")"
|
and pp_type_constr ctor = string ctor.value
|
||||||
|
|
||||||
and pp_type_constr ctor =
|
and pp_fun_type Region.{value; _} =
|
||||||
string ctor.value
|
let lhs, _, rhs = value in
|
||||||
|
group (pp_type_expr lhs ^^ string " ->") ^/^ pp_type_expr rhs
|
||||||
and pp_fun_type Region.{value; _} =
|
|
||||||
let lhs, _, rhs = value in
|
and pp_type_par Region.{value; _} =
|
||||||
group (pp_type_expr lhs ^^ string " ->") ^/^ pp_type_expr rhs
|
string "(" ^^ nest 1 (pp_type_expr value.inside ^^ string ")")
|
||||||
|
|
||||||
and pp_type_par Region.{value; _} =
|
|
||||||
string "(" ^^ nest 1 (pp_type_expr value.inside ^^ string ")")
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user