balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Somewhat better PP for ast_core and mini_c

Browse Source
This commit is contained in:
Tom Jack 2020-03-23 15:14:55 -05:00
parent 60070cc8d0
commit 6fed8998bb
7 changed files with 109 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/bin/expect_tests/contract_tests.ml
View File

@ -26,7 +26,7 @@ let%expect_test _ =
run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ; run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ;
[%expect {| [%expect {|
ligo: different kinds: {"a":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) , cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) , next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] , Sell_single -> record[card_to_sell -> nat] , Transfer_single -> record[card_to_transfer -> nat , destination -> address]]"} ligo: different kinds: {"a":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can
@ -39,7 +39,7 @@ let%expect_test _ =
run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ; run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ;
[%expect {| [%expect {|
ligo: different kinds: {"a":"sum[Buy_single -> record[card_to_buy -> nat] , Sell_single -> record[card_to_sell -> nat] , Transfer_single -> record[card_to_transfer -> nat , destination -> address]]","b":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) , cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) , next_id -> nat]"} ligo: different kinds: {"a":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]","b":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can
@ -1117,7 +1117,7 @@ let%expect_test _ =
let%expect_test _ = let%expect_test _ =
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#702 = #P in let p = rhs#702.0 in let s = rhs#702.1 in ( LIST_EMPTY() : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return\n let rhs#702 = #P in\n let p = rhs#702.0 in\n let s = rhs#702.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , store ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can
@ -1130,7 +1130,7 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8,
run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#705 = #P in let p = rhs#705.0 in let s = rhs#705.1 in ( LIST_EMPTY() : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return\n let rhs#705 = #P in\n let p = rhs#705.0 in\n let s = rhs#705.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , a ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"}
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can

4
src/bin/expect_tests/typer_error_tests.ml
View File

@ -158,7 +158,9 @@ let%expect_test _ =
run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ; run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ;
[%expect {| [%expect {|
ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address , owner -> address , profile -> bytes] ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address ,
owner -> address ,
profile -> bytes]
If you're not sure how to fix this error, you can If you're not sure how to fix this error, you can
do one of the following: do one of the following:

6
src/passes/11-self_mini_c/michelson_restrictions.ml
View File

@ -5,9 +5,9 @@ module Errors = struct
let bad_self_address cst () = let bad_self_address cst () =
let title = thunk @@ let title = thunk @@
Format.asprintf "Wrong %alocation" Mini_c.PP.expression' cst in Format.asprintf "Wrong %a location" Stage_common.PP.constant cst in
let message = thunk @@ let message = thunk @@
Format.asprintf "%ais only allowed at top-level" Mini_c.PP.expression' cst in Format.asprintf "%a is only allowed at top-level" Stage_common.PP.constant cst in
error title message () error title message ()
end end
@ -19,7 +19,7 @@ let self_in_lambdas : expression -> expression result =
| E_closure {binder=_ ; body} -> | E_closure {binder=_ ; body} ->
let%bind _self_in_lambdas = Helpers.map_expression let%bind _self_in_lambdas = Helpers.map_expression
(fun e -> match e.content with (fun e -> match e.content with
| E_constant {cons_name=C_SELF_ADDRESS; _} as c -> fail (bad_self_address c) | E_constant {cons_name=C_SELF_ADDRESS; _} -> fail (bad_self_address C_SELF_ADDRESS)
| _ -> ok e) | _ -> ok e)
body in body in
ok e ok e

62
src/passes/11-self_mini_c/subst.ml
View File

@ -225,7 +225,7 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(V(x))[x := L(unit)] = (x)[x := L(unit)] =
L(unit) |}] ; L(unit) |}] ;
(* other var *) (* other var *)
@ -235,8 +235,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(V(y))[x := L(unit)] = (y)[x := L(unit)] =
V(y) y
|}] ; |}] ;
(* closure shadowed *) (* closure shadowed *)
@ -246,8 +246,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(C(fun x -> (V(x))))[x := L(unit)] = (fun x -> (x))[x := L(unit)] =
C(fun x -> (V(x))) fun x -> (x)
|}] ; |}] ;
(* closure not shadowed *) (* closure not shadowed *)
@ -257,8 +257,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(C(fun y -> (V(x))))[x := L(unit)] = (fun y -> (x))[x := L(unit)] =
C(fun y -> (L(unit))) fun y -> (L(unit))
|}] ; |}] ;
(* closure capture-avoidance *) (* closure capture-avoidance *)
@ -268,8 +268,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:(wrap (E_variable y)) ; ~expr:(wrap (E_variable y)) ;
[%expect{| [%expect{|
(C(fun y -> ((V(x))@(V(y)))))[x := V(y)] = (fun y -> ((x)@(y)))[x := y] =
C(fun y#1 -> ((V(y))@(V(y#1)))) fun y#1 -> ((y)@(y#1))
|}] ; |}] ;
(* let-in shadowed (not in rhs) *) (* let-in shadowed (not in rhs) *)
@ -279,8 +279,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(let x = V(x) in ( V(x) ))[x := L(unit)] = (let x = x in x)[x := L(unit)] =
let x = L(unit) in ( V(x) ) let x = L(unit) in x
|}] ; |}] ;
(* let-in not shadowed *) (* let-in not shadowed *)
@ -290,8 +290,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(let y = V(x) in ( V(x) ))[x := L(unit)] = (let y = x in x)[x := L(unit)] =
let y = L(unit) in ( L(unit) ) let y = L(unit) in L(unit)
|}] ; |}] ;
(* let-in capture avoidance *) (* let-in capture avoidance *)
@ -302,8 +302,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:(var y) ; ~expr:(var y) ;
[%expect{| [%expect{|
(let y = V(x) in ( (V(x))@(V(y)) ))[x := V(y)] = (let y = x in (x)@(y))[x := y] =
let y#1 = V(y) in ( (V(y))@(V(y#1)) ) let y#1 = y in (y)@(y#1)
|}] ; |}] ;
(* iter shadowed *) (* iter shadowed *)
@ -313,8 +313,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(for_ITER x of V(x) do ( V(x) ))[x := L(unit)] = (for_ITER x of x do ( x ))[x := L(unit)] =
for_ITER x of L(unit) do ( V(x) ) for_ITER x of L(unit) do ( x )
|}] ; |}] ;
(* iter not shadowed *) (* iter not shadowed *)
@ -324,7 +324,7 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(for_ITER y of V(x) do ( V(x) ))[x := L(unit)] = (for_ITER y of x do ( x ))[x := L(unit)] =
for_ITER y of L(unit) do ( L(unit) ) for_ITER y of L(unit) do ( L(unit) )
|}] ; |}] ;
@ -335,8 +335,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:(var y) ; ~expr:(var y) ;
[%expect{| [%expect{|
(for_ITER y of (V(x))@(V(y)) do ( (V(x))@(V(y)) ))[x := V(y)] = (for_ITER y of (x)@(y) do ( (x)@(y) ))[x := y] =
for_ITER y#1 of (V(y))@(V(y)) do ( (V(y))@(V(y#1)) ) for_ITER y#1 of (y)@(y) do ( (y)@(y#1) )
|}] ; |}] ;
(* if_cons shadowed 1 *) (* if_cons shadowed 1 *)
@ -349,8 +349,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(V(x) ?? V(x) : (x :: y) -> V(x))[x := L(unit)] = (x ?? x : (x :: y) -> x)[x := L(unit)] =
L(unit) ?? L(unit) : (x :: y) -> V(x) L(unit) ?? L(unit) : (x :: y) -> x
|}] ; |}] ;
(* if_cons shadowed 2 *) (* if_cons shadowed 2 *)
@ -363,8 +363,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(V(x) ?? V(x) : (y :: x) -> V(x))[x := L(unit)] = (x ?? x : (y :: x) -> x)[x := L(unit)] =
L(unit) ?? L(unit) : (y :: x) -> V(x) L(unit) ?? L(unit) : (y :: x) -> x
|}] ; |}] ;
(* if_cons not shadowed *) (* if_cons not shadowed *)
@ -377,7 +377,7 @@ let%expect_test _ =
~x:x ~x:x
~expr:unit ; ~expr:unit ;
[%expect{| [%expect{|
(V(x) ?? V(x) : (y :: z) -> V(x))[x := L(unit)] = (x ?? x : (y :: z) -> x)[x := L(unit)] =
L(unit) ?? L(unit) : (y :: z) -> L(unit) L(unit) ?? L(unit) : (y :: z) -> L(unit)
|}] ; |}] ;
@ -391,8 +391,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:(var y) ; ~expr:(var y) ;
[%expect{| [%expect{|
(V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(y)] = (x ?? x : (y :: z) -> (x)@((y)@(z)))[x := y] =
V(y) ?? V(y) : (y#1 :: z) -> (V(y))@((V(y#1))@(V(z))) y ?? y : (y#1 :: z) -> (y)@((y#1)@(z))
|}] ; |}] ;
(* if_cons capture avoidance 2 *) (* if_cons capture avoidance 2 *)
@ -405,8 +405,8 @@ let%expect_test _ =
~x:x ~x:x
~expr:(var z) ; ~expr:(var z) ;
[%expect{| [%expect{|
(V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(z)] = (x ?? x : (y :: z) -> (x)@((y)@(z)))[x := z] =
V(z) ?? V(z) : (y :: z#1) -> (V(z))@((V(y))@(V(z#1))) z ?? z : (y :: z#1) -> (z)@((y)@(z#1))
|}] ; |}] ;
(* old bug *) (* old bug *)
@ -417,6 +417,6 @@ let%expect_test _ =
~x:x ~x:x
~expr:(var y) ; ~expr:(var y) ;
[%expect{| [%expect{|
(C(fun y -> (C(fun y#1 -> ((V(x))@((V(y))@(V(y#1))))))))[x := V(y)] = (fun y -> (fun y#1 -> ((x)@((y)@(y#1)))))[x := y] =
C(fun y#2 -> (C(fun y#1 -> ((V(y))@((V(y#2))@(V(y#1))))))) fun y#2 -> (fun y#1 -> ((y)@((y#2)@(y#1))))
|}] ; |}] ;

38
src/stages/3-ast_core/PP.ml
View File

@ -19,20 +19,20 @@ and expression_content ppf (ec : expression_content) =
| E_variable n -> | E_variable n ->
fprintf ppf "%a" expression_variable n fprintf ppf "%a" expression_variable n
| E_application {lamb;args} -> | E_application {lamb;args} ->
fprintf ppf "(%a)@(%a)" expression lamb expression args fprintf ppf "@[<hv>(%a)@@(%a)@]" expression lamb expression args
| E_constructor c -> | E_constructor c ->
fprintf ppf "%a(%a)" constructor c.constructor expression c.element fprintf ppf "@[%a(%a)@]" constructor c.constructor expression c.element
| E_constant c -> | E_constant c ->
fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) fprintf ppf "@[%a@[<hv 1>(%a)@]@]" constant c.cons_name (list_sep_d expression)
c.arguments c.arguments
| E_record m -> | E_record m ->
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
| E_record_accessor ra -> | E_record_accessor ra ->
fprintf ppf "%a.%a" expression ra.record label ra.path fprintf ppf "@[%a.%a@]" expression ra.record label ra.path
| E_record_update {record; path; update} -> | E_record_update {record; path; update} ->
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression record label path expression update
| E_lambda {binder; input_type; output_type; result} -> | E_lambda {binder; input_type; output_type; result} ->
fprintf ppf "lambda (%a:%a) : %a return %a" fprintf ppf "@[lambda (%a:%a) : %a@ return@ %a@]"
expression_variable binder expression_variable binder
(PP_helpers.option type_expression) (PP_helpers.option type_expression)
input_type input_type
@ -44,10 +44,10 @@ and expression_content ppf (ec : expression_content) =
type_expression fun_type type_expression fun_type
expression_content (E_lambda lambda) expression_content (E_lambda lambda)
| E_matching {matchee; cases; _} -> | E_matching {matchee; cases; _} ->
fprintf ppf "match %a with %a" expression matchee (matching expression) fprintf ppf "@[match %a with@ %a@]" expression matchee (matching expression)
cases cases
| E_let_in { let_binder ;rhs ; let_result; inline } -> | E_let_in { let_binder ;rhs ; let_result; inline } ->
fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" option_type_name let_binder expression rhs option_inline inline expression let_result
| E_ascription {anno_expr; type_annotation} -> | E_ascription {anno_expr; type_annotation} ->
fprintf ppf "%a : %a" expression anno_expr type_expression fprintf ppf "%a : %a" expression anno_expr type_expression
type_annotation type_annotation
@ -61,27 +61,27 @@ and option_type_name ppf
fprintf ppf "%a : %a" expression_variable n type_expression ty fprintf ppf "%a : %a" expression_variable n type_expression ty
and assoc_expression ppf : expr * expr -> unit = and assoc_expression ppf : expr * expr -> unit =
fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b fun (a, b) -> fprintf ppf "@[<2>%a ->@;<1 2>%a@]" expression a expression b
and single_record_patch ppf ((p, expr) : label * expr) = and single_record_patch ppf ((p, expr) : label * expr) =
fprintf ppf "%a <- %a" label p expression expr fprintf ppf "%a <- %a" label p expression expr
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit = and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
fun f ppf ((c,n),a) -> fun f ppf ((c,n),a) ->
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a fprintf ppf "| %a %a ->@;<1 2>%a@ " constructor c expression_variable n f a
and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit = and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit =
fun f ppf m -> match m with fun f ppf m -> match m with
| Match_tuple ((lst, b), _) -> | Match_tuple ((lst, b), _) ->
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b fprintf ppf "@[<hv>| (%a) ->@;<1 2>%a@]" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) -> | Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst fprintf ppf "@[<hv>%a@]" (list_sep (matching_variant_case f) (tag "@ ")) lst
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false fprintf ppf "@[<hv>| True ->@;<1 2>%a@ | False ->@;<1 2>%a@]" f match_true f match_false
| Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} -> | Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} ->
fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons fprintf ppf "@[<hv>| Nil ->@;<1 2>%a@ | %a :: %a ->@;<1 2>%a@]" f match_nil expression_variable hd expression_variable tl f match_cons
| Match_option {match_none ; match_some = (some, match_some, _)} -> | Match_option {match_none ; match_some = (some, match_some, _)} ->
fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some fprintf ppf "@[<hv>| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]" f match_none expression_variable some f match_some
(* Shows the type expected for the matched value *) (* Shows the type expected for the matched value *)
and matching_type ppf m = match m with and matching_type ppf m = match m with
@ -101,22 +101,22 @@ and matching_variant_case_type ppf ((c,n),_a) =
and option_mut ppf mut = and option_mut ppf mut =
if mut then if mut then
fprintf ppf "[@mut]" fprintf ppf "[@@mut]"
else else
fprintf ppf "" fprintf ppf ""
and option_inline ppf inline = and option_inline ppf inline =
if inline then if inline then
fprintf ppf "[@inline]" fprintf ppf "[@@inline]"
else else
fprintf ppf "" fprintf ppf ""
let declaration ppf (d : declaration) = let declaration ppf (d : declaration) =
match d with match d with
| Declaration_type (type_name, te) -> | Declaration_type (type_name, te) ->
fprintf ppf "type %a = %a" type_variable type_name type_expression te fprintf ppf "@[<2>type %a =@ %a@]" type_variable type_name type_expression te
| Declaration_constant (name, ty_opt, i, expr) -> | Declaration_constant (name, ty_opt, i, expr) ->
fprintf ppf "const %a = %a%a" option_type_name (name, ty_opt) expression fprintf ppf "@[<2>const %a =@ %a%a@]" option_type_name (name, ty_opt) expression
expr expr
option_inline i option_inline i

76
src/stages/5-mini_c/PP.ml
View File

@ -3,23 +3,21 @@ open Simple_utils.PP_helpers
open Types open Types
open Format open Format
let list_sep_d x = list_sep x (const " , ") let list_sep_d x = list_sep x (tag " ,@ ")
let space_sep ppf () = fprintf ppf " "
let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R" let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R"
let rec type_variable ppf : type_value -> _ = function let rec type_variable ppf : type_value -> _ = function
| T_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b | T_or(a, b) -> fprintf ppf "@[(%a) |@ (%a)@]" annotated a annotated b
| T_pair(a, b) -> fprintf ppf "(%a) & (%a)" annotated a annotated b | T_pair(a, b) -> fprintf ppf "@[(%a) &@ (%a)@]" annotated a annotated b
| T_base b -> type_constant ppf b | T_base b -> type_constant ppf b
| T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_variable a type_variable b | T_function(a, b) -> fprintf ppf "@[(%a) ->@ (%a)@]" type_variable a type_variable b
| T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_variable k type_variable v | T_map(k, v) -> fprintf ppf "@[<4>map(%a -> %a)@]" type_variable k type_variable v
| T_big_map(k, v) -> fprintf ppf "big_map(%a -> %a)" type_variable k type_variable v | T_big_map(k, v) -> fprintf ppf "@[<9>big_map(%a -> %a)@]" type_variable k type_variable v
| T_list(t) -> fprintf ppf "list(%a)" type_variable t | T_list(t) -> fprintf ppf "@[<5>list(%a)@]" type_variable t
| T_set(t) -> fprintf ppf "set(%a)" type_variable t | T_set(t) -> fprintf ppf "@[<4>set(%a)@]" type_variable t
| T_option(o) -> fprintf ppf "option(%a)" type_variable o | T_option(o) -> fprintf ppf "@[<7>option(%a)@]" type_variable o
| T_contract(t) -> fprintf ppf "contract(%a)" type_variable t | T_contract(t) -> fprintf ppf "@[<9>contract(%a)@]" type_variable t
and annotated ppf : type_value annotated -> _ = function and annotated ppf : type_value annotated -> _ = function
| (Some ann, a) -> fprintf ppf "(%a %%%s)" type_variable a ann | (Some ann, a) -> fprintf ppf "(%a %%%s)" type_variable a ann
@ -80,30 +78,38 @@ and expression ppf (e:expression) =
and expression' ppf (e:expression') = match e with and expression' ppf (e:expression') = match e with
| E_skip -> fprintf ppf "skip" | E_skip -> fprintf ppf "skip"
| E_closure x -> fprintf ppf "C(%a)" function_ x | E_closure x -> function_ ppf x
| E_variable v -> fprintf ppf "V(%a)" Var.pp v | E_variable v -> fprintf ppf "%a" Var.pp v
| E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b | E_application(a, b) -> fprintf ppf "@[(%a)@(%a)@]" expression a expression b
| E_constant c -> fprintf ppf "%a %a" constant c.cons_name (pp_print_list ~pp_sep:space_sep expression) c.arguments | E_constant c -> fprintf ppf "@[%a@[<hv 1>(%a)@]@]" constant c.cons_name (list_sep_d expression) c.arguments
| E_literal v -> fprintf ppf "L(%a)" value v | E_literal v -> fprintf ppf "@[L(%a)@]" value v
| E_make_none _ -> fprintf ppf "none" | E_make_none _ -> fprintf ppf "none"
| E_if_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b | E_if_bool (c, a, b) ->
| E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %a -> %a" expression c expression n Var.pp name expression s fprintf ppf
| E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "%a ?? %a : (%a :: %a) -> %a" expression c expression n Var.pp hd_name Var.pp tl_name expression cons "@[match %a with@ @[<hv>| True ->@;<1 2>%a@ | False ->@;<1 2>%a@]@]"
expression c expression a expression b
| E_if_none (c, n, ((name, _) , s)) ->
fprintf ppf
"@[match %a with@ @[<hv>| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]@]"
expression c expression n Var.pp name expression s
| E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "@[%a ?? %a : (%a :: %a) -> %a@]" expression c expression n Var.pp hd_name Var.pp tl_name expression cons
| E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
fprintf ppf "%a ?? %a -> %a : %a -> %a" expression c Var.pp name_l expression l Var.pp name_r expression r fprintf ppf
| E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b "@[match %a with@ @[<hv>| Left %a ->@;<1 2>%a@ | Right %a ->@;<1 2>%a@]@]"
expression c Var.pp name_l expression l Var.pp name_r expression r
| E_sequence (a , b) -> fprintf ppf "@[%a ;; %a@]" expression a expression b
| E_let_in ((name , _) , inline, expr , body) -> | E_let_in ((name , _) , inline, expr , body) ->
fprintf ppf "let %a = %a%a in ( %a )" Var.pp name expression expr option_inline inline expression body fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" Var.pp name expression expr option_inline inline expression body
| E_iterator (b , ((name , _) , body) , expr) -> | E_iterator (b , ((name , _) , body) , expr) ->
fprintf ppf "for_%a %a of %a do ( %a )" constant b Var.pp name expression expr expression body fprintf ppf "@[for_%a %a of %a do ( %a )@]" constant b Var.pp name expression expr expression body
| E_fold (((name , _) , body) , collection , initial) -> | E_fold (((name , _) , body) , collection , initial) ->
fprintf ppf "fold %a on %a with %a do ( %a )" expression collection expression initial Var.pp name expression body fprintf ppf "@[fold %a on %a with %a do ( %a )@]" expression collection expression initial Var.pp name expression body
| E_record_update (r, path,update) -> | E_record_update (r, path,update) ->
fprintf ppf "%a with { %a = %a }" expression r (list_sep lr (const ".")) path expression update fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression r (list_sep lr (const ".")) path expression update
| E_while (e , b) -> | E_while (e , b) ->
fprintf ppf "while %a do %a" expression e expression b fprintf ppf "@[while %a do %a@]" expression e expression b
and expression_with_type : _ -> expression -> _ = fun ppf e -> and expression_with_type : _ -> expression -> _ = fun ppf e ->
fprintf ppf "%a : %a" fprintf ppf "%a : %a"
@ -111,24 +117,22 @@ and expression_with_type : _ -> expression -> _ = fun ppf e ->
type_variable e.type_value type_variable e.type_value
and function_ ppf ({binder ; body}:anon_function) = and function_ ppf ({binder ; body}:anon_function) =
fprintf ppf "fun %a -> (%a)" fprintf ppf "@[fun %a ->@ (%a)@]"
Var.pp binder Var.pp binder
expression body expression body
and assignment ppf ((n, i, e):assignment) = fprintf ppf "%a = %a%a;" Var.pp n expression e option_inline i
and option_inline ppf inline = and option_inline ppf inline =
if inline then if inline then
fprintf ppf "[@inline]" fprintf ppf "[@@inline]"
else else
fprintf ppf "" fprintf ppf ""
and declaration ppf ((n,i, e):assignment) = fprintf ppf "let %a = %a%a;" Var.pp n expression e option_inline i and declaration ppf ((n,i, e):assignment) = fprintf ppf "@[let %a =@;<1 2>%a%a@]" Var.pp n expression e option_inline i
and tl_statement ppf (ass, _) = assignment ppf ass and tl_statement ppf (ass, _) = declaration ppf ass
and program ppf (p:program) = and program ppf (p:program) =
fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p fprintf ppf "@[<v>%a@]" (pp_print_list ~pp_sep:(tag "@ ") tl_statement) p
and constant ppf : constant' -> unit = function and constant ppf : constant' -> unit = function
| C_INT -> fprintf ppf "INT" | C_INT -> fprintf ppf "INT"
@ -254,9 +258,9 @@ let%expect_test _ =
let wrap e = { content = e ; type_value = dummy_type } in let wrap e = { content = e ; type_value = dummy_type } in
pp @@ E_closure { binder = Var.of_name "y" ; body = wrap (E_variable (Var.of_name "y")) } ; pp @@ E_closure { binder = Var.of_name "y" ; body = wrap (E_variable (Var.of_name "y")) } ;
[%expect{| [%expect{|
C(fun y -> (V(y))) fun y -> (y)
|}] ; |}] ;
pp @@ E_closure { binder = Var.of_name "z" ; body = wrap (E_variable (Var.of_name "z")) } ; pp @@ E_closure { binder = Var.of_name "z" ; body = wrap (E_variable (Var.of_name "z")) } ;
[%expect{| [%expect{|
C(fun z -> (V(z))) fun z -> (z)
|}] |}]

18
src/stages/common/PP.ml
View File

@ -11,13 +11,13 @@ let label ppf (l:label) : unit =
let cmap_sep value sep ppf m = let cmap_sep value sep ppf m =
let lst = CMap.to_kv_list m in let lst = CMap.to_kv_list m in
let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" constructor k value v in let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" constructor k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst fprintf ppf "%a" (list_sep new_pp sep) lst
let record_sep value sep ppf (m : 'a label_map) = let record_sep value sep ppf (m : 'a label_map) =
let lst = LMap.to_kv_list m in let lst = LMap.to_kv_list m in
let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in
let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in let new_pp ppf (k, v) = fprintf ppf "@[<h>%a -> %a@]" label k value v in
fprintf ppf "%a" (list_sep new_pp sep) lst fprintf ppf "%a" (list_sep new_pp sep) lst
let tuple_sep value sep ppf m = let tuple_sep value sep ppf m =
@ -30,14 +30,14 @@ let tuple_sep value sep ppf m =
0..(cardinal-1) as tuples *) 0..(cardinal-1) as tuples *)
let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m = let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m =
if Helpers.is_tuple_lmap m then if Helpers.is_tuple_lmap m then
fprintf ppf format_tuple (tuple_sep value (const sep_tuple)) m fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m
else else
fprintf ppf format_record (record_sep value (const sep_record)) m fprintf ppf format_record (record_sep value (tag sep_record)) m
let list_sep_d x = list_sep x (const " , ") let list_sep_d x = list_sep x (tag " ,@ ")
let cmap_sep_d x = cmap_sep x (const " , ") let cmap_sep_d x = cmap_sep x (tag " ,@ ")
let tuple_or_record_sep_expr value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " , " let tuple_or_record_sep_expr value = tuple_or_record_sep value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " ,@ "
let tuple_or_record_sep_type value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " * " let tuple_or_record_sep_type value = tuple_or_record_sep value "@[<hv 7>record[%a]@]" " ,@ " "@[<hv 2>( %a )@]" " *@ "
let constant ppf : constant' -> unit = function let constant ppf : constant' -> unit = function
| C_INT -> fprintf ppf "INT" | C_INT -> fprintf ppf "INT"
@ -206,7 +206,7 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct
-> unit = -> unit =
fun f ppf te -> fun f ppf te ->
match te.type_content with match te.type_content with
| T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m | T_sum m -> fprintf ppf "@[<hv 4>sum[%a]@]" (cmap_sep_d f) m
| T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m | T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m
| T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2
| T_variable tv -> type_variable ppf tv | T_variable tv -> type_variable ppf tv