Skip to content

Commit b64552a

Browse files
OctachronOctachron
committed
Track externals
1 parent bd2a83a commit b64552a

17 files changed

Lines changed: 127 additions & 40 deletions

‎Changelog.md‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,10 @@
11
# 0.12.2
22

3-
* Support 5.4
3+
* Support 5.4
4+
5+
## features:
6+
7+
* track external declarations
48

59
# 0.12.1
610

‎core/modes.ml‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -72,7 +72,10 @@ let structured fmt _ _ ppf param units =
7272
let groups = Unit.Group.group units in
7373
let local = Unit.Group.Map.fold assoc groups LocalSet.empty in
7474
let dep (u:Unit.r) =
75-
{ Schema.file = ufile u; deps= Deps.paths (Unit.deps u) } in
75+
{ Schema.file = ufile u;
76+
deps= Deps.paths (Unit.deps u);
77+
externals = Deps.externals (Unit.deps u);
78+
} in
7679
let dependencies = List.map dep all in
7780
let local = LocalSet.elements local in
7881
let library = LibSet.elements lib in

‎lib/ast_converter.mlp‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -231,7 +231,10 @@ and structure_item item =
231231
| Pstr_primitive desc
232232
(* val x: T
233233
external x: T = "s1" ... "sn" *)
234-
-> minor @@ data @@ core_type desc.pval_type
234+
-> minor (
235+
External desc.pval_prim ::
236+
data (core_type desc.pval_type);
237+
)
235238
| Pstr_type (_rec_flag, type_declarations)
236239
(* type t1 = ... and ... and tn = ... *) ->
237240
minor @@ data @@ Annot.union_map type_declaration type_declarations

‎lib/dep_zipper.ml‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,8 @@ module Pre = struct
2626
let access_add d _ _ d' = d + d'
2727
let access_init = empty
2828
let alias = id
29+
let external_def =
30+
List.fold_left (fun d s -> Deps.add_external s d) Deps.empty
2931

3032
let pack x = x
3133
let empty_minors = empty

‎lib/deps.ml‎

Lines changed: 52 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -16,63 +16,93 @@ module Edge = struct
1616
end
1717

1818
module S = Namespaced.Set
19+
module Externals = Name.Set
1920
type dep = { path: Namespaced.t; edge:Edge.t; pkg:Pkg.t; aliases:S.t}
2021
type subdep = { edge:Edge.t; pkg:Pkg.t; aliases:S.t }
2122
module Map = Namespaced.Map
22-
type t = subdep Map.t
23+
type t = { units: subdep Map.t; externals : Externals.t }
2324

2425
let sch: t Schematic.t =
2526
let module T = Schematic.Tuple in
26-
let from_list = let open T in
27-
List.fold_left
28-
(fun m [k; edge; pkg; aliases] -> Map.add k {edge;pkg;aliases} m)
29-
Map.empty in
30-
let to_list m =
31-
Map.fold (fun k {edge;pkg;aliases} l -> T.[k;edge;pkg;aliases] :: l) m [] in
27+
let from_ = let open T in
28+
fun [units; externals] ->
29+
let units =
30+
List.fold_left
31+
(fun m [k; edge; pkg; aliases] -> Map.add k {edge;pkg;aliases} m)
32+
Map.empty units
33+
in
34+
{ units; externals = Externals.of_list externals }
35+
in
36+
let to_ { units = m; externals } =
37+
T.(::)(
38+
(Map.fold (fun k {edge;pkg;aliases} l -> T.[k;edge;pkg;aliases] :: l) m []),
39+
T.[Externals.elements externals]
40+
)
41+
in
3242
let open Schematic in
33-
custom (Array [Namespaced.sch; Edge.sch; Pkg.sch; S.sch])
34-
to_list from_list
43+
custom ([Array [Namespaced.sch; Edge.sch; Pkg.sch; S.sch]; Array String])
44+
to_ from_
3545

3646
module Pth = Paths.S
3747
module P = Pkg
3848

39-
let empty = Map.empty
49+
let empty = { units = Map.empty; externals = Externals.empty }
4050

41-
let update ~path ?(aliases=S.empty) ~edge pkg deps: t =
51+
let update ~path ?(aliases=S.empty) ~edge pkg { units; externals }: t =
4252
let ep =
4353
let update x =
4454
let aliases = S.union aliases x.aliases in
4555
{ x with edge = Edge.max edge x.edge; aliases } in
4656
Option.either update {edge;pkg; aliases }
47-
(Map.find_opt path deps) in
48-
Map.add path ep deps
57+
(Map.find_opt path units) in
58+
let units = Map.add path ep units in
59+
{ units; externals }
60+
61+
let add_external ext deps = { deps with externals = Externals.add ext deps.externals }
62+
let add_externals ext deps =
63+
let externals = List.fold_left (fun s x -> Externals.add x s) deps.externals ext in
64+
{ deps with externals }
65+
let externals_only d = { empty with externals = d.externals }
4966

