Continue to dig-in codept
parent
e027cfbaf2
commit
e2a2a84a1f
@ -1 +1,2 @@
|
||||
version=0.24.1
|
||||
break-before-in=auto
|
||||
|
||||
@ -0,0 +1,33 @@
|
||||
type elt = {
|
||||
what : [ `Val of string | `Module ];
|
||||
from : [ `Local | `Unknown | `Path of Fpath.t | `Special of Mod.t ];
|
||||
aliases : Mod.Path.Set.t;
|
||||
}
|
||||
|
||||
type t = elt Mod.Map.t
|
||||
|
||||
let merge =
|
||||
Mod.Map.union (fun _k x y ->
|
||||
let aliases = Mod.Path.Set.union x.aliases y.aliases in
|
||||
let what =
|
||||
match (x.what, y.what) with `Module, _ -> `Module | _, what -> what
|
||||
in
|
||||
Some { y with what; aliases })
|
||||
|
||||
let empty = Mod.Map.empty
|
||||
|
||||
let phantom ?(aliases = Mod.Path.Set.empty) name =
|
||||
let elt = { what = `Module; from = `Unknown; aliases } in
|
||||
Mod.Map.singleton name elt
|
||||
|
||||
let update ?(aliases = Mod.Path.Set.empty) ~what from name deps =
|
||||
let elt =
|
||||
match Mod.Map.find_opt name deps with
|
||||
| None -> { what; from; aliases }
|
||||
| Some ({ aliases = aliases'; what = what'; _ } as x) ->
|
||||
let aliases = Mod.Path.Set.union aliases aliases' in
|
||||
let what = match what with `Module -> `Module | _ -> what' in
|
||||
{ x with aliases; what } in
|
||||
Mod.Map.add name elt deps
|
||||
|
||||
let v ?aliases ~what from name = update ?aliases ~what from name empty
|
||||
@ -0,0 +1,200 @@
|
||||
let src = Logs.Src.create "uniq.env"
|
||||
|
||||
module Log = (val Logs.src_log src : Logs.LOG)
|
||||
open Rresult
|
||||
|
||||
type context =
|
||||
| Signature of Module.signature
|
||||
(** A simple module with module type definitions & module expressions. *)
|
||||
| In_pack of Module.dictionary
|
||||
(** A pack which contains multiple modules with their
|
||||
module type definitions & module expressions. *)
|
||||
|
||||
(* The [Query] module lets us to keep [Deps.t] and [Message.t list]
|
||||
along our process. The ( >>? ) operator takes care for us to:
|
||||
1) merge dependencies
|
||||
2) append messages
|
||||
*)
|
||||
module Query = struct
|
||||
type 'a elt = { v : 'a; deps : Deps.t; msgs : Message.t list }
|
||||
type 'a t = 'a elt option
|
||||
|
||||
let ( >>? ) x f =
|
||||
match x with
|
||||
| None -> None
|
||||
| Some x ->
|
||||
Option.map
|
||||
(fun { v; deps; msgs } ->
|
||||
{ v; deps = Deps.merge deps x.deps; msgs = msgs @ x.msgs })
|
||||
(f x.v)
|
||||
|
||||
let ( >> ) x y = x >>? fun () -> y
|
||||
let return v : _ t = Some { v; deps = Deps.empty; msgs = [] }
|
||||
let return_with msg v = Some { v; deps = Deps.empty; msgs = [ msg ] }
|
||||
let deps deps = Some { v = (); deps; msgs = [] }
|
||||
|
||||
let record ~location:_ what ?aliases root name = function
|
||||
| Module.Origin.Unit src ->
|
||||
let src, modname =
|
||||
(src :> [ `Local | `Unknown | `Path of Fpath.t | `Special ] * Mod.t)
|
||||
in
|
||||
let src =
|
||||
match src with
|
||||
| `Special -> `Special modname
|
||||
| `Local -> `Local
|
||||
| `Path path -> `Path path
|
||||
| `Unknown -> `Unknown in
|
||||
deps (Deps.v ?aliases ~what src name)
|
||||
| Module.Origin.Phantom (root', _p) when root && not root' ->
|
||||
deps (Deps.v ?aliases ~what:`Module `Unknown name)
|
||||
| _ -> return ()
|
||||
|
||||
let injection = function
|
||||
| None -> None
|
||||
| Some v -> Some { v; deps = Deps.empty; msgs = [] }
|
||||
end
|
||||
|
||||
type t = { top : Module.dictionary; context : context }
|
||||
|
||||
let top env =
|
||||
{ env with context = Signature (Module.Signature.with_modules env.top) }
|
||||
|
||||
let restrict_as_a_pack t modules = { t with context = In_pack modules }
|
||||
let restrict env context = { env with context }
|
||||
|
||||
let v ~impls:me ~intfs:mt =
|
||||
{ top = me; context = Module.(Signature (Exact { me; mt })) }
|
||||
|
||||
type option = {
|
||||
approximation : bool;
|
||||
location : Fpath.t * Mml.Loc.t;
|
||||
what : [ `Module | `Val of string ];
|
||||
level : [ `Impl | `Intf ];
|
||||
}
|
||||
|
||||
let rec find_name ~location phantom level name = function
|
||||
| Signature Module.Unknown -> Query.return (Module.unknown name)
|
||||
| In_pack modules ->
|
||||
(* XXX(dinosaure): a packed object contains only implementations. *)
|
||||
if level = `Intf then None
|
||||
else
|
||||
Query.injection
|
||||
(Mod.Path.Map.find_opt (Mod.Path.singleton name) modules)
|
||||
| Signature (Module.Exact { me; mt }) ->
|
||||
let m = if level = `Impl then me else mt in
|
||||
Query.injection (Mod.Path.Map.find_opt (Mod.Path.singleton name) m)
|
||||
| Signature (Module.Divergence p) -> (
|
||||
let projection = if level = `Impl then fst else snd in
|
||||
(* If we have a divergent signature, we first look at the signature
|
||||
after the divergence. *)
|
||||
match
|
||||
Mod.Path.Map.find_opt (Mod.Path.singleton name) (projection p.pst)
|
||||
with
|
||||
| Some v -> Query.return v
|
||||
| None -> (
|
||||
let
|
||||
(* We then try to find the searched name in the signature
|
||||
before the divergence. *)
|
||||
open
|
||||
Query in
|
||||
let default =
|
||||
lazy
|
||||
(if level = `Intf then
|
||||
Query.return_with
|
||||
(Message.unknown ~location `Intf name)
|
||||
(Module.unknown name)
|
||||
else None) in
|
||||
match
|
||||
find_name ~location true level name (Signature p.pre) >>? fun r ->
|
||||
(* If we found the expected name before the divergence,
|
||||
we add a new ambiguity message and return the found
|
||||
module, after marking it as a phantom module. *)
|
||||
let m = Module.spirit_away p.point r in
|
||||
if phantom then return m
|
||||
else
|
||||
Query.return_with
|
||||
(Message.ambiguous ~location ~point:p.point name)
|
||||
m
|
||||
with
|
||||
| Some _ as v -> v
|
||||
| None -> Lazy.force default))
|
||||
|
||||
let find_name ~location level path t = find_name ~location false level path t
|
||||
|
||||
(* What we are looking for? *)
|
||||
type what =
|
||||
| Any (* Look for alias too *)
|
||||
| Concrete (* We are looking for a concrete unit *)
|
||||
| Sub_module
|
||||
|
||||
let is_top = function Any | Concrete -> true | Sub_module -> false
|
||||
|
||||
let rec find opt aliases what where env path =
|
||||
let[@warning "-8"] (root :: rest) = Mod.Path.to_list path in
|
||||
let open Query in
|
||||
let level =
|
||||
match rest with
|
||||
| [] ->
|
||||
opt.level (* XXX(dinosaure): can be an [module] or a [module type]. *)
|
||||
| _ :: _ -> `Impl (* XXX(dinosaure): must be a [module]. *) in
|
||||
let q =
|
||||
match find_name ~location:opt.location level root env.context with
|
||||
| None when opt.approximation && (what = Sub_module || opt.level = `Intf) ->
|
||||
let name = List.hd (List.rev (root :: rest)) in
|
||||
Query.return (* with no_sub_module *) (Module.unknown name)
|
||||
| None -> None (* TODO *)
|
||||
| Some _ as v -> v in
|
||||
q >>? find_elt opt aliases what (root :: where) env root rest
|
||||
|
||||
and find_elt opt aliases what where env name rest = function
|
||||
| Module.Alias { path; phantom } ->
|
||||
Log.debug (fun m -> m "Alias to %a" Mod.Path.pp path);
|
||||
let[@warning "-8"] (Ok elt) = Mod.Path.of_list_of_names (List.rev where) in
|
||||
let aliases = Mod.Path.Set.add elt aliases in
|
||||
let m =
|
||||
match phantom with
|
||||
| Some _ when what = Any || what = Concrete ->
|
||||
Query.deps (* with ambiguity *) (Deps.phantom name)
|
||||
| None | Some _ -> Query.return () in
|
||||
let open Query in
|
||||
(* XXX(dinosaure): currently, we manipulate an alias [name] which
|
||||
can be concretize by [path]. We must bring dependencies from
|
||||
it. [name] is /suffixed/ by [rest], so we will try to resolve
|
||||
dependencies from [path.rest]. *)
|
||||
let path = List.fold_left Mod.Path.( <.> ) path rest in
|
||||
m >> find opt aliases Any [] (top env) path
|
||||
| Module.Link _ when what = Concrete -> None
|
||||
| Module.Link name ->
|
||||
find opt aliases Concrete [] (top env) (Mod.Path.singleton name)
|
||||
| Module.Sig { origin; signature } -> (
|
||||
let open Query in
|
||||
Query.record ~location:opt.location opt.what ~aliases (is_top what) name
|
||||
origin
|
||||
>>
|
||||
match rest with
|
||||
| [] -> return (name, `Module (Module.Sig { origin; signature }))
|
||||
| rest ->
|
||||
let[@warning "-8"] (Ok path) = Mod.Path.of_list_of_names rest in
|
||||
find opt aliases Sub_module where
|
||||
(restrict env (Signature signature))
|
||||
path)
|
||||
| (Module.Abstract _ | Module.Functor _) as kind -> (
|
||||
match rest with
|
||||
| [] -> Query.return (name, `Module (Module.Partial.of_extended kind))
|
||||
| _ :: _ ->
|
||||
let name = List.hd (List.rev rest) in
|
||||
let m = Module.unknown name in
|
||||
Query.return (name, `Module m))
|
||||
| Module.Pack ms -> (
|
||||
match rest with
|
||||
| [] -> Query.return (name, `Pack ms)
|
||||
| _ :: _ ->
|
||||
let[@warning "-8"] (Ok path) = Mod.Path.of_list_of_names rest in
|
||||
find opt aliases what where (restrict_as_a_pack env ms) path)
|
||||
|
||||
let find ~location ?(what = `Module) level path env =
|
||||
let opt = { approximation = true; location; what; level } in
|
||||
Mod.Path.verify level path >>= fun path ->
|
||||
match find opt Mod.Path.Set.empty Any [] env path with
|
||||
| Some { Query.v = name, v; deps; msgs = _ } -> Ok (deps, name, v)
|
||||
| None -> Error `Not_found
|
||||
@ -0,0 +1,16 @@
|
||||
type t
|
||||
|
||||
val v : impls:Module.dictionary -> intfs:Module.dictionary -> t
|
||||
val restrict_as_a_pack : t -> Module.dictionary -> t
|
||||
|
||||
val find :
|
||||
location:Mml.Loc.p ->
|
||||
?what:[ `Val of string | `Module ] ->
|
||||
[ `Impl | `Intf ] ->
|
||||
Mod.Path.t ->
|
||||
t ->
|
||||
( Deps.t
|
||||
* Mod.t
|
||||
* [ `Pack of Module.dictionary | `Module of Module.simple Module.t ],
|
||||
[> `Not_found | `Msg of string ] )
|
||||
result
|
||||
@ -0,0 +1,12 @@
|
||||
type t = int
|
||||
type generator = unit -> t
|
||||
|
||||
let pp ppf v = Fmt.pf ppf "$%d" v
|
||||
|
||||
let v () =
|
||||
let v = ref (-1) in
|
||||
fun () ->
|
||||
incr v;
|
||||
!v
|
||||
|
||||
let gen = v ()
|
||||
@ -0,0 +1,6 @@
|
||||
type t = private int
|
||||
type generator = unit -> t
|
||||
|
||||
val gen : generator
|
||||
val pp : t Fmt.t
|
||||
val v : unit -> generator
|
||||
@ -1,47 +0,0 @@
|
||||
module Source = struct
|
||||
type t = {
|
||||
source : [ `Local | `Unknown | `Pack of Ns.t | `Special of Mod.t ];
|
||||
file : Ns.t;
|
||||
}
|
||||
end
|
||||
|
||||
module Arg = struct
|
||||
type 'a t = { name : Mod.t; signature : 'a }
|
||||
end
|
||||
|
||||
module Divergence = struct
|
||||
type origin = First_class_module | External
|
||||
type t = { root : Mod.t option; origin : origin; location : Source.t * Loc.t }
|
||||
end
|
||||
|
||||
module Origin = struct
|
||||
type t =
|
||||
| Unit of { source : Source.t; path : Ns.t } (** Toplevel module. *)
|
||||
| Sub_module
|
||||
| Namespace (** Temporary module from namespace *)
|
||||
| First_class_module (* Not resolved first-class module *)
|
||||
| Arg (** Functor argument *)
|
||||
| Phantom of bool * Divergence.t
|
||||
(** Ambiguous module, that could be an external module *)
|
||||
end
|
||||
|
||||
type 'a t =
|
||||
| Sig : { origin : Origin.t; signature : signature } -> 'a t
|
||||
| Alias : { path : Ns.t; phantom : Divergence.t option } -> extended t
|
||||
| Abstract : Id.t -> 'a t
|
||||
| Functor : 'a t Arg.t option * 'a t -> 'a t
|
||||
| Link : Ns.t -> extended t
|
||||
| Namepace : dictionary -> extended t
|
||||
|
||||
and extended = |
|
||||
and simple = |
|
||||
and dictionary = extended t Mod.Map.t
|
||||
|
||||
and signature =
|
||||
| Unknown
|
||||
| Exact of { me : extended t Mod.Map.t; mt : extended t Mod.Map.t }
|
||||
| Divergence of {
|
||||
point : Divergence.t;
|
||||
before : signature;
|
||||
after : signature;
|
||||
}
|
||||
@ -0,0 +1,16 @@
|
||||
type t =
|
||||
| Ambiguous of {
|
||||
where : Fpath.t * Mml.Loc.t;
|
||||
name : Mod.t;
|
||||
point : Module.Divergence.t;
|
||||
}
|
||||
| Unknown of {
|
||||
where : Fpath.t * Mml.Loc.t;
|
||||
name : Mod.t;
|
||||
level : [ `Impl | `Intf ];
|
||||
}
|
||||
|
||||
let ambiguous ~location ~point name =
|
||||
Ambiguous { where = location; name; point }
|
||||
|
||||
let unknown ~location level name = Unknown { where = location; name; level }
|
||||
@ -0,0 +1,6 @@
|
||||
type t
|
||||
|
||||
val ambiguous :
|
||||
location:Fpath.t * Mml.Loc.t -> point:Module.Divergence.t -> Mod.t -> t
|
||||
|
||||
val unknown : location:Fpath.t * Mml.Loc.t -> [ `Intf | `Impl ] -> Mod.t -> t
|
||||