jon.recoil.org
this repo has no description
1open Odoc_utils.ResultMonad
2open Odoc_model
3
4let handle_expansion env id expansion =
5 let handle_argument parent arg_opt expr env =
6 (* If there's an argument, extend the environment with the argument, then
7 do the substitution on the signature to replace the local identifier with
8 the global one *)
9 match arg_opt with
10 | Component.FunctorParameter.Unit -> (env, expr)
11 | Named arg ->
12 let identifier =
13 Paths.Identifier.Mk.parameter
14 (parent, Ident.Name.typed_module arg.Component.FunctorParameter.id)
15 in
16 let m = Component.module_of_functor_argument arg in
17 let env' =
18 Env.add_module identifier (Component.Delayed.put_val m) m.doc env
19 in
20 let rp = `Gpath (`Identifier identifier) in
21 let p = `Resolved rp in
22 let subst =
23 Subst.add_module (arg.id :> Ident.module_) p rp Subst.identity
24 in
25 (env', Subst.module_type_expr subst expr)
26 in
27 let rec expand id env expansion :
28 (Env.t * Component.ModuleType.simple_expansion, _) result =
29 match expansion with
30 | Tools.Signature sg ->
31 Ok
32 ( env,
33 (Component.ModuleType.Signature sg
34 : Component.ModuleType.simple_expansion) )
35 | Functor (arg, expr) ->
36 let env', expr' = handle_argument id arg expr env in
37 Tools.expansion_of_module_type_expr env' expr' >>= fun res ->
38 expand (Paths.Identifier.Mk.result id) env res >>= fun (env, res) ->
39 Ok
40 ( env,
41 (Component.ModuleType.Functor (arg, res)
42 : Component.ModuleType.simple_expansion) )
43 in
44 expand id env expansion
45
46exception Clash
47
48let rec type_expr map t =
49 let open Lang.TypeExpr in
50 match t with
51 | Var (v, _) -> (
52 try List.assoc v map
53 with Not_found ->
54 Format.eprintf "Type variable '%s' not found in map [%s]@." v
55 (String.concat ", " (List.map fst map));
56 assert false)
57 | Any -> Any
58 | Alias (t, s) ->
59 if List.mem_assoc s map then raise Clash else Alias (type_expr map t, s)
60 | Arrow (l, t1, t2, modes, ret_modes) -> Arrow (l, type_expr map t1, type_expr map t2, modes, ret_modes)
61 | Tuple ts -> Tuple (List.map (fun (l, ty) -> (l, type_expr map ty)) ts)
62 | Unboxed_tuple ts -> Unboxed_tuple (List.map (fun (l, t) -> l, type_expr map t) ts)
63 | Constr (p, ts) -> Constr (p, List.map (type_expr map) ts)
64 | Polymorphic_variant pv -> Polymorphic_variant (polymorphic_variant map pv)
65 | Object o -> Object (object_ map o)
66 | Class (path, ts) -> Class (path, List.map (type_expr map) ts)
67 | Poly (s, t) -> Poly (s, type_expr map t)
68 | Package p -> Package (package map p)
69 | Quote t -> Quote (type_expr map t)
70 | Splice t -> Splice (type_expr map t)
71
72and polymorphic_variant map pv =
73 let open Lang.TypeExpr.Polymorphic_variant in
74 let constructor c =
75 {
76 c with
77 Constructor.arguments = List.map (type_expr map) c.Constructor.arguments;
78 }
79 in
80 let element = function
81 | Type t -> Type (type_expr map t)
82 | Constructor c -> Constructor (constructor c)
83 in
84 { kind = pv.kind; elements = List.map element pv.elements }
85
86and object_ map o =
87 let open Lang.TypeExpr.Object in
88 let method_ m = { m with type_ = type_expr map m.type_ } in
89 let field = function
90 | Method m -> Method (method_ m)
91 | Inherit t -> Inherit (type_expr map t)
92 in
93 { o with fields = List.map field o.fields }
94
95and package map p =
96 let open Lang.TypeExpr.Package in
97 let subst (frag, t) = (frag, type_expr map t) in
98 { p with substitutions = List.map subst p.substitutions }
99
100let collapse_eqns eqn1 eqn2 params =
101 let open Lang.TypeDecl in
102 let map =
103 List.map2
104 (fun v p -> match v.desc with Var (x, _) -> Some (x, p) | Any -> None)
105 eqn2.Equation.params params
106 in
107 let map =
108 List.fold_right
109 (fun x xs -> match x with Some x -> x :: xs | None -> xs)
110 map []
111 in
112 {
113 eqn1 with
114 Equation.manifest =
115 (match eqn2.manifest with
116 | None -> None
117 | Some t -> Some (type_expr map t));
118 }