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

Records in ast_typed for match_variant and declaration_constant

Browse Source
This commit is contained in:
Suzanne Dupéron 2020-03-23 23:52:09 +01:00
parent fcbcea9382
commit 9d25773d61
13 changed files with 216 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
src/passes/10-interpreter/interpreter.ml
View File

@ -341,14 +341,13 @@ and eval : Ast_typed.expression -> env -> value result
let {hd;tl;body;tv=_} = cases.match_cons in
let env' = Env.extend (Env.extend env (hd,head)) (tl, V_List tail) in
eval body env'
| Match_variant (case_list , _) , V_Construct (matched_c , proj) ->
let ((_, var) , body) =
| Match_variant {cases ; tv=_} , V_Construct (matched_c , proj) ->
let {constructor=_ ; pattern ; body} =
List.find
(fun case ->
let (Ast_typed.Constructor c , _) = fst case in
(fun {constructor = (Constructor c) ; pattern=_ ; body=_} ->
String.equal matched_c c)
case_list in
let env' = Env.extend env (var, proj) in
cases in
let env' = Env.extend env (pattern, proj) in
eval body env'
| Match_bool cases , V_Ct (C_bool true) ->
eval cases.match_true env
@ -370,16 +369,16 @@ let dummy : Ast_typed.program -> string result =
fun prg ->
let%bind (res,_) = bind_fold_list
(fun (pp,top_env) el ->
let (Ast_typed.Declaration_constant (exp_name, exp , _ , _)) = Location.unwrap el in
let (Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _}) = Location.unwrap el in
let%bind v =
(*TODO This TRY-CATCH is here until we properly implement effects*)
try
eval exp top_env
eval expr top_env
with Temporary_hack s -> ok @@ V_Failure s
(*TODO This TRY-CATCH is here until we properly implement effects*)
in
let pp' = pp^"\n val "^(Var.to_name exp_name)^" = "^(Ligo_interpreter.PP.pp_value v) in
let top_env' = Env.extend top_env (exp_name, v) in
let pp' = pp^"\n val "^(Var.to_name binder)^" = "^(Ligo_interpreter.PP.pp_value v) in
let top_env' = Env.extend top_env (binder, v) in
ok @@ (pp',top_env')
)
("",Env.empty_env) prg in

37
src/passes/10-transpiler/transpiler.ml
View File