5067
let make ~path ?aliases ~edge pkg = update ~path ?aliases ~edge pkg empty
5168

52-
let merge =
53-
Map.union (fun _k x y ->
54-
let aliases = S.union x.aliases y.aliases in
55-
Some { y with edge = Edge.max x.edge y.edge; aliases })
69+
let merge x y =
70+
let units =
71+
Map.union (fun _k x y ->
72+
let aliases = S.union x.aliases y.aliases in
73+
Some { y with edge = Edge.max x.edge y.edge; aliases }
74+
) x.units y.units
75+
in
76+
let externals = Externals.union x.externals y.externals in
77+
{ units; externals }
5678

5779
let (+) = merge
5880

5981

6082
let find path deps =
61-
Option.fmap (fun {edge;pkg;aliases} -> {path;edge;pkg;aliases}) @@ Map.find_opt path deps
83+
Option.fmap (fun {edge;pkg;aliases} -> {path;edge;pkg;aliases}) @@ Map.find_opt path deps.units
6284
let fold f deps acc =
63-
Map.fold (fun path {edge;pkg;aliases} -> f {path;edge;pkg;aliases}) deps acc
85+
Map.fold (fun path {edge;pkg;aliases} -> f {path;edge;pkg;aliases}) deps.units acc
6486

6587
let pp_elt ppf (path, {edge;pkg;aliases}) =
6688
Pp.fp ppf "%s%a(%a)%a" (if edge = Edge.Normal then "" else "ε∙")
6789
Namespaced.pp path P.pp pkg S.pp aliases
6890

6991
let pp ppf s =
70-
Pp.fp ppf "@[<hov>{%a}@]" (Pp.list pp_elt) (Map.bindings s)
92+
Pp.fp ppf "@[<v>externals:@[<hov>]%a@,@[<hov>{%a}@]@]"
93+
Pp.(list string) (Externals.elements s.externals)
94+
(Pp.list pp_elt) (Map.bindings s.units)
7195

7296
let of_list l =
73-
List.fold_left (fun m {path;edge;pkg;aliases} -> Map.add path {edge; pkg; aliases} m) empty l
97+
let units =
98+
List.fold_left
99+
(fun m {path;edge;pkg;aliases} -> Map.add path {edge; pkg; aliases} m)
100+
empty.units l
101+
in
102+
{ units; externals = Externals.empty }
74103

75104
let pkgs deps = fold (fun {pkg; _ } x -> pkg :: x) deps []
76105
let paths deps = fold (fun {path; _ } x -> path :: x) deps []
106+
let externals deps = Externals.elements deps.externals
77107
let all deps = fold List.cons deps []
78-
let pkg_set x = Map.fold (fun _ x s -> P.Set.add x.pkg s) x P.Set.empty
108+
let pkg_set x = Map.fold (fun _ x s -> P.Set.add x.pkg s) x.units P.Set.empty

‎lib/deps.mli‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,11 @@ val update:
2323
val make:
2424
path:Namespaced.t -> ?aliases:Namespaced.set -> edge:Edge.t -> Pkg.t -> t
2525

26+
(** Add a new external to a dependency record *)
27+
val add_external: string -> t -> t
28+
val add_externals: string list -> t -> t
29+
val externals_only: t -> t
30+
2631
val merge: t -> t -> t
2732
val (+) : t -> t -> t
2833

@@ -36,4 +41,5 @@ val of_list: dep list -> t
3641
val pkgs: t -> Pkg.t list
3742
val paths: t -> Namespaced.t list
3843
val all: t -> dep list
44+
val externals: t -> string list
3945
val pkg_set: t -> Pkg.set

‎lib/m2l.ml‎

Lines changed: 10 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,9 @@ and minor =
4242
| Local_open of Loc.t * module_expr * minor list
4343
(** let open struct ... end in ... *)
4444
| Local_bind of Loc.t * module_expr bind * minor list
45+
46+
| External of string list (** external _ = "..." "..." *)
47+
4548
and access = (Loc.t * Deps.Edge.t) Paths.E.map
4649
(** [M.N.L.x] ⇒ access \{M.N.L = Normal \}
4750
type t = A.t ⇒ access \{ A = ε \}
@@ -145,6 +148,7 @@ module Sch = struct
145148
"Open", [reopen Loc.Sch.t; Mu.module_expr; Array Mu.minor];
146149
"Bind",
147150
[reopen Loc.Sch.t; option String; Mu.module_expr; Array Mu.minor];
151+
"External", Array String
148152
]
149153

