diff options
Diffstat (limited to 'lib/mininix/nix2mininix.ml')
-rw-r--r-- | lib/mininix/nix2mininix.ml | 254 |
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 @@ | |||
1 | open Conv | ||
2 | open Core | ||
3 | |||
4 | exception FromNixError of string | ||
5 | |||
6 | let 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 | |||
14 | let mn_singleton_set x e = | ||
15 | Extraction.( | ||
16 | EAttr (attr_set_insert (chlist x) (Attr (NONREC, e)) attr_set_empty)) | ||
17 | |||
18 | let mn_abs args e = | ||
19 | List.fold_right args ~init:e ~f:(fun arg e' -> | ||
20 | Extraction.EAbs (chlist arg, e')) | ||
21 | |||
22 | let mn_lit l = Extraction.ELit l | ||
23 | let mn_int x = mn_lit (Extraction.LitNum (Extraction.NInt x)) | ||
24 | let mn_float x = mn_lit (Extraction.LitNum (Extraction.NFloat x)) | ||
25 | let mn_bool b = mn_lit (Extraction.LitBool b) | ||
26 | let mn_true = mn_bool true | ||
27 | let mn_false = mn_bool false | ||
28 | let mn_str s = mn_lit (Extraction.LitString (chlist s)) | ||
29 | let mn_null = mn_lit Extraction.LitNull | ||
30 | let mn_id x = Extraction.EId (chlist x, None) | ||
31 | let mn_app e1 e2 = Extraction.EApp (e1, e2) | ||
32 | let mn_seq e1 e2 = Extraction.ESeq (Extraction.SHALLOW, e1, e2) | ||
33 | let mn_deep_seq e1 e2 = Extraction.ESeq (Extraction.DEEP, e1, e2) | ||
34 | let mn_list es = Extraction.EList es | ||
35 | |||
36 | let 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 | |||
44 | let mn_with e1 e2 = Extraction.ELetAttr (Extraction.WITH, e1, e2) | ||
45 | let mn_binop op e1 e2 = Extraction.EBinOp (op, e1, e2) | ||
46 | let mn_add e1 e2 = mn_binop Extraction.AddOp e1 e2 | ||
47 | let mn_sub e1 e2 = mn_binop Extraction.SubOp e1 e2 | ||
48 | let mn_mul e1 e2 = mn_binop Extraction.MulOp e1 e2 | ||
49 | let mn_div e1 e2 = mn_binop Extraction.DivOp e1 e2 | ||
50 | let mn_bit_and e1 e2 = mn_binop Extraction.AndOp e1 e2 | ||
51 | let mn_bit_or e1 e2 = mn_binop Extraction.OrOp e1 e2 | ||
52 | let mn_bit_xor e1 e2 = mn_binop Extraction.XOrOp e1 e2 | ||
53 | let mn_lt e1 e2 = mn_binop Extraction.LtOp e1 e2 | ||
54 | let mn_eq e1 e2 = mn_binop Extraction.EqOp e1 e2 | ||
55 | let mn_if e1 e2 e3 = Extraction.EIf (e1, e2, e3) | ||
56 | let mn_delete_attr e1 e2 = mn_binop Extraction.DeleteAttrOp e1 e2 | ||
57 | let mn_has_attr e1 e2 = mn_binop Extraction.HasAttrOp e1 e2 | ||
58 | let mn_select_attr e1 e2 = mn_binop Extraction.SelectAttrOp e1 e2 | ||
59 | |||
60 | let mn_singleton_attr e1 e2 = | ||
61 | mn_app (mn_binop Extraction.SingletonAttrOp e1 mn_null) e2 | ||
62 | |||
63 | let mn_update_attr e1 e2 = mn_binop Extraction.UpdateAttrOp e1 e2 | ||
64 | let mn_type_of e = mn_binop Extraction.TypeOfOp e mn_null | ||
65 | let mn_function_args e = mn_binop Extraction.FunctionArgsOp e mn_null | ||
66 | let mn_list_append e1 e2 = mn_binop Extraction.AppendListOp e1 e2 | ||
67 | let mn_list_match e = mn_binop Extraction.MatchListOp e mn_null | ||
68 | let mn_string_match e = mn_binop Extraction.MatchStringOp e mn_null | ||
69 | let mn_attr_match e = mn_binop Extraction.MatchAttrOp e mn_null | ||
70 | let mn_ceil e = mn_binop (Extraction.RoundOp Ceil) e mn_null | ||
71 | let mn_nearest_even e = mn_binop (Extraction.RoundOp NearestEven) e mn_null | ||
72 | let mn_floor e = mn_binop (Extraction.RoundOp Floor) e mn_null | ||
73 | |||
74 | (* Macros *) | ||
75 | |||
76 | let mn_cast_bool e = mn_if e mn_true mn_false | ||
77 | let mn_or e1 e2 = mn_if e1 mn_true (mn_cast_bool e2) | ||
78 | let mn_and e1 e2 = mn_if e1 (mn_cast_bool e2) mn_false | ||
79 | let mn_impl e1 e2 = mn_if e1 (mn_cast_bool e2) mn_true | ||
80 | let mn_not e = mn_if e mn_false mn_true | ||
81 | let mn_negate e = mn_sub (mn_int Extraction.Internal.BinNums.Z0) e | ||
82 | let mn_neq e1 e2 = mn_not (mn_eq e2 e1) | ||
83 | let mn_gt e1 e2 = mn_lt e2 e1 | ||
84 | let mn_lte e1 e2 = mn_not (mn_gt e1 e2) | ||
85 | let mn_gte e1 e2 = mn_not (mn_lt e1 e2) | ||
86 | |||
87 | (* Macros based on exported functions from the prelude *) | ||
88 | |||
89 | let mnbi_assert e1 e2 = mn_app (mn_app (mn_id "__mn_assert") e1) e2 | ||
90 | let mnbi_has_attr e ds = mn_app (mn_app (mn_id "__mn_attr_has") e) (mn_list ds) | ||
91 | let mnbi_select e ds = mn_app (mn_app (mn_id "__mn_attr_select") e) (mn_list ds) | ||
92 | |||
93 | let mnbi_select_or e1 ds e2 = | ||
94 | mn_app (mn_app (mn_app (mn_id "__mn_attr_selectOr") e1) (mn_list ds)) e2 | ||
95 | |||
96 | let mnbi_insert_new e1 e2 e3 = | ||
97 | mn_app (mn_app (mn_app (mn_id "__mn_attr_insertNew") e1) e2) e3 | ||
98 | |||
99 | let 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 | |||
107 | let has_dynamic_bindings (bs : Nix.Ast.binding list) = | ||
108 | List.exists bs ~f:is_dynamic_binding | ||
109 | |||
110 | (* Static bindings left, dynamic bindings right *) | ||
111 | let 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. *) | ||
118 | let 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 | |||
170 | and 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) | ||