diff --git a/lib/typing/typing.ml b/lib/typing/typing.ml index 8d0343b3..e2196c92 100644 --- a/lib/typing/typing.ml +++ b/lib/typing/typing.ml @@ -1425,7 +1425,15 @@ let check_module_annot env loc ~mname m annot = ) | None -> () -module Subst_functor (* : Map_module.Map_tree *) = struct +(* These different functors exist to factor out the [map_decl] function, which + is used by both modules. The reason for having two (very similar) modules is + that for [resolve_alias], we need all declarations to be present. The + declarations are collected in the first module, and are not guarenteed to + arrive in the order they are used. For instance, a type in a signature might + be the first type declared, but in the module the last type defined. Hence, + there are two split modules. One for renaming and the other one for resolving + alisases. *) +module Sub_def = struct open Module_type type mapping = { base : Path.t; with_ : Path.t } @@ -1436,34 +1444,16 @@ module Subst_functor (* : Map_module.Map_tree *) = struct * mapping list * decl_map - let empty_sub () = - (* Make sure the empty env is never used. We want to pass the actual env to - look up declarations. *) - failwith "unreachable" - - let change_var ~mname id m (_, subs, _) = - ignore mname; - match m with - | Some m -> - let p = - List.fold_left - (fun p { base; with_ } -> Path.subst_base ~base ~with_ p) - m subs - in - (id, Some p) - | None -> (id, m) - - let absolute_module_name = Module.absolute_module_name + let find_function find_type declsub path = + match Pmap.find_opt path declsub with + | Some decl -> Some decl + | None -> find_type path +end - let map_type (find_type, subs, decls) typ = - let typ = - List.fold_left - (fun typ { base; with_ } -> apply_pathsub ~base ~with_ typ) - typ subs - in - (* Use aliases if they are available *) - let typ = resolve_alias (find_type decls) typ in - ((find_type, subs, decls), typ) +module Map_decl (Subst : Map_module.Map_tree with type sub = Sub_def.sub) = +struct + open Module_type + include Subst let rec map_decl ~mname id sub decl = let (find, subs, dmap), kind = @@ -1505,14 +1495,80 @@ module Subst_functor (* : Map_module.Map_tree *) = struct let path = Path.append id mname in let dmap = Pmap.add path (decl, path) dmap in ((find, subs, dmap), decl) +end - let find_function find_type declsub path = - match Pmap.find_opt path declsub with - | Some decl -> Some decl - | None -> find_type path +module Subst_functor_impl (* : Map_module.Map_tree *) = struct + open Module_type + open Sub_def + + type sub = Sub_def.sub + + let empty_sub () = + (* Make sure the empty env is never used. We want to pass the actual env to + look up declarations. *) + failwith "unreachable" + + let change_var ~mname id m (_, subs, _) = + ignore mname; + match m with + | Some m -> + let p = + List.fold_left + (fun p { base; with_ } -> Path.subst_base ~base ~with_ p) + m subs + in + (id, Some p) + | None -> (id, m) + + let absolute_module_name = Module.absolute_module_name + + let map_type (find_type, subs, decls) typ = + let typ = + List.fold_left + (fun typ { base; with_ } -> apply_pathsub ~base ~with_ typ) + typ subs + in + ((find_type, subs, decls), typ) + + let map_decl ~mname id sub decl = + ignore mname; + ignore id; + ignore sub; + ignore decl; + failwith "unreachable" end +module Resolve_aliases_impl (* : Map_module.Map_tree *) = struct + type sub = Sub_def.sub + + let empty_sub () = + (* Make sure the empty env is never used. We want to pass the actual env to + look up declarations. *) + failwith "unreachable" + + let change_var ~mname id m _ = + ignore mname; + (id, m) + + let absolute_module_name = Module.absolute_module_name + + let map_type (find_type, subs, decls) typ = + (* Use aliases if they are available *) + let typ = resolve_alias (find_type decls) typ in + ((find_type, subs, decls), typ) + + let map_decl ~mname id sub decl = + ignore mname; + ignore id; + ignore sub; + ignore decl; + failwith "unreachable" +end + +module Subst_functor = Map_decl (Subst_functor_impl) module Subst = Map_module.Make (Subst_functor) +module Resolve_aliases = Map_decl (Resolve_aliases_impl) +module Aliases = Map_module.Make (Resolve_aliases) type fn_let_kind = | Callname of string * bool @@ -1771,14 +1827,12 @@ and convert_prog env items modul = want to apply the paramater sub, then the functor name sub. To make this explicit, we are using a list. *) (* Add functor -> applied functor mapping *) - let subs = - { Subst_functor.base = mname; with_ = applied_name } :: [] - in + let subs = { Sub_def.base = mname; with_ = applied_name } :: [] in let subs = Module_type.Pmap.fold (fun key value acc -> - Subst_functor.{ base = key; with_ = value } :: acc) + Sub_def.{ base = key; with_ = value } :: acc) !param_arg_map subs in (* Type declarations which are defined in this functor won't be @@ -1787,16 +1841,23 @@ and convert_prog env items modul = type. *) let find = let find path = Env.find_type_opt loc path env in - Subst_functor.find_function find + Sub_def.find_function find in let subs = (find, subs, Module_type.Pmap.empty) in let modul, body = Module.with_transitive_deps (fun () -> + (* Split name substitution and alias resolving into separate + passes, because not all decls are available in order. *) let subs, modul = Subst.map_module applied_name subs modul in + let _, modul = Aliases.map_module applied_name subs modul in let body = Subst.map_tl_items applied_name Smap.empty subs body |> snd in + let body = + Aliases.map_tl_items applied_name Smap.empty subs body + |> snd + in (modul, body)) in let moditems = List.map (fun item -> (applied_name, item)) body in diff --git a/test/typing.ml b/test/typing.ml index dc5c9073..3d3becd2 100644 --- a/test/typing.ml +++ b/test/typing.ml @@ -1295,6 +1295,25 @@ module whatev: module applied = use_types(whatev) |} +let test_functor_sgn_reorder () = + test "unit" + {| +module type any: + type t + +functor use_types(m : any): + signature: + type state + type result = { code : int } + + type state = result + +module whatev: + type t = int + +module applied = use_types(whatev) +|} + let test_farray_lit () = test "unit" "let arr = #[1, 2, 3]" let test_farray_lit_trailing () = test "unit" "let arr = #[1, 2, 3,]" @@ -1825,6 +1844,7 @@ do: case "check sig param" test_functor_check_param; case "check sig concrete" test_functor_check_concrete; case "sgn-only type" test_functor_sgn_only_type; + case "sgn reorder" test_functor_sgn_reorder; ] ); ( "fixed-size array", [