diff --git a/src/passes/6-transpiler/transpiler.ml b/src/passes/6-transpiler/transpiler.ml index 632fe0ee9..1a4569f75 100644 --- a/src/passes/6-transpiler/transpiler.ml +++ b/src/passes/6-transpiler/transpiler.ml @@ -338,7 +338,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = trace_option (corner_case ~loc:__LOC__ "missing var") @@ AST.Environment.get_opt v f.environment in match elt.definition with - | ED_declaration (f , _) -> ( + | ED_declaration { expr = f ; free_variables = _ } -> ( match f.expression_content with | E_lambda l -> lambda_to_iterator_body f l | _ -> fail @@ unsupported_iterator f.location diff --git a/src/stages/ast_typed/environment.ml b/src/stages/ast_typed/environment.ml index 61c21ed8a..cc0aa2878 100644 --- a/src/stages/ast_typed/environment.ml +++ b/src/stages/ast_typed/environment.ml @@ -6,24 +6,28 @@ let make_element : type_expression -> full_environment -> environment_element_de fun type_value source_environment definition -> {type_value ; source_environment ; definition} let make_element_binder = fun t s -> make_element t s ED_binder -let make_element_declaration = fun s (ae : expression) -> - let free_variables = Misc.Free_variables.(expression empty ae) in - make_element (get_type_expression ae) s (ED_declaration (ae , free_variables)) +let make_element_declaration = fun s (expr : expression) -> + let free_variables = Misc.Free_variables.(expression empty expr) in + make_element (get_type_expression expr) s (ED_declaration {expr ; free_variables}) module Small = struct type t = small_environment - let empty : t = ([] , []) + let empty : t = { expression_environment = [] ; type_environment = [] } - let get_environment : t -> environment = fst - let get_type_environment : t -> type_environment = snd - let map_environment : _ -> t -> t = fun f (a , b) -> (f a , b) - let map_type_environment : _ -> t -> t = fun f (a , b) -> (a , f b) + (* TODO: generate *) + let get_environment : t -> environment = fun { expression_environment ; type_environment=_ } -> expression_environment + (* TODO: generate *) + let get_type_environment : t -> type_environment = fun { expression_environment=_ ; type_environment } -> type_environment + (* TODO: generate *) + let map_environment : _ -> t -> t = fun f { expression_environment ; type_environment } -> { expression_environment = f expression_environment ; type_environment } + let map_type_environment : _ -> t -> t = fun f { expression_environment ; type_environment } -> { expression_environment ; type_environment = f type_environment } - let add : expression_variable -> element -> t -> t = fun k v -> map_environment (fun x -> (k , v) :: x) - let add_type : type_variable -> type_expression -> t -> t = fun k v -> map_type_environment (fun x -> (k , v) :: x) - let get_opt : expression_variable -> t -> element option = fun k x -> List.assoc_opt k (get_environment x) - let get_type_opt : type_variable -> t -> type_expression option = fun k x -> List.assoc_opt k (get_type_environment x) + let add : expression_variable -> element -> t -> t = fun expr_var env_elt -> map_environment (fun x -> {expr_var ; env_elt} :: x) + let add_type : type_variable -> type_expression -> t -> t = fun type_variable type_ -> map_type_environment (fun x -> { type_variable ; type_ } :: x) + (* TODO: generate : these are now messy, clean them up. *) + let get_opt : expression_variable -> t -> element option = fun k x -> Option.bind (fun {expr_var=_ ; env_elt} -> Some env_elt) @@ List.find_opt (fun {expr_var ; env_elt=_} -> Var.equal expr_var k) (get_environment x) + let get_type_opt : type_variable -> t -> type_expression option = fun k x -> Option.bind (fun {type_variable=_ ; type_} -> Some type_) @@ List.find_opt (fun {type_variable ; type_=_} -> Var.equal type_variable k) (get_type_environment x) end type t = full_environment @@ -41,11 +45,11 @@ let get_type_opt : type_variable -> t -> type_expression option = fun k x -> Lis let get_constructor : constructor' -> t -> (type_expression * type_expression) option = fun k x -> (* Left is the constructor, right is the sum type *) let aux = fun x -> - let aux = fun (_type_name , x) -> - match x.type_content with + let aux = fun {type_variable=_ ; type_} -> + match type_.type_content with | T_sum m -> (match CMap.find_opt k m with - Some km -> Some (km , x) + Some km -> Some (km , type_) | None -> None) | _ -> None in @@ -60,11 +64,11 @@ module PP = struct let list_sep_scope x = list_sep x (const " | ") - let environment_element = fun ppf (k , (ele : environment_element)) -> - fprintf ppf "%a -> %a" PP.expression_variable k PP.type_expression ele.type_value + let environment_element = fun ppf {expr_var ; env_elt} -> + fprintf ppf "%a -> %a" PP.expression_variable expr_var PP.type_expression env_elt.type_value - let type_environment_element = fun ppf (k , tv) -> - fprintf ppf "%a -> %a" PP.type_variable k PP.type_expression tv + let type_environment_element = fun ppf {type_variable ; type_} -> + fprintf ppf "%a -> %a" PP.type_variable type_variable PP.type_expression type_ let environment : _ -> environment -> unit = fun ppf lst -> fprintf ppf "E[%a]" (list_sep environment_element (const " , ")) lst diff --git a/src/stages/ast_typed/misc_smart.ml b/src/stages/ast_typed/misc_smart.ml index 3cc52eaec..bf376f383 100644 --- a/src/stages/ast_typed/misc_smart.ml +++ b/src/stages/ast_typed/misc_smart.ml @@ -59,7 +59,7 @@ module Captured_variables = struct Environment.get_opt name ae.environment in match env_element.definition with | ED_binder -> ok empty - | ED_declaration (_ , _) -> simple_fail "todo" + | ED_declaration {expr=_ ; free_variables=_} -> simple_fail "todo" ) | E_application {expr1;expr2} -> let%bind lst' = bind_map_list self [ expr1 ; expr2 ] in diff --git a/src/stages/ast_typed/types.ml b/src/stages/ast_typed/types.ml index 5aa323c9b..8b9195d60 100644 --- a/src/stages/ast_typed/types.ml +++ b/src/stages/ast_typed/types.ml @@ -26,11 +26,12 @@ and declaration = *) (* | Macro_declaration of macro_declaration *) -and expression = - { expression_content: expression_content - ; location: Location.t - ; type_expression: type_expression - ; environment: full_environment } +and expression = { + expression_content: expression_content ; + location: Location.t ; + type_expression: type_expression ; + environment: full_environment ; + } and expression_content = (* Base *) @@ -56,63 +57,98 @@ and expression_content = | E_look_up of (expression * expression) (* Advanced *) | E_loop of loop - (* - | E_ascription of ascription - *) - -and constant = - { cons_name: constant' (* this is at the end because it is huge *) - ; arguments: expression list } + (* | E_ascription of ascription *) +and constant = { + cons_name: constant' ; + arguments: expression list ; + } and application = {expr1: expression; expr2: expression} -and lambda = - { binder: expression_variable - (* ; input_type: type_expression option - ; output_type: type_expression option *) - ; result: expression } - -and let_in = - { let_binder: expression_variable - ; rhs: expression - ; let_result: expression - ; inline : inline } - -and constructor = {constructor: constructor'; element: expression} - -and accessor = {expr: expression; label: label} - -and update = {record: expression; path: label ; update: expression} - -and loop = {condition: expression; body: expression} - -and matching_expr = (expression,type_expression) matching_content -and matching = - { matchee: expression - ; cases: matching_expr +and lambda = { + binder: expression_variable ; + (* input_type: type_expression option ; *) + (* output_type: type_expression option ; *) + result: expression ; } -and ascription = {anno_expr: expression; type_annotation: type_expression} +and let_in = { + let_binder: expression_variable ; + rhs: expression ; + let_result: expression ; + inline : inline ; + } + +and constructor = { + constructor: constructor'; + element: expression ; + } + +and accessor = { + expr: expression ; + label: label ; + } + +and update = { + record: expression ; + path: label ; + update: expression ; + } + +and loop = { + condition: expression ; + body: expression ; + } + +and matching_expr = (expression, type_expression) matching_content +and matching = { + matchee: expression ; + cases: matching_expr ; + } + +and ascription = { + anno_expr: expression ; + type_annotation: type_expression ; + } and environment_element_definition = | ED_binder - | ED_declaration of (expression * free_variables) + | ED_declaration of environment_element_definition_declaration + +and environment_element_definition_declaration = { + expr: expression ; + free_variables: free_variables ; + } and free_variables = expression_variable list -and environment_element = - { type_value: type_expression - ; source_environment: full_environment - ; definition: environment_element_definition } +and environment_element = { + type_value: type_expression ; + source_environment: full_environment ; + definition: environment_element_definition ; + } -and environment = (expression_variable * environment_element) list +and environment = environment_binding list -and type_environment = (type_variable * type_expression) list +and environment_binding = { + expr_var: expression_variable ; + env_elt: environment_element ; + } + +and type_environment = type_environment_binding list + +and type_environment_binding = { + type_variable: type_variable ; + type_: type_expression ; +} (* SUBST ??? *) -and small_environment = environment * type_environment +and small_environment = { + expression_environment: environment ; + type_environment: type_environment ; +} and full_environment = small_environment List.Ne.t @@ -123,4 +159,4 @@ and texpr = type_expression and named_type_content = { type_name : type_variable; type_value : type_expression; -} + } diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index eb5e11c16..011fef1b7 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -17,25 +17,25 @@ module Substitution = struct let rec rec_yes = true and s_environment_element_definition ~substs = function | T.ED_binder -> ok @@ T.ED_binder - | T.ED_declaration (val_, free_variables) -> - let%bind val_ = s_expression ~substs val_ in + | T.ED_declaration T.{expr ; free_variables} -> + let%bind expr = s_expression ~substs expr in let%bind free_variables = bind_map_list (s_variable ~substs) free_variables in - ok @@ T.ED_declaration (val_, free_variables) + ok @@ T.ED_declaration {expr ; free_variables} and s_environment : T.environment w = fun ~substs env -> - bind_map_list (fun (variable, T.{ type_value; source_environment; definition }) -> + bind_map_list (fun T.{expr_var=variable ; env_elt={ type_value; source_environment; definition }} -> let%bind type_value = s_type_expression ~substs type_value in let%bind source_environment = s_full_environment ~substs source_environment in let%bind definition = s_environment_element_definition ~substs definition in - ok @@ (variable, T.{ type_value; source_environment; definition })) env + ok @@ T.{expr_var=variable ; env_elt={ type_value; source_environment; definition }}) env and s_type_environment : T.type_environment w = fun ~substs tenv -> - bind_map_list (fun (type_variable , type_value) -> + bind_map_list (fun T.{type_variable ; type_} -> let%bind type_variable = s_type_variable ~substs type_variable in - let%bind type_value = s_type_expression ~substs type_value in - ok @@ (type_variable , type_value)) tenv - and s_small_environment : T.small_environment w = fun ~substs (environment, type_environment) -> - let%bind environment = s_environment ~substs environment in + let%bind type_ = s_type_expression ~substs type_ in + ok @@ T.{type_variable ; type_}) tenv + and s_small_environment : T.small_environment w = fun ~substs T.{expression_environment ; type_environment} -> + let%bind expression_environment = s_environment ~substs expression_environment in let%bind type_environment = s_type_environment ~substs type_environment in - ok @@ (environment, type_environment) + ok @@ T.{ expression_environment ; type_environment } and s_full_environment : T.full_environment w = fun ~substs (a , b) -> let%bind a = s_small_environment ~substs a in let%bind b = bind_map_list (s_small_environment ~substs) b in