Fixed last commit (renaming of TStringLiteral, adding --pretty)

src/passes/1-parser/cameligo.ml

@@ -19,7 +19,8 @@ module SubIO =
       ext     : string;   (* ".mligo" *)
       mode    : [`Byte | `Point];
       cmd     : EvalOpt.command;
-      mono    : bool
+      mono    : bool;
+      pretty  : bool
     >
 
     let options : options =
@@ -34,6 +35,7 @@ module SubIO =
            method mode    = `Point
            method cmd     = EvalOpt.Quiet
            method mono    = false
+           method pretty  = false
          end
 
     let make =
@@ -46,6 +48,7 @@ module SubIO =
                    ~mode:options#mode
                    ~cmd:options#cmd
                    ~mono:options#mono
+                   ~pretty:options#mono
   end
 
 module Parser =

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

@@ -0,0 +1,187 @@
+[@@@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 app (Utils.nseq_to_list ast.decl)
+
+and pp_declaration = function
+  Let decl -> pp_let_decl decl
+| TypeDecl decl -> pp_type_decl decl
+
+and pp_let_decl Region.{value; _} =
+  let _, rec_opt, binding, attr = value in
+  let rec_str =
+    match rec_opt with
+      None -> ""
+    | Some _ -> " rec" in
+  string "let" ^^ string rec_str
+  ^/^ pp_let_binding binding ^/^ pp_attributes attr
+
+and pp_attributes attr =
+  let sep   = string ";" ^^ break 1 in
+  let make s = string "[@@" ^^ string s.value ^^ string "]"
+  in separate_map sep make attr
+
+and pp_string Region.{value; _} = string value
+
+and pp_let_binding (binding : let_binding) =
+  let {binders; lhs_type; let_rhs; _} = binding in
+  let patterns = Utils.nseq_to_list binders in
+  let patterns = flow (break 1) (List.map pp_pattern patterns) in
+  let lhs_type =
+    match lhs_type with
+      None -> string ""
+    | Some (_, t_expr) -> string " :" ^/^ pp_type_expr t_expr in
+  let let_rhs = pp_expr let_rhs in
+  patterns ^^ lhs_type ^^ string " =" ^/^ let_rhs
+
+and pp_pattern = function
+  PConstr p -> pp_pconstr p
+| PUnit   _ -> string "()"
+| PFalse  _ -> string "false"
+| PTrue   _ -> string "true"
+| PVar    v -> pp_string v
+| PInt    i -> pp_int i
+| PNat    n -> pp_nat n
+| PBytes  b -> pp_bytes b
+| PString s -> pp_string 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_some p
+| PConstrApp a -> pp_c_app a
+
+and pp_c_app Region.{value; _} =
+  match value with
+    constr, None -> pp_string constr
+  | constr, Some pat -> pp_string constr ^/^ pp_pattern pat
+
+and pp_some Region.{value; _} =
+  string "Some" ^/^ pp_pattern (snd value)
+
+and pp_int Region.{value; _} = string (fst value)
+and pp_nat Region.{value; _} = string (fst value)
+and pp_bytes Region.{value; _} = string (fst value)
+
+and pp_ppar Region.{value; _} =
+  let {lpar; inside; rpar} = value in
+  string "(" ^^ pp_pattern inside ^^ string ")"
+
+and pp_plist = function
+  PListComp cmp -> pp_list_comp cmp
+| PCons cons -> pp_cons cons
+
+and pp_list_comp Region.{value; _} =
+  let items = Utils.sepseq_to_list value.elements in
+  let sep = string ";" ^^ break 1 in
+  let items = separate_map sep pp_pattern items
+  in string "[" ^^ items ^^ string "]"
+
+and pp_cons Region.{value; _} =
+  let patt1, _, patt2 = value in
+  pp_pattern patt1 ^^ string " ::" ^/^ pp_pattern patt2
+
+and pp_ptuple Region.{value; _} =
+  let cmp = Utils.nsepseq_to_list value in
+  let sep = string "," ^^ break 1 in
+  separate_map sep pp_pattern cmp
+
+and pp_precord Region.{value; _} =
+  let fields = value.ne_elements in
+  let fields = Utils.nsepseq_to_list fields in
+  let sep    = string ";" ^^ break 1 in
+  let fields = separate_map sep pp_field_pattern fields
+  in string "{" ^^ fields ^^ string "}"
+
+and pp_field_pattern Region.{value; _} =
+  let {field_name; pattern; _} = value in
+  pp_string field_name ^^ string " =" ^/^ pp_pattern pattern
+
+and pp_ptyped Region.{value; _} =
+  let {pattern; type_expr; _} = value in
+  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 "=" ^/^ pp_type_expr type_expr
+
+and pp_expr expr =
+  string "TODO:pp_expr"
+
+and pp_type_expr = function
+  TProd cartesian -> pp_cartesian cartesian
+| TSum sum        -> pp_variants sum
+| TRecord fields  -> pp_fields fields
+| TApp t_app      -> pp_type_app t_app
+| TFun fun_type   -> pp_fun_type fun_type
+| TPar par        -> pp_type_par par
+| TVar var        -> pp_string var
+| TString s       -> pp_string s
+
+and pp_cartesian Region.{value; _} =
+  let cmp = Utils.nsepseq_to_list value in
+  let sep = string " *" ^^ break 1 in
+  separate_map sep pp_type_expr cmp
+
+and pp_variants Region.{value; _} =
+  let variants = Utils.nsepseq_to_list value
+  and sep      = string " |" ^^ break 1 in
+  separate_map sep pp_variant variants
+
+and pp_variant Region.{value; _} =
+  let {constr; arg} = value in
+  match arg with
+    None -> pp_string constr
+  | Some (_, t_expr) ->
+     pp_string constr ^^ string " of" ^/^ pp_type_expr t_expr
+
+and pp_fields Region.{value; _} =
+  let fields = value.ne_elements in
+  let fields = Utils.nsepseq_to_list fields in
+  let sep    = string ";" ^^ break 1 in
+  let fields = separate_map sep pp_field_decl fields
+  in string "{" ^^ fields ^^ string "}"
+
+and pp_field_decl Region.{value; _} =
+  let {field_name; field_type; _} = value in
+  let name = pp_string field_name in
+  let t_expr = pp_type_expr field_type
+  in name ^^ string " :" ^/^ t_expr
+
+and pp_type_app Region.{value; _} =
+  let ctor, tuple = value
+  in pp_type_tuple tuple ^/^ pp_type_constr ctor
+
+and pp_type_tuple Region.{value; _} =
+  let {lpar; inside; rpar} = value in
+  match inside with
+    t_expr, [] -> pp_type_expr t_expr
+  |        seq -> let sep = string "," ^^ break 1 in
+                 let lst = Utils.nsepseq_to_list seq in
+                 let cmp = separate_map sep pp_type_expr lst
+                 in string "(" ^^ cmp ^^ string ")"
+
+and pp_type_constr ctor =
+  string ctor.value
+
+and pp_fun_type Region.{value; _} =
+  let lhs, _, rhs = value in
+  pp_type_expr lhs ^^ string " ->" ^/^ pp_type_expr rhs
+
+and pp_type_par Region.{value; _} =
+  let {lpar; inside; rpar} = value in
+  string "(" ^^ pp_type_expr inside ^^ string ")"

src/passes/1-parser/pascaligo.ml

@@ -19,7 +19,8 @@ module SubIO =
       ext     : string;   (* ".ligo" *)
       mode    : [`Byte | `Point];
       cmd     : EvalOpt.command;
-      mono    : bool
+      mono    : bool;
+      pretty  : bool
     >
 
     let options : options =
@@ -34,6 +35,7 @@ module SubIO =
            method mode    = `Point
            method cmd     = EvalOpt.Quiet
            method mono    = false
