aboutsummaryrefslogtreecommitdiffstats
path: root/lib/mininix/nix2mininix.ml
diff options
context:
space:
mode:
Diffstat (limited to 'lib/mininix/nix2mininix.ml')
-rw-r--r--lib/mininix/nix2mininix.ml254
1 files changed, 254 insertions, 0 deletions
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)