Added more to the PascaLIGO pretty-printer.

Improved the AST of PascaLIGO to better capture the struture.

src/main/compile/helpers.ml

@@ -192,7 +192,7 @@ let pretty_print_pascaligo source =
 
 let pretty_print_cameligo source =
   let%bind ast = Parser.Cameligo.parse_file source in
-  let doc    = Parser_cameligo.Pretty.make ast in
+  let doc    = Parser_cameligo.Pretty.print ast in
   let buffer = Buffer.create 131 in
   let width  =
     match Terminal_size.get_columns () with
@@ -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_cameligo.Pretty.print ast in (* TODO *)
   let buffer = Buffer.create 131 in
   let width  =
     match Terminal_size.get_columns () with

src/passes/1-parser/cameligo.ml

@@ -157,7 +157,7 @@ let pretty_print source =
   match parse_file source with
     Stdlib.Error _ as e -> e
   | Ok ast ->
-      let doc    = Pretty.make (fst ast) in
+      let doc    = Pretty.print (fst ast) in
       let buffer = Buffer.create 131 in
       let width  =
         match Terminal_size.get_columns () with

src/passes/1-parser/cameligo/ParserMain.ml

@@ -78,7 +78,7 @@ let wrap = function
   Stdlib.Ok ast ->
     if IO.options#pretty then
       begin
-        let doc = Pretty.make ast in
+        let doc = Pretty.print ast in
         let width =
           match Terminal_size.get_columns () with
             None -> 60

src/passes/1-parser/cameligo/Pretty.ml

@@ -5,11 +5,13 @@ module Region = Simple_utils.Region
 open! Region
 open! PPrint
 
-(*let paragraph (s : string) = flow (break 1) (words s)*)
+let pp_par printer {value; _} =
+  string "(" ^^ nest 1 (printer value.inside ^^ string ")")
 
-let rec make ast =
+let rec print ast =
   let app decl = group (pp_declaration decl) in
-  separate_map (hardline ^^ hardline) app (Utils.nseq_to_list ast.decl)
+  let decl = Utils.nseq_to_list ast.decl in
+  separate_map (hardline ^^ hardline) app decl
 
 and pp_declaration = function
   Let decl -> pp_let_decl decl
@@ -90,8 +92,7 @@ and pp_nat {value; _} =
 and pp_bytes {value; _} =
   string ("0x" ^ Hex.show (snd value))
 
-and pp_ppar {value; _} =
+and pp_ppar p = pp_par pp_pattern p
-  string "(" ^^ nest 1 (pp_pattern value.inside ^^ string ")")
 
 and pp_plist = function
   PListComp cmp -> pp_list_comp cmp
@@ -345,8 +346,7 @@ and pp_tuple_expr {value; _} =
      then pp_expr head
      else pp_expr head ^^ string "," ^^ app (List.map snd tail)
 
-and pp_par_expr {value; _} =
+and pp_par_expr e = pp_par pp_expr e
-  string "(" ^^ nest 1 (pp_expr value.inside ^^ string ")")
 
 and pp_let_in {value; _} =
   let {binding; kwd_rec; body; attributes; _} = value in
@@ -425,8 +425,7 @@ and pp_field_decl {value; _} =
   let t_expr = pp_type_expr field_type
   in prefix 2 1 (name ^^ string " :") t_expr
 
-and pp_type_app {value; _} =
+and pp_type_app {value = ctor, tuple; _} =
-  let ctor, tuple = value in
   prefix 2 1 (pp_type_tuple tuple) (pp_type_constr ctor)
 
 and pp_type_tuple {value; _} =
@@ -449,5 +448,4 @@ and pp_fun_type {value; _} =
   let lhs, _, rhs = value in
   group (pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs)
 
-and pp_type_par {value; _} =
+and pp_type_par t = pp_par pp_type_expr t
-  string "(" ^^ nest 1 (pp_type_expr value.inside ^^ string ")")

src/passes/1-parser/pascaligo/AST.ml

@@ -109,6 +109,7 @@ type eof = Region.t
 type variable    = string reg
 type fun_name    = string reg
 type type_name   = string reg
+type type_constr = string reg
 type field_name  = string reg
 type map_name    = string reg
 type set_name    = string reg
@@ -181,7 +182,7 @@ and type_expr =
   TProd   of cartesian
 | TSum    of (variant reg, vbar) nsepseq reg
 | TRecord of field_decl reg ne_injection reg
-| TApp    of (type_name * type_tuple) reg
+| TApp    of (type_constr * type_tuple) reg
 | TFun    of (type_expr * arrow * type_expr) reg
 | TPar    of type_expr par reg
 | TVar    of variable
@@ -249,19 +250,14 @@ and param_var = {
 }
 
 and block = {
-  opening    : block_opening;
+  enclosing  : block_enclosing;
   statements : statements;
-  terminator : semi option;
+  terminator : semi option
-  closing    : block_closing
 }
 
-and block_opening =
+and block_enclosing =
-  Block of kwd_block * lbrace
+  Block    of kwd_block * lbrace * rbrace
-| Begin of kwd_begin
+| BeginEnd of kwd_begin * kwd_end
-
-and block_closing =
-  Block of rbrace
-| End   of kwd_end
 
 and statements = (statement, semi) nsepseq
 
