|
|
|
|
@ -0,0 +1,746 @@
|
|
|
|
|
let merge_minors_and_concat :
|
|
|
|
|
Mml.expression Mml.Loc.t' list ->
|
|
|
|
|
Mml.expression Mml.Loc.t' list ->
|
|
|
|
|
Mml.expression Mml.Loc.t' list =
|
|
|
|
|
fun l0 l1 ->
|
|
|
|
|
match (l0, l1) with
|
|
|
|
|
| ( [ { Mml.Loc.location = loc0; v = Mml.Minor v0 } ],
|
|
|
|
|
{ Mml.Loc.location = loc1; v = Mml.Minor v1 } :: rest ) ->
|
|
|
|
|
Mml.Loc.fmap
|
|
|
|
|
(fun x -> Mml.Minor x)
|
|
|
|
|
Mml.(Annot.merge (Loc.v ~location:loc0 v0) (Loc.v ~location:loc1 v1))
|
|
|
|
|
:: rest
|
|
|
|
|
| _ -> l0 @ l1
|
|
|
|
|
|
|
|
|
|
let rec mmap f = function
|
|
|
|
|
| [] -> []
|
|
|
|
|
| hd :: tl -> merge_minors_and_concat (f hd) (mmap f tl)
|
|
|
|
|
|
|
|
|
|
let minor ~location (x : Mml.minor list) =
|
|
|
|
|
if Mml.Annot.is_empty Mml.Loc.(v ~location:nowhere x) then []
|
|
|
|
|
else [ Mml.Loc.v ~location:(Mml.Loc.of_location location) (Mml.Minor x) ]
|
|
|
|
|
|
|
|
|
|
let access { Location.txt = v; loc } =
|
|
|
|
|
let access_to_path longident =
|
|
|
|
|
let res =
|
|
|
|
|
match longident with
|
|
|
|
|
| Longident.Lident _ | Lapply _ -> None
|
|
|
|
|
| Ldot (t, v) -> Some (t, v)
|
|
|
|
|
in
|
|
|
|
|
Option.map (fun (t, v) -> (With_apply.of_longident t, v)) res
|
|
|
|
|
in
|
|
|
|
|
match access_to_path v with
|
|
|
|
|
| None -> Mml.Annot.empty
|
|
|
|
|
| Some (path, name) ->
|
|
|
|
|
let location = Mml.Loc.of_location loc in
|
|
|
|
|
Mml.Annot.access ~location path name
|
|
|
|
|
|
|
|
|
|
let do_open loc me =
|
|
|
|
|
[ Mml.Loc.v ~location:(Mml.Loc.of_location loc) (Mml.Open me) ]
|
|
|
|
|
|
|
|
|
|
module Pattern = struct
|
|
|
|
|
type bind = Mml.module_expr Mml.bind Mml.Loc.t'
|
|
|
|
|
type t = { binds : bind list; annot : Mml.Annot.t }
|
|
|
|
|
|
|
|
|
|
let empty = { annot = Mml.Annot.empty; binds = [] }
|
|
|
|
|
let access pat = { empty with annot = access pat }
|
|
|
|
|
let of_annot annot = { empty with annot }
|
|
|
|
|
let to_annot { annot; _ } = annot
|
|
|
|
|
|
|
|
|
|
let merge e0 e1 =
|
|
|
|
|
{ annot = Mml.Annot.merge e0.annot e1.annot; binds = e0.binds @ e1.binds }
|
|
|
|
|
|
|
|
|
|
let union_map f = List.fold_left (fun p x -> merge p (f x)) empty
|
|
|
|
|
let option f x = Option.value ~default:empty (Option.map f x)
|
|
|
|
|
|
|
|
|
|
let bind ~location name signature =
|
|
|
|
|
{
|
|
|
|
|
empty with
|
|
|
|
|
binds = [ Mml.Loc.v ~location { Mml.name; expr = signature } ];
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
let open_module m { annot = { Mml.Loc.location; v }; binds } =
|
|
|
|
|
let me_open { Mml.name; expr } =
|
|
|
|
|
{ Mml.name; expr = Mml.Open_me { opens = [ m ]; expr } }
|
|
|
|
|
in
|
|
|
|
|
let md : Mml.module_expr = Ident m.Mml.Loc.v in
|
|
|
|
|
let v =
|
|
|
|
|
match (v, binds) with
|
|
|
|
|
| [], [] ->
|
|
|
|
|
[ Mml.Pack (Mml.Loc.v ~location:m.Mml.Loc.location md) ]
|
|
|
|
|
(* [M.(...nothing)] becomes (module M) *)
|
|
|
|
|
| v, _ -> [ Mml.Local_open (m.Mml.Loc.location, Ident m.Mml.Loc.v, v) ]
|
|
|
|
|
in
|
|
|
|
|
{
|
|
|
|
|
annot = Mml.Loc.v ~location v;
|
|
|
|
|
binds = List.map (Mml.Loc.fmap me_open) binds;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
let bind_fmod p inner =
|
|
|
|
|
let binded x =
|
|
|
|
|
let binder inner b =
|
|
|
|
|
[ Mml.Local_bind (b.Mml.Loc.location, b.Mml.Loc.v, inner) ]
|
|
|
|
|
in
|
|
|
|
|
List.fold_left binder x p.binds
|
|
|
|
|
in
|
|
|
|
|
Mml.Annot.merge p.annot (Mml.Loc.fmap binded inner)
|
|
|
|
|
|
|
|
|
|
let extension ext = of_annot (Mml.Annot.extension ext)
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
open Parsetree
|
|
|
|
|
|
|
|
|
|
let ( ++ ) = Mml.Annot.merge
|
|
|
|
|
let ( <.> ) f g x = f (g x)
|
|
|
|
|
let core_field { Parsetree.pof_desc = Otag (_, t) | Oinherit t; _ } = t
|
|
|
|
|
|
|
|
|
|
let row_field_core x =
|
|
|
|
|
match x.prf_desc with Rtag (_, _, cts) -> cts | Rinherit ct -> [ ct ]
|
|
|
|
|
|
|
|
|
|
let rec signature_item (item : Parsetree.signature_item) =
|
|
|
|
|
let location = Mml.Loc.of_location item.psig_loc in
|
|
|
|
|
let minor { Mml.Loc.v; _ } = minor ~location:item.psig_loc v in
|
|
|
|
|
match item.Parsetree.psig_desc with
|
|
|
|
|
| Psig_value v (* val x : T *) -> minor (core_type v.pval_type)
|
|
|
|
|
| Psig_type (_rec_flag, tds) (* type t1 = ... and ... and tn = ... *) ->
|
|
|
|
|
minor (Mml.Annot.union_map type_declaration tds)
|
|
|
|
|
| Psig_typext te (* type t1 += ... *) -> minor (type_extension te)
|
|
|
|
|
| Psig_exception ec (* exception C of T *) ->
|
|
|
|
|
minor (extension_constructor ec.ptyexn_constructor)
|
|
|
|
|
| Psig_module md (* module X : S *) ->
|
|
|
|
|
[ Mml.Loc.v ~location (Mml.Bind (module_declaration md)) ]
|
|
|
|
|
| Psig_recmodule mds (* module rec X1 : T1 and ... end Xn : Tn *) ->
|
|
|
|
|
(* TODO(dinosaure): coverage. *)
|
|
|
|
|
[ Mml.Loc.v ~location (Mml.Bind_rec (List.map module_declaration mds)) ]
|
|
|
|
|
| Psig_modtype mtd (* module type S = M *) ->
|
|
|
|
|
[ Mml.Loc.v ~location (Mml.Bind_sig (module_type_declaration mtd)) ]
|
|
|
|
|
| Psig_open od (* open X *) -> ident_open od
|
|
|
|
|
| Psig_include id (* include M *) ->
|
|
|
|
|
[ Mml.Loc.v ~location (Mml.Sig_include (module_type id.pincl_mod)) ]
|
|
|
|
|
| Psig_class cds (* class c1 : ... and ... and cn : ... *) ->
|
|
|
|
|
minor (Mml.Annot.union_map class_description cds)
|
|
|
|
|
| Psig_class_type ctds ->
|
|
|
|
|
minor (Mml.Annot.union_map class_type_declaration ctds)
|
|
|
|
|
| Psig_attribute _ -> []
|
|
|
|
|
| Psig_extension (ext, _) -> [ Mml.Loc.v ~location (extension ext) ]
|
|
|
|
|
| Psig_typesubst tds -> minor (Mml.Annot.union_map type_declaration tds)
|
|
|
|
|
| Psig_modsubst msub ->
|
|
|
|
|
let ghost =
|
|
|
|
|
Mml.Bind
|
|
|
|
|
{
|
|
|
|
|
name = Some (Mod.v msub.pms_name.Location.txt);
|
|
|
|
|
expr =
|
|
|
|
|
Mml.Ident
|
|
|
|
|
With_apply.(
|
|
|
|
|
concrete (of_longident msub.pms_manifest.Location.txt));
|
|
|
|
|
}
|
|
|
|
|
in
|
|
|
|
|
do_open msub.pms_loc (Mml.Struct [ Mml.Loc.v ~location ghost ])
|
|
|
|
|
| Psig_modtypesubst mtsub ->
|
|
|
|
|
let ghost = module_type_declaration mtsub in
|
|
|
|
|
do_open mtsub.pmtd_loc
|
|
|
|
|
(Mml.Struct [ Mml.Loc.v ~location (Mml.Bind_sig ghost) ])
|
|
|
|
|
|
|
|
|
|
and pattern pat =
|
|
|
|
|
let location = Mml.Loc.of_location pat.ppat_loc in
|
|
|
|
|
match pat.ppat_desc with
|
|
|
|
|
| Ppat_constant _ (* 1, 'a', "true", 1.0, 1l, 1L, 1n *)
|
|
|
|
|
| Ppat_interval _ (* 'a' .. 'z' *) | Ppat_any | Ppat_var _ (* x *) ->
|
|
|
|
|
Pattern.empty
|
|
|
|
|
| Ppat_extension ext ->
|
|
|
|
|
Pattern.extension (Mml.Loc.v ~location (extension_core ext))
|
|
|
|
|
| Ppat_exception pat (* exception E *)
|
|
|
|
|
| Ppat_lazy pat (* lazy p *)
|
|
|
|
|
| Ppat_alias (pat, _) (* P as 'a *) ->
|
|
|
|
|
pattern pat
|
|
|
|
|
| Ppat_array patterns (* [| P1; ...; Pn |] *)
|
|
|
|
|
| Ppat_tuple patterns (* (P1, ..., Pn) *) ->
|
|
|
|
|
Pattern.union_map pattern patterns
|
|
|
|
|
| Ppat_construct (c, p) (* >= 4.13.0 *) ->
|
|
|
|
|
(* C None
|
|
|
|
|
C P Some P
|
|
|
|
|
C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn])
|
|
|
|
|
C (type a b) P Some ([a; b], P) *)
|
|
|
|
|
Pattern.(merge (access c) (option pattern (Option.map snd p)))
|
|
|
|
|
| Ppat_variant (_, p) (* `A (None), `A P (Some P) *) ->
|
|
|
|
|
Pattern.option pattern p
|
|
|
|
|
| Ppat_record (fields, _flag) ->
|
|
|
|
|
(* { l1= P1; ...; ln= Pn } (flag= Closed)
|
|
|
|
|
{ l1= P1; ...; ln= Pn; _ } (flag= Open) *)
|
|
|
|
|
Pattern.union_map
|
|
|
|
|
Pattern.(fun (label, p) -> merge (pattern p) (access label))
|
|
|
|
|
fields
|
|
|
|
|
| Ppat_or (p1, p2) (* P1 | P2 *) -> Pattern.merge (pattern p1) (pattern p2)
|
|
|
|
|
| Ppat_constraint
|
|
|
|
|
({ ppat_desc = Ppat_unpack name; _ }, { ptyp_desc = Ptyp_package s; _ })
|
|
|
|
|
->
|
|
|
|
|
let name = Option.map Mod.v name.Location.txt in
|
|
|
|
|
let mt, others = full_package_type s in
|
|
|
|
|
let expr : Mml.module_expr = Mml.Constraint (Mml.Unpacked, mt) in
|
|
|
|
|
let bind = { Mml.name; expr } in
|
|
|
|
|
{ others with binds = [ Mml.Loc.v ~location bind ] }
|
|
|
|
|
(* TODO(dinosaure): catch higher up *)
|
|
|
|
|
| Ppat_constraint (pat, ct) (* (P : T) *) ->
|
|
|
|
|
Pattern.(merge (pattern pat) (of_annot (core_type ct)))
|
|
|
|
|
| Ppat_type name (* #v *) -> Pattern.access name
|
|
|
|
|
| Ppat_unpack m ->
|
|
|
|
|
(* TODO(dinosaure): first class module, coverage. *)
|
|
|
|
|
Pattern.bind ~location (Option.map Mod.v m.Location.txt) Mml.Unpacked
|
|
|
|
|
| Ppat_open (m, p) (* M.(P) *) ->
|
|
|
|
|
Pattern.open_module
|
|
|
|
|
(Mml.Loc.v ~location
|
|
|
|
|
With_apply.(concrete (of_longident m.Location.txt)))
|
|
|
|
|
(pattern p)
|
|
|
|
|
|
|
|
|
|
and full_package_type (s, constraints) =
|
|
|
|
|
( Ident (With_apply.of_longident s.Location.txt),
|
|
|
|
|
Pattern.of_annot (Mml.Annot.union_map (core_type <.> snd) constraints) )
|
|
|
|
|
|
|
|
|
|
and module_declaration mdec =
|
|
|
|
|
let s = module_type mdec.pmd_type in
|
|
|
|
|
{
|
|
|
|
|
name = Option.map Mod.v mdec.pmd_name.Location.txt;
|
|
|
|
|
expr = Constraint (Abstract, s);
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
and module_expr me : Mml.module_expr =
|
|
|
|
|
match me.pmod_desc with
|
|
|
|
|
| Pmod_ident lid (* A *) ->
|
|
|
|
|
Mml.Ident With_apply.(concrete (of_longident lid.Location.txt))
|
|
|
|
|
| Pmod_structure str (* struct ... end *) -> Struct (structure str)
|
|
|
|
|
| Pmod_functor (Named (name, mt), mex) (* functor (X : S) -> M *) ->
|
|
|
|
|
let name = Option.map Mod.v name.Location.txt in
|
|
|
|
|
let arg = Some { Mml.Arg.name; signature = module_type mt } in
|
|
|
|
|
Functor { arg; body = module_expr mex }
|
|
|
|
|
| Pmod_functor (Unit, mex) (* functor () -> M *) ->
|
|
|
|
|
Functor { arg = None; body = module_expr mex }
|
|
|
|
|
| Pmod_apply (f, x) (* F(X) *) ->
|
|
|
|
|
Apply { f = module_expr f; x = module_expr x }
|
|
|
|
|
| Pmod_constraint (me, mt) -> Constraint (module_expr me, module_type mt)
|
|
|
|
|
| Pmod_unpack
|
|
|
|
|
{
|
|
|
|
|
pexp_desc = Pexp_constraint (inner, { ptyp_desc = Ptyp_package s; _ });
|
|
|
|
|
_;
|
|
|
|
|
}
|
|
|
|
|
(* (val M : S) *) ->
|
|
|
|
|
Constraint (Val (expr inner).Mml.Loc.v, fst (full_package_type s))
|
|
|
|
|
| Pmod_unpack e (* (val M) *) -> Val (expr e).Mml.Loc.v
|
|
|
|
|
| Pmod_extension ext -> Extension_node (extension_core ext)
|
|
|
|
|
|
|
|
|
|
and extension_core (name, payload) =
|
|
|
|
|
let name = name.Location.txt in
|
|
|
|
|
match payload with
|
|
|
|
|
| PSig s -> { extension = Module (signature s); name }
|
|
|
|
|
| PStr s -> { extension = Module (structure s); name }
|
|
|
|
|
| PTyp c -> { extension = Val (core_type c).Mml.Loc.v; name }
|
|
|
|
|
| PPat (p, eo) ->
|
|
|
|
|
{
|
|
|
|
|
extension =
|
|
|
|
|
Val
|
|
|
|
|
(Pattern.to_annot (pattern p) ++ Mml.Annot.option expr eo).Mml.Loc.v;
|
|
|
|
|
name;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
and module_type (mt : Parsetree.module_type) =
|
|
|
|
|
match mt.pmty_desc with
|
|
|
|
|
| Pmty_signature s (* sig ... end *) -> Mml.Sig (signature s)
|
|
|
|
|
| Pmty_functor (Unit, res) (* functor () -> S' *) ->
|
|
|
|
|
Mml.Functor { arg = None; body = module_type res }
|
|
|
|
|
| Pmty_functor (Named (name, s), res) (* functor (X : S) -> S' *) ->
|
|
|
|
|
let arg =
|
|
|
|
|
Some
|
|
|
|
|
{
|
|
|
|
|
Mml.Arg.name = Option.map Mod.v name.Location.txt;
|
|
|
|
|
signature = module_type s;
|
|
|
|
|
}
|
|
|
|
|
in
|
|
|
|
|
Mml.Functor { arg; body = module_type res }
|
|
|
|
|
| Pmty_with (mt, with_constraints) (* X with ... *) ->
|
|
|
|
|
With
|
|
|
|
|
{
|
|
|
|
|
body = module_type mt;
|
|
|
|
|
with_constraints = List.map with_constraint with_constraints;
|
|
|
|
|
}
|
|
|
|
|
| Pmty_typeof me (* module type of M *) -> Of (module_expr me)
|
|
|
|
|
| Pmty_extension ext (* [%id] *) -> Extension_node (extension_core ext)
|
|
|
|
|
| Pmty_alias lid ->
|
|
|
|
|
Alias With_apply.(concrete (of_longident lid.Location.txt))
|
|
|
|
|
| Pmty_ident lid (* S *) -> Ident (With_apply.of_longident lid.Location.txt)
|
|
|
|
|
|
|
|
|
|
and with_constraint = function
|
|
|
|
|
| Pwith_typesubst (lhs, td) (* with type X.t := ... *) ->
|
|
|
|
|
let path = With_apply.(concrete (of_longident lhs.Location.txt)) in
|
|
|
|
|
let name = Mod.Path.head path in
|
|
|
|
|
Constraint
|
|
|
|
|
(Type (Some path, name), true, Type (type_declaration td).Mml.Loc.v)
|
|
|
|
|
| Pwith_type (lhs, td) (* with type X.t = ... *) ->
|
|
|
|
|
let path = With_apply.(concrete (of_longident lhs.Location.txt)) in
|
|
|
|
|
let name = Mod.Path.head path in
|
|
|
|
|
Constraint
|
|
|
|
|
(Type (Some path, name), false, Type (type_declaration td).Mml.Loc.v)
|
|
|
|
|
| Pwith_module (lhs, rhs) (* with module X.Y = Z *) ->
|
|
|
|
|
let location = Mml.Loc.of_location rhs.Location.loc in
|
|
|
|
|
let lhs = With_apply.(concrete (of_longident lhs.Location.txt)) in
|
|
|
|
|
let rhs = With_apply.(concrete (of_longident rhs.Location.txt)) in
|
|
|
|
|
Constraint (Module lhs, false, Module (Mml.Loc.v ~location rhs))
|
|
|
|
|
| Pwith_modsubst (lhs, rhs) (* with module X.Y := Z *) ->
|
|
|
|
|
let location = Mml.Loc.of_location rhs.Location.loc in
|
|
|
|
|
let lhs = With_apply.(concrete (of_longident lhs.Location.txt)) in
|
|
|
|
|
let rhs = With_apply.(concrete (of_longident rhs.Location.txt)) in
|
|
|
|
|
Constraint (Module lhs, true, Module (Mml.Loc.v ~location rhs))
|
|
|
|
|
| Pwith_modtype (lhs, rhs) (* with module X.Y = Z.s *) ->
|
|
|
|
|
let lhs = With_apply.(concrete (of_longident lhs.Location.txt)) in
|
|
|
|
|
Constraint (Module lhs, false, Module_type (module_type rhs))
|
|
|
|
|
| Pwith_modtypesubst (lhs, rhs) (* with module X.Y := Z.s *) ->
|
|
|
|
|
let lhs = With_apply.(concrete (of_longident lhs.Location.txt)) in
|
|
|
|
|
Constraint (Module lhs, true, Module_type (module_type rhs))
|
|
|
|
|
|
|
|
|
|
and type_declaration td : Mml.Annot.t =
|
|
|
|
|
Mml.Annot.union_map (fun (_, t, _) -> core_type t) td.ptype_cstrs
|
|
|
|
|
++
|
|
|
|
|
if td.ptype_kind = Ptype_abstract then
|
|
|
|
|
Mml.Annot.option (Mml.Annot.promote <.> core_type) td.ptype_manifest
|
|
|
|
|
else type_kind td.ptype_kind ++ Mml.Annot.option core_type td.ptype_manifest
|
|
|
|
|
|
|
|
|
|
and type_extension tyext : Mml.Annot.t =
|
|
|
|
|
access tyext.ptyext_path
|
|
|
|
|
++ Mml.Annot.union_map extension_constructor tyext.ptyext_constructors
|
|
|
|
|
|
|
|
|
|
and type_kind = function
|
|
|
|
|
| Ptype_abstract | Ptype_open -> Mml.Annot.empty
|
|
|
|
|
| Ptype_variant constructor_declarations ->
|
|
|
|
|
Mml.Annot.union_map constructor_declaration constructor_declarations
|
|
|
|
|
| Ptype_record label_declarations ->
|
|
|
|
|
Mml.Annot.union_map label_declaration label_declarations
|
|
|
|
|
|
|
|
|
|
and constructor_declaration cd =
|
|
|
|
|
Mml.Annot.option core_type cd.pcd_res ++ constructor_args cd.pcd_args
|
|
|
|
|
|
|
|
|
|
and extension_constructor extc : Mml.Annot.t =
|
|
|
|
|
match extc.pext_kind with
|
|
|
|
|
| Pext_decl (_vars, args, cto) (* >= 4.14.0 *) ->
|
|
|
|
|
constructor_args args ++ Mml.Annot.option core_type cto
|
|
|
|
|
| Pext_rebind name -> access name
|
|
|
|
|
|
|
|
|
|
and constructor_args = function
|
|
|
|
|
| Pcstr_tuple cts -> Mml.Annot.union_map core_type cts
|
|
|
|
|
| Pcstr_record lds -> Mml.Annot.union_map label_declaration lds
|
|
|
|
|
|
|
|
|
|
and label_declaration ld = core_type ld.pld_type
|
|
|
|
|
and signature sign = mmap signature_item sign
|
|
|
|
|
|
|
|
|
|
and core_type ct : Mml.Annot.t =
|
|
|
|
|
let location = Mml.Loc.of_location ct.ptyp_loc in
|
|
|
|
|
match ct.ptyp_desc with
|
|
|
|
|
| Ptyp_any (* _ *) | Ptyp_var _ (* 'a *) -> Mml.Annot.empty
|
|
|
|
|
| Ptyp_arrow (_, v0, v1) (* v0 -> v1 *) -> core_type v0 ++ core_type v1
|
|
|
|
|
| Ptyp_tuple cts (* t0 * .. * tn *) -> Mml.Annot.union_map core_type cts
|
|
|
|
|
| Ptyp_class (name, cts) | Ptyp_constr (name, cts) ->
|
|
|
|
|
access name ++ Mml.Annot.union_map core_type cts
|
|
|
|
|
| Ptyp_object (labels, _) (* < l1:t1; ...; ln:tn[; ..] > *) ->
|
|
|
|
|
Mml.Annot.union_map (core_type <.> core_field) labels
|
|
|
|
|
| Ptyp_poly (_, ct) | Ptyp_alias (ct, _) (* t as 'a *) -> core_type ct
|
|
|
|
|
| Ptyp_variant (row_fields, _, _labels) ->
|
|
|
|
|
Mml.Annot.union_map row_field row_fields
|
|
|
|
|
| Ptyp_package s (* (module S) *) -> package_type s
|
|
|
|
|
| Ptyp_extension ext (* [%id] *) ->
|
|
|
|
|
Mml.Annot.extension (Mml.Loc.v ~location (extension_core ext))
|
|
|
|
|
|
|
|
|
|
and row_field x = Mml.Annot.union_map core_type (row_field_core x)
|
|
|
|
|
|
|
|
|
|
and package_type (s, constraints) =
|
|
|
|
|
Mml.Annot.merge (access s)
|
|
|
|
|
(Mml.Annot.union_map (core_type <.> snd) constraints)
|
|
|
|
|
|
|
|
|
|
and structure str = mmap structure_item str
|
|
|
|
|
|
|
|
|
|
and structure_item item =
|
|
|
|
|
let location = Mml.Loc.of_location item.pstr_loc in
|
|
|
|
|
let minor { Mml.Loc.v; _ } = minor ~location:item.pstr_loc v in
|
|
|
|
|
match item.pstr_desc with
|
|
|
|
|
| Pstr_eval (exp, _attrs) (* ;; expr [@@attrs] *) -> minor (expr exp)
|
|
|
|
|
| Pstr_value (_rec_flag, vals) ->
|
|
|
|
|
(* let P1 = E1 and ... and Pn = En (flag= Nonrecursive)
|
|
|
|
|
let rec P1 = E1 and ... end Pn = En (flag= Recursive) *)
|
|
|
|
|
minor
|
|
|
|
|
(Mml.Annot.union_map
|
|
|
|
|
(Pattern.to_annot <.> val_binding <.> vb_pair)
|
|
|
|
|
vals)
|
|
|
|
|
| Pstr_primitive desc ->
|
|
|
|
|
(* val x : T
|
|
|
|
|
external x : T = "s1" ... "sn" *)
|
|
|
|
|
minor (core_type desc.pval_type)
|
|
|
|
|
| Pstr_type (_rec_flag, type_declarations) ->
|
|
|
|
|
(* type t1 = ... and ... and tn = ... *)
|
|
|
|
|
minor (Mml.Annot.union_map type_declaration type_declarations)
|
|
|
|
|
| Pstr_typext t (* type t1 += ... *) -> minor (type_extension t)
|
|
|
|
|
| Pstr_exception ec ->
|
|
|
|
|
(* exception C of T
|
|
|
|
|
exception C = M.X *)
|
|
|
|
|
minor (extension_constructor ec.ptyexn_constructor)
|
|
|
|
|
| Pstr_module mb (* module X = M *) ->
|
|
|
|
|
[ Mml.Loc.v ~location (Mml.Bind (module_binding_raw mb)) ]
|
|
|
|
|
| Pstr_recmodule module_bindings (* module rec X1 = E1 and ... and Xn = En *)
|
|
|
|
|
->
|
|
|
|
|
rec_modules module_bindings
|
|
|
|
|
| Pstr_modtype mt (* module type s = ... *) ->
|
|
|
|
|
[ Mml.Loc.v ~location (Mml.Bind_sig (module_type_declaration mt)) ]
|
|
|
|
|
| Pstr_open open_desc (* open M *) -> simple_open open_desc
|
|
|
|
|
| Pstr_class class_declarations (* class c1 = ... and ... and cn = ... *) ->
|
|
|
|
|
let v = Mml.Annot.union_map class_declaration class_declarations in
|
|
|
|
|
if Mml.Annot.is_empty v then []
|
|
|
|
|
else [ Mml.Loc.fmap (fun v -> Mml.Minor v) v ]
|
|
|
|
|
| Pstr_class_type ct ->
|
|
|
|
|
(* class type ct1 = ... and ... and ctn = ... *)
|
|
|
|
|
let v = Mml.Annot.union_map class_type_declaration ct in
|
|
|
|
|
if Mml.Annot.is_empty v then []
|
|
|
|
|
else [ Mml.Loc.fmap (fun v -> Mml.Minor v) v ]
|
|
|
|
|
| Pstr_include inc (* include M *) -> do_include inc
|
|
|
|
|
| Pstr_attribute _ -> []
|
|
|
|
|
| Pstr_extension (ext, _) (* [%%id] *) ->
|
|
|
|
|
[ Mml.Loc.v ~location (extension ext) ]
|
|
|
|
|
|
|
|
|
|
and rec_modules mbs =
|
|
|
|
|
let location =
|
|
|
|
|
List.fold_left Mml.Loc.choose Mml.Loc.nowhere
|
|
|
|
|
(List.map (fun mb -> Mml.Loc.of_location mb.pmb_loc) mbs)
|
|
|
|
|
in
|
|
|
|
|
[ Mml.Loc.v ~location (Mml.Bind_rec (List.map module_binding_raw mbs)) ]
|
|
|
|
|
|
|
|
|
|
and module_type_declaration mdec =
|
|
|
|
|
let name = Mod.v mdec.pmtd_name.Location.txt in
|
|
|
|
|
let expr =
|
|
|
|
|
let ( >>| ) x f = Option.map f x in
|
|
|
|
|
Option.value ~default:Abstract (mdec.pmtd_type >>| module_type)
|
|
|
|
|
in
|
|
|
|
|
{ Mml.name = Some name; expr }
|
|
|
|
|
|
|
|
|
|
and expr e =
|
|
|
|
|
let location = Mml.Loc.of_location e.pexp_loc in
|
|
|
|
|
match e.pexp_desc with
|
|
|
|
|
| Pexp_ident name (* x, M.x *) -> access name
|
|
|
|
|
| Pexp_let (_rec_flag, vbs, exp) ->
|
|
|
|
|
(* let P1 = E1 and ... and Pn = En in E (flag= Nonrecursive)
|
|
|
|
|
let rec P1 = E1 and ... end Pn = En in E (flag= Recursive) *)
|
|
|
|
|
Mml.Loc.v ~location (value_bindings vbs (expr exp)).Mml.Loc.v
|
|
|
|
|
| Pexp_function cases (* function P1 -> E1 | ... | Pn -> En *) ->
|
|
|
|
|
Mml.Annot.union_map case cases
|
|
|
|
|
| Pexp_fun (_arg_label, expr_opt, pat, exp) ->
|
|
|
|
|
(* fun P -> E1
|
|
|
|
|
fun ~l:P -> E1
|
|
|
|
|
fun ?l:P -> E1
|
|
|
|
|
fun ?l:(P = E0) -> E1
|
|
|
|
|
|
|
|
|
|
Notes:
|
|
|
|
|
- If E0 is provided, only Optional is allowed.
|
|
|
|
|
- "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun.
|
|
|
|
|
- "let f P = E" is represented using Pexp_fun. *)
|
|
|
|
|
Mml.Annot.option expr expr_opt
|
|
|
|
|
++ Pattern.bind_fmod (pattern pat) (expr exp)
|
|
|
|
|
| Pexp_apply (exp, args) ->
|
|
|
|
|
(* E0 ~l1:E1 ... ~ln:En
|
|
|
|
|
l[i] can be empty (non labeled argument) or start with '?'
|
|
|
|
|
(optional argument).
|
|
|
|
|
|
|
|
|
|
Invariant: n > 0 *)
|
|
|
|
|
expr exp ++ Mml.Annot.union_map (expr <.> snd) args
|
|
|
|
|
| Pexp_match (exp, cases) (* match E0 with P1 -> E1 | ... | Pn -> En *)
|
|
|
|
|
| Pexp_try (exp, cases) (* try E0 with P1 -> E1 | ... | Pn -> En *) ->
|
|
|
|
|
expr exp ++ Mml.Annot.union_map case cases
|
|
|
|
|
| Pexp_tuple exp (* (E1, ..., En) Invariant: n >= 2 *) ->
|
|
|
|
|
Mml.Annot.union_map expr exp
|
|
|
|
|
| Pexp_construct (constr, expr_opt) -> (
|
|
|
|
|
(* C None
|
|
|
|
|
C E Some E
|
|
|
|
|
C (E1, ..., En) Some (Pexp_tuple [E1;...;En]) *)
|
|
|
|
|
match expr_opt with
|
|
|
|
|
| Some e -> access constr ++ expr e
|
|
|
|
|
| None -> access constr)
|
|
|
|
|
| Pexp_variant (_label, eo) ->
|
|
|
|
|
(* `A (None)
|
|
|
|
|
`A E (Some E) *)
|
|
|
|
|
Mml.Annot.option expr eo
|
|
|
|
|
| Pexp_record (labels, eo) ->
|
|
|
|
|
(* { l1=P1; ...; ln=Pn } (None)
|
|
|
|
|
{ E0 with l1=P1; ...; ln=Pn } (Some E0)
|
|
|
|
|
|
|
|
|
|
Invariant: n > 0 *)
|
|
|
|
|
Mml.Annot.option expr eo
|
|
|
|
|
++ Mml.Annot.union_map
|
|
|
|
|
(fun (label, exp) -> access label ++ expr exp)
|
|
|
|
|
labels
|
|
|
|
|
| Pexp_field (exp, field) (* E.l *) -> access field ++ expr exp
|
|
|
|
|
| Pexp_setfield (e1, field, e2) (* E1.l <- E2 *) ->
|
|
|
|
|
access field ++ expr e1 ++ expr e2
|
|
|
|
|
| Pexp_array es (* [| E1; ...; En |] *) -> Mml.Annot.union_map expr es
|
|
|
|
|
| Pexp_ifthenelse (e1, e2, e3) (* if E1 then E2 else E3 *) ->
|
|
|
|
|
expr e1 ++ expr e2 ++ Mml.Annot.option expr e3
|
|
|
|
|
| Pexp_sequence (e1, e2) (* E1; E2 *) -> expr e1 ++ expr e2
|
|
|
|
|
| Pexp_while (e1, e2) (* while E1 do E2 done *) -> expr e1 ++ expr e2
|
|
|
|
|
| Pexp_for (pat, e1, e2, _, e3) ->
|
|
|
|
|
(* for pat = E1 to E2 do E3 done (flag= Upto)
|
|
|
|
|
for pat = E1 downto E2 do E3 done (flag= Downto) *)
|
|
|
|
|
Pattern.to_annot (pattern pat) ++ expr e1 ++ expr e2 ++ expr e3
|
|
|
|
|
| Pexp_constraint (e, t) (* (E : T) *) -> expr e ++ core_type t
|
|
|
|
|
| Pexp_coerce (e, t_opt, coer) ->
|
|
|
|
|
(* (E :> T) (None, T)
|
|
|
|
|
(E : T0 :> T) (Some T0, T) *)
|
|
|
|
|
expr e ++ Mml.Annot.option core_type t_opt ++ core_type coer
|
|
|
|
|
| Pexp_new name (* new M.c *) -> access name
|
|
|
|
|
| Pexp_setinstvar (_x, e) (* x <- e *) -> expr e
|
|
|
|
|
| Pexp_override labels (* {< x1 = E1; ...; Xn = En >} *) ->
|
|
|
|
|
Mml.Annot.union_map (expr <.> snd) labels
|
|
|
|
|
| Pexp_letmodule (m, me, e) (* let module M = ME in E *) ->
|
|
|
|
|
Mml.Loc.v ~location
|
|
|
|
|
[
|
|
|
|
|
Mml.Local_bind (location, module_binding (m, me), (expr e).Mml.Loc.v);
|
|
|
|
|
]
|
|
|
|
|
| Pexp_letexception (_c, e) (* let exception C in E *) -> expr e
|
|
|
|
|
| Pexp_send (e, _) (* E # m *)
|
|
|
|
|
| Pexp_assert e (* assert E *)
|
|
|
|
|
| Pexp_newtype (_, e) (* fun (type t) -> E *)
|
|
|
|
|
| Pexp_lazy e (* lazy E *) ->
|
|
|
|
|
expr e
|
|
|
|
|
| Pexp_poly (e, ct_opt) -> expr e ++ Mml.Annot.option core_type ct_opt
|
|
|
|
|
| Pexp_object clstr (* object ... end *) -> class_structure clstr
|
|
|
|
|
| Pexp_pack me (* (module ME) *) ->
|
|
|
|
|
(* TODO(dinosaure): are all cases caught by the [Module.approximation] mechanism? *)
|
|
|
|
|
Mml.Annot.pack (Mml.Loc.v ~location (module_expr me))
|
|
|
|
|
| Pexp_open (me, e) ->
|
|
|
|
|
(* M.(E), let open M in E, let! open M in E *)
|
|
|
|
|
Mml.Annot.local_open
|
|
|
|
|
(Mml.Loc.of_location me.popen_loc)
|
|
|
|
|
(local_open_arg me) (expr e)
|
|
|
|
|
| Pexp_constant _ | Pexp_unreachable (* . *) -> Mml.Annot.empty
|
|
|
|
|
| Pexp_extension ext (* [%ext] *) ->
|
|
|
|
|
Mml.Annot.extension (Mml.Loc.v ~location (extension_core ext))
|
|
|
|
|
| Pexp_letop b ->
|
|
|
|
|
val_bindings
|
|
|
|
|
(fun bop -> (bop.pbop_pat, bop.pbop_exp))
|
|
|
|
|
(b.let_ :: b.ands) (expr b.body)
|
|
|
|
|
|
|
|
|
|
and case cs =
|
|
|
|
|
Mml.Annot.option expr cs.pc_guard
|
|
|
|
|
++ Pattern.bind_fmod (pattern cs.pc_lhs) (expr cs.pc_rhs)
|
|
|
|
|
|
|
|
|
|
and module_binding_raw mb = module_binding (mb.pmb_name, mb.pmb_expr)
|
|
|
|
|
|
|
|
|
|
and module_binding (pmb_name, pmb_expr) =
|
|
|
|
|
{
|
|
|
|
|
Mml.name = Option.map Mod.v pmb_name.Location.txt;
|
|
|
|
|
expr = module_expr pmb_expr;
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
and val_binding (patt, expr) : Pattern.t =
|
|
|
|
|
let p, e = matched_patt_expr patt expr in
|
|
|
|
|
Pattern.(merge p (of_annot e))
|
|
|
|
|
|
|
|
|
|
and val_bindings : 'a. ('a -> pattern * Parsetree.expression) -> 'a list -> _ =
|
|
|
|
|
fun proj vbs expr ->
|
|
|
|
|
let p = Pattern.union_map (val_binding <.> proj) vbs in
|
|
|
|
|
let v =
|
|
|
|
|
let binder inner b =
|
|
|
|
|
[ Mml.Local_bind (b.Mml.Loc.location, b.Mml.Loc.v, inner) ]
|
|
|
|
|
in
|
|
|
|
|
List.fold_left binder expr.Mml.Loc.v p.binds
|
|
|
|
|
in
|
|
|
|
|
Pattern.to_annot p ++ Mml.Loc.v ~location:expr.Mml.Loc.location v
|
|
|
|
|
|
|
|
|
|
and vb_pair x = (x.pvb_pat, x.pvb_expr)
|
|
|
|
|
|
|
|
|
|
and matched_patt_expr x y =
|
|
|
|
|
(* matched_patt_expr is used to catch some case of packed module
|
|
|
|
|
where the module signature is provided not on the pattern side
|
|
|
|
|
but on the expression side. *)
|
|
|
|
|
match (x.ppat_desc, y.pexp_desc) with
|
|
|
|
|
| Ppat_constraint _, Pexp_constraint _ -> (pattern x, expr y)
|
|
|
|
|
| _, Pexp_constraint (_, t) ->
|
|
|
|
|
(pattern { x with ppat_desc = Ppat_constraint (x, t) }, expr y)
|
|
|
|
|
| Ppat_construct (_, po), Pexp_construct (_, eo) ->
|
|
|
|
|
let po = Option.map snd po in
|
|
|
|
|
let ( >>= ) = Option.bind and ( >>| ) x f = Option.map f x in
|
|
|
|
|
Option.value
|
|
|
|
|
~default:(Pattern.option pattern po, Mml.Annot.option expr eo)
|
|
|
|
|
( po >>= fun p ->
|
|
|
|
|
eo >>| fun e -> matched_patt_expr p e )
|
|
|
|
|
| _, _ -> (pattern x, expr y)
|
|
|
|
|
|
|
|
|
|
and simple_open o = do_open o.popen_loc (module_expr o.popen_expr)
|
|
|
|
|
and class_declaration cd = class_expr cd.pci_expr
|
|
|
|
|
and class_structure ct = Mml.Annot.union_map class_field ct.pcstr_fields
|
|
|
|
|
|
|
|
|
|
and class_field field =
|
|
|
|
|
match field.pcf_desc with
|
|
|
|
|
| Pcf_inherit (_override_flag, ce, _) (* inherit CE *) -> class_expr ce
|
|
|
|
|
| Pcf_method (_, _, cfk) | Pcf_val (_, _, cfk) (* val x = E *) ->
|
|
|
|
|
class_field_kind cfk
|
|
|
|
|
| Pcf_constraint (_, ct) (* constraint T1 = T2 *) -> core_type ct
|
|
|
|
|
| Pcf_initializer e (* initializer E *) -> expr e
|
|
|
|
|
| Pcf_attribute _ -> Mml.Annot.empty
|
|
|
|
|
| Pcf_extension ext ->
|
|
|
|
|
Mml.Annot.extension
|
|
|
|
|
(Mml.Loc.v
|
|
|
|
|
~location:(Mml.Loc.of_location field.pcf_loc)
|
|
|
|
|
(extension_core ext))
|
|
|
|
|
|
|
|
|
|
and class_expr ce =
|
|
|
|
|
let loc = ce.pcl_loc in
|
|
|
|
|
match ce.pcl_desc with
|
|
|
|
|
| Pcl_constr (name, cts) (* ['a1, ..., 'an] c *) ->
|
|
|
|
|
access name ++ Mml.Annot.union_map core_type cts
|
|
|
|
|
| Pcl_structure cs (* object ... end *) -> class_structure cs
|
|
|
|
|
| Pcl_fun (_arg_label, eo, pat, ce) ->
|
|
|
|
|
(* fun P -> CE (Simple, None)
|
|
|
|
|
fun ~l:P -> CE (Labelled l, None)
|
|
|
|
|
fun ?l:P -> CE (Optional l, None)
|
|
|
|
|
fun ?l:(P = E0) -> CE (Optional l, Some E0) *)
|
|
|
|
|
Mml.Annot.merge (Mml.Annot.option expr eo)
|
|
|
|
|
(Pattern.bind_fmod (pattern pat) (class_expr ce))
|
|
|
|
|
| Pcl_apply (ce, les) ->
|
|
|
|
|
(* CE ~l1:E1 ... ~ln:En
|
|
|
|
|
l1 can be empty (non labeled argument) or start with '?'
|
|
|
|
|
(optional argument).
|
|
|
|
|
|
|
|
|
|
Invariant: n > 0 *)
|
|
|
|
|
Mml.Annot.union_map (expr <.> snd) les ++ class_expr ce
|
|
|
|
|
| Pcl_let (_, vbs, ce) (* let P1 = E1 and .. and Pn = En in CE *) ->
|
|
|
|
|
Mml.Loc.v ~location:(Mml.Loc.of_location loc)
|
|
|
|
|
(value_bindings vbs (class_expr ce)).Mml.Loc.v
|
|
|
|
|
| Pcl_constraint (ce, ct) -> class_type ct ++ class_expr ce
|
|
|
|
|
| Pcl_extension ext ->
|
|
|
|
|
Mml.Annot.extension
|
|
|
|
|
(Mml.Loc.v ~location:(Mml.Loc.of_location loc) (extension_core ext))
|
|
|
|
|
| Pcl_open (m, cl) ->
|
|
|
|
|
let path =
|
|
|
|
|
With_apply.(concrete (of_longident m.popen_expr.Location.txt))
|
|
|
|
|
in
|
|
|
|
|
Mml.Annot.local_open
|
|
|
|
|
(Mml.Loc.of_location m.popen_loc)
|
|
|
|
|
(Mml.Ident path) (class_expr cl)
|
|
|
|
|
|
|
|
|
|
and class_field_kind = function
|
|
|
|
|
| Cfk_virtual ct -> core_type ct
|
|
|
|
|
| Cfk_concrete (_, e) -> expr e
|
|
|
|
|
|
|
|
|
|
and value_bindings x = val_bindings vb_pair x
|
|
|
|
|
|
|
|
|
|
and class_type ct =
|
|
|
|
|
match ct.pcty_desc with
|
|
|
|
|
| Pcty_constr (name, cts) (* c ['a1, ..., 'an] c *) ->
|
|
|
|
|
Mml.Annot.merge (access name) (Mml.Annot.union_map core_type cts)
|
|
|
|
|
| Pcty_signature cs (* object ... end *) -> class_signature cs
|
|
|
|
|
| Pcty_arrow (_arg_label, ct, clt) (* ^T -> CT *) ->
|
|
|
|
|
class_type clt ++ core_type ct
|
|
|
|
|
| Pcty_extension ext (* [%ext] *) ->
|
|
|
|
|
Mml.Annot.extension
|
|
|
|
|
(Mml.Loc.v
|
|
|
|
|
~location:(Mml.Loc.of_location ct.pcty_loc)
|
|
|
|
|
(extension_core ext))
|
|
|
|
|
| Pcty_open (m, cty) ->
|
|
|
|
|
let path =
|
|
|
|
|
With_apply.(concrete (of_longident m.popen_expr.Location.txt))
|
|
|
|
|
in
|
|
|
|
|
Mml.Annot.local_open
|
|
|
|
|
(Mml.Loc.of_location m.popen_loc)
|
|
|
|
|
(Mml.Ident path) (class_type cty)
|
|
|
|
|
|
|
|
|
|
and class_signature cs = Mml.Annot.union_map class_type_field cs.pcsig_fields
|
|
|
|
|
|
|
|
|
|
and class_type_field ctf =
|
|
|
|
|
match ctf.pctf_desc with
|
|
|
|
|
| Pctf_inherit ct -> class_type ct
|
|
|
|
|
| Pctf_val (_, _, _, ct) (* val x : T *)
|
|
|
|
|
| Pctf_method (_, _, _, ct) (* method x : T *) ->
|
|
|
|
|
core_type ct
|
|
|
|
|
| Pctf_constraint (t1, t2) (* constraint T1 = T2 *) ->
|
|
|
|
|
core_type t2 ++ core_type t1
|
|
|
|
|
| Pctf_attribute _ -> Mml.Annot.empty
|
|
|
|
|
| Pctf_extension ext ->
|
|
|
|
|
Mml.Annot.extension
|
|
|
|
|
(Mml.Loc.v
|
|
|
|
|
~location:(Mml.Loc.of_location ctf.pctf_loc)
|
|
|
|
|
(extension_core ext))
|
|
|
|
|
|
|
|
|
|
and class_type_declaration ctf = class_type ctf.pci_expr
|
|
|
|
|
and class_description x = class_type_declaration x
|
|
|
|
|
|
|
|
|
|
and do_include incl =
|
|
|
|
|
[
|
|
|
|
|
Mml.Loc.v
|
|
|
|
|
~location:(Mml.Loc.of_location incl.pincl_loc)
|
|
|
|
|
(Mml.Include (module_expr incl.pincl_mod));
|
|
|
|
|
]
|
|
|
|
|
|
|
|
|
|
and extension n = Extension_node (extension_core n)
|
|
|
|
|
|
|
|
|
|
and ident_open o =
|
|
|
|
|
do_open o.popen_loc
|
|
|
|
|
(Mml.Ident With_apply.(concrete (of_longident o.popen_expr.Location.txt)))
|
|
|
|
|
|
|
|
|
|
and local_open_arg o = module_expr o.popen_expr
|
|
|
|
|
|
|
|
|
|
let of_ml fpath =
|
|
|
|
|
try
|
|
|
|
|
Pparse.parse_implementation ~tool_name:"uniq" (Fpath.to_string fpath)
|
|
|
|
|
|> structure |> Rresult.R.ok
|
|
|
|
|
with Syntaxerr.Error _ -> assert false (* Approximation *)
|
|
|
|
|
|
|
|
|
|
let of_mli fpath =
|
|
|
|
|
try
|
|
|
|
|
Pparse.parse_interface ~tool_name:"uniq" (Fpath.to_string fpath)
|
|
|
|
|
|> signature |> Rresult.R.ok
|
|
|
|
|
with Syntaxerr.Error _ -> assert false (* Approximation *)
|
|
|
|
|
|
|
|
|
|
open Types
|
|
|
|
|
|
|
|
|
|
let rec mmap f = function [] -> [] | hd :: tl -> f hd @ mmap f tl
|
|
|
|
|
|
|
|
|
|
let module_declaration module_type id md =
|
|
|
|
|
let name = Some (Mod.v (Ident.name id)) in
|
|
|
|
|
Mml.Bind { name; expr = Constraint (Abstract, module_type md.md_type) }
|
|
|
|
|
|
|
|
|
|
let module_type_declaration module_type id mtd =
|
|
|
|
|
let name = Some (Mod.v (Ident.name id)) in
|
|
|
|
|
let expr =
|
|
|
|
|
let ( >>| ) x f = Option.map f x in
|
|
|
|
|
Option.value ~default:Mml.Abstract (mtd.mtd_type >>| module_type)
|
|
|
|
|
in
|
|
|
|
|
Mml.Bind_sig { name; expr }
|
|
|
|
|
|
|
|
|
|
let rec cmi x = mmap signature_item x
|
|
|
|
|
|
|
|
|
|
and signature_item : Types.signature_item -> Mml.expression list = function
|
|
|
|
|
| Sig_value _ (* val ... *) | Sig_type _ (* type ... *)
|
|
|
|
|
| Sig_typext _ (* type t += ... *) | Sig_class _ (* class ... *)
|
|
|
|
|
| Sig_class_type _ (* class ... *) ->
|
|
|
|
|
[]
|
|
|
|
|
| Sig_module (id, _, md, _, _) -> [ module_declaration module_type id md ]
|
|
|
|
|
| Sig_modtype (id, mtd, _) -> [ module_type_declaration module_type id mtd ]
|
|
|
|
|
|
|
|
|
|
and module_type = function
|
|
|
|
|
| Mty_signature s ->
|
|
|
|
|
Mml.Sig (List.map Mml.Loc.(v ~location:nowhere) (signature' s))
|
|
|
|
|
| Mty_ident p -> Mml.Ident (With_apply.of_path p)
|
|
|
|
|
| Mty_functor (arg, mt) ->
|
|
|
|
|
let arg =
|
|
|
|
|
match arg with
|
|
|
|
|
| Named (name, mt) ->
|
|
|
|
|
Some
|
|
|
|
|
{
|
|
|
|
|
Mml.Arg.name = Option.map (Mod.v <.> Ident.name) name;
|
|
|
|
|
signature = module_type mt;
|
|
|
|
|
}
|
|
|
|
|
| Unit -> None
|
|
|
|
|
in
|
|
|
|
|
Mml.Functor { arg; body = module_type mt }
|
|
|
|
|
| Mty_alias p -> Mml.Alias With_apply.(concrete (of_path p))
|
|
|
|
|
|
|
|
|
|
and signature' x = mmap signature_item x
|
|
|
|
|
|
|
|
|
|
let of_cmi fpath =
|
|
|
|
|
match Cmt_format.read (Fpath.to_string fpath) with
|
|
|
|
|
| None, _ -> Rresult.R.error_msgf "Invalid cmi object: %a" Fpath.pp fpath
|
|
|
|
|
| Some v, _ ->
|
|
|
|
|
cmi v.Cmi_format.cmi_sign
|
|
|
|
|
|> List.map Mml.Loc.(v ~location:nowhere)
|
|
|
|
|
|> Rresult.R.ok
|
