62 lines
2.8 KiB
OCaml
62 lines
2.8 KiB
OCaml
open Trace
|
|
open Types
|
|
|
|
let get_binder_name : 'a Var.t -> string = fun (v: _ Var.t) ->
|
|
if Var.is_generated v
|
|
then "generated"
|
|
else Var.to_name v
|
|
|
|
let make_def_id name i =
|
|
(name ^ (string_of_int i), i+1)
|
|
|
|
let add_shadowing_def : (int * _ Var.t) -> def -> def_map -> (int * def_map) = fun (i,var) def env ->
|
|
if Var.is_generated var then (i,env)
|
|
else
|
|
let name = get_binder_name var in
|
|
let (definition_id,i) = make_def_id name i in
|
|
let shadow = Def_map.filter
|
|
(fun _ s_def -> match def, s_def with
|
|
| Variable _ , Variable _ | Type _ , Type _ ->
|
|
not @@ String.equal (get_def_name s_def) name
|
|
| _ -> true )
|
|
env in
|
|
let env = Def_map.add definition_id def shadow in
|
|
(i,env)
|
|
|
|
let make_v_def_from_core : with_types:bool -> string -> string -> ('a Var.t) -> Ast_core.expression -> Location.t -> Location.t -> def =
|
|
fun ~with_types source_file syntax name exp range body_range ->
|
|
let name = get_binder_name name in
|
|
let t = to_option @@
|
|
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in
|
|
let env = Ast_typed.program_environment Environment.default typed_prg in
|
|
let%bind (e,_) = Compile.Of_core.compile_expression ~env ~state exp in
|
|
ok e.type_expression
|
|
in
|
|
(* TODO : the source_file is given here but it should only be the declarations seen so far,
|
|
otherwise nothing will be typed if an error occurs later in the file *)
|
|
make_v_def ~with_types name t range body_range
|
|
|
|
let make_v_def_option_type : with_types:bool -> string -> string -> ('a Var.t) -> Ast_core.type_expression option -> Location.t -> Location.t -> def =
|
|
fun ~with_types source_file syntax name maybe_typed range body_range ->
|
|
let name = get_binder_name name in
|
|
match maybe_typed with
|
|
| Some t ->
|
|
let t' = to_option @@
|
|
let%bind typed_prg,_ = Compile.Utils.type_file source_file syntax Env in
|
|
let env = Ast_typed.program_environment Environment.default typed_prg in
|
|
Compile.Of_core.evaluate_type env t in
|
|
make_v_def ~with_types name t' range body_range
|
|
| None -> make_v_def ~with_types name None range body_range
|
|
|
|
let make_v_def_ppx_type :
|
|
with_types:bool -> string -> string -> ('a Var.t) -> (Ast_typed.type_expression -> Ast_typed.type_expression) ->
|
|
Ast_core.expression -> Location.t -> Location.t -> def =
|
|
fun ~with_types source_file syntax name f exp range body_range ->
|
|
let name = get_binder_name name in
|
|
let t = to_option @@
|
|
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in
|
|
let env = Ast_typed.program_environment Environment.default typed_prg in
|
|
let%bind (e,_) = Compile.Of_core.compile_expression ~env ~state exp in
|
|
let v = f e.type_expression in ok v
|
|
in
|
|
make_v_def ~with_types name t range body_range |