@ -537,10 +537,10 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
in
return @@ E_if_cons (expr' , nil , cons)
)
| Match_variant (lst , variant) -> (
| Match_variant {cases ; tv} -> (
let%bind tree =
trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
tree_of_sum variant in
tree_of_sum tv in
let%bind tree' = match tree with
| Empty -> fail (corner_case ~loc:__LOC__ "match empty variant")
| Full x -> ok x in
@ -560,12 +560,14 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
let rec aux top t =
match t with
| ((`Leaf constructor_name) , tv) -> (
let%bind ((_ , name) , body) =
| ((`Leaf (AST.Constructor constructor_name)) , tv) -> (
let%bind {constructor=_ ; pattern ; body} =
trace_option (corner_case ~loc:__LOC__ "missing match clause") @@
List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
let aux ({constructor = Constructor c ; pattern=_ ; body=_} : AST.matching_content_case) =
(c = constructor_name) in
List.find_opt aux cases in
let%bind body' = transpile_annotated_expression body in
return @@ E_let_in ((name , tv) , false , top , body')
return @@ E_let_in ((pattern , tv) , false , top , body')
)
| ((`Node (a , b)) , tv) ->
let%bind a' =
@ -658,10 +660,10 @@ and transpile_recursive {fun_name; fun_type; lambda} =
in
return @@ E_if_cons (expr , nil , cons)
)
| Match_variant (lst , variant) -> (
| Match_variant {cases;tv} -> (
let%bind tree =
trace_strong (corner_case ~loc:__LOC__ "getting lr tree") @@
tree_of_sum variant in
tree_of_sum tv in
let%bind tree' = match tree with
| Empty -> fail (corner_case ~loc:__LOC__ "match empty variant")
| Full x -> ok x in
@ -680,12 +682,14 @@ and transpile_recursive {fun_name; fun_type; lambda} =
in
let rec aux top t =
match t with
| ((`Leaf constructor_name) , tv) -> (
let%bind ((_ , name) , body) =
| ((`Leaf (AST.Constructor constructor_name)) , tv) -> (
let%bind {constructor=_ ; pattern ; body} =
trace_option (corner_case ~loc:__LOC__ "missing match clause") @@
List.find_opt (fun ((constructor_name' , _) , _) -> constructor_name' = constructor_name) lst in
let aux ({constructor = Constructor c ; pattern=_ ; body=_} : AST.matching_content_case) =
(c = constructor_name) in
List.find_opt aux cases in
let%bind body' = replace_callback fun_name loop_type shadowed body in
return @@ E_let_in ((name , tv) , false , top , body')
return @@ E_let_in ((pattern , tv) , false , top , body')
)
| ((`Node (a , b)) , tv) ->
let%bind a' =
@ -719,12 +723,11 @@ and transpile_recursive {fun_name; fun_type; lambda} =
let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
match d with
| Declaration_constant (name,expression, inline, _) ->
let name = name in
let%bind expression = transpile_annotated_expression expression in
| Declaration_constant { binder ; expr ; inline ; post_env=_ } ->
let%bind expression = transpile_annotated_expression expr in
let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (name, tv) env in
ok @@ ((name, inline, expression), environment_wrap env env')
let env' = Environment.add (binder, tv) env in
ok @@ ((binder, inline, expression), environment_wrap env env')
let transpile_program (lst : AST.program) : program result =
let aux (prev:(toplevel_statement list * Environment.t) result) cur =

19
src/passes/10-transpiler/untranspiler.ml
View File

@ -156,14 +156,13 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
get_map v in
let%bind map' =
let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in
let%bind v' = untranspile v v_ty in
ok (k', v') in
let%bind k = untranspile k k_ty in
let%bind v = untranspile v v_ty in
ok ({k; v} : AST.map_kv) in
bind_map_list aux map in
let map' = List.sort_uniq compare map' in
let aux = fun prev (k, v) ->
let (k', v') = (k , v ) in
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k' ; v' ; prev]}
let aux = fun prev ({ k ; v } : AST.map_kv) ->
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k ; v ; prev]}
in
let%bind init = return @@ E_constant {cons_name=C_MAP_EMPTY;arguments=[]} in
bind_fold_right_list aux init map'
@ -174,12 +173,12 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul
get_big_map v in
let%bind big_map' =
let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in
let%bind v' = untranspile v v_ty in
ok (k', v') in
let%bind k = untranspile k k_ty in
let%bind v = untranspile v v_ty in
ok ({k; v} : AST.map_kv) in
bind_map_list aux big_map in
let big_map' = List.sort_uniq compare big_map' in
let aux = fun prev (k, v) ->
let aux = fun prev ({ k ; v } : AST.map_kv) ->
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k ; v ; prev]}
in
let%bind init = return @@ E_constant {cons_name=C_BIG_MAP_EMPTY;arguments=[]} in

57
src/passes/8-typer-new/typer.ml
View File

@ -455,16 +455,16 @@ let rec type_declaration env state : I.declaration -> (environment * Solver.stat
let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type (type_name) tv env in
ok (env', state , None)
| Declaration_constant (name , tv_opt , inline, expression) -> (
| Declaration_constant (binder , tv_opt , inline, expression) -> (
(*
Determine the type of the expression and add it to the environment
*)
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind (ae' , state') =
trace (constant_declaration_error name expression tv'_opt) @@
let%bind (expr , state') =
trace (constant_declaration_error binder expression tv'_opt) @@
type_expression env state expression in
let env' = Environment.add_ez_ae name ae' env in
ok (env', state' , Some (O.Declaration_constant (name, ae', inline, env') ))
let post_env = Environment.add_ez_ae binder expr env in
ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline ; post_env} ))
)
and type_match : environment -> Solver.state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * Solver.state) result =
@ -495,17 +495,17 @@ and type_match : environment -> Solver.state -> O.type_expression -> I.matching_
let e' = Environment.add_ez_binder tl t e' in
let%bind (body , state'') = type_expression e' state' b in
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body;tv=t}} , state'')
| Match_tuple ((lst, b),_) ->
let%bind t_tuple =
| Match_tuple ((vars, b),_) ->
let%bind tvs =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in
let%bind lst' =
generic_try (match_tuple_wrong_arity t_tuple lst loc)
@@ (fun () -> List.combine lst t_tuple) in
generic_try (match_tuple_wrong_arity tvs vars loc)
@@ (fun () -> List.combine vars tvs) in
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in
let%bind (b' , state') = type_expression e' state b in
ok (O.Match_tuple ((lst, b'), t_tuple) , state')
let%bind (body , state') = type_expression e' state b in
ok (O.Match_tuple {vars ; body ; tvs} , state')
| Match_variant (lst,_) ->
let%bind variant_opt =
let aux acc ((constructor_name , _) , _) =
@ -548,17 +548,18 @@ and type_match : environment -> Solver.state -> O.type_expression -> I.matching_
Assert.assert_true List.(length variant_cases = length match_cases) in
ok ()
in
let%bind (state'' , lst') =
let aux state ((constructor_name , name) , b) =
let%bind (state'' , cases) =
let aux state ((constructor_name , pattern) , b) =
let%bind (constructor , _) =
trace_option (unbound_constructor e constructor_name loc) @@
Environment.get_constructor constructor_name e in
let e' = Environment.add_ez_binder name constructor e in
let%bind (b' , state') = type_expression e' state b in
ok (state' , ((convert_constructor' constructor_name , name) , b'))
let e' = Environment.add_ez_binder pattern constructor e in
let%bind (body , state') = type_expression e' state b in
let constructor = convert_constructor' constructor_name in
ok (state' , ({constructor ; pattern ; body = body} : O.matching_content_case))
in
bind_fold_map_list aux state lst in
ok (O.Match_variant (lst' , variant) , state'')
ok (O.Match_variant {cases ; tv=variant } , state'')
(*
Recursively search the type_expression and return a result containing the
@ -781,6 +782,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
(* Data-structure *)
(* | E_lambda {
* binder ;
* input_type ;
@ -829,7 +831,6 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
let wrapped = Wrap.application f'.type_expression args.type_expression in
return_wrapped (E_application {lamb=f';args}) state'' wrapped
(* Advanced *)
(* | E_matching (ex, m) -> (
* let%bind ex' = type_expression e ex in
@ -884,8 +885,8 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = { hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ]
| Match_option { match_none ; match_some = {opt=_; body; tv=_} } -> [ match_none ; body ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in
| Match_tuple { vars=_ ; body ; tvs=_ } -> [ body ]
| Match_variant { cases ; tv=_ } -> List.map (fun ({constructor=_; pattern=_; body} : O.matching_content_case) -> body) cases in
List.map get_type_expression @@ aux m' in
let%bind () = match tvs with
[] -> fail @@ match_empty_variant cases ae.location
@ -1244,9 +1245,9 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -
let%bind match_true = f match_true in
let%bind match_false = f match_false in
ok @@ Match_bool {match_true ; match_false}
| Match_tuple ((lst, b),_) ->
let%bind b = f b in
ok @@ I.Match_tuple ((lst, b),[])
| Match_tuple { vars ; body ; tvs=_ } ->
let%bind b = f body in
ok @@ I.Match_tuple ((vars, b),[])
| Match_option {match_none ; match_some = {opt; body;tv=_}} ->
let%bind match_none = f match_none in
let%bind some = f body in
@ -1257,9 +1258,9 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -
let%bind cons = f body in
let match_cons = hd , tl , cons, () in
ok @@ Match_list {match_nil ; match_cons}
| Match_variant (lst , _) ->
let aux ((a,b),c) =
let%bind c' = f c in
ok ((unconvert_constructor' a,b),c') in
let%bind lst' = bind_map_list aux lst in
| Match_variant { cases ; tv=_ } ->
let aux ({constructor;pattern;body} : O.matching_content_case) =
let%bind body = f body in
ok ((unconvert_constructor' constructor,pattern),body) in
let%bind lst' = bind_map_list aux cases in
ok @@ Match_variant (lst',())

63
src/passes/8-typer-old/typer.ml
View File

@ -486,13 +486,13 @@ and type_declaration env (_placeholder_for_state_of_new_typer : Solver.state) :
let%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type (type_name) tv env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None)
| Declaration_constant (name , tv_opt , inline, expression) -> (
| Declaration_constant (binder , tv_opt , inline, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind ae' =
trace (constant_declaration_error name expression tv'_opt) @@
let%bind expr =
trace (constant_declaration_error binder expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression in
let env' = Environment.add_ez_ae name ae' env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant (name,ae', inline, env')))
let post_env = Environment.add_ez_ae binder expr env in
ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant { binder ; expr ; inline ; post_env}))
)
and type_match : (environment -> I.expression -> O.expression result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> O.matching_expr result =
@ -523,17 +523,17 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
let e' = Environment.add_ez_binder tl t e' in
let%bind body = f e' b in
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}})
| Match_tuple ((lst, b),_) ->
let%bind t_tuple =
| Match_tuple ((vars, b),_) ->
let%bind tvs =
trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in
let%bind lst' =
generic_try (match_tuple_wrong_arity t_tuple lst loc)
@@ (fun () -> List.combine lst t_tuple) in
let%bind vars' =
generic_try (match_tuple_wrong_arity tvs vars loc)
@@ (fun () -> List.combine vars tvs) in
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in
let%bind b' = f e' b in
ok (O.Match_tuple ((lst, b'),t_tuple))
let e' = List.fold_left aux e vars' in
let%bind body = f e' b in
ok (O.Match_tuple { vars ; body ; tvs})
| Match_variant (lst,_) ->
let%bind variant_opt =
let aux acc ((constructor_name , _) , _) =
@ -556,13 +556,13 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
ok acc in
trace (simple_info "in match variant") @@
bind_fold_list aux None lst in
let%bind variant =
let%bind tv =
trace_option (match_empty_variant i loc) @@
variant_opt in
let%bind () =
let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum variant in
@@ Ast_typed.Combinators.get_t_sum tv in
let variant_cases = List.map fst @@ O.CMap.to_kv_list variant_cases' in
let match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
let test_case = fun c ->
@ -576,17 +576,18 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
Assert.assert_true List.(length variant_cases = length match_cases) in
ok ()
in
let%bind lst' =
let aux ((constructor_name , name) , b) =
let%bind cases =
let aux ((constructor_name , pattern) , b) =
let%bind (constructor , _) =
trace_option (unbound_constructor e constructor_name loc) @@
Environment.get_constructor constructor_name e in
let e' = Environment.add_ez_binder name constructor e in
let%bind b' = f e' b in
ok ((convert_constructor' constructor_name , name) , b')
let e' = Environment.add_ez_binder pattern constructor e in
let%bind body = f e' b in
let constructor = convert_constructor' constructor_name in
ok ({constructor ; pattern ; body} : O.matching_content_case)
in
bind_map_list aux lst in
ok (O.Match_variant (lst' , variant))
ok (O.Match_variant { cases ; tv })
and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
let return tv' = ok (make_t tv' (Some t)) in
@ -921,8 +922,8 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
| Match_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = {hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ]
| Match_option { match_none ; match_some = {opt=_ ; body ; tv=_ } } -> [ match_none ; body ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ]
| Match_variant (lst , _) -> List.map snd lst in
| Match_tuple {vars=_;body;tvs=_} -> [ body ]
| Match_variant {cases; tv=_} -> List.map (fun (c : O.matching_content_case) -> c.body) cases in
List.map get_type_expression @@ aux m' in
let aux prec cur =
let%bind () =
@ -1093,9 +1094,9 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -
let%bind match_true = f match_true in
let%bind match_false = f match_false in
ok @@ Match_bool {match_true ; match_false}
| Match_tuple ((lst, b),_) ->
let%bind b = f b in
ok @@ I.Match_tuple ((lst, b),[])
| Match_tuple {vars; body;tvs=_} ->
let%bind b = f body in
ok @@ I.Match_tuple ((vars, b),[])
| Match_option {match_none ; match_some = {opt; body ; tv=_}} ->
let%bind match_none = f match_none in
let%bind some = f body in
@ -1106,9 +1107,9 @@ and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -
let%bind cons = f body in
let match_cons = hd , tl , cons, () in
ok @@ Match_list {match_nil ; match_cons}
| Match_variant (lst , _) ->
let aux ((a,b),c) =
let%bind c' = f c in
ok ((unconvert_constructor' a,b),c') in
let%bind lst' = bind_map_list aux lst in
| Match_variant {cases;tv=_} ->
let aux ({constructor;pattern;body} : O.matching_content_case) =
let%bind c' = f body in
ok ((unconvert_constructor' constructor,pattern),c') in
let%bind lst' = bind_map_list aux cases in
ok @@ Match_variant (lst',())

86
src/passes/9-self_ast_typed/helpers.ml
View File

@ -3,7 +3,7 @@ open Trace
open Ast_typed.Helpers
type 'a folder = 'a -> expression -> 'a result
let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e ->
let rec fold_expression : 'a . 'a folder -> 'a -> expression -> 'a result = fun f init e ->
let self = fold_expression f in
let%bind init' = f init e in
match e.expression_content with
@ -51,7 +51,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
ok res
)
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
and fold_cases : 'a . 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
match m with
| Match_bool { match_true ; match_false } -> (
let%bind res = fold_expression f init match_true in
@ -68,15 +68,15 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
let%bind res = fold_expression f res body in
ok res
)
| Match_tuple ((_ , e), _) -> (
let%bind res = fold_expression f init e in
| Match_tuple {vars=_ ; body; tvs=_} -> (
let%bind res = fold_expression f init body in
ok res
)
| Match_variant (lst, _) -> (
let aux init' ((_ , _) , e) =
let%bind res' = fold_expression f init' e in
| Match_variant {cases;tv=_} -> (
let aux init' {constructor=_; pattern=_ ; body} =
let%bind res' = fold_expression f init' body in
ok res' in
let%bind res = bind_fold_list aux init lst in
let%bind res = bind_fold_list aux init cases in
ok res
)
@ -150,31 +150,31 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
let%bind body = map_expression f body in
ok @@ Match_option { match_none ; match_some = { opt ; body ; tv } }
)
| Match_tuple ((names , e), te) -> (
let%bind e' = map_expression f e in
ok @@ Match_tuple ((names , e'), te)
| Match_tuple { vars ; body ; tvs } -> (
let%bind body = map_expression f body in
ok @@ Match_tuple { vars ; body ; tvs }
)
| Match_variant (lst, te) -> (
let aux ((a , b) , e) =
let%bind e' = map_expression f e in
ok ((a , b) , e')
| Match_variant {cases;tv} -> (
let aux { constructor ; pattern ; body } =
let%bind body = map_expression f body in
ok {constructor;pattern;body}
in
let%bind lst' = bind_map_list aux lst in
ok @@ Match_variant (lst', te)
let%bind cases = bind_map_list aux cases in
ok @@ Match_variant {cases ; tv}
)
and map_program : mapper -> program -> program result = fun m p ->
let aux = fun (x : declaration) ->
match x with
| Declaration_constant (n , e , i, env) -> (
let%bind e' = map_expression m e in
ok (Declaration_constant (n , e' , i, env))
| Declaration_constant {binder; expr ; inline ; post_env} -> (
let%bind expr = map_expression m expr in
ok (Declaration_constant {binder; expr ; inline ; post_env})
)
in
bind_map_list (bind_map_location aux) p
type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result
let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
let rec fold_map_expression : 'a . 'a fold_mapper -> 'a -> expression -> ('a * expression) result = fun f a e ->
let self = fold_map_expression f in
let%bind (continue, init',e') = f a e in
if (not continue) then ok(init',e')
@ -228,7 +228,7 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
)
| E_literal _ | E_variable _ as e' -> ok (init', return e')
and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m ->
match m with
| Match_bool { match_true ; match_false } -> (
let%bind (init, match_true) = fold_map_expression f init match_true in
@ -245,25 +245,25 @@ and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_exp
let%bind (init, body) = fold_map_expression f init body in
ok @@ (init, Match_option { match_none ; match_some = { opt ; body ; tv } })
)
| Match_tuple ((names , e), te) -> (
let%bind (init, e') = fold_map_expression f init e in
ok @@ (init, Match_tuple ((names , e'), te))
| Match_tuple { vars ; body ; tvs } -> (
let%bind (init, body) = fold_map_expression f init body in
ok @@ (init, Match_tuple {vars ; body ; tvs })
)
| Match_variant (lst, te) -> (
let aux init ((a , b) , e) =
let%bind (init,e') = fold_map_expression f init e in
ok (init, ((a , b) , e'))
| Match_variant {cases ; tv} -> (
let aux init {constructor ; pattern ; body} =
let%bind (init, body) = fold_map_expression f init body in
ok (init, {constructor; pattern ; body})
in
let%bind (init,lst') = bind_fold_map_list aux init lst in
ok @@ (init, Match_variant (lst', te))
let%bind (init,cases) = bind_fold_map_list aux init cases in
ok @@ (init, Match_variant {cases ; tv})
)
and fold_map_program : 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p ->
and fold_map_program : 'a . 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p ->
let aux = fun (acc,acc_prg) (x : declaration Location.wrap) ->
match Location.unwrap x with
| Declaration_constant (v , e , i, env) -> (
let%bind (acc',e') = fold_map_expression m acc e in
let wrap_content = Declaration_constant (v , e' , i, env) in
| Declaration_constant {binder ; expr ; inline ; post_env} -> (
let%bind (acc', expr) = fold_map_expression m acc expr in
let wrap_content = Declaration_constant {binder ; expr ; inline ; post_env} in
ok (acc', List.append acc_prg [{x with wrap_content}])
)
in
@ -315,28 +315,28 @@ type contract_type = {
let fetch_contract_type : string -> program -> contract_type result = fun main_fname program ->
let main_decl = List.rev @@ List.filter
(fun declt ->
let (Declaration_constant (v , _ , _ , _)) = Location.unwrap declt in
String.equal (Var.to_name v) main_fname
let (Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ }) = Location.unwrap declt in
String.equal (Var.to_name binder) main_fname
)
program
in
match main_decl with
| (hd::_) -> (
let (Declaration_constant (_,e,_,_)) = Location.unwrap hd in
match e.type_expression.type_content with
let (Declaration_constant { binder=_ ; expr ; inline=_ ; post_env=_ }) = Location.unwrap hd in
match expr.type_expression.type_content with
| T_arrow {type1 ; type2} -> (
match type1.type_content , type2.type_content with
| T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) ->
let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in
let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in
let%bind () = trace_strong (Errors.expected_list_operation main_fname listop e) @@
let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@
Ast_typed.assert_t_list_operation listop in
let%bind () = trace_strong (Errors.expected_same main_fname storage storage' e) @@
let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@
Ast_typed.assert_type_expression_eq (storage,storage') in
(* TODO: on storage/parameter : assert_storable, assert_passable ? *)
ok { parameter ; storage }
| _ -> fail @@ Errors.bad_contract_io main_fname e
| _ -> fail @@ Errors.bad_contract_io main_fname expr
)
| _ -> fail @@ Errors.bad_contract_io main_fname e
| _ -> fail @@ Errors.bad_contract_io main_fname expr
)
| [] -> simple_fail ("Entrypoint '"^main_fname^"' does not exist")

12
src/passes/9-self_ast_typed/tail_recursion.ml
View File

@ -71,15 +71,15 @@ and check_recursive_call_in_matching = fun n final_path c ->
let%bind _ = check_recursive_call n final_path match_none in
let%bind _ = check_recursive_call n final_path body in
ok ()
| Match_tuple ((_,e),_) ->
let%bind _ = check_recursive_call n final_path e in
| Match_tuple {vars=_;body;tvs=_} ->
let%bind _ = check_recursive_call n final_path body in
ok ()
| Match_variant (l,_) ->
let aux (_,e) =
let%bind _ = check_recursive_call n final_path e in
| Match_variant {cases;tv=_} ->
let aux {constructor=_; pattern=_; body} =
let%bind _ = check_recursive_call n final_path body in
ok ()
in
let%bind _ = bind_map_list aux l in
let%bind _ = bind_map_list aux cases in
ok ()

22
src/stages/4-ast_typed/PP.ml
View File

@ -281,8 +281,8 @@ and expression_content ppf (ec: expression_content) =
type_expression fun_type
expression_content (E_lambda lambda)
and assoc_expression ppf : expr * expr -> unit =
fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b
and assoc_expression ppf : map_kv -> unit =
fun {k ; v} -> fprintf ppf "%a -> %a" expression k expression v
and single_record_patch ppf ((p, expr) : label * expr) =
fprintf ppf "%a <- %a" label p expression expr
@ -294,15 +294,15 @@ and option_inline ppf inline =
else
fprintf ppf ""
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit =
fun f ppf ((c,n),a) ->
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a
and matching_variant_case : (_ -> expression -> unit) -> _ -> matching_content_case -> unit =
fun f ppf {constructor=c; pattern; body} ->
fprintf ppf "| %a %a -> %a" constructor c expression_variable pattern f body
and matching : (formatter -> expression -> unit) -> _ -> matching_content -> unit = fun f ppf m -> match m with
| Match_tuple ((lst, b),_) ->
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst
| Match_tuple {vars; body; tvs=_} ->
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) vars f body
| Match_variant {cases ; tv=_} ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) cases
| Match_bool {match_true ; match_false} ->
fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false
| Match_list {match_nil ; match_cons = {hd; tl; body; tv=_}} ->
@ -312,8 +312,8 @@ and matching : (formatter -> expression -> unit) -> _ -> matching_content -> uni
let declaration ppf (d : declaration) =
match d with
| Declaration_constant (name, expr, inline,_) ->
fprintf ppf "const %a = %a%a" expression_variable name expression expr option_inline inline
| Declaration_constant {binder; expr; inline; post_env=_} ->
fprintf ppf "const %a = %a%a" expression_variable binder expression expr option_inline inline
let program ppf (p : program) =
fprintf ppf "@[<v>%a@]"

2
src/stages/4-ast_typed/combinators.ml
View File

@ -341,7 +341,7 @@ let get_a_record_accessor = fun t ->
let get_declaration_by_name : program -> string -> declaration result = fun p name ->
let aux : declaration -> bool = fun declaration ->
match declaration with
| Declaration_constant (d, _, _, _) -> d = Var.of_name name
| Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ } -> binder = Var.of_name name
in
trace_option (Errors.declaration_not_found name ()) @@
List.find_opt aux @@ List.map Location.unwrap p

16
src/stages/4-ast_typed/misc.ml
View File

@ -229,17 +229,17 @@ module Free_variables = struct
and expression : bindings -> expression -> bindings = fun b e ->
expression_content b e.expression_content
and matching_variant_case : type a . (bindings -> a -> bindings) -> bindings -> ((constructor' * expression_variable) * a) -> bindings = fun f b ((_,n),c) ->
f (union (singleton n) b) c
and matching_variant_case : (bindings -> expression -> bindings) -> bindings -> matching_content_case -> bindings = fun f b { constructor=_ ; pattern ; body } ->
f (union (singleton pattern) b) body
and matching : (bindings -> expression -> bindings) -> bindings -> matching_content -> bindings = fun f b m ->
match m with
| Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa)
| Match_list { match_nil = n ; match_cons = {hd; tl; body; tv=_} } -> union (f b n) (f (union (of_list [hd ; tl]) b) body)
| Match_option { match_none = n ; match_some = {opt; body; tv=_} } -> union (f b n) (f (union (singleton opt) b) body)
| Match_tuple ((lst , a), _) ->
f (union (of_list lst) b) a
| Match_variant (lst,_) -> unions @@ List.map (matching_variant_case f b) lst
| Match_tuple { vars ; body ; tvs=_ } ->
f (union (of_list vars) b) body
| Match_variant { cases ; tv=_ } -> unions @@ List.map (matching_variant_case f b) cases
and matching_expression = fun x -> matching expression x
@ -517,8 +517,8 @@ let merge_annotation (a:type_expression option) (b:type_expression option) err :
let get_entry (lst : program) (name : string) : expression result =
trace_option (Errors.missing_entry_point name) @@
let aux x =
let (Declaration_constant (an , expr, _, _)) = Location.unwrap x in
if (an = Var.of_name name)
let (Declaration_constant { binder ; expr ; inline=_ ; _ }) = Location.unwrap x in
if Var.equal binder (Var.of_name name)
then Some expr
else None
in
@ -527,4 +527,4 @@ let get_entry (lst : program) (name : string) : expression result =
let program_environment (program : program) : full_environment =
let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with
| Declaration_constant (_ , _, _, post_env) -> post_env
| Declaration_constant { binder=_ ; expr=_ ; inline=_ ; post_env } -> post_env

16
src/stages/4-ast_typed/misc_smart.ml
View File

@ -8,7 +8,7 @@ let program_to_main : program -> string -> lambda result = fun p s ->
let%bind (main , input_type , _) =
let pred = fun d ->
match d with
| Declaration_constant (d , expr, _, _) when d = Var.of_name s -> Some expr
| Declaration_constant { binder; expr; inline=_ ; post_env=_ } when binder = Var.of_name s -> Some expr
| Declaration_constant _ -> None
in
let%bind main =
@ -23,7 +23,7 @@ let program_to_main : program -> string -> lambda result = fun p s ->
let env =
let aux = fun _ d ->
match d with
| Declaration_constant (_ , _, _, post_env) -> post_env in
| Declaration_constant {binder=_ ; expr= _ ; inline=_ ; post_env } -> post_env in
List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
let binder = Var.of_name "@contract_input" in
let result =
@ -86,8 +86,8 @@ module Captured_variables = struct
let b' = union (singleton r.fun_name) b in
expression_content b' env @@ E_lambda r.lambda
and matching_variant_case : type a . (bindings -> a -> bindings result) -> bindings -> ((constructor' * expression_variable) * a) -> bindings result = fun f b ((_,n),c) ->
f (union (singleton n) b) c
and matching_variant_case : (bindings -> expression -> bindings result) -> bindings -> matching_content_case -> bindings result = fun f b { constructor=_ ; pattern ; body } ->
f (union (singleton pattern) b) body
and matching : (bindings -> expression -> bindings result) -> bindings -> matching_content -> bindings result = fun f b m ->
match m with
@ -103,10 +103,10 @@ module Captured_variables = struct
let%bind n' = f b n in
let%bind s' = f (union (singleton opt) b) body in
ok @@ union n' s'
| Match_tuple ((lst , a),_) ->
f (union (of_list lst) b) a
| Match_variant (lst , _) ->
let%bind lst' = bind_map_list (matching_variant_case f b) lst in
| Match_tuple { vars ; body ; tvs=_ } ->
f (union (of_list vars) b) body
| Match_variant { cases ; tv=_ } ->
let%bind lst' = bind_map_list (matching_variant_case f b) cases in
ok @@ unions lst'
and matching_expression = fun x -> matching expression x

36
src/stages/4-ast_typed/types.ml
View File

@ -104,9 +104,21 @@ and matching_content_option = {
match_some : matching_content_some ;
}
and matching_content_tuple = (expression_variable list * expression) * type_expression list
and matching_content_tuple = {
vars : expression_variable list ;
body : expression ;
tvs : type_expression list ;
}
and matching_content_variant = ((constructor' * expression_variable) * expression) list * type_expression
and matching_content_case = {
constructor : constructor' ;
pattern : expression_variable ;
body : expression ;
}
and matching_content_variant = {
cases: matching_content_case list;
tv: type_expression;
}
and matching_content =
| Match_bool of matching_content_bool
@ -234,13 +246,20 @@ and program = declaration Location.wrap list
and inline = bool
and declaration_constant = {
binder : expression_variable ;
expr : expression ;
inline : inline ;
post_env : full_environment ;
}
and declaration =
(* A Declaration_constant is described by
* a name + a type-annotated expression
* a boolean indicating whether it should be inlined
* the environment before the declaration (the original environment)
* the environment after the declaration (i.e. with that new declaration added to the original environment). *)
| Declaration_constant of (expression_variable * expression * inline * full_environment)
| Declaration_constant of declaration_constant
(*
| Declaration_type of (type_variable * type_expression)
| Declaration_constant of (named_expression * (full_environment * full_environment))
@ -254,6 +273,17 @@ and expression = {
environment: full_environment ;
}
and map_kv = {
k : expression ;
v : expression ;
}
and look_up = {
ds : expression;
ind : expression;
}
and expression_content =
(* Base *)
| E_literal of literal

10
src/stages/typesystem/misc.ml
View File

@ -204,11 +204,11 @@ module Substitution = struct
and s_declaration : T.declaration w = fun ~substs ->
function
Ast_typed.Declaration_constant (ev,e,i,env) ->
let%bind ev = s_variable ~substs ev in
let%bind e = s_expression ~substs e in
let%bind env = s_full_environment ~substs env in
ok @@ Ast_typed.Declaration_constant (ev, e, i, env)
Ast_typed.Declaration_constant {binder ; expr ; inline ; post_env} ->
let%bind binder = s_variable ~substs binder in
let%bind expr = s_expression ~substs expr in
let%bind post_env = s_full_environment ~substs post_env in
ok @@ Ast_typed.Declaration_constant {binder; expr; inline; post_env}
and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d ->
Trace.bind_map_location (s_declaration ~substs) d