1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
module Simple =
struct
module Core = struct
type t = Name.t list
let compare (x:t) (y:t) = compare x y
let pp = Pp.(list ~sep:(s".") ) Name.pp
end
include Core
let sch = Schematic.(Array String)
module Set = struct
include Set.Make(Core)
let pp ppf s = Pp.(clist Core.pp) ppf (elements s)
let sch = let open Schematic in
custom (Array sch)
elements
(List.fold_left (fun s x -> add x s) empty)
end
module Map = struct
include Support.Map.Make(Core)
let union' s = union (fun _key _m1 m2 -> Some m2) s
end
type set = Set.t
type 'a map = 'a Map.t
let prefix = List.hd
let concat = List.append
let extension a =
let ext = Support.extension a in
if not (ext = "") && ext.[0] = '.' then
String.sub ext 1 (String.length ext - 1)
else
ext
let may_change_extension f a =
match extension a with
| "" -> a
| ext ->
let base = Filename.chop_extension a in
base ^ f ext
let rec change_file_extension f = function
| [] -> []
| [a] -> [may_change_extension f a ]
| a :: q -> a :: change_file_extension f q
let rec chop_extension l = match l with
| [] -> []
| [a] -> [Filename.chop_extension a]
| a :: q -> a :: chop_extension q
let parse_filename name =
let l = Support.split_on_dirs name in
match List.rev l with
| "" :: q -> List.rev q
| l -> List.rev l
end
module S = Simple
module type simple_core = sig
type t
val concat: t -> Simple.t -> t
val prefix: t -> Name.t
val sch: t Schematic.t
val pp: t Pp.t
end
(** Module paths with application *)
module type Expr = sig
type s
type t = private
| Simple of s
| Apply of { f:t; x:t; proj: Simple.t option }
val sch: t Schematic.t
exception Functor_not_expected
val concrete : t -> s
val concrete_with_f : t -> s
val multiples : t -> s list
val pure : s -> t
val app: t -> t -> Simple.t option -> t
val pp : Format.formatter -> t -> unit
val prefix : t -> string
module Map: Map.S with type key = t
type 'a map = 'a Map.t
end
module Make_expr(S:simple_core): Expr with type s := S.t = struct
type t =
| Simple of S.t
| Apply of { f:t; x:t; proj: Simple.t option }
module Sch = struct
type w = W of S.t [@@unboxed]
open Schematic
let w = Custom { fwd = (fun (W x) -> x); rev=(fun x -> W x); sch=S.sch }
let mu = Schematic_indices.one
let raw: _ s = Sum [ "S", reopen w; "Apply", [mu;mu; option (reopen Simple.sch) ] ]
let rec c = Custom {fwd;rev; sch=raw }
and fwd = function
| Apply {f;x;proj} -> C(S(Z Tuple.[f;x;proj]))
| Simple x -> C (Z (W x))
and rev =
let open Tuple in
function
| C Z (W s) -> Simple s
| C S Z [f;x;proj] -> Apply {f;x;proj}
| _ -> .
let t = Rec { id = ["Paths"; "Expr"; "t"]; defs = ["c", c]; proj = Zn }
end
let sch = Sch.t
exception Functor_not_expected
let concrete = function
| Simple x -> x
| Apply _ -> raise Functor_not_expected
let rec concrete_with_f = function
| Simple x -> x
| Apply {f;proj=None; _ } -> concrete_with_f f
| Apply {f;proj=Some r; _ } -> S.(concat (concrete_with_f f) r)
let rec multiples = function
| Apply {f;x;proj=Some proj} -> fn f proj @ multiples x
| Apply {f;x;proj=None} -> multiples f @ multiples x
| Simple x -> [x]
and fn f proj = match f with
| Simple x -> S.[concat x proj]
| Apply {proj=None; f; x } -> fn f proj @ multiples x
| Apply {proj=Some p; f; x } -> fn f ( p @ proj) @ multiples x
let pure path = Simple path
let app f x proj = Apply {f;x;proj}
let rec pp ppf = function
| Simple path -> S.pp ppf path
| Apply {f;x;proj=None} -> Pp.fp ppf "%a(%a)" pp f pp x
| Apply {f;x;proj=Some p} -> Pp.fp ppf "%a(%a).%a" pp f pp x Simple.pp p
let rec prefix = function
| Simple s -> S.prefix s
| Apply r -> prefix r.f
module Map = Map.Make(struct
let compare = compare
type nonrec t = t
end)
type 'a map = 'a Map.t
end
module Expr = Make_expr(Simple)
module E = Expr