setup.ml 305 KB
Newer Older
gerd's avatar
gerd committed
1 2 3
(* setup.ml generated for the first time by OASIS v0.4.4 *)

(* OASIS_START *)
Gerd Stolpmann's avatar
Gerd Stolpmann committed
4
(* DO NOT EDIT (digest: c3fa950038b202897f5d1273efe3675f) *)
gerd's avatar
gerd committed
5
(*
Gerd Stolpmann's avatar
Gerd Stolpmann committed
6
   Regenerated by OASIS v0.4.8
gerd's avatar
gerd committed
7 8 9 10
   Visit http://oasis.forge.ocamlcore.org for more information and
   documentation about functions used in this file.
*)
module OASISGettext = struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
11
(* # 22 "src/oasis/OASISGettext.ml" *)
gerd's avatar
gerd committed
12 13


Gerd Stolpmann's avatar
Gerd Stolpmann committed
14 15 16
  let ns_ str = str
  let s_ str = str
  let f_ (str: ('a, 'b, 'c, 'd) format4) = str
gerd's avatar
gerd committed
17 18 19 20 21 22 23 24 25


  let fn_ fmt1 fmt2 n =
    if n = 1 then
      fmt1^^""
    else
      fmt2^^""


Gerd Stolpmann's avatar
Gerd Stolpmann committed
26
  let init = []
gerd's avatar
gerd committed
27 28 29
end

module OASISString = struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
30
(* # 22 "src/oasis/OASISString.ml" *)
gerd's avatar
gerd committed
31 32 33 34 35 36 37


  (** Various string utilities.

      Mostly inspired by extlib and batteries ExtString and BatString libraries.

      @author Sylvain Le Gall
Gerd Stolpmann's avatar
Gerd Stolpmann committed
38
  *)
gerd's avatar
gerd committed
39 40 41 42 43 44 45 46 47 48 49 50 51


  let nsplitf str f =
    if str = "" then
      []
    else
      let buf = Buffer.create 13 in
      let lst = ref [] in
      let push () =
        lst := Buffer.contents buf :: !lst;
        Buffer.clear buf
      in
      let str_len = String.length str in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
52 53 54 55 56 57 58 59
      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
gerd's avatar
gerd committed
60 61 62 63


  (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
      separator.
Gerd Stolpmann's avatar
Gerd Stolpmann committed
64
  *)
gerd's avatar
gerd committed
65 66 67 68 69 70 71
  let nsplit str c =
    nsplitf str ((=) c)


  let find ~what ?(offset=0) str =
    let what_idx = ref 0 in
    let str_idx = ref offset in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
72 73 74 75
    while !str_idx < String.length str &&
          !what_idx < String.length what do
      if str.[!str_idx] = what.[!what_idx] then
        incr what_idx
gerd's avatar
gerd committed
76
      else
Gerd Stolpmann's avatar
Gerd Stolpmann committed
77 78 79 80 81 82 83
        what_idx := 0;
      incr str_idx
    done;
    if !what_idx <> String.length what then
      raise Not_found
    else
      !str_idx - !what_idx
gerd's avatar
gerd committed
84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105


  let sub_start str len =
    let str_len = String.length str in
    if len >= str_len then
      ""
    else
      String.sub str len (str_len - len)


  let sub_end ?(offset=0) str len =
    let str_len = String.length str in
    if len >= str_len then
      ""
    else
      String.sub str 0 (str_len - len)


  let starts_with ~what ?(offset=0) str =
    let what_idx = ref 0 in
    let str_idx = ref offset in
    let ok = ref true in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
106 107 108 109 110
    while !ok &&
          !str_idx < String.length str &&
          !what_idx < String.length what do
      if str.[!str_idx] = what.[!what_idx] then
        incr what_idx
gerd's avatar
gerd committed
111
      else
Gerd Stolpmann's avatar
Gerd Stolpmann committed
112 113 114 115 116 117 118
        ok := false;
      incr str_idx
    done;
    if !what_idx = String.length what then
      true
    else
      false
gerd's avatar
gerd committed
119 120 121 122 123 124 125 126 127 128 129 130 131


  let strip_starts_with ~what str =
    if starts_with ~what str then
      sub_start str (String.length what)
    else
      raise Not_found


  let ends_with ~what ?(offset=0) str =
    let what_idx = ref ((String.length what) - 1) in
    let str_idx = ref ((String.length str) - 1) in
    let ok = ref true in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
132 133 134 135 136
    while !ok &&
          offset <= !str_idx &&
          0 <= !what_idx do
      if str.[!str_idx] = what.[!what_idx] then
        decr what_idx
gerd's avatar
gerd committed
137
      else
Gerd Stolpmann's avatar
Gerd Stolpmann committed
138 139 140 141 142 143 144
        ok := false;
      decr str_idx
    done;
    if !what_idx = -1 then
      true
    else
      false
gerd's avatar
gerd committed
145 146 147 148 149 150 151 152 153 154


  let strip_ends_with ~what str =
    if ends_with ~what str then
      sub_end str (String.length what)
    else
      raise Not_found


  let replace_chars f s =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
155 156 157
    let buf = Buffer.create (String.length s) in
    String.iter (fun c -> Buffer.add_char buf (f c)) s;
    Buffer.contents buf
gerd's avatar
gerd committed
158

Gerd Stolpmann's avatar
Gerd Stolpmann committed
159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185
  let lowercase_ascii =
    replace_chars
      (fun c ->
         if (c >= 'A' && c <= 'Z') then
           Char.chr (Char.code c + 32)
         else
           c)

  let uncapitalize_ascii s =
    if s <> "" then
      (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
    else
      s

  let uppercase_ascii =
    replace_chars
      (fun c ->
         if (c >= 'a' && c <= 'z') then
           Char.chr (Char.code c - 32)
         else
           c)

  let capitalize_ascii s =
    if s <> "" then
      (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
    else
      s
gerd's avatar
gerd committed
186 187 188 189

end

module OASISUtils = struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
190
(* # 22 "src/oasis/OASISUtils.ml" *)
gerd's avatar
gerd committed
191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254


  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 =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
255
    String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2)
gerd's avatar
gerd committed
256 257 258 259 260 261


  module HashStringCsl =
    Hashtbl.Make
      (struct
         type t = string
Gerd Stolpmann's avatar
Gerd Stolpmann committed
262 263
         let equal s1 s2 = (compare_csl s1 s2) = 0
         let hash s = Hashtbl.hash (OASISString.lowercase_ascii s)
gerd's avatar
gerd committed
264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300
       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
Gerd Stolpmann's avatar
Gerd Stolpmann committed
301
          OASISString.lowercase_ascii buf
gerd's avatar
gerd committed
302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328
      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


Gerd Stolpmann's avatar
Gerd Stolpmann committed
329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720
  let rec file_location ?pos1 ?pos2 ?lexbuf () =
      match pos1, pos2, lexbuf with
      | Some p, None, _ | None, Some p, _ ->
        file_location ~pos1:p ~pos2:p ?lexbuf ()
      | Some p1, Some p2, _ ->
        let open Lexing in
        let fn, lineno = p1.pos_fname, p1.pos_lnum in
        let c1 = p1.pos_cnum - p1.pos_bol in
        let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in
        Printf.sprintf (f_ "file %S, line %d, characters %d-%d")  fn lineno c1 c2
      | _, _, Some lexbuf ->
        file_location
          ~pos1:(Lexing.lexeme_start_p lexbuf)
          ~pos2:(Lexing.lexeme_end_p lexbuf)
          ()
      | None, None, None ->
        s_ "<position undefined>"


  let failwithpf ?pos1 ?pos2 ?lexbuf fmt =
    let loc = file_location ?pos1 ?pos2 ?lexbuf () in
    Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt


end

module OASISUnixPath = struct
(* # 22 "src/oasis/OASISUnixPath.ml" *)


  type unix_filename = string
  type unix_dirname = string


  type host_filename = string
  type host_dirname = string


  let current_dir_name = "."


  let parent_dir_name = ".."


  let is_current_dir fn =
    fn = current_dir_name || fn = ""


  let concat f1 f2 =
    if is_current_dir f1 then
      f2
    else
      let f1' =
        try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1
      in
      f1'^"/"^f2


  let make =
    function
      | hd :: tl ->
        List.fold_left
          (fun f p -> concat f p)
          hd
          tl
      | [] ->
        invalid_arg "OASISUnixPath.make"


  let dirname f =
    try
      String.sub f 0 (String.rindex f '/')
    with Not_found ->
      current_dir_name


  let basename f =
    try
      let pos_start =
        (String.rindex f '/') + 1
      in
      String.sub f pos_start ((String.length f) - pos_start)
    with Not_found ->
      f


  let chop_extension f =
    try
      let last_dot =
        String.rindex f '.'
      in
      let sub =
        String.sub f 0 last_dot
      in
      try
        let last_slash =
          String.rindex f '/'
        in
        if last_slash < last_dot then
          sub
        else
          f
      with Not_found ->
        sub

    with Not_found ->
      f


  let capitalize_file f =
    let dir = dirname f in
    let base = basename f in
    concat dir (OASISString.capitalize_ascii base)


  let uncapitalize_file f =
    let dir = dirname f in
    let base = basename f in
    concat dir (OASISString.uncapitalize_ascii base)


end

module OASISHostPath = struct
(* # 22 "src/oasis/OASISHostPath.ml" *)


  open Filename
  open OASISGettext


  module Unix = OASISUnixPath


  let make =
    function
      | [] ->
        invalid_arg "OASISHostPath.make"
      | hd :: tl ->
        List.fold_left Filename.concat hd tl


  let of_unix ufn =
    match Sys.os_type with
    | "Unix" | "Cygwin" -> ufn
    | "Win32" ->
      make
        (List.map
           (fun p ->
              if p = Unix.current_dir_name then
                current_dir_name
              else if p = Unix.parent_dir_name then
                parent_dir_name
              else
                p)
           (OASISString.nsplit ufn '/'))
    | os_type ->
      OASISUtils.failwithf
        (f_ "Don't know the path format of os_type %S when translating unix \
             filename. %S")
        os_type ufn


end

module OASISFileSystem = struct
(* # 22 "src/oasis/OASISFileSystem.ml" *)

  (** File System functions

      @author Sylvain Le Gall
  *)

  type 'a filename = string

  class type closer =
    object
      method close: unit
    end

  class type reader =
    object
      inherit closer
      method input: Buffer.t -> int -> unit
    end

  class type writer =
    object
      inherit closer
      method output: Buffer.t -> unit
    end

  class type ['a] fs =
    object
      method string_of_filename: 'a filename -> string
      method open_out: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> writer
      method open_in: ?mode:(open_flag list) -> ?perm:int -> 'a filename -> reader
      method file_exists: 'a filename -> bool
      method remove: 'a filename -> unit
    end


  module Mode =
  struct
    let default_in = [Open_rdonly]
    let default_out = [Open_wronly; Open_creat; Open_trunc]

    let text_in = Open_text :: default_in
    let text_out = Open_text :: default_out

    let binary_in = Open_binary :: default_in
    let binary_out = Open_binary :: default_out
  end

  let std_length = 4096 (* Standard buffer/read length. *)
  let binary_out = Mode.binary_out
  let binary_in = Mode.binary_in

  let of_unix_filename ufn = (ufn: 'a filename)
  let to_unix_filename fn = (fn: string)


  let defer_close o f =
    try
      let r = f o in o#close; r
    with e ->
      o#close; raise e


  let stream_of_reader rdr =
    let buf = Buffer.create std_length in
    let pos = ref 0 in
    let eof = ref false in
    let rec next idx =
      let bpos = idx - !pos in
      if !eof then begin
        None
      end else if bpos < Buffer.length buf then begin
        Some (Buffer.nth buf bpos)
      end else begin
        pos := !pos + Buffer.length buf;
        Buffer.clear buf;
        begin
          try
            rdr#input buf std_length;
          with End_of_file ->
            if Buffer.length buf = 0 then
              eof := true
        end;
        next idx
      end
    in
    Stream.from next


  let read_all buf rdr =
    try
      while true do
        rdr#input buf std_length
      done
    with End_of_file ->
      ()

  class ['a] host_fs rootdir : ['a] fs =
    object (self)
      method private host_filename fn = Filename.concat rootdir fn
      method string_of_filename = self#host_filename

      method open_out ?(mode=Mode.text_out)  ?(perm=0o666) fn =
        let chn = open_out_gen mode perm (self#host_filename fn) in
        object
          method close = close_out chn
          method output buf = Buffer.output_buffer chn buf
        end

      method open_in ?(mode=Mode.text_in) ?(perm=0o666) fn =
        (* TODO: use Buffer.add_channel when minimal version of OCaml will
         * be >= 4.03.0 (previous version was discarding last chars).
         *)
        let chn = open_in_gen mode perm (self#host_filename fn) in
        let strm = Stream.of_channel chn in
        object
          method close = close_in chn
          method input buf len =
            let read = ref 0 in
            try
              for _i = 0 to len do
                Buffer.add_char buf (Stream.next strm);
                incr read
              done
            with Stream.Failure ->
              if !read = 0 then
                raise End_of_file
        end

      method file_exists fn = Sys.file_exists (self#host_filename fn)
      method remove fn = Sys.remove (self#host_filename fn)
    end

end

module OASISContext = struct
(* # 22 "src/oasis/OASISContext.ml" *)


  open OASISGettext


  type level =
    [ `Debug
    | `Info
    | `Warning
    | `Error]


  type source
  type source_filename = source OASISFileSystem.filename


  let in_srcdir ufn = OASISFileSystem.of_unix_filename ufn


  type t =
    {
      (* TODO: replace this by a proplist. *)
      quiet:                 bool;
      info:                  bool;
      debug:                 bool;
      ignore_plugins:        bool;
      ignore_unknown_fields: bool;
      printf:                level -> string -> unit;
      srcfs:                 source OASISFileSystem.fs;
      load_oasis_plugin:     string -> bool;
    }


  let printf lvl str =
    let beg =
      match lvl with
        | `Error -> s_ "E: "
        | `Warning -> s_ "W: "
        | `Info  -> s_ "I: "
        | `Debug -> s_ "D: "
    in
    prerr_endline (beg^str)


  let default =
    ref
      {
        quiet                 = false;
        info                  = false;
        debug                 = false;
        ignore_plugins        = false;
        ignore_unknown_fields = false;
        printf                = printf;
        srcfs                 = new OASISFileSystem.host_fs(Sys.getcwd ());
        load_oasis_plugin     = (fun _ -> false);
      }


  let quiet =
    {!default with quiet = true}


  let fspecs () =
    (* TODO: don't act on default. *)
    let ignore_plugins = ref false in
    ["-quiet",
     Arg.Unit (fun () -> default := {!default with quiet = true}),
     s_ " Run quietly";

     "-info",
     Arg.Unit (fun () -> default := {!default with info = true}),
     s_ " Display information message";


     "-debug",
     Arg.Unit (fun () -> default := {!default with debug = true}),
     s_ " Output debug message";

     "-ignore-plugins",
     Arg.Set ignore_plugins,
     s_ " Ignore plugin's field.";

     "-C",
     Arg.String
       (fun str ->
          Sys.chdir str;
          default := {!default with srcfs = new OASISFileSystem.host_fs str}),
     s_ "dir Change directory before running (affects setup.{data,log})."],
    fun () -> {!default with ignore_plugins = !ignore_plugins}
gerd's avatar
gerd committed
721 722 723
end

module PropList = struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
724
(* # 22 "src/oasis/PropList.ml" *)
gerd's avatar
gerd committed
725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740


  open OASISGettext


  type name = string


  exception Not_set of name * string option
  exception No_printer of name
  exception Unknown_field of name * name


  let () =
    Printexc.register_printer
      (function
Gerd Stolpmann's avatar
Gerd Stolpmann committed
741 742 743 744 745 746 747 748 749 750 751 752 753 754 755
        | 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)
gerd's avatar
gerd committed
756 757 758 759 760


  module Data =
  struct
    type t =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
761
      (name, unit -> unit) Hashtbl.t
gerd's avatar
gerd committed
762 763 764 765 766 767 768 769

    let create () =
      Hashtbl.create 13

    let clear t =
      Hashtbl.clear t


Gerd Stolpmann's avatar
Gerd Stolpmann committed
770
(* # 77 "src/oasis/PropList.ml" *)
gerd's avatar
gerd committed
771 772 773 774 775 776
  end


  module Schema =
  struct
    type ('ctxt, 'extra) value =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
777 778 779 780 781 782
      {
        get:   Data.t -> string;
        set:   Data.t -> ?context:'ctxt -> string -> unit;
        help:  (unit -> string) option;
        extra: 'extra;
      }
gerd's avatar
gerd committed
783 784

    type ('ctxt, 'extra) t =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
785 786 787 788 789 790
      {
        name:      name;
        fields:    (name, ('ctxt, 'extra) value) Hashtbl.t;
        order:     name Queue.t;
        name_norm: string -> string;
      }
gerd's avatar
gerd committed
791 792 793 794 795 796 797 798

    let create ?(case_insensitive=false) nm =
      {
        name      = nm;
        fields    = Hashtbl.create 13;
        order     = Queue.create ();
        name_norm =
          (if case_insensitive then
Gerd Stolpmann's avatar
Gerd Stolpmann committed
799
             OASISString.lowercase_ascii
gerd's avatar
gerd committed
800 801 802 803 804 805 806 807 808
           else
             fun s -> s);
      }

    let add t nm set get extra help =
      let key =
        t.name_norm nm
      in

Gerd Stolpmann's avatar
Gerd Stolpmann committed
809 810 811 812 813 814 815 816 817 818 819 820 821 822 823
      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
gerd's avatar
gerd committed
824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848

    let mem t nm =
      Hashtbl.mem t.fields nm

    let find t nm =
      try
        Hashtbl.find t.fields (t.name_norm nm)
      with Not_found ->
        raise (Unknown_field (nm, t.name))

    let get t data nm =
      (find t nm).get data

    let set t data nm ?context x =
      (find t nm).set
        data
        ?context
        x

    let fold f acc t =
      Queue.fold
        (fun acc k ->
           let v =
             find t k
           in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
849
           f acc k v.extra v.help)
gerd's avatar
gerd committed
850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866
        acc
        t.order

    let iter f t =
      fold
        (fun () -> f)
        ()
        t

    let name t =
      t.name
  end


  module Field =
  struct
    type ('ctxt, 'value, 'extra) t =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
867 868 869 870 871 872 873 874
      {
        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;
      }
gerd's avatar
gerd committed
875 876 877 878 879

    let new_id =
      let last_id =
        ref 0
      in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
880
      fun () -> incr last_id; !last_id
gerd's avatar
gerd committed
881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918

    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
      (* Default value container *)
      let v =
        ref None
      in

      (* If name is not given, create unique one *)
      let nm =
        match name with
          | Some s -> s
          | None -> Printf.sprintf "_anon_%d" (new_id ())
      in

      (* Last chance to get a value: the default *)
      let default () =
        match default with
          | Some d -> d
          | None -> raise (Not_set (nm, Some (s_ "no default value")))
      in

      (* Get data *)
      let get data =
        (* Get value *)
        try
          (Hashtbl.find data nm) ();
          match !v with
            | Some x -> x
            | None -> default ()
        with Not_found ->
          default ()
      in

      (* Set data *)
      let set data ?context x =
        let x =
          match update with
            | Some f ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
919 920 921 922 923 924
              begin
                try
                  f ?context (get data) x
                with Not_set _ ->
                  x
              end
gerd's avatar
gerd committed
925
            | None ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
926
              x
gerd's avatar
gerd committed
927
        in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
928 929 930 931
        Hashtbl.replace
          data
          nm
          (fun () -> v := Some x)
gerd's avatar
gerd committed
932 933 934 935 936 937
      in

      (* Parse string value, if possible *)
      let parse =
        match parse with
          | Some f ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
938
            f
gerd's avatar
gerd committed
939
          | None ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
940 941 942 943 944 945
            fun ?context s ->
              failwith
                (Printf.sprintf
                   (f_ "Cannot parse field '%s' when setting value %S")
                   nm
                   s)
gerd's avatar
gerd committed
946 947 948 949 950 951 952 953 954 955 956
      in

      (* Set data, from string *)
      let sets data ?context s =
        set ?context data (parse ?context s)
      in

      (* Output value as string, if possible *)
      let print =
        match print with
          | Some f ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
957
            f
gerd's avatar
gerd committed
958
          | None ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
959
            fun _ -> raise (No_printer nm)
gerd's avatar
gerd committed
960 961 962 963 964 965 966
      in

      (* Get data, as a string *)
      let gets data =
        print (get data)
      in

Gerd Stolpmann's avatar
Gerd Stolpmann committed
967 968 969 970 971 972 973
      begin
        match schema with
          | Some t ->
            Schema.add t nm sets gets extra help
          | None ->
            ()
      end;
gerd's avatar
gerd committed
974

Gerd Stolpmann's avatar
Gerd Stolpmann committed
975 976 977 978 979 980 981 982
      {
        set   = set;
        get   = get;
        sets  = sets;
        gets  = gets;
        help  = help;
        extra = extra;
      }
gerd's avatar
gerd committed
983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003

    let fset data t ?context x =
      t.set data ?context x

    let fget data t =
      t.get data

    let fsets data t ?context s =
      t.sets data ?context s

    let fgets data t =
      t.gets data
  end


  module FieldRO =
  struct
    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
      let fld =
        Field.create ?schema ?name ?parse ?print ?default ?update ?help extra
      in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1004
      fun data -> Field.fget data fld
gerd's avatar
gerd committed
1005 1006 1007 1008
  end
end

module OASISMessage = struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1009
(* # 22 "src/oasis/OASISMessage.ml" *)
gerd's avatar
gerd committed
1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025


  open OASISGettext
  open OASISContext


  let generic_message ~ctxt lvl fmt =
    let cond =
      if ctxt.quiet then
        false
      else
        match lvl with
          | `Debug -> ctxt.debug
          | `Info  -> ctxt.info
          | _ -> true
    in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1026 1027 1028 1029 1030 1031 1032
    Printf.ksprintf
      (fun str ->
         if cond then
           begin
             ctxt.printf lvl str
           end)
      fmt
gerd's avatar
gerd committed
1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052


  let debug ~ctxt fmt =
    generic_message ~ctxt `Debug fmt


  let info ~ctxt fmt =
    generic_message ~ctxt `Info fmt


  let warning ~ctxt fmt =
    generic_message ~ctxt `Warning fmt


  let error ~ctxt fmt =
    generic_message ~ctxt `Error fmt

end

module OASISVersion = struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1053
(* # 22 "src/oasis/OASISVersion.ml" *)
gerd's avatar
gerd committed
1054 1055 1056 1057 1058


  open OASISGettext


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1059
  type t = string
gerd's avatar
gerd committed
1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072


  type comparator =
    | VGreater of t
    | VGreaterEqual of t
    | VEqual of t
    | VLesser of t
    | VLesserEqual of t
    | VOr of  comparator * comparator
    | VAnd of comparator * comparator


  (* Range of allowed characters *)
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1073 1074 1075
  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
gerd's avatar
gerd committed
1076 1077 1078 1079 1080 1081 1082


  let rec version_compare v1 v2 =
    if v1 <> "" || v2 <> "" then
      begin
        (* Compare ascii string, using special meaning for version
         * related char
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1083
        *)
gerd's avatar
gerd committed
1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117
        let val_ascii c =
          if c = '~' then -1
          else if is_digit c then 0
          else if c = '\000' then 0
          else if is_alpha c then Char.code c
          else (Char.code c) + 256
        in

        let len1 = String.length v1 in
        let len2 = String.length v2 in

        let p = ref 0 in

        (** Compare ascii part *)
        let compare_vascii () =
          let cmp = ref 0 in
          while !cmp = 0 &&
                !p < len1 && !p < len2 &&
                not (is_digit v1.[!p] && is_digit v2.[!p]) do
            cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]);
            incr p
          done;
          if !cmp = 0 && !p < len1 && !p = len2 then
            val_ascii v1.[!p]
          else if !cmp = 0 && !p = len1 && !p < len2 then
            - (val_ascii v2.[!p])
          else
            !cmp
        in

        (** Compare digit part *)
        let compare_digit () =
          let extract_int v p =
            let start_p = !p in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129
            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
gerd's avatar
gerd committed
1130 1131 1132
          in
          let i1, tl1 = extract_int v1 (ref !p) in
          let i2, tl2 = extract_int v2 (ref !p) in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1133
          i1 - i2, tl1, tl2
gerd's avatar
gerd committed
1134 1135
        in

Gerd Stolpmann's avatar
Gerd Stolpmann committed
1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151
        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
gerd's avatar
gerd committed
1152
      end
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1153 1154 1155
    else begin
      0
    end
gerd's avatar
gerd committed
1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168


  let version_of_string str = str


  let string_of_version t = t


  let chop t =
    try
      let pos =
        String.rindex t '.'
      in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1169
      String.sub t 0 pos
gerd's avatar
gerd committed
1170 1171 1172 1173 1174 1175 1176
    with Not_found ->
      t


  let rec comparator_apply v op =
    match op with
      | VGreater cv ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1177
        (version_compare v cv) > 0
gerd's avatar
gerd committed
1178
      | VGreaterEqual cv ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1179
        (version_compare v cv) >= 0
gerd's avatar
gerd committed
1180
      | VLesser cv ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1181
        (version_compare v cv) < 0
gerd's avatar
gerd committed
1182
      | VLesserEqual cv ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1183
        (version_compare v cv) <= 0
gerd's avatar
gerd committed
1184
      | VEqual cv ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1185
        (version_compare v cv) = 0
gerd's avatar
gerd committed
1186
      | VOr (op1, op2) ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1187
        (comparator_apply v op1) || (comparator_apply v op2)
gerd's avatar
gerd committed
1188
      | VAnd (op1, op2) ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1189
        (comparator_apply v op1) && (comparator_apply v op2)
gerd's avatar
gerd committed
1190 1191 1192 1193 1194 1195 1196 1197 1198 1199


  let rec string_of_comparator =
    function
      | VGreater v  -> "> "^(string_of_version v)
      | VEqual v    -> "= "^(string_of_version v)
      | VLesser v   -> "< "^(string_of_version v)
      | VGreaterEqual v -> ">= "^(string_of_version v)
      | VLesserEqual v  -> "<= "^(string_of_version v)
      | VOr (c1, c2)  ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1200
        (string_of_comparator c1)^" || "^(string_of_comparator c2)
gerd's avatar
gerd committed
1201
      | VAnd (c1, c2) ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1202
        (string_of_comparator c1)^" && "^(string_of_comparator c2)
gerd's avatar
gerd committed
1203 1204 1205 1206 1207 1208 1209 1210 1211 1212


  let rec varname_of_comparator =
    let concat p v =
      OASISUtils.varname_concat
        p
        (OASISUtils.varname_of_string
           (string_of_version v))
    in
    function
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1213 1214 1215 1216 1217 1218 1219 1220 1221
      | 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)
gerd's avatar
gerd committed
1222 1223 1224 1225 1226


end

module OASISLicense = struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1227
(* # 22 "src/oasis/OASISLicense.ml" *)
gerd's avatar
gerd committed
1228 1229 1230 1231


  (** License for _oasis fields
      @author Sylvain Le Gall
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1232
  *)
gerd's avatar
gerd committed
1233 1234


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1235 1236
  type license = string
  type license_exception = string
gerd's avatar
gerd committed
1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256


  type license_version =
    | Version of OASISVersion.t
    | VersionOrLater of OASISVersion.t
    | NoVersion


  type license_dep_5_unit =
    {
      license:   license;
      excption:  license_exception option;
      version:   license_version;
    }


  type license_dep_5 =
    | DEP5Unit of license_dep_5_unit
    | DEP5Or of license_dep_5 list
    | DEP5And of license_dep_5 list
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1257

gerd's avatar
gerd committed
1258 1259 1260 1261 1262 1263 1264 1265 1266

  type t =
    | DEP5License of license_dep_5
    | OtherLicense of string (* URL *)


end

module OASISExpr = struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1267
(* # 22 "src/oasis/OASISExpr.ml" *)
gerd's avatar
gerd committed
1268 1269 1270


  open OASISGettext
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1271
  open OASISUtils
gerd's avatar
gerd committed
1272 1273


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1274 1275
  type test = string
  type flag = string
gerd's avatar
gerd committed
1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286


  type t =
    | EBool of bool
    | ENot of t
    | EAnd of t * t
    | EOr of t * t
    | EFlag of flag
    | ETest of test * string


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1287
  type 'a choices = (t * 'a) list
gerd's avatar
gerd committed
1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357


  let eval var_get t =
    let rec eval' =
      function
        | EBool b ->
            b

        | ENot e ->
            not (eval' e)

        | EAnd (e1, e2) ->
            (eval' e1) && (eval' e2)

        | EOr (e1, e2) ->
            (eval' e1) || (eval' e2)

        | EFlag nm ->
            let v =
              var_get nm
            in
              assert(v = "true" || v = "false");
              (v = "true")

        | ETest (nm, vl) ->
            let v =
              var_get nm
            in
              (v = vl)
    in
      eval' t


  let choose ?printer ?name var_get lst =
    let rec choose_aux =
      function
        | (cond, vl) :: tl ->
            if eval var_get cond then
              vl
            else
              choose_aux tl
        | [] ->
            let str_lst =
              if lst = [] then
                s_ "<empty>"
              else
                String.concat
                  (s_ ", ")
                  (List.map
                     (fun (cond, vl) ->
                        match printer with
                          | Some p -> p vl
                          | None -> s_ "<no printer>")
                     lst)
            in
              match name with
                | Some nm ->
                    failwith
                      (Printf.sprintf
                         (f_ "No result for the choice list '%s': %s")
                         nm str_lst)
                | None ->
                    failwith
                      (Printf.sprintf
                         (f_ "No result for a choice list: %s")
                         str_lst)
    in
      choose_aux (List.rev lst)


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474
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
gerd's avatar
gerd committed
1475 1476


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1477
  type t = Templater.t
gerd's avatar
gerd committed
1478 1479


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1480 1481 1482 1483 1484 1485 1486 1487 1488 1489
  let env ~modul () =
    {
      Templater.
      variables = MapString.of_list ["module", modul];
      functions = MapString.of_list
          [
            "capitalize_file", OASISUnixPath.capitalize_file;
            "uncapitalize_file", OASISUnixPath.uncapitalize_file;
          ];
    }
gerd's avatar
gerd committed
1490

Gerd Stolpmann's avatar
Gerd Stolpmann committed
1491 1492 1493 1494 1495
  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
gerd's avatar
gerd committed
1496 1497


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1498
  let to_string t = t.Templater.origin
gerd's avatar
gerd committed
1499 1500


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1501
end
gerd's avatar
gerd committed
1502

Gerd Stolpmann's avatar
Gerd Stolpmann committed
1503 1504
module OASISTypes = struct
(* # 22 "src/oasis/OASISTypes.ml" *)
gerd's avatar
gerd committed
1505 1506


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517
  type name          = string
  type package_name  = string
  type url           = string
  type unix_dirname  = string
  type unix_filename = string (* TODO: replace everywhere. *)
  type host_dirname  = string (* TODO: replace everywhere. *)
  type host_filename = string (* TODO: replace everywhere. *)
  type prog          = string
  type arg           = string
  type args          = string list
  type command_line  = (prog * arg list)
gerd's avatar
gerd committed
1518 1519


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1520 1521
  type findlib_name = string
  type findlib_full = string
gerd's avatar
gerd committed
1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552


  type compiled_object =
    | Byte
    | Native
    | Best


  type dependency =
    | FindlibPackage of findlib_full * OASISVersion.comparator option
    | InternalLibrary of name


  type tool =
    | ExternalTool of name
    | InternalExecutable of name


  type vcs =
    | Darcs
    | Git
    | Svn
    | Cvs
    | Hg
    | Bzr
    | Arch
    | Monotone
    | OtherVCS of url


  type plugin_kind =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1553 1554 1555 1556 1557 1558 1559
    [  `Configure
    | `Build
    | `Doc
    | `Test
    | `Install
    | `Extra
    ]
gerd's avatar
gerd committed
1560 1561 1562


  type plugin_data_purpose =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574
    [  `Configure
    | `Build
    | `Install
    | `Clean
    | `Distclean
    | `Install
    | `Uninstall
    | `Test
    | `Doc
    | `Extra
    | `Other of string
    ]
gerd's avatar
gerd committed
1575 1576


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1577
  type 'a plugin = 'a * name * OASISVersion.t option
gerd's avatar
gerd committed
1578 1579 1580 1581 1582 1583 1584 1585


  type all_plugin = plugin_kind plugin


  type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list


Gerd Stolpmann's avatar
Gerd Stolpmann committed
1586
  type 'a conditional = 'a OASISExpr.choices
gerd's avatar
gerd committed
1587 1588 1589


  type custom =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1590 1591 1592 1593
    {
      pre_command:  (command_line option) conditional;
      post_command: (command_line option) conditional;
    }
gerd's avatar
gerd committed
1594 1595 1596


  type common_section =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1597 1598 1599 1600 1601
    {
      cs_name: name;
      cs_data: PropList.Data.t;
      cs_plugin_data: plugin_data;
    }
gerd's avatar
gerd committed
1602 1603 1604


  type build_section =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623
    {
      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;
    }
gerd's avatar
gerd committed
1624 1625 1626


  type library =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1627 1628 1629 1630 1631 1632 1633 1634 1635
    {
      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;
    }
gerd's avatar
gerd committed
1636 1637 1638


  type object_ =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1639 1640 1641 1642 1643
    {
      obj_modules:            string list;
      obj_findlib_fullname:   findlib_name list option;
      obj_findlib_directory:  unix_dirname option;
    }
gerd's avatar
gerd committed
1644 1645 1646


  type executable =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1647 1648 1649 1650
    {
      exec_custom:          bool;
      exec_main_is:         unix_filename;
    }
gerd's avatar
gerd committed
1651 1652 1653


  type flag =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1654 1655 1656 1657
    {
      flag_description:  string option;
      flag_default:      bool conditional;
    }
gerd's avatar
gerd committed
1658 1659 1660


  type source_repository =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1661 1662 1663 1664 1665 1666 1667 1668 1669
    {
      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;
    }
gerd's avatar
gerd committed
1670 1671 1672


  type test =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1673 1674 1675 1676 1677 1678 1679 1680
    {
      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;
    }
gerd's avatar
gerd committed
1681 1682 1683


  type doc_format =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1684
    | HTML of unix_filename (* TODO: source filename. *)
gerd's avatar
gerd committed
1685 1686 1687
    | DocText
    | PDF
    | PostScript
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1688
    | Info of unix_filename (* TODO: source filename. *)
gerd's avatar
gerd committed
1689 1690 1691 1692 1693
    | DVI
    | OtherDoc


  type doc =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707
    {
      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;
    }
gerd's avatar
gerd committed
1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720


  type section =
    | Library    of common_section * build_section * library
    | Object     of common_section * build_section * object_
    | Executable of common_section * build_section * executable
    | Flag       of common_section * flag
    | SrcRepo    of common_section * source_repository
    | Test       of common_section * test
    | Doc        of common_section * doc


  type section_kind =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1721
    [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ]
gerd's avatar
gerd committed
1722 1723 1724


  type package =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764
    {
      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;
    }
gerd's avatar
gerd committed
1765 1766 1767 1768 1769


end

module OASISFeatures = struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1770
(* # 22 "src/oasis/OASISFeatures.ml" *)
gerd's avatar
gerd committed
1771 1772 1773 1774 1775 1776 1777 1778 1779

  open OASISTypes
  open OASISUtils
  open OASISGettext
  open OASISVersion

  module MapPlugin =
    Map.Make
      (struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1780 1781 1782
        type t = plugin_kind * name
        let compare = Pervasives.compare
      end)
gerd's avatar
gerd committed
1783 1784 1785 1786

  module Data =
  struct
    type t =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1787 1788 1789 1790 1791 1792
      {
        oasis_version: OASISVersion.t;
        plugin_versions: OASISVersion.t option MapPlugin.t;
        alpha_features: string list;
        beta_features: string list;
      }
gerd's avatar
gerd committed
1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809

    let create oasis_version alpha_features beta_features =
      {
        oasis_version = oasis_version;
        plugin_versions = MapPlugin.empty;
        alpha_features = alpha_features;
        beta_features = beta_features
      }

    let of_package pkg =
      create
        pkg.OASISTypes.oasis_version
        pkg.OASISTypes.alpha_features
        pkg.OASISTypes.beta_features

    let add_plugin (plugin_kind, plugin_name, plugin_version) t =
      {t with
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1810 1811 1812 1813
         plugin_versions = MapPlugin.add
             (plugin_kind, plugin_name)
             plugin_version
             t.plugin_versions}
gerd's avatar
gerd committed
1814 1815 1816 1817 1818 1819 1820 1821

    let plugin_version plugin_kind plugin_name t =
      MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions

    let to_string t =
      Printf.sprintf
        "oasis_version: %s; alpha_features: %s; beta_features: %s; \
         plugins_version: %s"
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1822
        (OASISVersion.string_of_version (t:t).oasis_version)
gerd's avatar
gerd committed
1823 1824 1825 1826 1827 1828
        (String.concat ", " t.alpha_features)
        (String.concat ", " t.beta_features)
        (String.concat ", "
           (MapPlugin.fold
              (fun (_, plg) ver_opt acc ->
                 (plg^
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1829 1830 1831 1832
                    (match ver_opt with
                      | Some v ->
                        " "^(OASISVersion.string_of_version v)
                      | None -> ""))
gerd's avatar
gerd committed
1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846
                 :: acc)
              t.plugin_versions []))
  end

  type origin =
    | Field of string * string
    | Section of string
    | NoOrigin

  type stage = Alpha | Beta


  let string_of_stage =
    function
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1847 1848
    | Alpha -> "alpha"
    | Beta -> "beta"
gerd's avatar
gerd committed
1849 1850 1851 1852


  let field_of_stage =
    function
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1853 1854
    | Alpha -> "AlphaFeatures"
    | Beta -> "BetaFeatures"
gerd's avatar
gerd committed
1855 1856 1857 1858

  type publication = InDev of stage | SinceVersion of OASISVersion.t

  type t =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1859 1860 1861 1862 1863 1864
    {
      name: string;
      plugin: all_plugin option;
      publication: publication;
      description: unit -> string;
    }
gerd's avatar
gerd committed
1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877

  (* TODO: mutex protect this. *)
  let all_features = Hashtbl.create 13


  let since_version ver_str = SinceVersion (version_of_string ver_str)
  let alpha = InDev Alpha
  let beta = InDev Beta


  let to_string t =
    Printf.sprintf
      "feature: %s; plugin: %s; publication: %s"
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1878
      (t:t).name
gerd's avatar
gerd committed
1879
      (match t.plugin with
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1880 1881
       | None -> "<none>"
       | Some (_, nm, _) -> nm)
gerd's avatar
gerd committed
1882
      (match t.publication with
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1883 1884
       | InDev stage -> string_of_stage stage
       | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver))
gerd's avatar
gerd committed
1885 1886 1887 1888 1889

  let data_check t data origin =
    let no_message = "no message" in

    let check_feature features stage =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1890
      let has_feature = List.mem (t:t).name features in
gerd's avatar
gerd committed
1891
      if not has_feature then
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906
        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
gerd's avatar
gerd committed
1907 1908 1909 1910 1911 1912 1913 1914 1915
      else
        None
    in

    let version_is_good ~min_version version fmt =
      let version_is_good =
        OASISVersion.comparator_apply
          version (OASISVersion.VGreaterEqual min_version)
      in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1916 1917 1918
      Printf.ksprintf
        (fun str -> if version_is_good then None else Some str)
        fmt
gerd's avatar
gerd committed
1919 1920 1921
    in

    match origin, t.plugin, t.publication with
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937
    | _, _, 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 =
gerd's avatar
gerd committed
1938
            try
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965
              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
gerd's avatar
gerd committed
1966

Gerd Stolpmann's avatar
Gerd Stolpmann committed
1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980
    | 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 =
gerd's avatar
gerd committed
1981
            try
Gerd Stolpmann's avatar
Gerd Stolpmann committed
1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008
              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
gerd's avatar
gerd committed
2009

Gerd Stolpmann's avatar
Gerd Stolpmann committed
2010 2011
    | NoOrigin, None, SinceVersion min_version ->
      version_is_good ~min_version data.Data.oasis_version "%s" no_message
gerd's avatar
gerd committed
2012

Gerd Stolpmann's avatar
Gerd Stolpmann committed
2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025
    | 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
gerd's avatar
gerd committed
2026 2027 2028 2029


  let data_assert t data origin =
    match data_check t data origin with
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2030 2031
    | None -> ()
    | Some str -> failwith str
gerd's avatar
gerd committed
2032 2033 2034 2035


  let data_test t data =
    match data_check t data NoOrigin with
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2036 2037
    | None -> true
    | Some _ -> false
gerd's avatar
gerd committed
2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056


  let package_test t pkg =
    data_test t (Data.of_package pkg)


  let create ?plugin name publication description =
    let () =
      if Hashtbl.mem all_features name then
        failwithf "Feature '%s' is already declared." name
    in
    let t =
      {
        name = name;
        plugin = plugin;
        publication = publication;
        description = description;
      }
    in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2057 2058
    Hashtbl.add all_features name t;
    t
gerd's avatar
gerd committed
2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086


  let get_stage name =
    try
      (Hashtbl.find all_features name).publication
    with Not_found ->
      failwithf (f_ "Feature %s doesn't exist.") name


  let list () =
    Hashtbl.fold (fun _ v acc -> v :: acc) all_features []

  (*
   * Real flags.
   *)


  let features =
    create "features_fields"
      (since_version "0.4")
      (fun () ->
         s_ "Enable to experiment not yet official features.")


  let flag_docs =
    create "flag_docs"
      (since_version "0.3")
      (fun () ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2087
         s_ "Make building docs require '-docs' flag at configure.")
gerd's avatar
gerd committed
2088 2089 2090 2091 2092 2093


  let flag_tests =
    create "flag_tests"
      (since_version "0.3")
      (fun () ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2094
         s_ "Make running tests require '-tests' flag at configure.")
gerd's avatar
gerd committed
2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118


  let pack =
    create "pack"
      (since_version "0.3")
      (fun () ->
         s_ "Allow to create packed library.")


  let section_object =
    create "section_object" beta
      (fun () ->
         s_ "Implement an object section.")


  let dynrun_for_release =
    create "dynrun_for_release" alpha
      (fun () ->
         s_ "Make '-setup-update dynamic' suitable for releasing project.")


  let compiled_setup_ml =
    create "compiled_setup_ml" alpha
      (fun () ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2119
         s_ "Compile the setup.ml and speed-up actions done with it.")
gerd's avatar
gerd committed
2120 2121 2122 2123

  let disable_oasis_section =
    create "disable_oasis_section" alpha
      (fun () ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2124 2125
         s_ "Allow the OASIS section comments and digests to be omitted in \
             generated files.")
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2126 2127 2128 2129 2130 2131 2132

  let no_automatic_syntax =
    create "no_automatic_syntax" alpha
      (fun () ->
         s_ "Disable the automatic inclusion of -syntax camlp4o for packages \
             that matches the internal heuristic (if a dependency ends with \
             a .syntax or is a well known syntax).")
gerd's avatar
gerd committed
2133

Gerd Stolpmann's avatar
Gerd Stolpmann committed
2134 2135 2136 2137 2138
  let findlib_directory =
    create "findlib_directory" beta
      (fun () ->
         s_ "Allow to install findlib libraries in sub-directories of the target \
            findlib directory.")
gerd's avatar
gerd committed
2139

Gerd Stolpmann's avatar
Gerd Stolpmann committed
2140 2141 2142 2143
  let findlib_extra_files =
    create "findlib_extra_files" beta
      (fun () ->
         s_ "Allow to install extra files for findlib libraries.")
gerd's avatar
gerd committed
2144

Gerd Stolpmann's avatar
Gerd Stolpmann committed
2145 2146 2147 2148
  let source_patterns =
    create "source_patterns" alpha
      (fun () ->
         s_ "Customize mapping between module name and source file.")
gerd's avatar
gerd committed
2149 2150 2151
end

module OASISSection = struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2152
(* # 22 "src/oasis/OASISSection.ml" *)
gerd's avatar
gerd committed
2153 2154 2155 2156 2157 2158 2159 2160


  open OASISTypes


  let section_kind_common =
    function
      | Library (cs, _, _) ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2161
        `Library, cs
gerd's avatar
gerd committed
2162
      | Object (cs, _, _) ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2163
        `Object, cs
gerd's avatar
gerd committed
2164
      | Executable (cs, _, _) ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2165
        `Executable, cs
gerd's avatar
gerd committed
2166
      | Flag (cs, _) ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2167
        `Flag, cs
gerd's avatar
gerd committed
2168
      | SrcRepo (cs, _) ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2169
        `SrcRepo, cs
gerd's avatar
gerd committed
2170
      | Test (cs, _) ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2171
        `Test, cs
gerd's avatar
gerd committed
2172
      | Doc (cs, _) ->
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2173
        `Doc, cs
gerd's avatar
gerd committed
2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191


  let section_common sct =
    snd (section_kind_common sct)


  let section_common_set cs =
    function
      | Library (_, bs, lib)     -> Library (cs, bs, lib)
      | Object (_, bs, obj)      -> Object (cs, bs, obj)
      | Executable (_, bs, exec) -> Executable (cs, bs, exec)
      | Flag (_, flg)            -> Flag (cs, flg)
      | SrcRepo (_, src_repo)    -> SrcRepo (cs, src_repo)
      | Test (_, tst)            -> Test (cs, tst)
      | Doc (_, doc)             -> Doc (cs, doc)


  (** Key used to identify section
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2192
  *)
gerd's avatar
gerd committed
2193 2194 2195 2196
  let section_id sct =
    let k, cs =
      section_kind_common sct
    in
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208
    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"
gerd's avatar
gerd committed
2209 2210 2211


  let string_of_section sct =
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2212 2213
    let k, nm = section_id sct in
    (string_of_section_kind k)^" "^nm
gerd's avatar
gerd committed
2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245


  let section_find id scts =
    List.find
      (fun sct -> id = section_id sct)
      scts


  module CSection =
  struct
    type t = section

    let id = section_id

    let compare t1 t2 =
      compare (id t1) (id t2)

    let equal t1 t2 =
      (id t1) = (id t2)

    let hash t =
      Hashtbl.hash (id t)
  end


  module MapSection = Map.Make(CSection)
  module SetSection = Set.Make(CSection)


end

module OASISBuildSection = struct
Gerd Stolpmann's avatar
Gerd Stolpmann committed
2246 2247 2248 2249 2250 2251 2252 2253 2254 2255