+           method pretty  = false
          end
 
     let make =
@@ -46,6 +48,7 @@ module SubIO =
                    ~mode:options#mode
                    ~cmd:options#cmd
                    ~mono:options#mono
+                   ~pretty:options#pretty
   end
 
 module Parser =

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

@@ -185,7 +185,7 @@ and type_expr =
 | TFun    of (type_expr * arrow * type_expr) reg
 | TPar    of type_expr par reg
 | TVar    of variable
-| TStringLiteral of Lexer.lexeme reg
+| TString of Lexer.lexeme reg
 
 and cartesian = (type_expr, times) nsepseq reg
 
@@ -659,7 +659,7 @@ let type_expr_to_region = function
 | TApp    {region; _}
 | TFun    {region; _}
 | TPar    {region; _}
-| TStringLiteral {region; _}
+| TString {region; _}
 | TVar    {region; _} -> region
 
 let rec expr_to_region = function

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

@@ -160,9 +160,9 @@ cartesian:
     in TProd {region; value} }
 
 core_type:
-  type_name      { TVar $1 }
+  type_name      { TVar    $1 }
-| "<string>"     { TStringLiteral $1 }
+| "<string>"     { TString $1 }
-| par(type_expr) { TPar $1 }
+| par(type_expr) { TPar    $1 }
 | type_name type_tuple {
     let region = cover $1.region $2.region
     in TApp {region; value = $1,$2}

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

@@ -153,7 +153,7 @@ and print_type_expr state = function
 | TFun    type_fun    -> print_type_fun    state type_fun
 | TPar    par_type    -> print_par_type    state par_type
 | TVar    type_var    -> print_var         state type_var
-| TStringLiteral s -> print_string state s
+| TString str         -> print_string      state str
 
 and print_cartesian state {value; _} =
   print_nsepseq state "*" print_type_expr value
@@ -398,9 +398,9 @@ and print_for_int state ({value; _} : for_int reg) =
   print_var_assign state assign;
   print_token      state kwd_to "to";
   print_expr       state bound;
-  match kwd_step with 
+  match kwd_step with
   | None -> ();
-  | Some kwd_step -> 
+  | Some kwd_step ->
   print_token      state kwd_step "step";
   match step with
   | None -> ();
@@ -941,8 +941,8 @@ and pp_type_expr state = function
                     field_decl.value in
     let fields = Utils.nsepseq_to_list value.ne_elements in
     List.iteri (List.length fields |> apply) fields
-| TStringLiteral s ->
+| TString s ->
-  pp_node   state "String";
+  pp_node   state "TString";
   pp_string (state#pad 1 0) s
 
 and pp_cartesian state {value; _} =

src/passes/1-parser/reasonligo.ml

@@ -22,7 +22,8 @@ module SubIO =
       ext     : string;   (* ".religo" *)
       mode    : [`Byte | `Point];
       cmd     : EvalOpt.command;
-      mono    : bool
+      mono    : bool;
+      pretty  : bool
     >
 
     let options : options =
@@ -37,6 +38,7 @@ module SubIO =
            method mode    = `Point
            method cmd     = EvalOpt.Quiet
            method mono    = false
+           method pretty  = false
          end
 
     let make =
@@ -49,6 +51,7 @@ module SubIO =
                    ~mode:options#mode
                    ~cmd:options#cmd
                    ~mono:options#mono
+                   ~pretty:options#pretty
   end
 
 module Parser =

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

@@ -205,9 +205,9 @@ type_args:
 | fun_type        { $1, [] }
 
 core_type:
-  type_name      { TVar $1 }
+  type_name      { TVar    $1 }
-| "<string>"     { TStringLiteral $1 }
+| "<string>"     { TString $1 }
-| par(fun_type)  { TPar $1 }
+| par(fun_type)  { TPar    $1 }
 | module_name "." type_name {
     let module_name = $1.value in
     let type_name   = $3.value in
@@ -938,10 +938,10 @@ sequence_or_record_in:
     field_name = $1;
     assignment = ghost;
     field_expr = EVar $1 }
-  in 
+  in
   let field_name = {$1 with value} in
   let (comma, elts) = $2 in
-  let r_elts = Utils.nsepseq_cons field_name comma elts in 
+  let r_elts = Utils.nsepseq_cons field_name comma elts in
   PaRecord {r_elts; r_terminator = None}
 }
 

src/passes/2-concrete_to_imperative/cameligo.ml

@@ -169,7 +169,7 @@ open Operators.Concrete_to_imperative.Cameligo
 let r_split = Location.r_split
 
 let get_t_string_singleton_opt = function
-  | Raw.TStringLiteral s -> Some (String.(sub s.value 1 ((length s.value)-2)))
+  | Raw.TString s -> Some (String.(sub s.value 1 (length s.value - 2)))
   | _ -> None
 
 let rec pattern_to_var : Raw.pattern -> _ = fun p ->
@@ -249,7 +249,7 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
       let (x,loc) = r_split x in
       let (name, tuple) = x in
       ( match name.value with
-        | "michelson_or" -> 
+        | "michelson_or" ->
           let lst = npseq_to_list tuple.value.inside in
           (match lst with
           | [a ; b ; c ; d ] -> (
@@ -318,7 +318,7 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te -
         @@ npseq_to_list s in
       let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
       ok @@ make_t ~loc @@ T_sum m
-  | TStringLiteral _s -> simple_fail "we don't support singleton string type"
+  | TString _s -> simple_fail "we don't support singleton string type"
 
 and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
   match lst with

src/passes/2-concrete_to_imperative/pascaligo.ml

@@ -152,7 +152,7 @@ let return_statement expr = ok @@ fun expr'_opt ->
   | Some expr' -> ok @@ e_sequence expr expr'
 
 let get_t_string_singleton_opt = function
-  | Raw.TStringLiteral s -> Some (String.(sub s.value 1 ((length s.value)-2)))
+  | Raw.TString s -> Some (String.(sub s.value 1 (length s.value -2)))
   | _ -> None
 
 
@@ -176,7 +176,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
       let (x, loc) = r_split x in
       let (name, tuple) = x in
       (match name.value with
-        | "michelson_or" -> 
+        | "michelson_or" ->
           let lst = npseq_to_list tuple.value.inside in
           (match lst with
           | [a ; b ; c ; d ] -> (
@@ -248,7 +248,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result =
         @@ npseq_to_list s in
       let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in
       ok @@ make_t ~loc @@ T_sum m
-  | TStringLiteral _s -> simple_fail "we don't support singleton string type"
+  | TString _s -> simple_fail "we don't support singleton string type"
 
 and compile_list_type_expression (lst:Raw.type_expr list) : type_expression result =
   match lst with
@@ -461,7 +461,7 @@ and compile_update = fun (u:Raw.update Region.reg) ->
   let (name, path) = compile_path u.record in
   let record = match path with
   | [] -> e_variable (Var.of_name name)
-  | _ -> e_accessor_list (e_variable (Var.of_name name)) path in 
+  | _ -> e_accessor_list (e_variable (Var.of_name name)) path in
   let updates = u.updates.value.ne_elements in
   let%bind updates' =
     let aux (f:Raw.field_path_assign Raw.reg) =
@@ -471,13 +471,13 @@ and compile_update = fun (u:Raw.update Region.reg) ->
     in
     bind_map_list aux @@ npseq_to_list updates
   in
-  let aux ur (path, expr) = 
+  let aux ur (path, expr) =
     let rec aux record = function
       | [] -> failwith "error in parsing"
       | hd :: [] -> ok @@ e_record_update ~loc record hd expr
-      | hd :: tl -> 
+      | hd :: tl ->
         let%bind expr = (aux (e_record_accessor ~loc record hd) tl) in
-        ok @@ e_record_update ~loc record hd expr 
+        ok @@ e_record_update ~loc record hd expr
     in
     aux ur path in
   bind_fold_list aux record updates'
@@ -645,11 +645,11 @@ and compile_fun_decl :
       let binder = Var.of_name binder in
       let fun_name = Var.of_name fun_name.value in
       let fun_type = t_function input_type output_type in
-      let expression : expression = 
+      let expression : expression =
         e_lambda ~loc binder (Some input_type)(Some output_type) result in
       let%bind expression = match kwd_recursive with
         None -> ok @@ expression |
-        Some _ -> ok @@ e_recursive ~loc fun_name fun_type 
+        Some _ -> ok @@ e_recursive ~loc fun_name fun_type
         @@ {binder;input_type=Some input_type; output_type= Some output_type; result}
       in
        ok ((fun_name, Some fun_type), expression)
@@ -680,11 +680,11 @@ and compile_fun_decl :
          bind_fold_right_list aux result body in
       let fun_name = Var.of_name fun_name.value in
       let fun_type = t_function input_type output_type in
-      let expression : expression = 
+      let expression : expression =
         e_lambda ~loc binder (Some input_type)(Some output_type) result in
       let%bind expression = match kwd_recursive with
         None -> ok @@ expression |
-        Some _ -> ok @@ e_recursive ~loc fun_name fun_type 
+        Some _ -> ok @@ e_recursive ~loc fun_name fun_type
         @@ {binder;input_type=Some input_type; output_type= Some output_type; result}
       in
        ok ((fun_name, Some fun_type), expression)
@@ -713,7 +713,7 @@ and compile_fun_expression :
         let fun_type = t_function input_type output_type in
         let expression = match kwd_recursive with
           | None -> e_lambda ~loc binder (Some input_type)(Some output_type) result
-          | Some _ -> e_recursive ~loc binder fun_type 
+          | Some _ -> e_recursive ~loc binder fun_type
           @@ {binder;input_type=Some input_type; output_type= Some output_type; result}
         in
         ok (Some fun_type , expression)
@@ -744,7 +744,7 @@ and compile_fun_expression :
       let fun_type = t_function input_type output_type in
       let expression = match kwd_recursive with
         | None -> e_lambda ~loc binder (Some input_type)(Some output_type) result
-        | Some _ -> e_recursive ~loc binder fun_type 
+        | Some _ -> e_recursive ~loc binder fun_type
         @@ {binder;input_type=Some input_type; output_type= Some output_type; result}
       in
       ok (Some fun_type , expression)
@@ -857,7 +857,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
                 compile_block value
             | ShortBlock {value; _} ->
                 compile_statements @@ fst value.inside in
-      
+
       let%bind match_true = match_true None in
       let%bind match_false = match_false None in
       return_statement @@ e_cond ~loc expr match_true match_false
@@ -943,7 +943,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
             (fun (key, value) map ->  (e_map_add key value map))
             inj
             (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path)
-        in 
+        in
        return_statement @@ e_ez_assign ~loc name access_path assigns
     )
   | SetPatch patch -> (