aboutsummaryrefslogtreecommitdiffstats
path: root/lib/mininix
diff options
context:
space:
mode:
Diffstat (limited to 'lib/mininix')
-rw-r--r--lib/mininix/builtins.ml77
-rw-r--r--lib/mininix/builtins.nix302
-rw-r--r--lib/mininix/conv.ml96
-rw-r--r--lib/mininix/dune15
-rw-r--r--lib/mininix/import.ml54
-rw-r--r--lib/mininix/mininix.ml13
-rw-r--r--lib/mininix/mininix2nix.ml54
-rw-r--r--lib/mininix/nix2mininix.ml254
-rw-r--r--lib/mininix/run.ml17
-rw-r--r--lib/mininix/sexp.ml160
10 files changed, 1042 insertions, 0 deletions
diff --git a/lib/mininix/builtins.ml b/lib/mininix/builtins.ml
new file mode 100644
index 0000000..0809668
--- /dev/null
+++ b/lib/mininix/builtins.ml
@@ -0,0 +1,77 @@
1open Core
2open Nix2mininix
3
4let minimal_prelude =
5 mn_attr
6 [
7 ("true", `Nonrec, Extraction.ELit (Extraction.LitBool true));
8 ("false", `Nonrec, Extraction.ELit (Extraction.LitBool false));
9 ("null", `Nonrec, Extraction.ELit Extraction.LitNull);
10 ("seq", `Nonrec, mn_abs [ "e1"; "e2" ] (mn_seq (mn_id "e1") (mn_id "e2")));
11 ( "deepSeq",
12 `Nonrec,
13 mn_abs [ "e1"; "e2" ] (mn_deep_seq (mn_id "e1") (mn_id "e2")) );
14 ("typeOf", `Nonrec, mn_abs [ "e" ] (mn_type_of (mn_id "e")));
15 ("functionArgs", `Nonrec, mn_abs [ "f" ] (mn_function_args (mn_id "f")));
16 ( "bitAnd",
17 `Nonrec,
18 mn_abs [ "x"; "y" ] (mn_bit_and (mn_id "x") (mn_id "y")) );
19 ("bitOr", `Nonrec, mn_abs [ "x"; "y" ] (mn_bit_or (mn_id "x") (mn_id "y")));
20 ( "bitXor",
21 `Nonrec,
22 mn_abs [ "x"; "y" ] (mn_bit_xor (mn_id "x") (mn_id "y")) );
23 ("ceil", `Nonrec, mn_abs [ "x" ] (mn_ceil (mn_id "x")));
24 ("floor", `Nonrec, mn_abs [ "x" ] (mn_floor (mn_id "x")));
25 ("__mn_nearestEven", `Nonrec, mn_abs [ "x" ] (mn_nearest_even (mn_id "x")));
26 ( "__mn_singleton",
27 `Nonrec,
28 mn_abs [ "x"; "e" ] (mn_singleton_attr (mn_id "x") (mn_id "e")) );
29 ( "__mn_attr_delete",
30 `Nonrec,
31 mn_abs [ "as"; "x" ] (mn_delete_attr (mn_id "as") (mn_id "x")) );
32 ( "__mn_attr_has_prim",
33 `Nonrec,
34 mn_abs [ "d"; "e" ] (mn_has_attr (mn_id "d") (mn_id "e")) );
35 ("__mn_attr_match", `Nonrec, mn_abs [ "as" ] (mn_attr_match (mn_id "as")));
36 ("__mn_list_match", `Nonrec, mn_abs [ "xs" ] (mn_list_match (mn_id "xs")));
37 ( "__mn_string_match",
38 `Nonrec,
39 mn_abs [ "s" ] (mn_string_match (mn_id "s")) );
40 ]
41
42(* Watch out to not introduce constructs here that refer to themselves using
43 the mnbi_* functions in Nix2mininix - this can cause undesired loops. *)
44let builtins_nix =
45 Nix.elaborate (Nix.parse ~filename:"<builtins>" [%blob "builtins.nix"])
46
47let builtins =
48 Extraction.ELetAttr
49 (Extraction.ABS, minimal_prelude, Nix2mininix.from_nix builtins_nix)
50
51let exported_builtins =
52 [
53 "__mn_assert";
54 "__mn_attr_has";
55 "__mn_attr_insertNew";
56 "__mn_attr_select";
57 "__mn_attr_selectOr";
58 "abort";
59 "false";
60 "head";
61 "map";
62 "null";
63 "removeAttrs";
64 "tail";
65 "throw";
66 "toString";
67 "true";
68 ]
69
70let apply_prelude e =
71 let bindings =
72 mn_attr
73 (("builtins", `Nonrec, builtins)
74 :: List.map exported_builtins ~f:(fun x ->
75 (x, `Rec, mn_select_attr (mn_id "builtins") (mn_str x))))
76 in
77 Extraction.ELetAttr (Extraction.ABS, bindings, e)
diff --git a/lib/mininix/builtins.nix b/lib/mininix/builtins.nix
new file mode 100644
index 0000000..9c7ed32
--- /dev/null
+++ b/lib/mininix/builtins.nix
@@ -0,0 +1,302 @@
1rec {
2 inherit true false null functionArgs typeOf seq deepSeq bitAnd bitOr bitXor floor ceil; # from the minimal prelude
3
4 abort = _: null null; # we ignore the provided message
5 throw = abort; # same here
6
7 head = xs: (__mn_list_match xs).head;
8 tail = xs: (__mn_list_match xs).tail;
9
10 __mn_matchAttr = f: as: f (__mn_attr_match as);
11 __mn_matchList = f: xs: f (__mn_list_match xs);
12 __mn_matchString = f: s: f (__mn_string_match s);
13
14 __mn_foldr = op: nul:
15 __mn_matchList ({ head, tail, empty }:
16 if empty then nul else op head (__mn_foldr op nul tail));
17
18 # foldl' should really be strict. But if we do that (using seq), the
19 # complexity of this function suddenly morphs from linear to
20 # exponential, which is way worse than not actually being strict.
21 foldl' = op: nul:
22 __mn_matchList
23 ({ head, tail, empty }:
24 if empty then nul else
25 let v = op nul head; in
26 seq v (foldl' op v tail));
27 map = f:
28 __mn_matchList ({ head, tail, empty }:
29 if empty then [ ] else [ (f head) ] ++ map f tail);
30 elem = x: any (y: x == y);
31 elemAt = xs: n: assert n >= 0;
32 let go = xs: n: if n == 0 then head xs else go (tail xs) (n - 1);
33 in go xs n;
34 length = __mn_matchList ({ head, tail, empty }:
35 if empty then 0 else 1 + length tail);
36 sort = __mn_mergesort;
37 any = f: __mn_matchList ({ head, tail, empty }: !empty && (f head || any f tail));
38 all = f: __mn_matchList ({ head, tail, empty }: !empty -> (f head && all f tail));
39 concatLists =
40 __mn_matchList ({ head, tail, empty }:
41 if empty then [ ] else head ++ concatLists tail);
42 concatMap = f: xss: concatLists (map f xss);
43 concatStringsSep = sep:
44 __mn_matchList ({ head, tail, empty }:
45 if empty then "" else if tail == [ ] then head
46 else head + sep + concatStringsSep sep tail);
47 filter = f:
48 __mn_matchList ({ head, tail, empty }:
49 if empty then [ ] else (if f head then [ head ] else [ ]) ++ filter f tail);
50 groupBy = f: xs:
51 let update = x: acc: acc // { ${f x} = [ x ] ++ (acc.${f x} or [ ]); };
52 in __mn_foldr update { } xs;
53 partition = f: groupBy (x: if f x then "right" else "wrong");
54
55 hasAttr = x: as: as ? ${x};
56 getAttr = x: as: as.${x};
57 attrNames = __mn_matchAttr ({ key, tail, empty, ... }:
58 if empty then [ ] else [ key ] ++ attrNames tail);
59 attrValues = __mn_matchAttr ({ head, tail, empty, ... }:
60 if empty then [ ] else [ head ] ++ attrValues tail);
61 mapAttrs = f: __mn_matchAttr ({ key, head, tail, empty }:
62 if empty then { } else
63 mapAttrs f tail // { ${key} = f key head; });
64 removeAttrs = __mn_foldr (x: as': __mn_attr_delete as' x);
65 zipAttrsWith = f: ass: mapAttrs f (__mn_zipAttrs ass);
66 catAttrs = x:
67 __mn_matchList ({ head, tail, empty }:
68 if empty then [ ]
69 else (if head ? ${x} then [ head.${x} ] else [ ]) ++ catAttrs x tail);
70 listToAttrs =
71 __mn_foldr (attr: as': as' // { ${attr.name} = attr.value; }) { };
72 intersectAttrs = e1: e2:
73 __mn_matchAttr
74 ({ key, head, tail, empty }:
75 if empty then { } else
76 (if e2 ? ${key} then { ${key} = e2.${key}; } else { }) //
77 intersectAttrs tail (__mn_attr_delete e2 key))
78 e1;
79
80 lessThan = x: y: x < y; # documentation is misleading, not only for numbers
81 add = x: y: x + y;
82 mul = x: y: x * y;
83 div = x: y: x / y;
84 sub = x: y: x - y;
85 genList = gen: n:
86 let
87 aux = off: if off >= n then [ ] else
88 [ (gen off) ] ++ aux (off + 1);
89 in
90 aux 0;
91
92 __mn_genericClosure = { operator, seen, startSet }:
93 __mn_matchList
94 ({ head, tail, empty }:
95 if empty then [ ] else
96 if seen head.key
97 then __mn_genericClosure { inherit operator seen; startSet = tail; }
98 else [ head ] ++ __mn_genericClosure {
99 inherit operator;
100 seen = k: k == head.key || seen k;
101 startSet = tail ++ operator head;
102 })
103 startSet;
104 genericClosure = { operator, startSet }:
105 __mn_genericClosure { inherit operator startSet; seen = _: false; };
106
107 isAttrs = e: typeOf e == "set";
108 isBool = e: typeOf e == "bool";
109 isFloat = e: typeOf e == "float";
110 isFunction = e: typeOf e == "lambda";
111 isInt = e: typeOf e == "int";
112 isList = e: typeOf e == "list";
113 isNull = e: typeOf e == "null";
114 isString = e: typeOf e == "string";
115
116 toString = e:
117 if isAttrs e then
118 if e ? __toString then e.__toString e else e.outPath
119 else if isBool e then
120 if e then "1" else ""
121 else if isFloat e then
122 __mn_float_toString e
123 else if isInt e then
124 __mn_int_toString e
125 else if isList e then
126 concatStringsSep " " (map toString e)
127 else if isNull e then
128 ""
129 else if isString e then
130 e
131 else abort null;
132
133 stringLength =
134 __mn_matchString ({ head, tail, empty }:
135 if empty then 0 else 1 + stringLength tail);
136
137 substring = start: assert start >= 0; len:
138 __mn_matchString ({ head, tail, empty }:
139 if empty || len == 0 then "" else
140 if start > 0
141 then substring (start - 1) len tail
142 else head + substring 0 (len - 1) tail);
143
144 replaceStrings = from: to: s:
145 __mn_matchList
146 ({ head, tail, empty }:
147 let from = if empty then [ ] else [ head ] ++ tail; in
148 __mn_matchList
149 ({ head, tail, empty }:
150 let to = if empty then [ ] else [ head ] ++ tail; in
151 assert length from == length to;
152 __mn_strings_replace from to s)
153 to)
154 from;
155
156 __mn_strings_replace = subsFrom: subsTo: s:
157 let go = __mn_strings_replace subsFrom subsTo; in
158 __mn_strings_replace_aux go subsFrom subsTo s;
159
160 __mn_strings_replace_aux = go: subsFrom: subsTo: s:
161 __mn_matchList
162 ({ head, tail, empty }:
163 if empty
164 then
165 __mn_matchString
166 ({ head, tail, empty }: if empty then "" else head + go tail)
167 s
168 else
169 let subFrom = head; subsFrom' = tail; in
170 __mn_matchList
171 ({ head, tail, ... }:
172 let subTo = head; subsTo' = tail; in
173 if subFrom == ""
174 then
175 # We can only ask ourselves why, but it is so -- in Nix:
176 # replaceStrings ["" "a"] ["X" "_"] "asdf" ~> "XaXsXdXfX"
177 # and so we emulate this 'behavior'
178 subTo + __mn_matchString
179 ({ head, tail, empty }:
180 if empty then "" else head + go tail)
181 s
182 else
183 ({ ok, rest }:
184 if ok
185 then subTo + go rest
186 else __mn_strings_replace_aux go subsFrom' subsTo' s)
187 (__mn_string_chopPrefix subFrom s))
188 subsTo)
189 subsFrom;
190
191 __mn_string_chopPrefix = prefix: s:
192 __mn_matchString
193 ({ head, tail, empty }:
194 if empty then { ok = true; rest = s; } else
195 let prefix = head; prefix' = tail; in __mn_matchString
196 ({ head, tail, empty }:
197 if empty || prefix != head then { ok = false; rest = null; } else
198 __mn_string_chopPrefix prefix' tail)
199 s)
200 prefix;
201
202 __mn_string_drop = n: s:
203 if n <= 0 then s else
204 __mn_matchString
205 ({ tail, empty, ... }:
206 if empty then "" else
207 __mn_string_drop (n - 1) tail)
208 s;
209
210 __mn_float_toString = x:
211 let
212 sign = x < 0;
213 abs = __mn_abs x;
214 int = floor abs;
215 dec = __mn_nearestEven ((abs - int) * 1000000);
216 in
217 (if sign then "-" else "") +
218 __mn_int_toString int + "." + __mn_int_toString dec;
219 __mn_int_toString = x: (if x < 0 then "-" else "") +
220 (
221 let d10 = __mn_quotRem (__mn_abs x) 10; in
222 (if d10.quot != 0 then toString d10.quot else "") +
223 (if d10.rem == 0 then "0" else
224 if d10.rem == 1 then "1" else
225 if d10.rem == 2 then "2" else
226 if d10.rem == 3 then "3" else
227 if d10.rem == 4 then "4" else
228 if d10.rem == 5 then "5" else
229 if d10.rem == 6 then "6" else
230 if d10.rem == 7 then "7" else
231 if d10.rem == 8 then "8" else
232 if d10.rem == 9 then "9" else
233 abort null)
234 );
235
236 __mn_quotRem = x: y:
237 let quot = x / y; in
238 { inherit quot; rem = x - quot * y; };
239 __mn_abs = x: if x < 0 then -x else x;
240
241 __mn_attr_insertNew = as: x: e:
242 if x == null then { } else
243 assert !(as ? ${x}); as // __mn_singleton x e;
244 __mn_attr_has_aux = d: e:
245 if typeOf d != "set" then false else __mn_attr_has_prim d e;
246 __mn_attr_has = e:
247 __mn_matchList ({ head, tail, empty }:
248 if empty then true else
249 if __mn_attr_has_aux e head then __mn_attr_has e.${head} tail
250 else false);
251 __mn_attr_select = e:
252 __mn_matchList ({ head, tail, empty }:
253 if empty then e
254 else __mn_attr_select e.${head} tail);
255 __mn_attr_selectOr = e: as: d:
256 if __mn_attr_has e as
257 then __mn_attr_select e as
258 else d;
259 __mn_assert = e1: e2:
260 if e1 then e2 else abort null;
261
262 __mn_consAttrs = as: acc:
263 __mn_foldr
264 (x: acc: acc // {
265 ${x} = [ as.${x} ] ++ (acc.${x} or [ ]);
266 })
267 acc
268 (attrNames as);
269 __mn_zipAttrs = __mn_foldr __mn_consAttrs { };
270
271 # Old merge sort algorithm, taken from GHC.Internal.Data.OldList.
272 __mn_mergesort = cmp: xs: __mn_mergesort' cmp (__mn_singletons xs);
273 __mn_singletons = map (x: [ x ]);
274 __mn_mergesort' = cmp: xs:
275 __mn_matchList
276 ({ head, tail, empty }:
277 if empty then [ ] else if tail == [ ] then head else
278 __mn_mergesort' cmp (__mn_mergePairs cmp xs))
279 xs;
280 __mn_mergePairs = cmp:
281 __mn_matchList ({ head, tail, empty }: if empty then [ ] else
282 let xs' = head; in __mn_matchList
283 ({ head, tail, empty }:
284 if empty then [ xs' ] else
285 let ys' = head; xss' = tail; in
286 [ (__mn_merge cmp xs' ys') ] ++ __mn_mergePairs cmp xss')
287 tail);
288 __mn_merge = cmp: xs: ys:
289 __mn_matchList
290 ({ head, tail, empty }:
291 if empty then ys else
292 let x = head; xs' = tail; in
293 __mn_matchList
294 ({ head, tail, empty }:
295 if empty then xs else
296 let y = head; ys' = tail; in
297 if cmp y x
298 then [ y ] ++ __mn_merge cmp xs ys' # y < x, i.e., x > y
299 else [ x ] ++ __mn_merge cmp xs' ys)
300 ys)
301 xs;
302}
diff --git a/lib/mininix/conv.ml b/lib/mininix/conv.ml
new file mode 100644
index 0000000..8062099
--- /dev/null
+++ b/lib/mininix/conv.ml
@@ -0,0 +1,96 @@
1open Core
2
3let _ = assert (Sys.word_size_in_bits = 64)
4let chlist s = String.to_list s
5let ( <> ) l1 l2 = not (List.equal Char.( = ) l1 l2)
6let str = String.of_char_list
7let prec = 53
8let emax = 1024
9let exp_bits = 11
10let saturated_exp = Int.shift_left 1 exp_bits - 1
11
12let rec int_bits (x : int) : bool list =
13 if Int.(x < 0) then raise (Invalid_argument "Number must be nonnegative")
14 else if Int.(x = 0) then []
15 else
16 let q = x /% 2 and r = x % 2 in
17 int_bits q @ [ r = 1 ]
18
19let int_to_positive (x : int) : Extraction.Internal.BinNums.positive =
20 if x <= 0 then raise (Invalid_argument "Number must be positive")
21 else
22 let bits = List.tl_exn (int_bits x) in
23 List.fold_left
24 ~f:(fun acc digit ->
25 if digit then Extraction.Internal.BinNums.Coq_xI acc
26 else Extraction.Internal.BinNums.Coq_xO acc)
27 ~init:Extraction.Internal.BinNums.Coq_xH bits
28
29let int_to_z (x : int) : Extraction.Internal.BinNums.coq_Z =
30 if x = 0 then Z0
31 else if x < 0 then Zneg (int_to_positive (-x))
32 else Zpos (int_to_positive x)
33
34let rec int63_of_positive (x : Extraction.Internal.BinNums.positive) : Int63.t =
35 let two = Int63.(succ one) in
36 match x with
37 | Coq_xH -> Int63.of_int_exn 1
38 | Coq_xO x -> Int63.(two * int63_of_positive x)
39 | Coq_xI x -> Int63.((two * int63_of_positive x) + one)
40
41let int63_of_z (x : Extraction.Internal.BinNums.coq_Z) : Int63.t =
42 match x with
43 | Z0 -> Int63.zero
44 | Zpos x -> int63_of_positive x
45 | Zneg x -> Int63.neg (int63_of_positive x)
46
47let int63_to_positive x = Int63.to_int_exn x |> int_to_positive
48
49(* Conversions are the same as those in Coq's FloatOps.
50 See https://github.com/coq/coq/blob/master/theories/Floats/FloatOps.v *)
51
52let normfr_mantissa f =
53 let f = Float.abs f in
54 if Float.(f >= 0.5) && Float.(f < 1.) then Float.to_int (Float.ldexp f prec)
55 else 0
56
57let float_to_flocq (x : float) : Extraction.Internal.Floats.float =
58 match Float.classify x with
59 | Zero -> Extraction.Internal.Floats.B754_zero (Float.ieee_negative x)
60 | Nan ->
61 Extraction.Internal.Floats.B754_nan
62 (Float.ieee_negative x, Float.ieee_mantissa x |> int63_to_positive)
63 | Infinite -> Extraction.Internal.Floats.B754_infinity (Float.ieee_negative x)
64 | Normal | Subnormal -> (
65 let prec_z = int_to_z prec and emax_z = int_to_z emax in
66 let r, exp = Float.frexp x in
67 let e = int_to_z (exp - prec) and r' = int_to_z (normfr_mantissa r) in
68 let shr, e' =
69 Extraction.Internal.Floats.(shr_fexp prec_z emax_z r' e Coq_loc_Exact)
70 in
71 match shr.shr_m with
72 | Zpos p -> B754_finite (Float.is_negative x, p, e')
73 | Zneg _ | Z0 -> assert false)
74
75let float_from_flocq x : float =
76 match x with
77 | Extraction.Internal.Floats.B754_zero s ->
78 Float.create_ieee_exn ~negative:s ~mantissa:Int63.zero ~exponent:0
79 | Extraction.Internal.Floats.B754_infinity s ->
80 if s then Float.neg_infinity else Float.infinity
81 | Extraction.Internal.Floats.B754_nan (s, m) ->
82 let m_int = int63_of_positive m in
83 Float.create_ieee_exn ~negative:s ~mantissa:m_int ~exponent:saturated_exp
84 | Extraction.Internal.Floats.B754_finite (s, m, e) ->
85 let pm = Float.of_int63 (int63_of_positive m) in
86 let f = Float.ldexp pm (Int63.to_int_exn (int63_of_z e)) in
87 if s then Float.neg f else f
88
89open struct
90 open Base_quickcheck
91
92 let%expect_test "float conversion" =
93 Test.run_exn
94 (module Float)
95 ~f:(fun x -> [%test_eq: float] (float_from_flocq (float_to_flocq x)) x)
96end
diff --git a/lib/mininix/dune b/lib/mininix/dune
new file mode 100644
index 0000000..aabbf45
--- /dev/null
+++ b/lib/mininix/dune
@@ -0,0 +1,15 @@
1(library
2 (name mininix)
3 (inline_tests)
4 (preprocessor_deps
5 (file builtins.nix))
6 (preprocess
7 (pps
8 ppx_blob
9 ppx_sexp_conv
10 ppx_expect
11 ppx_assert
12 base_quickcheck.ppx_quickcheck))
13 (instrumentation
14 (backend bisect_ppx))
15 (libraries core extraction nix ppx_blob ppx_sexp_conv))
diff --git a/lib/mininix/import.ml b/lib/mininix/import.ml
new file mode 100644
index 0000000..ca1bfb5
--- /dev/null
+++ b/lib/mininix/import.ml
@@ -0,0 +1,54 @@
1open Core
2
3exception ImportError of string
4
5type tree = { filename : string; deps : forest }
6and forest = tree list
7
8let provide (imports : (string * Extraction.coq_val) list) =
9 let imports_set =
10 Extraction.(
11 VAttr
12 (List.fold imports ~init:thunk_map_empty ~f:(fun attrs (filename, v) ->
13 thunk_map_insert (Conv.chlist filename) (Forced v) attrs)))
14 in
15 let make_env =
16 Extraction.(
17 env_insert_abs (Conv.chlist "imports") (Forced imports_set) env_empty)
18 in
19 Extraction.(
20 VClo
21 ( Conv.chlist "path",
22 make_env,
23 EBinOp
24 ( SelectAttrOp,
25 EId (Conv.chlist "imports", None),
26 EId (Conv.chlist "path", None) ) ))
27
28let make_env (imports : (string * Extraction.coq_val) list) =
29 Extraction.(
30 env_insert_abs (Conv.chlist "import") (Forced (provide imports)) env_empty)
31
32let rec import trees : (string * Extraction.coq_val) list =
33 List.map trees ~f:(fun { filename; deps } ->
34 let data = In_channel.read_all filename in
35 Nix.parse ~filename data |> Nix.elaborate |> Nix2mininix.from_nix
36 |> Builtins.apply_prelude
37 |> Run.interp ~fuel:`Unlimited ~mode:`Shallow
38 ~env:(make_env (import deps))
39 |> function
40 | Res (Some v) -> (filename, v)
41 | Res None ->
42 raise
43 (ImportError
44 (sprintf "Could not import %s: Failed to evaluate" filename))
45 | NoFuel -> assert false)
46
47let rec tree_map ~(f : string -> string) { filename; deps } =
48 { filename = f filename; deps = forest_map ~f deps }
49
50and forest_map ~(f : string -> string) trees = List.map ~f:(tree_map ~f) trees
51
52(* [relative_to] must be an absolute path *)
53let materialize forest ~relative_to : (string * Extraction.coq_val) list =
54 forest_map forest ~f:(Filename.to_absolute_exn ~relative_to) |> import
diff --git a/lib/mininix/mininix.ml b/lib/mininix/mininix.ml
new file mode 100644
index 0000000..b121619
--- /dev/null
+++ b/lib/mininix/mininix.ml
@@ -0,0 +1,13 @@
1module Nix2mininix = Nix2mininix
2module Mininix2nix = Mininix2nix
3module Sexp = Sexp
4module Import = Import
5
6let interp_tl ~fuel ~mode ?(imports = []) e =
7 Run.interp ~fuel ~mode ~env:(Import.make_env imports) e
8
9let apply_prelude = Builtins.apply_prelude
10
11let preprocess input ~filename =
12 input |> Nix.parse ~filename |> Nix.elaborate |> Nix2mininix.from_nix
13 |> Builtins.apply_prelude
diff --git a/lib/mininix/mininix2nix.ml b/lib/mininix/mininix2nix.ml
new file mode 100644
index 0000000..efbc42a
--- /dev/null
+++ b/lib/mininix/mininix2nix.ml
@@ -0,0 +1,54 @@
1open Conv
2open Core
3
4(* [or] is not a 'strong' keyword. That means that 'it depends' whether it is
5 identified as such. In the context of the left-hand side of an attribute, it
6 is not recognized as such. *)
7let strong_keywords =
8 [ "with"; "rec"; "let"; "in"; "inherit"; "if"; "then"; "else"; "assert" ]
9
10let id_re = Str.regexp {|^[A-Za-z_]+[A-Za-z0-9'_-]*$|}
11
12let is_simple_id s =
13 Str.string_match id_re s 0
14 && not (List.exists strong_keywords ~f:(String.( = ) s))
15
16let thunk_map_to_map tm =
17 Extraction.thunk_map_fold
18 (fun k t -> Map.add_exn ~key:(String.of_char_list k) ~data:t)
19 (Map.empty (module String))
20 tm
21
22let from_lit l =
23 match l with
24 | Extraction.LitString s -> Nix.Ast.Val (Nix.Ast.Str (str s, []))
25 | Extraction.LitNull -> Nix.Ast.Id "null"
26 | Extraction.LitBool b -> Nix.Ast.Id (if b then "true" else "false")
27 | Extraction.LitNum x ->
28 Nix.Ast.Val
29 (match x with
30 | Extraction.NInt x -> Nix.Ast.Int (x |> Extraction.string_of_Z |> str)
31 | Extraction.NFloat x ->
32 Nix.Ast.Float (Printf.sprintf "%g" (float_from_flocq x)))
33
34let rec from_val = function
35 | Extraction.VClo _ | Extraction.VCloMatch _ -> Nix.Ast.Id "<CODE>"
36 | Extraction.VLit l -> from_lit l
37 | Extraction.VAttr bs ->
38 let bs =
39 thunk_map_to_map bs
40 |> Map.to_alist ~key_order:`Increasing
41 |> List.map ~f:(fun (x, t) ->
42 let lhs =
43 if is_simple_id x then Nix.Ast.Id x
44 else Nix.Ast.Val (Nix.Ast.Str (x, []))
45 in
46 Nix.Ast.AttrPath ([ lhs ], from_thunk t))
47 in
48 Nix.Ast.Val (Nix.Ast.AttSet (Nix.Ast.Nonrec, bs))
49 | Extraction.VList ts -> Nix.Ast.Val (Nix.Ast.List List.(ts >>| from_thunk))
50
51and from_thunk = function
52 | Extraction.Thunk (_, ELit l) -> from_lit l
53 | Extraction.Thunk _ | Extraction.Indirect _ -> Nix.Ast.Id "<CODE>"
54 | Extraction.Forced v -> from_val v
diff --git a/lib/mininix/nix2mininix.ml b/lib/mininix/nix2mininix.ml
new file mode 100644
index 0000000..cfd4fa3
--- /dev/null
+++ b/lib/mininix/nix2mininix.ml
@@ -0,0 +1,254 @@
1open Conv
2open Core
3
4exception FromNixError of string
5
6let try_insert_attr x e bs =
7 let x = chlist x in
8 if Extraction.attr_set_contains x bs then
9 raise (FromNixError "Attribute already exists")
10 else Extraction.attr_set_insert x e bs
11
12(* Shorthands, minor conversions *)
13
14let mn_singleton_set x e =
15 Extraction.(
16 EAttr (attr_set_insert (chlist x) (Attr (NONREC, e)) attr_set_empty))
17
18let mn_abs args e =
19 List.fold_right args ~init:e ~f:(fun arg e' ->
20 Extraction.EAbs (chlist arg, e'))
21
22let mn_lit l = Extraction.ELit l
23let mn_int x = mn_lit (Extraction.LitNum (Extraction.NInt x))
24let mn_float x = mn_lit (Extraction.LitNum (Extraction.NFloat x))
25let mn_bool b = mn_lit (Extraction.LitBool b)
26let mn_true = mn_bool true
27let mn_false = mn_bool false
28let mn_str s = mn_lit (Extraction.LitString (chlist s))
29let mn_null = mn_lit Extraction.LitNull
30let mn_id x = Extraction.EId (chlist x, None)
31let mn_app e1 e2 = Extraction.EApp (e1, e2)
32let mn_seq e1 e2 = Extraction.ESeq (Extraction.SHALLOW, e1, e2)
33let mn_deep_seq e1 e2 = Extraction.ESeq (Extraction.DEEP, e1, e2)
34let mn_list es = Extraction.EList es
35
36let mn_attr (bs : (string * [ `Rec | `Nonrec ] * Extraction.expr) list) =
37 Extraction.EAttr
38 (List.fold_left bs ~init:Extraction.attr_set_empty ~f:(fun bs' (x, r, e) ->
39 let r' =
40 match r with `Rec -> Extraction.REC | `Nonrec -> Extraction.NONREC
41 in
42 Extraction.attr_set_insert (chlist x) (Extraction.Attr (r', e)) bs'))
43
44let mn_with e1 e2 = Extraction.ELetAttr (Extraction.WITH, e1, e2)
45let mn_binop op e1 e2 = Extraction.EBinOp (op, e1, e2)
46let mn_add e1 e2 = mn_binop Extraction.AddOp e1 e2
47let mn_sub e1 e2 = mn_binop Extraction.SubOp e1 e2
48let mn_mul e1 e2 = mn_binop Extraction.MulOp e1 e2
49let mn_div e1 e2 = mn_binop Extraction.DivOp e1 e2
50let mn_bit_and e1 e2 = mn_binop Extraction.AndOp e1 e2
51let mn_bit_or e1 e2 = mn_binop Extraction.OrOp e1 e2
52let mn_bit_xor e1 e2 = mn_binop Extraction.XOrOp e1 e2
53let mn_lt e1 e2 = mn_binop Extraction.LtOp e1 e2
54let mn_eq e1 e2 = mn_binop Extraction.EqOp e1 e2
55let mn_if e1 e2 e3 = Extraction.EIf (e1, e2, e3)
56let mn_delete_attr e1 e2 = mn_binop Extraction.DeleteAttrOp e1 e2
57let mn_has_attr e1 e2 = mn_binop Extraction.HasAttrOp e1 e2
58let mn_select_attr e1 e2 = mn_binop Extraction.SelectAttrOp e1 e2
59
60let mn_singleton_attr e1 e2 =
61 mn_app (mn_binop Extraction.SingletonAttrOp e1 mn_null) e2
62
63let mn_update_attr e1 e2 = mn_binop Extraction.UpdateAttrOp e1 e2
64let mn_type_of e = mn_binop Extraction.TypeOfOp e mn_null
65let mn_function_args e = mn_binop Extraction.FunctionArgsOp e mn_null
66let mn_list_append e1 e2 = mn_binop Extraction.AppendListOp e1 e2
67let mn_list_match e = mn_binop Extraction.MatchListOp e mn_null
68let mn_string_match e = mn_binop Extraction.MatchStringOp e mn_null
69let mn_attr_match e = mn_binop Extraction.MatchAttrOp e mn_null
70let mn_ceil e = mn_binop (Extraction.RoundOp Ceil) e mn_null
71let mn_nearest_even e = mn_binop (Extraction.RoundOp NearestEven) e mn_null
72let mn_floor e = mn_binop (Extraction.RoundOp Floor) e mn_null
73
74(* Macros *)
75
76let mn_cast_bool e = mn_if e mn_true mn_false
77let mn_or e1 e2 = mn_if e1 mn_true (mn_cast_bool e2)
78let mn_and e1 e2 = mn_if e1 (mn_cast_bool e2) mn_false
79let mn_impl e1 e2 = mn_if e1 (mn_cast_bool e2) mn_true
80let mn_not e = mn_if e mn_false mn_true
81let mn_negate e = mn_sub (mn_int Extraction.Internal.BinNums.Z0) e
82let mn_neq e1 e2 = mn_not (mn_eq e2 e1)
83let mn_gt e1 e2 = mn_lt e2 e1
84let mn_lte e1 e2 = mn_not (mn_gt e1 e2)
85let mn_gte e1 e2 = mn_not (mn_lt e1 e2)
86
87(* Macros based on exported functions from the prelude *)
88
89let mnbi_assert e1 e2 = mn_app (mn_app (mn_id "__mn_assert") e1) e2
90let mnbi_has_attr e ds = mn_app (mn_app (mn_id "__mn_attr_has") e) (mn_list ds)
91let mnbi_select e ds = mn_app (mn_app (mn_id "__mn_attr_select") e) (mn_list ds)
92
93let mnbi_select_or e1 ds e2 =
94 mn_app (mn_app (mn_app (mn_id "__mn_attr_selectOr") e1) (mn_list ds)) e2
95
96let mnbi_insert_new e1 e2 e3 =
97 mn_app (mn_app (mn_app (mn_id "__mn_attr_insertNew") e1) e2) e3
98
99let is_dynamic_binding (b : Nix.Ast.binding) =
100 match b with
101 | Nix.Ast.AttrPath ([ Nix.Ast.Val (Nix.Ast.Str (_, [])) ], _)
102 | Nix.Ast.Inherit _ ->
103 false
104 | Nix.Ast.AttrPath ([ _ ], _) -> true
105 | _ -> assert false
106
107let has_dynamic_bindings (bs : Nix.Ast.binding list) =
108 List.exists bs ~f:is_dynamic_binding
109
110(* Static bindings left, dynamic bindings right *)
111let partition_dynamic (bs : Nix.Ast.binding list) :
112 Nix.Ast.binding list * Nix.Ast.binding list =
113 List.fold_left bs ~init:([], []) ~f:(fun (static, dynamic) b ->
114 if is_dynamic_binding b then (static, b :: dynamic)
115 else (b :: static, dynamic))
116
117(* Precondition: e must be have been processed by the elaborator. *)
118let rec from_nix e =
119 match e with
120 | Nix.Ast.BinaryOp (op, e1, e2) -> (
121 let e1', e2' = (from_nix e1, from_nix e2) in
122 match op with
123 | Nix.Ast.Plus -> mn_add e1' e2'
124 | Nix.Ast.Minus -> mn_sub e1' e2'
125 | Nix.Ast.Mult -> mn_mul e1' e2'
126 | Nix.Ast.Div -> mn_div e1' e2'
127 | Nix.Ast.Gt -> mn_gt e1' e2'
128 | Nix.Ast.Lt -> mn_lt e1' e2'
129 | Nix.Ast.Lte -> mn_lte e1' e2'
130 | Nix.Ast.Gte -> mn_gte e1' e2'
131 | Nix.Ast.Eq -> mn_eq e1' e2'
132 | Nix.Ast.Neq -> mn_neq e1' e2'
133 | Nix.Ast.Or -> mn_or e1' e2'
134 | Nix.Ast.And -> mn_and e1' e2'
135 | Nix.Ast.Impl -> mn_impl e1' e2'
136 | Nix.Ast.Merge -> mn_update_attr e1' e2'
137 | Nix.Ast.Concat -> mn_list_append e1' e2')
138 | Nix.Ast.UnaryOp (op, e) -> (
139 let e = from_nix e in
140 match op with Nix.Ast.Negate -> mn_negate e | Nix.Ast.Not -> mn_not e)
141 | Nix.Ast.Cond (e1, e2, e3) -> mn_if (from_nix e1) (from_nix e2) (from_nix e3)
142 | Nix.Ast.With (e1, e2) -> mn_with (from_nix e1) (from_nix e2)
143 | Nix.Ast.Assert (e1, e2) -> mnbi_assert (from_nix e1) (from_nix e2)
144 | Nix.Ast.Test (e, ds) -> mnbi_has_attr (from_nix e) List.(ds >>| from_nix)
145 | Nix.Ast.SetLet bs ->
146 from_nix
147 (Nix.Ast.Select
148 ( Nix.Ast.Val (Nix.Ast.AttSet (Nix.Ast.Rec, bs)),
149 [ Nix.Ast.Val (Nix.Ast.Str ("body", [])) ],
150 None ))
151 | Nix.Ast.Let (bs, e2) ->
152 if has_dynamic_bindings bs then
153 raise (FromNixError "Let bindings may not be dynamic");
154 let e1 = from_nix (Nix.Ast.Val (Nix.Ast.AttSet (Nix.Ast.Rec, bs))) in
155 Extraction.ELetAttr (Extraction.ABS, e1, from_nix e2)
156 | Nix.Ast.Val v -> from_nix_val v
157 | Nix.Ast.Id x -> mn_id x
158 | Nix.Ast.Select (e, parts, md) -> (
159 match md with
160 | Some d ->
161 mnbi_select_or (from_nix e) List.(parts >>| from_nix) (from_nix d)
162 | None -> (
163 match parts with
164 | [ part ] -> mn_select_attr (from_nix e) (from_nix part)
165 | _ -> mnbi_select (from_nix e) List.(parts >>| from_nix)))
166 | Nix.Ast.Apply (e1, e2) -> mn_app (from_nix e1) (from_nix e2)
167 | Nix.Ast.Aquote _ ->
168 assert false (* should be gone after processing by elaborator *)
169
170and from_nix_val v =
171 match v with
172 | Str (s, parts) ->
173 let parts = List.(parts >>= fun (e, s) -> [ from_nix e; mn_str s ]) in
174 List.fold_left parts ~init:(mn_str s) ~f:mn_add
175 | IStr _ -> raise (FromNixError "Indented strings are not supported")
176 | Int n -> (
177 match Extraction.string_to_Z (chlist n) with
178 | Some n -> mn_int n
179 | None -> raise (FromNixError "Bad integer literal"))
180 | Float n ->
181 let n =
182 try Float.of_string n
183 with Invalid_argument _ -> raise (FromNixError "Bad float literal")
184 in
185 if Float.(is_nan n || is_inf n) then
186 raise (FromNixError "Bad float literal")
187 else mn_float (float_to_flocq n)
188 | Path _ | SPath _ | HPath _ -> raise (FromNixError "Paths are not supported")
189 | Uri s -> mn_str s
190 | Lambda (Alias x, e) -> mn_abs [ x ] (from_nix e)
191 | Lambda (ParamSet (Some x, fs), e) ->
192 from_nix_val
193 (Lambda (Alias x, Apply (Val (Lambda (ParamSet (None, fs), e)), Id x)))
194 | Lambda (ParamSet (None, (fs, strictness)), e) ->
195 let ms =
196 List.fold_left fs ~init:Extraction.matcher_empty ~f:(fun ms (x, me) ->
197 Extraction.matcher_insert (chlist x) (Option.map ~f:from_nix me) ms)
198 in
199 Extraction.EAbsMatch
200 ( ms,
201 (match strictness with Loose -> false | Exact -> true),
202 from_nix e )
203 | List es -> mn_list (List.map es ~f:from_nix)
204 | AttSet (recursivity, bs) ->
205 let static, dynamic = partition_dynamic bs
206 and recursivity' =
207 match recursivity with
208 | Nix.Ast.Rec -> Extraction.REC
209 | Nix.Ast.Nonrec -> Extraction.NONREC
210 in
211
212 let set_no_dyn =
213 Extraction.EAttr
214 (List.fold_left static ~init:Extraction.attr_set_empty
215 ~f:(fun static' bnd ->
216 match bnd with
217 | Nix.Ast.AttrPath ([ Nix.Ast.Val (Nix.Ast.Str (x, [])) ], e) ->
218 try_insert_attr x
219 (Extraction.Attr (recursivity', from_nix e))
220 static'
221 | Nix.Ast.Inherit (None, xs) ->
222 List.fold_left xs ~init:static' ~f:(fun static' x ->
223 match x with
224 | Id x ->
225 try_insert_attr x
226 (Extraction.Attr (Extraction.NONREC, mn_id x))
227 static'
228 | _ -> assert false)
229 | Nix.Ast.Inherit (Some e, xs) ->
230 let e = from_nix e in
231 List.fold_left xs ~init:static' ~f:(fun static' x ->
232 match x with
233 | Id x ->
234 try_insert_attr x
235 (Extraction.Attr
236 (recursivity', mn_select_attr e (mn_str x)))
237 static'
238 | _ -> assert false)
239 | _ -> assert false))
240 in
241
242 List.fold_right dynamic ~init:set_no_dyn ~f:(fun bnd set ->
243 match bnd with
244 | Nix.Ast.AttrPath ([ d ], e) ->
245 mnbi_insert_new set
246 (match recursivity with
247 | Nix.Ast.Rec ->
248 Extraction.ELetAttr (Extraction.ABS, set_no_dyn, from_nix d)
249 | Nix.Ast.Nonrec -> from_nix d)
250 (match recursivity with
251 | Nix.Ast.Rec ->
252 Extraction.ELetAttr (Extraction.ABS, set_no_dyn, from_nix e)
253 | Nix.Ast.Nonrec -> from_nix e)
254 | _ -> assert false)
diff --git a/lib/mininix/run.ml b/lib/mininix/run.ml
new file mode 100644
index 0000000..f33bace
--- /dev/null
+++ b/lib/mininix/run.ml
@@ -0,0 +1,17 @@
1open Core
2
3(* The [n]th Church numeral *)
4let rec church n f x = if n <= 0 then x else church (n - 1) f (f x)
5
6let limited =
7 church 2048
8 (fun x -> Extraction.Internal.Datatypes.S x)
9 Extraction.Internal.Datatypes.O
10
11let rec infinity = Extraction.Internal.Datatypes.S infinity
12
13let interp ~fuel ~mode ~env e =
14 let mode : Extraction.mode =
15 match mode with `Shallow -> SHALLOW | `Deep -> DEEP
16 and fuel = match fuel with `Unlimited -> infinity | `Limited -> limited in
17 Extraction.interp' fuel mode env e
diff --git a/lib/mininix/sexp.ml b/lib/mininix/sexp.ml
new file mode 100644
index 0000000..95da655
--- /dev/null
+++ b/lib/mininix/sexp.ml
@@ -0,0 +1,160 @@
1open Conv
2open Core
3open Extraction
4
5exception ToSexpError of string
6
7let tag t l = Sexp.List (Sexp.Atom t :: l)
8
9let lit_to_sexp = function
10 | LitString s -> tag "LitString" [ Sexp.Atom (str s) ]
11 | LitNum (NInt n) ->
12 tag "LitNum" [ Sexp.Atom "INT"; Sexp.Atom (str (string_of_Z n)) ]
13 | LitNum (NFloat n) ->
14 tag "LitNum"
15 [
16 Sexp.Atom "FLOAT";
17 Sexp.Atom (Printf.sprintf "%g" (float_from_flocq n));
18 ]
19 | LitBool b -> tag "LitBool" [ Sexp.Atom (Bool.to_string b) ]
20 | LitNull -> tag "LitNull" []
21
22let option_to_sexp mv ~f =
23 match mv with Some v -> tag "Some" [ f v ] | None -> Sexp.Atom "None"
24
25let mode_to_sexp mode =
26 Sexp.Atom (match mode with SHALLOW -> "SHALLOW" | DEEP -> "DEEP")
27
28let rec_to_sexp r = Sexp.Atom (match r with REC -> "REC" | NONREC -> "NONREC")
29
30let binop_to_sexp op =
31 Sexp.Atom
32 (match op with
33 | UpdateAttrOp -> "UpdateAttrOp"
34 | AddOp -> "AddOp"
35 | SubOp -> "SubOp"
36 | MulOp -> "MulOp"
37 | DivOp -> "DivOp"
38 | AndOp -> "AndOp"
39 | OrOp -> "OrOp"
40 | XOrOp -> "XOrOp"
41 | RoundOp Ceil -> "Ceil"
42 | RoundOp NearestEven -> "NearestEven"
43 | RoundOp Floor -> "Floor"
44 | LtOp -> "LtOp"
45 | EqOp -> "EqOp"
46 | HasAttrOp -> "HasAttrOp"
47 | SelectAttrOp -> "SelectAttrOp"
48 | DeleteAttrOp -> "DeleteAttrOp"
49 | SingletonAttrOp -> "SingletonAttrOp"
50 | TypeOfOp -> "TypeOfOp"
51 | AppendListOp -> "AppendListOp"
52 | MatchAttrOp -> "MatchAttrOp"
53 | MatchListOp -> "MatchListOp"
54 | MatchStringOp -> "MatchStringOp"
55 | FunctionArgsOp -> "FunctionArgsOp")
56
57let kind_to_sexp k = Sexp.Atom (match k with ABS -> "ABS" | WITH -> "WITH")
58
59let rec expr_to_sexp = function
60 | ELit l -> tag "ELit" [ lit_to_sexp l ]
61 | EId (x, None) -> tag "EId" [ Sexp.Atom (str x) ]
62 | EId (x, Some (k, e)) ->
63 tag "EId"
64 [ Sexp.Atom (str x); tag "alt" [ kind_to_sexp k; expr_to_sexp e ] ]
65 | EAbs (x, e) -> tag "EAbs" [ Sexp.Atom (str x); expr_to_sexp e ]
66 | EAbsMatch (ms, strict, e) ->
67 tag "EAbsMatch"
68 [
69 Sexp.Atom (if strict then "EXACT" else "LOOSE");
70 tag "formals"
71 (matcher_fold
72 (fun x me se ->
73 Sexp.List
74 [ Sexp.Atom (str x); option_to_sexp me ~f:expr_to_sexp ]
75 :: se)
76 [] ms);
77 expr_to_sexp e;
78 ]
79 | EApp (e1, e2) -> tag "EApp" [ expr_to_sexp e1; expr_to_sexp e2 ]
80 | ELetAttr (k, e1, e2) ->
81 tag "ELetAttr" [ kind_to_sexp k; expr_to_sexp e1; expr_to_sexp e2 ]
82 | ESeq (mode, e1, e2) ->
83 tag "ESeq" [ mode_to_sexp mode; expr_to_sexp e1; expr_to_sexp e2 ]
84 | EAttr bs ->
85 tag "EAttr"
86 (attr_set_fold
87 (fun x (Attr (r, e)) se ->
88 Sexp.List [ Sexp.Atom (str x); rec_to_sexp r; expr_to_sexp e ]
89 :: se)
90 [] bs)
91 | EList es ->
92 tag "EList"
93 (Internal.List.fold_right (fun e se -> expr_to_sexp e :: se) [] es)
94 | EBinOp (op, e1, e2) ->
95 tag "EBinOp" [ binop_to_sexp op; expr_to_sexp e1; expr_to_sexp e2 ]
96 | EIf (e1, e2, e3) ->
97 tag "EIf" [ expr_to_sexp e1; expr_to_sexp e2; expr_to_sexp e3 ]
98
99let rec val_to_sexp = function
100 | VLit l -> tag "VLit" [ lit_to_sexp l ]
101 | VClo _ -> tag "VClo" []
102 | VCloMatch _ -> tag "VCloMatch" []
103 | VAttr bs ->
104 tag "VAttr"
105 (Extraction.thunk_map_fold
106 (fun x t bs' ->
107 Sexp.List [ Sexp.Atom (str x); thunk_to_sexp t ] :: bs')
108 [] bs)
109 | VList ts ->
110 tag "VList"
111 (Internal.List.fold_right (fun t st -> thunk_to_sexp t :: st) [] ts)
112
113and env_to_sexp env =
114 tag "Env"
115 (Extraction.env_fold
116 (fun x (k, t) envs ->
117 Sexp.List
118 [
119 Sexp.Atom (str x);
120 Sexp.Atom
121 (match k with
122 | Extraction.ABS -> "ABS"
123 | Extraction.WITH -> "WITH");
124 thunk_to_sexp t;
125 ]
126 :: envs)
127 [] env)
128
129and thunk_to_sexp = function
130 | Thunk _ -> tag "Thunk" [ Sexp.Atom "DELAYED" ]
131 | Indirect _ -> tag "Thunk" [ Sexp.Atom "INDIRECT" ]
132 | Forced v -> tag "Thunk" [ Sexp.Atom "FORCED"; val_to_sexp v ]
133
134let expr_res_to_sexp = function
135 | NoFuel -> Sexp.Atom "NoFuel"
136 | Res e -> tag "Res" [ option_to_sexp e ~f:expr_to_sexp ]
137
138let val_res_to_sexp = function
139 | NoFuel -> Sexp.Atom "NoFuel"
140 | Res e -> tag "Res" [ option_to_sexp e ~f:val_to_sexp ]
141
142let rec (sexp_of_import_tree : Import.tree -> Sexp.t) = function
143 | { filename; deps = [] } -> Sexp.Atom filename
144 | { filename; deps } ->
145 Sexp.List [ Sexp.Atom filename; sexp_of_import_forest deps ]
146
147and sexp_of_import_forest forest =
148 Sexp.List (Sexp.Atom "deps" :: List.map forest ~f:sexp_of_import_tree)
149
150exception OfSexpError of string
151
152let rec import_tree_of_sexp : Sexp.t -> Import.tree = function
153 | Sexp.Atom filename -> { filename; deps = [] }
154 | Sexp.List [ Sexp.Atom filename; deps ] ->
155 { filename; deps = import_forest_of_sexp deps }
156 | _ -> raise (OfSexpError "Could not parse import tree")
157
158and import_forest_of_sexp = function
159 | Sexp.List (Sexp.Atom "deps" :: deps) -> List.map ~f:import_tree_of_sexp deps
160 | _ -> raise (OfSexpError "Could not parse import forest")
generated by cgit v1.2.3 (git 2.49.0) at 2025-10-13 23:21:19 +0000