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 }
-| "<string>"     { TStringLiteral $1 }
-| par(type_expr) { TPar $1 }
+  type_name      { TVar    $1 }
+| "<string>"     { TString $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
@@ -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 ->
-  pp_node   state "String";
+| TString s ->
+  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 }
-| "<string>"     { TStringLiteral $1 }
-| par(fun_type)  { TPar $1 }
+  type_name      { TVar    $1 }
+| "<string>"     { TString $1 }
+| par(fun_type)  { TPar    $1 }
 | module_name "." type_name {
     let module_name = $1.value in
     let type_name   = $3.value in

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 ->
@@ -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
 
 
@@ -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