diff --git a/src/passes/1-parser/cameligo.ml b/src/passes/1-parser/cameligo.ml index 79093af97..1413108a8 100644 --- a/src/passes/1-parser/cameligo.ml +++ b/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 = diff --git a/src/passes/1-parser/cameligo/Pretty.ml b/src/passes/1-parser/cameligo/Pretty.ml new file mode 100644 index 000000000..02aa37da8 --- /dev/null +++ b/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 ")" diff --git a/src/passes/1-parser/pascaligo.ml b/src/passes/1-parser/pascaligo.ml index 02b8f462e..b2c6ab9f4 100644 --- a/src/passes/1-parser/pascaligo.ml +++ b/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 = diff --git a/src/passes/1-parser/pascaligo/AST.ml b/src/passes/1-parser/pascaligo/AST.ml index fa22a7b25..070fbde68 100644 --- a/src/passes/1-parser/pascaligo/AST.ml +++ b/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 diff --git a/src/passes/1-parser/pascaligo/Parser.mly b/src/passes/1-parser/pascaligo/Parser.mly index 21d9420b7..4ac48d253 100644 --- a/src/passes/1-parser/pascaligo/Parser.mly +++ b/src/passes/1-parser/pascaligo/Parser.mly @@ -160,9 +160,9 @@ cartesian: in TProd {region; value} } core_type: - type_name { TVar $1 } -| "" { TStringLiteral $1 } -| par(type_expr) { TPar $1 } + type_name { TVar $1 } +| "" { TString $1 } +| par(type_expr) { TPar $1 } | type_name type_tuple { let region = cover $1.region $2.region in TApp {region; value = $1,$2} diff --git a/src/passes/1-parser/pascaligo/ParserLog.ml b/src/passes/1-parser/pascaligo/ParserLog.ml index 6347b07f7..c319dc8b0 100644 --- a/src/passes/1-parser/pascaligo/ParserLog.ml +++ b/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 -> - pp_node state "String"; +| TString s -> + pp_node state "TString"; pp_string (state#pad 1 0) s and pp_cartesian state {value; _} = diff --git a/src/passes/1-parser/reasonligo.ml b/src/passes/1-parser/reasonligo.ml index 1af70c927..d8cc66424 100644 --- a/src/passes/1-parser/reasonligo.ml +++ b/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 = diff --git a/src/passes/1-parser/reasonligo/Parser.mly b/src/passes/1-parser/reasonligo/Parser.mly index 702094ecd..65753b004 100644 --- a/src/passes/1-parser/reasonligo/Parser.mly +++ b/src/passes/1-parser/reasonligo/Parser.mly @@ -205,9 +205,9 @@ type_args: | fun_type { $1, [] } core_type: - type_name { TVar $1 } -| "" { TStringLiteral $1 } -| par(fun_type) { TPar $1 } + type_name { TVar $1 } +| "" { TString $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} } diff --git a/src/passes/2-concrete_to_imperative/cameligo.ml b/src/passes/2-concrete_to_imperative/cameligo.ml index 33d8cca21..a9543da3c 100644 --- a/src/passes/2-concrete_to_imperative/cameligo.ml +++ b/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 diff --git a/src/passes/2-concrete_to_imperative/pascaligo.ml b/src/passes/2-concrete_to_imperative/pascaligo.ml index 4ebef1559..d76910c18 100644 --- a/src/passes/2-concrete_to_imperative/pascaligo.ml +++ b/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 -> (