Initial work for the ReasonLIGO pretty printer.

This commit is contained in:
Sander Spies 2020-05-29 19:07:44 +02:00
parent cade57a47c
commit e9f5c3e1ae
5 changed files with 485 additions and 4 deletions

View File

@ -203,7 +203,7 @@ let pretty_print_cameligo source =
let pretty_print_reasonligo source =
let%bind ast = Parser.Reasonligo.parse_file source in
let doc = Parser_cameligo.Pretty.make ast in (* TODO *)
let doc = Parser_reasonligo.Pretty.make ast in
let buffer = Buffer.create 131 in
let width =
match Terminal_size.get_columns () with

View File

@ -8,7 +8,7 @@ module Region = Simple_utils.Region
module ParErr = Parser_reasonligo.ParErr
module SyntaxError = Parser_reasonligo.SyntaxError
module SSet = Set.Make (String)
module Pretty = Parser_cameligo.Pretty
module Pretty = Parser_reasonligo.Pretty
(* Mock IOs TODO: Fill them with CLI options *)

View File

@ -901,7 +901,7 @@ update_record:
lbrace = $1;
record = $3;
kwd_with = $4;
updates = {value = {compound = Braces($1,$6);
updates = {value = {compound = Braces(Region.ghost, Region.ghost);
ne_elements;
terminator};
region = cover $4 $6};

View File

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

View File

@ -15,7 +15,7 @@
(name parser_reasonligo)
(public_name ligo.parser.reasonligo)
(modules
SyntaxError reasonligo LexToken ParErr Parser)
SyntaxError reasonligo LexToken ParErr Parser Pretty)
(libraries
menhirLib
parser_shared