(* setup.ml generated for the first time by OASIS v0.3.0 *)

(* OASIS_START *)

(* DO NOT EDIT (digest: f28112438aa429142b5a71c24aa366d2) *)

(*

Regenerated by OASIS v0.3.0

Visit http://oasis.forge.ocamlcore.org for more information and

documentation about functions used in this file.

*)

module OASISGettext = struct

(* # 21 "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 OASISContext = struct

(* # 21 "src/oasis/OASISContext.ml" *)

open OASISGettext

type level =

[ `Debug

| `Info

| `Warning

| `Error]

type t =

{

quiet: bool;

info: bool;

debug: bool;

ignore_plugins: bool;

ignore_unknown_fields: bool;

printf: level -> string -> unit;

}

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;

}

let quiet =

{!default with quiet = true}

let args () =

["-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")]

end

module OASISString = struct

(* # 1 "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 = String.make (String.length s) 'X' in

for i = 0 to String.length s - 1 do

buf.[i] <- f s.[i]

done;

buf

end

module OASISUtils = struct

(* # 21 "src/oasis/OASISUtils.ml" *)

open OASISGettext

module MapString = Map.Make(String)

let map_string_of_assoc assoc =

List.fold_left

(fun acc (k, v) -> MapString.add k v acc)

MapString.empty

assoc

module SetString = Set.Make(String)

let set_string_add_list st lst =

List.fold_left

(fun acc e -> SetString.add e acc)

st

lst

let set_string_of_list =

set_string_add_list

SetString.empty

let compare_csl s1 s2 =

String.compare (String.lowercase s1) (String.lowercase s2)

module HashStringCsl =

Hashtbl.Make

(struct

type t = string

let equal s1 s2 =

(String.lowercase s1) = (String.lowercase s2)

let hash s =

Hashtbl.hash (String.lowercase s)

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

String.lowercase 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

end

module PropList = struct

(* # 21 "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

(* # 71 "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

String.lowercase

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

(* # 21 "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

(* # 21 "src/oasis/OASISVersion.ml" *)

open OASISGettext

type s = string

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)

let version_0_3_or_after t =

comparator_apply t (VGreaterEqual (string_of_version "0.3"))

end

module OASISLicense = struct

(* # 21 "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

(* # 21 "src/oasis/OASISExpr.ml" *)

open OASISGettext

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 OASISTypes = struct

(* # 21 "src/oasis/OASISTypes.ml" *)

type name = string

type package_name = string

type url = string

type unix_dirname = string

type unix_filename = string

type host_dirname = string

type host_filename = string

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

]