diff --git a/src/passes/01-parser/cameligo/AST.ml b/src/passes/01-parser/cameligo/AST.ml index 9be76e138..afb945c2d 100644 --- a/src/passes/01-parser/cameligo/AST.ml +++ b/src/passes/01-parser/cameligo/AST.ml @@ -228,7 +228,7 @@ and field_pattern = { and expr = ECase of expr case reg | ECond of cond_expr reg -| EAnnot of (expr * colon * type_expr) par reg +| EAnnot of annot_expr par reg | ELogic of logic_expr | EArith of arith_expr | EString of string_expr @@ -247,6 +247,8 @@ and expr = | EFun of fun_expr reg | ESeq of expr injection reg +and annot_expr = expr * colon * type_expr + and 'a injection = { compound : compound; elements : ('a, semi) sepseq; diff --git a/src/passes/01-parser/cameligo/Parser.mly b/src/passes/01-parser/cameligo/Parser.mly index 4f309c5b6..35f692671 100644 --- a/src/passes/01-parser/cameligo/Parser.mly +++ b/src/passes/01-parser/cameligo/Parser.mly @@ -583,7 +583,10 @@ core_expr: | record_expr { ERecord $1 } | update_record { EUpdate $1 } | par(expr) { EPar $1 } -| par(expr ":" type_expr {$1,$2,$3}) { EAnnot $1 } +| par(annot_expr) { EAnnot $1 } + +annot_expr: + expr ":" type_expr { $1,$2,$3 } module_field: module_name "." module_fun { diff --git a/src/passes/01-parser/cameligo/Pretty.ml b/src/passes/01-parser/cameligo/Pretty.ml index 50a16afb4..8fa298e3f 100644 --- a/src/passes/01-parser/cameligo/Pretty.ml +++ b/src/passes/01-parser/cameligo/Pretty.ml @@ -41,8 +41,9 @@ and pp_verbatim s = string "{|" ^^ pp_ident s ^^ string "|}" 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 = group (separate_map (break 1) pp_pattern patterns) in + let head, tail = binders in + let patterns = + group (nest 2 (separate_map (break 1) pp_pattern (head::tail))) in let lhs = patterns ^^ match lhs_type with @@ -95,11 +96,11 @@ and pp_ppar p = pp_par pp_pattern p and pp_plist = function PListComp cmp -> pp_list_comp cmp -| PCons cons -> pp_cons cons +| PCons cons -> pp_pcons cons and pp_list_comp e = group (pp_injection pp_pattern e) -and pp_cons {value; _} = +and pp_pcons {value; _} = let patt1, _, patt2 = value in prefix 2 1 (pp_pattern patt1 ^^ string " ::") (pp_pattern patt2) @@ -126,14 +127,15 @@ and pp_ptyped {value; _} = and pp_type_decl decl = let {name; type_expr; _} = decl.value in + let padding = match type_expr with TSum _ -> 0 | _ -> 2 in string "type " ^^ string name.value ^^ string " =" - ^^ group (nest 2 (break 1 ^^ pp_type_expr type_expr)) + ^^ group (nest padding (break 1 ^^ pp_type_expr type_expr)) 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 +| ELogic e -> group (pp_logic_expr e) | EArith e -> group (pp_arith_expr e) | EString e -> pp_string_expr e | EList e -> group (pp_list_expr e) @@ -166,15 +168,16 @@ and pp_cases {value; _} = and pp_clause {value; _} = let {pattern; rhs; _} = value in - prefix 4 1 (pp_pattern pattern ^^ string " ->") (pp_expr rhs) + pp_pattern pattern ^^ prefix 4 1 (string " ->") (pp_expr rhs) and pp_cond_expr {value; _} = let {test; ifso; kwd_else; ifnot; _} = value in let test = string "if " ^^ group (nest 3 (pp_expr test)) and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso)) and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot)) - in if kwd_else#is_ghost then test ^/^ ifso - else test ^/^ ifso ^/^ ifnot + in if kwd_else#is_ghost + then test ^/^ ifso + else test ^/^ ifso ^/^ ifnot and pp_annot_expr {value; _} = let expr, _, type_expr = value.inside in @@ -420,7 +423,7 @@ and pp_field_decl {value; _} = in prefix 2 1 (name ^^ string " :") t_expr and pp_type_app {value = ctor, tuple; _} = - prefix 2 1 (pp_type_tuple tuple) (pp_type_constr ctor) + pp_type_tuple tuple ^^ group (nest 2 (break 1 ^^ pp_type_constr ctor)) and pp_type_tuple {value; _} = let head, tail = value.inside in diff --git a/src/passes/01-parser/pascaligo/AST.ml b/src/passes/01-parser/pascaligo/AST.ml index cf6906b69..631704d47 100644 --- a/src/passes/01-parser/pascaligo/AST.ml +++ b/src/passes/01-parser/pascaligo/AST.ml @@ -206,7 +206,6 @@ and type_tuple = (type_expr, comma) nsepseq par reg (* Function and procedure declarations *) and fun_expr = { - kwd_recursive: kwd_recursive option; kwd_function : kwd_function; param : parameters; colon : colon; @@ -448,7 +447,7 @@ and collection = and expr = ECase of expr case reg | ECond of cond_expr reg -| EAnnot of annot_expr reg +| EAnnot of annot_expr par reg | ELogic of logic_expr | EArith of arith_expr | EString of string_expr @@ -467,7 +466,7 @@ and expr = | EPar of expr par reg | EFun of fun_expr reg -and annot_expr = expr * type_expr +and annot_expr = expr * colon * type_expr and set_expr = SetInj of expr injection reg diff --git a/src/passes/01-parser/pascaligo/Parser.mly b/src/passes/01-parser/pascaligo/Parser.mly index 753354cfd..64a12eb78 100644 --- a/src/passes/01-parser/pascaligo/Parser.mly +++ b/src/passes/01-parser/pascaligo/Parser.mly @@ -239,16 +239,15 @@ field_decl: fun_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; - kwd_function = $2; - param = $3; - colon = $4; - ret_type = $5; - kwd_is = $6; - return = $7} + "function" parameters ":" type_expr "is" expr { + let stop = expr_to_region $6 in + let region = cover $1 stop + and value = {kwd_function = $1; + param = $2; + colon = $3; + ret_type = $4; + kwd_is = $5; + return = $6} in {region; value} } (* Function declarations *) @@ -849,7 +848,7 @@ core_expr: | "False" { ELogic (BoolExpr (False $1)) } | "True" { ELogic (BoolExpr (True $1)) } | "Unit" { EUnit $1 } -| annot_expr { EAnnot $1 } +| par(annot_expr) { EAnnot $1 } | tuple_expr { ETuple $1 } | list_expr { EList $1 } | "None" { EConstr (NoneExpr $1) } @@ -891,12 +890,7 @@ fun_call_or_par_or_projection: | fun_call { ECall $1 } annot_expr: - "(" disj_expr ":" type_expr ")" { - let start = expr_to_region $2 - and stop = type_expr_to_region $4 in - let region = cover start stop - and value = $2, $4 - in {region; value} } + disj_expr ":" type_expr { $1,$2,$3 } set_expr: injection("set",expr) { SetInj ($1 (fun region -> InjSet region)) } diff --git a/src/passes/01-parser/pascaligo/ParserLog.ml b/src/passes/01-parser/pascaligo/ParserLog.ml index 6ae1ca0ac..414b27d0f 100644 --- a/src/passes/01-parser/pascaligo/ParserLog.ml +++ b/src/passes/01-parser/pascaligo/ParserLog.ml @@ -180,9 +180,9 @@ and print_type_app state {value; _} = and print_type_fun state {value; _} = let type_expr_a, arrow, type_expr_b = value in - print_type_expr state type_expr_a; - print_token state arrow "->"; - print_type_expr state type_expr_b + print_type_expr state type_expr_a; + print_token state arrow "->"; + print_type_expr state type_expr_b and print_par_type state {value; _} = let {lpar; inside; rpar} = value in @@ -206,12 +206,12 @@ and print_fun_decl state {value; _} = let {kwd_function; fun_name; param; colon; ret_type; kwd_is; block_with; return; terminator; _} = value in - print_token state kwd_function "function"; - print_var state fun_name; - print_parameters state param; - print_token state colon ":"; - print_type_expr state ret_type; - print_token state kwd_is "is"; + print_token state kwd_function "function"; + print_var state fun_name; + print_parameters state param; + print_token state colon ":"; + print_type_expr state ret_type; + print_token state kwd_is "is"; (match block_with with None -> () | Some (block, kwd_with) -> @@ -221,15 +221,14 @@ and print_fun_decl state {value; _} = print_terminator state terminator; and print_fun_expr state {value; _} = - let {kwd_recursive; kwd_function; param; colon; + let {kwd_function; param; colon; ret_type; kwd_is; return} : fun_expr = value in - print_token_opt state kwd_recursive "recursive"; - print_token state kwd_function "function"; - print_parameters state param; - print_token state colon ":"; - print_type_expr state ret_type; - print_token state kwd_is "is"; - print_expr state return + print_token state kwd_function "function"; + print_parameters state param; + print_token state colon ":"; + print_type_expr state ret_type; + print_token state kwd_is "is"; + print_expr state return and print_parameters state {value; _} = let {lpar; inside; rpar} = value in @@ -260,10 +259,10 @@ and print_block state block = match enclosing with Block (kwd_block, lbrace, rbrace) -> print_token state kwd_block "block"; - print_token state lbrace "{"; + print_token state lbrace "{"; print_statements state statements; print_terminator state terminator; - print_token state rbrace "}" + print_token state rbrace "}" | BeginEnd (kwd_begin, kwd_end) -> print_token state kwd_begin "begin"; print_statements state statements; @@ -464,7 +463,9 @@ and print_expr state = function | EPar e -> print_par_expr state e | EFun e -> print_fun_expr state e -and print_annot_expr state (expr , type_expr) = +and print_annot_expr state node = + let {inside; _} : annot_expr par = node in + let expr, _, type_expr = inside in print_expr state expr; print_type_expr state type_expr @@ -1432,7 +1433,7 @@ and pp_expr state = function pp_cond_expr state value | EAnnot {value; region} -> pp_loc_node state "EAnnot" region; - pp_annotated state value + pp_annotated state value.inside | ELogic e_logic -> pp_node state "ELogic"; pp_e_logic (state#pad 1 0) e_logic @@ -1607,7 +1608,7 @@ and pp_string_expr state = function pp_node state "Verbatim"; pp_verbatim (state#pad 1 0) v -and pp_annotated state (expr, t_expr) = +and pp_annotated state (expr, _, t_expr) = pp_expr (state#pad 2 0) expr; pp_type_expr (state#pad 2 1) t_expr diff --git a/src/passes/01-parser/pascaligo/Pretty.ml b/src/passes/01-parser/pascaligo/Pretty.ml index 37ee63569..089763655 100644 --- a/src/passes/01-parser/pascaligo/Pretty.ml +++ b/src/passes/01-parser/pascaligo/Pretty.ml @@ -32,14 +32,14 @@ and pp_attr_decl decl = pp_ne_injection pp_string decl and pp_const_decl {value; _} = let {name; const_type; init; attributes; _} = value in - let start = string ("const " ^ name.value ^ " :") in + let start = string ("const " ^ name.value) in let t_expr = pp_type_expr const_type in let attr = match attributes with None -> empty - | Some a -> hardline ^^ pp_attr_decl a - in prefix 2 1 start t_expr - ^/^ prefix 2 1 (string "=") (pp_expr init) - ^^ attr + | Some a -> hardline ^^ pp_attr_decl a in + group (start ^/^ nest 2 (string ": " ^^ t_expr)) + ^^ group (break 1 ^^ nest 2 (string "= " ^^ pp_expr init)) + ^^ attr (* Type declarations *) @@ -117,32 +117,40 @@ and pp_type_tuple {value; _} = (* Function and procedure declarations *) -and pp_fun_expr {value; _} = string "TODO:pp_fun_expr" +and pp_fun_expr {value; _} = + let {param; ret_type; return; _} : fun_expr = value in + let start = string "function" in + let parameters = pp_par pp_parameters param in + let return_t = pp_type_expr ret_type in + let expr = pp_expr return in + group (start ^^ nest 2 (break 1 ^^ parameters)) + ^^ group (break 1 ^^ nest 2 (string ": " ^^ return_t)) + ^^ string " is" ^^ group (nest 4 (break 1 ^^ 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" + None -> string "function" | Some _ -> string "recursive" ^/^ string "function" in + let start = start ^^ group (break 1 ^^ nest 2 (pp_ident fun_name)) in let parameters = pp_par pp_parameters param in let return_t = pp_type_expr ret_type in - let blk_opening, blk_in, blk_closing = - match block_with with - None -> empty, empty, empty - | Some (b,_) -> - hardline ^^ string "is block [", pp_block b, string "] with" in let expr = pp_expr return in - let attr = match attributes with + let body = + match block_with with + None -> group (nest 2 (break 1 ^^ expr)) + | Some (b,_) -> hardline ^^ string "block [" + ^^ nest 2 (hardline ^^ pp_block b) + ^^ hardline + ^^ group (string "] with" ^^ nest 4 (break 1 ^^ expr)) + and attr = match attributes with None -> empty - | Some a -> hardline ^^ pp_attr_decl a - in group (start ^^ nest 2 (break 1 ^^ parameters)) - ^/^ string ": " ^^ nest 2 return_t - ^^ blk_opening - ^^ nest 2 (break 0 ^^ blk_in) - ^/^ group (blk_closing ^^ nest 4 (break 1 ^^ expr)) - ^^ attr + | Some a -> hardline ^^ pp_attr_decl a in + prefix 2 1 start parameters + ^^ group (nest 2 (break 1 ^^ string ": " ^^ return_t ^^ string " is")) + ^^ body ^^ attr and pp_parameters p = pp_nsepseq ";" pp_param_decl p @@ -178,10 +186,10 @@ and pp_data_decl = function and pp_var_decl {value; _} = let {name; var_type; init; _} = value in - let start = string ("var " ^ name.value ^ " :") in - let t_expr = pp_type_expr var_type - in prefix 2 1 start - (t_expr ^/^ prefix 2 1 (string ":=") (pp_expr init)) + let start = string ("var " ^ name.value) in + let t_expr = pp_type_expr var_type in + group (start ^/^ nest 2 (string ": " ^^ t_expr)) + ^^ group (break 1 ^^ nest 2 (string ":= " ^^ pp_expr init)) and pp_instruction = function Cond i -> group (pp_conditional i) @@ -196,41 +204,52 @@ and pp_instruction = function | MapRemove i -> pp_map_remove i | SetRemove i -> pp_set_remove i -and pp_set_remove {value; _} = string "TODO:pp_set_remove" +and pp_set_remove {value; _} = + let {element; set; _} : set_remove = value in + string "remove" ^^ group (nest 2 (break 1 ^^ pp_expr element)) + ^/^ string "from set" ^^ group (nest 2 (break 1 ^^ pp_path set)) -and pp_map_remove {value; _} = string "TODO:pp_map_remove" +and pp_map_remove {value; _} = + let {key; map; _} = value in + string "remove" ^^ group (nest 2 (break 1 ^^ pp_expr key)) + ^/^ string "from map" ^^ group (nest 2 (break 1 ^^ pp_path map)) 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_binding {value; _} = + let {source; image; _} = value in + pp_expr source ^^ string " ->" + ^^ group (nest 2 (break 1 ^^ pp_expr image)) and pp_record_patch {value; _} = string "TODO:pp_record_patch" -and pp_cond_expr {value; _} = string "TODO:pp_cond_expr" +and pp_cond_expr {value; _} = + let {test; ifso; kwd_else; ifnot; _} : cond_expr = value in + let test = string "if " ^^ group (nest 3 (pp_expr test)) + and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_expr ifso)) + and ifnot = string "else" ^^ group (nest 2 (break 1 ^^ pp_expr ifnot)) + in test ^/^ ifso ^/^ ifnot and pp_conditional {value; _} = let {test; ifso; ifnot; _} : conditional = value in let test = string "if " ^^ group (nest 3 (pp_expr test)) and ifso = string "then" ^^ group (nest 2 (break 1 ^^ pp_if_clause ifso)) - and ifnot = - if is_clause_block ifnot then - string "else {" - ^^ group (nest 2 (hardline ^^ pp_if_clause ifnot)) - ^^ hardline ^^ string "}" - else - string "else" ^^ group (nest 2 (break 1 ^^ pp_if_clause ifnot)) + and ifnot = match ifnot with + ClauseInstr i -> + string "else" + ^^ group (nest 2 (break 1 ^^ pp_instruction i)) + | ClauseBlock b -> + string "else {" + ^^ group (nest 2 (hardline ^^ pp_clause_block b)) + ^^ hardline ^^ string "}" in test ^/^ ifso ^/^ ifnot and pp_if_clause = function ClauseInstr i -> pp_instruction i | ClauseBlock b -> pp_clause_block b -and is_clause_block = function - ClauseInstr _ -> false -| ClauseBlock _ -> true - and pp_clause_block = function LongBlock b -> pp_block b | ShortBlock {value; _} -> Utils.(pp_statements <@ fst) value.inside @@ -251,7 +270,7 @@ and pp_cases : fun printer {value; _} -> let head, tail = value in let head = pp_case_clause printer head in - let head = if tail = [] then head else blank 2 ^^ head in + let head = blank 2 ^^ head in let rest = List.map snd tail in let app clause = break 1 ^^ string "| " ^^ pp_case_clause printer clause in head ^^ concat_map app rest @@ -260,8 +279,7 @@ and pp_case_clause : 'a.('a -> document) -> 'a case_clause Region.reg -> document = fun printer {value; _} -> let {pattern; rhs; _} = value in - prefix 4 1 (pp_pattern pattern ^^ string " ->") (printer rhs) - + pp_pattern pattern ^^ prefix 4 1 (string " ->") (printer rhs) and pp_assignment {value; _} = let {lhs; rhs; _} = value in @@ -298,7 +316,7 @@ and pp_expr = function ECase e -> pp_case pp_expr e | ECond e -> group (pp_cond_expr e) | EAnnot e -> pp_annot_expr e -| ELogic e -> pp_logic_expr e +| ELogic e -> group (pp_logic_expr e) | EArith e -> group (pp_arith_expr e) | EString e -> pp_string_expr e | EList e -> group (pp_list_expr e) @@ -316,7 +334,10 @@ and pp_expr = function | 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_annot_expr {value; _} = + let expr, _, type_expr = value.inside in + group (string "(" ^^ nest 1 (pp_expr expr ^/^ string ": " + ^^ pp_type_expr type_expr ^^ string ")")) and pp_set_expr = function SetInj inj -> string "TODO:pp_set_expr:SetInj" @@ -324,11 +345,11 @@ and pp_set_expr = function 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 +| MapInj inj -> group (pp_injection pp_binding inj) +| BigMapInj inj -> group (pp_injection pp_binding inj) and pp_map_lookup {value; _} = - pp_path value.path ^^ blank 1 ^^ pp_brackets pp_expr value.index + prefix 2 1 (pp_path value.path) (pp_brackets pp_expr value.index) and pp_path = function Name v -> pp_ident v @@ -451,7 +472,8 @@ and pp_injection : let kwd = pp_injection_kwd kind in let offset = String.length kwd + 2 in string (kwd ^ " [") - ^^ group (nest 2 (break 0 ^^ elements ^^ string "]")) + ^^ group (nest 2 (break 0 ^^ elements)) + ^^ break 0 ^^ string "]" and pp_injection_kwd = function InjSet _ -> "set" @@ -467,7 +489,8 @@ and pp_ne_injection : let kwd = pp_ne_injection_kwd kind in let offset = String.length kwd + 2 in string (kwd ^ " [") - ^^ group (nest 2 (break 0 ^^ elements ^^ string "]")) + ^^ group (nest 2 (break 0 ^^ elements )) + ^^ break 0 ^^ string "]" and pp_ne_injection_kwd = function NEInjAttr _ -> "attributes" @@ -526,9 +549,9 @@ 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 +| PCons p -> nest 4 (pp_nsepseq " #" pp_pattern p.value) -and pp_list_comp {value; _} = string "TODO:pp_list_comp" +and pp_list_comp e = group (pp_injection pp_pattern e) and pp_ppar_cons {value; _} = string "TODO:pp_ppar_cons"