|
|
@@ -1,7976 +0,0 @@
|
|
|
-(* setup.ml generated for the first time by OASIS v0.4.6 *)
|
|
|
-
|
|
|
-(* OASIS_START *)
|
|
|
-(* DO NOT EDIT (digest: 68879f85a75fd3d411f0ced162a213b7) *)
|
|
|
-(*
|
|
|
- Regenerated by OASIS v0.4.8
|
|
|
- Visit http://oasis.forge.ocamlcore.org for more information and
|
|
|
- documentation about functions used in this file.
|
|
|
-*)
|
|
|
-module OASISGettext = struct
|
|
|
-(* # 22 "src/oasis/OASISGettext.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- let ns_ str = str
|
|
|
- let s_ str = str
|
|
|
- let f_ (str: ('a, 'b, 'c, 'd) format4) = str
|
|
|
-
|
|
|
-
|
|
|
- let fn_ fmt1 fmt2 n =
|
|
|
- if n = 1 then
|
|
|
- fmt1^^""
|
|
|
- else
|
|
|
- fmt2^^""
|
|
|
-
|
|
|
-
|
|
|
- let init = []
|
|
|
-end
|
|
|
-
|
|
|
-module OASISString = struct
|
|
|
-(* # 22 "src/oasis/OASISString.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- (** Various string utilities.
|
|
|
-
|
|
|
- Mostly inspired by extlib and batteries ExtString and BatString libraries.
|
|
|
-
|
|
|
- @author Sylvain Le Gall
|
|
|
- *)
|
|
|
-
|
|
|
-
|
|
|
- let nsplitf str f =
|
|
|
- if str = "" then
|
|
|
- []
|
|
|
- else
|
|
|
- let buf = Buffer.create 13 in
|
|
|
- let lst = ref [] in
|
|
|
- let push () =
|
|
|
- lst := Buffer.contents buf :: !lst;
|
|
|
- Buffer.clear buf
|
|
|
- in
|
|
|
- let str_len = String.length str in
|
|
|
- for i = 0 to str_len - 1 do
|
|
|
- if f str.[i] then
|
|
|
- push ()
|
|
|
- else
|
|
|
- Buffer.add_char buf str.[i]
|
|
|
- done;
|
|
|
- push ();
|
|
|
- List.rev !lst
|
|
|
-
|
|
|
-
|
|
|
- (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
|
|
|
- separator.
|
|
|
- *)
|
|
|
- let nsplit str c =
|
|
|
- nsplitf str ((=) c)
|
|
|
-
|
|
|
-
|
|
|
- let find ~what ?(offset=0) str =
|
|
|
- let what_idx = ref 0 in
|
|
|
- let str_idx = ref offset in
|
|
|
- while !str_idx < String.length str &&
|
|
|
- !what_idx < String.length what do
|
|
|
- if str.[!str_idx] = what.[!what_idx] then
|
|
|
- incr what_idx
|
|
|
- else
|
|
|
- what_idx := 0;
|
|
|
- incr str_idx
|
|
|
- done;
|
|
|
- if !what_idx <> String.length what then
|
|
|
- raise Not_found
|
|
|
- else
|
|
|
- !str_idx - !what_idx
|
|
|
-
|
|
|
-
|
|
|
- let sub_start str len =
|
|
|
- let str_len = String.length str in
|
|
|
- if len >= str_len then
|
|
|
- ""
|
|
|
- else
|
|
|
- String.sub str len (str_len - len)
|
|
|
-
|
|
|
-
|
|
|
- let sub_end ?(offset=0) str len =
|
|
|
- let str_len = String.length str in
|
|
|
- if len >= str_len then
|
|
|
- ""
|
|
|
- else
|
|
|
- String.sub str 0 (str_len - len)
|
|
|
-
|
|
|
-
|
|
|
- let starts_with ~what ?(offset=0) str =
|
|
|
- let what_idx = ref 0 in
|
|
|
- let str_idx = ref offset in
|
|
|
- let ok = ref true in
|
|
|
- while !ok &&
|
|
|
- !str_idx < String.length str &&
|
|
|
- !what_idx < String.length what do
|
|
|
- if str.[!str_idx] = what.[!what_idx] then
|
|
|
- incr what_idx
|
|
|
- else
|
|
|
- ok := false;
|
|
|
- incr str_idx
|
|
|
- done;
|
|
|
- if !what_idx = String.length what then
|
|
|
- true
|
|
|
- else
|
|
|
- false
|
|
|
-
|
|
|
-
|
|
|
- let strip_starts_with ~what str =
|
|
|
- if starts_with ~what str then
|
|
|
- sub_start str (String.length what)
|
|
|
- else
|
|
|
- raise Not_found
|
|
|
-
|
|
|
-
|
|
|
- let ends_with ~what ?(offset=0) str =
|
|
|
- let what_idx = ref ((String.length what) - 1) in
|
|
|
- let str_idx = ref ((String.length str) - 1) in
|
|
|
- let ok = ref true in
|
|
|
- while !ok &&
|
|
|
- offset <= !str_idx &&
|
|
|
- 0 <= !what_idx do
|
|
|
- if str.[!str_idx] = what.[!what_idx] then
|
|
|
- decr what_idx
|
|
|
- else
|
|
|
- ok := false;
|
|
|
- decr str_idx
|
|
|
- done;
|
|
|
- if !what_idx = -1 then
|
|
|
- true
|
|
|
- else
|
|
|
- false
|
|
|
-
|
|
|
-
|
|
|
- let strip_ends_with ~what str =
|
|
|
- if ends_with ~what str then
|
|
|
- sub_end str (String.length what)
|
|
|
- else
|
|
|
- raise Not_found
|
|
|
-
|
|
|
-
|
|
|
- let replace_chars f s =
|
|
|
- let buf = Buffer.create (String.length s) in
|
|
|
- String.iter (fun c -> Buffer.add_char buf (f c)) s;
|
|
|
- Buffer.contents buf
|
|
|
-
|
|
|
- let lowercase_ascii =
|
|
|
- replace_chars
|
|
|
- (fun c ->
|
|
|
- if (c >= 'A' && c <= 'Z') then
|
|
|
- Char.chr (Char.code c + 32)
|
|
|
- else
|
|
|
- c)
|
|
|
-
|
|
|
- let uncapitalize_ascii s =
|
|
|
- if s <> "" then
|
|
|
- (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
|
|
|
- else
|
|
|
- s
|
|
|
-
|
|
|
- let uppercase_ascii =
|
|
|
- replace_chars
|
|
|
- (fun c ->
|
|
|
- if (c >= 'a' && c <= 'z') then
|
|
|
- Char.chr (Char.code c - 32)
|
|
|
- else
|
|
|
- c)
|
|
|
-
|
|
|
- let capitalize_ascii s =
|
|
|
- if s <> "" then
|
|
|
- (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
|
|
|
- else
|
|
|
- s
|
|
|
-
|
|
|
-end
|
|
|
-
|
|
|
-module OASISUtils = struct
|
|
|
-(* # 22 "src/oasis/OASISUtils.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- open OASISGettext
|
|
|
-
|
|
|
-
|
|
|
- module MapExt =
|
|
|
- struct
|
|
|
- module type S =
|
|
|
- sig
|
|
|
- include Map.S
|
|
|
- val add_list: 'a t -> (key * 'a) list -> 'a t
|
|
|
- val of_list: (key * 'a) list -> 'a t
|
|
|
- val to_list: 'a t -> (key * 'a) list
|
|
|
- end
|
|
|
-
|
|
|
- module Make (Ord: Map.OrderedType) =
|
|
|
- struct
|
|
|
- include Map.Make(Ord)
|
|
|
-
|
|
|
- let rec add_list t =
|
|
|
- function
|
|
|
- | (k, v) :: tl -> add_list (add k v t) tl
|
|
|
- | [] -> t
|
|
|
-
|
|
|
- let of_list lst = add_list empty lst
|
|
|
-
|
|
|
- let to_list t = fold (fun k v acc -> (k, v) :: acc) t []
|
|
|
- end
|
|
|
- end
|
|
|
-
|
|
|
-
|
|
|
- module MapString = MapExt.Make(String)
|
|
|
-
|
|
|
-
|
|
|
- module SetExt =
|
|
|
- struct
|
|
|
- module type S =
|
|
|
- sig
|
|
|
- include Set.S
|
|
|
- val add_list: t -> elt list -> t
|
|
|
- val of_list: elt list -> t
|
|
|
- val to_list: t -> elt list
|
|
|
- end
|
|
|
-
|
|
|
- module Make (Ord: Set.OrderedType) =
|
|
|
- struct
|
|
|
- include Set.Make(Ord)
|
|
|
-
|
|
|
- let rec add_list t =
|
|
|
- function
|
|
|
- | e :: tl -> add_list (add e t) tl
|
|
|
- | [] -> t
|
|
|
-
|
|
|
- let of_list lst = add_list empty lst
|
|
|
-
|
|
|
- let to_list = elements
|
|
|
- end
|
|
|
- end
|
|
|
-
|
|
|
-
|
|
|
- module SetString = SetExt.Make(String)
|
|
|
-
|
|
|
-
|
|
|
- let compare_csl s1 s2 =
|
|
|
- String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2)
|
|
|
-
|
|
|
-
|
|
|
- module HashStringCsl =
|
|
|
- Hashtbl.Make
|
|
|
- (struct
|
|
|
- type t = string
|
|
|
- let equal s1 s2 = (compare_csl s1 s2) = 0
|
|
|
- let hash s = Hashtbl.hash (OASISString.lowercase_ascii s)
|
|
|
- end)
|
|
|
-
|
|
|
- module SetStringCsl =
|
|
|
- SetExt.Make
|
|
|
- (struct
|
|
|
- type t = string
|
|
|
- let compare = compare_csl
|
|
|
- end)
|
|
|
-
|
|
|
-
|
|
|
- let varname_of_string ?(hyphen='_') s =
|
|
|
- if String.length s = 0 then
|
|
|
- begin
|
|
|
- invalid_arg "varname_of_string"
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- let buf =
|
|
|
- OASISString.replace_chars
|
|
|
- (fun c ->
|
|
|
- if ('a' <= c && c <= 'z')
|
|
|
- ||
|
|
|
- ('A' <= c && c <= 'Z')
|
|
|
- ||
|
|
|
- ('0' <= c && c <= '9') then
|
|
|
- c
|
|
|
- else
|
|
|
- hyphen)
|
|
|
- s;
|
|
|
- in
|
|
|
- let buf =
|
|
|
- (* Start with a _ if digit *)
|
|
|
- if '0' <= s.[0] && s.[0] <= '9' then
|
|
|
- "_"^buf
|
|
|
- else
|
|
|
- buf
|
|
|
- in
|
|
|
- OASISString.lowercase_ascii buf
|
|
|
- end
|
|
|
-
|
|
|
-
|
|
|
- let varname_concat ?(hyphen='_') p s =
|
|
|
- let what = String.make 1 hyphen in
|
|
|
- let p =
|
|
|
- try
|
|
|
- OASISString.strip_ends_with ~what p
|
|
|
- with Not_found ->
|
|
|
- p
|
|
|
- in
|
|
|
- let s =
|
|
|
- try
|
|
|
- OASISString.strip_starts_with ~what s
|
|
|
- with Not_found ->
|
|
|
- s
|
|
|
- in
|
|
|
- p^what^s
|
|
|
-
|
|
|
-
|
|
|
- let is_varname str =
|
|
|
- str = varname_of_string str
|
|
|
-
|
|
|
-
|
|
|
- let failwithf fmt = Printf.ksprintf failwith fmt
|
|
|
-
|
|
|
-
|
|
|
- let rec file_location ?pos1 ?pos2 ?lexbuf () =
|
|
|
- match pos1, pos2, lexbuf with
|
|
|
- | Some p, None, _ | None, Some p, _ ->
|
|
|
- file_location ~pos1:p ~pos2:p ?lexbuf ()
|
|
|
- | Some p1, Some p2, _ ->
|
|
|
- let open Lexing in
|
|
|
- let fn, lineno = p1.pos_fname, p1.pos_lnum in
|
|
|
- let c1 = p1.pos_cnum - p1.pos_bol in
|
|
|
- let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in
|
|
|
- Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2
|
|
|
- | _, _, Some lexbuf ->
|
|
|
- file_location
|
|
|
- ~pos1:(Lexing.lexeme_start_p lexbuf)
|
|
|
- ~pos2:(Lexing.lexeme_end_p lexbuf)
|
|
|
- ()
|
|
|
- | None, None, None ->
|
|
|
- s_ "<position undefined>"
|
|
|
-
|
|
|
-
|
|
|
- let failwithpf ?pos1 ?pos2 ?lexbuf fmt =
|
|
|
- let loc = file_location ?pos1 ?pos2 ?lexbuf () in
|
|
|
- Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt
|
|
|
-
|
|
|
-
|
|
|
-end
|
|
|
-
|
|
|
-module OASISUnixPath = struct
|
|
|
-(* # 22 "src/oasis/OASISUnixPath.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- type unix_filename = string
|
|
|
- type unix_dirname = string
|
|
|
-
|
|
|
-
|
|
|
- type host_filename = string
|
|
|
- type host_dirname = string
|
|
|
-
|
|
|
-
|
|
|
- let current_dir_name = "."
|
|
|
-
|
|
|
-
|
|
|
- let parent_dir_name = ".."
|
|
|
-
|
|
|
-
|
|
|
- let is_current_dir fn =
|
|
|
- fn = current_dir_name || fn = ""
|
|
|
-
|
|
|
-
|
|
|
- let concat f1 f2 =
|
|
|
- if is_current_dir f1 then
|
|
|
- f2
|
|
|
- else
|
|
|
- let f1' =
|
|
|
- try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1
|
|
|
- in
|
|
|
- f1'^"/"^f2
|
|
|
-
|
|
|
-
|
|
|
- let make =
|
|
|
- function
|
|
|
- | hd :: tl ->
|
|
|
- List.fold_left
|
|
|
- (fun f p -> concat f p)
|
|
|
- hd
|
|
|
- tl
|
|
|
- | [] ->
|
|
|
- invalid_arg "OASISUnixPath.make"
|
|
|
-
|
|
|
-
|
|
|
- let dirname f =
|
|
|
- try
|
|
|
- String.sub f 0 (String.rindex f '/')
|
|
|
- with Not_found ->
|
|
|
- current_dir_name
|
|
|
-
|
|
|
-
|
|
|
- let basename f =
|
|
|
- try
|
|
|
- let pos_start =
|
|
|
- (String.rindex f '/') + 1
|
|
|
- in
|
|
|
- String.sub f pos_start ((String.length f) - pos_start)
|
|
|
- with Not_found ->
|
|
|
- f
|
|
|
-
|
|
|
-
|
|
|
- let chop_extension f =
|
|
|
- try
|
|
|
- let last_dot =
|
|
|
- String.rindex f '.'
|
|
|
- in
|
|
|
- let sub =
|
|
|
- String.sub f 0 last_dot
|
|
|
- in
|
|
|
- try
|
|
|
- let last_slash =
|
|
|
- String.rindex f '/'
|
|
|
- in
|
|
|
- if last_slash < last_dot then
|
|
|
- sub
|
|
|
- else
|
|
|
- f
|
|
|
- with Not_found ->
|
|
|
- sub
|
|
|
-
|
|
|
- with Not_found ->
|
|
|
- f
|
|
|
-
|
|
|
-
|
|
|
- let capitalize_file f =
|
|
|
- let dir = dirname f in
|
|
|
- let base = basename f in
|
|
|
- concat dir (OASISString.capitalize_ascii base)
|
|
|
-
|
|
|
-
|
|
|
- let uncapitalize_file f =
|
|
|
- let dir = dirname f in
|
|
|
- let base = basename f in
|
|
|
- concat dir (OASISString.uncapitalize_ascii base)
|
|
|
-
|
|
|
-
|
|
|
-end
|
|
|
-
|
|
|
-module OASISHostPath = struct
|
|
|
-(* # 22 "src/oasis/OASISHostPath.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- open Filename
|
|
|
- open OASISGettext
|
|
|
-
|
|
|
-
|
|
|
- module Unix = OASISUnixPath
|
|
|
-
|
|
|
-
|
|
|
- let make =
|
|
|
- function
|
|
|
- | [] ->
|
|
|
- invalid_arg "OASISHostPath.make"
|
|
|
- | hd :: tl ->
|
|
|
- List.fold_left Filename.concat hd tl
|
|
|
-
|
|
|
-
|
|
|
- let of_unix ufn =
|
|
|
- match Sys.os_type with
|
|
|
- | "Unix" | "Cygwin" -> ufn
|
|
|
- | "Win32" ->
|
|
|
- make
|
|
|
- (List.map
|
|
|
- (fun p ->
|
|
|
- if p = Unix.current_dir_name then
|
|
|
- current_dir_name
|
|
|
- else if p = Unix.parent_dir_name then
|
|
|
- parent_dir_name
|
|
|
- else
|
|
|
- p)
|
|
|
- (OASISString.nsplit ufn '/'))
|
|
|
- | os_type ->
|
|
|
- OASISUtils.failwithf
|
|
|
- (f_ "Don't know the path format of os_type %S when translating unix \
|
|
|
- filename. %S")
|
|
|
- os_type ufn
|
|
|
-
|
|
|
-
|
|
|
-end
|
|
|
-
|
|
|
-module OASISFileSystem = struct
|
|
|
-(* # 22 "src/oasis/OASISFileSystem.ml" *)
|
|
|
-
|
|
|
- (** File System functions
|
|
|
-
|
|
|
- @author Sylvain Le Gall
|
|
|
- *)
|
|
|
-
|
|
|
- type 'a filename = string
|
|
|
-
|
|
|
- class type closer =
|
|
|
- object
|
|
|
- method close: unit
|
|
|
- end
|
|
|
-
|
|
|
- class type reader =
|
|
|
- object
|
|
|
- inherit closer
|
|
|
- method input: Buffer.t -> int -> unit
|
|
|
- end
|
|
|
-
|
|
|
- class type writer =
|
|
|
- object
|
|
|
- inherit closer
|
|
|
- method output: Buffer.t -> unit
|
|
|
- end
|
|
|
-
|
|
|
- class type ['a] fs =
|
|
|
- object
|
|
|
- method string_of_filename: 'a filename -> string
|
|
|
- method open_out: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> writer
|
|
|
- method open_in: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> reader
|
|
|
- method file_exists: 'a filename -> bool
|
|
|
- method remove: 'a filename -> unit
|
|
|
- end
|
|
|
-
|
|
|
-
|
|
|
- module Mode =
|
|
|
- struct
|
|
|
- let default_in = [Open_rdonly]
|
|
|
- let default_out = [Open_wronly; Open_creat; Open_trunc]
|
|
|
-
|
|
|
- let text_in = Open_text :: default_in
|
|
|
- let text_out = Open_text :: default_out
|
|
|
-
|
|
|
- let binary_in = Open_binary :: default_in
|
|
|
- let binary_out = Open_binary :: default_out
|
|
|
- end
|
|
|
-
|
|
|
- let std_length = 4096 (* Standard buffer/read length. *)
|
|
|
- let binary_out = Mode.binary_out
|
|
|
- let binary_in = Mode.binary_in
|
|
|
-
|
|
|
- let of_unix_filename ufn = (ufn: 'a filename)
|
|
|
- let to_unix_filename fn = (fn: string)
|
|
|
-
|
|
|
-
|
|
|
- let defer_close o f =
|
|
|
- try
|
|
|
- let r = f o in o#close; r
|
|
|
- with e ->
|
|
|
- o#close; raise e
|
|
|
-
|
|
|
-
|
|
|
- let stream_of_reader rdr =
|
|
|
- let buf = Buffer.create std_length in
|
|
|
- let pos = ref 0 in
|
|
|
- let eof = ref false in
|
|
|
- let rec next idx =
|
|
|
- let bpos = idx - !pos in
|
|
|
- if !eof then begin
|
|
|
- None
|
|
|
- end else if bpos < Buffer.length buf then begin
|
|
|
- Some (Buffer.nth buf bpos)
|
|
|
- end else begin
|
|
|
- pos := !pos + Buffer.length buf;
|
|
|
- Buffer.clear buf;
|
|
|
- begin
|
|
|
- try
|
|
|
- rdr#input buf std_length;
|
|
|
- with End_of_file ->
|
|
|
- if Buffer.length buf = 0 then
|
|
|
- eof := true
|
|
|
- end;
|
|
|
- next idx
|
|
|
- end
|
|
|
- in
|
|
|
- Stream.from next
|
|
|
-
|
|
|
-
|
|
|
- let read_all buf rdr =
|
|
|
- try
|
|
|
- while true do
|
|
|
- rdr#input buf std_length
|
|
|
- done
|
|
|
- with End_of_file ->
|
|
|
- ()
|
|
|
-
|
|
|
- class ['a] host_fs rootdir : ['a] fs =
|
|
|
- object (self)
|
|
|
- method private host_filename fn = Filename.concat rootdir fn
|
|
|
- method string_of_filename = self#host_filename
|
|
|
-
|
|
|
- method open_out ?(mode=Mode.text_out) ?(perm=0o666) fn =
|
|
|
- let chn = open_out_gen mode perm (self#host_filename fn) in
|
|
|
- object
|
|
|
- method close = close_out chn
|
|
|
- method output buf = Buffer.output_buffer chn buf
|
|
|
- end
|
|
|
-
|
|
|
- method open_in ?(mode=Mode.text_in) ?(perm=0o666) fn =
|
|
|
- (* TODO: use Buffer.add_channel when minimal version of OCaml will
|
|
|
- * be >= 4.03.0 (previous version was discarding last chars).
|
|
|
- *)
|
|
|
- let chn = open_in_gen mode perm (self#host_filename fn) in
|
|
|
- let strm = Stream.of_channel chn in
|
|
|
- object
|
|
|
- method close = close_in chn
|
|
|
- method input buf len =
|
|
|
- let read = ref 0 in
|
|
|
- try
|
|
|
- for _i = 0 to len do
|
|
|
- Buffer.add_char buf (Stream.next strm);
|
|
|
- incr read
|
|
|
- done
|
|
|
- with Stream.Failure ->
|
|
|
- if !read = 0 then
|
|
|
- raise End_of_file
|
|
|
- end
|
|
|
-
|
|
|
- method file_exists fn = Sys.file_exists (self#host_filename fn)
|
|
|
- method remove fn = Sys.remove (self#host_filename fn)
|
|
|
- end
|
|
|
-
|
|
|
-end
|
|
|
-
|
|
|
-module OASISContext = struct
|
|
|
-(* # 22 "src/oasis/OASISContext.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- open OASISGettext
|
|
|
-
|
|
|
-
|
|
|
- type level =
|
|
|
- [ `Debug
|
|
|
- | `Info
|
|
|
- | `Warning
|
|
|
- | `Error]
|
|
|
-
|
|
|
-
|
|
|
- type source
|
|
|
- type source_filename = source OASISFileSystem.filename
|
|
|
-
|
|
|
-
|
|
|
- let in_srcdir ufn = OASISFileSystem.of_unix_filename ufn
|
|
|
-
|
|
|
-
|
|
|
- type t =
|
|
|
- {
|
|
|
- (* TODO: replace this by a proplist. *)
|
|
|
- quiet: bool;
|
|
|
- info: bool;
|
|
|
- debug: bool;
|
|
|
- ignore_plugins: bool;
|
|
|
- ignore_unknown_fields: bool;
|
|
|
- printf: level -> string -> unit;
|
|
|
- srcfs: source OASISFileSystem.fs;
|
|
|
- load_oasis_plugin: string -> bool;
|
|
|
- }
|
|
|
-
|
|
|
-
|
|
|
- let printf lvl str =
|
|
|
- let beg =
|
|
|
- match lvl with
|
|
|
- | `Error -> s_ "E: "
|
|
|
- | `Warning -> s_ "W: "
|
|
|
- | `Info -> s_ "I: "
|
|
|
- | `Debug -> s_ "D: "
|
|
|
- in
|
|
|
- prerr_endline (beg^str)
|
|
|
-
|
|
|
-
|
|
|
- let default =
|
|
|
- ref
|
|
|
- {
|
|
|
- quiet = false;
|
|
|
- info = false;
|
|
|
- debug = false;
|
|
|
- ignore_plugins = false;
|
|
|
- ignore_unknown_fields = false;
|
|
|
- printf = printf;
|
|
|
- srcfs = new OASISFileSystem.host_fs(Sys.getcwd ());
|
|
|
- load_oasis_plugin = (fun _ -> false);
|
|
|
- }
|
|
|
-
|
|
|
-
|
|
|
- let quiet =
|
|
|
- {!default with quiet = true}
|
|
|
-
|
|
|
-
|
|
|
- let fspecs () =
|
|
|
- (* TODO: don't act on default. *)
|
|
|
- let ignore_plugins = ref false in
|
|
|
- ["-quiet",
|
|
|
- Arg.Unit (fun () -> default := {!default with quiet = true}),
|
|
|
- s_ " Run quietly";
|
|
|
-
|
|
|
- "-info",
|
|
|
- Arg.Unit (fun () -> default := {!default with info = true}),
|
|
|
- s_ " Display information message";
|
|
|
-
|
|
|
-
|
|
|
- "-debug",
|
|
|
- Arg.Unit (fun () -> default := {!default with debug = true}),
|
|
|
- s_ " Output debug message";
|
|
|
-
|
|
|
- "-ignore-plugins",
|
|
|
- Arg.Set ignore_plugins,
|
|
|
- s_ " Ignore plugin's field.";
|
|
|
-
|
|
|
- "-C",
|
|
|
- Arg.String
|
|
|
- (fun str ->
|
|
|
- Sys.chdir str;
|
|
|
- default := {!default with srcfs = new OASISFileSystem.host_fs str}),
|
|
|
- s_ "dir Change directory before running (affects setup.{data,log})."],
|
|
|
- fun () -> {!default with ignore_plugins = !ignore_plugins}
|
|
|
-end
|
|
|
-
|
|
|
-module PropList = struct
|
|
|
-(* # 22 "src/oasis/PropList.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- open OASISGettext
|
|
|
-
|
|
|
-
|
|
|
- type name = string
|
|
|
-
|
|
|
-
|
|
|
- exception Not_set of name * string option
|
|
|
- exception No_printer of name
|
|
|
- exception Unknown_field of name * name
|
|
|
-
|
|
|
-
|
|
|
- let () =
|
|
|
- Printexc.register_printer
|
|
|
- (function
|
|
|
- | Not_set (nm, Some rsn) ->
|
|
|
- Some
|
|
|
- (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn)
|
|
|
- | Not_set (nm, None) ->
|
|
|
- Some
|
|
|
- (Printf.sprintf (f_ "Field '%s' is not set") nm)
|
|
|
- | No_printer nm ->
|
|
|
- Some
|
|
|
- (Printf.sprintf (f_ "No default printer for value %s") nm)
|
|
|
- | Unknown_field (nm, schm) ->
|
|
|
- Some
|
|
|
- (Printf.sprintf
|
|
|
- (f_ "Field %s is not defined in schema %s") nm schm)
|
|
|
- | _ ->
|
|
|
- None)
|
|
|
-
|
|
|
-
|
|
|
- module Data =
|
|
|
- struct
|
|
|
- type t =
|
|
|
- (name, unit -> unit) Hashtbl.t
|
|
|
-
|
|
|
- let create () =
|
|
|
- Hashtbl.create 13
|
|
|
-
|
|
|
- let clear t =
|
|
|
- Hashtbl.clear t
|
|
|
-
|
|
|
-
|
|
|
-(* # 77 "src/oasis/PropList.ml" *)
|
|
|
- end
|
|
|
-
|
|
|
-
|
|
|
- module Schema =
|
|
|
- struct
|
|
|
- type ('ctxt, 'extra) value =
|
|
|
- {
|
|
|
- get: Data.t -> string;
|
|
|
- set: Data.t -> ?context:'ctxt -> string -> unit;
|
|
|
- help: (unit -> string) option;
|
|
|
- extra: 'extra;
|
|
|
- }
|
|
|
-
|
|
|
- type ('ctxt, 'extra) t =
|
|
|
- {
|
|
|
- name: name;
|
|
|
- fields: (name, ('ctxt, 'extra) value) Hashtbl.t;
|
|
|
- order: name Queue.t;
|
|
|
- name_norm: string -> string;
|
|
|
- }
|
|
|
-
|
|
|
- let create ?(case_insensitive=false) nm =
|
|
|
- {
|
|
|
- name = nm;
|
|
|
- fields = Hashtbl.create 13;
|
|
|
- order = Queue.create ();
|
|
|
- name_norm =
|
|
|
- (if case_insensitive then
|
|
|
- OASISString.lowercase_ascii
|
|
|
- else
|
|
|
- fun s -> s);
|
|
|
- }
|
|
|
-
|
|
|
- let add t nm set get extra help =
|
|
|
- let key =
|
|
|
- t.name_norm nm
|
|
|
- in
|
|
|
-
|
|
|
- if Hashtbl.mem t.fields key then
|
|
|
- failwith
|
|
|
- (Printf.sprintf
|
|
|
- (f_ "Field '%s' is already defined in schema '%s'")
|
|
|
- nm t.name);
|
|
|
- Hashtbl.add
|
|
|
- t.fields
|
|
|
- key
|
|
|
- {
|
|
|
- set = set;
|
|
|
- get = get;
|
|
|
- help = help;
|
|
|
- extra = extra;
|
|
|
- };
|
|
|
- Queue.add nm t.order
|
|
|
-
|
|
|
- let mem t nm =
|
|
|
- Hashtbl.mem t.fields nm
|
|
|
-
|
|
|
- let find t nm =
|
|
|
- try
|
|
|
- Hashtbl.find t.fields (t.name_norm nm)
|
|
|
- with Not_found ->
|
|
|
- raise (Unknown_field (nm, t.name))
|
|
|
-
|
|
|
- let get t data nm =
|
|
|
- (find t nm).get data
|
|
|
-
|
|
|
- let set t data nm ?context x =
|
|
|
- (find t nm).set
|
|
|
- data
|
|
|
- ?context
|
|
|
- x
|
|
|
-
|
|
|
- let fold f acc t =
|
|
|
- Queue.fold
|
|
|
- (fun acc k ->
|
|
|
- let v =
|
|
|
- find t k
|
|
|
- in
|
|
|
- f acc k v.extra v.help)
|
|
|
- acc
|
|
|
- t.order
|
|
|
-
|
|
|
- let iter f t =
|
|
|
- fold
|
|
|
- (fun () -> f)
|
|
|
- ()
|
|
|
- t
|
|
|
-
|
|
|
- let name t =
|
|
|
- t.name
|
|
|
- end
|
|
|
-
|
|
|
-
|
|
|
- module Field =
|
|
|
- struct
|
|
|
- type ('ctxt, 'value, 'extra) t =
|
|
|
- {
|
|
|
- set: Data.t -> ?context:'ctxt -> 'value -> unit;
|
|
|
- get: Data.t -> 'value;
|
|
|
- sets: Data.t -> ?context:'ctxt -> string -> unit;
|
|
|
- gets: Data.t -> string;
|
|
|
- help: (unit -> string) option;
|
|
|
- extra: 'extra;
|
|
|
- }
|
|
|
-
|
|
|
- let new_id =
|
|
|
- let last_id =
|
|
|
- ref 0
|
|
|
- in
|
|
|
- fun () -> incr last_id; !last_id
|
|
|
-
|
|
|
- let create ?schema ?name ?parse ?print ?default ?update ?help extra =
|
|
|
- (* Default value container *)
|
|
|
- let v =
|
|
|
- ref None
|
|
|
- in
|
|
|
-
|
|
|
- (* If name is not given, create unique one *)
|
|
|
- let nm =
|
|
|
- match name with
|
|
|
- | Some s -> s
|
|
|
- | None -> Printf.sprintf "_anon_%d" (new_id ())
|
|
|
- in
|
|
|
-
|
|
|
- (* Last chance to get a value: the default *)
|
|
|
- let default () =
|
|
|
- match default with
|
|
|
- | Some d -> d
|
|
|
- | None -> raise (Not_set (nm, Some (s_ "no default value")))
|
|
|
- in
|
|
|
-
|
|
|
- (* Get data *)
|
|
|
- let get data =
|
|
|
- (* Get value *)
|
|
|
- try
|
|
|
- (Hashtbl.find data nm) ();
|
|
|
- match !v with
|
|
|
- | Some x -> x
|
|
|
- | None -> default ()
|
|
|
- with Not_found ->
|
|
|
- default ()
|
|
|
- in
|
|
|
-
|
|
|
- (* Set data *)
|
|
|
- let set data ?context x =
|
|
|
- let x =
|
|
|
- match update with
|
|
|
- | Some f ->
|
|
|
- begin
|
|
|
- try
|
|
|
- f ?context (get data) x
|
|
|
- with Not_set _ ->
|
|
|
- x
|
|
|
- end
|
|
|
- | None ->
|
|
|
- x
|
|
|
- in
|
|
|
- Hashtbl.replace
|
|
|
- data
|
|
|
- nm
|
|
|
- (fun () -> v := Some x)
|
|
|
- in
|
|
|
-
|
|
|
- (* Parse string value, if possible *)
|
|
|
- let parse =
|
|
|
- match parse with
|
|
|
- | Some f ->
|
|
|
- f
|
|
|
- | None ->
|
|
|
- fun ?context s ->
|
|
|
- failwith
|
|
|
- (Printf.sprintf
|
|
|
- (f_ "Cannot parse field '%s' when setting value %S")
|
|
|
- nm
|
|
|
- s)
|
|
|
- in
|
|
|
-
|
|
|
- (* Set data, from string *)
|
|
|
- let sets data ?context s =
|
|
|
- set ?context data (parse ?context s)
|
|
|
- in
|
|
|
-
|
|
|
- (* Output value as string, if possible *)
|
|
|
- let print =
|
|
|
- match print with
|
|
|
- | Some f ->
|
|
|
- f
|
|
|
- | None ->
|
|
|
- fun _ -> raise (No_printer nm)
|
|
|
- in
|
|
|
-
|
|
|
- (* Get data, as a string *)
|
|
|
- let gets data =
|
|
|
- print (get data)
|
|
|
- in
|
|
|
-
|
|
|
- begin
|
|
|
- match schema with
|
|
|
- | Some t ->
|
|
|
- Schema.add t nm sets gets extra help
|
|
|
- | None ->
|
|
|
- ()
|
|
|
- end;
|
|
|
-
|
|
|
- {
|
|
|
- set = set;
|
|
|
- get = get;
|
|
|
- sets = sets;
|
|
|
- gets = gets;
|
|
|
- help = help;
|
|
|
- extra = extra;
|
|
|
- }
|
|
|
-
|
|
|
- let fset data t ?context x =
|
|
|
- t.set data ?context x
|
|
|
-
|
|
|
- let fget data t =
|
|
|
- t.get data
|
|
|
-
|
|
|
- let fsets data t ?context s =
|
|
|
- t.sets data ?context s
|
|
|
-
|
|
|
- let fgets data t =
|
|
|
- t.gets data
|
|
|
- end
|
|
|
-
|
|
|
-
|
|
|
- module FieldRO =
|
|
|
- struct
|
|
|
- let create ?schema ?name ?parse ?print ?default ?update ?help extra =
|
|
|
- let fld =
|
|
|
- Field.create ?schema ?name ?parse ?print ?default ?update ?help extra
|
|
|
- in
|
|
|
- fun data -> Field.fget data fld
|
|
|
- end
|
|
|
-end
|
|
|
-
|
|
|
-module OASISMessage = struct
|
|
|
-(* # 22 "src/oasis/OASISMessage.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- open OASISGettext
|
|
|
- open OASISContext
|
|
|
-
|
|
|
-
|
|
|
- let generic_message ~ctxt lvl fmt =
|
|
|
- let cond =
|
|
|
- if ctxt.quiet then
|
|
|
- false
|
|
|
- else
|
|
|
- match lvl with
|
|
|
- | `Debug -> ctxt.debug
|
|
|
- | `Info -> ctxt.info
|
|
|
- | _ -> true
|
|
|
- in
|
|
|
- Printf.ksprintf
|
|
|
- (fun str ->
|
|
|
- if cond then
|
|
|
- begin
|
|
|
- ctxt.printf lvl str
|
|
|
- end)
|
|
|
- fmt
|
|
|
-
|
|
|
-
|
|
|
- let debug ~ctxt fmt =
|
|
|
- generic_message ~ctxt `Debug fmt
|
|
|
-
|
|
|
-
|
|
|
- let info ~ctxt fmt =
|
|
|
- generic_message ~ctxt `Info fmt
|
|
|
-
|
|
|
-
|
|
|
- let warning ~ctxt fmt =
|
|
|
- generic_message ~ctxt `Warning fmt
|
|
|
-
|
|
|
-
|
|
|
- let error ~ctxt fmt =
|
|
|
- generic_message ~ctxt `Error fmt
|
|
|
-
|
|
|
-end
|
|
|
-
|
|
|
-module OASISVersion = struct
|
|
|
-(* # 22 "src/oasis/OASISVersion.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- open OASISGettext
|
|
|
-
|
|
|
-
|
|
|
- type t = string
|
|
|
-
|
|
|
-
|
|
|
- type comparator =
|
|
|
- | VGreater of t
|
|
|
- | VGreaterEqual of t
|
|
|
- | VEqual of t
|
|
|
- | VLesser of t
|
|
|
- | VLesserEqual of t
|
|
|
- | VOr of comparator * comparator
|
|
|
- | VAnd of comparator * comparator
|
|
|
-
|
|
|
-
|
|
|
- (* Range of allowed characters *)
|
|
|
- let is_digit c = '0' <= c && c <= '9'
|
|
|
- let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')
|
|
|
- let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false
|
|
|
-
|
|
|
-
|
|
|
- let rec version_compare v1 v2 =
|
|
|
- if v1 <> "" || v2 <> "" then
|
|
|
- begin
|
|
|
- (* Compare ascii string, using special meaning for version
|
|
|
- * related char
|
|
|
- *)
|
|
|
- let val_ascii c =
|
|
|
- if c = '~' then -1
|
|
|
- else if is_digit c then 0
|
|
|
- else if c = '\000' then 0
|
|
|
- else if is_alpha c then Char.code c
|
|
|
- else (Char.code c) + 256
|
|
|
- in
|
|
|
-
|
|
|
- let len1 = String.length v1 in
|
|
|
- let len2 = String.length v2 in
|
|
|
-
|
|
|
- let p = ref 0 in
|
|
|
-
|
|
|
- (** Compare ascii part *)
|
|
|
- let compare_vascii () =
|
|
|
- let cmp = ref 0 in
|
|
|
- while !cmp = 0 &&
|
|
|
- !p < len1 && !p < len2 &&
|
|
|
- not (is_digit v1.[!p] && is_digit v2.[!p]) do
|
|
|
- cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]);
|
|
|
- incr p
|
|
|
- done;
|
|
|
- if !cmp = 0 && !p < len1 && !p = len2 then
|
|
|
- val_ascii v1.[!p]
|
|
|
- else if !cmp = 0 && !p = len1 && !p < len2 then
|
|
|
- - (val_ascii v2.[!p])
|
|
|
- else
|
|
|
- !cmp
|
|
|
- in
|
|
|
-
|
|
|
- (** Compare digit part *)
|
|
|
- let compare_digit () =
|
|
|
- let extract_int v p =
|
|
|
- let start_p = !p in
|
|
|
- while !p < String.length v && is_digit v.[!p] do
|
|
|
- incr p
|
|
|
- done;
|
|
|
- let substr =
|
|
|
- String.sub v !p ((String.length v) - !p)
|
|
|
- in
|
|
|
- let res =
|
|
|
- match String.sub v start_p (!p - start_p) with
|
|
|
- | "" -> 0
|
|
|
- | s -> int_of_string s
|
|
|
- in
|
|
|
- res, substr
|
|
|
- in
|
|
|
- let i1, tl1 = extract_int v1 (ref !p) in
|
|
|
- let i2, tl2 = extract_int v2 (ref !p) in
|
|
|
- i1 - i2, tl1, tl2
|
|
|
- in
|
|
|
-
|
|
|
- match compare_vascii () with
|
|
|
- | 0 ->
|
|
|
- begin
|
|
|
- match compare_digit () with
|
|
|
- | 0, tl1, tl2 ->
|
|
|
- if tl1 <> "" && is_digit tl1.[0] then
|
|
|
- 1
|
|
|
- else if tl2 <> "" && is_digit tl2.[0] then
|
|
|
- -1
|
|
|
- else
|
|
|
- version_compare tl1 tl2
|
|
|
- | n, _, _ ->
|
|
|
- n
|
|
|
- end
|
|
|
- | n ->
|
|
|
- n
|
|
|
- end
|
|
|
- else begin
|
|
|
- 0
|
|
|
- end
|
|
|
-
|
|
|
-
|
|
|
- let version_of_string str = str
|
|
|
-
|
|
|
-
|
|
|
- let string_of_version t = t
|
|
|
-
|
|
|
-
|
|
|
- let chop t =
|
|
|
- try
|
|
|
- let pos =
|
|
|
- String.rindex t '.'
|
|
|
- in
|
|
|
- String.sub t 0 pos
|
|
|
- with Not_found ->
|
|
|
- t
|
|
|
-
|
|
|
-
|
|
|
- let rec comparator_apply v op =
|
|
|
- match op with
|
|
|
- | VGreater cv ->
|
|
|
- (version_compare v cv) > 0
|
|
|
- | VGreaterEqual cv ->
|
|
|
- (version_compare v cv) >= 0
|
|
|
- | VLesser cv ->
|
|
|
- (version_compare v cv) < 0
|
|
|
- | VLesserEqual cv ->
|
|
|
- (version_compare v cv) <= 0
|
|
|
- | VEqual cv ->
|
|
|
- (version_compare v cv) = 0
|
|
|
- | VOr (op1, op2) ->
|
|
|
- (comparator_apply v op1) || (comparator_apply v op2)
|
|
|
- | VAnd (op1, op2) ->
|
|
|
- (comparator_apply v op1) && (comparator_apply v op2)
|
|
|
-
|
|
|
-
|
|
|
- let rec string_of_comparator =
|
|
|
- function
|
|
|
- | VGreater v -> "> "^(string_of_version v)
|
|
|
- | VEqual v -> "= "^(string_of_version v)
|
|
|
- | VLesser v -> "< "^(string_of_version v)
|
|
|
- | VGreaterEqual v -> ">= "^(string_of_version v)
|
|
|
- | VLesserEqual v -> "<= "^(string_of_version v)
|
|
|
- | VOr (c1, c2) ->
|
|
|
- (string_of_comparator c1)^" || "^(string_of_comparator c2)
|
|
|
- | VAnd (c1, c2) ->
|
|
|
- (string_of_comparator c1)^" && "^(string_of_comparator c2)
|
|
|
-
|
|
|
-
|
|
|
- let rec varname_of_comparator =
|
|
|
- let concat p v =
|
|
|
- OASISUtils.varname_concat
|
|
|
- p
|
|
|
- (OASISUtils.varname_of_string
|
|
|
- (string_of_version v))
|
|
|
- in
|
|
|
- function
|
|
|
- | VGreater v -> concat "gt" v
|
|
|
- | VLesser v -> concat "lt" v
|
|
|
- | VEqual v -> concat "eq" v
|
|
|
- | VGreaterEqual v -> concat "ge" v
|
|
|
- | VLesserEqual v -> concat "le" v
|
|
|
- | VOr (c1, c2) ->
|
|
|
- (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2)
|
|
|
- | VAnd (c1, c2) ->
|
|
|
- (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2)
|
|
|
-
|
|
|
-
|
|
|
-end
|
|
|
-
|
|
|
-module OASISLicense = struct
|
|
|
-(* # 22 "src/oasis/OASISLicense.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- (** License for _oasis fields
|
|
|
- @author Sylvain Le Gall
|
|
|
- *)
|
|
|
-
|
|
|
-
|
|
|
- type license = string
|
|
|
- type license_exception = string
|
|
|
-
|
|
|
-
|
|
|
- type license_version =
|
|
|
- | Version of OASISVersion.t
|
|
|
- | VersionOrLater of OASISVersion.t
|
|
|
- | NoVersion
|
|
|
-
|
|
|
-
|
|
|
- type license_dep_5_unit =
|
|
|
- {
|
|
|
- license: license;
|
|
|
- excption: license_exception option;
|
|
|
- version: license_version;
|
|
|
- }
|
|
|
-
|
|
|
-
|
|
|
- type license_dep_5 =
|
|
|
- | DEP5Unit of license_dep_5_unit
|
|
|
- | DEP5Or of license_dep_5 list
|
|
|
- | DEP5And of license_dep_5 list
|
|
|
-
|
|
|
-
|
|
|
- type t =
|
|
|
- | DEP5License of license_dep_5
|
|
|
- | OtherLicense of string (* URL *)
|
|
|
-
|
|
|
-
|
|
|
-end
|
|
|
-
|
|
|
-module OASISExpr = struct
|
|
|
-(* # 22 "src/oasis/OASISExpr.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- open OASISGettext
|
|
|
- open OASISUtils
|
|
|
-
|
|
|
-
|
|
|
- type test = string
|
|
|
- type flag = string
|
|
|
-
|
|
|
-
|
|
|
- type t =
|
|
|
- | EBool of bool
|
|
|
- | ENot of t
|
|
|
- | EAnd of t * t
|
|
|
- | EOr of t * t
|
|
|
- | EFlag of flag
|
|
|
- | ETest of test * string
|
|
|
-
|
|
|
-
|
|
|
- type 'a choices = (t * 'a) list
|
|
|
-
|
|
|
-
|
|
|
- let eval var_get t =
|
|
|
- let rec eval' =
|
|
|
- function
|
|
|
- | EBool b ->
|
|
|
- b
|
|
|
-
|
|
|
- | ENot e ->
|
|
|
- not (eval' e)
|
|
|
-
|
|
|
- | EAnd (e1, e2) ->
|
|
|
- (eval' e1) && (eval' e2)
|
|
|
-
|
|
|
- | EOr (e1, e2) ->
|
|
|
- (eval' e1) || (eval' e2)
|
|
|
-
|
|
|
- | EFlag nm ->
|
|
|
- let v =
|
|
|
- var_get nm
|
|
|
- in
|
|
|
- assert(v = "true" || v = "false");
|
|
|
- (v = "true")
|
|
|
-
|
|
|
- | ETest (nm, vl) ->
|
|
|
- let v =
|
|
|
- var_get nm
|
|
|
- in
|
|
|
- (v = vl)
|
|
|
- in
|
|
|
- eval' t
|
|
|
-
|
|
|
-
|
|
|
- let choose ?printer ?name var_get lst =
|
|
|
- let rec choose_aux =
|
|
|
- function
|
|
|
- | (cond, vl) :: tl ->
|
|
|
- if eval var_get cond then
|
|
|
- vl
|
|
|
- else
|
|
|
- choose_aux tl
|
|
|
- | [] ->
|
|
|
- let str_lst =
|
|
|
- if lst = [] then
|
|
|
- s_ "<empty>"
|
|
|
- else
|
|
|
- String.concat
|
|
|
- (s_ ", ")
|
|
|
- (List.map
|
|
|
- (fun (cond, vl) ->
|
|
|
- match printer with
|
|
|
- | Some p -> p vl
|
|
|
- | None -> s_ "<no printer>")
|
|
|
- lst)
|
|
|
- in
|
|
|
- match name with
|
|
|
- | Some nm ->
|
|
|
- failwith
|
|
|
- (Printf.sprintf
|
|
|
- (f_ "No result for the choice list '%s': %s")
|
|
|
- nm str_lst)
|
|
|
- | None ->
|
|
|
- failwith
|
|
|
- (Printf.sprintf
|
|
|
- (f_ "No result for a choice list: %s")
|
|
|
- str_lst)
|
|
|
- in
|
|
|
- choose_aux (List.rev lst)
|
|
|
-
|
|
|
-
|
|
|
-end
|
|
|
-
|
|
|
-module OASISText = struct
|
|
|
-(* # 22 "src/oasis/OASISText.ml" *)
|
|
|
-
|
|
|
- type elt =
|
|
|
- | Para of string
|
|
|
- | Verbatim of string
|
|
|
- | BlankLine
|
|
|
-
|
|
|
- type t = elt list
|
|
|
-
|
|
|
-end
|
|
|
-
|
|
|
-module OASISSourcePatterns = struct
|
|
|
-(* # 22 "src/oasis/OASISSourcePatterns.ml" *)
|
|
|
-
|
|
|
- open OASISUtils
|
|
|
- open OASISGettext
|
|
|
-
|
|
|
- module Templater =
|
|
|
- struct
|
|
|
- (* TODO: use this module in BaseEnv.var_expand and BaseFileAB, at least. *)
|
|
|
- type t =
|
|
|
- {
|
|
|
- atoms: atom list;
|
|
|
- origin: string
|
|
|
- }
|
|
|
- and atom =
|
|
|
- | Text of string
|
|
|
- | Expr of expr
|
|
|
- and expr =
|
|
|
- | Ident of string
|
|
|
- | String of string
|
|
|
- | Call of string * expr
|
|
|
-
|
|
|
-
|
|
|
- type env =
|
|
|
- {
|
|
|
- variables: string MapString.t;
|
|
|
- functions: (string -> string) MapString.t;
|
|
|
- }
|
|
|
-
|
|
|
-
|
|
|
- let eval env t =
|
|
|
- let rec eval_expr env =
|
|
|
- function
|
|
|
- | String str -> str
|
|
|
- | Ident nm ->
|
|
|
- begin
|
|
|
- try
|
|
|
- MapString.find nm env.variables
|
|
|
- with Not_found ->
|
|
|
- (* TODO: add error location within the string. *)
|
|
|
- failwithf
|
|
|
- (f_ "Unable to find variable %S in source pattern %S")
|
|
|
- nm t.origin
|
|
|
- end
|
|
|
-
|
|
|
- | Call (fn, expr) ->
|
|
|
- begin
|
|
|
- try
|
|
|
- (MapString.find fn env.functions) (eval_expr env expr)
|
|
|
- with Not_found ->
|
|
|
- (* TODO: add error location within the string. *)
|
|
|
- failwithf
|
|
|
- (f_ "Unable to find function %S in source pattern %S")
|
|
|
- fn t.origin
|
|
|
- end
|
|
|
- in
|
|
|
- String.concat ""
|
|
|
- (List.map
|
|
|
- (function
|
|
|
- | Text str -> str
|
|
|
- | Expr expr -> eval_expr env expr)
|
|
|
- t.atoms)
|
|
|
-
|
|
|
-
|
|
|
- let parse env s =
|
|
|
- let lxr = Genlex.make_lexer [] in
|
|
|
- let parse_expr s =
|
|
|
- let st = lxr (Stream.of_string s) in
|
|
|
- match Stream.npeek 3 st with
|
|
|
- | [Genlex.Ident fn; Genlex.Ident nm] -> Call(fn, Ident nm)
|
|
|
- | [Genlex.Ident fn; Genlex.String str] -> Call(fn, String str)
|
|
|
- | [Genlex.String str] -> String str
|
|
|
- | [Genlex.Ident nm] -> Ident nm
|
|
|
- (* TODO: add error location within the string. *)
|
|
|
- | _ -> failwithf (f_ "Unable to parse expression %S") s
|
|
|
- in
|
|
|
- let parse s =
|
|
|
- let lst_exprs = ref [] in
|
|
|
- let ss =
|
|
|
- let buff = Buffer.create (String.length s) in
|
|
|
- Buffer.add_substitute
|
|
|
- buff
|
|
|
- (fun s -> lst_exprs := (parse_expr s) :: !lst_exprs; "\000")
|
|
|
- s;
|
|
|
- Buffer.contents buff
|
|
|
- in
|
|
|
- let rec join =
|
|
|
- function
|
|
|
- | hd1 :: tl1, hd2 :: tl2 -> Text hd1 :: Expr hd2 :: join (tl1, tl2)
|
|
|
- | [], tl -> List.map (fun e -> Expr e) tl
|
|
|
- | tl, [] -> List.map (fun e -> Text e) tl
|
|
|
- in
|
|
|
- join (OASISString.nsplit ss '\000', List.rev (!lst_exprs))
|
|
|
- in
|
|
|
- let t = {atoms = parse s; origin = s} in
|
|
|
- (* We rely on a simple evaluation for checking variables/functions.
|
|
|
- It works because there is no if/loop statement.
|
|
|
- *)
|
|
|
- let _s : string = eval env t in
|
|
|
- t
|
|
|
-
|
|
|
-(* # 144 "src/oasis/OASISSourcePatterns.ml" *)
|
|
|
- end
|
|
|
-
|
|
|
-
|
|
|
- type t = Templater.t
|
|
|
-
|
|
|
-
|
|
|
- let env ~modul () =
|
|
|
- {
|
|
|
- Templater.
|
|
|
- variables = MapString.of_list ["module", modul];
|
|
|
- functions = MapString.of_list
|
|
|
- [
|
|
|
- "capitalize_file", OASISUnixPath.capitalize_file;
|
|
|
- "uncapitalize_file", OASISUnixPath.uncapitalize_file;
|
|
|
- ];
|
|
|
- }
|
|
|
-
|
|
|
- let all_possible_files lst ~path ~modul =
|
|
|
- let eval = Templater.eval (env ~modul ()) in
|
|
|
- List.fold_left
|
|
|
- (fun acc pat -> OASISUnixPath.concat path (eval pat) :: acc)
|
|
|
- [] lst
|
|
|
-
|
|
|
-
|
|
|
- let to_string t = t.Templater.origin
|
|
|
-
|
|
|
-
|
|
|
-end
|
|
|
-
|
|
|
-module OASISTypes = struct
|
|
|
-(* # 22 "src/oasis/OASISTypes.ml" *)
|
|
|
-
|
|
|
-
|
|
|
- type name = string
|
|
|
- type package_name = string
|
|
|
- type url = string
|
|
|
- type unix_dirname = string
|
|
|
- type unix_filename = string (* TODO: replace everywhere. *)
|
|
|
- type host_dirname = string (* TODO: replace everywhere. *)
|
|
|
- type host_filename = string (* TODO: replace everywhere. *)
|
|
|
- type prog = string
|
|
|
- type arg = string
|
|
|
- type args = string list
|
|
|
- type command_line = (prog * arg list)
|
|
|
-
|
|
|
-
|
|
|
- type findlib_name = string
|
|
|
- type findlib_full = string
|
|
Aaron Dufour