summaryrefslogtreecommitdiff
path: root/myocamlbuild_config.ml (plain)
blob: 287b2033da2d00edd17fd44d5adc9c04bbee773f
1(**
2 Symbiosis configuration file
3 Ocamlbuild currently doesn't allow linking with other files,
4 so we collect everything we need here in separate modules.
5 *)
6
7
8module Util = struct
9
10 (* raises not found if c not in string *)
11 let split_first c s =
12 let k = String.index s c in
13 let n = String.length s in
14 String.sub s 0 k, String.sub s (k + 1) (n - k - 1)
15
16 (* raises not found if c not in string *)
17 let split_last c s =
18 let k = String.rindex s c in
19 let n = String.length s in
20 String.sub s 0 k, String.sub s (k + 1) (n - k - 1)
21
22 let split c s =
23 let n = String.length s in
24 let rec again i lst =
25 begin try let k = String.rindex_from s i c in
26 again (k - 1) ((if i = k then "" else (String.sub s (k + 1) (i - k))) :: lst)
27 with _ -> (String.sub s 0 (i + 1)) :: lst
28 end
29 in again (n - 1) []
30
31 let prechomp prefix s =
32 let k = String.length prefix in
33 let n = String.length s in
34 try
35 if k > n then raise Not_found;
36 for i = 0 to k - 1 do
37 if prefix.[i] <> s.[i] then raise Not_found
38 done;
39 if k = n then "" else String.sub s k (n - k)
40 with Not_found -> s
41
42 let chomp suffix s =
43 let k = String.length suffix in
44 let n = String.length s in
45 try
46 if k > n then raise Not_found;
47 for i = 0 to k - 1 do
48 if suffix.[i] <> s.[n - k + i] then raise Not_found
49 done;
50 if k = n then "" else String.sub s 0 (n - k)
51 with Not_found -> s
52
53 (* generic value type for navigating variant values - derived from JSON types
54 but useful in other contexts also *)
55 module Value = struct
56 type value_type =
57 Object of (string * value_type) list
58 | Array of value_type list
59 | String of string
60 | Int of int
61 | Float of float
62 | Bool of bool
63 | Null
64 end
65
66end (* end of Util module *)
67
68
69module Fleece = struct
70
71(** Fleece is a combinator library, primarily for parsing json files,
72 but can be used for general configuration file parsing *)
73
74 module Combinator = struct
75
76 module Stream = struct
77 (** simple streams for parsing strings and lists
78 compatible with Abstract_stream semantics *)
79
80 (** Creates a stream reading from a list without using
81 the reference implemention. *)
82 let list_stream input output =
83 (input, output),
84 (fun p wx (i, o as state) -> match i with
85 | [] -> (state, false)
86 | x :: i' -> if p x then (i', wx x o), true else state, false)
87
88 (* low level input state manipulators to carry extra payload such as line numbers *)
89 let _pos0 = 0, 1, 1
90 let _nextpos (off, ln, col) x =
91 if x = '\n' then (off + 1, ln + 1, 1) else (off + 1, ln, col + 1)
92 let _pos (off, ln, col) = off
93
94 (** parse a sub string *)
95 let substring_stream (s, i0, len) output =
96 let n = (_pos i0) + len in
97 if (_pos i0) < 0 || len < 0 || n > (String.length s)
98 then raise (Invalid_argument "substring_stream offset or length out of bounds");
99 (i0, output),
100 (fun p wx (i, o as state) -> if (_pos i) = n then state, false else
101 let x = String.unsafe_get s (_pos i) in
102 if p x then ((_nextpos i x), wx x o), true else state, false)
103
104 let string_stream s output = substring_stream (s, _pos0, (String.length s)) output
105
106 let output ((i, o),n) = o
107 let input ((i, o), n) = i
108 let is_empty (s, n) = not (snd (n (fun _ -> true) (fun _ o -> o) s))
109
110 (* peek next char for char streams - intended for error reporting *)
111 let peek_string_stream (state, n as s) =
112 if is_empty s then raise Not_found;
113 let m = ref 'x' in
114 let wx x s = m := x; s in
115 let _, _ = n (fun x -> true) wx state in !m
116
117 end
118
119 module Result = struct
120
121 type annotation = string
122 type 's stream = 's
123
124 type 's errors = ('s stream * annotation) list
125 type 's status =
126 | Success
127 | Failure of 's errors
128 | Optional of 's errors (* optional that did not succeed, but isn't a failure either *)
129
130 type 's result = 's stream * 's status
131 let stream (s, r) = s
132 let status (s, r) = r
133 let valid = function Success | Optional _ -> true | _ -> false
134 let invalid r = not (valid r)
135 let succeeded r = r = Success
136
137 end (* end of Result module *)
138
139 module StreamAccessor = struct
140 (** Stream accessors - parser interface to streams, regardless of implementation *)
141
142 (*
143
144 type input
145 type output
146 type predicate_symbol
147 type write_symbol
148 type annotation = string
149
150 type state = input * output
151 type predicate = predicate_symbol -> bool
152 type annotated_predicate = predicate * annotation
153 type symbol_writer = write_symbol -> output -> output
154 type stream_next = predicate -> symbol_writer -> state -> state * bool
155 type stream = state * stream_next
156 type generator = output -> output
157
158 stream interface:
159
160 Input state may be as simple as a buffer offset, output state could be nil ()
161
162 We allow predicates and symbol writers to have different types,
163 but conceptually they refer to the same symbol.
164
165 In the following 'return false' means:
166 applying 'valid' to the returned status should yield false
167 and vice versa for true.
168
169 - next must return false if the input stream is false
170 - next must return unmodified input and output stream if it returns false
171 - next must give current output state and store new state from writer
172 - next must only call writer iff the stream returns true
173 - next with true predicate can only return false if the input stream is empty
174 - next with false predicate will always return false
175 - the output state is ignored except through user supplied writers
176 - next can be applied to an old state multiple times (backtracking)
177 - the parser considers the stream opaque
178 - the default write and next implementation assumes structure on the stream
179 ... but this can be replaced
180 - exceptions will terminate parser,
181 ... consider having next capture End_of_input and return false
182
183 *)
184
185 open Result
186
187 (* constructors *)
188 let failure ann s = Failure [s, ann]
189 let success = Success
190
191 let return r s = s, r
192 let optional r s = match r with
193 | Failure e -> return (Optional e) s
194 | Optional _ | Success -> return r s
195
196 (* assymetrical - assuming result is no worse than second argument *)
197 let merge r1 r2 = match r1, r2 with
198 | Success, Success -> Success
199 | Success, Optional e2 -> r2
200 | Success, Failure e2 -> r2
201 | Optional e1, Success -> r2
202 | Optional e1, Optional e2 -> Optional (e1 @ e2)
203 | Optional e1, Failure e2 -> Failure (e1 @ e2)
204 | Failure e1, Success -> r2
205 | Failure e1, Optional e2 -> Optional (e1 @ e2)
206 | Failure e1, Failure e2 -> Failure (e1 @ e2)
207
208
209 (** Functions needed by combinators to parse a stream.
210 This hides the internal stream representation.*)
211
212 let next (pred, ann) wx s =
213 let (state, stream_next) = s in
214 let state', ok = stream_next pred wx state in
215 let stream = (state', stream_next) in
216 if ok then return success stream
217 else return (failure ann stream) stream
218
219 (**
220 Given a generator function w: output -> output and a stream s,
221 write (manipulate) the output without affecting the input.
222 Always succeed for compatibility with the next return type.
223 *)
224 let write w s =
225 let ((input, output), next) = s in
226 return success ((input, w output), next)
227
228 end
229
230 open StreamAccessor
231 include Result
232
233 (* literal writer for emit_sat that writes nothing *)
234 let discard x o = o
235
236 (* predicates for sat *)
237 let always x = true
238 let never x = false
239 let eq x = ((=) x)
240 let ne x = ((<>) x)
241 let below x = ((>) x)
242 let above x = ((<) x)
243 let inside x y = (fun z -> z >= x && y >= z)
244 let outside x y = (fun z -> z < x || y < z)
245
246 (* basic combinators *)
247
248 let fail msg s = return (failure msg s) s
249 let succeed s = return success s
250
251 let bind a b s = let sa, ra = a s in if invalid ra then return ra s
252 else let sb, rb = b sa in return (merge ra rb) sb
253
254 let xor a b s = let sa, ra = a s in if valid ra then return ra sa else
255 let sb, rb = b s in if valid rb then return rb sb else return (merge ra rb) s
256
257 let opt a s = let sa, ra = a s in if valid ra then return ra sa else optional ra s
258
259 (* negate is useful to test empty stream, but not intended as general purpose *)
260 let neg ann a s = let sa, ra = a s in if valid ra then fail ann s else succeed s
261
262 (* parser combinators *)
263
264 (* inject error in parser to have it return location *)
265 let trace msg s = fail ("trace:" ^ msg) s
266 let trace_off msg s = succeed s
267
268 let seq = bind
269 let alt = xor
270
271 (** Write to, or otherwise transform the output stream
272 using writer w : output -> output
273
274 For example, inspect earlier parse results from output
275 and write an updated result stack example:
276
277 stmt = seqs [lit ' '; str "<statement>"; write (fun s :: t -> (Stmt s) :: t)]
278 if_stmt_parser = seqs [str "if"; expr; str "then"; stmt; str "else"; stmt ]
279 seq if_stmt_parser
280 (write (fun o -> match o with
281 | (Stmt _else) :: (Stmt _then) :: If :: tl
282 -> (Stmt (If (_then, _else))) :: tl
283 | _ -> o))
284
285 Note that terminal parsers like sat, lit, and any
286 uses another writer type that also receives the matched symbol as input *)
287 let write w s = StreamAccessor.write w s
288
289 (** Attach a writer after a successful parse
290
291 For example:
292 emit if_stmt_parser (fun o -> match o with ... -> ...)
293
294 See also write
295 *)
296 let emit a w s = bind a (write w) s
297
298 (** Read a symbol from stream s, match it with predicate p: x -> bool
299 and write the symbol to output with generator
300 wx: x' -> output -> output
301 Fail if stream is empty or the predicate does not match.
302 The symbol type x depends on the stream.
303 generator wx and predicate p may use different types for x and x'. *)
304 let emit_sat p wx s = StreamAccessor.next p wx s
305 let emit_any ann wx s = emit_sat (always, ann) wx s
306 let emit_lit (x, ann) wx s = emit_sat (eq x, ann) wx s
307
308 let sat p s = emit_sat p discard s
309 let any ann s = sat (always, ann) s
310 let lit (x, ann) s = sat ((eq x), ann) s
311 let none ann s = neg ann (any ann) s (* we don't cary about ann for any, but it needs an argument *)
312 let rec loop a s = opt (seq a (loop a)) s (* a* *)
313 let repeat a s = seq a (loop a) s (* a+ *)
314 let alts ann lst s = (List.fold_left alt (fail ann) lst) s
315 let seqs lst s = (List.fold_left seq succeed lst) s
316 let par lpar body rpar = seq lpar (seq body rpar)
317 let list_term elem term = repeat (seq elem term) (* (a;)+ *)
318 let list_sep elem sep = seq elem (loop (seq sep elem)) (* a(, a)* *)
319 let list_trail elem sep = seq (list_sep elem sep) (opt sep) (* a (, a)*[,] *)
320
321 (* match string in character stream *)
322 let emit_str (xs, ann) wx s =
323 let m, i, n = ref (succeed s), ref 0, String.length xs in
324 while !i < n && valid (status !m) do
325 m := emit_lit ((String.unsafe_get xs !i), ann) wx (stream !m); i := !i + 1;
326 done; if !i = n && valid (status !m) then !m else fail xs s
327
328 let str (xs, ann) s = emit_str (xs, ann) discard s
329 end (* end of module Combinator *)
330
331 (* for compatibility with OCaml JSON Wheel types *)
332 module Json_type = struct
333 include Util.Value
334
335 type json_type = value_type
336 type t = json_type
337
338 exception Json_error of string
339
340 end (* end of Json_type module *)
341
342 module Json_parser = struct
343
344 open Json_type
345
346 include Combinator
347
348 (* annotate literals *)
349 let emit_lit c = emit_lit (c, Char.escaped c)
350 let lit c = lit (c, Char.escaped c)
351 let str s = str (s, s)
352
353 type json_stack = t list
354 type lexeme = string * int
355 type output = lexeme * json_stack
356 let fail msg = raise (Invalid_argument ("Internal parser error, invalid " ^ msg))
357
358
359 let create_lex n = (String.create n), 0
360 let advance_lex (buf, pos) need =
361 if pos + need >= String.length buf then
362 let b = String.create (max (2 * pos) (pos + need)) in
363 String.blit buf 0 b 0 pos; (b, pos + need) else (buf, pos + need)
364
365 let create_output_stream () = (create_lex 100, [])
366
367 let wmark ((buf, pos), values) = ((buf, 0), values)
368 let wchar c (lex, values) =
369 let buf, pos as lex = advance_lex lex 1 in
370 String.unsafe_set buf (pos - 1) c;
371 lex, values
372
373 let push v (lex, values) = (lex, v :: values)
374 let lexeme ((buf, pos), values) = String.sub buf 0 pos
375 let stack (lex, values) = values
376 let update_stack new_values (lex, values) = (lex, new_values)
377
378 let int_of_hex (c:char) = (Char.code c) + match c with
379 | '0' .. '9' -> - (Char.code '0')
380 | 'A' .. 'F' -> 10 - (Char.code 'A')
381 | 'a' .. 'f' -> 10 - (Char.code 'a')
382 | _ -> fail "hex digit"
383 let wcode k o = wchar (Char.unsafe_chr k) o
384 let encode_utf8 k o =
385 (* derived from extlib utf8 string *)
386 let masq = 0b111111 in
387 if k <= 0x7f then
388 wcode k o
389 else if k <= 0x7ff then begin
390 let o = wcode (0xc0 lor (k lsr 6)) o in
391 wcode (0x80 lor (k land masq)) o
392 end else begin
393 let o = wcode (0xe0 lor (k lsr 12)) o in
394 let o = wcode (0x80 lor ((k lsr 6) land masq)) o in
395 wcode (0x80 lor (k land masq)) o
396 end
397
398 let wescape x o =
399 let x = match x with
400 | '"' -> '\x22' | '\\' -> '\x5C' | '/' -> '\x2F' | 'b' -> '\x08'
401 | 'f' -> '\x0C' | 'n' -> '\x0A' | 'r' -> '\x0D' | 't' -> '\x09'
402 | _ -> fail "escape code"
403 in wchar x o
404
405 let wnum o =
406 let num = (lexeme o) in if String.contains num '.'
407 then push (Float (float_of_string num)) o
408 else push (Int (int_of_string num)) o
409 let wunicode o = push (Int 0) o
410 let wutf8 o = match stack o with Int x :: vs ->
411 encode_utf8 x (update_stack vs o) | _ -> fail "unicode"
412 let wudigit c o = match stack o with Int x :: vs ->
413 push (Int ((x * 16) + (int_of_hex c))) (update_stack vs o) | _ -> fail "hex digit"
414 let wstring o = push (String (lexeme o)) o
415 let wtrue o = push (Bool true) o
416 let wfalse o = push (Bool false) o
417 let wnull o = push Null o
418 let warray o = push (Array []) o
419 let wobject o = push (Object []) o
420
421 let reduce_element o = match stack o with value :: Array (elements) :: vs ->
422 update_stack (Array (value::elements) :: vs) o | _ -> fail "element reduction"
423 let reduce_member o = match stack o with value :: String name :: Object members :: vs ->
424 update_stack (Object ((name, value) :: members) :: vs) o | _ -> fail "member reduction"
425 let reduce_array o = match stack o with Array elements :: vs ->
426 update_stack (Array (List.rev elements) :: vs) o | _ -> fail "array reduction"
427 let reduce_object o = match stack o with Object members :: vs ->
428 update_stack (Object (List.rev members) :: vs) o | _ -> fail "object reduction"
429
430 (* 'overload' common parser operations to emit content *)
431 let esat p s = emit_sat p wchar s
432 let elit c s = emit_lit c wchar s
433 let space s = loop (sat ((function ' ' | '\t' | '\r' | '\n' -> true | _ -> false),
434 (* annotation we don't want to see as a parser alternative in error reports - prefixed by @@ as a convention *)
435 "@@whitespace ' ', \\t, \\r, or \\n")) s
436 let token t s = seq (emit space wmark) t s
437 let delim c s = seq space (lit c) s
438
439 (* Collect number in lexeme buffer - the token 'wmark' operation resets buffer
440 TODO: BUG: parser backtraces on '1.2e' after trying optional exponent expr., but
441 buffer keeps the 'e' resulting in incorrect conversion before discovering parse error on subsequent input *)
442 let digit s = esat ((function '0' .. '9' -> true | _ -> false), "digit 0-9") s
443 let digits s = repeat digit s
444 let sign s = esat ((function '+' | '-' -> true | _ -> false), "sign +/-") s
445 let posdigit s = esat ((function '1' .. '9' -> true | _ -> false), "digit 1-9") s
446 let exp s = esat ((function 'E' | 'e' -> true | _ -> false), "exponent E/e") s
447 let num s = seqs [opt (elit '-'); alt (elit '0') (seq posdigit (opt digits));
448 opt (seq (elit '.') digits); opt (seqs [exp; opt sign; digits])] s
449
450 (* Collect string in lexeme buffer - translate escapes along the way
451 Unicode hex escapes are pushed as int on the stack and converted to integer,
452 then added to lexeme buffer as utf-8 - stack use mainly because buffer can't truncate. *)
453 let udigit s = emit_sat ((function '0'..'9' | 'A'..'F' | 'a'..'f' -> true | _ -> false),
454 "hex digit for unicode sequence \\uhhhh: 0-9, A-F or a-f") wudigit s
455 let unicode s = seqs [lit 'u'; write wunicode; udigit; udigit; udigit; udigit; write wutf8] s
456 let esccode s = emit_sat ((function '"' | '\\' | '/'
457 | 'b' | 'f' | 'n' | 'r' | 't' -> true | _ -> false), "escape character following '\\': \", b, f, n, r or t") wescape s
458 let esc s = seq (lit '\\') (alt esccode unicode) s
459 let text s = repeat (esat ((function '\x00'..'\x1f' | '\\' | '\"' -> false | _ -> true),
460 "plain utf-8 text, not linebreak, tab, control character, \\ or \"")) s
461 let string s = seqs [lit '"'; loop (alt text esc); lit '"'] s
462
463 (* lexing complete, now structural parsing *)
464 let rec value s = token (alts
465 "value: null, true, false, number, string, array or object"
466 [emit (str "null") wnull; emit (str "false") wfalse; emit (str "true") wtrue;
467 emit num wnum; emit string wstring; obj; array]) s
468 and obj s = par (emit (delim '{') wobject)
469 (opt (list_sep (emit named_value reduce_member) (delim ',')))
470 (emit (delim '}') reduce_object) s
471 and array s = par (emit (delim '[') warray)
472 (opt (list_sep (emit value reduce_element) (delim ',')))
473 (emit (delim ']') reduce_array) s
474 and named_value s = seqs [emit name wstring; delim ':'; value] s
475 and name s = token string s
476
477 let stream_value s = seqs [value; space; none "end of input"] s
478
479 end (* end of module Json_parser *)
480
481 module Json_writer = struct
482 open Json_type
483
484 (* Assumes that string contains valid utf-8 encoding and that any control characters
485 are stored as control characters
486 - i.e. 'x0A' would become newline and \n would become \\n
487 This assumption holds if the string has been parsed from a valid JSON document in utf-8 encoding.
488 We don't escape '/' since JSON only supports it to be escaped, but does not require it.
489 *)
490 let escape_string b s =
491 let n = String.length s in
492 for i = 0 to (n - 1) do
493 let c = String.unsafe_get s i in
494 let c' =
495 match c with
496 | '\x22' -> '"' | '\x5C' -> '\\' | (* '\x2F' -> '/' | *) '\x08' -> 'b'
497 | '\x0C' -> 'f' | '\x0A' -> 'n' | '\x0D' -> 'r' | '\x09' -> 't'
498 | _ -> '_' in
499 if c' <> '_'
500 then begin Buffer.add_char b '\\'; Buffer.add_char b c' end
501 else if c < '\x10'
502 then begin Buffer.add_string b "\\u000"; Buffer.add_char b (Char.unsafe_chr ((Char.code c) + (Char.code '0'))) end
503 else if c < '\x20'
504 then begin Buffer.add_string b "\\u001"; Buffer.add_char b (Char.unsafe_chr ((Char.code c) + (Char.code '0') - 0x10)) end
505 else Buffer.add_char b c
506 done
507
508 (* JSON requires digit after '.', OCaml doesn't. *)
509 let sprint_float x =
510 let s = Printf.sprintf "%F" x in
511 if (s.[(String.length s) - 1]) = '.' then s ^ "0" else s
512
513 let bprint_float b x =
514 Printf.bprintf b "%F" x;
515 if (Buffer.nth b ((Buffer.length b) - 1)) = '.' then Buffer.add_char b '0'
516
517 (* Yaml compatibility: Yaml requires space after ',' and ':' in array and object separators
518 http://ajaxian.com/archives/json-yaml-its-getting-closer-to-truth *)
519
520 (* Serialize to YAML compatible syntax by adding to given buffer,
521 starting at given indent level and with factor spaces per level. *)
522 let buffered_string_of_json b level factor x =
523 let pad level = for i = 1 to factor * level do Buffer.add_char b ' ' done in
524 let indent first level =
525 if not first then Buffer.add_char b ',';
526 if factor < 1 then Buffer.add_char b ' ' else
527 (Buffer.add_char b '\n'; pad level)
528 in
529 let rec again level = function
530 | String x -> Buffer.add_char b '\"'; escape_string b x; Buffer.add_char b '\"';
531 | Float x -> bprint_float b x
532 | Int x -> Printf.bprintf b "%i" x
533 | Bool true -> Buffer.add_string b "true"
534 | Bool false -> Buffer.add_string b "false"
535 | Null -> Buffer.add_string b "null"
536 | Array lst -> Buffer.add_char b '[';
537 let k = List.fold_left (fun first v -> indent first (level + 1); again (level + 1) v; false) true lst in
538 if not k then indent true level else Buffer.add_char b ' '; Buffer.add_char b ']'
539 | Object lst -> Buffer.add_char b '{';
540 let k = List.fold_left (fun first (n, v) ->
541 indent first (level + 1);
542 Buffer.add_char b '\"'; escape_string b n;
543 Buffer.add_string b "\": "; (* space ensures YAML compatibility *)
544 again (level + 1) v; false) true lst in
545 if not k then indent true level else Buffer.add_char b ' '; Buffer.add_char b '}'
546 in pad level; again level x
547
548 let string_of_json x =
549 let b = Buffer.create 500 in
550 buffered_string_of_json b 0 2 x;
551 Buffer.contents b
552
553 let rec print = function
554 | String x -> x
555 | Float x -> sprint_float x
556 | Int x -> string_of_int x
557 | Bool true -> "true"
558 | Bool false -> "false"
559 | Null -> "null"
560 | Array x -> List.fold_left (fun a b -> a ^ (print b) ^ "\n") "" x
561 | Object x -> List.fold_left (fun a (n, v) -> a ^ n ^ "=" ^ (print v) ^ "\n") "" x
562
563 end (* end of module JSON_writer *)
564
565 open Json_type
566 open Combinator.Result
567
568 (** creates a default string stream from string and initializes
569 output stream *)
570 let create_string_stream str = Combinator.Stream.string_stream str (Json_parser.create_output_stream ())
571
572 (** result: stream -> json.t
573 Returns json value from parsed stream *)
574 let result s = List.hd (Json_parser.stack (Combinator.Stream.output s))
575
576 let report b errors =
577 let pos s = Combinator.Stream.input s in
578 let off s = (let off, ln, col = pos s in off) in
579 let cmp_off (s1, a1) (s2, a2) = compare (off s2) (off s1) in
580 (* filter error alternatives that are irrelevant, such as whitespace *)
581 let lst = List.filter (fun (es, ann) -> try (String.sub ann 0 2) <> "@@" with _ -> true) errors in
582 let lst = if lst = [] then errors else lst in
583 let lst = List.stable_sort cmp_off lst in
584 let (best_off, ln, col), ann = pos (List.hd lst) in
585 let lst = List.filter (fun (es, ann) -> best_off = (off es)) lst in
586 Printf.bprintf b " line %i, column %i : expected " ln col;
587 let s, ann = List.hd lst in
588 Buffer.add_string b (if List.length lst = 1 then ":" else "one of :");
589 let seen = Hashtbl.create 7 in (* strip duplicates in parser tracer *)
590 List.iter (fun (es, ann) -> if not (Hashtbl.mem seen ann) then
591 begin Hashtbl.add seen ann ann; Buffer.add_string b "\n ";
592 let ann = match ann with "\\\\" -> "\\" | " " -> "<space>" | "\\n" -> "<newline>" | _ -> ann in
593 Buffer.add_string b ann end) lst;
594 Buffer.add_string b "\n but found :\n ";
595 let found = try let c = (Combinator.Stream.peek_string_stream s) in
596 (match c with '\n' -> "<newline>" | ' ' -> "<space>" | '\\' -> "\\" | _ -> Char.escaped c)
597 with Not_found -> "<end of input>" in
598 Buffer.add_string b found;
599 Buffer.add_char b '\n'
600
601 (** succeedful parser state or report error location and expected result(s) *)
602 let validate (state, status) =
603 match status with
604 | Optional errors | Failure errors ->
605 let b = Buffer.create 200 in
606 Buffer.add_string b "JSON Fleece Parser syntax error\n";
607 report b errors;
608 raise (Json_error (Buffer.contents b))
609 | _ -> state
610
611 (* for debug purposes - dumps every attempted parse from line 1 *)
612 let validate_trace = function
613 _, Failure lst | _, Optional lst ->
614 let b = Buffer.create 200 in
615 Buffer.add_string b "JSON Fleece Parser syntax error; locations parser have unsuccessfully tried :\n";
616 List.iter (fun (estate, ann) ->
617 let offset, line, column = Combinator.Stream.input estate in
618 Printf.bprintf b " line %2i, column %2i : %s\n" line column ann) lst;
619 raise (Json_error (Buffer.contents b))
620 | state, Success -> state
621
622 (** low level json parser for embedding in other parsers:
623 parse a json value from stream and return parsed stream
624 containing a single json value - caller is responsible
625 for parsing any termination as this parser will stop
626 at garbage if the input up to then is valid
627 for example, "01" will parse 0 and then return.
628 result (parse_value s) will return this value of type json.t
629 The stream must use an output stream created with init_output() and
630 the input stream must use predicates and writers of 'char' type. *)
631 let parse_value s = validate (Json_parser.value s)
632
633 (** like parse_json_value but ensures a complete parse
634 this parser won't accept "01", but parse_json_value will *)
635 let parse_stream s = validate (Json_parser.stream_value s)
636
637 (** parse_string: string -> Json.t
638 high level parser that creates its own stream from a string
639 and return a json value *)
640 let parse_string str = result (parse_stream (create_string_stream str))
641
642 let write_string = Json_writer.string_of_json
643
644 let json_of_string s = parse_string s
645
646 let string_of_json = Json_writer.string_of_json
647 let print = Json_writer.print
648
649end (* end of module Fleece *)
650
651module Json = struct
652
653 include Fleece.Json_type
654
655 let json_of_string = Fleece.json_of_string
656 let string_of_json = Fleece.string_of_json
657 let print = Fleece.print
658
659 let parse_string str = Fleece.parse_string str
660
661 let parse_file filename = parse_string (Ocamlbuild_plugin.Pathname.read filename)
662
663 let fail s = raise (Invalid_argument s)
664
665 let get_object v = match v with Object x -> x
666 | _ -> fail "json object expected"
667 let get_array v = match v with Array x -> x
668 | _ -> fail "json array expected"
669 let get_string v = match v with String x -> x
670 | _ -> fail "json string expected"
671 let get_integer v = match v with Int x -> x
672 | _ -> fail "json integer expected"
673 let get_number v = match v with Int x -> float_of_int x
674 | Float x -> x
675 | _ -> fail "json integer or number expected"
676 let get_boolean v = match v with Bool x -> x
677 | _ -> fail "json boolean expected"
678 let get_null v = match v with Null -> ()
679 | _ -> fail "json boolean expected"
680
681 let member value name = List.assoc name (get_object value)
682 let path base_value names = List.fold_left (fun value name -> member value name) base_value names
683
684 exception Found of t
685 let pattern_path value names =
686 let rec again value = function
687 | "*" :: names -> List.iter (fun (n, v) -> try again v names
688 with Invalid_argument _ | Not_found -> ()) (get_object value)
689 | name :: names -> again (List.assoc name (get_object value)) names
690 | [] -> raise (Found value)
691 in try again value names; raise Not_found with Found value -> value
692
693 let is_null v = match v with Null -> true | _ -> false
694end
695
696(* variable substitution in text values *)
697module Environment = struct
698
699 open Fleece.Combinator
700
701 let lit c = lit (c, Char.escaped c)
702 let emit_lit c = emit_lit (c, Char.escaped c)
703 let str s = str (s, s)
704
705 type expr = Text of string | Begin | End
706
707 let wchar c (buf, values) = (Buffer.add_char buf c; buf, values)
708 let wmark (b, v) = let s = Buffer.contents b in Buffer.clear b; (b, Text s :: v)
709 let wbegin (b, v) = (b, Begin :: v)
710 let wend (b, v) = (b, End :: v)
711
712 (* dollar style variable substitution: $(name) or $name
713 non-std.$'x' escape instead of \x - more friendly inside strings *)
714 module Dollar = struct
715 let rec expr s = loop (alts "escaped $'x', $(expr), $name, text, or '(' expr ')'"
716 [varesc; text; group]) s
717 and varesc s = seq (lit '$') (alt esc var) s
718 and var s = seqs [write wmark; write wbegin; alt varexpr varname; write wmark; write wend] s
719 and varexpr s = seqs [lit '('; expr; lit ')'] s
720 and varname s = loop (emit_sat (
721 (function '0'..'9'|'A'..'Z'|'a'..'z'|'_' -> true | _ -> false), "name (A-Za-z0-9_)") wchar) s
722 (* escape: $'(', $')', $'$', $''', ... backslash is too crowded *)
723 and esc s = seqs [lit '\''; emit_any "quoted character" wchar; lit '\''] s
724 and text s = repeat (emit_sat (
725 (function '$'|'('|')' -> false | _ -> true), "text without $ ( and )") wchar) s
726 (* just to avoid requiring balanced parentheses to be escaped *)
727 and group s = par (emit_lit '(' wchar) expr (emit_lit ')' wchar) s
728 let start s = seqs [expr; write wmark; none "end of input"] s
729 end (* end of Dollar module *)
730
731 (* bracket style variable substitution: <name>, escape using xml style &lt; &gt;
732 we could also use &varname; for substitution,
733 but we don't (then there are issue with xml conformant syntax ...) *)
734 module Brackets = struct
735 let esc xs c s = emit (str xs) (wchar c) s
736 let entity s = seq (lit '&') (alts "escape &lt; &gt; &amp; &apos; or &quot;"
737 [esc "amp;" '&'; esc "lt;" '<'; esc "gt;" '>'; esc "quot;" '\"'; esc "apos;" '\'']) s
738 let text s = repeat (emit_sat ((function '<' | '>' | '&' -> false | _ -> true),
739 "text, except &, < or >") wchar) s
740 let rec expr s = loop (alts "text or <name> or &lt; &gt; &amp; &quot; &apos;"
741 [entity; text; par (lit '<') var (lit '>')]) s
742 and var s = seqs [write wmark; write wbegin; expr; write wmark; write wend] s
743 let start s = seqs [expr; write wmark; none "end of input"] s
744 end (* end of Brackets module *)
745
746 let gparse_string grammar str =
747 let state, status = grammar (Stream.string_stream str (Buffer.create 100, [])) in
748 if valid status then snd (Stream.output state)
749 else failwith "Expression error in variable substition"
750
751 let parse_bracket_string str = gparse_string Brackets.start str
752 let parse_dollar_string str = gparse_string Dollar.start str
753
754 let eval_result lookup v =
755 let rec again a = function
756 | Text s :: t -> again (s ^ a) t
757 | End :: t -> let s, t = (again "" t) in again (s ^ a) t
758 | Begin :: t -> (lookup a), t
759 | [] -> a, []
760 in fst (again "" v)
761
762 let eval lookup str = eval_result lookup (parse_bracket_string str)
763
764end
765
766
767(** Navigational abstraction over object hierarchies
768 here using JSON, but we could navigate over other structures as well *)
769
770module Objects = struct
771
772include Util.Value
773
774let print = Printf.sprintf
775
776type location = string list
777type t = location * Json.t
778
779let objval lst = Json.Object lst
780let strval s = Json.String s
781let nullval = Json.Null
782
783let serialize = Json.string_of_json
784let access (loc, value) = value
785let locate (loc, value) = loc
786
787let string_of_loc loc = String.concat ":" (List.rev loc)
788let string_of_path path = String.concat ":" path
789
790let attempt f v = try f (access v) with
791 Invalid_argument s -> failwith (print "Unexpected value type at \n '%s'\n %s" (string_of_loc (locate v)) s)
792let p v = Json.print (access v)
793let o v = attempt Json.get_object v
794let a v = attempt Json.get_array v
795let b v = attempt Json.get_boolean v
796
797
798let find (loc, value) name =
799 try name::loc, Json.member value name with
800 | Not_found -> failwith (print "The object member '%s' was not found in\n '%s'" name (string_of_loc loc))
801 | Invalid_argument s -> failwith (print "%s while looking for object member '%s' in\n '%s'" s name (string_of_loc loc))
802
803(* default value carries it's own location *)
804let find_opt (loc, value) name default =
805 try name::loc, Json.member value name with
806 | Not_found -> default
807 | Invalid_argument s -> failwith
808 (print "%s while looking for object member '%s' in\n '%s'" s name (string_of_loc loc))
809
810let arr_iter f (loc, value as v) =
811 let rec again i = function
812 | value :: more -> f (((print "[%i]" i) :: loc), value); again (i + 1) more
813 | [] -> ()
814 in again 0 (attempt Json.get_array v)
815
816let arr_fold_left f a (loc, value as v) =
817 let rec again i a = function
818 | value :: more -> again (i + 1) (f a (((print "[%i]" i) :: loc), value)) more
819 | [] -> a
820 in again 0 a (attempt Json.get_array v)
821
822let arr_map f (loc, value as v) = List.rev (arr_fold_left (fun a v' -> (f v') :: a) [] v)
823
824let obj_iter f (loc, value as v) =
825 List.iter (fun (n, value') -> f n ((n::loc), value')) (attempt Json.get_object v)
826
827let obj_fold_left f a (loc, value as v) =
828 List.fold_left (fun a (n, value') -> f a n ((n::loc), value')) a (attempt Json.get_object v)
829
830let obj_map f (loc, value as v) = List.rev (obj_fold_left (fun a n v' -> (f n v') :: a) [] v)
831
832(* recurse through arrays and objects then applies f to shallow values
833 returns a copy with similar structure and identical object names, but different values,
834 f must match String, Float, Bool and Bool and return a constructed value like String "hello" *)
835let rec map f = function
836 | _, Object _ as v -> Object (obj_map (fun n v' -> (n, map f v')) v)
837 | _, Array _ as v -> Array (arr_map (fun v' -> map f v') v)
838 | v -> f v
839
840let find_opt_str (loc, value) name default = find_opt (loc, value) name (name::loc, Json.String default)
841let find_opt_obj (loc, value) name default = find_opt (loc, value) name (name::loc, Json.Object default)
842let find_opt_arr (loc, value) name default = find_opt (loc, value) name (name::loc, Json.Array default)
843let find_opt_bool (loc, value) name default = find_opt (loc, value) name (name::loc, Json.Bool default)
844
845let find_path (loc, value) path =
846 try ((List.rev path)@loc), Json.pattern_path value path with
847 Not_found -> failwith (print "The object path '%s' was not found in '%s'" (string_of_path path) (string_of_loc loc))
848 | Invalid_argument s ->
849 failwith (print "%s\n while looking for object path '%s' in\n '%s'" s (string_of_path path) (string_of_loc loc))
850
851let load file = try ["file://" ^ file], Json.parse_file file with
852 | Sys_error s -> failwith (print "The file '%s' could not be opened :\n %s" file s)
853 | Failure s | Json.Json_error s ->
854 let s = match s with "float_of_string" -> "floating point conversion error somewhere inside file"
855 | "int_of_string" -> "integer conversion error somewhere inside the file"
856 | _ -> s in
857 failwith (print "While parsing file '%s' :\n %s" file s)
858
859(* when we want to retry another path *)
860let load_nf file = if not (Sys.file_exists file) then raise Not_found else load file
861
862let chomp = Util.chomp
863let prechomp = Util.prechomp
864let split_name = Util.split ':'
865let split_first = Util.split_first ':'
866let remove_global_scope = Util.prechomp ":"
867
868let default_scope name = failwith (print "The variable '%s' was not defined" name)
869
870let env_scope scope name =
871 let env_var = prechomp "env:" name in
872 if env_var = name then scope name else
873 try (["env"; name], strval (Sys.getenv env_var)) with _ -> failwith (print "The environment variable '%s' was not defined" name)
874
875let list_scope scope env_lst name = try ["list"; name], strval (List.assoc name env_lst) with Not_found -> scope name
876
877(* handle name prefixes: context:path, arguments:path and object global names like ":agent" or ":context.path" *)
878let lookup_path scope obj name =
879 let name' = remove_global_scope name in
880 if name' = name then scope name else
881 try (find_path obj (split_name name')) with _ -> scope name'
882
883(* gives priority to local path scope, then attempts global scope *)
884let lookup_path_locally scope obj local_path name =
885 try (find_path obj (local_path @ (split_name name)))
886 with _ -> lookup_path scope obj name
887
888let print_scope scope name = p (scope name)
889
890(* expand expression where <x> is searched in arguments, context, and environment in that order *)
891let eval scope expr =
892 let rec fixpoint e n =
893 if n > 100 then failwith (print
894 "Expression '%s' was expanded more than a hundred times without any conclusive result,\n probably due to a circular reference. The result so far is: '%s'" expr e);
895 let e' = Environment.eval (print_scope scope) e in
896 if e' = e then e else fixpoint e' (n + 1)
897 in let e = fixpoint expr 0 in
898 (* handle special case expr = <x> and x=<x> : *)
899 Environment.eval (fun x -> failwith (print "Expression '%s' keeps expanding '%s' to itself in a circular reference" expr x)) e
900
901(* sometimes the lookup_path should have lower scope precedence
902 then use eval and rearrange scope change as appropriate *)
903let eval_obj obj expr =
904 eval (lookup_path default_scope obj) expr
905
906end (* end of Objects module *)
907
908module MyPath = struct
909
910 module Shell = Ocamlbuild_pack.Shell
911
912 module PathnameX = struct
913 (* partial reimplementation because we don't have access to the internals of Pathname *)
914 open Ocamlbuild_plugin.Pathname
915 open Operators
916
917 let dir_seps = ['/';'\\']
918
919 let split p =
920 let rec go p acc =
921 let dir = dirname p in
922 if dir = p then dir, acc
923 else go dir (basename p :: acc)
924 in go p []
925
926 let join root paths =
927 let root = if root = current_dir_name then "" else root in
928 List.fold_left (/) root paths
929
930 let is_prefix x y =
931 let string_before s pos = String.sub s 0 pos in
932 let lx = String.length x and ly = String.length y in
933 if lx = ly then x = (string_before y lx)
934 else if lx < ly then x = (string_before y lx) && List.mem y.[lx] dir_seps
935 else false
936
937 end (* end of PathnameX module *)
938
939 open PathnameX (* access to non-public Pathname functions *)
940 include Ocamlbuild_plugin.Pathname
941
942 let dir_seps = PathnameX.dir_seps
943
944 open Operators
945
946 let is_prefix x y = is_prefix x y
947 let is_absolute x = String.length x > 0 && List.mem x.[0] dir_seps
948 let is_relative x = not (is_absolute x)
949 let is_current x = x = current_dir_name
950
951 let parentdir = dirname
952 let absolute x y = if is_absolute x then x else concat y x
953
954 (* relative path from y to x - use relative_in when resulting path needs to go outside y *)
955 let relative x y =
956 let rx, lx = split x
957 and ry, ly = split y in
958 let rec again = function
959 | hx::tx, hy::ty when hx = hy -> again (tx, ty)
960 | lx, [] -> lx, []
961 | lx, hy :: ty -> again ((".." :: lx), ty)
962 in let paths = fst (again (lx, ly)) in
963 join current_dir_name paths
964
965 (* relative path from y to x where both x and y are relative to base
966 this handles the case where y is not a parent of x *)
967 let relative_in x y base =
968 relative (normalize (base / x)) (normalize (base / y))
969
970 (* Returns list of lists of paths where the inner list is valid prefix paths appended to one suffix path
971 this is useful for adding include directories to targets for the ocamlbuild build function.
972 the map function is applied to each suffix to handle OS specific issues like .a -> .lib
973 Any resulting path that cannot be normalized is silently removed *)
974 let translate prefixes suffixes map =
975 (* Append suffix to all given prefixes and remove any results that are not valid. *)
976 let append_prefixes prefixes suffix =
977 List.fold_right
978 (fun prefix acc -> try normalize (prefix / suffix) :: acc with _ -> acc)
979 prefixes [] in
980 List.map (fun suffix -> append_prefixes prefixes (map suffix)) suffixes;;
981
982end (* end of MyPath module *)
983
984
985(* Note on JSON values and Objects interface
986
987 Symbiosis is heavily based on parsing JSON values, but we want a generic interface
988 based on the Objects interface so we can also potentially access values stored in
989 other navigational structures. Apart from that, Objects mainly serve to provide
990 search facilities and location tracking for error reporting.
991
992 Thus: don't specifically reference Json types or parsers in the Symbiosis module,
993 use Objects or update Objects as necessary. *)
994
995module Symbiosis = struct
996
997(* this will give us access to cache invalidating shell operations *)
998module Shell = Ocamlbuild_pack.Shell
999module My_std = Ocamlbuild_pack.My_std
1000
1001module Core = struct
1002
1003open Objects
1004open Ocamlbuild_plugin
1005
1006exception Found of Objects.t
1007
1008let print = Printf.sprintf
1009
1010let currentdir () = Sys.getcwd()
1011let basedir () = (* Path.add (currentdir()) *) !Options.build_dir
1012
1013let system = ref (["<uninitialized-system>"], nullval)
1014let system_file = ref "<internal-defaults>"
1015
1016(* register root path before ocamlbuild changes directory into _build *)
1017let site = ref (currentdir ())
1018
1019let system_configuration_file = ref "symbiosis.system"
1020let system_configuration_dir = ref (try (Sys.getenv "HOME") / ".symbiosis" with _ -> "_symbiosis")
1021
1022let conf_force_tools = ref false
1023
1024let conf_activities = ref "activities"
1025let conf_artefacts = ref "<activities>/artefacts"
1026let conf_family = ref "common"
1027let conf_metaspaces = ref "<activities>/meta" (* can't have underscore due to ocamlbuild visibility *)
1028let conf_oversight = ref "<activities>/_oversight"
1029let conf_proxies = ref "proxies"
1030let conf_repositories = ref "repositories"
1031let conf_site = ref "<repositories>"
1032let conf_tools = ref "<activities>/tools"
1033let conf_volumes = ref "volumes"
1034let conf_workspaces = ref "<activities>/_work" (* hide unnecessary stuff from ocamlbuild - saves bandwidth *)
1035
1036let sys_defaults scope name =
1037 list_scope scope [
1038 "activities", !conf_activities;
1039 "artefacts", !conf_artefacts;
1040 "family", !conf_family;
1041 "metaspaces", !conf_metaspaces;
1042 "oversight", !conf_oversight;
1043 "proxies", !conf_proxies;
1044 "repositories", !conf_repositories;
1045 "site", !conf_site;
1046 "tools", !conf_tools;
1047 "volumes", !conf_volumes;
1048 "workspaces", !conf_workspaces;
1049] name
1050
1051let absolute path = MyPath.absolute path !site
1052let relative path = MyPath.relative path !site
1053let parentdir path = MyPath.parentdir path
1054let normalize path = try MyPath.normalize path with _ ->
1055 failwith (print "The path '%s' reaches outside itself but it was not supposed to do that" path)
1056
1057(* Appends suffix as a subdir to path and requires the resulting path
1058 to be a subdir of path. Allows subdir to be non-normalized (outside and back inside).
1059 Returns normalized path relative to site or raises an error. *)
1060let subdir path suffix =
1061 try
1062 let path = absolute path in
1063 let dir = normalize ((absolute path) / suffix) in
1064 if not (MyPath.is_prefix path dir) then failwith "invalid path";
1065 relative dir
1066 with _ -> failwith (print "'%s' is not a valid subdirectory of '%s'" suffix path)
1067
1068let relfrom path base = MyPath.relative_in path base !site
1069
1070let tool x = try ( p (find_path !system ["tools"; x])) with
1071 Failure s -> begin try
1072 let tool_path = absolute (subdir !conf_tools x) in
1073 if Sys.file_exists tool_path then tool_path else failwith "Not found"
1074 with
1075 Failure s ->
1076 if not !conf_force_tools then x else
1077 failwith (print "The tool '%s' was not found in tools path :\n '%s'\n nor listed in the configuration file :\n %s\n %s"
1078 x !conf_tools s "(yes mildly annoying, but it helps tracking required build tools and to use the proper version\n ... you can override this with symbiosis.system:force_tools:false)")
1079 end
1080
1081let installed_agents = Hashtbl.create 7
1082
1083let register_agent (name, actions) = Hashtbl.add installed_agents name actions
1084let register_agents agents = List.iter register_agent agents
1085
1086let resolve_agent_action name action =
1087 let agent = try Hashtbl.find installed_agents name with
1088 Not_found -> failwith (print "Agent '%s' is not listed" name) in
1089 try List.assoc action agent with Not_found ->
1090 begin try List.assoc "_missing_" agent with Not_found ->
1091 failwith (print "Agent '%s' does not know how to '%s'" name action)
1092 end
1093
1094let eval_system_conf path expr =
1095 let scope name = lookup_path_locally (sys_defaults (env_scope default_scope)) !system path name in
1096 eval scope expr
1097
1098let relcwd path = relfrom (absolute path) (currentdir())
1099
1100(* resulting paths are site relative *)
1101let workspace path =
1102 subdir !conf_workspaces
1103 (try Pathname.normalize path with _ ->
1104 failwith (print "The workspace path '%s' attempts to escape the workspace root" path))
1105
1106let repository path = subdir !conf_repositories path
1107let proxy path = subdir !conf_proxies path
1108let target path = subdir (basedir()) path
1109
1110let lookup_context scope msg name =
1111 try (find_path msg ("context" :: split_name name)) with _ -> scope name
1112
1113let lookup_exports scope msg name =
1114 try (find_path msg ("context" :: "dependencies" :: split_name name)) with _ -> scope name
1115
1116let lookup_argument scope msg name =
1117 try (find_path msg ("arguments" :: split_name name)) with _ -> scope name
1118
1119let msg_arg scope msg name =
1120 let scope = lookup_path scope msg in
1121 lookup_argument (lookup_context (lookup_exports scope msg) msg) msg name
1122
1123let msg_scope env_lst msg =
1124 (* scope order:
1125 argument -> context -> context:dependencies
1126 -> msg global -> env_list defaults -> default_scope (an error message) *)
1127 let scope = (list_scope default_scope env_lst) in
1128 msg_arg scope msg
1129
1130let msg_eval env_lst msg expr =
1131 eval (msg_scope env_lst msg) expr
1132
1133let send_message to_req agent action arguments context =
1134 let message_body = objval [
1135 "agent", agent;
1136 "action", action;
1137 "arguments", arguments;
1138 "context", context] in
1139 Echo ([serialize message_body], to_req)
1140
1141(* todo: some actions need a stamp, and will generate side effects but no output.
1142 'touch' isn't good enough since we need to destill impact of dependencies
1143 such as the signature in the rule ~stamp argument
1144
1145 Solution is probably to always create a stamp in addition to the .resp file an
1146 action is required to create. In the simplest form an agent action can copy req to resp:
1147 fun arg req resp -> cp req resp
1148 Then have dependencies on both stamp and resp.
1149 *)
1150let activate_agent req resp =
1151 let msg = load req in
1152 let agent_name = find msg "agent" in
1153 let action_name = find msg "action" in
1154 try
1155 let action = resolve_agent_action (p agent_name) (p action_name) in
1156 action msg (msg_eval [] msg) req resp
1157 with Failure s -> failwith (print
1158 "Something went wrong while agent '%s'\n was trying to perform the action '%s' for the request :\n %s :\n %s"
1159 (p agent_name) (p action_name) req s)
1160
1161
1162let meta_volume_message volume action to_req =
1163 try
1164 let c = find_path !system ["meta-volumes"; volume] in
1165 let agent = access (find c "agent") and arguments = access (find c "arguments")
1166 and action = strval action
1167 and context = objval [
1168 "artefacts", strval !conf_artefacts;
1169 "branch", strval "";
1170 "family", strval !conf_family;
1171 "module", strval "";
1172 "name", strval volume;
1173 "proxies", strval !conf_proxies;
1174 "tools", strval !conf_tools;
1175 "repositories", strval !conf_repositories;
1176 "site", strval !conf_site;
1177 "volume", strval volume;
1178 "volumes", strval !conf_volumes;
1179 "workspace", strval volume;
1180 "workspaces", strval !conf_metaspaces; (* route meta-volumes to separate directory *)
1181 ] in
1182 send_message to_req agent action arguments context
1183 with Failure s -> failwith (print
1184 "Something went wrong while creating a request to the meta volume '%s' :\n %s" volume s)
1185
1186let resolve file errmsg env build =
1187 match build ([[file]]) with
1188 | [Outcome.Good x] -> x
1189 | [Outcome.Bad _] -> failwith ("While building :\n " ^ errmsg)
1190 | _ -> failwith (print "Unexpected result while trying to build '%s'" file)
1191
1192let resolve_proxy file env build =
1193 load (resolve file (print "The '%s' proxy was not found" file) env build)
1194
1195let resolve_volume volume proxy labels env build =
1196 ignore proxy;
1197 ignore labels;
1198 let volume_name = volume in
1199 let file = !conf_volumes / (p volume_name ^ ".volume") in
1200 load (resolve file (print "The '%s' volume was not found, the search was conducted in :\n '%s'"
1201 (p volume) !conf_volumes) env build)
1202
1203let resolve_volume_action action volume proxy labels env build =
1204 let c = resolve_volume volume proxy labels env build in
1205 (find c "agent"), (find c "arguments")
1206
1207let resolve_synopsis ws synopsis env build =
1208 (* The synopsis file contains information about build agents and build actions,
1209 it can be located with the proxy, or in the workspace.
1210 If it is present with the proxy, this takes priority *)
1211 let synopsis_proxy_source = env (!conf_proxies / "%(name).synopsis") in
1212 let synopsis_repo_source = normalize (ws / synopsis) in
1213 try load_nf
1214 (try resolve synopsis_proxy_source
1215 "INERNAL ERROR: could not build synopsis file (we should retry alternative instead of failing)" env build with _ -> raise Not_found),
1216 synopsis_proxy_source
1217 with
1218 | Failure s -> failwith s
1219 | Not_found ->
1220 begin
1221 let errmsg = print "The '%s' synopsis could not located for workspace :\n '%s'\n It was expected in workspace :\n '%s'\n or next to the proxy: '%s'"
1222 synopsis ws synopsis_repo_source synopsis_proxy_source in
1223 try
1224 (* source code check out confuses resource cache *)
1225 Ocamlbuild_pack.Resource.Cache.import_in_build_dir synopsis_repo_source;
1226 load_nf (resolve synopsis_repo_source errmsg env build), synopsis_repo_source
1227 with Not_found -> failwith errmsg
1228 end
1229
1230let resolve_workspace proxy synopsis name env build =
1231
1232 let resp = proxy ^ ".volume.checkout.resp" in
1233 let req = proxy ^ ".volume.checkout.req" in
1234
1235 (* If the workspace is removed after checkout, this rule will think it is up to date. *)
1236 let errmsg = print "The workspace for the proxy '%s' could not be checked out" name in
1237 ignore (resolve resp errmsg env build);
1238
1239 (* Get the workspace path from req file - req is not available or up to date before resp has been built. *)
1240 let eval = msg_eval [] (load req) in
1241 let ws = workspace (eval "<workspace>") in
1242 let syn = try (eval "<synopsis>") with _ -> eval "<path>/<name>.synopsis" in
1243 let path = try (eval "<path>") with _ -> "." in
1244 if not (MyPath.exists (relcwd ws)) then
1245 begin
1246 (* Someone might have deleted the workspace - so we force re-checkout by removing the .resp file. *)
1247 begin try MyPath.Shell.rm resp with _ -> () end;
1248 failwith (print
1249 "The workspace '%s' has unexpectedly been removed.\n The corresponding log entry has therefore been removed ...\n --> please try again - sometimes that will sort things out" ws)
1250 (* We could try to build again, but ocamlbuild still thinks the target is up,
1251 and then we need to do some ocamlbuild resource magic. *)
1252 end;
1253 let syn, syn_path = resolve_synopsis ws syn env build in
1254 ws, syn, path, syn_path
1255
1256let find_action actions action =
1257 try
1258 arr_iter (function
1259 | loc, Objects.String s -> if s = action then raise (Found (loc, objval []))
1260 | a -> if (p (find a "action")) = action then raise (Found a))
1261 actions;
1262 failwith (print "'%s' was not found in the list of actions.\n Hint: an <action-name> is either a simple string or an action attribute :\n \"actions\": [ \"<action-name>\", ..., { \"action\": \"<action-name>\", ... }, ... ]" action)
1263 with Found a -> a
1264
1265let resolve_synopsis_action proxy synopsis name action env build =
1266 let ws, syn, path, syn_path = resolve_workspace proxy synopsis name env build in
1267 (* load action defaults *)
1268 let agent = find_opt_str syn "agent" "<build>" in
1269 let arguments = find_opt_obj syn "arguments" [] in
1270 let dependencies = find_opt_arr syn "dependencies" [] in
1271 let exports = find_opt_obj syn "exports" [] in
1272
1273 (* load action *)
1274 let action_obj = try find_action (find syn "actions") action
1275 with Failure s -> failwith (print "The synopsis '%s'\n for proxy '%s' is not responding to the action '%s' because\n %s" syn_path name action s)
1276 in
1277 let agent = find_opt action_obj "agent" agent in
1278 let arguments = find_opt action_obj "arguments" arguments in
1279 let dependencies = find_opt action_obj "dependencies" dependencies in
1280 let exports = find_opt action_obj "exports" exports in
1281 ws, syn, agent, arguments, dependencies, exports, path
1282
1283let proxy_volume_message proxy to_req env build =
1284 let proxy = env proxy
1285 and to_req = env to_req in
1286 let name = env "%(name)" in
1287 let action = env "%(action)" in
1288 try
1289 let proxy = resolve_proxy proxy env build in
1290 let volume = (find proxy "volume") in
1291 let labels = (find_opt_arr proxy "labels" []) in
1292 let agent, arguments = resolve_volume_action action volume name labels env build in
1293 let context = objval [
1294 "artefacts", strval !conf_artefacts;
1295 "branch", access (find_opt_str proxy "branch" "");
1296 "family", strval !conf_family;
1297 "module", access (find_opt_str proxy "module" "");
1298 "name", strval name;
1299 "path", access (find_opt_str proxy "path" ".");
1300 "repositories", strval !conf_repositories;
1301 "site", strval !conf_site;
1302 "synopsis", access (find_opt_str proxy "synopsis" "<path>/<name>.synopsis");
1303 "tools", strval !conf_tools;
1304 "volume", access (find_opt_str proxy "volume" "default");
1305 "workspace", strval name; (* default value to be overridden in volume arguments *)
1306 "workspaces", strval !conf_workspaces;
1307 ] in
1308 send_message to_req (access agent) (strval action) (access arguments) context
1309 with Failure s -> failwith (print
1310 "Something went wrong while creating a volume request from proxy '%s' for action '%s' :\n %s" name action s)
1311
1312(* Dependency names are relative to dependent name space, or absolute (from proxies dir);
1313 here we make the path absolute (from proxies dir). *)
1314let normalize_dependency_name name dependency =
1315 try prechomp "/" (normalize ((parentdir name) / dependency)) with _ ->
1316 failwith (print "The dependency '%s' is not valid relative to the namespace\n of the dependent proxy '%s'"
1317 dependency name)
1318
1319let dependency_message ext name action dependency =
1320 let dependency = normalize_dependency_name name dependency in
1321 print "%s.proxy.synopsis.%s.%s" dependency action ext
1322
1323let request_dependency ext name action dependency env build =
1324 let msg = dependency_message ext name action dependency in
1325 (* base_req can be build via cmd line due to include path, but here we are responsible for adding include paths *)
1326 let errmsg = print "The proxy '%s' depends on the action '%s' of the proxy '%s,\n but this dependency is not available.\n The attempted target was: '%s"
1327 name action dependency msg in
1328 resolve (!conf_proxies / msg) errmsg env build
1329
1330(* when a string is a shortcut for an object, create a simple object *)
1331let map_object field = function (loc, (Objects.String s as value)) -> loc, objval [field, value] | x -> x
1332
1333(* dependency as object or as string: "name" or ":action" or "name:action"
1334 map these forms into an object *)
1335let split_dependency s = try Util.split_first ':' s with Not_found -> s, ""
1336
1337let map_dependency = function
1338 | (loc, Objects.String s) ->
1339 begin match split_dependency s with
1340 | "", action -> loc, objval ["action", strval action]
1341 | name, "" -> loc, objval ["name", strval name]
1342 | name, action -> loc, objval ["name", strval name; "action", strval action]
1343 end
1344 | x -> x
1345
1346(* e.g. [ {"name": "myproxy", "action": "myaction"}, {"action:": "pre-build"}, "otherproxy" ] *)
1347let request_dependencies name action dependencies env build =
1348 let depend x = let dependency = map_dependency x in
1349 ignore (request_dependency "resp" name (p (find_opt_str dependency "action" action))
1350 (p (find_opt_str dependency "name" name)) env build) in
1351 arr_iter depend dependencies
1352
1353let eval_exports msg exports =
1354 ignore(o exports); (* error if we do not receive an object *)
1355 Objects.map (fun x -> strval (msg_eval [] msg (p x))) exports
1356
1357 (* load the dependency req file, it should list the exported values by that action
1358 - we don't normalize the dependency name in the result tuple
1359 because users would expect the name in the same format as given in the synopsis
1360 TODO: same synopsis may contribute multiple times for different actions, need to handle this *)
1361let resolve_exports name action dependencies env build =
1362 let get_export dependency =
1363 begin
1364 let dependency = map_dependency dependency in
1365 let dname = p (find_opt_str dependency "name" name) in
1366 let daction = p (find_opt_str dependency "action" action) in
1367 let msg = load (request_dependency "req" name daction dname env build) in
1368 eval_exports msg (find_path msg ["context"; "exports"])
1369 end in
1370 objval (arr_map (fun d -> (p d), get_export d) dependencies)
1371
1372let proxy_synopsis_message proxy synopsis to_req env build =
1373 let proxy = env proxy in
1374 let syn = env synopsis in
1375 let to_req = env to_req in
1376 let name = env "%(name)" in
1377 let action = env "%(action)" in
1378 let ws, syn, agent, arguments, dependencies, exports, path =
1379 resolve_synopsis_action proxy syn name action env build in
1380 request_dependencies name action dependencies env build;
1381 let dependency_exports = resolve_exports name action dependencies env build in
1382 let project = subdir ws path in
1383 let context = objval [
1384 "artefacts", strval !conf_artefacts;
1385 "base", strval (relfrom "." project);
1386 "dependencies", dependency_exports;
1387 "exports", access exports;
1388 "name", strval name;
1389 "path", strval path;
1390 "project", strval project;
1391 "tools", strval !conf_tools;
1392 "workspace", strval (relfrom ws !conf_workspaces);
1393 "workspaces", strval !conf_workspaces;
1394 ] in
1395 try
1396 send_message to_req (access agent) (strval action) (access arguments) context
1397 with Failure s -> failwith (print
1398 "Something went wrong while creating a synopsis request from proxy '%s' for action '%s' :\n %s" name action s)
1399
1400let load_system () =
1401 site := currentdir();
1402 system := begin try load_nf (!system_configuration_file) with
1403 Not_found -> try load_nf (!system_configuration_dir / !system_configuration_file) with
1404 Not_found -> ["internal"; !system_configuration_file], objval []
1405 end;
1406 let get expr = begin try eval_system_conf ["configuration"] expr with
1407 Failure s -> failwith (print
1408 "The configuration setting '%s' could not be evaluated in :\n 'file://%s:configuration'\n %s"
1409 expr !system_configuration_file s) end in
1410
1411 conf_activities := get "<activities>";
1412 conf_artefacts := get "<artefacts>";
1413 conf_family := get "<family>";
1414 conf_metaspaces := get "<metaspaces>";
1415 conf_repositories := get "<repositories>";
1416 conf_oversight := get "<oversight>";
1417 conf_proxies := get "<proxies>";
1418 conf_tools := get "<tools>";
1419 conf_volumes := get "<volumes>";
1420 conf_workspaces := get "<workspaces>";
1421
1422 conf_force_tools := b (find_opt_bool !system "force-tools" !conf_force_tools);
1423 (* force rescan of system config for meta-volumes in case new volumes were added *)
1424 MyPath.Shell.rm_f (!conf_oversight/"meta-volumes");
1425 MyPath.Shell.mkdir_p !conf_artefacts;
1426 MyPath.Shell.mkdir_p !conf_tools;
1427 let path_sep = match Sys.os_type with "Win32" | "Win64" -> ";" | _ -> ":" in
1428 let path = Unix.getenv "PATH" in
1429 let tools = absolute !conf_tools in
1430 Unix.putenv "PATH" (tools ^ path_sep ^ path)
1431
1432let no_further_action env build = Nop
1433
1434let meta_volumes_rule () =
1435 let c = find_opt_obj !system "meta-volumes" [] in
1436 let deps = List.map (fun (name, _) -> print "meta-volume.%s.checkout.resp" name) (o c) in
1437 rule "meta-volumes-resp" ~deps ~stamp:"meta-volumes" no_further_action;
1438 let req = "meta-volume.%(volume).checkout.req" in
1439 rule "meta-volumes-req" ~prod:req
1440 (fun env build -> meta_volume_message (env "%(volume)") "checkout" (env req))
1441
1442(* e.g. "targets" : { "myproject": "org/example/myproject.proxy.synopsis.build.resp" }
1443 simplifies command line to"symbiosis myproject"
1444 note: adding pattern based simplifications tend to cause the solver tree to explode *)
1445let user_targets prefix =
1446 obj_iter (fun n v -> let src, dst = (prefix / (p v)), n
1447 in copy_rule (print "user target from '%s' to '%s" src dst) src dst)
1448 (find_opt_obj !system "targets" [])
1449
1450let load_rules () =
1451
1452 let prefix = !conf_proxies in
1453
1454 (* The prefix is important, otherwise %(name) will consume the entire path
1455 and thus not correctly identify proxy names as a path relative to proxies.
1456 Thus, relying on include_dirs won't work correctly although the basic rules will. *)
1457 let base_pattern = prefix / "%(name:<**/*> and not <**/*.*>)" in
1458 let base = prefix / "%(name)" in
1459
1460 let proxy = ".proxy" in
1461 let volume_req = ".proxy.volume.%(action).req" in
1462 let syn_req = ".proxy.synopsis.%(action).req" in
1463 let co_resp = ".proxy.volume.checkout.resp" in
1464 let synopsis = ".proxy.synopsis" in
1465
1466 meta_volumes_rule ();
1467 user_targets prefix;
1468
1469 copy_rule "init command" "meta-volumes" "init";
1470
1471 rule "agent action" ~dep:"%.req" ~prod:"%.resp"
1472 (fun env build -> activate_agent (env "%.req") (env "%.resp"));
1473
1474 rule "proxy volume message" ~dep:(base ^ proxy) ~prod:(base_pattern ^ volume_req)
1475 (proxy_volume_message (base ^ proxy) (base ^ volume_req));
1476
1477 rule "proxy synopsis message" ~dep:(base ^ co_resp) ~prod:(base_pattern ^ syn_req)
1478 (proxy_synopsis_message (base ^ proxy) (base ^ synopsis) (base ^ syn_req))
1479
1480end (* end of Core module *)
1481
1482module Agent = struct
1483 include Ocamlbuild_plugin.Command
1484
1485 (* a subset of has_variable *)
1486 let has_argument msg name =
1487 try ignore (Core.lookup_argument (fun _ -> raise Not_found) msg name); true
1488 with Not_found -> false
1489
1490 let has_variable msg name =
1491 try ignore (Core.msg_scope [] msg name); true
1492 with Not_found -> false
1493
1494 let relcwd = Core.relcwd (* low-level *)
1495 let relfrom path base = Core.relfrom path base
1496 let subdir path suffix = Core.subdir path suffix
1497 let normalize path = Core.normalize path
1498 let baserel path = relcwd path
1499
1500 let tool = Core.tool
1501
1502 let mv = Ocamlbuild_plugin.mv
1503 let cp = Ocamlbuild_plugin.cp
1504 let rm_f = Ocamlbuild_plugin.rm_f
1505
1506 let pipe x = S[Sh "|"; S x]
1507 let redirect file = S[Sh ">"; Px file]
1508 let redirect_in dir file = S[Sh ">"; Px (relfrom file dir)]
1509 let also_redirect file = S[Sh ">>"; P file]
1510
1511 let in_dir dir = S[A "cd"; A (relcwd dir); Sh "&&"]
1512 let also_in_dir dir = S[Sh "&&"; Sh "cd"; P dir; Sh "&&"]
1513
1514 let cmd_in dir x = Cmd (S[A "cd"; A (relcwd dir); Sh "&&"; S x])
1515 let cmd = cmd_in "."
1516 let oversight_cmd x = Cmd (S x)
1517 let respond_cmd_in dir resp x = Cmd (S[in_dir dir; S x; redirect_in dir (Core.target resp)])
1518
1519 (* e.g
1520 [[ "mkdir", "-p", "<project>/mydir"],
1521 ["cp", "<mydep:myfile>", "<project>/mydir/"],
1522 ["make", "all"]] *)
1523 let eval_script msg home name =
1524 let script = Core.msg_scope [] msg name in (* like eval "<name>", except we don't evaluate to text *)
1525 let map_cmd = begin function
1526 | A "#" :: tl -> Nop
1527 | A "cp" :: A src :: A dst :: tl -> if tl <> [] then failwith "cp expects only two arguments";
1528 Ocamlbuild_plugin.cp (relcwd (relfrom src home)) (relcwd (relfrom dst home))
1529 | A "mv" :: A src :: A dst :: tl -> if tl <> [] then failwith "mv expects only two arguments";
1530 Ocamlbuild_plugin.mv (relcwd (relfrom src home)) (relcwd (relfrom dst home))
1531 (* TODO: ocamlbuild does not support mkdir, mkdir_p, so we don't have cross platform support,
1532 but we can still pass it to shell, and map mkdir_p using tool command - but windows can't trivially
1533 create multi-level missing subdirs AFAIK *)
1534 (*
1535 | A "mkdir_p" :: A src :: tl -> if tl <> [] then failwith "mkdir_p expects only one argument";
1536 Ocamlbuild_plugin.mkdir_p src
1537 | A "mkdir" :: A src :: tl -> if tl <> [] then failwith "mkdir expects only one argument";
1538 Ocamlbuild_plugin.mkdir src *)
1539 | A cmd :: tl -> cmd_in home (A (tool cmd) :: tl)
1540 | _ -> Nop
1541 end in
1542 Seq (Objects.arr_map (fun line -> map_cmd (Objects.arr_map
1543 (fun arg -> A (Core.msg_eval [] msg (Objects.p arg))) line)) script)
1544
1545 let eval_arguments msg name =
1546 let args = Core.msg_scope [] msg name in
1547 S (Objects.arr_map (fun arg -> A (Core.msg_eval [] msg (Objects.p arg))) args)
1548
1549 let register_agent = Core.register_agent
1550
1551 let fail_missing_action () = failwith "Dynamic resolution of action through _missing_ action did not succeed."
1552
1553end (* end of Agent module *)
1554
1555
1556open Ocamlbuild_plugin
1557let initialize agents =
1558 dispatch begin function
1559 | Before_options ->
1560 Core.load_system ();
1561 Options.build_dir := !Core.conf_oversight;
1562 (* std. access to proxies regardless of location *)
1563 Options.include_dirs := !Core.conf_proxies :: !Core.conf_volumes :: !Options.include_dirs;
1564
1565 | After_rules ->
1566 Core.load_rules();
1567 Core.register_agents agents
1568 | _ -> ()
1569 end
1570
1571end (* end of Symbiosis module *)
1572
1573

dVide Home | dVide Labs