150154
let annot = Array Mu.minor
@@ -293,14 +297,16 @@ module Sch = struct
293297
| Access x -> C (Z x)
294298
| Pack m -> C (S (Z m))
295299
| Extension_node e -> C (S (S (Z e)))
296-
| Local_open (loc,x,y) -> C (S (S ( S (Z [loc;x;y]))))
297-
| Local_bind(loc,b,x) -> C (S (S (S ( S (Z [loc;b.name; b.expr; x])))))
300+
| Local_open (loc,x,y) -> C (S (S (S (Z [loc;x;y]))))
301+
| Local_bind(loc,b,x) -> C (S (S (S (S (Z [loc;b.name; b.expr; x])))))
302+
| External s -> C (S (S (S (S (S (Z s))))))
298303
and rev = let open Tuple in function
299304
| C Z x -> Access x
300305
| C S Z m -> Pack m
301306
| C S S Z e -> Extension_node e
302307
| C S S S Z [x;y;z] -> Local_open (x,y,z)
303308
| C S S S S Z [loc;name;expr;z] -> Local_bind (loc,{name;expr},z)
309+
| C S S S S S Z s -> External s
304310
| C E -> assert false
305311
| _ -> .
306312

@@ -421,6 +427,7 @@ module Annot = struct
421427
Local_open(loc,me, List.map epsilon_promote_raw x)
422428
| Local_bind (loc,b,x) ->
423429
Local_bind (loc, b, List.map epsilon_promote_raw x)
430+
| External _ as e -> e
424431

425432
let epsilon_promote = Loc.fmap @@ List.map epsilon_promote_raw
426433

@@ -462,6 +469,7 @@ let rec pp_expression ppf = function
462469
Pp.fp ppf "rec@[[ %a ]@]" (and_list pp_bind) bs
463470

464471
and pp_minor ppf = function
472+
| External exts -> Pp.fp ppf "@[external(%a)@]" Pp.(list string) exts
465473
| Access a -> pp_access ppf a
466474
| Pack x -> Pp.fp ppf "@[(module %a)@]" pp_me x.Loc.data
467475
| Extension_node e -> Pp.fp ppf "@[%a@]" pp_extension e.data

‎lib/m2l.mli‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -63,15 +63,17 @@ and expression =
6363
dependency tracking.
6464
*)
6565
and minor =
66-
6766
| Access of access (** see {!access} below *)
6867
| Pack of module_expr Loc.ext (** (module struct ... end) *)
6968
| Extension_node of extension Loc.ext (** [%ext ... ] *)
7069

7170
| Local_open of Loc.t * module_expr * minor list
7271
(** let open struct ... end in ... *)
7372
| Local_bind of Loc.t * module_expr bind * minor list
74-
(** let module M = ... in ... *)
73+
74+
| External of string list (** external _ = "..." "..." *)
75+
76+
(** let module M = ... in ... *)
7577
and access = (Loc.t * Deps.Edge.t) Paths.E.map
7678
(** [M.N.L.x] ⇒ access \{M.N.L = Normal \}
7779
type t = A.t ⇒ access \{ A = ε \}

‎lib/schema.ml‎

Lines changed: 12 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -74,26 +74,32 @@ module Deps = Label(struct let l = "deps" end)
7474

7575
module File = Label(struct let l = "file" end)
7676

77-
type unit = { file: string; deps: p list }
77+
module Externals = Label(struct let l = "externals" end)
78+
79+
type unit = { file: string; deps: p list; externals: string list }
7880

7981
let raw_unit =
8082
Obj [
8183
Req, File.l, String <?> "File name";
82-
Opt, Deps.l, Array path <?> "list of dependencies"
84+
Opt, Deps.l, Array path <?> "list of dependencies";
85+
Opt, Externals.l, Array String <?> "list of external primitive dependencies";
8386
]
8487

8588
let unit =
86-
let e: _ list = [] in
89+
let e x = Option.default ([] : _ list) x in
8790
let ($=$) x l = if l = L.[] then x $=? None else x $=? Some l in
8891
custom raw_unit
89-
(fun d -> [ File.l $= d.file; Deps.l $=$ d.deps ])
90-
(let open R in fun [_, file; _,deps] -> {file; deps = Option.default e deps } )
92+
(fun d -> [ File.l $= d.file; Deps.l $=$ d.deps; Externals.l $=$ d.externals ])
93+
(let open R in fun [_, file; _,deps; _, externals ] ->
94+
{file; deps = e deps; externals = e externals }
95+
)
9196

9297

9398

9499
module Dependencies = Label(struct let l = "dependencies" end)
95100
module Atlas = Label(struct let l = "atlas" end)
96101

102+
97103
type deps = {
98104
dependencies: unit list;
99105
local: local_association list;
@@ -123,7 +129,7 @@ let deps =
123129
{dependencies;
124130
local=list local;
125131
library=list lib;
126-
unknown=list u
132+
unknown=list u;
127133
} )
128134

129135

‎lib/schema.mli‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@ type p = Namespaced.t
1414
type local_association = { path: p; ml: string option; mli: string option }
1515
type library_module = { path:p; lib:p}
1616

17-
type unit = { file:string; deps: p list }
17+
type unit = { file:string; deps: p list; externals: string list }
1818
type deps = {
1919
dependencies: unit list;
2020
local: local_association list;

0 commit comments

Comments
 (0)