From e9f5c3e1aedd09b9be981c5f850447b2bc3e0136 Mon Sep 17 00:00:00 2001
From: Sander Spies <sandermail@gmail.com>
Date: Fri, 29 May 2020 19:07:44 +0200
Subject: [PATCH] Initial work for the ReasonLIGO pretty printer.

---
 src/main/compile/helpers.ml               |   2 +-
 src/passes/1-parser/reasonligo.ml         |   2 +-
 src/passes/1-parser/reasonligo/Parser.mly |   2 +-
 src/passes/1-parser/reasonligo/Pretty.ml  | 481 ++++++++++++++++++++++
 src/passes/1-parser/reasonligo/dune       |   2 +-
 5 files changed, 485 insertions(+), 4 deletions(-)
 create mode 100644 src/passes/1-parser/reasonligo/Pretty.ml

diff --git a/src/main/compile/helpers.ml b/src/main/compile/helpers.ml
index 8e35e2887..9e2019df5 100644
--- a/src/main/compile/helpers.ml
+++ b/src/main/compile/helpers.ml
@@ -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
diff --git a/src/passes/1-parser/reasonligo.ml b/src/passes/1-parser/reasonligo.ml
index 5a7b1b2f1..ff353412a 100644
--- a/src/passes/1-parser/reasonligo.ml
+++ b/src/passes/1-parser/reasonligo.ml
@@ -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 *)
 
diff --git a/src/passes/1-parser/reasonligo/Parser.mly b/src/passes/1-parser/reasonligo/Parser.mly
index fe3503328..ef1e7b030 100644
--- a/src/passes/1-parser/reasonligo/Parser.mly
+++ b/src/passes/1-parser/reasonligo/Parser.mly
@@ -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};
diff --git a/src/passes/1-parser/reasonligo/Pretty.ml b/src/passes/1-parser/reasonligo/Pretty.ml
new file mode 100644
index 000000000..f462d7a9b
--- /dev/null
+++ b/src/passes/1-parser/reasonligo/Pretty.ml
@@ -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 ")")
diff --git a/src/passes/1-parser/reasonligo/dune b/src/passes/1-parser/reasonligo/dune
index b8f57b665..f41445b7d 100644
--- a/src/passes/1-parser/reasonligo/dune
+++ b/src/passes/1-parser/reasonligo/dune
@@ -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