From 4fb5a19a573e9f666c01c3d7f84deaf69bfb4e1c Mon Sep 17 00:00:00 2001 From: Mindy Preston Date: Tue, 27 Sep 2016 05:47:40 -0500 Subject: [PATCH 1/4] add an implementation for `mem` in kv_ro module --- lib/KV_RO.ml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/lib/KV_RO.ml b/lib/KV_RO.ml index b3bf324..3b09f97 100644 --- a/lib/KV_RO.ml +++ b/lib/KV_RO.ml @@ -35,6 +35,12 @@ module Make(FS: FS with let id t = t + let mem t name = + FS.stat t name >>= function + | `Ok _ -> return @@ `Ok true + | `Error `Not_a_directory _ | `Error `No_directory_entry _ -> return @@ `Ok false + | `Error e -> return @@ `Error e + let read t name off len = FS.read t name off len >>= function @@ -46,4 +52,5 @@ module Make(FS: FS with >>= function | `Error _ -> return (`Error (Unknown_key name)) | `Ok stat -> return (`Ok (stat.FS.size)) + end From a5bf8afac8926f95cb997e569236ad196c0729d8 Mon Sep 17 00:00:00 2001 From: Mindy Preston Date: Tue, 27 Sep 2016 05:59:05 -0500 Subject: [PATCH 2/4] error can also be Failure from the underlying FS; add KV_RO.mli --- lib/KV_RO.ml | 26 +++++++++++++------------- lib/KV_RO.mli | 23 +++++++++++++++++++++++ 2 files changed, 36 insertions(+), 13 deletions(-) create mode 100644 lib/KV_RO.mli diff --git a/lib/KV_RO.ml b/lib/KV_RO.ml index 3b09f97..a79b3f9 100644 --- a/lib/KV_RO.ml +++ b/lib/KV_RO.ml @@ -26,7 +26,7 @@ module Make(FS: FS with type id = FS.t type page_aligned_buffer = FS.page_aligned_buffer - type error = Unknown_key of string + type error = Unknown_key of string | Failure of string let connect t = return (`Ok t) @@ -36,21 +36,21 @@ module Make(FS: FS with let id t = t let mem t name = - FS.stat t name >>= function - | `Ok _ -> return @@ `Ok true - | `Error `Not_a_directory _ | `Error `No_directory_entry _ -> return @@ `Ok false - | `Error e -> return @@ `Error e + FS.stat t name >|= function + | `Ok _ -> `Ok true + | `Error `Not_a_directory _ | `Error `No_directory_entry _ -> `Ok false + | `Error _ -> `Error (Failure "Failure in the underlying filesystem") let read t name off len = - FS.read t name off len - >>= function - | `Error _ -> return (`Error (Unknown_key name)) - | `Ok l -> return (`Ok l) + FS.read t name off len >|= function + | `Error `Not_a_directory _ | `Error `No_directory_entry _ -> `Error (Unknown_key name) + | `Error _ -> `Error (Failure name) + | `Ok l -> `Ok l let size t name = - FS.stat t name - >>= function - | `Error _ -> return (`Error (Unknown_key name)) - | `Ok stat -> return (`Ok (stat.FS.size)) + FS.stat t name >|= function + | `Error `Not_a_directory _ | `Error `No_directory_entry _ -> `Error (Unknown_key name) + | `Error _ -> `Error (Failure name) + | `Ok stat -> `Ok (stat.FS.size) end diff --git a/lib/KV_RO.mli b/lib/KV_RO.mli new file mode 100644 index 0000000..64141a6 --- /dev/null +++ b/lib/KV_RO.mli @@ -0,0 +1,23 @@ +(* + * Copyright (C) 2013 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +open V1 +open Lwt + +module Make(FS : FS with type 'a io = 'a Lwt.t) : sig + include KV_RO + val connect : FS.t -> [`Error of error | `Ok of t] FS.io +end From 0d5131e6612b4f364cc7547f11f6e97132f8da0e Mon Sep 17 00:00:00 2001 From: Mindy Preston Date: Tue, 27 Sep 2016 06:15:32 -0500 Subject: [PATCH 3/4] remove custom result; use rresult for bind --- _oasis | 4 +- _tags | 17 +- lib/KV_RO.mli | 1 - lib/META | 4 +- lib/boot_sector.ml | 17 +- lib/fat.mlpack | 3 +- lib/fs.ml | 16 +- lib/result.ml | 24 - lib/result.mli | 6 - lib_test/test.ml | 18 +- myocamlbuild.ml | 645 ++-- opam | 1 + setup.ml | 7121 ++++++++++++++++++++------------------------ 13 files changed, 3570 insertions(+), 4307 deletions(-) delete mode 100644 lib/result.ml delete mode 100644 lib/result.mli diff --git a/_oasis b/_oasis index 09cdd8b..3524060 100644 --- a/_oasis +++ b/_oasis @@ -12,8 +12,8 @@ Library fat CompiledObject: best Path: lib Findlibname: fat-filesystem - Modules: Fat_format, Boot_sector, Entry, Name, Path, Fs, Update, SectorMap, Result, MemoryIO, S, KV_RO - BuildDepends: cstruct, cstruct.ppx,re, re.str, mirage-types, lwt + Modules: Fat_format, Boot_sector, Entry, Name, Path, Fs, Update, SectorMap, MemoryIO, S, KV_RO + BuildDepends: cstruct, cstruct.ppx,re, re.str, mirage-types, lwt, result, rresult Executable fat CompiledObject: best diff --git a/_tags b/_tags index 85da242..47a04e4 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 6be1f2fc4591a45a457c1cf22f497bcf) +# DO NOT EDIT (digest: 10b5a5533bbbf4d3bdeb84b24d2fa168) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -24,7 +24,6 @@ true: annot, bin_annot "lib/fs.cmx": for-pack(Fat) "lib/update.cmx": for-pack(Fat) "lib/sectorMap.cmx": for-pack(Fat) -"lib/result.cmx": for-pack(Fat) "lib/memoryIO.cmx": for-pack(Fat) "lib/s.cmx": for-pack(Fat) "lib/KV_RO.cmx": for-pack(Fat) @@ -34,6 +33,8 @@ true: annot, bin_annot : pkg_mirage-types : pkg_re : pkg_re.str +: pkg_result +: pkg_rresult # Executable fat : pkg_cmdliner : pkg_cstruct @@ -45,6 +46,8 @@ true: annot, bin_annot : pkg_mirage-types : pkg_re : pkg_re.str +: pkg_result +: pkg_rresult : use_fat : pkg_cmdliner : pkg_cstruct @@ -56,6 +59,8 @@ true: annot, bin_annot : pkg_mirage-types : pkg_re : pkg_re.str +: pkg_result +: pkg_rresult : use_fat : custom # Executable shell @@ -68,6 +73,8 @@ true: annot, bin_annot : pkg_mirage-types : pkg_re : pkg_re.str +: pkg_result +: pkg_rresult : use_fat : pkg_cstruct : pkg_cstruct.ppx @@ -78,6 +85,8 @@ true: annot, bin_annot : pkg_mirage-types : pkg_re : pkg_re.str +: pkg_result +: pkg_rresult : use_fat : custom # Executable test @@ -92,6 +101,8 @@ true: annot, bin_annot : pkg_oUnit : pkg_re : pkg_re.str +: pkg_result +: pkg_rresult : use_fat : pkg_cstruct : pkg_cstruct.ppx @@ -104,6 +115,8 @@ true: annot, bin_annot : pkg_oUnit : pkg_re : pkg_re.str +: pkg_result +: pkg_rresult : use_fat : custom # OASIS_STOP diff --git a/lib/KV_RO.mli b/lib/KV_RO.mli index 64141a6..f60e036 100644 --- a/lib/KV_RO.mli +++ b/lib/KV_RO.mli @@ -15,7 +15,6 @@ *) open V1 -open Lwt module Make(FS : FS with type 'a io = 'a Lwt.t) : sig include KV_RO diff --git a/lib/META b/lib/META index 0c18571..0a711e3 100644 --- a/lib/META +++ b/lib/META @@ -1,8 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 01d8de93c6eb4a15a1a4509fc45eb076) +# DO NOT EDIT (digest: c15a0b94276d5cdc0b8c46005b010455) version = "0.11.0" description = "FAT filesystem manipulation" -requires = "cstruct cstruct.ppx re re.str mirage-types lwt" +requires = "cstruct cstruct.ppx re re.str mirage-types lwt result rresult" archive(byte) = "fat.cma" archive(byte, plugin) = "fat.cma" archive(native) = "fat.cmxa" diff --git a/lib/boot_sector.ml b/lib/boot_sector.ml index 777931a..7c1d386 100644 --- a/lib/boot_sector.ml +++ b/lib/boot_sector.ml @@ -14,8 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -open Result - type t = { oem_name: string; bytes_per_sector: int; (* usually 512 *) @@ -78,13 +76,14 @@ let marshal (buf: Cstruct.t) t = set_t_signature buf 0xaa55 let unmarshal (buf: Cstruct.t) : (t, string) result = + let open Rresult in ( if Cstruct.len buf < sizeof - then `Error (Printf.sprintf "boot sector too small: %d < %d" (Cstruct.len buf) sizeof) - else `Ok () ) >>= fun () -> + then Error (Printf.sprintf "boot sector too small: %d < %d" (Cstruct.len buf) sizeof) + else Ok () ) >>= fun () -> let signature = get_t_signature buf in ( if signature <> 0xaa55 - then `Error (Printf.sprintf "boot sector signature invalid: %04x <> %04x" signature 0xaa55) - else `Ok () ) >>= fun () -> + then Error (Printf.sprintf "boot sector signature invalid: %04x <> %04x" signature 0xaa55) + else Ok () ) >>= fun () -> let oem_name = Cstruct.to_string (get_t_oem_name buf) in let bytes_per_sector = get_t_bytes_per_sector buf in let sectors_per_cluster = get_t_sectors_per_cluster buf in @@ -95,7 +94,7 @@ let unmarshal (buf: Cstruct.t) : (t, string) result = let sectors_per_fat = get_t_sectors_per_fat buf in let hidden_preceeding_sectors = get_t_hidden_preceeding_sectors buf in let total_sectors_large = get_t_total_sectors_large buf in - `Ok { + Ok { oem_name; bytes_per_sector; sectors_per_cluster; reserved_sectors; number_of_fats; number_of_root_dir_entries; total_sectors = max (Int32.of_int total_sectors_small) total_sectors_large; @@ -147,8 +146,8 @@ let format_of_clusters number_of_clusters = exception Unknown_FAT_cluster_type let detect_format x = match format_of_clusters (clusters x) with - | None -> `Error "unknown cluster type" - | Some x -> `Ok x + | None -> Error "unknown cluster type" + | Some x -> Ok x let make size = let bytes_per_sector = 512 in diff --git a/lib/fat.mlpack b/lib/fat.mlpack index cb59bc0..e15f947 100644 --- a/lib/fat.mlpack +++ b/lib/fat.mlpack @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 2a18a52246061cc96029e574457a25ef) +# DO NOT EDIT (digest: 8ff44075ee1b4010187f5bd8c1b7d885) Fat_format Boot_sector Entry @@ -8,7 +8,6 @@ Path Fs Update SectorMap -Result MemoryIO S KV_RO diff --git a/lib/fs.ml b/lib/fs.ml index a019e69..ea22010 100644 --- a/lib/fs.ml +++ b/lib/fs.ml @@ -128,7 +128,7 @@ module Make (B: BLOCK_DEVICE return () let make size = - let open Result in + let open Rresult in let boot = Boot_sector.make size in Boot_sector.detect_format boot >>= fun format -> @@ -140,14 +140,14 @@ module Make (B: BLOCK_DEVICE Cstruct.set_uint8 root i 0 done; let fs = { boot = boot; format = format; fat = fat; root = root } in - `Ok fs + Ok fs let format t size = let device = t.device in (match make size with - | `Ok x -> return x - | `Error x -> fail (Failure x) + | Ok x -> return x + | Error x -> fail (Failure x) ) >>= fun fs -> let sector = alloc 512 in @@ -179,11 +179,11 @@ module Make (B: BLOCK_DEVICE let sector = Cstruct.sub page 0 info.B.sector_size in B.read device 0L [ sector ] >>|= fun () -> ( match Boot_sector.unmarshal sector with - | `Error _ -> return None - | `Ok boot -> + | Error _ -> return None + | Ok boot -> match Boot_sector.detect_format boot with - | `Error reason -> return None - | `Ok format -> + | Error reason -> return None + | Ok format -> read_sectors boot.Boot_sector.bytes_per_sector device (Boot_sector.sectors_of_fat boot) >>= fun fat -> read_sectors boot.Boot_sector.bytes_per_sector device (Boot_sector.sectors_of_root_dir boot) >>= fun root -> return (Some { boot; format; fat; root }) ) >>= fun fs -> diff --git a/lib/result.ml b/lib/result.ml deleted file mode 100644 index bd7785a..0000000 --- a/lib/result.ml +++ /dev/null @@ -1,24 +0,0 @@ -(* - * Copyright (C) 2011-2013 Citrix Systems Inc - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -type ('a, 'b) result = [ - | `Ok of 'a - | `Error of 'b -] - -let ( >>= ) x f = match x with - | `Error y -> `Error y - | `Ok z -> f z diff --git a/lib/result.mli b/lib/result.mli deleted file mode 100644 index 7412839..0000000 --- a/lib/result.mli +++ /dev/null @@ -1,6 +0,0 @@ -type ('a, 'b) result = [ - | `Ok of 'a - | `Error of 'b -] - -val ( >>= ): ('a, 'b) result -> ('a -> ('c, 'b) result) -> ('c, 'b) result diff --git a/lib_test/test.ml b/lib_test/test.ml index 5b36fb7..63b2c7d 100644 --- a/lib_test/test.ml +++ b/lib_test/test.ml @@ -98,12 +98,12 @@ let test_chains () = let open Boot_sector in read_sector "lib_test/bootsector.dat" >>= fun bytes -> let boot = match unmarshal bytes with - | `Error x -> failwith x - | `Ok x -> x in + | Error x -> failwith x + | Ok x -> x in let printer = function - | `Error e -> e - | `Ok x -> Fat_format.to_string x in - assert_equal ~printer (`Ok Fat_format.FAT16) (Boot_sector.detect_format boot); + | Error e -> e + | Ok x -> Fat_format.to_string x in + assert_equal ~printer (Ok Fat_format.FAT16) (Boot_sector.detect_format boot); read_whole_file "lib_test/root.dat" >>= fun bytes -> let all = Name.list bytes in read_whole_file "lib_test/fat.dat" >>= fun fat -> @@ -125,8 +125,8 @@ let test_parse_boot_sector () = let open Boot_sector in read_sector "lib_test/bootsector.dat" >>= fun bytes -> let x = match unmarshal bytes with - | `Error x -> failwith x - | `Ok x -> x in + | Error x -> failwith x + | Ok x -> x in let check x = assert_equal ~printer:(fun x -> x) "mkdosfs\000" x.oem_name; assert_equal ~printer:string_of_int 512 x.bytes_per_sector; @@ -145,8 +145,8 @@ let test_parse_boot_sector () = let buf = alloc sizeof in marshal buf x; let x = match unmarshal buf with - | `Error x -> failwith x - | `Ok x -> x in + | Error x -> failwith x + | Ok x -> x in check x; return () in Lwt_main.run t diff --git a/myocamlbuild.ml b/myocamlbuild.ml index ef2a461..237dbee 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,12 +1,19 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 77511168c6bae74056f2c3aa4f0eaea6) *) +(* DO NOT EDIT (digest: 1709d397c8499edc40835b386854ea54) *) 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 ns_ str = + str + + + let s_ str = + str + + + let f_ (str: ('a, 'b, 'c, 'd) format4) = + str let fn_ fmt1 fmt2 n = @@ -16,7 +23,10 @@ module OASISGettext = struct fmt2^^"" - let init = [] + let init = + [] + + end module OASISString = struct @@ -28,7 +38,7 @@ module OASISString = struct Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall - *) + *) let nsplitf str f = @@ -42,19 +52,19 @@ module OASISString = struct 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 + 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) @@ -62,18 +72,18 @@ module OASISString = struct 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 + 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 - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx + !str_idx - !what_idx let sub_start str len = @@ -96,19 +106,19 @@ module OASISString = struct 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 + 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 - ok := false; - incr str_idx - done; - if !what_idx = String.length what then - true - else - false + false let strip_starts_with ~what str = @@ -122,19 +132,19 @@ module OASISString = struct 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 + 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 - ok := false; - decr str_idx - done; - if !what_idx = -1 then - true - else - false + false let strip_ends_with ~what str = @@ -179,181 +189,19 @@ module OASISString = struct 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_ "" - - - 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 +module OASISExpr = struct +(* # 22 "src/oasis/OASISExpr.ml" *) -end -module OASISExpr = struct -(* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext - open OASISUtils type test = string + + type flag = string @@ -366,6 +214,7 @@ module OASISExpr = struct | ETest of test * string + type 'a choices = (t * 'a) list @@ -440,7 +289,7 @@ module OASISExpr = struct end -# 443 "myocamlbuild.ml" +# 292 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -451,103 +300,132 @@ module BaseEnvLight = struct type t = string MapString.t - let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" - let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = - let line = ref 1 in - let lexer st = - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - Genlex.make_lexer ["="] st_line - in - let rec read_file lxr mp = - match Stream.npeek 3 lxr with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; - read_file lxr (MapString.add nm value mp) - | [] -> mp - | _ -> - failwith - (Printf.sprintf "Malformed data file '%s' line %d" filename !line) - in - match stream with - | Some st -> read_file (lexer st) MapString.empty - | None -> - if Sys.file_exists filename then begin - let chn = open_in_bin filename in - let st = Stream.of_channel chn in - try - let mp = read_file (lexer st) MapString.empty in - close_in chn; mp - with e -> - close_in chn; raise e - end else if allow_empty then begin + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin MapString.empty - end else begin + end + else + begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end + let rec var_expand str env = - let buff = Buffer.create ((String.length str) * 2) in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = var_expand (MapString.find name env) env - let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst end -# 523 "myocamlbuild.ml" +# 397 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from - * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html + * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild * by N. Pouillard and others * - * Updated on 2016-06-02 + * Updated on 2009/02/28 * * Modified by Sylvain Le Gall - *) + *) open Ocamlbuild_plugin + type conf = + { no_automatic_syntax: bool; + } - type conf = {no_automatic_syntax: bool} - + (* these functions are not really officially exported *) + let run_and_read = + Ocamlbuild_pack.My_unix.run_and_read - let run_and_read = Ocamlbuild_pack.My_unix.run_and_read - - let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings + let blank_sep_strings = + Ocamlbuild_pack.Lexers.blank_sep_strings let exec_from_conf exec = let exec = - let env = BaseEnvLight.load ~allow_empty:true () in + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in try BaseEnvLight.var_get exec env with Not_found -> @@ -558,7 +436,7 @@ module MyOCamlbuildFindlib = struct if Sys.os_type = "Win32" then begin let buff = Buffer.create (String.length str) in (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. - *) + *) String.iter (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) str; @@ -567,8 +445,7 @@ module MyOCamlbuildFindlib = struct str end in - fix_win32 exec - + fix_win32 exec let split s ch = let buf = Buffer.create 13 in @@ -577,15 +454,15 @@ module MyOCamlbuildFindlib = struct x := (Buffer.contents buf) :: !x; Buffer.clear buf in - String.iter - (fun c -> - if c = ch then - flush () - else - Buffer.add_char buf c) - s; - flush (); - List.rev !x + String.iter + (fun c -> + if c = ch then + flush () + else + Buffer.add_char buf c) + s; + flush (); + List.rev !x let split_nl s = split s '\n' @@ -627,89 +504,85 @@ module MyOCamlbuildFindlib = struct let dispatch conf = function | After_options -> - (* By using Before_options one let command line options have an higher - * priority on the contrary using After_options will guarantee to have - * the higher priority override default commands by ocamlfind ones *) - Options.ocamlc := ocamlfind & A"ocamlc"; - Options.ocamlopt := ocamlfind & A"ocamlopt"; - Options.ocamldep := ocamlfind & A"ocamldep"; - Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop"; - Options.ocamlmklib := ocamlfind & A"ocamlmklib" + (* By using Before_options one let command line options have an higher + * priority on the contrary using After_options will guarantee to have + * the higher priority override default commands by ocamlfind ones *) + Options.ocamlc := ocamlfind & A"ocamlc"; + Options.ocamlopt := ocamlfind & A"ocamlopt"; + Options.ocamldep := ocamlfind & A"ocamldep"; + Options.ocamldoc := ocamlfind & A"ocamldoc"; + Options.ocamlmktop := ocamlfind & A"ocamlmktop"; + Options.ocamlmklib := ocamlfind & A"ocamlmklib" | After_rules -> - (* Avoid warnings for unused tag *) - flag ["tests"] N; - - (* When one link an OCaml library/binary/package, one should use - * -linkpkg *) - flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - - (* For each ocamlfind package one inject the -package option when - * compiling, computing dependencies, generating documentation and - * linking. *) - List.iter - begin fun pkg -> - let base_args = [A"-package"; A pkg] in - (* TODO: consider how to really choose camlp4o or camlp4r. *) - let syn_args = [A"-syntax"; A "camlp4o"] in - let (args, pargs) = - (* Heuristic to identify syntax extensions: whether they end in - ".syntax"; some might not. - *) - if not (conf.no_automatic_syntax) && - (Filename.check_suffix pkg "syntax" || - List.mem pkg well_known_syntax) then - (syn_args @ base_args, syn_args) - else - (base_args, []) - in - flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; - flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; - - (* TODO: Check if this is allowed for OCaml < 3.12.1 *) - flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; - flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; - end - (find_packages ()); - - (* Like -package but for extensions syntax. Morover -syntax is useless - * when linking. *) - List.iter begin fun syntax -> + (* When one link an OCaml library/binary/package, one should use + * -linkpkg *) + flag ["ocaml"; "link"; "program"] & A"-linkpkg"; + + if not (conf.no_automatic_syntax) then begin + (* For each ocamlfind package one inject the -package option when + * compiling, computing dependencies, generating documentation and + * linking. *) + List.iter + begin fun pkg -> + let base_args = [A"-package"; A pkg] in + (* TODO: consider how to really choose camlp4o or camlp4r. *) + let syn_args = [A"-syntax"; A "camlp4o"] in + let (args, pargs) = + (* Heuristic to identify syntax extensions: whether they end in + ".syntax"; some might not. + *) + if Filename.check_suffix pkg "syntax" || + List.mem pkg well_known_syntax then + (syn_args @ base_args, syn_args) + else + (base_args, []) + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + + (* TODO: Check if this is allowed for OCaml < 3.12.1 *) + flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; + flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; + end + (find_packages ()); + end; + + (* Like -package but for extensions syntax. Morover -syntax is useless + * when linking. *) + List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & - S[A"-syntax"; A syntax]; - end (find_syntaxes ()); - - (* The default "thread" tag is not compatible with ocamlfind. - * Indeed, the default rules add the "threads.cma" or "threads.cmxa" - * options when using this tag. When using the "-linkpkg" option with - * ocamlfind, this module will then be added twice on the command line. - * - * To solve this, one approach is to add the "-thread" option when using - * the "threads" package using the previous plugin. - *) - flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); - flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); - flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); - flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); - flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); - flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]); + S[A"-syntax"; A syntax]; + end (find_syntaxes ()); + + (* The default "thread" tag is not compatible with ocamlfind. + * Indeed, the default rules add the "threads.cma" or "threads.cmxa" + * options when using this tag. When using the "-linkpkg" option with + * ocamlfind, this module will then be added twice on the command line. + * + * To solve this, one approach is to add the "-thread" option when using + * the "threads" package using the previous plugin. + *) + flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); + flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); + flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); + flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); | _ -> - () + () end module MyOCamlbuildBase = struct @@ -721,6 +594,9 @@ module MyOCamlbuildBase = struct *) + + + open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler @@ -731,6 +607,9 @@ module MyOCamlbuildBase = struct type tag = string +(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + + type t = { lib_ocaml: (name * dir list * string list) list; @@ -743,7 +622,9 @@ module MyOCamlbuildBase = struct } -(* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + let env_filename = + Pathname.basename + BaseEnvLight.default_filename let dispatch_combine lst = @@ -762,7 +643,12 @@ module MyOCamlbuildBase = struct let dispatch t e = - let env = BaseEnvLight.load ~allow_empty:true () in + let env = + BaseEnvLight.load + ~filename:env_filename + ~allow_empty:true + () + in match e with | Before_options -> let no_trailing_dot s = @@ -826,19 +712,18 @@ module MyOCamlbuildBase = struct flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then - flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] - (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] + (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. This holds both for programs and for libraries. *) - dep ["link"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["link"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; - dep ["compile"; "ocaml"; tag_libstubs lib] - [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; + dep ["compile"; "ocaml"; tag_libstubs lib] + [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) @@ -878,7 +763,7 @@ module MyOCamlbuildBase = struct end -# 881 "myocamlbuild.ml" +# 766 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { @@ -893,6 +778,6 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 897 "myocamlbuild.ml" +# 782 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; diff --git a/opam b/opam index 1abf477..327aaa0 100644 --- a/opam +++ b/opam @@ -18,6 +18,7 @@ depends: [ "ocamlbuild" {build} "cstruct" {>= "2.0.0"} "ppx_tools" + "rresult" "lwt" {>= "2.4.3"} "mirage-types" {>= "2.6.1"} "mirage-block-unix" {>= "1.2.0"} diff --git a/setup.ml b/setup.ml index 69df29b..1d1dc49 100644 --- a/setup.ml +++ b/setup.ml @@ -1,9 +1,9 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 532b02af2801dfffb611f3a24bfac6da) *) +(* DO NOT EDIT (digest: 55d94bd6c76e89b6eb45e18174cb2502) *) (* - Regenerated by OASIS v0.4.7 + Regenerated by OASIS v0.4.6 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) @@ -11,9 +11,16 @@ 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 ns_ str = + str + + + let s_ str = + str + + + let f_ (str: ('a, 'b, 'c, 'd) format4) = + str let fn_ fmt1 fmt2 n = @@ -23,7 +30,90 @@ module OASISGettext = struct fmt2^^"" - let init = [] + let init = + [] + + +end + +module OASISContext = struct +(* # 22 "src/oasis/OASISContext.ml" *) + + + open OASISGettext + + + type level = + [ `Debug + | `Info + | `Warning + | `Error] + + + 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; + } + + + 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 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", + (* TODO: remove this chdir. *) + Arg.String (fun str -> Sys.chdir str), + s_ "dir Change directory before running."], + fun () -> {!default with ignore_plugins = !ignore_plugins} end module OASISString = struct @@ -35,7 +125,7 @@ module OASISString = struct Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall - *) + *) let nsplitf str f = @@ -49,19 +139,19 @@ module OASISString = struct 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 + 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) @@ -69,18 +159,18 @@ module OASISString = struct 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 + 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 - what_idx := 0; - incr str_idx - done; - if !what_idx <> String.length what then - raise Not_found - else - !str_idx - !what_idx + !str_idx - !what_idx let sub_start str len = @@ -103,19 +193,19 @@ module OASISString = struct 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 + 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 - ok := false; - incr str_idx - done; - if !what_idx = String.length what then - true - else - false + false let strip_starts_with ~what str = @@ -129,19 +219,19 @@ module OASISString = struct 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 + 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 - ok := false; - decr str_idx - done; - if !what_idx = -1 then - true - else - false + false let strip_ends_with ~what str = @@ -255,467 +345,77 @@ module OASISUtils = struct 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_ "" - - - 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; - } - - - 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) + 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 default = - ref - { - quiet = false; - info = false; - debug = false; - ignore_plugins = false; - ignore_unknown_fields = false; - printf = printf; - srcfs = new OASISFileSystem.host_fs(Sys.getcwd ()); - } + 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 quiet = - {!default with quiet = true} + 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 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"; + let is_varname str = + str = varname_of_string str - "-debug", - Arg.Unit (fun () -> default := {!default with debug = true}), - s_ " Output debug message"; + let failwithf fmt = Printf.ksprintf failwith fmt - "-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 @@ -736,27 +436,27 @@ module PropList = struct 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) + | 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 + (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 @@ -765,27 +465,27 @@ module PropList = struct Hashtbl.clear t -(* # 77 "src/oasis/PropList.ml" *) +(* # 78 "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; - } + { + 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; - } + { + name: name; + fields: (name, ('ctxt, 'extra) value) Hashtbl.t; + order: name Queue.t; + name_norm: string -> string; + } let create ?(case_insensitive=false) nm = { @@ -804,21 +504,21 @@ module PropList = struct 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 + 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 @@ -844,7 +544,7 @@ module PropList = struct let v = find t k in - f acc k v.extra v.help) + f acc k v.extra v.help) acc t.order @@ -862,20 +562,20 @@ module PropList = struct 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; - } + { + 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 + fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) @@ -914,33 +614,33 @@ module PropList = struct let x = match update with | Some f -> - begin - try - f ?context (get data) x - with Not_set _ -> - x - end + begin + try + f ?context (get data) x + with Not_set _ -> + x + end | None -> - x + x in - Hashtbl.replace - data - nm - (fun () -> v := Some x) + Hashtbl.replace + data + nm + (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> - f + f | None -> - fun ?context s -> - failwith - (Printf.sprintf - (f_ "Cannot parse field '%s' when setting value %S") - nm - s) + fun ?context s -> + failwith + (Printf.sprintf + (f_ "Cannot parse field '%s' when setting value %S") + nm + s) in (* Set data, from string *) @@ -952,9 +652,9 @@ module PropList = struct let print = match print with | Some f -> - f + f | None -> - fun _ -> raise (No_printer nm) + fun _ -> raise (No_printer nm) in (* Get data, as a string *) @@ -962,22 +662,22 @@ module PropList = struct print (get data) in - begin - match schema with - | Some t -> - Schema.add t nm sets gets extra help - | None -> - () - end; + 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; - } + { + set = set; + get = get; + sets = sets; + gets = gets; + help = help; + extra = extra; + } let fset data t ?context x = t.set data ?context x @@ -999,7 +699,7 @@ module PropList = struct let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in - fun data -> Field.fget data fld + fun data -> Field.fget data fld end end @@ -1021,13 +721,13 @@ module OASISMessage = struct | `Info -> ctxt.info | _ -> true in - Printf.ksprintf - (fun str -> - if cond then - begin - ctxt.printf lvl str - end) - fmt + Printf.ksprintf + (fun str -> + if cond then + begin + ctxt.printf lvl str + end) + fmt let debug ~ctxt fmt = @@ -1054,6 +754,12 @@ module OASISVersion = struct open OASISGettext + + + + type s = string + + type t = string @@ -1067,10 +773,20 @@ module OASISVersion = struct | 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 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 = @@ -1078,7 +794,7 @@ module OASISVersion = struct 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 @@ -1113,44 +829,45 @@ module OASISVersion = struct 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 + 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 + 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 + 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 - else begin - 0 - end let version_of_string str = str @@ -1159,12 +876,16 @@ module OASISVersion = struct let string_of_version t = t + let version_compare_string s1 s2 = + version_compare (version_of_string s1) (version_of_string s2) + + let chop t = try let pos = String.rindex t '.' in - String.sub t 0 pos + String.sub t 0 pos with Not_found -> t @@ -1172,19 +893,19 @@ module OASISVersion = struct let rec comparator_apply v op = match op with | VGreater cv -> - (version_compare v cv) > 0 + (version_compare v cv) > 0 | VGreaterEqual cv -> - (version_compare v cv) >= 0 + (version_compare v cv) >= 0 | VLesser cv -> - (version_compare v cv) < 0 + (version_compare v cv) < 0 | VLesserEqual cv -> - (version_compare v cv) <= 0 + (version_compare v cv) <= 0 | VEqual cv -> - (version_compare v cv) = 0 + (version_compare v cv) = 0 | VOr (op1, op2) -> - (comparator_apply v op1) || (comparator_apply v op2) + (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> - (comparator_apply v op1) && (comparator_apply v op2) + (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = @@ -1195,9 +916,9 @@ module OASISVersion = struct | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> - (string_of_comparator c1)^" || "^(string_of_comparator c2) + (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> - (string_of_comparator c1)^" && "^(string_of_comparator c2) + (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = @@ -1207,16 +928,28 @@ module OASISVersion = struct (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 rec comparator_ge v' = + let cmp v = version_compare v v' >= 0 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) + | VEqual v + | VGreaterEqual v + | VGreater v -> cmp v + | VLesserEqual _ + | VLesser _ -> false + | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 + | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 end @@ -1227,10 +960,15 @@ module OASISLicense = struct (** License for _oasis fields @author Sylvain Le Gall - *) + *) + + + type license = string + + type license_exception = string @@ -1240,6 +978,7 @@ module OASISLicense = struct | NoVersion + type license_dep_5_unit = { license: license; @@ -1248,6 +987,7 @@ module OASISLicense = struct } + type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list @@ -1259,17 +999,22 @@ module OASISLicense = struct | OtherLicense of string (* URL *) + end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) + + + open OASISGettext - open OASISUtils type test = string + + type flag = string @@ -1282,6 +1027,7 @@ module OASISExpr = struct | ETest of test * string + type 'a choices = (t * 'a) list @@ -1342,159 +1088,31 @@ module OASISExpr = struct | 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 + (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) - type t = Templater.t +end +module OASISText = struct +(* # 22 "src/oasis/OASISText.ml" *) - 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 + type elt = + | Para of string + | Verbatim of string + | BlankLine - let to_string t = t.Templater.origin + type t = elt list end @@ -1502,13 +1120,16 @@ 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 unix_filename = string + type host_dirname = string + type host_filename = string type prog = string type arg = string type args = string list @@ -1525,16 +1146,19 @@ module OASISTypes = struct | 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 @@ -1547,29 +1171,30 @@ module OASISTypes = struct | OtherVCS of url + type plugin_kind = - [ `Configure - | `Build - | `Doc - | `Test - | `Install - | `Extra - ] + [ `Configure + | `Build + | `Doc + | `Test + | `Install + | `Extra + ] type plugin_data_purpose = - [ `Configure - | `Build - | `Install - | `Clean - | `Distclean - | `Install - | `Uninstall - | `Test - | `Doc - | `Extra - | `Other of string - ] + [ `Configure + | `Build + | `Install + | `Clean + | `Distclean + | `Install + | `Uninstall + | `Test + | `Doc + | `Extra + | `Other of string + ] type 'a plugin = 'a * name * OASISVersion.t option @@ -1581,128 +1206,129 @@ module OASISTypes = struct type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list +(* # 115 "src/oasis/OASISTypes.ml" *) + + type 'a conditional = 'a OASISExpr.choices type custom = - { - pre_command: (command_line option) conditional; - post_command: (command_line option) conditional; - } + { + 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; - } + { + 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; - } + { + 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_c_sources: unix_filename list; + bs_data_files: (unix_filename * unix_filename option) 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; - } + { + 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_containers: findlib_name list; + } type object_ = - { - obj_modules: string list; - obj_findlib_fullname: findlib_name list option; - obj_findlib_directory: unix_dirname option; - } + { + obj_modules: string list; + obj_findlib_fullname: findlib_name list option; + } type executable = - { - exec_custom: bool; - exec_main_is: unix_filename; - } + { + exec_custom: bool; + exec_main_is: unix_filename; + } type flag = - { - flag_description: string option; - flag_default: bool conditional; - } + { + 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; - } + { + 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; - } + { + 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. *) + | HTML of unix_filename | DocText | PDF | PostScript - | Info of unix_filename (* TODO: source filename. *) + | Info of unix_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; - } + { + doc_type: [`Doc] plugin; + doc_custom: custom; + doc_build: bool conditional; + doc_install: bool conditional; + doc_install_dir: unix_filename; + doc_title: string; + doc_authors: string list; + doc_abstract: string option; + doc_format: doc_format; + doc_data_files: (unix_filename * unix_filename option) list; + doc_build_tools: tool list; + } type section = @@ -1715,51 +1341,50 @@ module OASISTypes = struct | Doc of common_section * doc + type section_kind = - [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + [ `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; - } + { + 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; + copyrights: string list; + maintainers: string list; + authors: string list; + homepage: url option; + synopsis: string; + description: OASISText.t option; + 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; + sections: section list; + plugins: [`Extra] plugin list; + disable_oasis_section: unix_filename list; + schema_data: PropList.Data.t; + plugin_data: plugin_data; + } end @@ -1775,19 +1400,19 @@ module OASISFeatures = struct module MapPlugin = Map.Make (struct - type t = plugin_kind * name - let compare = Pervasives.compare - end) + 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; - } + { + 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 = { @@ -1805,10 +1430,10 @@ module OASISFeatures = struct 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} + 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 @@ -1817,17 +1442,17 @@ module OASISFeatures = struct Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" - (OASISVersion.string_of_version (t:t).oasis_version) + (OASISVersion.string_of_version 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 -> "")) + (match ver_opt with + | Some v -> + " "^(OASISVersion.string_of_version v) + | None -> "")) :: acc) t.plugin_versions [])) end @@ -1842,24 +1467,24 @@ module OASISFeatures = struct let string_of_stage = function - | Alpha -> "alpha" - | Beta -> "beta" + | Alpha -> "alpha" + | Beta -> "beta" let field_of_stage = function - | Alpha -> "AlphaFeatures" - | Beta -> "BetaFeatures" + | 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; - } + { + name: string; + plugin: all_plugin option; + publication: publication; + description: unit -> string; + } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 @@ -1873,35 +1498,35 @@ module OASISFeatures = struct let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" - (t:t).name + t.name (match t.plugin with - | None -> "" - | Some (_, nm, _) -> nm) + | None -> "" + | Some (_, nm, _) -> nm) (match t.publication with - | InDev stage -> string_of_stage stage - | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) + | 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 + let has_feature = List.mem 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 + match 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 @@ -1911,128 +1536,132 @@ module OASISFeatures = struct OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in - Printf.ksprintf - (fun str -> if version_is_good then None else Some str) - fmt + 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 = + | _, _, 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 - 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 + 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 = + | 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 - 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 + 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, 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 + | 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 + | None -> () + | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with - | None -> true - | Some _ -> false + | None -> true + | Some str -> false let package_test t pkg = @@ -2052,8 +1681,8 @@ module OASISFeatures = struct description = description; } in - Hashtbl.add all_features name t; - t + Hashtbl.add all_features name t; + t let get_stage name = @@ -2082,14 +1711,14 @@ module OASISFeatures = struct create "flag_docs" (since_version "0.3") (fun () -> - s_ "Make building docs require '-docs' flag at configure.") + s_ "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.") + s_ "Running tests require '-tests' flag at configure.") let pack = @@ -2114,13 +1743,13 @@ module OASISFeatures = struct let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> - s_ "Compile the setup.ml and speed-up actions done with it.") + s_ "It compiles 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.") + s_ "Allows the OASIS section comments and digest to be omitted in \ + generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha @@ -2128,22 +1757,139 @@ module OASISFeatures = struct 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).") +end - let findlib_directory = - create "findlib_directory" beta - (fun () -> - s_ "Allow to install findlib libraries in sub-directories of the target \ - findlib directory.") +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 + + + module Unix = OASISUnixPath + + + let make = + function + | [] -> + invalid_arg "OASISHostPath.make" + | hd :: tl -> + List.fold_left Filename.concat hd tl + + + let of_unix ufn = + if Sys.os_type = "Unix" then + ufn + else + 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 '/')) - 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 @@ -2156,19 +1902,19 @@ module OASISSection = struct let section_kind_common = function | Library (cs, _, _) -> - `Library, cs + `Library, cs | Object (cs, _, _) -> - `Object, cs + `Object, cs | Executable (cs, _, _) -> - `Executable, cs + `Executable, cs | Flag (cs, _) -> - `Flag, cs + `Flag, cs | SrcRepo (cs, _) -> - `SrcRepo, cs + `SrcRepo, cs | Test (cs, _) -> - `Test, cs + `Test, cs | Doc (cs, _) -> - `Doc, cs + `Doc, cs let section_common sct = @@ -2187,28 +1933,27 @@ module OASISSection = struct (** 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" + k, cs.cs_name let string_of_section sct = - let k, nm = section_id sct in - (string_of_section_kind k)^" "^nm + let k, nm = + section_id sct + in + (match k with + | `Library -> "library" + | `Object -> "object" + | `Executable -> "executable" + | `Flag -> "flag" + | `SrcRepo -> "src repository" + | `Test -> "test" + | `Doc -> "doc") + ^" "^nm let section_find id scts = @@ -2243,32 +1988,6 @@ 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 @@ -2292,16 +2011,16 @@ module OASISExecutable = struct | Byte -> false in - OASISUnixPath.concat - dir - (cs.cs_name^(suffix_program ())), + 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 + 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 @@ -2311,57 +2030,99 @@ module OASISLibrary = struct open OASISTypes + open OASISUtils open OASISGettext + open OASISSection + + + (* Look for a module file, considering capitalization or not. *) + let find_module source_file_exists bs modul = + let possible_base_fn = + List.map + (OASISUnixPath.concat bs.bs_path) + [modul; + OASISUnixPath.uncapitalize_file modul; + OASISUnixPath.capitalize_file modul] + in + (* TODO: we should be able to be able to determine the source for every + * files. Hence we should introduce a Module(source: fn) for the fields + * Modules and InternalModules + *) + List.fold_left + (fun acc base_fn -> + match acc with + | `No_sources _ -> + begin + let file_found = + List.fold_left + (fun acc ext -> + if source_file_exists (base_fn^ext) then + (base_fn^ext) :: acc + else + acc) + [] + [".ml"; ".mli"; ".mll"; ".mly"] + in + match file_found with + | [] -> + acc + | lst -> + `Sources (base_fn, lst) + end + | `Sources _ -> + acc) + (`No_sources possible_base_fn) + possible_base_fn - 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) + match find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + 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) = + ~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 + match find_module source_file_exists bs modul with + | `Sources (base_fn, [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 -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in library %s") + modul cs.cs_name; + 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) + match find_module nm with + | None -> acc + | Some base_fns -> + List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in @@ -2370,21 +2131,21 @@ module OASISLibrary = struct let cmxs = let should_be_built = match bs.bs_compiled_object with - | Native -> true - | Best -> is_native - | Byte -> false + | Native -> true + | Best -> is_native + | Byte -> false in - if should_be_built then - if lib.lib_pack then - find_modules - [cs.cs_name] - "cmx" + 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 - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" - else - [] + [] in let acc_nopath = @@ -2399,12 +2160,15 @@ module OASISLibrary = struct else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map - (List.fold_left - (fun accu s -> + begin + List.fold_left + begin fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in - List.map ((^) base) sufx @ accu) - []) + List.map ((^) base) sufx @ accu + end + [] + end (find_modules lib.lib_modules "cmi") in @@ -2427,35 +2191,38 @@ module OASISLibrary = struct [cs.cs_name^".cmxs"] :: acc else acc) in - [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc + [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 + 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 + if bs.bs_c_sources <> [] then + begin + ["lib"^cs.cs_name^"_stubs"^ext_lib] + :: + ["dll"^cs.cs_name^"_stubs"^ext_dll] + :: acc_nopath - end else begin + end + else 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) + (* All the files generated *) + List.rev_append + (List.rev_map + (List.rev_map + (OASISUnixPath.concat bs.bs_path)) + acc_nopath) + (headers @ cmxs) end @@ -2468,64 +2235,62 @@ module OASISObject = struct 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) + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name; + acc) [] obj.obj_modules let generated_unix_files - ~ctxt - ~is_native - ~source_file_exists - (cs, bs, obj) = + ~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 + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, _) -> [base_fn ^ ext] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name ; + 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) + 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) + [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 :: []) + 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 @@ -2537,6 +2302,7 @@ module OASISFindlib = struct open OASISTypes open OASISUtils open OASISGettext + open OASISSection type library_name = name @@ -2554,13 +2320,12 @@ module OASISFindlib = struct 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_] + build_section * + [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data @@ -2578,53 +2343,53 @@ module OASISFindlib = struct let name = String.concat "." (lib.lib_findlib_containers @ [name]) in - name + 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 -> + 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 - lib_name - (`Solved fndlb_parts) + obj_name + (`Solved findlib_full_name) 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 + end - | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> - mp) - MapString.empty - pkg.sections + | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> + mp) + MapString.empty + pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) @@ -2636,40 +2401,40 @@ module OASISFindlib = struct 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 + 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 + (* Solved initialy, no need to go further *) + mp | `Unsolved _ -> - let _, mp = solve SetString.empty mp lib_name "" in - mp) + let _, mp = solve SetString.empty mp lib_name "" 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 + MapString.map + (function + | `Solved fndlb_nm -> fndlb_nm + | `Unsolved _ -> assert false) + mp in (* Convert an internal library name to a findlib name. *) @@ -2681,89 +2446,75 @@ module OASISFindlib = struct 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 + 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 + 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 + (* 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) + 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 + (* 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 (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> - Node (data_opt, add_children tl children) + Node (data_opt, add_children tl children) end and new_node = function | [] -> - Leaf sct + 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 + Node (None, MapString.add hd (new_node tl) MapString.empty) 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) + add_children (OASISString.nsplit fndlb_fullname '.') mp in - let rec group_of_tree dn mp = + let rec group_of_tree 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, []) + | Node (Some (cs, bs, lib), children) -> + Package (nm, cs, bs, lib, group_of_tree children) + | Node (None, children) -> + Container (nm, group_of_tree children) + | Leaf (cs, bs, lib) -> + Package (nm, cs, bs, lib, []) in - cur :: acc) + cur :: acc) mp [] in @@ -2772,16 +2523,18 @@ module OASISFindlib = struct (fun mp -> function | Library (cs, bs, lib) -> - add (cs, bs, `Library lib) mp + add (cs, bs, `Library lib) mp | Object (cs, bs, obj) -> - add (cs, bs, `Object obj) mp + add (cs, bs, `Object obj) mp | _ -> - mp) + mp) MapString.empty pkg.sections in - let groups = group_of_tree None group_mp in + let groups = + group_of_tree group_mp + in let library_name_of_findlib_name = lazy begin @@ -2799,15 +2552,15 @@ module OASISFindlib = struct raise (FindlibPackageNotFound fndlb_nm) in - groups, - findlib_name_of_library_name, - library_name_of_findlib_name + groups, + findlib_name_of_library_name, + library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) - | Package (fndlb_nm, _, _, _, _, _) -> fndlb_nm + | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = @@ -2815,24 +2568,24 @@ module OASISFindlib = struct (* 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) + 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) + 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 @@ -2878,7 +2631,7 @@ module OASISExec = struct (* 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 @@ -2896,57 +2649,57 @@ module OASISExec = struct 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 + 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 - let () = - run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) - in - let chn = - open_in fn - in - let routput = - ref [] - in + try begin - try - while true do - routput := (input_line chn) :: !routput - done - with End_of_file -> - () - end; - close_in chn; - Sys.remove fn; - List.rev !routput - end - with e -> - (try Sys.remove fn with _ -> ()); - raise e + let () = + run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) + in + let chn = + open_in fn + in + let routput = + ref [] + in + begin + try + while true do + routput := (input_line chn) :: !routput + done + with End_of_file -> + () + end; + close_in chn; + Sys.remove fn; + List.rev !routput + end + with e -> + (try Sys.remove fn with _ -> ()); + raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> - fst + fst | lst -> - failwithf - (f_ "Command return unexpected output %S") - (String.concat "\n" lst) + failwithf + (f_ "Command return unexpected output %S") + (String.concat "\n" lst) end module OASISFileUtil = struct @@ -2959,15 +2712,15 @@ module OASISFileUtil = struct let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in - if Sys.file_exists dirname then - if basename = Filename.current_dir_name then - true + if Sys.file_exists dirname then + if basename = Filename.current_dir_name then + true + else + List.mem + basename + (Array.to_list (Sys.readdir dirname)) else - List.mem - basename - (Array.to_list (Sys.readdir dirname)) - else - false + false let find_file ?(case_sensitive=true) paths exts = @@ -2986,16 +2739,16 @@ module OASISFileUtil = struct let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> - let acc = - (List.map - (fun (a, b) -> Filename.concat a b) - (p1 * p2)) - in - combined_paths (acc :: tl) + let acc = + (List.map + (fun (a, b) -> Filename.concat a b) + (p1 * p2)) + in + combined_paths (acc :: tl) | [e] -> - e + e | [] -> - [] + [] in let alternatives = @@ -3007,46 +2760,46 @@ module OASISFileUtil = struct p ^ e) ((combined_paths paths) * exts) in - List.find (fun file -> - (if case_sensitive then - file_exists_case file - else - Sys.file_exists file) - && not (Sys.is_directory file) - ) alternatives + List.find (fun file -> + (if case_sensitive then + file_exists_case file + else + Sys.file_exists file) + && not (Sys.is_directory file) + ) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> - ';' + ';' | _ -> - ':' + ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> - "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) + "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> - [""] + [""] in - find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true - *) + *) let ln = String.length dn in - if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then - fix_dir (String.sub dn 0 (ln - 1)) - else - dn + if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then + fix_dir (String.sub dn 0 (ln - 1)) + else + dn let q = Filename.quote @@ -3057,24 +2810,24 @@ module OASISFileUtil = struct if recurse then match Sys.os_type with | "Win32" -> - OASISExec.run ~ctxt - "xcopy" [q src; q tgt; "/E"] + OASISExec.run ~ctxt + "xcopy" [q src; q tgt; "/E"] | _ -> - OASISExec.run ~ctxt - "cp" ["-r"; q src; q tgt] + OASISExec.run ~ctxt + "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with - | "Win32" -> "copy" - | _ -> "cp") + | "Win32" -> "copy" + | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with - | "Win32" -> "md" - | _ -> "mkdir") + | "Win32" -> "md" + | _ -> "mkdir") [q tgt] @@ -3082,32 +2835,32 @@ module OASISFileUtil = struct let tgt = fix_dir tgt in - if Sys.file_exists tgt then - begin - if not (Sys.is_directory tgt) then - OASISUtils.failwithf - (f_ "Cannot create directory '%s', a file of the same name already \ - exists") - tgt - end - else - begin - mkdir_parent ~ctxt f (Filename.dirname tgt); - if not (Sys.file_exists tgt) then - begin - f tgt; - mkdir ~ctxt tgt - end - end + if Sys.file_exists tgt then + begin + if not (Sys.is_directory tgt) then + OASISUtils.failwithf + (f_ "Cannot create directory '%s', a file of the same name already \ + exists") + tgt + end + else + begin + mkdir_parent ~ctxt f (Filename.dirname tgt); + if not (Sys.file_exists tgt) then + begin + f tgt; + mkdir ~ctxt tgt + end + end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> - OASISExec.run ~ctxt "rd" [q tgt] + OASISExec.run ~ctxt "rd" [q tgt] | _ -> - OASISExec.run ~ctxt "rm" ["-r"; q tgt] + OASISExec.run ~ctxt "rm" ["-r"; q tgt] end else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") @@ -3116,51 +2869,51 @@ module OASISFileUtil = struct let glob ~ctxt fn = - let basename = - Filename.basename fn - in - if String.length basename >= 2 && - basename.[0] = '*' && - basename.[1] = '.' then - begin - let ext_len = - (String.length basename) - 2 - in - let ext = - String.sub basename 2 ext_len - in - let dirname = - Filename.dirname fn - in - Array.fold_left - (fun acc fn -> - try - let fn_ext = - String.sub - fn - ((String.length fn) - ext_len) - ext_len - in - if fn_ext = ext then - (Filename.concat dirname fn) :: acc - else - acc - with Invalid_argument _ -> - acc) - [] - (Sys.readdir dirname) - end - else - begin - if file_exists_case fn then - [fn] - else - [] - end + let basename = + Filename.basename fn + in + if String.length basename >= 2 && + basename.[0] = '*' && + basename.[1] = '.' then + begin + let ext_len = + (String.length basename) - 2 + in + let ext = + String.sub basename 2 ext_len + in + let dirname = + Filename.dirname fn + in + Array.fold_left + (fun acc fn -> + try + let fn_ext = + String.sub + fn + ((String.length fn) - ext_len) + ext_len + in + if fn_ext = ext then + (Filename.concat dirname fn) :: acc + else + acc + with Invalid_argument _ -> + acc) + [] + (Sys.readdir dirname) + end + else + begin + if file_exists_case fn then + [fn] + else + [] + end end -# 3163 "setup.ml" +# 2916 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) @@ -3171,76 +2924,101 @@ module BaseEnvLight = struct type t = string MapString.t - let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" + let default_filename = + Filename.concat + (Sys.getcwd ()) + "setup.data" - let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = - let line = ref 1 in - let lexer st = - let st_line = - Stream.from - (fun _ -> - try - match Stream.next st with - | '\n' -> incr line; Some '\n' - | c -> Some c - with Stream.Failure -> None) - in - Genlex.make_lexer ["="] st_line - in - let rec read_file lxr mp = - match Stream.npeek 3 lxr with - | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> - Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; - read_file lxr (MapString.add nm value mp) - | [] -> mp - | _ -> - failwith - (Printf.sprintf "Malformed data file '%s' line %d" filename !line) - in - match stream with - | Some st -> read_file (lexer st) MapString.empty - | None -> - if Sys.file_exists filename then begin - let chn = open_in_bin filename in - let st = Stream.of_channel chn in - try - let mp = read_file (lexer st) MapString.empty in - close_in chn; mp - with e -> - close_in chn; raise e - end else if allow_empty then begin + let load ?(allow_empty=false) ?(filename=default_filename) () = + if Sys.file_exists filename then + begin + let chn = + open_in_bin filename + in + let st = + Stream.of_channel chn + in + let line = + ref 1 + in + let st_line = + Stream.from + (fun _ -> + try + match Stream.next st with + | '\n' -> incr line; Some '\n' + | c -> Some c + with Stream.Failure -> None) + in + let lexer = + Genlex.make_lexer ["="] st_line + in + let rec read_file mp = + match Stream.npeek 3 lexer with + | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> + Stream.junk lexer; + Stream.junk lexer; + Stream.junk lexer; + read_file (MapString.add nm value mp) + | [] -> + mp + | _ -> + failwith + (Printf.sprintf + "Malformed data file '%s' line %d" + filename !line) + in + let mp = + read_file MapString.empty + in + close_in chn; + mp + end + else if allow_empty then + begin MapString.empty - end else begin + end + else + begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end + let rec var_expand str env = - let buff = Buffer.create ((String.length str) * 2) in - Buffer.add_substitute - buff - (fun var -> - try - var_expand (MapString.find var env) env - with Not_found -> - failwith - (Printf.sprintf - "No variable %s defined when trying to expand %S." - var - str)) - str; - Buffer.contents buff - - - let var_get name env = var_expand (MapString.find name env) env - let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + var_expand (MapString.find var env) env + with Not_found -> + failwith + (Printf.sprintf + "No variable %s defined when trying to expand %S." + var + str)) + str; + Buffer.contents buff + + + let var_get name env = + var_expand (MapString.find name env) env + + + let var_choose lst env = + OASISExpr.choose + (fun nm -> var_get nm env) + lst end -# 3243 "setup.ml" +# 3021 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) @@ -3261,7 +3039,7 @@ module BaseMessage = struct (** Message to user, overrid for Base @author Sylvain Le Gall - *) + *) open OASISMessage open BaseContext @@ -3284,7 +3062,6 @@ module BaseEnv = struct open OASISGettext open OASISUtils - open OASISContext open PropList @@ -3307,80 +3084,84 @@ module BaseEnv = struct type definition_t = - { - hide: bool; - dump: bool; - cli: cli_handle_t; - arg_help: string option; - group: string option; - } + { + hide: bool; + dump: bool; + cli: cli_handle_t; + arg_help: string option; + group: string option; + } - let schema = Schema.create "environment" + let schema = + Schema.create "environment" (* Environment data *) - let env = Data.create () + let env = + Data.create () (* Environment data from file *) - let env_from_file = ref MapString.empty + let env_from_file = + ref MapString.empty (* Lexer for var *) - let var_lxr = Genlex.make_lexer [] + let var_lxr = + Genlex.make_lexer [] - let rec var_expand str = - let buff = - Buffer.create ((String.length str) * 2) - in - Buffer.add_substitute - buff - (fun var -> - try - (* TODO: this is a quick hack to allow calling Test.Command - * without defining executable name really. I.e. if there is - * an exec Executable toto, then $(toto) should be replace - * by its real name. It is however useful to have this function - * for other variable that depend on the host and should be - * written better than that. - *) - let st = - var_lxr (Stream.of_string var) - in - match Stream.npeek 3 st with - | [Genlex.Ident "utoh"; Genlex.Ident nm] -> - OASISHostPath.of_unix (var_get nm) - | [Genlex.Ident "utoh"; Genlex.String s] -> - OASISHostPath.of_unix s - | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> - String.escaped (var_get nm) - | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> - String.escaped s - | [Genlex.Ident nm] -> - var_get nm - | _ -> - failwithf - (f_ "Unknown expression '%s' in variable expansion of %s.") - var - str - with - | Unknown_field (_, _) -> - failwithf - (f_ "No variable %s defined when trying to expand %S.") - var - str - | Stream.Error e -> - failwithf - (f_ "Syntax error when parsing '%s' when trying to \ - expand %S: %s") - var - str - e) - str; - Buffer.contents buff - + let rec var_expand str = + let buff = + Buffer.create ((String.length str) * 2) + in + Buffer.add_substitute + buff + (fun var -> + try + (* TODO: this is a quick hack to allow calling Test.Command + * without defining executable name really. I.e. if there is + * an exec Executable toto, then $(toto) should be replace + * by its real name. It is however useful to have this function + * for other variable that depend on the host and should be + * written better than that. + *) + let st = + var_lxr (Stream.of_string var) + in + match Stream.npeek 3 st with + | [Genlex.Ident "utoh"; Genlex.Ident nm] -> + OASISHostPath.of_unix (var_get nm) + | [Genlex.Ident "utoh"; Genlex.String s] -> + OASISHostPath.of_unix s + | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> + String.escaped (var_get nm) + | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> + String.escaped s + | [Genlex.Ident nm] -> + var_get nm + | _ -> + failwithf + (f_ "Unknown expression '%s' in variable expansion of %s.") + var + str + with + | Unknown_field (_, _) -> + failwithf + (f_ "No variable %s defined when trying to expand %S.") + var + str + | Stream.Error e -> + failwithf + (f_ "Syntax error when parsing '%s' when trying to \ + expand %S: %s") + var + str + e) + str; + Buffer.contents buff + and var_get name = let vl = @@ -3394,7 +3175,7 @@ module BaseEnv = struct raise e end in - var_expand vl + var_expand vl let var_choose ?printer ?name lst = @@ -3409,24 +3190,24 @@ module BaseEnv = struct let buff = Buffer.create (String.length vl) in - String.iter - (function - | '$' -> Buffer.add_string buff "\\$" - | c -> Buffer.add_char buff c) - vl; - Buffer.contents buff + String.iter + (function + | '$' -> Buffer.add_string buff "\\$" + | c -> Buffer.add_char buff c) + vl; + Buffer.contents buff let var_define - ?(hide=false) - ?(dump=true) - ?short_desc - ?(cli=CLINone) - ?arg_help - ?group - name (* TODO: type constraint on the fact that name must be a valid OCaml - id *) - dflt = + ?(hide=false) + ?(dump=true) + ?short_desc + ?(cli=CLINone) + ?arg_help + ?group + name (* TODO: type constraint on the fact that name must be a valid OCaml + id *) + dflt = let default = [ @@ -3447,22 +3228,22 @@ module BaseEnv = struct in (* Try to find a value that can be defined - *) + *) let var_get_low lst = let errors, res = List.fold_left - (fun (errors, res) (_, v) -> + (fun (errors, res) (o, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> - errors, res + errors, res | Failure rsn -> - (rsn :: errors), res + (rsn :: errors), res | e -> - (Printexc.to_string e) :: errors, res + (Printexc.to_string e) :: errors, res end else errors, res) @@ -3472,13 +3253,13 @@ module BaseEnv = struct Pervasives.compare o2 o1) lst) in - match res, errors with - | Some v, _ -> - v - | None, [] -> - raise (Not_set (name, None)) - | None, lst -> - raise (Not_set (name, Some (String.concat (s_ ", ") lst))) + match res, errors with + | Some v, _ -> + v + | None, [] -> + raise (Not_set (name, None)) + | None, lst -> + raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = @@ -3494,24 +3275,24 @@ module BaseEnv = struct ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default - ~update:(fun ?context:_ x old_x -> x @ old_x) + ~update:(fun ?context x old_x -> x @ old_x) ?help extra in - fun () -> - var_expand (var_get_low (var_get_lst env)) + fun () -> + var_expand (var_get_low (var_get_lst env)) let var_redefine - ?hide - ?dump - ?short_desc - ?cli - ?arg_help - ?group - name - dflt = + ?hide + ?dump + ?short_desc + ?cli + ?arg_help + ?group + name + dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) @@ -3532,7 +3313,7 @@ module BaseEnv = struct end - let var_ignore (_: unit -> string) = () + let var_ignore (e: unit -> string) = () let print_hidden = @@ -3557,34 +3338,12 @@ module BaseEnv = struct schema) - let default_filename = in_srcdir "setup.data" - - - let load ~ctxt ?(allow_empty=false) ?(filename=default_filename) () = - let open OASISFileSystem in - env_from_file := - let repr_filename = ctxt.srcfs#string_of_filename filename in - if ctxt.srcfs#file_exists filename then begin - let buf = Buffer.create 13 in - defer_close - (ctxt.srcfs#open_in ~mode:binary_in filename) - (read_all buf); - defer_close - (ctxt.srcfs#open_in ~mode:binary_in filename) - (fun rdr -> - OASISMessage.info ~ctxt "Loading environment from %S." repr_filename; - BaseEnvLight.load ~allow_empty - ~filename:(repr_filename) - ~stream:(stream_of_reader rdr) - ()) - end else if allow_empty then begin - BaseEnvLight.MapString.empty - end else begin - failwith - (Printf.sprintf - (f_ "Unable to load environment, the file '%s' doesn't exist.") - repr_filename) - end + let default_filename = + BaseEnvLight.default_filename + + + let load ?allow_empty ?filename () = + env_from_file := BaseEnvLight.load ?allow_empty ?filename () let unload () = @@ -3592,32 +3351,40 @@ module BaseEnv = struct Data.clear env - let dump ~ctxt ?(filename=default_filename) () = - let open OASISFileSystem in - defer_close - (ctxt.OASISContext.srcfs#open_out ~mode:binary_out filename) - (fun wrtr -> - let buf = Buffer.create 63 in - let output nm value = - Buffer.add_string buf (Printf.sprintf "%s=%S\n" nm value) - in - let mp_todo = - (* Dump data from schema *) - Schema.fold - (fun mp_todo nm def _ -> - if def.dump then begin - try - output nm (Schema.get schema env nm) - with Not_set _ -> - () - end; - MapString.remove nm mp_todo) - !env_from_file - schema - in - (* Dump data defined outside of schema *) - MapString.iter output mp_todo; - wrtr#output buf) + let dump ?(filename=default_filename) () = + let chn = + open_out_bin filename + in + let output nm value = + Printf.fprintf chn "%s=%S\n" nm value + in + let mp_todo = + (* Dump data from schema *) + Schema.fold + (fun mp_todo nm def _ -> + if def.dump then + begin + try + let value = + Schema.get + schema + env + nm + in + output nm value + with Not_set _ -> + () + end; + MapString.remove nm mp_todo) + !env_from_file + schema + in + (* Dump data defined outside of schema *) + MapString.iter output mp_todo; + + (* End of the dump *) + close_out chn + let print () = let printable_vars = @@ -3626,15 +3393,20 @@ module BaseEnv = struct if not def.hide || bool_of_string (print_hidden ()) then begin try - let value = Schema.get schema env nm in + let value = + Schema.get + schema + env + nm + in let txt = match short_descr_opt with | Some s -> s () | None -> nm in - (txt, value) :: acc + (txt, value) :: acc with Not_set _ -> - acc + acc end else acc) @@ -3646,122 +3418,123 @@ module BaseEnv = struct (List.rev_map String.length (List.rev_map fst printable_vars)) in - let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in - Printf.printf "\nConfiguration:\n"; + let dot_pad str = + String.make ((max_length - (String.length str)) + 3) '.' + in + + Printf.printf "\nConfiguration: \n"; List.iter (fun (name, value) -> - Printf.printf "%s: %s" name (dot_pad name); - if value = "" then - Printf.printf "\n" - else - Printf.printf " %s\n" value) + Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" let args () = - let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in - [ - "--override", - Arg.Tuple - ( - let rvr = ref "" - in - let rvl = ref "" - in - [ - Arg.Set_string rvr; - Arg.Set_string rvl; - Arg.Unit - (fun () -> - Schema.set - schema - env - ~context:OCommandLine - !rvr - !rvl) - ] - ), - "var+val Override any configuration variable."; + let arg_concat = + OASISUtils.varname_concat ~hyphen:'-' + in + [ + "--override", + Arg.Tuple + ( + let rvr = ref "" + in + let rvl = ref "" + in + [ + Arg.Set_string rvr; + Arg.Set_string rvl; + Arg.Unit + (fun () -> + Schema.set + schema + env + ~context:OCommandLine + !rvr + !rvl) + ] + ), + "var+val Override any configuration variable."; - ] - @ + ] + @ List.flatten (Schema.fold - (fun acc name def short_descr_opt -> - let var_set s = - Schema.set - schema - env - ~context:OCommandLine - name - s - in + (fun acc name def short_descr_opt -> + let var_set s = + Schema.set + schema + env + ~context:OCommandLine + name + s + in - let arg_name = - OASISUtils.varname_of_string ~hyphen:'-' name - in + let arg_name = + OASISUtils.varname_of_string ~hyphen:'-' name + in - let hlp = - match short_descr_opt with - | Some txt -> txt () - | None -> "" - in + let hlp = + match short_descr_opt with + | Some txt -> txt () + | None -> "" + in - let arg_hlp = - match def.arg_help with - | Some s -> s - | None -> "str" - in + let arg_hlp = + match def.arg_help with + | Some s -> s + | None -> "str" + in - let default_value = - try - Printf.sprintf - (f_ " [%s]") - (Schema.get - schema - env - name) - with Not_set _ -> - "" - in + let default_value = + try + Printf.sprintf + (f_ " [%s]") + (Schema.get + schema + env + name) + with Not_set _ -> + "" + in - let args = - match def.cli with - | CLINone -> - [] - | CLIAuto -> - [ - arg_concat "--" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIWith -> - [ - arg_concat "--with-" arg_name, - Arg.String var_set, - Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value - ] - | CLIEnable -> - let dflt = - if default_value = " [true]" then - s_ " [default: enabled]" - else - s_ " [default: disabled]" - in - [ - arg_concat "--enable-" arg_name, - Arg.Unit (fun () -> var_set "true"), - Printf.sprintf (f_ " %s%s") hlp dflt; - - arg_concat "--disable-" arg_name, - Arg.Unit (fun () -> var_set "false"), - Printf.sprintf (f_ " %s%s") hlp dflt - ] - | CLIUser lst -> - lst - in - args :: acc) + let args = + match def.cli with + | CLINone -> + [] + | CLIAuto -> + [ + arg_concat "--" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIWith -> + [ + arg_concat "--with-" arg_name, + Arg.String var_set, + Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value + ] + | CLIEnable -> + let dflt = + if default_value = " [true]" then + s_ " [default: enabled]" + else + s_ " [default: disabled]" + in + [ + arg_concat "--enable-" arg_name, + Arg.Unit (fun () -> var_set "true"), + Printf.sprintf (f_ " %s%s") hlp dflt; + + arg_concat "--disable-" arg_name, + Arg.Unit (fun () -> var_set "false"), + Printf.sprintf (f_ " %s%s") hlp dflt + ] + | CLIUser lst -> + lst + in + args :: acc) [] schema) end @@ -3775,25 +3548,25 @@ module BaseArgExt = struct let parse argv args = - (* Simulate command line for Arg *) - let current = - ref 0 - in + (* Simulate command line for Arg *) + let current = + ref 0 + in - try - Arg.parse_argv - ~current:current - (Array.concat [[|"none"|]; argv]) - (Arg.align args) - (failwithf (f_ "Don't know what to do with arguments: '%s'")) - (s_ "configure options:") - with - | Arg.Help txt -> - print_endline txt; - exit 0 - | Arg.Bad txt -> - prerr_endline txt; - exit 1 + try + Arg.parse_argv + ~current:current + (Array.concat [[|"none"|]; argv]) + (Arg.align args) + (failwithf (f_ "Don't know what to do with arguments: '%s'")) + (s_ "configure options:") + with + | Arg.Help txt -> + print_endline txt; + exit 0 + | Arg.Bad txt -> + prerr_endline txt; + exit 1 end module BaseCheck = struct @@ -3815,18 +3588,18 @@ module BaseCheck = struct (fun res e -> match res with | Some _ -> - res + res | None -> - try - Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) - with Not_found -> - None) + try + Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) + with Not_found -> + None) None prg_lst in - match alternate with - | Some prg -> prg - | None -> raise Not_found) + match alternate with + | Some prg -> prg + | None -> raise Not_found) let prog prg = @@ -3842,45 +3615,45 @@ module BaseCheck = struct let version - var_prefix - cmp - fversion - () = + var_prefix + cmp + fversion + () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in - var_redefine - ~hide:true - var - (fun () -> - let version_str = - match fversion () with - | "[Distributed with OCaml]" -> - begin - try - (var_get "ocaml_version") - with Not_found -> - warning - (f_ "Variable ocaml_version not defined, fallback \ - to default"); - Sys.ocaml_version - end - | res -> - res - in - let version = - OASISVersion.version_of_string version_str - in - if OASISVersion.comparator_apply version cmp then - version_str - else - failwithf - (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") - var_prefix - (OASISVersion.string_of_comparator cmp) - version_str) - () + var_redefine + ~hide:true + var + (fun () -> + let version_str = + match fversion () with + | "[Distributed with OCaml]" -> + begin + try + (var_get "ocaml_version") + with Not_found -> + warning + (f_ "Variable ocaml_version not defined, fallback \ + to default"); + Sys.ocaml_version + end + | res -> + res + in + let version = + OASISVersion.version_of_string version_str + in + if OASISVersion.comparator_apply version cmp then + version_str + else + failwithf + (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") + var_prefix + (OASISVersion.string_of_comparator cmp) + version_str) + () let package_version pkg = @@ -3901,13 +3674,13 @@ module BaseCheck = struct (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in - if Sys.file_exists dir && Sys.is_directory dir then - dir - else - failwithf - (f_ "When looking for findlib package %s, \ - directory %s return doesn't exist") - pkg dir + if Sys.file_exists dir && Sys.is_directory dir then + dir + else + failwithf + (f_ "When looking for findlib package %s, \ + directory %s return doesn't exist") + pkg dir in let vl = var_redefine @@ -3915,19 +3688,19 @@ module BaseCheck = struct (fun () -> findlib_dir pkg) () in - ( - match version_comparator with - | Some ver_cmp -> - ignore - (version - var - ver_cmp - (fun _ -> package_version pkg) - ()) - | None -> - () - ); - vl + ( + match version_comparator with + | Some ver_cmp -> + ignore + (version + var + ver_cmp + (fun _ -> package_version pkg) + ()) + | None -> + () + ); + vl end module BaseOCamlcConfig = struct @@ -3949,46 +3722,46 @@ module BaseOCamlcConfig = struct let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) - *) + *) let rec split_field mp lst = match lst with | line :: tl -> - let mp = - try - let pos_semicolon = - String.index line ':' - in - if pos_semicolon > 1 then - ( - let name = - String.sub line 0 pos_semicolon - in - let linelen = - String.length line - in - let value = - if linelen > pos_semicolon + 2 then - String.sub - line - (pos_semicolon + 2) - (linelen - pos_semicolon - 2) - else - "" - in - SMap.add name value mp - ) - else + let mp = + try + let pos_semicolon = + String.index line ':' + in + if pos_semicolon > 1 then + ( + let name = + String.sub line 0 pos_semicolon + in + let linelen = + String.length line + in + let value = + if linelen > pos_semicolon + 2 then + String.sub + line + (pos_semicolon + 2) + (linelen - pos_semicolon - 2) + else + "" + in + SMap.add name value mp + ) + else + ( + mp + ) + with Not_found -> ( mp ) - with Not_found -> - ( - mp - ) - in - split_field mp tl + in + split_field mp tl | [] -> - mp + mp in let cache = @@ -4002,13 +3775,13 @@ module BaseOCamlcConfig = struct (ocamlc ()) ["-config"])) [])) in - var_redefine - "ocamlc_config_map" - ~hide:true - ~dump:false - (fun () -> - (* TODO: update if ocamlc change !!! *) - Lazy.force cache) + var_redefine + "ocamlc_config_map" + ~hide:true + ~dump:false + (fun () -> + (* TODO: update if ocamlc change !!! *) + Lazy.force cache) let var_define nm = @@ -4023,30 +3796,30 @@ module BaseOCamlcConfig = struct String.sub s 0 (String.index s '+') with _ -> s - in + in let nm_config, value_config = match nm with | "ocaml_version" -> - "version", chop_version_suffix + "version", chop_version_suffix | _ -> nm, (fun x -> x) in - var_redefine - nm - (fun () -> - try - let map = - avlbl_config_get () - in - let value = - SMap.find nm_config map - in - value_config value - with Not_found -> - failwithf - (f_ "Cannot find field '%s' in '%s -config' output") - nm - (ocamlc ())) + var_redefine + nm + (fun () -> + try + let map = + avlbl_config_get () + in + let value = + SMap.find nm_config map + in + value_config value + with Not_found -> + failwithf + (f_ "Cannot find field '%s' in '%s -config' output") + nm + (ocamlc ())) end @@ -4056,6 +3829,7 @@ module BaseStandardVar = struct open OASISGettext open OASISTypes + open OASISExpr open BaseCheck open BaseEnv @@ -4085,11 +3859,11 @@ module BaseStandardVar = struct let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in - var_cond := + var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; - fun () -> !holder () + fun () -> !holder () (**/**) @@ -4150,11 +3924,11 @@ module BaseStandardVar = struct OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in - match lst with - | line :: _ -> - Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) - | [] -> - raise Not_found) + match lst with + | line :: _ -> + Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) + | [] -> + raise Not_found) (**/**) @@ -4170,7 +3944,7 @@ module BaseStandardVar = struct let (/) a b = if os_type () = Sys.os_type then Filename.concat a b - else if os_type () = "Unix" || os_type () = "Cygwin" then + else if os_type () = "Unix" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") @@ -4184,12 +3958,12 @@ module BaseStandardVar = struct (fun () -> match os_type () with | "Win32" -> - let program_files = - Sys.getenv "PROGRAMFILES" - in - program_files/(pkg_name ()) + let program_files = + Sys.getenv "PROGRAMFILES" + in + program_files/(pkg_name ()) | _ -> - "/usr/local") + "/usr/local") let exec_prefix = @@ -4325,12 +4099,12 @@ module BaseStandardVar = struct let _s: string = ocamlopt () in - "true" + "true" with PropList.Not_set _ -> let _s: string = ocamlc () in - "false") + "false") let ext_program = @@ -4383,7 +4157,7 @@ module BaseStandardVar = struct (fun () -> var_define ~short_desc:(fun () -> - s_ "Compile tests executable and library and run them") + s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) @@ -4422,35 +4196,35 @@ module BaseStandardVar = struct in let has_native_dynlink = let ocamlfind = ocamlfind () in - try - let fn = - OASISExec.run_read_one_line - ~ctxt:!BaseContext.default - ocamlfind - ["query"; "-predicates"; "native"; "dynlink"; - "-format"; "%d/%a"] - in - Sys.file_exists fn - with _ -> - false + try + let fn = + OASISExec.run_read_one_line + ~ctxt:!BaseContext.default + ocamlfind + ["query"; "-predicates"; "native"; "dynlink"; + "-format"; "%d/%a"] + in + Sys.file_exists fn + with _ -> + false in - if not has_native_dynlink then - false - else if ocaml_lt_312 () then - false - else if (os_type () = "Win32" || os_type () = "Cygwin") - && flexdll_lt_030 () then - begin - BaseMessage.warning - (f_ ".cmxs generation disabled because FlexDLL needs to be \ - at least 0.30. Please upgrade FlexDLL from %s to 0.30.") - (flexdll_version ()); + if not has_native_dynlink then false - end - else - true + else if ocaml_lt_312 () then + false + else if (os_type () = "Win32" || os_type () = "Cygwin") + && flexdll_lt_030 () then + begin + BaseMessage.warning + (f_ ".cmxs generation disabled because FlexDLL needs to be \ + at least 0.30. Please upgrade FlexDLL from %s to 0.30.") + (flexdll_version ()); + false + end + else + true in - string_of_bool res) + string_of_bool res) let init pkg = @@ -4466,29 +4240,48 @@ module BaseFileAB = struct open BaseEnv open OASISGettext open BaseMessage - open OASISContext let to_filename fn = - if not (Filename.check_suffix fn ".ab") then - warning (f_ "File '%s' doesn't have '.ab' extension") fn; - OASISFileSystem.of_unix_filename (Filename.chop_extension fn) + let fn = + OASISHostPath.of_unix fn + in + if not (Filename.check_suffix fn ".ab") then + warning + (f_ "File '%s' doesn't have '.ab' extension") + fn; + Filename.chop_extension fn - let replace ~ctxt fn_lst = - let open OASISFileSystem in - let ibuf, obuf = Buffer.create 13, Buffer.create 13 in - List.iter - (fun fn -> - Buffer.clear ibuf; Buffer.clear obuf; - defer_close - (ctxt.srcfs#open_in (of_unix_filename fn)) - (read_all ibuf); - Buffer.add_string obuf (var_expand (Buffer.contents ibuf)); - defer_close - (ctxt.srcfs#open_out (to_filename fn)) - (fun wrtr -> wrtr#output obuf)) - fn_lst + let replace fn_lst = + let buff = + Buffer.create 13 + in + List.iter + (fun fn -> + let fn = + OASISHostPath.of_unix fn + in + let chn_in = + open_in fn + in + let chn_out = + open_out (to_filename fn) + in + ( + try + while true do + Buffer.add_string buff (var_expand (input_line chn_in)); + Buffer.add_char buff '\n' + done + with End_of_file -> + () + ); + Buffer.output_buffer chn_out buff; + Buffer.clear buff; + close_in chn_in; + close_out chn_out) + fn_lst end module BaseLog = struct @@ -4496,92 +4289,126 @@ module BaseLog = struct open OASISUtils - open OASISContext - open OASISGettext - open OASISFileSystem - let default_filename = in_srcdir "setup.log" + let default_filename = + Filename.concat + (Filename.dirname BaseEnv.default_filename) + "setup.log" - let load ~ctxt () = - let module SetTupleString = - Set.Make - (struct - type t = string * string - let compare (s11, s12) (s21, s22) = - match String.compare s11 s21 with - | 0 -> String.compare s12 s22 - | n -> n - end) - in - if ctxt.srcfs#file_exists default_filename then begin - defer_close - (ctxt.srcfs#open_in default_filename) - (fun rdr -> - let line = ref 1 in - let lxr = Genlex.make_lexer [] (stream_of_reader rdr) in - let rec read_aux (st, lst) = - match Stream.npeek 2 lxr with - | [Genlex.String e; Genlex.String d] -> - let t = e, d in - Stream.junk lxr; Stream.junk lxr; - if SetTupleString.mem t st then - read_aux (st, lst) - else - read_aux (SetTupleString.add t st, t :: lst) - | [] -> List.rev lst - | _ -> - failwithf - (f_ "Malformed log file '%s' at line %d") - (ctxt.srcfs#string_of_filename default_filename) - !line - in - read_aux (SetTupleString.empty, [])) - end else begin - [] - end + module SetTupleString = + Set.Make + (struct + type t = string * string + let compare (s11, s12) (s21, s22) = + match String.compare s11 s21 with + | 0 -> String.compare s12 s22 + | n -> n + end) + + + let load () = + if Sys.file_exists default_filename then + begin + let chn = + open_in default_filename + in + let scbuf = + Scanf.Scanning.from_file default_filename + in + let rec read_aux (st, lst) = + if not (Scanf.Scanning.end_of_input scbuf) then + begin + let acc = + try + Scanf.bscanf scbuf "%S %S\n" + (fun e d -> + let t = + e, d + in + if SetTupleString.mem t st then + st, lst + else + SetTupleString.add t st, + t :: lst) + with Scanf.Scan_failure _ -> + failwith + (Scanf.bscanf scbuf + "%l" + (fun line -> + Printf.sprintf + "Malformed log file '%s' at line %d" + default_filename + line)) + in + read_aux acc + end + else + begin + close_in chn; + List.rev lst + end + in + read_aux (SetTupleString.empty, []) + end + else + begin + [] + end - let register ~ctxt event data = - defer_close - (ctxt.srcfs#open_out - ~mode:[Open_append; Open_creat; Open_text] - ~perm:0o644 - default_filename) - (fun wrtr -> - let buf = Buffer.create 13 in - Printf.bprintf buf "%S %S\n" event data; - wrtr#output buf) + let register event data = + let chn_out = + open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename + in + Printf.fprintf chn_out "%S %S\n" event data; + close_out chn_out - let unregister ~ctxt event data = - let lst = load ~ctxt () in - let buf = Buffer.create 13 in - List.iter - (fun (e, d) -> - if e <> event || d <> data then - Printf.bprintf buf "%S %S\n" e d) - lst; - if Buffer.length buf > 0 then - defer_close - (ctxt.srcfs#open_out default_filename) - (fun wrtr -> wrtr#output buf) - else - ctxt.srcfs#remove default_filename + let unregister event data = + if Sys.file_exists default_filename then + begin + let lst = + load () + in + let chn_out = + open_out default_filename + in + let write_something = + ref false + in + List.iter + (fun (e, d) -> + if e <> event || d <> data then + begin + write_something := true; + Printf.fprintf chn_out "%S %S\n" e d + end) + lst; + close_out chn_out; + if not !write_something then + Sys.remove default_filename + end - let filter ~ctxt events = - let st_events = SetString.of_list events in - List.filter - (fun (e, _) -> SetString.mem e st_events) - (load ~ctxt ()) + let filter events = + let st_events = + List.fold_left + (fun st e -> + SetString.add e st) + SetString.empty + events + in + List.filter + (fun (e, _) -> SetString.mem e st_events) + (load ()) - let exists ~ctxt event data = + let exists event data = List.exists (fun v -> (event, data) = v) - (load ~ctxt ()) + (load ()) end module BaseBuilt = struct @@ -4604,81 +4431,100 @@ module BaseBuilt = struct let to_log_event_file t nm = "built_"^ - (match t with - | BExec -> "exec" - | BExecLib -> "exec_lib" - | BLib -> "lib" - | BObj -> "obj" - | BDoc -> "doc")^ - "_"^nm + (match t with + | BExec -> "exec" + | BExecLib -> "exec_lib" + | BLib -> "lib" + | BObj -> "obj" + | BDoc -> "doc")^ + "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) - let register ~ctxt t nm lst = - BaseLog.register ~ctxt (to_log_event_done t nm) "true"; + let register t nm lst = + BaseLog.register + (to_log_event_done t nm) + "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> - if OASISFileUtil.file_exists_case fn then begin - BaseLog.register ~ctxt - (to_log_event_file t nm) - (if Filename.is_relative fn then - Filename.concat (Sys.getcwd ()) fn - else - fn); - true - end else begin - registered - end) + if OASISFileUtil.file_exists_case fn then + begin + BaseLog.register + (to_log_event_file t nm) + (if Filename.is_relative fn then + Filename.concat (Sys.getcwd ()) fn + else + fn); + true + end + else + registered) false alt in - if not registered then - warning - (f_ "Cannot find an existing alternative files among: %s") - (String.concat (s_ ", ") alt)) + if not registered then + warning + (f_ "Cannot find an existing alternative files among: %s") + (String.concat (s_ ", ") alt)) lst - let unregister ~ctxt t nm = + let unregister t nm = List.iter - (fun (e, d) -> BaseLog.unregister ~ctxt e d) - (BaseLog.filter ~ctxt [to_log_event_file t nm; to_log_event_done t nm]) + (fun (e, d) -> + BaseLog.unregister e d) + (BaseLog.filter + [to_log_event_file t nm; + to_log_event_done t nm]) - let fold ~ctxt t nm f acc = + let fold t nm f acc = List.fold_left (fun acc (_, fn) -> - if OASISFileUtil.file_exists_case fn then begin - f acc fn - end else begin - warning - (f_ "File '%s' has been marked as built \ + if OASISFileUtil.file_exists_case fn then + begin + f acc fn + end + else + begin + warning + (f_ "File '%s' has been marked as built \ for %s but doesn't exist") - fn - (Printf.sprintf - (match t with - | BExec | BExecLib -> (f_ "executable %s") - | BLib -> (f_ "library %s") - | BObj -> (f_ "object %s") - | BDoc -> (f_ "documentation %s")) - nm); - acc - end) + fn + (Printf.sprintf + (match t with + | BExec | BExecLib -> + (f_ "executable %s") + | BLib -> + (f_ "library %s") + | BObj -> + (f_ "object %s") + | BDoc -> + (f_ "documentation %s")) + nm); + acc + end) acc - (BaseLog.filter ~ctxt [to_log_event_file t nm]) + (BaseLog.filter + [to_log_event_file t nm]) - let is_built ~ctxt t nm = + let is_built t nm = List.fold_left - (fun _ (_, d) -> try bool_of_string d with _ -> false) + (fun is_built (_, d) -> + (try + bool_of_string d + with _ -> + false)) false - (BaseLog.filter ~ctxt [to_log_event_done t nm]) + (BaseLog.filter + [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = @@ -4694,15 +4540,15 @@ module BaseBuilt = struct let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: - (match unix_dll_opt with - | Some fn -> - [BExecLib, cs.cs_name, [[ffn fn]]] - | None -> - []) + (match unix_dll_opt with + | Some fn -> + [BExecLib, cs.cs_name, [[ffn fn]]] + | None -> + []) in - evs, - unix_exec_is, - unix_dll_opt + evs, + unix_exec_is, + unix_dll_opt let of_library ffn (cs, bs, lib) = @@ -4710,7 +4556,7 @@ module BaseBuilt = struct OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) @@ -4722,7 +4568,7 @@ module BaseBuilt = struct cs.cs_name, List.map (List.map ffn) unix_lst] in - evs, unix_lst + evs, unix_lst let of_object ffn (cs, bs, obj) = @@ -4730,7 +4576,7 @@ module BaseBuilt = struct OASISObject.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> - OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) (cs, bs, obj) in @@ -4739,7 +4585,7 @@ module BaseBuilt = struct cs.cs_name, List.map (List.map ffn) unix_lst] in - evs, unix_lst + evs, unix_lst end @@ -4768,32 +4614,32 @@ module BaseCustom = struct | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in - match - var_choose - ~name:(s_ "Pre/Post Command") - ~printer - lst with - | Some (cmd, args) -> - begin - try - run cmd args [||] - with e when failsafe -> - warning - (f_ "Command '%s' fail with error: %s") - (String.concat " " (cmd :: args)) - (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) - end - | None -> - () + match + var_choose + ~name:(s_ "Pre/Post Command") + ~printer + lst with + | Some (cmd, args) -> + begin + try + run cmd args [||] + with e when failsafe -> + warning + (f_ "Command '%s' fail with error: %s") + (String.concat " " (cmd :: args)) + (match e with + | Failure msg -> msg + | e -> Printexc.to_string e) + end + | None -> + () in let res = optional_command cstm.pre_command; f e in - optional_command cstm.post_command; - res + optional_command cstm.post_command; + res end module BaseDynVar = struct @@ -4806,38 +4652,41 @@ module BaseDynVar = struct open BaseBuilt - let init ~ctxt pkg = + let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function - | Executable (cs, bs, _) -> - if var_choose bs.bs_build then - var_ignore - (var_redefine - (* We don't save this variable *) - ~dump:false - ~short_desc:(fun () -> - Printf.sprintf - (f_ "Filename of executable '%s'") - cs.cs_name) - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - let fn_opt = - fold ~ctxt BExec cs.cs_name (fun _ fn -> Some fn) None - in - match fn_opt with - | Some fn -> fn - | None -> - raise - (PropList.Not_set - (cs.cs_name, - Some (Printf.sprintf - (f_ "Executable '%s' not yet built.") - cs.cs_name))))) - - | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> - ()) + | Executable (cs, bs, exec) -> + if var_choose bs.bs_build then + var_ignore + (var_redefine + (* We don't save this variable *) + ~dump:false + ~short_desc:(fun () -> + Printf.sprintf + (f_ "Filename of executable '%s'") + cs.cs_name) + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + let fn_opt = + fold + BExec cs.cs_name + (fun _ fn -> Some fn) + None + in + match fn_opt with + | Some fn -> fn + | None -> + raise + (PropList.Not_set + (cs.cs_name, + Some (Printf.sprintf + (f_ "Executable '%s' not yet built.") + cs.cs_name))))) + + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + ()) pkg.sections end @@ -4848,48 +4697,53 @@ module BaseTest = struct open BaseEnv open BaseMessage open OASISTypes + open OASISExpr open OASISGettext - let test ~ctxt lst pkg extra_args = + let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose - ~name:(Printf.sprintf - (f_ "test %s run") - cs.cs_name) - ~printer:string_of_bool - test.test_run then + ~name:(Printf.sprintf + (f_ "test %s run") + cs.cs_name) + ~printer:string_of_bool + test.test_run then begin - let () = info (f_ "Running test '%s'") cs.cs_name in + let () = + info (f_ "Running test '%s'") cs.cs_name + in let back_cwd = match test.test_working_directory with | Some dir -> - let cwd = Sys.getcwd () in - let chdir d = - info (f_ "Changing directory to '%s'") d; - Sys.chdir d - in - chdir dir; - fun () -> chdir cwd + let cwd = + Sys.getcwd () + in + let chdir d = + info (f_ "Changing directory to '%s'") d; + Sys.chdir d + in + chdir dir; + fun () -> chdir cwd | None -> - fun () -> () + fun () -> () in - try - let failure_percent = - BaseCustom.hook - test.test_custom - (test_plugin ~ctxt pkg (cs, test)) - extra_args - in - back_cwd (); - (failure_percent +. failure, n + 1) - with e -> - begin - back_cwd (); - raise e - end + try + let failure_percent = + BaseCustom.hook + test.test_custom + (test_plugin pkg (cs, test)) + extra_args + in + back_cwd (); + (failure_percent +. failure, n + 1) + with e -> + begin + back_cwd (); + raise e + end end else begin @@ -4897,25 +4751,35 @@ module BaseTest = struct (failure, n) end in - let failed, n = List.fold_left one_test (0.0, 0) lst in - let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in + let failed, n = + List.fold_left + one_test + (0.0, 0) + lst + in + let failure_percent = + if n = 0 then + 0.0 + else + failed /. (float_of_int n) + in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in - if failure_percent > 0.0 then - failwith msg - else - info "%s" msg; - - (* Possible explanation why the tests where not run. *) - if OASISFeatures.package_test OASISFeatures.flag_tests pkg && - not (bool_of_string (BaseStandardVar.tests ())) && - lst <> [] then - BaseMessage.warning - "Tests are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-tests'" + if failure_percent > 0.0 then + failwith msg + else + info "%s" msg; + + (* Possible explanation why the tests where not run. *) + if OASISFeatures.package_test OASISFeatures.flag_tests pkg && + not (bool_of_string (BaseStandardVar.tests ())) && + lst <> [] then + BaseMessage.warning + "Tests are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct @@ -4928,79 +4792,74 @@ module BaseDoc = struct open OASISGettext - let doc ~ctxt lst pkg extra_args = + let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose - ~name:(Printf.sprintf - (f_ "documentation %s build") - cs.cs_name) - ~printer:string_of_bool - doc.doc_build then + ~name:(Printf.sprintf + (f_ "documentation %s build") + cs.cs_name) + ~printer:string_of_bool + doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom - (doc_plugin ~ctxt pkg (cs, doc)) + (doc_plugin pkg (cs, doc)) extra_args end in - List.iter one_doc lst; - - if OASISFeatures.package_test OASISFeatures.flag_docs pkg && - not (bool_of_string (BaseStandardVar.docs ())) && - lst <> [] then - BaseMessage.warning - "Docs are turned off, consider enabling with \ - 'ocaml setup.ml -configure --enable-docs'" + List.iter one_doc lst; + + if OASISFeatures.package_test OASISFeatures.flag_docs pkg && + not (bool_of_string (BaseStandardVar.docs ())) && + lst <> [] then + BaseMessage.warning + "Docs are turned off, consider enabling with \ + 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 22 "src/base/BaseSetup.ml" *) - open OASISContext open BaseEnv open BaseMessage open OASISTypes + open OASISSection open OASISGettext open OASISUtils type std_args_fun = - ctxt:OASISContext.t -> package -> string array -> unit + package -> string array -> unit type ('a, 'b) section_args_fun = - name * - (ctxt:OASISContext.t -> - package -> - (common_section * 'a) -> - string array -> - 'b) + name * (package -> (common_section * 'a) -> string array -> 'b) type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } + { + configure: std_args_fun; + build: std_args_fun; + doc: ((doc, unit) section_args_fun) list; + test: ((test, float) section_args_fun) list; + install: std_args_fun; + uninstall: std_args_fun; + clean: std_args_fun list; + clean_doc: (doc, unit) section_args_fun list; + clean_test: (test, unit) section_args_fun list; + distclean: std_args_fun list; + distclean_doc: (doc, unit) section_args_fun list; + distclean_test: (test, unit) section_args_fun list; + package: package; + oasis_fn: string option; + oasis_version: string; + oasis_digest: Digest.t option; + oasis_exec: string option; + oasis_setup_args: string list; + setup_update: bool; + } (* Associate a plugin function with data from package *) @@ -5010,9 +4869,9 @@ module BaseSetup = struct (fun acc sct -> match filter_map sct with | Some e -> - e :: acc + e :: acc | None -> - acc) + acc) [] lst) @@ -5029,7 +4888,7 @@ module BaseSetup = struct action - let configure ~ctxt t args = + let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom @@ -5038,137 +4897,154 @@ module BaseSetup = struct begin try unload (); - load ~ctxt (); + load (); with _ -> () end; (* Run plugin's configure *) - t.configure ~ctxt t.package args; + t.configure t.package args; (* Dump to allow postconf to change it *) - dump ~ctxt ()) + dump ()) (); (* Reload environment *) unload (); - load ~ctxt (); + load (); (* Save environment *) print (); (* Replace data in file *) - BaseFileAB.replace ~ctxt t.package.files_ab + BaseFileAB.replace t.package.files_ab - let build ~ctxt t args = + let build t args = BaseCustom.hook t.package.build_custom - (t.build ~ctxt t.package) + (t.build t.package) args - let doc ~ctxt t args = + let doc t args = BaseDoc.doc - ~ctxt (join_plugin_sections (function - | Doc (cs, e) -> - Some - (lookup_plugin_section - "documentation" - (s_ "build") - cs.cs_name - t.doc, - cs, - e) - | _ -> - None) + | Doc (cs, e) -> + Some + (lookup_plugin_section + "documentation" + (s_ "build") + cs.cs_name + t.doc, + cs, + e) + | _ -> + None) t.package.sections) t.package args - let test ~ctxt t args = + let test t args = BaseTest.test - ~ctxt (join_plugin_sections (function - | Test (cs, e) -> - Some - (lookup_plugin_section - "test" - (s_ "run") - cs.cs_name - t.test, - cs, - e) - | _ -> - None) + | Test (cs, e) -> + Some + (lookup_plugin_section + "test" + (s_ "run") + cs.cs_name + t.test, + cs, + e) + | _ -> + None) t.package.sections) t.package args - let all ~ctxt t args = - let rno_doc = ref false in - let rno_test = ref false in - let arg_rest = ref [] in - Arg.parse_argv - ~current:(ref 0) - (Array.of_list - ((Sys.executable_name^" all") :: + let all t args = + let rno_doc = + ref false + in + let rno_test = + ref false + in + let arg_rest = + ref [] + in + Arg.parse_argv + ~current:(ref 0) + (Array.of_list + ((Sys.executable_name^" all") :: (Array.to_list args))) - [ - "-no-doc", - Arg.Set rno_doc, - s_ "Don't run doc target"; + [ + "-no-doc", + Arg.Set rno_doc, + s_ "Don't run doc target"; - "-no-test", - Arg.Set rno_test, - s_ "Don't run test target"; + "-no-test", + Arg.Set rno_test, + s_ "Don't run test target"; - "--", - Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), - s_ "All arguments for configure."; - ] - (failwithf (f_ "Don't know what to do with '%s'")) - ""; + "--", + Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), + s_ "All arguments for configure."; + ] + (failwithf (f_ "Don't know what to do with '%s'")) + ""; - info "Running configure step"; - configure ~ctxt t (Array.of_list (List.rev !arg_rest)); + info "Running configure step"; + configure t (Array.of_list (List.rev !arg_rest)); - info "Running build step"; - build ~ctxt t [||]; + info "Running build step"; + build t [||]; - (* Load setup.log dynamic variables *) - BaseDynVar.init ~ctxt t.package; + (* Load setup.log dynamic variables *) + BaseDynVar.init t.package; - if not !rno_doc then begin - info "Running doc step"; - doc ~ctxt t [||] - end else begin - info "Skipping doc step" - end; - if not !rno_test then begin - info "Running test step"; - test ~ctxt t [||] - end else begin - info "Skipping test step" - end + if not !rno_doc then + begin + info "Running doc step"; + doc t [||]; + end + else + begin + info "Skipping doc step" + end; + + if not !rno_test then + begin + info "Running test step"; + test t [||] + end + else + begin + info "Skipping test step" + end - let install ~ctxt t args = - BaseCustom.hook t.package.install_custom (t.install ~ctxt t.package) args + let install t args = + BaseCustom.hook + t.package.install_custom + (t.install t.package) + args - let uninstall ~ctxt t args = - BaseCustom.hook t.package.uninstall_custom (t.uninstall ~ctxt t.package) args + let uninstall t args = + BaseCustom.hook + t.package.uninstall_custom + (t.uninstall t.package) + args - let reinstall ~ctxt t args = - uninstall ~ctxt t args; - install ~ctxt t args + let reinstall t args = + uninstall t args; + install t args let clean, distclean = @@ -5179,11 +5055,11 @@ module BaseSetup = struct warning (f_ "Action fail with error: %s") (match e with - | Failure msg -> msg - | e -> Printexc.to_string e) + | Failure msg -> msg + | e -> Printexc.to_string e) in - let generic_clean ~ctxt t cstm mains docs tests args = + let generic_clean t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm @@ -5191,32 +5067,45 @@ module BaseSetup = struct (* Clean section *) List.iter (function - | Test (cs, test) -> - let f = - try - List.assoc cs.cs_name tests - with Not_found -> - fun ~ctxt:_ _ _ _ -> () - in - failsafe (f ~ctxt t.package (cs, test)) args - | Doc (cs, doc) -> - let f = - try - List.assoc cs.cs_name docs - with Not_found -> - fun ~ctxt:_ _ _ _ -> () - in - failsafe (f ~ctxt t.package (cs, doc)) args - | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) + | Test (cs, test) -> + let f = + try + List.assoc cs.cs_name tests + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, test)) + args + | Doc (cs, doc) -> + let f = + try + List.assoc cs.cs_name docs + with Not_found -> + fun _ _ _ -> () + in + failsafe + (f t.package (cs, doc)) + args + | Library _ + | Object _ + | Executable _ + | Flag _ + | SrcRepo _ -> + ()) t.package.sections; (* Clean whole package *) - List.iter (fun f -> failsafe (f ~ctxt t.package) args) mains) + List.iter + (fun f -> + failsafe + (f t.package) + args) + mains) () in - let clean ~ctxt t args = + let clean t args = generic_clean - ~ctxt t t.package.clean_custom t.clean @@ -5225,13 +5114,12 @@ module BaseSetup = struct args in - let distclean ~ctxt t args = + let distclean t args = (* Call clean *) - clean ~ctxt t args; + clean t args; (* Call distclean code *) generic_clean - ~ctxt t t.package.distclean_custom t.distclean @@ -5239,31 +5127,36 @@ module BaseSetup = struct t.distclean_test args; - (* Remove generated source files. *) + (* Remove generated file *) List.iter (fun fn -> - if ctxt.srcfs#file_exists fn then begin - info (f_ "Remove '%s'") (ctxt.srcfs#string_of_filename fn); - ctxt.srcfs#remove fn - end) - ([BaseEnv.default_filename; BaseLog.default_filename] - @ (List.rev_map BaseFileAB.to_filename t.package.files_ab)) + if Sys.file_exists fn then + begin + info (f_ "Remove '%s'") fn; + Sys.remove fn + end) + (BaseEnv.default_filename + :: + BaseLog.default_filename + :: + (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in - clean, distclean + clean, distclean - let version ~ctxt:_ (t: t) _ = print_endline t.oasis_version + let version t _ = + print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in - b, - ("-no-update-setup-ml", - Arg.Clear b, - s_ " Don't try to update setup.ml, even if _oasis has changed.") + b, + ("-no-update-setup-ml", + Arg.Clear b, + s_ " Don't try to update setup.ml, even if _oasis has changed.") + - (* TODO: srcfs *) let default_oasis_fn = "_oasis" @@ -5284,16 +5177,16 @@ module BaseSetup = struct let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> - setup_ml, args + setup_ml, args | [] -> - failwith - (s_ "Expecting non-empty command line arguments.") + failwith + (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. - *) + *) "ocaml", "setup.ml" else ocaml, setup_ml @@ -5304,62 +5197,64 @@ module BaseSetup = struct OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: - (function - | 0 -> - () - | 1 -> - failwithf - (f_ "Executable '%s' is probably an old version \ - of oasis (< 0.3.0), please update to version \ - v%s.") - oasis_exec t.oasis_version - | 127 -> - failwithf - (f_ "Cannot find executable '%s', please install \ - oasis v%s.") - oasis_exec t.oasis_version - | n -> - failwithf - (f_ "Command '%s version' exited with code %d.") - oasis_exec n) + (function + | 0 -> + () + | 1 -> + failwithf + (f_ "Executable '%s' is probably an old version \ + of oasis (< 0.3.0), please update to version \ + v%s.") + oasis_exec t.oasis_version + | 127 -> + failwithf + (f_ "Cannot find executable '%s', please install \ + oasis v%s.") + oasis_exec t.oasis_version + | n -> + failwithf + (f_ "Command '%s version' exited with code %d.") + oasis_exec n) oasis_exec ["version"] in - if OASISVersion.comparator_apply - (OASISVersion.version_of_string oasis_exec_version) - (OASISVersion.VGreaterEqual - (OASISVersion.version_of_string t.oasis_version)) then - begin - (* We have a version >= for the executable oasis, proceed with - * update. - *) - (* TODO: delegate this check to 'oasis setup'. *) - if Sys.os_type = "Win32" then - failwithf - (f_ "It is not possible to update the running script \ - setup.ml on Windows. Please update setup.ml by \ - running '%s'.") - (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) - else - begin - OASISExec.run - ~ctxt:!BaseContext.default - ~f_exit_code: - (fun n -> - if n <> 0 then - failwithf - (f_ "Unable to update setup.ml using '%s', \ - please fix the problem and retry.") - oasis_exec) - oasis_exec ("setup" :: t.oasis_setup_args); - OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) - end - end - else - failwithf - (f_ "The version of '%s' (v%s) doesn't match the version of \ - oasis used to generate the %s file. Please install at \ - least oasis v%s.") - oasis_exec oasis_exec_version setup_ml t.oasis_version + if OASISVersion.comparator_apply + (OASISVersion.version_of_string oasis_exec_version) + (OASISVersion.VGreaterEqual + (OASISVersion.version_of_string t.oasis_version)) then + begin + (* We have a version >= for the executable oasis, proceed with + * update. + *) + (* TODO: delegate this check to 'oasis setup'. *) + if Sys.os_type = "Win32" then + failwithf + (f_ "It is not possible to update the running script \ + setup.ml on Windows. Please update setup.ml by \ + running '%s'.") + (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) + else + begin + OASISExec.run + ~ctxt:!BaseContext.default + ~f_exit_code: + (function + | 0 -> + () + | n -> + failwithf + (f_ "Unable to update setup.ml using '%s', \ + please fix the problem and retry.") + oasis_exec) + oasis_exec ("setup" :: t.oasis_setup_args); + OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) + end + end + else + failwithf + (f_ "The version of '%s' (v%s) doesn't match the version of \ + oasis used to generate the %s file. Please install at \ + least oasis v%s.") + oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then @@ -5376,7 +5271,7 @@ module BaseSetup = struct else false | None -> - false + false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ @@ -5390,287 +5285,158 @@ module BaseSetup = struct let setup t = - let catch_exn = ref true in - let act_ref = - ref (fun ~ctxt:_ _ -> - failwithf - (f_ "No action defined, run '%s %s -help'") - Sys.executable_name - Sys.argv.(0)) - + let catch_exn = + ref true in - let extra_args_ref = ref [] in - let allow_empty_env_ref = ref false in - let arg_handle ?(allow_empty_env=false) act = - Arg.Tuple - [ - Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); - Arg.Unit - (fun () -> - allow_empty_env_ref := allow_empty_env; - act_ref := act); - ] - in - try - let () = - Arg.parse - (Arg.align - ([ - "-configure", - arg_handle ~allow_empty_env:true configure, - s_ "[options*] Configure the whole build process."; - - "-build", - arg_handle build, - s_ "[options*] Build executables and libraries."; - - "-doc", - arg_handle doc, - s_ "[options*] Build documents."; - - "-test", - arg_handle test, - s_ "[options*] Run tests."; - - "-all", - arg_handle ~allow_empty_env:true all, - s_ "[options*] Run configure, build, doc and test targets."; - - "-install", - arg_handle install, - s_ "[options*] Install libraries, data, executables \ - and documents."; - - "-uninstall", - arg_handle uninstall, - s_ "[options*] Uninstall libraries, data, executables \ - and documents."; - - "-reinstall", - arg_handle reinstall, - s_ "[options*] Uninstall and install libraries, data, \ - executables and documents."; - - "-clean", - arg_handle ~allow_empty_env:true clean, - s_ "[options*] Clean files generated by a build."; - - "-distclean", - arg_handle ~allow_empty_env:true distclean, - s_ "[options*] Clean files generated by a build and configure."; - - "-version", - arg_handle ~allow_empty_env:true version, - s_ " Display version of OASIS used to generate this setup.ml."; - - "-no-catch-exn", - Arg.Clear catch_exn, - s_ " Don't catch exception, useful for debugging."; - ] - @ + try + let act_ref = + ref (fun _ -> + failwithf + (f_ "No action defined, run '%s %s -help'") + Sys.executable_name + Sys.argv.(0)) + + in + let extra_args_ref = + ref [] + in + let allow_empty_env_ref = + ref false + in + let arg_handle ?(allow_empty_env=false) act = + Arg.Tuple + [ + Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); + + Arg.Unit + (fun () -> + allow_empty_env_ref := allow_empty_env; + act_ref := act); + ] + in + + Arg.parse + (Arg.align + ([ + "-configure", + arg_handle ~allow_empty_env:true configure, + s_ "[options*] Configure the whole build process."; + + "-build", + arg_handle build, + s_ "[options*] Build executables and libraries."; + + "-doc", + arg_handle doc, + s_ "[options*] Build documents."; + + "-test", + arg_handle test, + s_ "[options*] Run tests."; + + "-all", + arg_handle ~allow_empty_env:true all, + s_ "[options*] Run configure, build, doc and test targets."; + + "-install", + arg_handle install, + s_ "[options*] Install libraries, data, executables \ + and documents."; + + "-uninstall", + arg_handle uninstall, + s_ "[options*] Uninstall libraries, data, executables \ + and documents."; + + "-reinstall", + arg_handle reinstall, + s_ "[options*] Uninstall and install libraries, data, \ + executables and documents."; + + "-clean", + arg_handle ~allow_empty_env:true clean, + s_ "[options*] Clean files generated by a build."; + + "-distclean", + arg_handle ~allow_empty_env:true distclean, + s_ "[options*] Clean files generated by a build and configure."; + + "-version", + arg_handle ~allow_empty_env:true version, + s_ " Display version of OASIS used to generate this setup.ml."; + + "-no-catch-exn", + Arg.Clear catch_exn, + s_ " Don't catch exception, useful for debugging."; + ] + @ (if t.setup_update then [no_update_setup_ml_cli] else []) - @ (BaseContext.args ()))) - (failwithf (f_ "Don't know what to do with '%s'")) - (s_ "Setup and run build process current package\n") - in - - (* Instantiate the context. *) - let ctxt = !BaseContext.default in - - (* Build initial environment *) - load ~ctxt ~allow_empty:!allow_empty_env_ref (); - - (** Initialize flags *) - List.iter - (function - | Flag (cs, {flag_description = hlp; - flag_default = choices}) -> - begin - let apply ?short_desc () = - var_ignore - (var_define - ~cli:CLIEnable - ?short_desc - (OASISUtils.varname_of_string cs.cs_name) - (fun () -> - string_of_bool - (var_choose - ~name:(Printf.sprintf - (f_ "default value of flag %s") - cs.cs_name) - ~printer:string_of_bool - choices))) - in - match hlp with - | Some hlp -> apply ~short_desc:(fun () -> hlp) () - | None -> apply () - end - | _ -> - ()) - t.package.sections; - - BaseStandardVar.init t.package; - - BaseDynVar.init ~ctxt t.package; - - if not (t.setup_update && update_setup_ml t) then - !act_ref ~ctxt t (Array.of_list (List.rev !extra_args_ref)) - - with e when !catch_exn -> - error "%s" (Printexc.to_string e); - exit 1 - - -end - -module BaseCompat = struct -(* # 22 "src/base/BaseCompat.ml" *) - - (** Compatibility layer to provide a stable API inside setup.ml. - This layer allows OASIS to change in between minor versions - (e.g. 0.4.6 -> 0.4.7) but still provides a stable API inside setup.ml. This - enables to write functions that manipulate setup_t inside setup.ml. See - deps.ml for an example. - - The module opened by default will depend on the version of the _oasis. E.g. - if we have "OASISFormat: 0.3", the module Compat_0_3 will be opened and - the function Compat_0_3 will be called. If setup.ml is generated with the - -nocompat, no module will be opened. - - @author Sylvain Le Gall - *) - - module Compat_0_4 = - struct - let rctxt = ref !BaseContext.default - - module BaseSetup = - struct - module Original = BaseSetup + @ (BaseContext.args ()))) + (failwithf (f_ "Don't know what to do with '%s'")) + (s_ "Setup and run build process current package\n"); - open OASISTypes + (* Build initial environment *) + load ~allow_empty:!allow_empty_env_ref (); - type std_args_fun = package -> string array -> unit - type ('a, 'b) section_args_fun = - name * (package -> (common_section * 'a) -> string array -> 'b) - type t = - { - configure: std_args_fun; - build: std_args_fun; - doc: ((doc, unit) section_args_fun) list; - test: ((test, float) section_args_fun) list; - install: std_args_fun; - uninstall: std_args_fun; - clean: std_args_fun list; - clean_doc: (doc, unit) section_args_fun list; - clean_test: (test, unit) section_args_fun list; - distclean: std_args_fun list; - distclean_doc: (doc, unit) section_args_fun list; - distclean_test: (test, unit) section_args_fun list; - package: package; - oasis_fn: string option; - oasis_version: string; - oasis_digest: Digest.t option; - oasis_exec: string option; - oasis_setup_args: string list; - setup_update: bool; - } + (** Initialize flags *) + List.iter + (function + | Flag (cs, {flag_description = hlp; + flag_default = choices}) -> + begin + let apply ?short_desc () = + var_ignore + (var_define + ~cli:CLIEnable + ?short_desc + (OASISUtils.varname_of_string cs.cs_name) + (fun () -> + string_of_bool + (var_choose + ~name:(Printf.sprintf + (f_ "default value of flag %s") + cs.cs_name) + ~printer:string_of_bool + choices))) + in + match hlp with + | Some hlp -> + apply ~short_desc:(fun () -> hlp) () + | None -> + apply () + end + | _ -> + ()) + t.package.sections; - let setup t = - let mk_std_args_fun f = - fun ~ctxt pkg args -> rctxt := ctxt; f pkg args - in - let mk_section_args_fun l = - List.map - (fun (nm, f) -> - nm, - (fun ~ctxt pkg sct args -> - rctxt := ctxt; - f pkg sct args)) - l - in - let t' = - { - Original. - configure = mk_std_args_fun t.configure; - build = mk_std_args_fun t.build; - doc = mk_section_args_fun t.doc; - test = mk_section_args_fun t.test; - install = mk_std_args_fun t.install; - uninstall = mk_std_args_fun t.uninstall; - clean = List.map mk_std_args_fun t.clean; - clean_doc = mk_section_args_fun t.clean_doc; - clean_test = mk_section_args_fun t.clean_test; - distclean = List.map mk_std_args_fun t.distclean; - distclean_doc = mk_section_args_fun t.distclean_doc; - distclean_test = mk_section_args_fun t.distclean_test; - - package = t.package; - oasis_fn = t.oasis_fn; - oasis_version = t.oasis_version; - oasis_digest = t.oasis_digest; - oasis_exec = t.oasis_exec; - oasis_setup_args = t.oasis_setup_args; - setup_update = t.setup_update; - } - in - Original.setup t' + BaseStandardVar.init t.package; - end + BaseDynVar.init t.package; - let adapt_setup_t setup_t = - let module O = BaseSetup.Original in - let mk_std_args_fun f = fun pkg args -> f ~ctxt:!rctxt pkg args in - let mk_section_args_fun l = - List.map - (fun (nm, f) -> nm, (fun pkg sct args -> f ~ctxt:!rctxt pkg sct args)) - l - in - { - BaseSetup. - configure = mk_std_args_fun setup_t.O.configure; - build = mk_std_args_fun setup_t.O.build; - doc = mk_section_args_fun setup_t.O.doc; - test = mk_section_args_fun setup_t.O.test; - install = mk_std_args_fun setup_t.O.install; - uninstall = mk_std_args_fun setup_t.O.uninstall; - clean = List.map mk_std_args_fun setup_t.O.clean; - clean_doc = mk_section_args_fun setup_t.O.clean_doc; - clean_test = mk_section_args_fun setup_t.O.clean_test; - distclean = List.map mk_std_args_fun setup_t.O.distclean; - distclean_doc = mk_section_args_fun setup_t.O.distclean_doc; - distclean_test = mk_section_args_fun setup_t.O.distclean_test; - - package = setup_t.O.package; - oasis_fn = setup_t.O.oasis_fn; - oasis_version = setup_t.O.oasis_version; - oasis_digest = setup_t.O.oasis_digest; - oasis_exec = setup_t.O.oasis_exec; - oasis_setup_args = setup_t.O.oasis_setup_args; - setup_update = setup_t.O.setup_update; - } - end + if t.setup_update && update_setup_ml t then + () + else + !act_ref t (Array.of_list (List.rev !extra_args_ref)) + with e when !catch_exn -> + error "%s" (Printexc.to_string e); + exit 1 - module Compat_0_3 = - struct - include Compat_0_4 - end end -# 5666 "setup.ml" +# 5432 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall - *) + *) open BaseEnv @@ -5681,9 +5447,9 @@ module InternalConfigurePlugin = struct (** Configure build using provided series of check to be done - and then output corresponding file. - *) - let configure ~ctxt:_ pkg argv = + * and then output corresponding file. + *) + let configure pkg argv = let var_ignore_eval var = let _s: string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in @@ -5705,29 +5471,29 @@ module InternalConfigurePlugin = struct let check_tools lst = List.iter (function - | ExternalTool tool -> - begin - try - var_ignore_eval (BaseCheck.prog tool) - with e -> - warn_exception e; - add_errors (f_ "Cannot find external tool '%s'") tool - end - | InternalExecutable nm1 -> - (* Check that matching tool is built *) - List.iter - (function - | Executable ({cs_name = nm2; _}, - {bs_build = build; _}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal executable \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) + | ExternalTool tool -> + begin + try + var_ignore_eval (BaseCheck.prog tool) + with e -> + warn_exception e; + add_errors (f_ "Cannot find external tool '%s'") tool + end + | InternalExecutable nm1 -> + (* Check that matching tool is built *) + List.iter + (function + | Executable ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal executable \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) lst in @@ -5751,39 +5517,39 @@ module InternalConfigurePlugin = struct (* Check depends *) List.iter (function - | FindlibPackage (findlib_pkg, version_comparator) -> - begin - try - var_ignore_eval - (BaseCheck.package ?version_comparator findlib_pkg) - with e -> - warn_exception e; - match version_comparator with - | None -> - add_errors - (f_ "Cannot find findlib package %s") - findlib_pkg - | Some ver_cmp -> - add_errors - (f_ "Cannot find findlib package %s (%s)") - findlib_pkg - (OASISVersion.string_of_comparator ver_cmp) - end - | InternalLibrary nm1 -> - (* Check that matching library is built *) - List.iter - (function - | Library ({cs_name = nm2; _}, - {bs_build = build; _}, - _) when nm1 = nm2 -> - if not (var_choose build) then - add_errors - (f_ "Cannot find buildable internal library \ - '%s' when checking build depends") - nm1 - | _ -> - ()) - pkg.sections) + | FindlibPackage (findlib_pkg, version_comparator) -> + begin + try + var_ignore_eval + (BaseCheck.package ?version_comparator findlib_pkg) + with e -> + warn_exception e; + match version_comparator with + | None -> + add_errors + (f_ "Cannot find findlib package %s") + findlib_pkg + | Some ver_cmp -> + add_errors + (f_ "Cannot find findlib package %s (%s)") + findlib_pkg + (OASISVersion.string_of_comparator ver_cmp) + end + | InternalLibrary nm1 -> + (* Check that matching library is built *) + List.iter + (function + | Library ({cs_name = nm2}, + {bs_build = build}, + _) when nm1 = nm2 -> + if not (var_choose build) then + add_errors + (f_ "Cannot find buildable internal library \ + '%s' when checking build depends") + nm1 + | _ -> + ()) + pkg.sections) bs.bs_build_depends end in @@ -5795,50 +5561,50 @@ module InternalConfigurePlugin = struct begin match pkg.ocaml_version with | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "ocaml" - ver_cmp - BaseStandardVar.ocaml_version) - with e -> - warn_exception e; - add_errors - (f_ "OCaml version %s doesn't match version constraint %s") - (BaseStandardVar.ocaml_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end + begin + try + var_ignore_eval + (BaseCheck.version + "ocaml" + ver_cmp + BaseStandardVar.ocaml_version) + with e -> + warn_exception e; + add_errors + (f_ "OCaml version %s doesn't match version constraint %s") + (BaseStandardVar.ocaml_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end | None -> - () + () end; (* Findlib version *) begin match pkg.findlib_version with | Some ver_cmp -> - begin - try - var_ignore_eval - (BaseCheck.version - "findlib" - ver_cmp - BaseStandardVar.findlib_version) - with e -> - warn_exception e; - add_errors - (f_ "Findlib version %s doesn't match version constraint %s") - (BaseStandardVar.findlib_version ()) - (OASISVersion.string_of_comparator ver_cmp) - end + begin + try + var_ignore_eval + (BaseCheck.version + "findlib" + ver_cmp + BaseStandardVar.findlib_version) + with e -> + warn_exception e; + add_errors + (f_ "Findlib version %s doesn't match version constraint %s") + (BaseStandardVar.findlib_version ()) + (OASISVersion.string_of_comparator ver_cmp) + end | None -> - () + () end; (* Make sure the findlib version is fine for the OCaml compiler. *) begin let ocaml_ge4 = OASISVersion.version_compare - (OASISVersion.version_of_string (BaseStandardVar.ocaml_version ())) + (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) (OASISVersion.version_of_string "4.0.0") >= 0 in if ocaml_ge4 then let findlib_lt132 = @@ -5863,37 +5629,37 @@ module InternalConfigurePlugin = struct (* Check build depends *) List.iter (function - | Executable (_, bs, _) - | Library (_, bs, _) as sct -> - build_checks sct bs - | Doc (_, doc) -> - if var_choose doc.doc_build then - check_tools doc.doc_build_tools - | Test (_, test) -> - if var_choose test.test_run then - check_tools test.test_tools - | _ -> - ()) + | Executable (_, bs, _) + | Library (_, bs, _) as sct -> + build_checks sct bs + | Doc (_, doc) -> + if var_choose doc.doc_build then + check_tools doc.doc_build_tools + | Test (_, test) -> + if var_choose test.test_run then + check_tools test.test_tools + | _ -> + ()) pkg.sections; (* Check if we need native dynlink (presence of libraries that compile to - native) - *) + * native) + *) begin let has_cmxa = List.exists (function - | Library (_, bs, _) -> - var_choose bs.bs_build && - (bs.bs_compiled_object = Native || - (bs.bs_compiled_object = Best && - bool_of_string (BaseStandardVar.is_native ()))) - | _ -> - false) + | Library (_, bs, _) -> + var_choose bs.bs_build && + (bs.bs_compiled_object = Native || + (bs.bs_compiled_object = Best && + bool_of_string (BaseStandardVar.is_native ()))) + | _ -> + false) pkg.sections in - if has_cmxa then - var_ignore_eval BaseStandardVar.native_dynlink + if has_cmxa then + var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) @@ -5922,8 +5688,6 @@ module InternalInstallPlugin = struct *) - (* TODO: rewrite this module with OASISFileSystem. *) - open BaseEnv open BaseStandardVar open BaseMessage @@ -5933,17 +5697,34 @@ module InternalInstallPlugin = struct open OASISUtils - let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) - let lib_hook = ref (fun (cs, bs, dn, lib) -> cs, bs, dn, lib, []) - let obj_hook = ref (fun (cs, bs, dn, obj) -> cs, bs, dn, obj, []) - let doc_hook = ref (fun (cs, doc) -> cs, doc) + let exec_hook = + ref (fun (cs, bs, exec) -> cs, bs, exec) + + + let lib_hook = + ref (fun (cs, bs, lib) -> cs, bs, lib, []) + + + let obj_hook = + ref (fun (cs, bs, obj) -> cs, bs, obj, []) + + + let doc_hook = + ref (fun (cs, doc) -> cs, doc) + + + let install_file_ev = + "install-file" - let install_file_ev = "install-file" - let install_dir_ev = "install-dir" - let install_findlib_ev = "install-findlib" + + let install_dir_ev = + "install-dir" + + + let install_findlib_ev = + "install-findlib" - (* TODO: this can be more generic and used elsewhere. *) let win32_max_command_line_length = 8000 @@ -6012,7 +5793,7 @@ module InternalInstallPlugin = struct ["install" :: findlib_name :: meta :: files] - let install = + let install pkg argv = let in_destdir = try @@ -6027,9 +5808,9 @@ module InternalInstallPlugin = struct fun fn -> fn in - let install_file ~ctxt ?(prepend_destdir=true) ?tgt_fn src_file envdir = + let install_file ?tgt_fn src_file envdir = let tgt_dir = - if prepend_destdir then in_destdir (envdir ()) else envdir () + in_destdir (envdir ()) in let tgt_file = Filename.concat @@ -6042,48 +5823,20 @@ module InternalInstallPlugin = struct in (* Create target directory if needed *) OASISFileUtil.mkdir_parent - ~ctxt + ~ctxt:!BaseContext.default (fun dn -> info (f_ "Creating directory '%s'") dn; - BaseLog.register ~ctxt install_dir_ev dn) - (Filename.dirname tgt_file); + BaseLog.register install_dir_ev dn) + tgt_dir; (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; - OASISFileUtil.cp ~ctxt src_file tgt_file; - BaseLog.register ~ctxt install_file_ev tgt_file - in - - (* Install the files for a library. *) - - let install_lib_files ~ctxt findlib_name files = - let findlib_dir = - let dn = - let findlib_destdir = - OASISExec.run_read_one_line ~ctxt (ocamlfind ()) - ["printconf" ; "destdir"] - in - Filename.concat findlib_destdir findlib_name - in - fun () -> dn - in - let () = - if not (OASISFileUtil.file_exists_case (findlib_dir ())) then - failwithf - (f_ "Directory '%s' doesn't exist for findlib library %s") - (findlib_dir ()) findlib_name - in - let f dir file = - let basename = Filename.basename file in - let tgt_fn = Filename.concat dir basename in - (* Destdir is already include in printconf. *) - install_file ~ctxt ~prepend_destdir:false ~tgt_fn file findlib_dir - in - List.iter (fun (dir, files) -> List.iter (f dir) files) files ; + OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; + BaseLog.register install_file_ev tgt_file in (* Install data into defined directory *) - let install_data ~ctxt srcdir lst tgtdir = + let install_data srcdir lst tgtdir = let tgtdir = OASISHostPath.of_unix (var_expand tgtdir) in @@ -6100,7 +5853,7 @@ module InternalInstallPlugin = struct src; List.iter (fun fn -> - install_file ~ctxt + install_file fn (fun () -> match tgt_opt with @@ -6124,146 +5877,149 @@ module InternalInstallPlugin = struct in (** Install all libraries *) - let install_libs ~ctxt pkg = + let install_libs pkg = - let find_first_existing_files_in_path bs lst = - let path = OASISHostPath.of_unix bs.bs_path in - List.find - OASISFileUtil.file_exists_case - (List.map (Filename.concat path) lst) - in + let files_of_library (f_data, acc) data_lib = + let cs, bs, lib, lib_extra = + !lib_hook data_lib + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then + begin + let acc = + (* Start with acc + lib_extra *) + List.rev_append lib_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + begin fun acc modul -> + begin + try + [List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".mli"; ".ml"]))] + with Not_found -> + warning + (f_ "Cannot find source header for module %s \ + in library %s") + modul cs.cs_name; + [] + end + @ + List.filter + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".annot";".cmti";".cmt"])) + @ acc + end + acc + lib.lib_modules + in - let files_of_modules new_files typ cs bs modules = - List.fold_left - (fun acc modul -> - begin - try - (* Add uncompiled header from the source tree *) - [find_first_existing_files_in_path - bs (make_fnames modul [".mli"; ".ml"])] - with Not_found -> - warning - (f_ "Cannot find source header for module %s \ - in %s %s") - typ modul cs.cs_name; - [] - end - @ - List.fold_left - (fun acc fn -> - try - find_first_existing_files_in_path bs [fn] :: acc - with Not_found -> - acc) - acc (make_fnames modul [".annot";".cmti";".cmt"])) - new_files - modules - in + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BLib + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in - let files_of_build_section (f_data, new_files) typ cs bs = - let extra_files = - List.map - (fun fn -> - try - find_first_existing_files_in_path bs [fn] - with Not_found -> - failwithf - (f_ "Cannot find extra findlib file %S in %s %s ") - fn - typ - cs.cs_name) - bs.bs_findlib_extra_files - in - let f_data () = - (* Install data associated with the library *) - install_data - ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () + let f_data () = + (* Install data associated with the library *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + and files_of_object (f_data, acc) data_obj = + let cs, bs, obj, obj_extra = + !obj_hook data_obj in - f_data, new_files @ extra_files - in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then + begin + let acc = + (* Start with acc + obj_extra *) + List.rev_append obj_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + begin fun acc modul -> + begin + try + [List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".mli"; ".ml"]))] + with Not_found -> + warning + (f_ "Cannot find source header for module %s \ + in object %s") + modul cs.cs_name; + [] + end + @ + List.filter + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + (make_fnames modul [".annot";".cmti";".cmt"])) + @ acc + end + acc + obj.obj_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BObj + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in - let files_of_library (f_data, acc) data_lib = - let cs, bs, lib, dn, lib_extra = !lib_hook data_lib in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BLib cs.cs_name then begin - (* Start with lib_extra *) - let new_files = lib_extra in - let new_files = - files_of_modules new_files "library" cs bs lib.lib_modules - in - let f_data, new_files = - files_of_build_section (f_data, new_files) "library" cs bs - in - let new_files = - (* Get generated files *) - BaseBuilt.fold - ~ctxt - BaseBuilt.BLib - cs.cs_name - (fun acc fn -> fn :: acc) - new_files - in - let acc = (dn, new_files) :: acc in - - let f_data () = - (* Install data associated with the library *) - install_data - ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat - (datarootdir ()) - pkg.name); - f_data () - in + let f_data () = + (* Install data associated with the object *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in - (f_data, acc) - end else begin - (f_data, acc) - end - and files_of_object (f_data, acc) data_obj = - let cs, bs, obj, dn, obj_extra = !obj_hook data_obj in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BObj cs.cs_name then begin - (* Start with obj_extra *) - let new_files = obj_extra in - let new_files = - files_of_modules new_files "object" cs bs obj.obj_modules - in - let f_data, new_files = - files_of_build_section (f_data, new_files) "object" cs bs - in + (f_data, acc) + end + else + begin + (f_data, acc) + end - let new_files = - (* Get generated files *) - BaseBuilt.fold - ~ctxt - BaseBuilt.BObj - cs.cs_name - (fun acc fn -> fn :: acc) - new_files - in - let acc = (dn, new_files) :: acc in - - let f_data () = - (* Install data associated with the object *) - install_data - ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat (datarootdir ()) pkg.name); - f_data () - in - (f_data, acc) - end else begin - (f_data, acc) - end in (* Install one group of library *) @@ -6274,10 +6030,10 @@ module InternalInstallPlugin = struct match grp with | Container (_, children) -> data_and_files, children - | Package (_, cs, bs, `Library lib, dn, children) -> - files_of_library data_and_files (cs, bs, lib, dn), children - | Package (_, cs, bs, `Object obj, dn, children) -> - files_of_object data_and_files (cs, bs, obj, dn), children + | Package (_, cs, bs, `Library lib, children) -> + files_of_library data_and_files (cs, bs, lib), children + | Package (_, cs, bs, `Object obj, children) -> + files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux @@ -6286,196 +6042,264 @@ module InternalInstallPlugin = struct in (* Findlib name of the root library *) - let findlib_name = findlib_of_group grp in + let findlib_name = + findlib_of_group grp + in (* Determine root library *) - let root_lib = root_of_group grp in + let root_lib = + root_of_group grp + in (* All files to install for this library *) - let f_data, files = install_group_lib_aux (ignore, []) grp in + let f_data, files = + install_group_lib_aux (ignore, []) grp + in (* Really install, if there is something to install *) - if files = [] then begin - warning - (f_ "Nothing to install for findlib library '%s'") findlib_name - end else begin - let meta = - (* Search META file *) - let _, bs, _ = root_lib in - let res = Filename.concat bs.bs_path "META" in - if not (OASISFileUtil.file_exists_case res) then - failwithf - (f_ "Cannot find file '%s' for findlib library %s") - res - findlib_name; - res - in - let files = - (* Make filename shorter to avoid hitting command max line length - * too early, esp. on Windows. - *) - (* TODO: move to OASISHostPath as make_relative. *) - let remove_prefix p n = - let plen = String.length p in - let nlen = String.length n in - if plen <= nlen && String.sub n 0 plen = p then begin - let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in - let cutpoint = - plen + - (if plen < nlen && n.[plen] = fn_sep then 1 else 0) + if files = [] then + begin + warning + (f_ "Nothing to install for findlib library '%s'") + findlib_name + end + else + begin + let meta = + (* Search META file *) + let _, bs, _ = + root_lib in - String.sub n cutpoint (nlen - cutpoint) - end else begin - n - end - in - List.map - (fun (dir, fn) -> - (dir, List.map (remove_prefix (Sys.getcwd ())) fn)) - files - in - let ocamlfind = ocamlfind () in - let nodir_files, dir_files = - List.fold_left - (fun (nodir, dir) (dn, lst) -> - match dn with - | Some dn -> nodir, (dn, lst) :: dir - | None -> lst @ nodir, dir) - ([], []) - (List.rev files) - in - info (f_ "Installing findlib library '%s'") findlib_name; - List.iter - (OASISExec.run ~ctxt ocamlfind) - (split_install_command ocamlfind findlib_name meta nodir_files); - install_lib_files ~ctxt findlib_name dir_files; - BaseLog.register ~ctxt install_findlib_ev findlib_name - end; + let res = + Filename.concat bs.bs_path "META" + in + if not (OASISFileUtil.file_exists_case res) then + failwithf + (f_ "Cannot find file '%s' for findlib library %s") + res + findlib_name; + res + in + let files = + (* Make filename shorter to avoid hitting command max line length + * too early, esp. on Windows. + *) + let remove_prefix p n = + let plen = String.length p in + let nlen = String.length n in + if plen <= nlen && String.sub n 0 plen = p then + begin + let fn_sep = + if Sys.os_type = "Win32" then + '\\' + else + '/' + in + let cutpoint = plen + + (if plen < nlen && n.[plen] = fn_sep then + 1 + else + 0) + in + String.sub n cutpoint (nlen - cutpoint) + end + else + n + in + List.map (remove_prefix (Sys.getcwd ())) files + in + info + (f_ "Installing findlib library '%s'") + findlib_name; + let ocamlfind = ocamlfind () in + let commands = + split_install_command + ocamlfind + findlib_name + meta + files + in + List.iter + (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) + commands; + BaseLog.register install_findlib_ev findlib_name + end; + + (* Install data files *) + f_data (); - (* Install data files *) - f_data (); in - let group_libs, _, _ = findlib_mapping pkg in + let group_libs, _, _ = + findlib_mapping pkg + in (* We install libraries in groups *) List.iter install_group_lib group_libs in - let install_execs ~ctxt pkg = + let install_execs pkg = let install_exec data_exec = - let cs, bs, _ = !exec_hook data_exec in - if var_choose bs.bs_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BExec cs.cs_name then begin - let exec_libdir () = Filename.concat (libdir ()) pkg.name in - BaseBuilt.fold - ~ctxt - BaseBuilt.BExec - cs.cs_name - (fun () fn -> - install_file ~ctxt - ~tgt_fn:(cs.cs_name ^ ext_program ()) - fn - bindir) - (); - BaseBuilt.fold - ~ctxt - BaseBuilt.BExecLib - cs.cs_name - (fun () fn -> install_file ~ctxt fn exec_libdir) - (); - install_data ~ctxt - bs.bs_path - bs.bs_data_files - (Filename.concat (datarootdir ()) pkg.name) - end + let cs, bs, exec = + !exec_hook data_exec + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then + begin + let exec_libdir () = + Filename.concat + (libdir ()) + pkg.name + in + BaseBuilt.fold + BaseBuilt.BExec + cs.cs_name + (fun () fn -> + install_file + ~tgt_fn:(cs.cs_name ^ ext_program ()) + fn + bindir) + (); + BaseBuilt.fold + BaseBuilt.BExecLib + cs.cs_name + (fun () fn -> + install_file + fn + exec_libdir) + (); + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name) + end in - List.iter - (function - | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) - | _ -> ()) + List.iter + (function + | Executable (cs, bs, exec)-> + install_exec (cs, bs, exec) + | _ -> + ()) pkg.sections in - let install_docs ~ctxt pkg = + let install_docs pkg = let install_doc data = - let cs, doc = !doc_hook data in - if var_choose doc.doc_install && - BaseBuilt.is_built ~ctxt BaseBuilt.BDoc cs.cs_name then begin - let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in - BaseBuilt.fold - ~ctxt - BaseBuilt.BDoc - cs.cs_name - (fun () fn -> install_file ~ctxt fn (fun () -> tgt_dir)) - (); - install_data ~ctxt - Filename.current_dir_name - doc.doc_data_files - doc.doc_install_dir - end + let cs, doc = + !doc_hook data + in + if var_choose doc.doc_install && + BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then + begin + let tgt_dir = + OASISHostPath.of_unix (var_expand doc.doc_install_dir) + in + BaseBuilt.fold + BaseBuilt.BDoc + cs.cs_name + (fun () fn -> + install_file + fn + (fun () -> tgt_dir)) + (); + install_data + Filename.current_dir_name + doc.doc_data_files + doc.doc_install_dir + end in - List.iter - (function - | Doc (cs, doc) -> install_doc (cs, doc) - | _ -> ()) - pkg.sections + List.iter + (function + | Doc (cs, doc) -> + install_doc (cs, doc) + | _ -> + ()) + pkg.sections in - fun ~ctxt pkg _ -> - install_libs ~ctxt pkg; - install_execs ~ctxt pkg; - install_docs ~ctxt pkg + + install_libs pkg; + install_execs pkg; + install_docs pkg (* Uninstall already installed data *) - let uninstall ~ctxt _ _ = - let uninstall_aux (ev, data) = - if ev = install_file_ev then begin - if OASISFileUtil.file_exists_case data then begin - info (f_ "Removing file '%s'") data; - Sys.remove data - end else begin - warning (f_ "File '%s' doesn't exist anymore") data - end - end else if ev = install_dir_ev then begin - if Sys.file_exists data && Sys.is_directory data then begin - if Sys.readdir data = [||] then begin - info (f_ "Removing directory '%s'") data; - OASISFileUtil.rmdir ~ctxt data - end else begin - warning - (f_ "Directory '%s' is not empty (%s)") - data - (String.concat ", " (Array.to_list (Sys.readdir data))) - end - end else begin - warning (f_ "Directory '%s' doesn't exist anymore") data - end - end else if ev = install_findlib_ev then begin - info (f_ "Removing findlib library '%s'") data; - OASISExec.run ~ctxt (ocamlfind ()) ["remove"; data] - end else begin - failwithf (f_ "Unknown log event '%s'") ev; - end; - BaseLog.unregister ~ctxt ev data - in - (* We process event in reverse order *) - List.iter uninstall_aux + let uninstall _ argv = + List.iter + (fun (ev, data) -> + if ev = install_file_ev then + begin + if OASISFileUtil.file_exists_case data then + begin + info + (f_ "Removing file '%s'") + data; + Sys.remove data + end + else + begin + warning + (f_ "File '%s' doesn't exist anymore") + data + end + end + else if ev = install_dir_ev then + begin + if Sys.file_exists data && Sys.is_directory data then + begin + if Sys.readdir data = [||] then + begin + info + (f_ "Removing directory '%s'") + data; + OASISFileUtil.rmdir ~ctxt:!BaseContext.default data + end + else + begin + warning + (f_ "Directory '%s' is not empty (%s)") + data + (String.concat + ", " + (Array.to_list + (Sys.readdir data))) + end + end + else + begin + warning + (f_ "Directory '%s' doesn't exist anymore") + data + end + end + else if ev = install_findlib_ev then + begin + info (f_ "Removing findlib library '%s'") data; + OASISExec.run ~ctxt:!BaseContext.default + (ocamlfind ()) ["remove"; data] + end + else + failwithf (f_ "Unknown log event '%s'") ev; + BaseLog.unregister ev data) + (* We process event in reverse order *) (List.rev - (BaseLog.filter ~ctxt [install_file_ev; install_dir_ev])); - List.iter uninstall_aux - (List.rev (BaseLog.filter ~ctxt [install_findlib_ev])) + (BaseLog.filter + [install_file_ev; + install_dir_ev; + install_findlib_ev])) + end -# 6472 "setup.ml" +# 6296 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin - *) + *) open OASISGettext @@ -6484,6 +6308,8 @@ module OCamlbuildCommon = struct open OASISTypes + + type extra_args = string list @@ -6506,14 +6332,6 @@ module OCamlbuildCommon = struct "-classic-display"; "-no-log"; "-no-links"; - ] - else - []; - - if OASISVersion.comparator_apply - (OASISVersion.version_of_string (ocaml_version ())) - (OASISVersion.VLesser (OASISVersion.version_of_string "3.11.1")) then - [ "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") ] @@ -6550,32 +6368,35 @@ module OCamlbuildCommon = struct (** Run 'ocamlbuild -clean' if not already done *) - let run_clean ~ctxt extra_argv = + let run_clean extra_argv = let extra_cli = String.concat " " (Array.to_list extra_argv) in - (* Run if never called with these args *) - if not (BaseLog.exists ~ctxt ocamlbuild_clean_ev extra_cli) then - begin - OASISExec.run ~ctxt (ocamlbuild ()) (fix_args ["-clean"] extra_argv); - BaseLog.register ~ctxt ocamlbuild_clean_ev extra_cli; - at_exit - (fun () -> - try - BaseLog.unregister ~ctxt ocamlbuild_clean_ev extra_cli - with _ -> ()) - end + (* Run if never called with these args *) + if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then + begin + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args ["-clean"] extra_argv); + BaseLog.register ocamlbuild_clean_ev extra_cli; + at_exit + (fun () -> + try + BaseLog.unregister ocamlbuild_clean_ev extra_cli + with _ -> + ()) + end (** Run ocamlbuild, unregister all clean events *) - let run_ocamlbuild ~ctxt args extra_argv = + let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html - *) - OASISExec.run ~ctxt (ocamlbuild ()) (fix_args args extra_argv); + *) + OASISExec.run ~ctxt:!BaseContext.default + (ocamlbuild ()) (fix_args args extra_argv); (* Remove any clean event, we must run it again *) List.iter - (fun (e, d) -> BaseLog.unregister ~ctxt e d) - (BaseLog.filter ~ctxt [ocamlbuild_clean_ev]) + (fun (e, d) -> BaseLog.unregister e d) + (BaseLog.filter [ocamlbuild_clean_ev]) (** Determine real build directory *) @@ -6583,13 +6404,13 @@ module OCamlbuildCommon = struct let rec search_args dir = function | "-build-dir" :: dir :: tl -> - search_args dir tl + search_args dir tl | _ :: tl -> - search_args dir tl + search_args dir tl | [] -> - dir + dir in - search_args "_build" (fix_args [] extra_argv) + search_args "_build" (fix_args [] extra_argv) end @@ -6610,12 +6431,17 @@ module OCamlbuildPlugin = struct open BaseEnv open OCamlbuildCommon open BaseStandardVar + open BaseMessage - let cond_targets_hook = ref (fun lst -> lst) - let build ~ctxt extra_args pkg argv = + + let cond_targets_hook = + ref (fun lst -> lst) + + + let build extra_args pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat @@ -6679,8 +6505,8 @@ module OCamlbuildPlugin = struct (List.map (List.filter (fun fn -> - ends_with ~what:".cmo" fn - || ends_with ~what:".cmx" fn)) + ends_with ".cmo" fn + || ends_with ".cmx" fn)) unix_files)) in @@ -6695,8 +6521,10 @@ module OCamlbuildPlugin = struct | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin - let evs, _, _ = - BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) + let evs, unix_exec_is, unix_dll_opt = + BaseBuilt.of_executable + in_build_dir_of_unix + (cs, bs, exec) in let target ext = @@ -6710,7 +6538,7 @@ module OCamlbuildPlugin = struct (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function - | BaseBuilt.BExec, nm, _ when nm = cs.cs_name -> + | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> @@ -6754,30 +6582,27 @@ module OCamlbuildPlugin = struct (List.length fns)) (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; - (BaseBuilt.register ~ctxt bt bnm lst) + (BaseBuilt.register bt bnm lst) in (* Run the hook *) let cond_targets = !cond_targets_hook cond_targets in (* Run a list of target... *) - run_ocamlbuild - ~ctxt - (List.flatten (List.map snd cond_targets) @ extra_args) - argv; + run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; (* ... and register events *) List.iter check_and_register (List.flatten (List.map fst cond_targets)) - let clean ~ctxt pkg extra_args = - run_clean ~ctxt extra_args; + let clean pkg extra_args = + run_clean extra_args; List.iter (function | Library (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections @@ -6791,12 +6616,16 @@ module OCamlbuildDocPlugin = struct (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall - *) + *) open OASISTypes open OASISGettext + open OASISMessage open OCamlbuildCommon + open BaseStandardVar + + type run_t = @@ -6806,7 +6635,7 @@ module OCamlbuildDocPlugin = struct } - let doc_build ~ctxt run _ (cs, _) argv = + let doc_build run pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ @@ -6823,126 +6652,139 @@ module OCamlbuildDocPlugin = struct cs.cs_name^".docdir"; ] in - run_ocamlbuild ~ctxt (index_html :: run.extra_args) argv; - List.iter - (fun glb -> - BaseBuilt.register - ~ctxt - BaseBuilt.BDoc - cs.cs_name - [OASISFileUtil.glob ~ctxt (Filename.concat tgt_dir glb)]) - ["*.html"; "*.css"] + run_ocamlbuild (index_html :: run.extra_args) argv; + List.iter + (fun glb -> + BaseBuilt.register + BaseBuilt.BDoc + cs.cs_name + [OASISFileUtil.glob ~ctxt:!BaseContext.default + (Filename.concat tgt_dir glb)]) + ["*.html"; "*.css"] - let doc_clean ~ctxt _ _ (cs, _) argv = - run_clean ~ctxt argv; - BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name + let doc_clean run pkg (cs, doc) argv = + run_clean argv; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name end -# 6845 "setup.ml" +# 6674 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) (** Generate custom configure/build/doc/test/install system @author - *) + *) open BaseEnv open OASISGettext open OASISTypes + + + + type t = - { - cmd_main: command_line conditional; - cmd_clean: (command_line option) conditional; - cmd_distclean: (command_line option) conditional; - } + { + cmd_main: command_line conditional; + cmd_clean: (command_line option) conditional; + cmd_distclean: (command_line option) conditional; + } let run = BaseCustom.run - let main ~ctxt:_ t _ extra_args = - let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in - run cmd args extra_args + let main t _ extra_args = + let cmd, args = + var_choose + ~name:(s_ "main command") + t.cmd_main + in + run cmd args extra_args - let clean ~ctxt:_ t _ extra_args = + let clean t pkg extra_args = match var_choose t.cmd_clean with - | Some (cmd, args) -> run cmd args extra_args - | _ -> () + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () - let distclean ~ctxt:_ t _ extra_args = + let distclean t pkg extra_args = match var_choose t.cmd_distclean with - | Some (cmd, args) -> run cmd args extra_args - | _ -> () + | Some (cmd, args) -> + run cmd args extra_args + | _ -> + () module Build = struct - let main ~ctxt t pkg extra_args = - main ~ctxt t pkg extra_args; + let main t pkg extra_args = + main t pkg extra_args; List.iter (fun sct -> let evs = match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> - begin - let evs, _ = - BaseBuilt.of_library - OASISHostPath.of_unix - (cs, bs, lib) - in - evs - end + begin + let evs, _ = + BaseBuilt.of_library + OASISHostPath.of_unix + (cs, bs, lib) + in + evs + end | Executable (cs, bs, exec) when var_choose bs.bs_build -> - begin - let evs, _, _ = - BaseBuilt.of_executable - OASISHostPath.of_unix - (cs, bs, exec) - in - evs - end + begin + let evs, _, _ = + BaseBuilt.of_executable + OASISHostPath.of_unix + (cs, bs, exec) + in + evs + end | _ -> - [] + [] in - List.iter - (fun (bt, bnm, lst) -> BaseBuilt.register ~ctxt bt bnm lst) - evs) + List.iter + (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) + evs) pkg.sections - let clean ~ctxt t pkg extra_args = - clean ~ctxt t pkg extra_args; + let clean t pkg extra_args = + clean t pkg extra_args; (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild * considering moving this to BaseSetup? *) List.iter (function - | Library (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BLib cs.cs_name - | Executable (cs, _, _) -> - BaseBuilt.unregister ~ctxt BaseBuilt.BExec cs.cs_name; - BaseBuilt.unregister ~ctxt BaseBuilt.BExecLib cs.cs_name - | _ -> - ()) + | Library (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BLib cs.cs_name + | Executable (cs, _, _) -> + BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; + BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name + | _ -> + ()) pkg.sections - let distclean ~ctxt t pkg extra_args = distclean ~ctxt t pkg extra_args + let distclean t pkg extra_args = + distclean t pkg extra_args end module Test = struct - let main ~ctxt t pkg (cs, _) extra_args = + let main t pkg (cs, test) extra_args = try - main ~ctxt t pkg extra_args; + main t pkg extra_args; 0.0 with Failure s -> BaseMessage.warning @@ -6951,30 +6793,33 @@ module CustomPlugin = struct s; 1.0 - let clean ~ctxt t pkg _ extra_args = clean ~ctxt t pkg extra_args + let clean t pkg (cs, test) extra_args = + clean t pkg extra_args - let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args + let distclean t pkg (cs, test) extra_args = + distclean t pkg extra_args end module Doc = struct - let main ~ctxt t pkg (cs, _) extra_args = - main ~ctxt t pkg extra_args; - BaseBuilt.register ~ctxt BaseBuilt.BDoc cs.cs_name [] + let main t pkg (cs, _) extra_args = + main t pkg extra_args; + BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] - let clean ~ctxt t pkg (cs, _) extra_args = - clean ~ctxt t pkg extra_args; - BaseBuilt.unregister ~ctxt BaseBuilt.BDoc cs.cs_name + let clean t pkg (cs, _) extra_args = + clean t pkg extra_args; + BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name - let distclean ~ctxt t pkg _ extra_args = distclean ~ctxt t pkg extra_args + let distclean t pkg (cs, _) extra_args = + distclean t pkg extra_args end end -# 6977 "setup.ml" +# 6822 "setup.ml" open OASISTypes;; let setup_t = @@ -7025,6 +6870,10 @@ let setup_t = { oasis_version = "0.4"; ocaml_version = None; + findlib_version = None; + alpha_features = []; + beta_features = []; + name = "fat-filesystem"; version = "0.11.0"; license = OASISLicense.DEP5License @@ -7034,20 +6883,47 @@ let setup_t = excption = None; version = OASISLicense.NoVersion }); - findlib_version = None; - alpha_features = []; - beta_features = []; - name = "fat-filesystem"; license_file = None; copyrights = []; maintainers = []; authors = ["David Scott"; "Anil Madhavapeddy"]; homepage = None; - bugreports = None; synopsis = "FAT filesystem manipulation"; description = None; - tags = []; categories = []; + conf_type = (`Configure, "internal", Some "0.4"); + conf_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + build_type = (`Build, "ocamlbuild", Some "0.4"); + build_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + install_type = (`Install, "internal", Some "0.4"); + install_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + uninstall_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + clean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; + distclean_custom = + { + pre_command = [(OASISExpr.EBool true, None)]; + post_command = [(OASISExpr.EBool true, None)] + }; files_ab = []; sections = [ @@ -7069,122 +6945,13 @@ let setup_t = FindlibPackage ("re", None); FindlibPackage ("re.str", None); FindlibPackage ("mirage-types", None); - FindlibPackage ("lwt", None) + FindlibPackage ("lwt", None); + FindlibPackage ("result", None); + FindlibPackage ("rresult", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; bs_c_sources = []; bs_data_files = []; - bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; @@ -7203,7 +6970,6 @@ let setup_t = "Fs"; "Update"; "SectorMap"; - "Result"; "MemoryIO"; "S"; "KV_RO" @@ -7212,7 +6978,6 @@ let setup_t = lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = Some "fat-filesystem"; - lib_findlib_directory = None; lib_findlib_containers = [] }); Executable @@ -7235,119 +7000,8 @@ let setup_t = FindlibPackage ("io-page.unix", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; bs_c_sources = []; bs_data_files = []; - bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; @@ -7375,119 +7029,8 @@ let setup_t = FindlibPackage ("io-page.unix", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; bs_c_sources = []; bs_data_files = []; - bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; @@ -7519,119 +7062,8 @@ let setup_t = FindlibPackage ("io-page.unix", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; bs_c_sources = []; bs_data_files = []; - bs_findlib_extra_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; @@ -7664,47 +7096,14 @@ let setup_t = test_tools = [ExternalTool "ocamlbuild"] }) ]; - disable_oasis_section = []; - conf_type = (`Configure, "internal", Some "0.4"); - conf_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - build_type = (`Build, "ocamlbuild", Some "0.4"); - build_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - install_type = (`Install, "internal", Some "0.4"); - install_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - uninstall_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - clean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; - distclean_custom = - { - pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)] - }; plugins = [(`Extra, "META", Some "0.4")]; + disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; - oasis_version = "0.4.7"; - oasis_digest = Some "\196\248V\224~\026\027\135\015U\191\163^\"\\\241"; + oasis_version = "0.4.6"; + oasis_digest = Some "\181\153\238\177\1595j_\205\028|\227~&\149\r"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7712,8 +7111,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7716 "setup.ml" -let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t -open BaseCompat.Compat_0_4 +# 7115 "setup.ml" (* OASIS_STOP *) let () = setup ();; From de44665f4e1de2fa359568b50113f34533f56f68 Mon Sep 17 00:00:00 2001 From: Mindy Preston Date: Wed, 28 Sep 2016 04:01:29 -0500 Subject: [PATCH 4/4] need result in opam for 4.02 --- opam | 1 + 1 file changed, 1 insertion(+) diff --git a/opam b/opam index 327aaa0..5932653 100644 --- a/opam +++ b/opam @@ -18,6 +18,7 @@ depends: [ "ocamlbuild" {build} "cstruct" {>= "2.0.0"} "ppx_tools" + "result" "rresult" "lwt" {>= "2.4.3"} "mirage-types" {>= "2.6.1"}