@@ -378,10 +374,10 @@ and set_membership = {
 and 'a case = {
   kwd_case  : kwd_case;
   expr      : expr;
-  opening   : opening;
+  kwd_of    : kwd_of;
+  enclosing : enclosing;
   lead_vbar : vbar option;
-  cases     : ('a case_clause reg, vbar) nsepseq reg;
+  cases     : ('a case_clause reg, vbar) nsepseq reg
-  closing   : closing
 }
 
 and 'a case_clause = {
@@ -471,34 +467,12 @@ and expr =
 | EPar    of expr par reg
 | EFun    of fun_expr reg
 
-and annot_expr = (expr * type_expr)
+and annot_expr = expr * type_expr
 
 and set_expr =
   SetInj of expr injection reg
 | SetMem of set_membership reg
 
-and 'a injection = {
-  opening    : opening;
-  elements   : ('a, semi) sepseq;
-  terminator : semi option;
-  closing    : closing
-}
-
-and 'a ne_injection = {
-  opening     : opening;
-  ne_elements : ('a, semi) nsepseq;
-  terminator  : semi option;
-  closing     : closing
-}
-
-and opening =
-  Kwd        of keyword
-| KwdBracket of keyword * lbracket
-
-and closing =
-  End       of kwd_end
-| RBracket  of rbracket
-
 and map_expr =
   MapLookUp of map_lookup reg
 | MapInj    of binding reg injection reg
@@ -605,6 +579,38 @@ and fun_call = (expr * arguments) reg
 
 and arguments = tuple_expr
 
+(* Injections *)
+
+and 'a injection = {
+  kind       : injection_kwd;
+  enclosing  : enclosing;
+  elements   : ('a, semi) sepseq;
+  terminator : semi option
+}
+
+and injection_kwd =
+  InjSet    of keyword
+| InjMap    of keyword
+| InjBigMap of keyword
+| InjList   of keyword
+
+and enclosing =
+  Brackets of lbracket * rbracket
+| End      of kwd_end
+
+and 'a ne_injection = {
+  kind        : ne_injection_kwd;
+  enclosing   : enclosing;
+  ne_elements : ('a, semi) nsepseq;
+  terminator  : semi option
+}
+
+and ne_injection_kwd =
+  NEInjAttr   of keyword
+| NEInjSet    of keyword
+| NEInjMap    of keyword
+| NEInjRecord of keyword
+
 (* Patterns *)
 
 and pattern =
@@ -635,7 +641,7 @@ and list_pattern =
 | PCons     of (pattern, cons) nsepseq reg
 
 
-(* Projecting regions *)
+(* PROJECTING REGIONS *)
 
 let rec last to_region = function
     [] -> Region.ghost

src/passes/1-parser/pascaligo/Parser.mly

@@ -122,7 +122,8 @@ attr_decl:
   open_attr_decl ";"? { $1 }
 
 open_attr_decl:
-  ne_injection("attributes","<string>") { $1 }
+  ne_injection("attributes","<string>") {
+    $1 (fun region -> NEInjAttr region) }
 
 (* Type declarations *)
 
@@ -214,19 +215,19 @@ record_type:
     let () = Utils.nsepseq_to_list ne_elements
              |> Scoping.check_fields in
     let region = cover $1 $3
-    and value  = {opening = Kwd $1;
+    and value  = {kind      = NEInjRecord $1;
+                  enclosing = End $3;
                   ne_elements;
-                  terminator;
+                  terminator}
-                  closing = End $3}
     in TRecord {region; value}
   }
 | "record" "[" sep_or_term_list(field_decl,";") "]" {
    let ne_elements, terminator = $3 in
    let region = cover $1 $4
-   and value  = {opening = KwdBracket ($1,$2);
+   and value  = {kind      = NEInjRecord $1;
+                 enclosing = Brackets ($2,$4);
                  ne_elements;
-                 terminator;
+                 terminator}
-                 closing = RBracket $4}
    in TRecord {region; value} }
 
 field_decl:
@@ -238,7 +239,7 @@ field_decl:
 
 
 fun_expr:
-  | ioption ("recursive") "function" parameters ":" type_expr "is" expr {
+  ioption ("recursive") "function" parameters ":" type_expr "is" expr {
     let stop   = expr_to_region $7 in
     let region = cover $2 stop
     and value  = {kwd_recursive= $1;
@@ -271,7 +272,8 @@ open_fun_decl:
                   attributes   = None}
     in {region; value}
   }
-| ioption ("recursive") "function" fun_name parameters ":" type_expr "is" expr {
+| ioption ("recursive") "function" fun_name parameters ":" type_expr "is"
+  expr {
     Scoping.check_reserved_name $3;
     let stop   = expr_to_region $8 in
     let region = cover $2 stop
@@ -326,19 +328,17 @@ block:
   "begin" sep_or_term_list(statement,";") "end" {
      let statements, terminator = $2 in
      let region = cover $1 $3
-     and value  = {opening = Begin $1;
+     and value  = {enclosing = BeginEnd ($1,$3);
                    statements;
-                   terminator;
+                   terminator}
-                   closing = End $3}
      in {region; value}
   }
 | "block" "{" sep_or_term_list(statement,";") "}" {
      let statements, terminator = $3 in
      let region = cover $1 $4
-     and value  = {opening = Block ($1,$2);
+     and value  = {enclosing = Block ($1,$2,$4);
                    statements;
-                   terminator;
+                   terminator}
-                   closing = Block $4}
      in {region; value} }
 
 statement:
@@ -404,8 +404,7 @@ instruction:
 set_remove:
   "remove" expr "from" "set" path {
     let region = cover $1 (path_to_region $5) in
-    let value  = {
+    let value  = {kwd_remove = $1;
-      kwd_remove = $1;
                   element    = $2;
                   kwd_from   = $3;
                   kwd_set    = $4;
@@ -415,8 +414,7 @@ set_remove:
 map_remove:
   "remove" expr "from" "map" path {
     let region = cover $1 (path_to_region $5) in
-    let value  = {
+    let value  = {kwd_remove = $1;
-      kwd_remove = $1;
                   key        = $2;
                   kwd_from   = $3;
                   kwd_map    = $4;
@@ -425,82 +423,83 @@ map_remove:
 
 set_patch:
   "patch" path "with" ne_injection("set",expr) {
-    let region = cover $1 $4.region in
+    let set_inj = $4 (fun region -> NEInjSet region) in
-    let value  = {
+    let region = cover $1 set_inj.region in
-      kwd_patch = $1;
+    let value  = {kwd_patch = $1;
                   path      = $2;
                   kwd_with  = $3;
-      set_inj   = $4}
+                  set_inj}
     in {region; value} }
 
 map_patch:
   "patch" path "with" ne_injection("map",binding) {
-    let region = cover $1 $4.region in
+    let map_inj = $4 (fun region -> NEInjMap region) in
-    let value  = {
+    let region  = cover $1 map_inj.region in
-      kwd_patch = $1;
+    let value   = {kwd_patch = $1;
                    path      = $2;
                    kwd_with  = $3;
-      map_inj   = $4}
+                   map_inj}
     in {region; value} }
 
 injection(Kind,element):
   Kind sep_or_term_list(element,";") "end" {
+    fun mk_kwd ->
       let elements, terminator = $2 in
       let region = cover $1 $3
       and value  = {
-      opening  = Kwd $1;
+        kind      = mk_kwd $1;
+        enclosing = End $3;
         elements  = Some elements;
-      terminator;
+        terminator}
-      closing = End $3}
       in {region; value}
   }
 | Kind "end" {
+    fun mk_kwd ->
       let region = cover $1 $2
-    and value = {
+      and value  = {kind       = mk_kwd $1;
-      opening    = Kwd $1;
+                    enclosing  = End $2;
                     elements   = None;
-      terminator = None;
+                    terminator = None}
-      closing    = End $2}
       in {region; value}
   }
 | Kind "[" sep_or_term_list(element,";") "]" {
+    fun mk_kwd ->
       let elements, terminator = $3 in
       let region = cover $1 $4
-    and value = {
+      and value  = {kind      = mk_kwd $1;
-      opening  = KwdBracket ($1,$2);
+                    enclosing = Brackets ($2,$4);
                     elements  = Some elements;
-      terminator;
+                    terminator}
-      closing = RBracket $4}
       in {region; value}
   }
 | Kind "[" "]" {
+    fun mk_kwd ->
       let region = cover $1 $3
-    and value = {
+      and value  = {kind       = mk_kwd $1;
-      opening    = KwdBracket ($1,$2);
+                    enclosing  = Brackets ($2,$3);
                     elements   = None;
-      terminator = None;
+                    terminator = None}
-      closing    = RBracket $3}
       in {region; value} }
 
 ne_injection(Kind,element):
   Kind sep_or_term_list(element,";") "end" {
+    fun mk_kwd ->
       let ne_elements, terminator = $2 in
       let region = cover $1 $3
-    and value = {
+      and value  = {kind      = mk_kwd $1;
-      opening  = Kwd $1;
+                    enclosing = End $3;
                     ne_elements;
-      terminator;
+                    terminator}
-      closing = End $3}
       in {region; value}
   }
 | Kind "[" sep_or_term_list(element,";") "]" {
+    fun mk_kwd ->
       let ne_elements, terminator = $3 in
       let region = cover $1 $4
-    and value = {
+      and value = {kind      = mk_kwd $1;
-      opening  = KwdBracket ($1,$2);
+                   enclosing = Brackets ($2,$4);
                    ne_elements;
-      terminator;
+                   terminator}
-      closing = RBracket $4}
       in {region; value} }
 
 binding:
@@ -508,20 +507,19 @@ binding:
     let start  = expr_to_region $1
     and stop   = expr_to_region $3 in
     let region = cover start stop
-    and value  = {
+    and value  = {source = $1;
-      source = $1;
                   arrow  = $2;
                   image  = $3}
     in {region; value} }
 
 record_patch:
   "patch" path "with" ne_injection("record",field_assignment) {
-    let region = cover $1 $4.region in
+    let record_inj = $4 (fun region -> NEInjRecord region) in
-    let value  = {
+    let region = cover $1 record_inj.region in
-      kwd_patch  = $1;
+    let value  = {kwd_patch = $1;
                   path      = $2;
                   kwd_with  = $3;
-      record_inj = $4}
+                  record_inj}
     in {region; value} }
 
 proc_call:
@@ -547,12 +545,9 @@ if_clause:
 clause_block:
   block { LongBlock $1 }
 | "{" sep_or_term_list(statement,";") "}" {
-    let statements, terminator = $2 in
     let region = cover $1 $3 in
-    let value  = {lbrace = $1;
+    let value  = {lbrace=$1; inside=$2; rbrace=$3}
-                  inside = statements, terminator;
+    in ShortBlock {value; region} }
-                  rbrace = $3} in
-    ShortBlock {value; region} }
 
 case_instr:
   case(if_clause) { $1 if_clause_to_region }
@@ -563,10 +558,10 @@ case(rhs):
       let region = cover $1 $6 in
       let value  = {kwd_case  = $1;
                     expr      = $2;
-                    opening   = Kwd $3;
+                    kwd_of    = $3;
+                    enclosing = End $6;
                     lead_vbar = $4;
-                    cases     = $5 rhs_to_region;
+                    cases     = $5 rhs_to_region}
-                    closing   = End $6}
       in {region; value}
   }
 | "case" expr "of" "[" "|"? cases(rhs) "]" {
@@ -574,10 +569,10 @@ case(rhs):
       let region = cover $1 $7 in
       let value  = {kwd_case  = $1;
                     expr      = $2;
-                    opening   = KwdBracket ($3,$4);
+                    kwd_of    = $3;
+                    enclosing = Brackets ($4,$7);
                     lead_vbar = $5;
-                    cases     = $6 rhs_to_region;
+                    cases     = $6 rhs_to_region}
-                    closing   = RBracket $7}
       in {region; value} }
 
 cases(rhs):
@@ -904,12 +899,17 @@ annot_expr:
     in {region; value} }
 
 set_expr:
-  injection("set",expr) { SetInj $1 }
+  injection("set",expr) { SetInj ($1 (fun region -> InjSet region)) }
 
 map_expr:
-  map_lookup                   { MapLookUp $1 }
+  map_lookup {
-| injection("map",binding)     {    MapInj $1 }
+    MapLookUp $1
-| injection("big_map",binding) { BigMapInj $1 }
+  }
+| injection("map",binding) {
+    MapInj ($1 (fun region -> InjMap region))
+  }
+| injection("big_map",binding) {
+    BigMapInj ($1 (fun region -> InjBigMap region)) }
 
 map_lookup:
   path brackets(expr) {
@@ -958,26 +958,27 @@ record_expr:
     let ne_elements, terminator = $2 in
     let region = cover $1 $3
     and value : field_assign AST.reg ne_injection = {
-      opening = Kwd $1;
+      kind      = NEInjRecord $1;
+      enclosing = End $3;
       ne_elements;
-      terminator;
+      terminator}
-      closing = End $3}
     in {region; value}
   }
 | "record" "[" sep_or_term_list(field_assignment,";") "]" {
     let ne_elements, terminator = $3 in
     let region = cover $1 $4
     and value : field_assign AST.reg ne_injection = {
-     opening = KwdBracket ($1,$2);
+      kind      = NEInjRecord $1;
+      enclosing = Brackets ($2,$4);
       ne_elements;
-     terminator;
+      terminator}
-     closing = RBracket $4}
     in {region; value} }
 
 update_record:
   path "with" ne_injection("record",field_path_assignment) {
-    let region = cover (path_to_region $1) $3.region in
+    let updates = $3 (fun region -> NEInjRecord region) in
-    let value  = {record=$1; kwd_with=$2; updates=$3}
+    let region = cover (path_to_region $1) updates.region in
+    let value  = {record=$1; kwd_with=$2; updates}
     in {region; value} }
 
 field_assignment:
@@ -1010,7 +1011,7 @@ arguments:
   par(nsepseq(expr,",")) { $1 }
 
 list_expr:
-  injection("list",expr) { EListComp $1 }
+  injection("list",expr) { EListComp ($1 (fun region -> InjList region)) }
 | "nil"                  { ENil $1                                     }
 
 (* Patterns *)
@@ -1034,9 +1035,10 @@ core_pattern:
 | constr_pattern           { PConstr $1 }
 
 list_pattern:
-  injection("list",core_pattern) { PListComp $1 }
+  "nil"                          {      PNil $1 }
-| "nil"                          {      PNil $1 }
 | par(cons_pattern)              {  PParCons $1 }
+| injection("list",core_pattern) {
+    PListComp ($1 (fun region -> InjList region)) }
 
 cons_pattern:
   core_pattern "#" pattern { $1,$2,$3 }

src/passes/1-parser/pascaligo/ParserLog.ml

@@ -27,7 +27,7 @@ let mk_state ~offsets ~mode ~buffer =
     val pad_node    = ""
     method pad_node = pad_node
 
-    (** The method [pad] updates the current padding, which is
+    (* The method [pad] updates the current padding, which is
        comprised of two components: the padding to reach the new node
        (space before reaching a subtree, then a vertical bar for it)
        and the padding for the new node itself (Is it the last child
@@ -44,7 +44,7 @@ let mk_state ~offsets ~mode ~buffer =
 let compact state (region: Region.t) =
   region#compact ~offsets:state#offsets state#mode
 
-(** {1 Printing the tokens with their source regions} *)
+(* Printing the tokens with their source regions *)
 
 let print_nsepseq :
   state -> string -> (state -> 'a -> unit) ->
@@ -117,7 +117,7 @@ let rec print_tokens state ast =
   print_token state eof "EOF"
 
 and print_attr_decl state =
-  print_ne_injection state "attributes" print_string
+  print_ne_injection state print_string
 
 and print_decl state = function
   TypeDecl  decl -> print_type_decl  state decl
@@ -170,8 +170,8 @@ and print_variant state ({value; _}: variant reg) =
 and print_sum_type state {value; _} =
   print_nsepseq state "|" print_variant value
 
-and print_record_type state record_type =
+and print_record_type state =
-  print_ne_injection state "record" print_field_decl record_type
+  print_ne_injection state print_field_decl
 
 and print_type_app state {value; _} =
   let type_name, type_tuple = value in
@@ -256,22 +256,19 @@ and print_param_var state {value; _} =
   print_type_expr state param_type
 
 and print_block state block =
-  let {opening; statements; terminator; closing} = block.value in
+  let {enclosing; statements; terminator} = block.value in
-  print_block_opening state opening;
+  match enclosing with
+    Block (kwd_block, lbrace, rbrace) ->
+      print_token      state kwd_block "block";
+      print_token      state lbrace    "{";
       print_statements state statements;
       print_terminator state terminator;
-  print_block_closing state closing
+      print_token state rbrace  "}"
-
+  | BeginEnd (kwd_begin, kwd_end) ->
-and print_block_opening state = function
+      print_token      state kwd_begin "begin";
-  Block (kwd_block, lbrace) ->
+      print_statements state statements;
-    print_token state kwd_block "block";
+      print_terminator state terminator;
-    print_token state lbrace    "{"
+      print_token      state kwd_end "end"
-| Begin kwd_begin ->
-    print_token state kwd_begin "begin"
-
-and print_block_closing state = function
-  Block rbrace -> print_token state rbrace  "}"
-| End kwd_end  -> print_token state kwd_end "end"
 
 and print_data_decl state = function
   LocalConst decl -> print_const_decl state decl
@@ -344,14 +341,20 @@ and print_clause_block state = function
     print_token      state rbrace "}"
 
 and print_case_instr state (node : if_clause case) =
-  let {kwd_case; expr; opening;
+  let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
-       lead_vbar; cases; closing} = node in
   print_token       state kwd_case "case";
   print_expr        state expr;
-  print_opening     state "of" opening;
+  print_token       state kwd_of "of";
+  match enclosing with
+    Brackets (lbracket, rbracket) ->
+      print_token       state lbracket "[";
       print_token_opt   state lead_vbar "|";
       print_cases_instr state cases;
-  print_closing     state closing
+      print_token       state rbracket "]"
+  | End kwd_end ->
+      print_token_opt   state lead_vbar "|";
+      print_cases_instr state cases;
+      print_token       state kwd_end "end"
 
 and print_token_opt state = function
          None -> fun _ -> ()
@@ -466,14 +469,20 @@ and print_annot_expr state (expr , type_expr) =
   print_type_expr state type_expr
 
 and print_case_expr state (node : expr case) =
-  let {kwd_case; expr; opening;
+  let {kwd_case; expr; kwd_of; enclosing; lead_vbar; cases} = node in
-       lead_vbar; cases; closing} = node in
   print_token      state kwd_case "case";
   print_expr       state expr;
-  print_opening    state "of" opening;
+  print_token       state kwd_of "of";
+  match enclosing with
+    Brackets (lbracket, rbracket) ->
+      print_token      state lbracket "[";
       print_token_opt  state lead_vbar "|";
       print_cases_expr state cases;
-  print_closing    state closing
+      print_token      state rbracket "]"
+  | End kwd_end ->
+      print_token_opt  state lead_vbar "|";
+      print_cases_expr state cases;
+      print_token      state kwd_end "end"
 
 and print_cases_expr state {value; _} =
   print_nsepseq state "|" print_case_clause_expr value
@@ -486,11 +495,11 @@ and print_case_clause_expr state {value; _} =
 
 and print_map_expr state = function
   MapLookUp {value; _} -> print_map_lookup state value
-| MapInj inj           -> print_injection  state "map" print_binding inj
+| MapInj inj           -> print_injection  state print_binding inj
-| BigMapInj inj        -> print_injection  state "big_map" print_binding inj
+| BigMapInj inj        -> print_injection  state print_binding inj
 
 and print_set_expr state = function
-  SetInj inj -> print_injection state "set" print_expr inj
+  SetInj inj -> print_injection state print_expr inj
 | SetMem mem -> print_set_membership state mem
 
 and print_set_membership state {value; _} =
@@ -600,7 +609,7 @@ and print_list_expr state = function
     print_expr  state arg1;
     print_token state op "#";
     print_expr  state arg2
-| EListComp e -> print_injection state "list" print_expr e
+| EListComp e -> print_injection state print_expr e
 | ENil e -> print_nil state e
 
 and print_constr_expr state = function
@@ -608,8 +617,8 @@ and print_constr_expr state = function
 | NoneExpr e  -> print_none_expr  state e
 | ConstrApp e -> print_constr_app state e
 
-and print_record_expr state e =
+and print_record_expr state =
-  print_ne_injection state "record" print_field_assign e
+  print_ne_injection state print_field_assign
 
 and print_field_assign state {value; _} =
   let {field_name; equal; field_expr} = value in
@@ -627,8 +636,7 @@ and print_update_expr state {value; _} =
   let {record; kwd_with; updates} = value in
   print_path state record;
   print_token state kwd_with "with";
-  print_ne_injection state "updates field" print_field_path_assign updates
+  print_ne_injection state print_field_path_assign updates
-
 
 and print_projection state {value; _} =
   let {struct_name; selector; field_path} = value in
@@ -648,21 +656,21 @@ and print_record_patch state node =
   print_token        state kwd_patch "patch";
   print_path         state path;
   print_token        state kwd_with "with";
-  print_ne_injection state "record" print_field_assign record_inj
+  print_ne_injection state print_field_assign record_inj
 
 and print_set_patch state node =
   let {kwd_patch; path; kwd_with; set_inj} = node in
   print_token        state kwd_patch "patch";
   print_path         state path;
   print_token        state kwd_with "with";
-  print_ne_injection state "set" print_expr set_inj
+  print_ne_injection state print_expr set_inj
 
 and print_map_patch state node =
   let {kwd_patch; path; kwd_with; map_inj} = node in
   print_token        state kwd_patch "patch";
   print_path         state path;
   print_token        state kwd_with "with";
-  print_ne_injection state "map" print_binding map_inj
+  print_ne_injection state print_binding map_inj
 
 and print_map_remove state node =
   let {kwd_remove; key; kwd_from; kwd_map; map} = node in
@@ -681,35 +689,48 @@ and print_set_remove state node =
   print_path  state set
 
 and print_injection :
-  'a.state -> string -> (state -> 'a -> unit) ->
+  'a.state -> (state -> 'a -> unit) -> 'a injection reg -> unit =
-  'a injection reg -> unit =
+  fun state print {value; _} ->
-  fun state kwd print {value; _} ->
+    let {kind; enclosing; elements; terminator} = value in
-    let {opening; elements; terminator; closing} = value in
+    print_injection_kwd state kind;
-    print_opening    state kwd opening;
+    match enclosing with
+      Brackets (lbracket, rbracket) ->
+        print_token      state lbracket "[";
         print_sepseq     state ";" print elements;
         print_terminator state terminator;
-    print_closing    state closing
+        print_token      state rbracket "]"
+    | End kwd_end ->
+        print_sepseq     state ";" print elements;
+        print_terminator state terminator;
+        print_token      state kwd_end "end"
+
+and print_injection_kwd state = function
+  InjSet    kwd_set     -> print_token state kwd_set "set"
+| InjMap    kwd_map     -> print_token state kwd_map "map"
+| InjBigMap kwd_big_map -> print_token state kwd_big_map "big_map"
+| InjList   kwd_list    -> print_token state kwd_list "list"
 
 and print_ne_injection :
-  'a.state -> string -> (state -> 'a -> unit) ->
+  'a.state -> (state -> 'a -> unit) -> 'a ne_injection reg -> unit =
-  'a ne_injection reg -> unit =
+  fun state print {value; _} ->
-  fun state kwd print {value; _} ->
+    let {kind; enclosing; ne_elements; terminator} = value in
-    let {opening; ne_elements; terminator; closing} = value in
+    print_ne_injection_kwd state kind;
-    print_opening    state kwd opening;
+    match enclosing with
+      Brackets (lbracket, rbracket) ->
+        print_token      state lbracket "[";
         print_nsepseq     state ";" print ne_elements;
         print_terminator state terminator;
-    print_closing    state closing
+        print_token      state rbracket "]"
+    | End kwd_end ->
+        print_nsepseq     state ";" print ne_elements;
+        print_terminator state terminator;
+        print_token      state kwd_end "end"
 
-and print_opening state lexeme = function
+and print_ne_injection_kwd state = function
-  Kwd kwd ->
+  NEInjAttr   kwd_attributes -> print_token state kwd_attributes "attributes"
-    print_token state kwd lexeme
+| NEInjSet    kwd_set        -> print_token state kwd_set "set"
-| KwdBracket (kwd, lbracket) ->
+| NEInjMap    kwd_map        -> print_token state kwd_map "map"
-    print_token state kwd lexeme;
+| NEInjRecord kwd_record     -> print_token state kwd_record "record"
-    print_token state lbracket "["
-
-and print_closing state = function
-  RBracket rbracket -> print_token state rbracket "]"
-| End kwd_end       -> print_token state kwd_end "end"
 
 and print_binding state {value; _} =
   let {source; arrow; image} = value in
@@ -787,7 +808,7 @@ and print_patterns state {value; _} =
 
 and print_list_pattern state = function
   PListComp comp ->
-   print_injection state "list" print_pattern comp
+   print_injection state print_pattern comp
 | PNil kwd_nil ->
     print_token state kwd_nil "nil"
 | PParCons cons ->
@@ -831,7 +852,7 @@ let pattern_to_string ~offsets ~mode =
 let instruction_to_string ~offsets ~mode =
   to_string ~offsets ~mode print_instruction
 
-(** {1 Pretty-printing the AST} *)
+(* Pretty-printing the AST *)
 
 let pp_ident state {value=name; region} =
   let reg  = compact state region in

src/passes/1-parser/pascaligo/ParserMain.ml

@@ -75,9 +75,23 @@ module Unit =
 (* Main *)
 
 let wrap = function
-  Stdlib.Ok _ -> flush_all ()
+  Stdlib.Ok ast ->
+    if IO.options#pretty then
+      begin
+        let doc = Pretty.print ast in
+        let width =
+          match Terminal_size.get_columns () with
+            None -> 60
+          | Some c -> c in
+        PPrint.ToChannel.pretty 1.0 width stdout doc;
+        print_newline ()
+      end;
+    flush_all ()
 | Error msg ->
-    (flush_all (); Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value)
+    begin
+      flush_all ();
+      Printf.eprintf "\027[31m%s\027[0m%!" msg.Region.value
+    end
 
 let () =
   match IO.options#input with

src/passes/1-parser/pascaligo/Pretty.ml

@@ -0,0 +1,425 @@
+[@@@warning "-42"]
+
+open AST
+module Region = Simple_utils.Region
+open! Region
+open! PPrint
+
+let pp_par (printer: 'a -> document) ({value; _} : 'a par reg) =
+  string "(" ^^ nest 1 (printer value.inside ^^ string ")")
+
+let rec print ast =
+  let app decl = group (pp_declaration decl) in
+  let decl = Utils.nseq_to_list ast.decl in
+  separate_map (hardline ^^ hardline) app decl
+
+and pp_declaration = function
+  TypeDecl  d -> pp_type_decl  d
+| ConstDecl d -> pp_const_decl d
+| FunDecl   d -> pp_fun_decl   d
+| AttrDecl  d -> pp_attr_decl  d
+
+and pp_attr_decl decl = pp_ne_injection pp_string decl
+
+and pp_const_decl {value; _} = string "TODO:pp_const_decl"
+
+(* Type declarations *)
+
+and pp_type_decl decl =
+  let {name; type_expr; _} = decl.value in
+  string "type " ^^ string name.value ^^ string " is"
+  ^^ group (nest 2 (break 1 ^^ pp_type_expr type_expr))
+
+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 pp_type_expr head ^^ string " *" ^^ app (List.map snd tail)
+
+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 4 1 (pp_ident constr ^^ string " of") (pp_type_expr e)
+
+and pp_fields fields = 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
+  let t_expr = pp_type_expr field_type
+  in prefix 2 1 (name ^^ string " :") t_expr
+
+and pp_fun_type {value; _} =
+  let lhs, _, rhs = value in
+  group (pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs)
+
+and pp_type_par t = pp_par pp_type_expr t
+
+and pp_type_app {value = ctor, tuple; _} =
+  prefix 2 1 (pp_type_constr ctor) (pp_type_tuple tuple)
+
+and pp_type_constr ctor = string ctor.value
+
+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 string "(" ^^ nest 1 (components ^^ string ")")
+
+(* Function and procedure declarations *)
+
+and pp_fun_expr {value; _} = string "TODO:pp_fun_expr"
+
+and pp_fun_decl {value; _} =
+  let {kwd_recursive; fun_name; param;
+       ret_type; block_with; return; attributes} = value in
+  let start =
+    match kwd_recursive with
+      None   -> string "function"
+    | Some _ -> string "recursive" ^/^ string "function" in
+  let parameters = pp_par pp_parameters param in
+  let return_t = pp_type_expr ret_type in
+
+  string "TODO:pp_fun_decl"
+
+and pp_parameters p = pp_nsepseq ";" pp_param_decl p
+
+and pp_param_decl = function
+  ParamConst c -> pp_param_const c
+| ParamVar   v -> pp_param_var v
+
+and pp_param_const {value; _} = string "PP:pp_param_const"
+
+and pp_param_var {value; _} = string "TODO:pp_param_var"
+
+and pp_block {value; _} = string "TODO:pp_block"
+
+and pp_statements s = pp_nsepseq ";" pp_statement s
+
+and pp_statement = function
+  Instr s -> pp_instruction s
+| Data  s -> pp_data_decl   s
+| Attr  s -> pp_attr_decl   s
+
+and pp_data_decl = function
+  LocalConst d -> pp_const_decl d
+| LocalVar   d -> pp_var_decl   d
+| LocalFun   d -> pp_fun_decl   d
+
+and pp_var_decl decl = string "TODO:pp_var_decl"
+
+and pp_instruction = function
+  Cond        i -> pp_conditional i
+| CaseInstr   i -> pp_case pp_if_clause i
+| Assign      i -> pp_assignment i
+| Loop        i -> pp_loop i
+| ProcCall    i -> pp_fun_call i
+| Skip        _ -> string "skip"
+| RecordPatch i -> pp_record_patch i
+| MapPatch    i -> pp_map_patch i
+| SetPatch    i -> pp_set_patch i
+| MapRemove   i -> pp_map_remove i
+| SetRemove   i -> pp_set_remove i
+
+and pp_set_remove {value; _} = string "TODO:pp_set_remove"
+
+and pp_map_remove {value; _} = string "TODO:pp_map_remove"
+
+and pp_set_patch {value; _} = string "TODO:pp_set_patch"
+
+and pp_map_patch {value; _} = string "TODO:pp_map_patch"
+
+and pp_binding b = string "TODO:pp_binding"
+
+and pp_record_patch {value; _} = string "TODO:pp_record_patch"
+
+and pp_cond_expr {value; _} = string "TODO:pp_cond_expr"
+
+and pp_conditional {value; _} = string "TODO:pp_conditional"
+
+and pp_if_clause = function
+  ClauseInstr i -> pp_instruction i
+| ClauseBlock b -> pp_clause_block b
+
+and pp_clause_block = function
+  LongBlock b -> pp_block b
+| ShortBlock b -> pp_short_block b
+
+and pp_short_block {value; _} = string "TODO:pp_short_block"
+
+and pp_set_membership {value; _} = string "TODO:pp_set_membership"
+
+and pp_case :
+  'a.('a -> document) -> 'a case Region.reg -> document =
+  fun printer case -> string "TODO:pp_case"
+
+and pp_case_clause :
+  'a.('a -> document) -> 'a case_clause Region.reg -> document =
+  fun printer clause -> string "TODO:pp_case_clause"
+
+and pp_assignment {value; _} = string "TODO:pp_assignment"
+
+and pp_lhs : lhs -> document = function
+  Path p -> pp_path p
+| MapPath p -> pp_map_lookup p
+
+and pp_loop = function
+  While l -> pp_while_loop l
+| For f -> pp_for_loop f
+
+and pp_while_loop {value; _} = string "TODO:pp_while_loop"
+
+and pp_for_loop = function
+  ForInt l -> pp_for_int l
+| ForCollect l -> pp_for_collect l
+
+and pp_for_int {value; _} = string "TODO:pp_for_int"
+
+and pp_var_assign {value; _} = string "TODO:pp_var_assign"
+
+and pp_for_collect {value; _} = string "TODO:pp_for_collect"
+
+and pp_collection = function
+  Map  _ -> string "map"
+| Set  _ -> string "set"
+| List _ -> string "list"
+
+(* Expressions *)
+
+and pp_expr = function
+  ECase   e -> pp_case pp_expr e
+| ECond   e -> pp_cond_expr e
+| EAnnot  e -> pp_annot_expr e
+| ELogic  e -> pp_logic_expr e
+| EArith  e -> pp_arith_expr e
+| EString e -> pp_string_expr e
+| EList   e -> pp_list_expr e
+| ESet    e -> pp_set_expr e
+| EConstr e -> pp_constr_expr e
+| ERecord e -> pp_record e
+| EProj   e -> pp_projection e
+| EUpdate e -> pp_update e
+| EMap    e -> pp_map_expr e
+| EVar    e -> pp_ident e
+| ECall   e -> pp_fun_call e
+| EBytes  e -> pp_bytes e
+| EUnit   _ -> string "Unit"
+| ETuple  e -> pp_tuple_expr e
+| EPar    e -> pp_par pp_expr e
+| EFun    e -> pp_fun_expr e
+
+and pp_annot_expr {value; _} = string "TODO:pp_annot_expr"
+
+and pp_set_expr = function
+  SetInj inj -> string "TODO:pp_set_expr:SetInj"
+| SetMem mem -> string "TODO:pp_set_expr:SetMem"
+
+and pp_map_expr = function
+  MapLookUp fetch -> pp_map_lookup fetch
+| MapInj inj -> pp_injection pp_binding inj
+| BigMapInj inj -> pp_injection pp_binding inj
+
+and pp_map_lookup {value; _} = string "TODO:pp_map_lookup"
+
+and pp_path = function
+  Name v -> pp_ident v
+| Path p -> pp_projection p
+
+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 "not" 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_ident {value; _} = string value
+
+and pp_string s = string "\"" ^^ pp_ident s ^^ string "\""
+
+and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}"
+
+and pp_list_expr = function
+      ECons e -> pp_bin_op "#" e
+| EListComp e -> group (pp_injection pp_expr e)
+|      ENil _ -> string "nil"
+
+and pp_constr_expr = function
+  SomeApp a   -> pp_some_app a
+| NoneExpr _  -> string "None"
+| ConstrApp a -> pp_constr_app a
+
+and pp_some_app {value; _} = string "TODO:pp_some_app"
+
+and pp_constr_app {value; _} = string "TODO:pp_constr_app"
+
+and pp_field_assign {value; _} = string "TODO:pp_field_assign"
+
+and pp_record ne_inj = group (pp_ne_injection pp_field_assign ne_inj)
+
+and pp_projection {value; _} = string "TODO:pp_projection"
+
+and pp_update {value; _} = string "TODO:pp_update"
+
+and pp_field_path_assign {value; _} = string "TODO:pp_field_path_assign"
+
+and pp_selection = function
+  FieldName _   -> string "TODO:pp_selection:FieldName"
+| Component cmp -> cmp.value |> snd |> Z.to_string |> string
+
+and pp_tuple_expr {value; _} = string "TODO:pp_tuple_expr"
+
+and pp_fun_call {value; _} = string "TODO:pp_fun_call"
+
+and pp_arguments v = pp_tuple_expr v
+
+(* Injections *)
+
+and pp_injection :
+  'a.('a -> document) -> 'a injection reg -> document =
+  fun printer {value; _} -> string "TODO:pp_injection"
+
+and pp_ne_injection :
+  'a.('a -> document) -> 'a ne_injection reg -> document =
+  fun printer {value; _} ->
+    let {kind; enclosing; ne_elements; _} = value in
+    let elements = pp_nsepseq ";" printer ne_elements in
+    let kwd      = pp_ne_injection_kwd kind in
+    let offset   = String.length kwd + 2 in
+    string (kwd ^ " [")
+    ^^ group (nest 2 (break 0 ^^ elements ^^ string "]"))
+
+and pp_ne_injection_kwd = function
+  NEInjAttr   _ -> "attributes"
+| NEInjSet    _ -> "set"
+| NEInjMap    _ -> "map"
+| NEInjRecord _ -> "record"
+
+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
+
+(* Patterns *)
+
+and pp_pattern = function
+  PConstr p -> pp_constr_pattern p
+| PVar    v -> pp_ident v
+| PWild   _ -> string "_"
+| PInt    i -> pp_int i
+| PNat    n -> pp_nat n
+| PBytes  b -> pp_bytes b
+| PString s -> pp_string s
+| PList   l -> pp_list_pattern l
+| PTuple  t -> pp_tuple_pattern t
+
+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_constr_pattern = function
+  PUnit      _ -> string "Unit"
+| PFalse     _ -> string "False"
+| PTrue      _ -> string "True"
+| PNone      _ -> string "None"
+| PSomeApp   a -> pp_psome a
+| PConstrApp a -> pp_pconstr_app a
+
+and pp_psome {value=_, p; _} =
+  prefix 4 1 (string "Some") (pp_par pp_pattern p)
+
+and pp_pconstr_app {value; _} = string "TODO:pp_pconstr_app"
+
+and pp_tuple_pattern {value; _} = string "TODO:tuple_pattern"
+
+and pp_list_pattern = function
+  PListComp cmp -> pp_list_comp cmp
+| PNil _        -> string "nil"
+| PParCons p    -> pp_ppar_cons p
+| PCons p       -> pp_nsepseq "#" pp_pattern p.value
+
+and pp_list_comp {value; _} = string "TODO:pp_list_comp"
+
+and pp_ppar_cons {value; _} = string "TODO:pp_ppar_cons"
+
+and pp_cons {value; _} = string "TODO:pp_cons"

src/passes/1-parser/pascaligo/dune

@@ -15,7 +15,7 @@
   (name parser_pascaligo)
   (public_name ligo.parser.pascaligo)
   (modules
-     Scoping AST pascaligo Parser ParserLog LexToken ParErr)
+     Scoping AST pascaligo Parser ParserLog LexToken ParErr Pretty)
   (libraries
      menhirLib
      parser_shared

src/passes/1-parser/reasonligo.ml

@@ -189,7 +189,7 @@ let pretty_print source =
   match parse_file source with
     Stdlib.Error _ as e -> e
   | Ok ast ->
-      let doc    = Pretty.make (fst ast) in
+      let doc    = Pretty.print (fst ast) in
       let buffer = Buffer.create 131 in
       let width  =
         match Terminal_size.get_columns () with