Skip to content
Permalink
master
Switch branches/tags

Name already in use

A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
Go to file
 
 
Cannot retrieve contributors at this time
(******************************************************************************)
(* OASIS: architecture for building OCaml libraries and applications *)
(* *)
(* Copyright (C) 2011-2016, Sylvain Le Gall *)
(* Copyright (C) 2008-2011, OCamlCore SARL *)
(* *)
(* This library is free software; you can redistribute it and/or modify it *)
(* under the terms of the GNU Lesser General Public License as published by *)
(* the Free Software Foundation; either version 2.1 of the License, or (at *)
(* your option) any later version, with the OCaml static compilation *)
(* exception. *)
(* *)
(* This library is distributed in the hope that it will be useful, but *)
(* WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *)
(* or FITNESS FOR A PARTICULAR PURPOSE. See the file COPYING for more *)
(* details. *)
(* *)
(* You should have received a copy of the GNU Lesser General Public License *)
(* along with this library; if not, write to the Free Software Foundation, *)
(* Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA *)
(******************************************************************************)
(* OASIS_START *)
(* DO NOT EDIT (digest: ba786ae126b8ef96bff21f5a44b69ef6) *)
(*
Regenerated by OASIS v0.4.11
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;
!what_idx = String.length what
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;
!what_idx = -1
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
type compiled_object =
| Byte
| Native
| Best
type dependency =
| FindlibPackage of findlib_full * OASISVersion.comparator option
| InternalLibrary of name
type tool =
| ExternalTool of name
| InternalExecutable of name
type vcs =
| Darcs
| Git
| Svn
| Cvs
| Hg
| Bzr
| Arch
| Monotone
| OtherVCS of url
type plugin_kind =
[ `Configure
| `Build
| `Doc
| `Test
| `Install
| `Extra
]
type plugin_data_purpose =
[ `Configure
| `Build
| `Install
| `Clean
| `Distclean
| `Install
| `Uninstall
| `Test
| `Doc
| `Extra
| `Other of string
]
type 'a plugin = 'a * name * OASISVersion.t option
type all_plugin = plugin_kind plugin
type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list
type 'a conditional = 'a OASISExpr.choices
type custom =
{
pre_command: (command_line option) conditional;
post_command: (command_line option) conditional;
}
type common_section =
{
cs_name: name;
cs_data: PropList.Data.t;
cs_plugin_data: plugin_data;
}
type build_section =
{
bs_build: bool conditional;
bs_install: bool conditional;
bs_path: unix_dirname;
bs_compiled_object: compiled_object;
bs_build_depends: dependency list;
bs_build_tools: tool list;
bs_interface_patterns: OASISSourcePatterns.t list;
bs_implementation_patterns: OASISSourcePatterns.t list;
bs_c_sources: unix_filename list;
bs_data_files: (unix_filename * unix_filename option) list;
bs_findlib_extra_files: unix_filename list;
bs_ccopt: args conditional;
bs_cclib: args conditional;
bs_dlllib: args conditional;
bs_dllpath: args conditional;
bs_byteopt: args conditional;
bs_nativeopt: args conditional;
}
type library =
{
lib_modules: string list;
lib_pack: bool;
lib_internal_modules: string list;
lib_findlib_parent: findlib_name option;
lib_findlib_name: findlib_name option;
lib_findlib_directory: unix_dirname option;
lib_findlib_containers: findlib_name list;
}
type object_ =
{
obj_modules: string list;
obj_findlib_fullname: findlib_name list option;
obj_findlib_directory: unix_dirname option;
}
type executable =
{
exec_custom: bool;
exec_main_is: unix_filename;
}
type flag =
{
flag_description: string option;
flag_default: bool conditional;
}
type source_repository =
{
src_repo_type: vcs;
src_repo_location: url;
src_repo_browser: url option;
src_repo_module: string option;
src_repo_branch: string option;
src_repo_tag: string option;
src_repo_subdir: unix_filename option;
}
type test =
{
test_type: [`Test] plugin;
test_command: command_line conditional;
test_custom: custom;
test_working_directory: unix_filename option;
test_run: bool conditional;
test_tools: tool list;
}
type doc_format =
| HTML of unix_filename (* TODO: source filename. *)
| DocText
| PDF
| PostScript
| Info of unix_filename (* TODO: source filename. *)
| DVI
| OtherDoc
type doc =
{
doc_type: [`Doc] plugin;
doc_custom: custom;
doc_build: bool conditional;
doc_install: bool conditional;
doc_install_dir: unix_filename; (* TODO: dest filename ?. *)
doc_title: string;
doc_authors: string list;
doc_abstract: string option;
doc_format: doc_format;
(* TODO: src filename. *)
doc_data_files: (unix_filename * unix_filename option) list;
doc_build_tools: tool list;
}
type section =
| Library of common_section * build_section * library
| Object of common_section * build_section * object_
| Executable of common_section * build_section * executable
| Flag of common_section * flag
| SrcRepo of common_section * source_repository
| Test of common_section * test
| Doc of common_section * doc
type section_kind =
[ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ]
type package =
{
oasis_version: OASISVersion.t;
ocaml_version: OASISVersion.comparator option;
findlib_version: OASISVersion.comparator option;
alpha_features: string list;
beta_features: string list;
name: package_name;
version: OASISVersion.t;
license: OASISLicense.t;
license_file: unix_filename option; (* TODO: source filename. *)
copyrights: string list;
maintainers: string list;
authors: string list;
homepage: url option;
bugreports: url option;
synopsis: string;
description: OASISText.t option;
tags: string list;
categories: url list;
conf_type: [`Configure] plugin;
conf_custom: custom;
build_type: [`Build] plugin;
build_custom: custom;
install_type: [`Install] plugin;
install_custom: custom;
uninstall_custom: custom;
clean_custom: custom;
distclean_custom: custom;
files_ab: unix_filename list; (* TODO: source filename. *)
sections: section list;
plugins: [`Extra] plugin list;
disable_oasis_section: unix_filename list; (* TODO: source filename. *)
schema_data: PropList.Data.t;
plugin_data: plugin_data;
}
end
module OASISFeatures = struct
# 22 "src/oasis/OASISFeatures.ml"
open OASISTypes
open OASISUtils
open OASISGettext
open OASISVersion
module MapPlugin =
Map.Make
(struct
type t = plugin_kind * name
let compare = Pervasives.compare
end)
module Data =
struct
type t =
{
oasis_version: OASISVersion.t;
plugin_versions: OASISVersion.t option MapPlugin.t;
alpha_features: string list;
beta_features: string list;
}
let create oasis_version alpha_features beta_features =
{
oasis_version = oasis_version;
plugin_versions = MapPlugin.empty;
alpha_features = alpha_features;
beta_features = beta_features
}
let of_package pkg =
create
pkg.OASISTypes.oasis_version
pkg.OASISTypes.alpha_features
pkg.OASISTypes.beta_features
let add_plugin (plugin_kind, plugin_name, plugin_version) t =
{t with
plugin_versions = MapPlugin.add
(plugin_kind, plugin_name)
plugin_version
t.plugin_versions}
let plugin_version plugin_kind plugin_name t =
MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions
let to_string t =
Printf.sprintf
"oasis_version: %s; alpha_features: %s; beta_features: %s; \
plugins_version: %s"
(OASISVersion.string_of_version (t:t).oasis_version)
(String.concat ", " t.alpha_features)
(String.concat ", " t.beta_features)
(String.concat ", "
(MapPlugin.fold
(fun (_, plg) ver_opt acc ->
(plg^
(match ver_opt with
| Some v ->
" "^(OASISVersion.string_of_version v)
| None -> ""))
:: acc)
t.plugin_versions []))
end
type origin =
| Field of string * string
| Section of string
| NoOrigin
type stage = Alpha | Beta
let string_of_stage =
function
| Alpha -> "alpha"
| Beta -> "beta"
let field_of_stage =
function
| Alpha -> "AlphaFeatures"
| Beta -> "BetaFeatures"
type publication = InDev of stage | SinceVersion of OASISVersion.t
type t =
{
name: string;
plugin: all_plugin option;
publication: publication;
description: unit -> string;
}
(* TODO: mutex protect this. *)
let all_features = Hashtbl.create 13
let since_version ver_str = SinceVersion (version_of_string ver_str)
let alpha = InDev Alpha
let beta = InDev Beta
let to_string t =
Printf.sprintf
"feature: %s; plugin: %s; publication: %s"
(t:t).name
(match t.plugin with
| None -> "<none>"
| Some (_, nm, _) -> nm)
(match t.publication with
| InDev stage -> string_of_stage stage
| SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver))
let data_check t data origin =
let no_message = "no message" in
let check_feature features stage =
let has_feature = List.mem (t:t).name features in
if not has_feature then
match (origin:origin) with
| Field (fld, where) ->
Some
(Printf.sprintf
(f_ "Field %s in %s is only available when feature %s \
is in field %s.")
fld where t.name (field_of_stage stage))
| Section sct ->
Some
(Printf.sprintf
(f_ "Section %s is only available when features %s \
is in field %s.")
sct t.name (field_of_stage stage))
| NoOrigin ->
Some no_message
else
None
in
let version_is_good ~min_version version fmt =
let version_is_good =
OASISVersion.comparator_apply
version (OASISVersion.VGreaterEqual min_version)
in
Printf.ksprintf
(fun str -> if version_is_good then None else Some str)
fmt
in
match origin, t.plugin, t.publication with
| _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha
| _, _, InDev Beta -> check_feature data.Data.beta_features Beta
| Field(fld, where), None, SinceVersion min_version ->
version_is_good ~min_version data.Data.oasis_version
(f_ "Field %s in %s is only valid since OASIS v%s, update \
OASISFormat field from '%s' to '%s' after checking \
OASIS changelog.")
fld where (string_of_version min_version)
(string_of_version data.Data.oasis_version)
(string_of_version min_version)
| Field(fld, where), Some(plugin_knd, plugin_name, _),
SinceVersion min_version ->
begin
try
let plugin_version_current =
try
match Data.plugin_version plugin_knd plugin_name data with
| Some ver -> ver
| None ->
failwithf
(f_ "Field %s in %s is only valid for the OASIS \
plugin %s since v%s, but no plugin version is \
defined in the _oasis file, change '%s' to \
'%s (%s)' in your _oasis file.")
fld where plugin_name (string_of_version min_version)
plugin_name
plugin_name (string_of_version min_version)
with Not_found ->
failwithf
(f_ "Field %s in %s is only valid when the OASIS plugin %s \
is defined.")
fld where plugin_name
in
version_is_good ~min_version plugin_version_current
(f_ "Field %s in %s is only valid for the OASIS plugin %s \
since v%s, update your plugin from '%s (%s)' to \
'%s (%s)' after checking the plugin's changelog.")
fld where plugin_name (string_of_version min_version)
plugin_name (string_of_version plugin_version_current)
plugin_name (string_of_version min_version)
with Failure msg ->
Some msg
end
| Section sct, None, SinceVersion min_version ->
version_is_good ~min_version data.Data.oasis_version
(f_ "Section %s is only valid for since OASIS v%s, update \
OASISFormat field from '%s' to '%s' after checking OASIS \
changelog.")
sct (string_of_version min_version)
(string_of_version data.Data.oasis_version)
(string_of_version min_version)
| Section sct, Some(plugin_knd, plugin_name, _),
SinceVersion min_version ->
begin
try
let plugin_version_current =
try
match Data.plugin_version plugin_knd plugin_name data with
| Some ver -> ver
| None ->
failwithf
(f_ "Section %s is only valid for the OASIS \
plugin %s since v%s, but no plugin version is \
defined in the _oasis file, change '%s' to \
'%s (%s)' in your _oasis file.")
sct plugin_name (string_of_version min_version)
plugin_name
plugin_name (string_of_version min_version)
with Not_found ->
failwithf
(f_ "Section %s is only valid when the OASIS plugin %s \
is defined.")
sct plugin_name
in
version_is_good ~min_version plugin_version_current
(f_ "Section %s is only valid for the OASIS plugin %s \
since v%s, update your plugin from '%s (%s)' to \
'%s (%s)' after checking the plugin's changelog.")
sct plugin_name (string_of_version min_version)
plugin_name (string_of_version plugin_version_current)
plugin_name (string_of_version min_version)
with Failure msg ->
Some msg
end
| NoOrigin, None, SinceVersion min_version ->
version_is_good ~min_version data.Data.oasis_version "%s" no_message
| NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version ->
begin
try
let plugin_version_current =
match Data.plugin_version plugin_knd plugin_name data with
| Some ver -> ver
| None -> raise Not_found
in
version_is_good ~min_version plugin_version_current
"%s" no_message
with Not_found ->
Some no_message
end
let data_assert t data origin =
match data_check t data origin with
| None -> ()
| Some str -> failwith str
let data_test t data =
match data_check t data NoOrigin with
| None -> true
| Some _ -> false
let package_test t pkg =
data_test t (Data.of_package pkg)
let create ?plugin name publication description =
let () =
if Hashtbl.mem all_features name then
failwithf "Feature '%s' is already declared." name
in
let t =
{
name = name;
plugin = plugin;
publication = publication;
description = description;
}
in
Hashtbl.add all_features name t;
t
let get_stage name =
try
(Hashtbl.find all_features name).publication
with Not_found ->
failwithf (f_ "Feature %s doesn't exist.") name
let list () =
Hashtbl.fold (fun _ v acc -> v :: acc) all_features []
(*
* Real flags.
*)
let features =
create "features_fields"
(since_version "0.4")
(fun () ->
s_ "Enable to experiment not yet official features.")
let flag_docs =
create "flag_docs"
(since_version "0.3")
(fun () ->
s_ "Make building docs require '-docs' flag at configure.")
let flag_tests =
create "flag_tests"
(since_version "0.3")
(fun () ->
s_ "Make running tests require '-tests' flag at configure.")
let pack =
create "pack"
(since_version "0.3")
(fun () ->
s_ "Allow to create packed library.")
let section_object =
create "section_object" beta
(fun () ->
s_ "Implement an object section.")
let dynrun_for_release =
create "dynrun_for_release" alpha
(fun () ->
s_ "Make '-setup-update dynamic' suitable for releasing project.")
let compiled_setup_ml =
create "compiled_setup_ml" alpha
(fun () ->
s_ "Compile the setup.ml and speed-up actions done with it.")
let disable_oasis_section =
create "disable_oasis_section" alpha
(fun () ->
s_ "Allow the OASIS section comments and digests to be omitted in \
generated files.")
let no_automatic_syntax =
create "no_automatic_syntax" alpha
(fun () ->
s_ "Disable the automatic inclusion of -syntax camlp4o for packages \
that matches the internal heuristic (if a dependency ends with \
a .syntax or is a well known syntax).")
let findlib_directory =
create "findlib_directory" beta
(fun () ->
s_ "Allow to install findlib libraries in sub-directories of the target \
findlib directory.")
let findlib_extra_files =
create "findlib_extra_files" beta
(fun () ->
s_ "Allow to install extra files for findlib libraries.")
let source_patterns =
create "source_patterns" alpha
(fun () ->
s_ "Customize mapping between module name and source file.")
end
module OASISSection = struct
# 22 "src/oasis/OASISSection.ml"
open OASISTypes
let section_kind_common =
function
| Library (cs, _, _) ->
`Library, cs
| Object (cs, _, _) ->
`Object, cs
| Executable (cs, _, _) ->
`Executable, cs
| Flag (cs, _) ->
`Flag, cs
| SrcRepo (cs, _) ->
`SrcRepo, cs
| Test (cs, _) ->
`Test, cs
| Doc (cs, _) ->
`Doc, cs
let section_common sct =
snd (section_kind_common sct)
let section_common_set cs =
function
| Library (_, bs, lib) -> Library (cs, bs, lib)
| Object (_, bs, obj) -> Object (cs, bs, obj)
| Executable (_, bs, exec) -> Executable (cs, bs, exec)
| Flag (_, flg) -> Flag (cs, flg)
| SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo)
| Test (_, tst) -> Test (cs, tst)
| Doc (_, doc) -> Doc (cs, doc)
(** Key used to identify section
*)
let section_id sct =
let k, cs =
section_kind_common sct
in
k, cs.cs_name
let string_of_section_kind =
function
| `Library -> "library"
| `Object -> "object"
| `Executable -> "executable"
| `Flag -> "flag"
| `SrcRepo -> "src repository"
| `Test -> "test"
| `Doc -> "doc"
let string_of_section sct =
let k, nm = section_id sct in
(string_of_section_kind k)^" "^nm
let section_find id scts =
List.find
(fun sct -> id = section_id sct)
scts
module CSection =
struct
type t = section
let id = section_id
let compare t1 t2 =
compare (id t1) (id t2)
let equal t1 t2 =
(id t1) = (id t2)
let hash t =
Hashtbl.hash (id t)
end
module MapSection = Map.Make(CSection)
module SetSection = Set.Make(CSection)
end
module OASISBuildSection = struct
# 22 "src/oasis/OASISBuildSection.ml"
open OASISTypes
(* Look for a module file, considering capitalization or not. *)
let find_module source_file_exists bs modul =
let possible_lst =
OASISSourcePatterns.all_possible_files
(bs.bs_interface_patterns @ bs.bs_implementation_patterns)
~path:bs.bs_path
~modul
in
match List.filter source_file_exists possible_lst with
| (fn :: _) as fn_lst -> `Sources (OASISUnixPath.chop_extension fn, fn_lst)
| [] ->
let open OASISUtils in
let _, rev_lst =
List.fold_left
(fun (set, acc) fn ->
let base_fn = OASISUnixPath.chop_extension fn in
if SetString.mem base_fn set then
set, acc
else
SetString.add base_fn set, base_fn :: acc)
(SetString.empty, []) possible_lst
in
`No_sources (List.rev rev_lst)
end
module OASISExecutable = struct
# 22 "src/oasis/OASISExecutable.ml"
open OASISTypes
let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program =
let dir =
OASISUnixPath.concat
bs.bs_path
(OASISUnixPath.dirname exec.exec_main_is)
in
let is_native_exec =
match bs.bs_compiled_object with
| Native -> true
| Best -> is_native ()
| Byte -> false
in
OASISUnixPath.concat
dir
(cs.cs_name^(suffix_program ())),
if not is_native_exec &&
not exec.exec_custom &&
bs.bs_c_sources <> [] then
Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ()))
else
None
end
module OASISLibrary = struct
# 22 "src/oasis/OASISLibrary.ml"
open OASISTypes
open OASISGettext
let find_module ~ctxt source_file_exists cs bs modul =
match OASISBuildSection.find_module source_file_exists bs modul with
| `Sources _ as res -> res
| `No_sources _ as res ->
OASISMessage.warning
~ctxt
(f_ "Cannot find source file matching module '%s' in library %s.")
modul cs.cs_name;
OASISMessage.warning
~ctxt
(f_ "Use InterfacePatterns or ImplementationPatterns to define \
this file with feature %S.")
(OASISFeatures.source_patterns.OASISFeatures.name);
res
let source_unix_files ~ctxt (cs, bs, lib) source_file_exists =
List.fold_left
(fun acc modul ->
match find_module ~ctxt source_file_exists cs bs modul with
| `Sources (base_fn, lst) -> (base_fn, lst) :: acc
| `No_sources _ -> acc)
[]
(lib.lib_modules @ lib.lib_internal_modules)
let generated_unix_files
~ctxt
~is_native
~has_native_dynlink
~ext_lib
~ext_dll
~source_file_exists
(cs, bs, lib) =
let find_modules lst ext =
let find_module modul =
match find_module ~ctxt source_file_exists cs bs modul with
| `Sources (_, [fn]) when ext <> "cmi"
&& Filename.check_suffix fn ".mli" ->
None (* No implementation files for pure interface. *)
| `Sources (base_fn, _) -> Some [base_fn]
| `No_sources lst -> Some lst
in
List.fold_left
(fun acc nm ->
match find_module nm with
| None -> acc
| Some base_fns ->
List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc)
[]
lst
in
(* The .cmx that be compiled along *)
let cmxs =
let should_be_built =
match bs.bs_compiled_object with
| Native -> true
| Best -> is_native
| Byte -> false
in
if should_be_built then
if lib.lib_pack then
find_modules
[cs.cs_name]
"cmx"
else
find_modules
(lib.lib_modules @ lib.lib_internal_modules)
"cmx"
else
[]
in
let acc_nopath =
[]
in
(* The headers and annot/cmt files that should be compiled along *)
let headers =
let sufx =
if lib.lib_pack
then [".cmti"; ".cmt"; ".annot"]
else [".cmi"; ".cmti"; ".cmt"; ".annot"]
in
List.map
(List.fold_left
(fun accu s ->
let dot = String.rindex s '.' in
let base = String.sub s 0 dot in
List.map ((^) base) sufx @ accu)
[])
(find_modules lib.lib_modules "cmi")
in
(* Compute what libraries should be built *)
let acc_nopath =
(* Add the packed header file if required *)
let add_pack_header acc =
if lib.lib_pack then
[cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc
else
acc
in
let byte acc =
add_pack_header ([cs.cs_name^".cma"] :: acc)
in
let native acc =
let acc =
add_pack_header
(if has_native_dynlink then
[cs.cs_name^".cmxs"] :: acc
else acc)
in
[cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc
in
match bs.bs_compiled_object with
| Native -> byte (native acc_nopath)
| Best when is_native -> byte (native acc_nopath)
| Byte | Best -> byte acc_nopath
in
(* Add C library to be built *)
let acc_nopath =
if bs.bs_c_sources <> [] then begin
["lib"^cs.cs_name^"_stubs"^ext_lib]
::
if has_native_dynlink then
["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath
else
acc_nopath
end else begin
acc_nopath
end
in
(* All the files generated *)
List.rev_append
(List.rev_map
(List.rev_map
(OASISUnixPath.concat bs.bs_path))
acc_nopath)
(headers @ cmxs)
end
module OASISObject = struct
# 22 "src/oasis/OASISObject.ml"
open OASISTypes
open OASISGettext
let find_module ~ctxt source_file_exists cs bs modul =
match OASISBuildSection.find_module source_file_exists bs modul with
| `Sources _ as res -> res
| `No_sources _ as res ->
OASISMessage.warning
~ctxt
(f_ "Cannot find source file matching module '%s' in object %s.")
modul cs.cs_name;
OASISMessage.warning
~ctxt
(f_ "Use InterfacePatterns or ImplementationPatterns to define \
this file with feature %S.")
(OASISFeatures.source_patterns.OASISFeatures.name);
res
let source_unix_files ~ctxt (cs, bs, obj) source_file_exists =
List.fold_left
(fun acc modul ->
match find_module ~ctxt source_file_exists cs bs modul with
| `Sources (base_fn, lst) -> (base_fn, lst) :: acc
| `No_sources _ -> acc)
[]
obj.obj_modules
let generated_unix_files
~ctxt
~is_native
~source_file_exists
(cs, bs, obj) =
let find_module ext modul =
match find_module ~ctxt source_file_exists cs bs modul with
| `Sources (base_fn, _) -> [base_fn ^ ext]
| `No_sources lst -> lst
in
let header, byte, native, c_object, f =
match obj.obj_modules with
| [ m ] -> (find_module ".cmi" m,
find_module ".cmo" m,
find_module ".cmx" m,
find_module ".o" m,
fun x -> x)
| _ -> ([cs.cs_name ^ ".cmi"],
[cs.cs_name ^ ".cmo"],
[cs.cs_name ^ ".cmx"],
[cs.cs_name ^ ".o"],
OASISUnixPath.concat bs.bs_path)
in
List.map (List.map f) (
match bs.bs_compiled_object with
| Native ->
native :: c_object :: byte :: header :: []
| Best when is_native ->
native :: c_object :: byte :: header :: []
| Byte | Best ->
byte :: header :: [])
end
module OASISFindlib = struct
# 22 "src/oasis/OASISFindlib.ml"
open OASISTypes
open OASISUtils
open OASISGettext
type library_name = name
type findlib_part_name = name
type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t
exception InternalLibraryNotFound of library_name
exception FindlibPackageNotFound of findlib_name
type group_t =
| Container of findlib_name * group_t list
| Package of (findlib_name *
common_section *
build_section *
[`Library of library | `Object of object_] *
unix_dirname option *
group_t list)
type data = common_section *
build_section *
[`Library of library | `Object of object_]
type tree =
| Node of (data option) * (tree MapString.t)
| Leaf of data
let findlib_mapping pkg =
(* Map from library name to either full findlib name or parts + parent. *)
let fndlb_parts_of_lib_name =
let fndlb_parts cs lib =
let name =
match lib.lib_findlib_name with
| Some nm -> nm
| None -> cs.cs_name
in
let name =
String.concat "." (lib.lib_findlib_containers @ [name])
in
name
in
List.fold_left
(fun mp ->
function
| Library (cs, _, lib) ->
begin
let lib_name = cs.cs_name in
let fndlb_parts = fndlb_parts cs lib in
if MapString.mem lib_name mp then
failwithf
(f_ "The library name '%s' is used more than once.")
lib_name;
match lib.lib_findlib_parent with
| Some lib_name_parent ->
MapString.add
lib_name
(`Unsolved (lib_name_parent, fndlb_parts))
mp
| None ->
MapString.add
lib_name
(`Solved fndlb_parts)
mp
end
| Object (cs, _, obj) ->
begin
let obj_name = cs.cs_name in
if MapString.mem obj_name mp then
failwithf
(f_ "The object name '%s' is used more than once.")
obj_name;
let findlib_full_name = match obj.obj_findlib_fullname with
| Some ns -> String.concat "." ns
| None -> obj_name
in
MapString.add
obj_name
(`Solved findlib_full_name)
mp
end
| Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ ->
mp)
MapString.empty
pkg.sections
in
(* Solve the above graph to be only library name to full findlib name. *)
let fndlb_name_of_lib_name =
let rec solve visited mp lib_name lib_name_child =
if SetString.mem lib_name visited then
failwithf
(f_ "Library '%s' is involved in a cycle \
with regard to findlib naming.")
lib_name;
let visited = SetString.add lib_name visited in
try
match MapString.find lib_name mp with
| `Solved fndlb_nm ->
fndlb_nm, mp
| `Unsolved (lib_nm_parent, post_fndlb_nm) ->
let pre_fndlb_nm, mp =
solve visited mp lib_nm_parent lib_name
in
let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in
fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp
with Not_found ->
failwithf
(f_ "Library '%s', which is defined as the findlib parent of \
library '%s', doesn't exist.")
lib_name lib_name_child
in
let mp =
MapString.fold
(fun lib_name status mp ->
match status with
| `Solved _ ->
(* Solved initialy, no need to go further *)
mp
| `Unsolved _ ->
let _, mp = solve SetString.empty mp lib_name "<none>" in
mp)
fndlb_parts_of_lib_name
fndlb_parts_of_lib_name
in
MapString.map
(function
| `Solved fndlb_nm -> fndlb_nm
| `Unsolved _ -> assert false)
mp
in
(* Convert an internal library name to a findlib name. *)
let findlib_name_of_library_name lib_nm =
try
MapString.find lib_nm fndlb_name_of_lib_name
with Not_found ->
raise (InternalLibraryNotFound lib_nm)
in
(* Add a library to the tree.
*)
let add sct mp =
let fndlb_fullname =
let cs, _, _ = sct in
let lib_name = cs.cs_name in
findlib_name_of_library_name lib_name
in
let rec add_children nm_lst (children: tree MapString.t) =
match nm_lst with
| (hd :: tl) ->
begin
let node =
try
add_node tl (MapString.find hd children)
with Not_found ->
(* New node *)
new_node tl
in
MapString.add hd node children
end
| [] ->
(* Should not have a nameless library. *)
assert false
and add_node tl node =
if tl = [] then
begin
match node with
| Node (None, children) ->
Node (Some sct, children)
| Leaf (cs', _, _) | Node (Some (cs', _, _), _) ->
(* TODO: allow to merge Package, i.e.
* archive(byte) = "foo.cma foo_init.cmo"
*)
let cs, _, _ = sct in
failwithf
(f_ "Library '%s' and '%s' have the same findlib name '%s'")
cs.cs_name cs'.cs_name fndlb_fullname
end
else
begin
match node with
| Leaf data ->
Node (Some data, add_children tl MapString.empty)
| Node (data_opt, children) ->
Node (data_opt, add_children tl children)
end
and new_node =
function
| [] ->
Leaf sct
| hd :: tl ->
Node (None, MapString.add hd (new_node tl) MapString.empty)
in
add_children (OASISString.nsplit fndlb_fullname '.') mp
in
let unix_directory dn lib =
let directory =
match lib with
| `Library lib -> lib.lib_findlib_directory
| `Object obj -> obj.obj_findlib_directory
in
match dn, directory with
| None, None -> None
| None, Some dn | Some dn, None -> Some dn
| Some dn1, Some dn2 -> Some (OASISUnixPath.concat dn1 dn2)
in
let rec group_of_tree dn mp =
MapString.fold
(fun nm node acc ->
let cur =
match node with
| Node (Some (cs, bs, lib), children) ->
let current_dn = unix_directory dn lib in
Package (nm, cs, bs, lib, current_dn, group_of_tree current_dn children)
| Node (None, children) ->
Container (nm, group_of_tree dn children)
| Leaf (cs, bs, lib) ->
let current_dn = unix_directory dn lib in
Package (nm, cs, bs, lib, current_dn, [])
in
cur :: acc)
mp []
in
let group_mp =
List.fold_left
(fun mp ->
function
| Library (cs, bs, lib) ->
add (cs, bs, `Library lib) mp
| Object (cs, bs, obj) ->
add (cs, bs, `Object obj) mp
| _ ->
mp)
MapString.empty
pkg.sections
in
let groups = group_of_tree None group_mp in
let library_name_of_findlib_name =
lazy begin
(* Revert findlib_name_of_library_name. *)
MapString.fold
(fun k v mp -> MapString.add v k mp)
fndlb_name_of_lib_name
MapString.empty
end
in
let library_name_of_findlib_name fndlb_nm =
try
MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name)
with Not_found ->
raise (FindlibPackageNotFound fndlb_nm)
in
groups,
findlib_name_of_library_name,
library_name_of_findlib_name
let findlib_of_group =
function
| Container (fndlb_nm, _)
| Package (fndlb_nm, _, _, _, _, _) -> fndlb_nm
let root_of_group grp =
let rec root_lib_aux =
(* We do a DFS in the group. *)
function
| Container (_, children) ->
List.fold_left
(fun res grp ->
if res = None then
root_lib_aux grp
else
res)
None
children
| Package (_, cs, bs, lib, _, _) ->
Some (cs, bs, lib)
in
match root_lib_aux grp with
| Some res ->
res
| None ->
failwithf
(f_ "Unable to determine root library of findlib library '%s'")
(findlib_of_group grp)
end
module OASISFlag = struct
# 22 "src/oasis/OASISFlag.ml"
end
module OASISPackage = struct
# 22 "src/oasis/OASISPackage.ml"
end
module OASISSourceRepository = struct
# 22 "src/oasis/OASISSourceRepository.ml"
end
module OASISTest = struct
# 22 "src/oasis/OASISTest.ml"
end
module OASISDocument = struct
# 22 "src/oasis/OASISDocument.ml"
end
module OASISExec = struct
# 22 "src/oasis/OASISExec.ml"
open OASISGettext
open OASISUtils
open OASISMessage
(* TODO: I don't like this quote, it is there because $(rm) foo expands to
* 'rm -f' foo...
*)
let run ~ctxt ?f_exit_code ?(quote=true) cmd args =
let cmd =
if quote then
if Sys.os_type = "Win32" then
if String.contains cmd ' ' then
(* Double the 1st double quote... win32... sigh *)
"\""^(Filename.quote cmd)
else
cmd
else
Filename.quote cmd
else
cmd
in
let cmdline =
String.concat " " (cmd :: args)
in
info ~ctxt (f_ "Running command '%s'") cmdline;
match f_exit_code, Sys.command cmdline with
| None, 0 -> ()
| None, i ->
failwithf
(f_ "Command '%s' terminated with error code %d")
cmdline i
| Some f, i ->
f i
let run_read_output ~ctxt ?f_exit_code cmd args =
let fn =
Filename.temp_file "oasis-" ".txt"
in
try
begin