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 {hd;tl;body;tv=_} = cases.match_cons in
let env' = Env.extend (Env.extend env (hd,head)) (tl, V_List tail) in let env' = Env.extend (Env.extend env (hd,head)) (tl, V_List tail) in
eval body env' eval body env'
| Match_variant (case_list , _) , V_Construct (matched_c , proj) -> | Match_variant {cases ; tv=_} , V_Construct (matched_c , proj) ->
let ((_, var) , body) = let {constructor=_ ; pattern ; body} =
List.find List.find
(fun case -> (fun {constructor = (Constructor c) ; pattern=_ ; body=_} ->
let (Ast_typed.Constructor c , _) = fst case in
String.equal matched_c c) String.equal matched_c c)
case_list in cases in
let env' = Env.extend env (var, proj) in let env' = Env.extend env (pattern, proj) in
eval body env' eval body env'
| Match_bool cases , V_Ct (C_bool true) -> | Match_bool cases , V_Ct (C_bool true) ->
eval cases.match_true env eval cases.match_true env
@ -370,16 +369,16 @@ let dummy : Ast_typed.program -> string result =
fun prg -> fun prg ->
let%bind (res,_) = bind_fold_list let%bind (res,_) = bind_fold_list
(fun (pp,top_env) el -> (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 = let%bind v =
(*TODO This TRY-CATCH is here until we properly implement effects*) (*TODO This TRY-CATCH is here until we properly implement effects*)
try try
eval exp top_env eval expr top_env
with Temporary_hack s -> ok @@ V_Failure s with Temporary_hack s -> ok @@ V_Failure s
(*TODO This TRY-CATCH is here until we properly implement effects*) (*TODO This TRY-CATCH is here until we properly implement effects*)
in in
let pp' = pp^"\n val "^(Var.to_name exp_name)^" = "^(Ligo_interpreter.PP.pp_value 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 (exp_name, v) in let top_env' = Env.extend top_env (binder, v) in
ok @@ (pp',top_env') ok @@ (pp',top_env')
) )
("",Env.empty_env) prg in ("",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 in
return @@ E_if_cons (expr' , nil , cons) return @@ E_if_cons (expr' , nil , cons)
) )
| Match_variant (lst , variant) -> ( | Match_variant {cases ; tv} -> (
let%bind tree = let%bind tree =
trace_strong (corner_case ~loc:__LOC__ "getting lr 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 let%bind tree' = match tree with
| Empty -> fail (corner_case ~loc:__LOC__ "match empty variant") | Empty -> fail (corner_case ~loc:__LOC__ "match empty variant")
| Full x -> ok x in | Full x -> ok x in
@ -560,12 +560,14 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
let rec aux top t = let rec aux top t =
match t with match t with
| ((`Leaf constructor_name) , tv) -> ( | ((`Leaf (AST.Constructor constructor_name)) , tv) -> (
let%bind ((_ , name) , body) = let%bind {constructor=_ ; pattern ; body} =
trace_option (corner_case ~loc:__LOC__ "missing match clause") @@ 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 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) -> | ((`Node (a , b)) , tv) ->
let%bind a' = let%bind a' =
@ -658,10 +660,10 @@ and transpile_recursive {fun_name; fun_type; lambda} =
in in
return @@ E_if_cons (expr , nil , cons) return @@ E_if_cons (expr , nil , cons)
) )
| Match_variant (lst , variant) -> ( | Match_variant {cases;tv} -> (
let%bind tree = let%bind tree =
trace_strong (corner_case ~loc:__LOC__ "getting lr 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 let%bind tree' = match tree with
| Empty -> fail (corner_case ~loc:__LOC__ "match empty variant") | Empty -> fail (corner_case ~loc:__LOC__ "match empty variant")
| Full x -> ok x in | Full x -> ok x in
@ -680,12 +682,14 @@ and transpile_recursive {fun_name; fun_type; lambda} =
in in
let rec aux top t = let rec aux top t =
match t with match t with
| ((`Leaf constructor_name) , tv) -> ( | ((`Leaf (AST.Constructor constructor_name)) , tv) -> (
let%bind ((_ , name) , body) = let%bind {constructor=_ ; pattern ; body} =
trace_option (corner_case ~loc:__LOC__ "missing match clause") @@ 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 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) -> | ((`Node (a , b)) , tv) ->
let%bind a' = 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 = let transpile_declaration env (d:AST.declaration) : toplevel_statement result =
match d with match d with
| Declaration_constant (name,expression, inline, _) -> | Declaration_constant { binder ; expr ; inline ; post_env=_ } ->
let name = name in let%bind expression = transpile_annotated_expression expr in
let%bind expression = transpile_annotated_expression expression in
let tv = Combinators.Expression.get_type expression in let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (name, tv) env in let env' = Environment.add (binder, tv) env in
ok @@ ((name, inline, expression), environment_wrap env env') ok @@ ((binder, inline, expression), environment_wrap env env')
let transpile_program (lst : AST.program) : program result = let transpile_program (lst : AST.program) : program result =
let aux (prev:(toplevel_statement list * Environment.t) result) cur = 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 get_map v in
let%bind map' = let%bind map' =
let aux = fun (k, v) -> let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in let%bind k = untranspile k k_ty in
let%bind v' = untranspile v v_ty in let%bind v = untranspile v v_ty in
ok (k', v') in ok ({k; v} : AST.map_kv) in
bind_map_list aux map in bind_map_list aux map in
let map' = List.sort_uniq compare map' in let map' = List.sort_uniq compare map' in
let aux = fun prev (k, v) -> let aux = fun prev ({ k ; v } : AST.map_kv) ->
let (k', v') = (k , v ) in return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k ; v ; prev]}
return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k' ; v' ; prev]}
in in
let%bind init = return @@ E_constant {cons_name=C_MAP_EMPTY;arguments=[]} in let%bind init = return @@ E_constant {cons_name=C_MAP_EMPTY;arguments=[]} in
bind_fold_right_list aux init map' 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 get_big_map v in
let%bind big_map' = let%bind big_map' =
let aux = fun (k, v) -> let aux = fun (k, v) ->
let%bind k' = untranspile k k_ty in let%bind k = untranspile k k_ty in
let%bind v' = untranspile v v_ty in let%bind v = untranspile v v_ty in
ok (k', v') in ok ({k; v} : AST.map_kv) in
bind_map_list aux big_map in bind_map_list aux big_map in
let big_map' = List.sort_uniq compare 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]} return @@ E_constant {cons_name=C_MAP_ADD;arguments=[k ; v ; prev]}
in in
let%bind init = return @@ E_constant {cons_name=C_BIG_MAP_EMPTY;arguments=[]} 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%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type (type_name) tv env in let env' = Environment.add_type (type_name) tv env in
ok (env', state , None) 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 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 tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind (ae' , state') = let%bind (expr , state') =
trace (constant_declaration_error name expression tv'_opt) @@ trace (constant_declaration_error binder expression tv'_opt) @@
type_expression env state expression in type_expression env state expression in
let env' = Environment.add_ez_ae name ae' env in let post_env = Environment.add_ez_ae binder expr env in
ok (env', state' , Some (O.Declaration_constant (name, ae', inline, env') )) 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 = 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 e' = Environment.add_ez_binder tl t e' in
let%bind (body , state'') = type_expression e' state' b 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'') ok (O.Match_list {match_nil ; match_cons = {hd; tl; body;tv=t}} , state'')
| Match_tuple ((lst, b),_) -> | Match_tuple ((vars, b),_) ->
let%bind t_tuple = let%bind tvs =
trace_strong (match_error ~expected:i ~actual:t loc) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in @@ get_t_tuple t in
let%bind lst' = let%bind lst' =
generic_try (match_tuple_wrong_arity t_tuple lst loc) generic_try (match_tuple_wrong_arity tvs vars loc)
@@ (fun () -> List.combine lst t_tuple) in @@ (fun () -> List.combine vars tvs) in
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in let e' = List.fold_left aux e lst' in
let%bind (b' , state') = type_expression e' state b in let%bind (body , state') = type_expression e' state b in
ok (O.Match_tuple ((lst, b'), t_tuple) , state') ok (O.Match_tuple {vars ; body ; tvs} , state')
| Match_variant (lst,_) -> | Match_variant (lst,_) ->
let%bind variant_opt = let%bind variant_opt =
let aux acc ((constructor_name , _) , _) = 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 Assert.assert_true List.(length variant_cases = length match_cases) in
ok () ok ()
in in
let%bind (state'' , lst') = let%bind (state'' , cases) =
let aux state ((constructor_name , name) , b) = let aux state ((constructor_name , pattern) , b) =
let%bind (constructor , _) = let%bind (constructor , _) =
trace_option (unbound_constructor e constructor_name loc) @@ trace_option (unbound_constructor e constructor_name loc) @@
Environment.get_constructor constructor_name e in Environment.get_constructor constructor_name e in
let e' = Environment.add_ez_binder name constructor e in let e' = Environment.add_ez_binder pattern constructor e in
let%bind (b' , state') = type_expression e' state b in let%bind (body , state') = type_expression e' state b in
ok (state' , ((convert_constructor' constructor_name , name) , b')) let constructor = convert_constructor' constructor_name in
ok (state' , ({constructor ; pattern ; body = body} : O.matching_content_case))
in in
bind_fold_map_list aux state lst 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 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) return_wrapped (E_record_update {record; path; update}) state (Wrap.record wrapped)
(* Data-structure *) (* Data-structure *)
(* | E_lambda { (* | E_lambda {
* binder ; * binder ;
* input_type ; * 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 let wrapped = Wrap.application f'.type_expression args.type_expression in
return_wrapped (E_application {lamb=f';args}) state'' wrapped return_wrapped (E_application {lamb=f';args}) state'' wrapped
(* Advanced *) (* Advanced *)
(* | E_matching (ex, m) -> ( (* | E_matching (ex, m) -> (
* let%bind ex' = type_expression e ex in * 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_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = { hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ] | 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_option { match_none ; match_some = {opt=_; body; tv=_} } -> [ match_none ; body ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ] | Match_tuple { vars=_ ; body ; tvs=_ } -> [ body ]
| Match_variant (lst , _) -> List.map snd lst in | 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 List.map get_type_expression @@ aux m' in
let%bind () = match tvs with let%bind () = match tvs with
[] -> fail @@ match_empty_variant cases ae.location [] -> 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_true = f match_true in
let%bind match_false = f match_false in let%bind match_false = f match_false in
ok @@ Match_bool {match_true ; match_false} ok @@ Match_bool {match_true ; match_false}
| Match_tuple ((lst, b),_) -> | Match_tuple { vars ; body ; tvs=_ } ->
let%bind b = f b in let%bind b = f body in
ok @@ I.Match_tuple ((lst, b),[]) ok @@ I.Match_tuple ((vars, b),[])
| Match_option {match_none ; match_some = {opt; body;tv=_}} -> | Match_option {match_none ; match_some = {opt; body;tv=_}} ->
let%bind match_none = f match_none in let%bind match_none = f match_none in
let%bind some = f body 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%bind cons = f body in
let match_cons = hd , tl , cons, () in let match_cons = hd , tl , cons, () in
ok @@ Match_list {match_nil ; match_cons} ok @@ Match_list {match_nil ; match_cons}
| Match_variant (lst , _) -> | Match_variant { cases ; tv=_ } ->
let aux ((a,b),c) = let aux ({constructor;pattern;body} : O.matching_content_case) =
let%bind c' = f c in let%bind body = f body in
ok ((unconvert_constructor' a,b),c') in ok ((unconvert_constructor' constructor,pattern),body) in
let%bind lst' = bind_map_list aux lst in let%bind lst' = bind_map_list aux cases in
ok @@ Match_variant (lst',()) 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%bind tv = evaluate_type env type_expression in
let env' = Environment.add_type (type_name) tv env in let env' = Environment.add_type (type_name) tv env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None) 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 tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind ae' = let%bind expr =
trace (constant_declaration_error name expression tv'_opt) @@ trace (constant_declaration_error binder expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression in type_expression' ?tv_opt:tv'_opt env expression in
let env' = Environment.add_ez_ae name ae' env in let post_env = Environment.add_ez_ae binder expr env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant (name,ae', inline, env'))) 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 = 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 e' = Environment.add_ez_binder tl t e' in
let%bind body = f e' b in let%bind body = f e' b in
ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}}) ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}})
| Match_tuple ((lst, b),_) -> | Match_tuple ((vars, b),_) ->
let%bind t_tuple = let%bind tvs =
trace_strong (match_error ~expected:i ~actual:t loc) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in @@ get_t_tuple t in
let%bind lst' = let%bind vars' =
generic_try (match_tuple_wrong_arity t_tuple lst loc) generic_try (match_tuple_wrong_arity tvs vars loc)
@@ (fun () -> List.combine lst t_tuple) in @@ (fun () -> List.combine vars tvs) in
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in let e' = List.fold_left aux e vars' in
let%bind b' = f e' b in let%bind body = f e' b in
ok (O.Match_tuple ((lst, b'),t_tuple)) ok (O.Match_tuple { vars ; body ; tvs})
| Match_variant (lst,_) -> | Match_variant (lst,_) ->
let%bind variant_opt = let%bind variant_opt =
let aux acc ((constructor_name , _) , _) = let aux acc ((constructor_name , _) , _) =
@ -556,13 +556,13 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
ok acc in ok acc in
trace (simple_info "in match variant") @@ trace (simple_info "in match variant") @@
bind_fold_list aux None lst in bind_fold_list aux None lst in
let%bind variant = let%bind tv =
trace_option (match_empty_variant i loc) @@ trace_option (match_empty_variant i loc) @@
variant_opt in variant_opt in
let%bind () = let%bind () =
let%bind variant_cases' = let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc) 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 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 match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
let test_case = fun c -> 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 Assert.assert_true List.(length variant_cases = length match_cases) in
ok () ok ()
in in
let%bind lst' = let%bind cases =
let aux ((constructor_name , name) , b) = let aux ((constructor_name , pattern) , b) =
let%bind (constructor , _) = let%bind (constructor , _) =
trace_option (unbound_constructor e constructor_name loc) @@ trace_option (unbound_constructor e constructor_name loc) @@
Environment.get_constructor constructor_name e in Environment.get_constructor constructor_name e in
let e' = Environment.add_ez_binder name constructor e in let e' = Environment.add_ez_binder pattern constructor e in
let%bind b' = f e' b in let%bind body = f e' b in
ok ((convert_constructor' constructor_name , name) , b') let constructor = convert_constructor' constructor_name in
ok ({constructor ; pattern ; body} : O.matching_content_case)
in in
bind_map_list aux lst 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 = and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
let return tv' = ok (make_t tv' (Some t)) in 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_bool { match_true ; match_false } -> [ match_true ; match_false ]
| Match_list { match_nil ; match_cons = {hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ] | 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_option { match_none ; match_some = {opt=_ ; body ; tv=_ } } -> [ match_none ; body ]
| Match_tuple ((_ , match_tuple), _) -> [ match_tuple ] | Match_tuple {vars=_;body;tvs=_} -> [ body ]
| Match_variant (lst , _) -> List.map snd lst in | Match_variant {cases; tv=_} -> List.map (fun (c : O.matching_content_case) -> c.body) cases in
List.map get_type_expression @@ aux m' in List.map get_type_expression @@ aux m' in
let aux prec cur = let aux prec cur =
let%bind () = 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_true = f match_true in
let%bind match_false = f match_false in let%bind match_false = f match_false in
ok @@ Match_bool {match_true ; match_false} ok @@ Match_bool {match_true ; match_false}
| Match_tuple ((lst, b),_) -> | Match_tuple {vars; body;tvs=_} ->
let%bind b = f b in let%bind b = f body in
ok @@ I.Match_tuple ((lst, b),[]) ok @@ I.Match_tuple ((vars, b),[])
| Match_option {match_none ; match_some = {opt; body ; tv=_}} -> | Match_option {match_none ; match_some = {opt; body ; tv=_}} ->
let%bind match_none = f match_none in let%bind match_none = f match_none in
let%bind some = f body 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%bind cons = f body in
let match_cons = hd , tl , cons, () in let match_cons = hd , tl , cons, () in
ok @@ Match_list {match_nil ; match_cons} ok @@ Match_list {match_nil ; match_cons}
| Match_variant (lst , _) -> | Match_variant {cases;tv=_} ->
let aux ((a,b),c) = let aux ({constructor;pattern;body} : O.matching_content_case) =
let%bind c' = f c in let%bind c' = f body in
ok ((unconvert_constructor' a,b),c') in ok ((unconvert_constructor' constructor,pattern),c') in
let%bind lst' = bind_map_list aux lst in let%bind lst' = bind_map_list aux cases in
ok @@ Match_variant (lst',()) 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 open Ast_typed.Helpers
type 'a folder = 'a -> expression -> 'a result 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 self = fold_expression f in
let%bind init' = f init e in let%bind init' = f init e in
match e.expression_content with match e.expression_content with
@ -51,7 +51,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
ok res 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 m with
| Match_bool { match_true ; match_false } -> ( | Match_bool { match_true ; match_false } -> (
let%bind res = fold_expression f init match_true in 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 let%bind res = fold_expression f res body in
ok res ok res
) )
| Match_tuple ((_ , e), _) -> ( | Match_tuple {vars=_ ; body; tvs=_} -> (
let%bind res = fold_expression f init e in let%bind res = fold_expression f init body in
ok res ok res
) )
| Match_variant (lst, _) -> ( | Match_variant {cases;tv=_} -> (
let aux init' ((_ , _) , e) = let aux init' {constructor=_; pattern=_ ; body} =
let%bind res' = fold_expression f init' e in let%bind res' = fold_expression f init' body in
ok res' 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 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 let%bind body = map_expression f body in
ok @@ Match_option { match_none ; match_some = { opt ; body ; tv } } ok @@ Match_option { match_none ; match_some = { opt ; body ; tv } }
) )
| Match_tuple ((names , e), te) -> ( | Match_tuple { vars ; body ; tvs } -> (
let%bind e' = map_expression f e in let%bind body = map_expression f body in
ok @@ Match_tuple ((names , e'), te) ok @@ Match_tuple { vars ; body ; tvs }
) )
| Match_variant (lst, te) -> ( | Match_variant {cases;tv} -> (
let aux ((a , b) , e) = let aux { constructor ; pattern ; body } =
let%bind e' = map_expression f e in let%bind body = map_expression f body in
ok ((a , b) , e') ok {constructor;pattern;body}
in in
let%bind lst' = bind_map_list aux lst in let%bind cases = bind_map_list aux cases in
ok @@ Match_variant (lst', te) ok @@ Match_variant {cases ; tv}
) )
and map_program : mapper -> program -> program result = fun m p -> and map_program : mapper -> program -> program result = fun m p ->
let aux = fun (x : declaration) -> let aux = fun (x : declaration) ->
match x with match x with
| Declaration_constant (n , e , i, env) -> ( | Declaration_constant {binder; expr ; inline ; post_env} -> (
let%bind e' = map_expression m e in let%bind expr = map_expression m expr in
ok (Declaration_constant (n , e' , i, env)) ok (Declaration_constant {binder; expr ; inline ; post_env})
) )
in in
bind_map_list (bind_map_location aux) p bind_map_list (bind_map_location aux) p
type 'a fold_mapper = 'a -> expression -> (bool * 'a * expression) result 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 self = fold_map_expression f in
let%bind (continue, init',e') = f a e in let%bind (continue, init',e') = f a e in
if (not continue) then ok(init',e') 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') | 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 m with
| Match_bool { match_true ; match_false } -> ( | Match_bool { match_true ; match_false } -> (
let%bind (init, match_true) = fold_map_expression f init match_true in 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 let%bind (init, body) = fold_map_expression f init body in
ok @@ (init, Match_option { match_none ; match_some = { opt ; body ; tv } }) ok @@ (init, Match_option { match_none ; match_some = { opt ; body ; tv } })
) )
| Match_tuple ((names , e), te) -> ( | Match_tuple { vars ; body ; tvs } -> (
let%bind (init, e') = fold_map_expression f init e in let%bind (init, body) = fold_map_expression f init body in
ok @@ (init, Match_tuple ((names , e'), te)) ok @@ (init, Match_tuple {vars ; body ; tvs })
) )
| Match_variant (lst, te) -> ( | Match_variant {cases ; tv} -> (
let aux init ((a , b) , e) = let aux init {constructor ; pattern ; body} =
let%bind (init,e') = fold_map_expression f init e in let%bind (init, body) = fold_map_expression f init body in
ok (init, ((a , b) , e')) ok (init, {constructor; pattern ; body})
in in
let%bind (init,lst') = bind_fold_map_list aux init lst in let%bind (init,cases) = bind_fold_map_list aux init cases in
ok @@ (init, Match_variant (lst', te)) 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) -> let aux = fun (acc,acc_prg) (x : declaration Location.wrap) ->
match Location.unwrap x with match Location.unwrap x with
| Declaration_constant (v , e , i, env) -> ( | Declaration_constant {binder ; expr ; inline ; post_env} -> (
let%bind (acc',e') = fold_map_expression m acc e in let%bind (acc', expr) = fold_map_expression m acc expr in
let wrap_content = Declaration_constant (v , e' , i, env) in let wrap_content = Declaration_constant {binder ; expr ; inline ; post_env} in
ok (acc', List.append acc_prg [{x with wrap_content}]) ok (acc', List.append acc_prg [{x with wrap_content}])
) )
in in
@ -315,28 +315,28 @@ type contract_type = {
let fetch_contract_type : string -> program -> contract_type result = fun main_fname program -> let fetch_contract_type : string -> program -> contract_type result = fun main_fname program ->
let main_decl = List.rev @@ List.filter let main_decl = List.rev @@ List.filter
(fun declt -> (fun declt ->
let (Declaration_constant (v , _ , _ , _)) = Location.unwrap declt in let (Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ }) = Location.unwrap declt in
String.equal (Var.to_name v) main_fname String.equal (Var.to_name binder) main_fname
) )
program program
in in
match main_decl with match main_decl with
| (hd::_) -> ( | (hd::_) -> (
let (Declaration_constant (_,e,_,_)) = Location.unwrap hd in let (Declaration_constant { binder=_ ; expr ; inline=_ ; post_env=_ }) = Location.unwrap hd in
match e.type_expression.type_content with match expr.type_expression.type_content with
| T_arrow {type1 ; type2} -> ( | T_arrow {type1 ; type2} -> (
match type1.type_content , type2.type_content with match type1.type_content , type2.type_content with
| T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) -> | 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 (parameter,storage) = Ast_typed.Helpers.get_pair tin in
let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout 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 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 Ast_typed.assert_type_expression_eq (storage,storage') in
(* TODO: on storage/parameter : assert_storable, assert_passable ? *) (* TODO: on storage/parameter : assert_storable, assert_passable ? *)
ok { parameter ; storage } 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") | [] -> 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 match_none in
let%bind _ = check_recursive_call n final_path body in let%bind _ = check_recursive_call n final_path body in
ok () ok ()
| Match_tuple ((_,e),_) -> | Match_tuple {vars=_;body;tvs=_} ->
let%bind _ = check_recursive_call n final_path e in let%bind _ = check_recursive_call n final_path body in
ok () ok ()
| Match_variant (l,_) -> | Match_variant {cases;tv=_} ->
let aux (_,e) = let aux {constructor=_; pattern=_; body} =
let%bind _ = check_recursive_call n final_path e in let%bind _ = check_recursive_call n final_path body in
ok () ok ()
in in
let%bind _ = bind_map_list aux l in let%bind _ = bind_map_list aux cases in
ok () 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 type_expression fun_type
expression_content (E_lambda lambda) expression_content (E_lambda lambda)
and assoc_expression ppf : expr * expr -> unit = and assoc_expression ppf : map_kv -> unit =
fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b fun {k ; v} -> fprintf ppf "%a -> %a" expression k expression v
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
@ -294,15 +294,15 @@ and option_inline ppf inline =
else else
fprintf ppf "" fprintf ppf ""
and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit = and matching_variant_case : (_ -> expression -> unit) -> _ -> matching_content_case -> unit =
fun f ppf ((c,n),a) -> fun f ppf {constructor=c; pattern; body} ->
fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a 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 and matching : (formatter -> expression -> unit) -> _ -> matching_content -> unit = fun f ppf m -> match m with
| Match_tuple ((lst, b),_) -> | Match_tuple {vars; body; tvs=_} ->
fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) vars f body
| Match_variant (lst, _) -> | Match_variant {cases ; tv=_} ->
fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) cases
| 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 "| True -> %a @.| False -> %a" f match_true f match_false
| Match_list {match_nil ; match_cons = {hd; tl; body; tv=_}} -> | 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) = let declaration ppf (d : declaration) =
match d with match d with
| Declaration_constant (name, expr, inline,_) -> | Declaration_constant {binder; expr; inline; post_env=_} ->
fprintf ppf "const %a = %a%a" expression_variable name expression expr option_inline inline fprintf ppf "const %a = %a%a" expression_variable binder expression expr option_inline inline
let program ppf (p : program) = let program ppf (p : program) =
fprintf ppf "@[<v>%a@]" 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 get_declaration_by_name : program -> string -> declaration result = fun p name ->
let aux : declaration -> bool = fun declaration -> let aux : declaration -> bool = fun declaration ->
match declaration with match declaration with
| Declaration_constant (d, _, _, _) -> d = Var.of_name name | Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ } -> binder = Var.of_name name
in in
trace_option (Errors.declaration_not_found name ()) @@ trace_option (Errors.declaration_not_found name ()) @@
List.find_opt aux @@ List.map Location.unwrap p 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 -> and expression : bindings -> expression -> bindings = fun b e ->
expression_content b e.expression_content 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) -> and matching_variant_case : (bindings -> expression -> bindings) -> bindings -> matching_content_case -> bindings = fun f b { constructor=_ ; pattern ; body } ->
f (union (singleton n) b) c f (union (singleton pattern) b) body
and matching : (bindings -> expression -> bindings) -> bindings -> matching_content -> bindings = fun f b m -> and matching : (bindings -> expression -> bindings) -> bindings -> matching_content -> bindings = fun f b m ->
match m with match m with
| Match_bool { match_true = t ; match_false = fa } -> union (f b t) (f b fa) | 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_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_option { match_none = n ; match_some = {opt; body; tv=_} } -> union (f b n) (f (union (singleton opt) b) body)
| Match_tuple ((lst , a), _) -> | Match_tuple { vars ; body ; tvs=_ } ->
f (union (of_list lst) b) a f (union (of_list vars) b) body
| Match_variant (lst,_) -> unions @@ List.map (matching_variant_case f b) lst | Match_variant { cases ; tv=_ } -> unions @@ List.map (matching_variant_case f b) cases
and matching_expression = fun x -> matching expression x 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 = let get_entry (lst : program) (name : string) : expression result =
trace_option (Errors.missing_entry_point name) @@ trace_option (Errors.missing_entry_point name) @@
let aux x = let aux x =
let (Declaration_constant (an , expr, _, _)) = Location.unwrap x in let (Declaration_constant { binder ; expr ; inline=_ ; _ }) = Location.unwrap x in
if (an = Var.of_name name) if Var.equal binder (Var.of_name name)
then Some expr then Some expr
else None else None
in in
@ -527,4 +527,4 @@ let get_entry (lst : program) (name : string) : expression result =
let program_environment (program : program) : full_environment = let program_environment (program : program) : full_environment =
let last_declaration = Location.unwrap List.(hd @@ rev program) in let last_declaration = Location.unwrap List.(hd @@ rev program) in
match last_declaration with 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%bind (main , input_type , _) =
let pred = fun d -> let pred = fun d ->
match d with 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 | Declaration_constant _ -> None
in in
let%bind main = let%bind main =
@ -23,7 +23,7 @@ let program_to_main : program -> string -> lambda result = fun p s ->
let env = let env =
let aux = fun _ d -> let aux = fun _ d ->
match d with 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 List.fold_left aux Environment.full_empty (List.map Location.unwrap p) in
let binder = Var.of_name "@contract_input" in let binder = Var.of_name "@contract_input" in
let result = let result =
@ -86,8 +86,8 @@ module Captured_variables = struct
let b' = union (singleton r.fun_name) b in let b' = union (singleton r.fun_name) b in
expression_content b' env @@ E_lambda r.lambda 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) -> and matching_variant_case : (bindings -> expression -> bindings result) -> bindings -> matching_content_case -> bindings result = fun f b { constructor=_ ; pattern ; body } ->
f (union (singleton n) b) c f (union (singleton pattern) b) body
and matching : (bindings -> expression -> bindings result) -> bindings -> matching_content -> bindings result = fun f b m -> and matching : (bindings -> expression -> bindings result) -> bindings -> matching_content -> bindings result = fun f b m ->
match m with match m with
@ -103,10 +103,10 @@ module Captured_variables = struct
let%bind n' = f b n in let%bind n' = f b n in
let%bind s' = f (union (singleton opt) b) body in let%bind s' = f (union (singleton opt) b) body in
ok @@ union n' s' ok @@ union n' s'
| Match_tuple ((lst , a),_) -> | Match_tuple { vars ; body ; tvs=_ } ->
f (union (of_list lst) b) a f (union (of_list vars) b) body
| Match_variant (lst , _) -> | Match_variant { cases ; tv=_ } ->
let%bind lst' = bind_map_list (matching_variant_case f b) lst in let%bind lst' = bind_map_list (matching_variant_case f b) cases in
ok @@ unions lst' ok @@ unions lst'
and matching_expression = fun x -> matching expression x 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 ; 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 = and matching_content =
| Match_bool of matching_content_bool | Match_bool of matching_content_bool
@ -234,13 +246,20 @@ and program = declaration Location.wrap list
and inline = bool and inline = bool
and declaration_constant = {
binder : expression_variable ;
expr : expression ;
inline : inline ;
post_env : full_environment ;
}
and declaration = and declaration =
(* A Declaration_constant is described by (* A Declaration_constant is described by
* a name + a type-annotated expression * a name + a type-annotated expression
* a boolean indicating whether it should be inlined * a boolean indicating whether it should be inlined
* the environment before the declaration (the original environment) * the environment before the declaration (the original environment)
* the environment after the declaration (i.e. with that new declaration added to 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_type of (type_variable * type_expression)
| Declaration_constant of (named_expression * (full_environment * full_environment)) | Declaration_constant of (named_expression * (full_environment * full_environment))
@ -254,6 +273,17 @@ and expression = {
environment: full_environment ; environment: full_environment ;
} }
and map_kv = {
k : expression ;
v : expression ;
}
and look_up = {
ds : expression;
ind : expression;
}
and expression_content = and expression_content =
(* Base *) (* Base *)
| E_literal of literal | 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 -> and s_declaration : T.declaration w = fun ~substs ->
function function
Ast_typed.Declaration_constant (ev,e,i,env) -> Ast_typed.Declaration_constant {binder ; expr ; inline ; post_env} ->
let%bind ev = s_variable ~substs ev in let%bind binder = s_variable ~substs binder in
let%bind e = s_expression ~substs e in let%bind expr = s_expression ~substs expr in
let%bind env = s_full_environment ~substs env in let%bind post_env = s_full_environment ~substs post_env in
ok @@ Ast_typed.Declaration_constant (ev, e, i, env) ok @@ Ast_typed.Declaration_constant {binder; expr; inline; post_env}
and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d -> and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d ->
Trace.bind_map_location (s_declaration ~substs) d Trace.bind_map_location (s_declaration ~substs) d