(*---------------------------------------------------------------------------
   Copyright (c) 2011-2012 Daniel C. Bünzli. All rights reserved.
   Distributed under a BSD3 license, see license at the end of the file.
   cmdliner release 0.9.3
  ---------------------------------------------------------------------------*)

(* Invalid_arg strings *)

let err_argv = "argv array must have at least one element"
let err_not_opt = "Option argument without name"
let err_not_pos = "Positional argument with a name" 
let err_help s = "term error, help requested for unknown command " ^ s

(* A few useful definitions. *)

let rev_compare n n' = compare n' n
let str = Printf.sprintf 
let pr = Format.fprintf 
let pr_str = Format.pp_print_string 
let pr_char = Format.pp_print_char
let str_of_pp pp v = pp Format.str_formatter v; Format.flush_str_formatter ()
let quote s = str "`%s'" s
let pr_white_str spaces ppf s =  (* spaces and new lines with Format's funs *)
  let left = ref 0 and right = ref 0 and len = String.length s in 
  let flush () = 
    Format.pp_print_string ppf (String.sub s !left (!right - !left)); 
    incr right; left := !right;			     
  in
  while (!right <> len) do 
    if s.[!right] = '\n' then (flush (); Format.pp_force_newline ppf ()) else
    if spaces && s.[!right] = ' ' then (flush (); Format.pp_print_space ppf ())
    else incr right;
  done;
  if !left <> len then flush ()

let pr_text = pr_white_str true
let pr_lines = pr_white_str false
let pr_to_temp_file pr v = try
  let exec = Filename.basename Sys.argv.(0) in
  let file, oc = Filename.open_temp_file exec "out" in
  let ppf = Format.formatter_of_out_channel oc in
  pr ppf v; Format.pp_print_flush ppf (); close_out oc; 
  Some file
with Sys_error _ -> None

(* Tries. This implementation also maps any non ambiguous prefix of a
   key to its value. *)
    
module Trie : sig 
  type 'a t
  val empty : 'a t 
  val is_empty : 'a t -> bool
  val add : 'a t -> string -> 'a -> 'a t
  val find : 'a t -> string -> [ `Ok of 'a | `Ambiguous | `Not_found ]
  val ambiguities : 'a t -> string -> string list
  val of_list : (string * 'a) list -> 'a t
end = struct  
  module Cmap = Map.Make (Char)                           (* character maps. *)
  type 'a value =                         (* type for holding a bound value. *)
    | Pre of 'a                    (* value is bound by the prefix of a key. *)
    | Key of 'a                          (* value is bound by an entire key. *)
    | Amb                     (* no value bound because of ambiguous prefix. *)
    | Nil                            (* not bound (only for the empty trie). *)

  type 'a t = { v : 'a value; succs : 'a t Cmap.t }
  let empty = { v = Nil; succs = Cmap.empty }
  let is_empty t = t = empty

  (* N.B. If we replace a non-ambiguous key, it becomes ambiguous but it's
     not important for our use. Also the following is not tail recursive but 
     the stack is bounded by key length. *)
  let add t k d = 
    let rec aux t k len i d pre_d =
      if i = len then { v = Key d; succs = t.succs } else
      let v = match t.v with
      | Amb | Pre _ -> Amb | Key _ as v -> v | Nil -> pre_d
      in
      let succs = 
	let t' = try Cmap.find k.[i] t.succs with Not_found -> empty in
	Cmap.add k.[i] (aux t' k len (i + 1) d pre_d) t.succs
      in
      { v; succs }
    in
    aux t k (String.length k) 0 d (Pre d (* allocate less *)) 
      
  let find_node t k = 
    let rec aux t k len i = 
      if i = len then t else
      aux (Cmap.find k.[i] t.succs) k len (i + 1) 
    in
    aux t k (String.length k) 0
      
  let find t k = 
    try match (find_node t k).v with 
    | Key v | Pre v -> `Ok v | Amb -> `Ambiguous | Nil -> `Not_found
    with Not_found -> `Not_found
      
  let ambiguities t p =                        (* ambiguities of [p] in [t]. *)
    try
      let t = find_node t p in
      match t.v with
      | Key _ | Pre _ | Nil -> []
      | Amb -> 
	  let add_char s c = s ^ (String.make 1 c) in 
	  let rem_char s = String.sub s 0 ((String.length s) - 1) in 
	  let to_list m = Cmap.fold (fun k t acc -> (k,t) :: acc) m [] in
	  let rec aux acc p = function
	    | ((c, t) :: succs) :: rest ->
		let p' = add_char p c in
		let acc' = match t.v with 
		| Pre _ | Amb -> acc 
		| Key _ -> (p' :: acc) 
		| Nil -> assert false
		in
		aux acc' p' ((to_list t.succs) :: succs :: rest)
	    | [] :: [] -> acc
	    | [] :: rest -> aux acc (rem_char p) rest
	    | [] -> assert false
	  in
	  aux [] p (to_list t.succs :: [])
    with Not_found -> []
	
  let of_list l = List.fold_left (fun t (s, v) -> add t s v) empty l
end

(* The following types keep untyped information about arguments and
   terms. This data is used to parse the command line, report errors
   and format man page information. *)

type absence =        (* what happens if the argument is absent from the cl. *)
  | Error                                           (* an error is reported. *)
  | Val of string                (* if <> "", takes the given default value. *)

type opt_kind =                              (* kinds of optional arguments. *)
  | Flag                                      (* just a flag, without value. *)
  | Opt                                                (* value is required. *)
  | Opt_vopt of string     (* option value is optional, takes given default. *)

type pos_kind =                            (* kinds of positional arguments. *)
  | All                                         (* all positional arguments. *)
  | Nth of bool * int                                  (* specific position. *)
  | Left of bool * int                (* all args on the left of a position. *)
  | Right of bool * int              (* all args on the right of a position. *)

type arg_info =                (* information about a command line argument. *)
    { id : int;                               (* unique id for the argument. *)
      absent : absence;                              (* behaviour if absent. *)
      doc : string;                                                 (* help. *)
      docv : string;              (* variable name for the argument in help. *)
      docs : string;                  (* title of help section where listed. *)
      p_kind : pos_kind;                             (* positional arg kind. *)
      o_kind : opt_kind;                               (* optional arg kind. *)
      o_names : string list;                        (* names (for opt args). *)
      o_all : bool; }                          (* repeatable (for opt args). *)

let arg_id () = Oo.id (object end)                      (* thread-safe UIDs. *)
let is_opt a = a.o_names <> []
let is_pos a = a.o_names = []

module Amap = Map.Make                                     (* arg info maps. *)
    (struct type t = arg_info let compare a a' = compare a.id a'.id end)

type arg =        (* unconverted argument data as found on the command line. *)
  | O of (int * string * (string option)) list (* (pos, name, value) of opt. *)
  | P of string list

type cmdline = arg Amap.t      (* command line, maps arg_infos to arg value. *)

type man_block = [                                 (* block of manpage text. *)
  | `S of string | `P of string | `I of string * string | `Noblank ] 

type term_info = 
    { name : string;                                    (* name of the term. *)
      version : string option;                   (* version (for --version). *)
      tdoc : string;                        (* one line description of term. *)
      tdocs : string;       (* title of man section where listed (commands). *) 
      sdocs : string;    (* standard options, title of section where listed. *)
      man : man_block list; }                              (* man page text. *)

type eval_info =                (* information about the evaluation context. *)
    { term : term_info * arg_info list;             (* term being evaluated. *)
      main : term_info * arg_info list;                        (* main term. *)
      choices : (term_info * arg_info list) list}       (* all term choices. *)

let eval_kind ei =                       (* evaluation with multiple terms ? *) 
  if ei.choices = [] then `Simple else
  if (fst ei.term) == (fst ei.main) then `M_main else `M_choice

module Manpage = struct
  type title = string * int * string * string * string
  type block = man_block
  type t = title * block list

  let p_indent = 7                                  (* paragraph indentation. *)
  let l_indent = 4                                      (* label indentation. *)
  let escape subst esc buf s =
    let subst s = 
      let len = String.length s in 
      if not (len > 1 && s.[1] = ',') then (subst s) else
      if len = 2 then "" else
      esc s.[0] (String.sub s 2 (len - 2))
    in
    Buffer.clear buf; Buffer.add_substitute buf subst s; 
    let s = Buffer.contents buf in (* twice for $(i,$(mname)). *)
    Buffer.clear buf; Buffer.add_substitute buf subst s; 
    Buffer.contents buf
    

  let pr_tokens ?(groff = false) ppf s = 
    let is_space = function ' ' | '\n' | '\r' | '\t' -> true | _ -> false in
    let len = String.length s in
    let i = ref 0 in
    try while (true) do 
      while (!i < len && is_space s.[!i]) do incr i done;
      let start = !i in
      if start = len then raise Exit;
      while (!i < len && not (is_space s.[!i]) && not (s.[!i] = '-')) do 
	incr i 
      done;
      pr_str ppf (String.sub s start (!i - start));
      if !i = len then raise Exit;
      if s.[!i] = '-' then
	(incr i; if groff then pr_str ppf "\\-" else pr_char ppf '-');
      if (!i < len && is_space s.[!i]) then 
	(if groff then pr_char ppf ' ' else Format.pp_print_space ppf ())
    done with Exit -> ()
   	
  (* Plain text output *)

  let plain_esc c s = match c with 'g' -> "" (* groff specific *) | _ ->  s
  let pr_indent ppf c = for i = 1 to c do pr_char ppf ' ' done
  let pr_plain_blocks subst ppf ts = 
    let buf = Buffer.create 1024 in
    let escape t = escape subst plain_esc buf t in
    let pr_tokens ppf t = pr_tokens ppf (escape t) in
    let rec aux = function
      | [] -> ()
      | t :: ts -> 
	  begin match t with 
	  | `Noblank -> ()
	  | `P s -> pr ppf "%a@[%a@]@," pr_indent p_indent pr_tokens s
	  | `S s -> pr ppf "%a" pr_tokens s
	  | `I (label, s) ->
	      let label = escape label in
	      let ll = String.length label in 
	      pr ppf "@[%a@[%a@]" pr_indent p_indent pr_tokens label;
	      if s = "" then () else
	      if ll < l_indent then 
		pr ppf "%a@[%a@]@]@," pr_indent (l_indent - ll) pr_tokens s
	      else
		pr ppf "@\n%a@[%a@]@]@," 
		  pr_indent (p_indent + l_indent) pr_tokens s
	  end;
	  begin match ts with
	  | `Noblank :: ts -> aux ts
	  | ts -> Format.pp_print_cut ppf (); aux ts
	  end
    in
    aux ts
      
  let pr_plain_page subst ppf (_, text) = 
    pr ppf "@[<v>%a@]" (pr_plain_blocks subst) text
      
  (* Groff output *)

  let groff_esc c s = match c with 
  | 'i' -> (str "\\fI%s\\fR" s)
  | 'b' -> (str "\\fB%s\\fR" s)
  | 'p' -> "" (* plain text specific *)
  | _ -> s

  let pr_groff_blocks subst ppf text = 
    let buf = Buffer.create 1024 in
    let escape t = escape subst groff_esc buf t in
    let pr_tokens ppf t = pr_tokens ~groff:true ppf (escape t) in
    let pr_block = function 
      | `P s -> pr ppf "@\n.P@\n%a" pr_tokens s
      | `S s -> pr ppf "@\n.SH %a" pr_tokens s
      | `Noblank -> pr ppf "@\n.sp -1"
      | `I (l, s) -> pr ppf "@\n.TP 4@\n%a@\n%a" pr_tokens l pr_tokens s
    in 
    List.iter pr_block text
      
  let pr_groff_page subst ppf ((n, s, a1, a2, a3), t) =
    pr ppf ".\\\" Pipe this output to groff -man -Tutf8 | less@\n\
            .\\\"@\n\
            .TH \"%s\" %d \"%s\" \"%s\" \"%s\"@\n\
            .\\\" Disable hyphenantion and ragged-right@\n\
            .nh@\n\
	    .ad l\
	    %a@?" 
      n s a1 a2 a3 (pr_groff_blocks subst) t

  (* Printing to a pager *)

  let find_cmd cmds =
    let cmd c = Sys.command (str "type %s 1>/dev/null 2>/dev/null" c) = 0 in
    try Some (List.find cmd cmds) with Not_found -> None
	
  let pr_to_pager print ppf v = 
    let pager = 
      let cmds = ["less"; "more"] in
      let cmds = try (Sys.getenv "PAGER") :: cmds with Not_found -> cmds in
      find_cmd cmds
    in
    match pager with 
    | None -> print `Plain ppf v
    | Some pager -> 
	let cmd = match (find_cmd ["groff"; "nroff"]) with 
	| None ->
	    begin match pr_to_temp_file (print `Plain) v with 
	    | None -> None
	    | Some f -> Some (str "%s < %s" pager f)
	    end
	| Some c ->
	    begin match pr_to_temp_file (print `Groff) v with
	    | None -> None 
	    | Some f -> 
                (* TODO use -Tutf8, but annoyingly maps U+002D to U+2212. *)
		let xroff = if c = "groff" then c ^ " -Tascii -P-c" else c in
		Some (str "%s -man < %s | %s" xroff f pager)
	    end
	in
	match cmd with 
	| None -> print `Plain ppf v
	| Some cmd -> if (Sys.command cmd) <> 0 then print `Plain ppf v

  let rec print ?(subst = fun x -> x) fmt ppf page = match fmt with
  | `Pager -> pr_to_pager (print ~subst) ppf page 
  | `Plain -> pr_plain_page subst ppf page
  | `Groff -> pr_groff_page subst ppf page
end

module Help = struct
  let invocation ?(sep = ' ') ei = match eval_kind ei with 
  | `Simple | `M_main -> (fst ei.main).name 
  | `M_choice -> str "%s%c%s" (fst ei.main).name sep (fst ei.term).name

  let title ei =
    let prog = String.capitalize (fst ei.main).name in 
    let name = String.uppercase (invocation ~sep:'-' ei) in 
    let left_footer = prog ^ match (fst ei.main).version with 
    | None -> "" | Some v -> str " %s" v
    in
    let center_header = str "%s Manual" prog in 
    name, 1, "", left_footer, center_header

  let name_section ei =
    let tdoc d = if d = "" then "" else (str " - %s" d) in
    [`S "NAME"; `P (str "%s%s" (invocation ~sep:'-' ei) 
		      (tdoc (fst ei.term).tdoc)); ]

  let synopsis ei = match eval_kind ei with
  | `M_main -> str "$(b,%s) $(i,COMMAND) ..." (invocation ei)
  | `Simple | `M_choice -> 
      let rev_cmp (p, _) (p', _) = match p', p with        (* best effort. *)
      | p, All -> -1 | All, p -> 1
      | Left _, Right _ -> -1 | Right _, Left _ -> 1
      | Left (false, k), Nth (false, k')
      | Nth (false, k), Nth (false, k')
      | Nth (false, k), Right (false, k') -> if k <= k' then -1 else 1
      | Nth (false, k), Left (false, k')
      | Right (false, k), Nth (false, k') -> if k >= k' then 1 else -1
      | Left (true, k), Nth (true, k')
      | Nth (true, k), Nth (true, k')
      | Nth (true, k), Right (true, k') -> if k >= k' then -1 else 1
      | Nth (true, k), Left (true, k')
      | Right (true, k), Nth (true, k') -> if k <= k' then 1 else -1 
      | p, p' -> compare p p'
      in
      let rec format_pos acc = function
	| a :: al ->
	    if is_opt a then format_pos acc al else
	    let v = if a.docv = "" then "$(i,ARG)" else str "$(i,%s)" a.docv in
	    let v = if a.absent = Error then str "%s" v else str "[%s]" v in
	    let v = v ^ match a.p_kind with Nth _ -> "" | _ -> "..." in 
	    format_pos ((a.p_kind, v) :: acc) al
	| [] -> acc
      in
      let args = List.sort rev_cmp (format_pos [] (snd ei.term)) in
      let args = String.concat " " (List.rev_map snd args) in 
      str "$(b,%s) [$(i,OPTION)]... %s" (invocation ei) args 
	
  let get_synopsis_section ei =
    let rec extract_synopsis syn = function   
    | `S _ :: _ as man -> List.rev syn, man
    |  block :: rest -> extract_synopsis (block :: syn) rest
    | [] -> List.rev syn, []
    in
    match (fst ei.term).man with 
    | `S "SYNOPSIS" as s :: rest -> extract_synopsis [s] rest (* user-defined *)
    | man -> [ `S "SYNOPSIS"; `P (synopsis ei); ], man           (* automatic *)

  let make_arg_label a = 
    if is_pos a then str "$(i,%s)" a.docv else
    let fmt_name var = match a.o_kind with 
    | Flag -> fun n -> str "$(b,%s)" n
    | Opt -> 
	fun n -> 
	  if String.length n > 2 then str "$(b,%s)=$(i,%s)" n var else 
	  str "$(b,%s) $(i,%s)" n var
    | Opt_vopt _ -> 
	fun n -> 
	  if String.length n > 2 then str "$(b,%s)[=$(i,%s)]" n var else
	  str "$(b,%s) [$(i,%s)]" n var
    in
    let var = if a.docv = "" then "VAL" else a.docv in
    let names = List.sort compare a.o_names in
    let s = String.concat ", " (List.rev_map (fmt_name var) names) in
    s
      
  let make_arg_items ei =
    let buf = Buffer.create 200 in 
    let subst_docv docv d = 
      let subst = function "docv" -> str "$(i,%s)" docv | s -> str "$(%s)" s in
      Buffer.clear buf; Buffer.add_substitute buf subst d; Buffer.contents buf
    in
    let rev_cmp a' a =
      let c = compare a.docs a'.docs in 
      if c <> 0 then c else
      match is_opt a, is_opt a' with 
      | true, true ->
	  let key names = 
	    let k = String.lowercase (List.hd (List.sort rev_compare names)) in
	    if k.[1] = '-' then String.sub k 1 (String.length k - 1) else k 
	  in
	  compare (key a.o_names) (key a'.o_names)
      | false, false -> 
	  compare (String.lowercase a.docv) (String.lowercase a'.docv)
      | true, false -> -1
      | false, true -> 1
    in
    let format a = 
      let absent = match a.absent with
      | Val "" | Error -> "" | Val v -> str "absent=%s" v
      in
      let optvopt = match a.o_kind with Opt_vopt v -> str "default=%s" v 
      | _ -> "" in
      let argvdoc = match absent, optvopt with 
      | "", "" -> "" 
      | s, "" | "", s -> str " (%s)" s
      | s, s' -> str " (%s, %s)" s s' 
      in
      (a.docs, `I (make_arg_label a ^ argvdoc, (subst_docv a.docv a.doc)))
    in
    let is_arg_item a = not (is_pos a && (a.docv = "" || a.doc = "")) in
    let l = List.sort rev_cmp (List.filter is_arg_item (snd ei.term)) in
    List.rev_map format l
        
  let make_cmd_items ei = match eval_kind ei with 
  | `Simple | `M_choice -> [] 
  | `M_main -> 
      let add_cmd acc (ti, _) = 
	(ti.tdocs, `I ((str "$(b,%s)" ti.name), ti.tdoc)) :: acc 
      in
      List.sort rev_compare (List.fold_left add_cmd [] ei.choices)

  let text ei =                  (* man that code is particulary unreadable. *)
    let rec merge_items acc to_insert mark il = function
      | `S s as sec :: ts -> 
	  let acc = List.rev_append to_insert acc in 
	  let acc = if mark then sec :: `Orphan_mark :: acc else sec :: acc in
	  let to_insert, il = List.partition (fun (n, _) -> n = s) il in 
	  let to_insert = List.rev_map (fun (_, i) -> i) to_insert in
	  let to_insert = (to_insert :> [ `Orphan_mark | Manpage.block] list) in
	  merge_items acc to_insert (s = "DESCRIPTION") il ts
      | t :: ts -> 
	  let t = (t :> [`Orphan_mark | Manpage.block]) in 
	  merge_items (t :: acc) to_insert mark il ts
      | [] -> 
	  let acc = List.rev_append to_insert acc in 
	  (if mark then `Orphan_mark :: acc else acc), il
    in
    let rec merge_orphans acc orphans = function 
      | `Orphan_mark :: ts -> 
	  let rec merge acc s = function
	    | [] -> (`S s) :: acc 
	    | (s', i) :: ss -> 
		let i = (i :> Manpage.block) in
		if s = s' then merge (i :: acc) s ss else 
		merge (i :: (`S s) :: acc) s' ss
	  in
	  let acc = match orphans with 
	  | [] -> acc | (s, _) :: _ -> merge acc s orphans
	  in
	  merge_orphans acc [] ts
      | (#Manpage.block as e) :: ts -> merge_orphans (e :: acc) orphans ts
      | [] -> acc
    in
    let cmds = make_cmd_items ei in
    let args = make_arg_items ei in
    let cmp (s, _) (s', _) = compare s s' in
    let items = List.rev (List.stable_sort cmp (List.rev_append cmds args)) in
    let synopsis, man = get_synopsis_section ei in
    let rev_text, orphans =
      merge_items [`Orphan_mark] [] false items man
    in
    synopsis @ merge_orphans [] orphans rev_text

  let ei_subst ei = function 
    | "tname" -> (fst ei.term).name
    | "mname" -> (fst ei.main).name
    | s -> s

  let man ei = 
    title ei, (name_section ei) @ (text ei)

  let print fmt ppf ei = Manpage.print ~subst:(ei_subst ei) fmt ppf (man ei)
  let pr_synopsis ppf ei =
    pr ppf "@[%s@]" 
      (Manpage.escape (ei_subst ei) 
         Manpage.plain_esc (Buffer.create 100) (synopsis ei))

  let pr_version ppf ei = match (fst ei.main).version with None -> assert false
  | Some v -> pr ppf "@[%a@]@." pr_text v
end

(* Errors for the command line user *)

module Err = struct
  let alts = function 
    | [a; b] -> str "either %s or %s" a b
    | alts -> str "one of: %s" (String.concat ", " alts)

  let invalid kind s exp = str "invalid %s %s, %s" kind (quote s) exp  
  let invalid_val = invalid "value"
  let no kind s = str "no %s %s" (quote s) kind
  let not_dir s = str "%s is not a directory" (quote s)
  let is_dir s = str "%s is a directory" (quote s)
  let element kind s exp = str "invalid element in %s (`%s'): %s" kind s exp
  let sep_miss sep s = invalid_val s (str "missing a `%c' separator" sep)
  let unknown kind v = str "unknown %s %s" kind (quote v)
  let ambiguous kind s ambs =
    str "%s %s ambiguous, could be %s" kind (quote s) (alts ambs)

  let pos_excess excess = 
    str "too many arguments, don't know what to do with %s" 
      (String.concat ", " (List.map quote excess))

  let flag_value f v = 
    str "option %s is a flag, it cannot take the argument %s"
      (quote f) (quote v)

  let opt_value_missing f = str "option %s needs an argument" (quote f)
  let opt_parse_value f e = str "option %s: %s" (quote f) e
  let opt_repeated f f' = 
    if f = f' then str "option %s cannot be repeated" (quote f) else
    str "options %s and %s cannot be present at the same time" (quote f) 
      (quote f')

  let pos_parse_value a e = 
    if a.docv = "" then e else match a.p_kind with
    | Nth _ -> str "%s argument: %s" a.docv e
    | _ -> str "%s... arguments: %s" a.docv e
	  
  let arg_missing a =
    if is_opt a then
      let rec long_name = function
	| n :: l -> if (String.length n) > 2 || l = [] then n else long_name l
	| [] -> assert false
      in
      str "required option %s is missing" (long_name a.o_names)
    else
      if a.docv = "" then str "a required argument is missing" else
      str "required argument %s is missing" a.docv

  (* Error printers *)
  
  let print ppf ei e = pr ppf "%s: @[%a@]@." (fst ei.main).name pr_text e
  let pr_backtrace err ei e bt =
    let bt = 
      let len = String.length bt in 
      if len > 0 then String.sub bt 0 (len - 1) (* remove final '\n' *) else bt
    in
    pr err 
     "%s: @[internal error, uncaught exception:@\n%a@]@." 
      (fst ei.main).name pr_lines (str "%s\n%s" (Printexc.to_string e) bt)
      
  let pr_try_help ppf ei = 
    let exec = Help.invocation ei in 
    let main = (fst ei.main).name in 
    if exec = main then 
      pr ppf "@[<2>Try `%s --help' for more information.@]" exec 
    else
      pr ppf "@[<2>Try `%s --help' or `%s --help' for more information.@]" 
	exec main 

  let pr_usage ppf ei e =
    pr ppf "@[<v>%s: @[%a@]@,@[Usage: @[%a@]@]@,%a@]@."
      (fst ei.main).name pr_text e Help.pr_synopsis ei pr_try_help ei
end

(* Command lines. A command line stores pre-parsed information about
   the command line's arguments in a more structured way. Given the
   [arg_info] values mentionned in a term and Sys.argv (whithout exec
   name) we parse the command line into a map of [arg_info] values to
   [arg] values. This map is used by the term's closures to retrieve
   and convert command line arguments (see the Arg module). *)

module Cmdline :sig 
  exception Error of string
  val choose_term : term_info -> (term_info * 'a) list -> string list -> 
    term_info * string list
  val create : arg_info list -> string list -> cmdline
  val opt_arg : cmdline -> arg_info -> (int * string * (string option)) list
  val pos_arg : cmdline -> arg_info -> string list
end = struct
  exception Error of string

  let opt_arg cl a = match try Amap.find a cl with Not_found -> assert false 
  with O l -> l | _ -> assert false

  let pos_arg cl a = match try Amap.find a cl with Not_found -> assert false 
  with P l -> l | _ -> assert false

  let choose_term ti choices = function 
    | [] -> ti, []
    | maybe :: args' as args ->
	if String.length maybe > 1 && maybe.[0] = '-' then ti, args else
	let index =
	  let add acc (choice, _) = Trie.add acc choice.name choice in 
	  List.fold_left add Trie.empty choices
	in
	match Trie.find index maybe with 
	| `Ok choice -> choice, args' 
	| `Not_found -> raise (Error (Err.unknown "command" maybe))
	| `Ambiguous ->
	    let ambs = List.sort compare (Trie.ambiguities index maybe) in
	    raise (Error (Err.ambiguous "command" maybe ambs))

  let arg_info_indexes al = 
    (* from [al] returns a trie mapping the names of optional arguments to
       their arg_info, a list with all arg_info for positional arguments and
       a cmdline mapping each arg_info to an empty [arg]. *)
    let rec aux opti posi cl = function
      | a :: l -> 
	  if is_pos a then aux opti (a :: posi) (Amap.add a (P []) cl) l else
	  let add t name = Trie.add t name a in
	  aux (List.fold_left add opti a.o_names) posi (Amap.add a (O []) cl) l
      | [] -> opti, posi, cl
    in
    aux Trie.empty [] Amap.empty al

  let parse_opt_arg s =          (* (name,value) of opt arg, assert len > 1. *)
    let l = String.length s in
    if s.[1] <> '-' then
      if l = 2 then s, None else
      String.sub s 0 2, Some (String.sub s 2 (l - 2))
    else try 
      let i = String.index s '=' in 
      String.sub s 0 i, Some (String.sub s (i + 1) (l - i - 1))
    with Not_found -> s, None

  let parse_args opti cl args =
    (* returns an updated [cl] cmdline according to the options found in [args]
       with the trie index [opti]. Positional arguments are returned in order
       in a list. *)
    let rec aux k opti cl pargs = function
      | [] -> cl, (List.rev pargs)
      | "--" :: args -> cl, (List.rev_append pargs args)
      | s :: args -> 
	  let is_opt s = String.length s > 1 && s.[0] = '-' in
	  if not (is_opt s) then aux (k+1) opti cl (s :: pargs) args else
	  let name, value = parse_opt_arg s in
	  match Trie.find opti name with
	  | `Ok a -> 
	      let value, args =
		if (value <> None || a.o_kind = Flag) then value, args else
		match args with 
		| v :: rest -> if is_opt v then None, args else Some v, rest
		| [] -> None, args
	      in
	      let arg = O ((k, name, value) :: opt_arg cl a) in
	      aux (k+1) opti (Amap.add a arg cl) pargs args
	  | `Not_found -> raise (Error (Err.unknown "option" name))
	  | `Ambiguous -> 
	      let ambs = List.sort compare (Trie.ambiguities opti name) in
	      raise (Error (Err.ambiguous "option" name ambs))
    in
    aux 0 opti cl [] args 

  let process_pos_args posi cl pargs =
    (* returns an updated [cl] cmdline in which each positional arg mentionned
       in the list index posi, is given a value according the list 
       of positional arguments values [pargs]. *)
    if pargs = [] then cl else
    let rec take n acc l =
      if n = 0 then List.rev acc else
      take (n - 1) (List.hd l :: acc) (List.tl l) 
    in
    let rec aux pargs last cl max_spec = function
      | a :: al ->
	  let arg, max_spec = match a.p_kind with 
	  | All -> P pargs, last
	  | Nth (rev, k) -> 
              let k = if rev then last - k else k in
              let max_spec = max k max_spec in
              if k < 0 || k > last then P [], max_spec else
	      P ([List.nth pargs k]), max_spec
	  | Left (rev, k) ->
              let k = if rev then last - k else k in
              let max_spec = max k max_spec in
              if k <= 0 || k > last then P [], max_spec else
	      P (take k [] pargs), max_spec
	  | Right (rev, k) ->
              let k = if rev then last - k else k in
	      if k < 0 || k >= last then P [], last else
	      P (List.rev (take (last - k) [] (List.rev pargs))), last
	  in
	  aux pargs last (Amap.add a arg cl) max_spec al
      | [] -> cl, max_spec
    in
    let last = List.length pargs - 1 in
    let cl, max_spec = aux pargs last cl (-1) posi in 
    if last <= max_spec then cl else
    let excess = List.rev (take (last - max_spec) [] (List.rev pargs)) in
    raise (Error (Err.pos_excess excess))

  let create al args =
    let opti, posi, cl = arg_info_indexes al in
    let cl, pargs = parse_args opti cl args in
    process_pos_args posi cl pargs
end

module Arg = struct
  type 'a parser = string -> [ `Ok of 'a | `Error of string ]
  type 'a printer = Format.formatter -> 'a -> unit
  type 'a converter = 'a parser * 'a printer
  type 'a arg_converter = (eval_info -> cmdline -> 'a) 
  type 'a t = arg_info list * 'a arg_converter
  type info = arg_info

  let ( & ) f x = f x	
  let parse_error e = raise (Cmdline.Error e)
  let some ?(none = "") (parse, print) =
    (fun s -> match parse s with `Ok v -> `Ok (Some v) | `Error _ as e -> e),
    (fun ppf v -> match v with None -> pr_str ppf none| Some v -> print ppf v)

  let info ?docs ?(docv = "") ?(doc = "") names = 
    let dash n = if String.length n = 1 then "-" ^ n else "--" ^ n in
    let docs = match docs with 
    | None -> if names = [] then "ARGUMENTS" else "OPTIONS"
    | Some s -> s
    in
    { id = arg_id (); absent = Val ""; doc = doc; docv = docv; docs = docs; 
      p_kind = All; o_kind = Flag; o_names = List.rev_map dash names; 
      o_all = false; }

  let flag a =
    if is_pos a then invalid_arg err_not_opt else
    let convert _ cl = match Cmdline.opt_arg cl a with
      | [] -> false
      | [_, _, None] -> true
      | [_, f, Some v] -> parse_error (Err.flag_value f v)
      | (_, f, _) :: (_ ,g, _) :: _  -> parse_error (Err.opt_repeated f g)
    in
    [a], convert

  let flag_all a =
    if is_pos a then invalid_arg err_not_opt else
    let a = { a with o_all = true } in
    let convert _ cl = match Cmdline.opt_arg cl a with
    | [] -> []
    | l -> 
	let truth (_, f, v) = match v with 
	| None -> true | Some v -> parse_error (Err.flag_value f v)
	in
	List.rev_map truth l
    in
    [a], convert
	  
  let vflag v l =
    let convert _ cl =
      let rec aux fv = function
	| (v, a) :: rest -> 
	    begin match Cmdline.opt_arg cl a with
	    | [] -> aux fv rest
	    | [_, f, None] -> 
		begin match fv with 
		| None -> aux (Some (f, v)) rest
		| Some (g, _) -> parse_error (Err.opt_repeated g f)
		end
	    | [_, f, Some v] -> parse_error (Err.flag_value f v)
	    | (_, f, _) :: (_, g, _) :: _ -> parse_error (Err.opt_repeated g f)
	    end
	| [] -> match fv with None -> v | Some (_, v) -> v
      in
      aux None l
    in
    let flag (_, a) = if is_pos a then invalid_arg err_not_opt else a in
    List.rev_map flag l, convert

  let vflag_all v l =
    let convert _ cl = 
      let rec aux acc = function
	| (fv, a) :: rest -> 
	    begin match Cmdline.opt_arg cl a with
	    | [] -> aux acc rest 
	    | l -> 
		let fval (k, f, v) = match v with 
		| None -> (k, fv) | Some v -> parse_error (Err.flag_value f v)
		in
		aux (List.rev_append (List.rev_map fval l) acc) rest
	    end
	| [] ->
	    if acc = [] then v else List.rev_map snd (List.sort rev_compare acc)
      in
      aux [] l
    in
    let flag (_, a) = 
      if is_pos a then invalid_arg err_not_opt else { a with o_all = true } 
    in
    List.rev_map flag l, convert

  let parse_opt_value parse f v = match parse v with 
  | `Ok v -> v | `Error e -> parse_error (Err.opt_parse_value f e)

  let opt ?vopt (parse, print) v a =
    if is_pos a then invalid_arg err_not_opt else
    let a = { a with absent = Val (str_of_pp print v);
	      o_kind = match vopt with 
	      | None -> Opt | Some dv -> Opt_vopt (str_of_pp print dv) } 
    in
    let convert _ cl = match Cmdline.opt_arg cl a with 
    | [] -> v
    | [_, f, Some v] -> parse_opt_value parse f v
    | [_, f, None] -> 
	begin match vopt with 
	| None -> parse_error (Err.opt_value_missing f)
	| Some optv -> optv
	end
    | (_, f, _) :: (_, g, _) :: _ -> parse_error (Err.opt_repeated g f)
    in
    [a], convert
    
  let opt_all ?vopt (parse, print) v a = 
    if is_pos a then invalid_arg err_not_opt else
    let a = { a with absent = Val ""; o_all = true;
		o_kind = match vopt with 
		| None -> Opt | Some dv -> Opt_vopt (str_of_pp print dv) }
    in
    let convert _ cl = match Cmdline.opt_arg cl a with 
    | [] -> v
    | l -> 
	let parse (k, f, v) = match v with 
	| Some v -> (k, parse_opt_value parse f v)
	| None -> match vopt with 
	  | None -> parse_error (Err.opt_value_missing f)
	  | Some dv -> (k, dv)
	in
	List.rev_map snd (List.sort rev_compare (List.rev_map parse l))
    in
    [a], convert

  (* Positional arguments *)

  let parse_pos_value parse a v = match parse v with 
  | `Ok v -> v | `Error e -> parse_error (Err.pos_parse_value a e)

  let pos ?(rev = false) k (parse, print) v a =
    if is_opt a then invalid_arg err_not_pos else
    let a = { a with p_kind = Nth (rev, k); absent = Val (str_of_pp print v) }in
    let convert _ cl = match Cmdline.pos_arg cl a with
    | [] -> v 
    | [v] -> parse_pos_value parse a v
    | _ -> assert false 
    in
    [a], convert

  let pos_list kind (parse, _) v a = 
    if is_opt a then invalid_arg err_not_pos else
    let a = { a with p_kind = kind } in 
    let convert _ cl = match Cmdline.pos_arg cl a with 
    | [] -> v
    | l -> List.rev (List.rev_map (parse_pos_value parse a) l)
    in
    [a], convert

  let pos_all c v a = pos_list All c v a
  let pos_left ?(rev = false) k = pos_list (Left (rev, k))
  let pos_right ?(rev = false) k = pos_list (Right (rev, k))
  
  (* Arguments as terms *)

  let absent_error al = List.rev_map (fun a -> { a with absent = Error }) al
  let value a = a
  let required (al, convert) =
    let al = absent_error al in 
    let convert ei cl = match convert ei cl with 
    | Some v -> v
    | None -> parse_error (Err.arg_missing (List.hd al))
    in
    al, convert

  let non_empty (al, convert) =
    let al = absent_error al in 
    let convert ei cl = match convert ei cl with
    | [] -> parse_error (Err.arg_missing (List.hd al)) 
    | l -> l
    in
    al, convert
    
  let last (al, convert) =
    let convert ei cl = match convert ei cl with
    | [] -> parse_error (Err.arg_missing (List.hd al))
    | l -> List.hd (List.rev l)
    in
    al, convert

  (* Predefined converters. *)

  let bool = 
    (fun s -> try `Ok (bool_of_string s) with Invalid_argument _ -> 
      `Error (Err.invalid_val s (Err.alts ["true"; "false"]))),
    Format.pp_print_bool
      
  let char = 
    (fun s -> if String.length s = 1 then `Ok s.[0] else
    `Error (Err.invalid_val s "expected a character")),
    pr_char

  let parse_with t_of_str exp s = 
    try `Ok (t_of_str s) with Failure _ -> `Error (Err.invalid_val s exp)
      
  let int =
    parse_with int_of_string "expected an integer", Format.pp_print_int

  let int32 = 
    parse_with Int32.of_string "expected a 32-bit integer",
    (fun ppf -> pr ppf "%ld")
      
  let int64 = 
    parse_with Int64.of_string "expected a 64-bit integer",
    (fun ppf -> pr ppf "%Ld")

  let nativeint = 
    parse_with Nativeint.of_string "expected a processor-native integer",
    (fun ppf -> pr ppf "%nd")
      
  let float =
    parse_with float_of_string "expected a floating point number",
    Format.pp_print_float 
      
  let string = (fun s -> `Ok s), pr_str
  let enum sl =
    let sl_inv = List.rev_map (fun (s,v) -> (v,s)) sl in
    let print ppf v = pr_str ppf (List.assoc v sl_inv) in
    let t = Trie.of_list sl in
    let parse s = match Trie.find t s with 
    | `Ok _ as r -> r
    | `Ambiguous -> 
	let ambs = List.sort compare (Trie.ambiguities t s) in 
	`Error (Err.ambiguous "enum value" s ambs)
    | `Not_found -> 
	let alts = List.rev (List.rev_map (fun (s, _) -> s) sl) in
	`Error (Err.invalid_val s ("expected " ^ (Err.alts alts)))
    in
    parse, print

  let file =
    (fun s -> if Sys.file_exists s then `Ok s else 
    `Error (Err.no "file or directory" s)), 
    pr_str
      
  let dir = 
    (fun s -> 
      if Sys.file_exists s then 
	if Sys.is_directory s then `Ok s else `Error (Err.not_dir s)
      else
	`Error (Err.no "directory" s)), 
    pr_str

  let non_dir_file = 
    (fun s -> 
      if Sys.file_exists s then 
	if not (Sys.is_directory s) then `Ok s else `Error (Err.is_dir s)
      else
	`Error (Err.no "file" s)), 
    pr_str

  let split_and_parse sep parse s =
    let parse sub = match parse sub with 
    | `Error e -> failwith e | `Ok v -> v in
    let rec split accum j =
      let i = try String.rindex_from s j sep with Not_found -> -1 in
      if (i = -1) then 
	let p = String.sub s 0 (j + 1) in
	if p <> "" then parse p :: accum else accum
      else 
	let p = String.sub s (i + 1) (j - i) in
	let accum' = if p <> "" then parse p :: accum else accum in
	split accum' (i - 1)
    in
    split [] (String.length s - 1)
      
  let list ?(sep = ',') (parse, pr_e) = 
    let parse s = try `Ok (split_and_parse sep parse s) with 
    | Failure e -> `Error (Err.element "list" s e)
    in
    let rec print ppf = function
      | v :: l -> pr_e ppf v; if (l <> []) then (pr_char ppf sep; print ppf l)
      | [] -> ()
    in
    parse, print
 
  let array ?(sep = ',') (parse, pr_e) =
    let parse s = try `Ok (Array.of_list (split_and_parse sep parse s)) with
    | Failure e -> `Error (Err.element "array" s e)
    in
    let print ppf v =
      let max = Array.length v - 1 in 
      for i = 0 to max do pr_e ppf v.(i); if i <> max then pr_char ppf sep done
    in
    parse, print

  let split_left sep s = 
    try 
      let i = String.index s sep in
      let len = String.length s in
      Some ((String.sub s 0 i), (String.sub s (i + 1) (len - i - 1)))
    with Not_found -> None 

  let pair ?(sep = ',') (pa0, pr0) (pa1, pr1) = 
    let parser s = match split_left sep s with 
    | None -> `Error (Err.sep_miss sep s)
    | Some (v0, v1) -> match pa0 v0, pa1 v1 with 
      | `Ok v0, `Ok v1 -> `Ok (v0, v1)
      | `Error e, _ | _, `Error e -> `Error (Err.element "pair" s e)
    in
    let printer ppf (v0, v1) = pr ppf "%a%c%a" pr0 v0 sep pr1 v1 in
    parser, printer
	  
  let t2 = pair
  let t3 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) = 
    let parse s = match split_left sep s with 
    | None -> `Error (Err.sep_miss sep s)
    | Some (v0, s) -> 
	match split_left sep s with
	| None -> `Error (Err.sep_miss sep s)
	| Some (v1, v2) -> 
	    match pa0 v0, pa1 v1, pa2 v2 with 
	    | `Ok v0, `Ok v1, `Ok v2 -> `Ok (v0, v1, v2) 
	    | `Error e, _, _ | _, `Error e, _ | _, _, `Error e -> 
		`Error (Err.element "triple" s e)
    in
    let print ppf (v0, v1, v2) = 
      pr ppf "%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2
    in
    parse, print
	  
  let t4 ?(sep = ',') (pa0, pr0) (pa1, pr1) (pa2, pr2) (pa3, pr3) = 
    let parse s = match split_left sep s with 
    | None -> `Error (Err.sep_miss sep s)
    | Some(v0, s) -> 
	match split_left sep s with
	| None -> `Error (Err.sep_miss sep s)
	| Some (v1, s) -> 
	    match split_left sep s with 
	    | None -> `Error (Err.sep_miss sep s)
	    | Some (v2, v3) -> 
		match pa0 v0, pa1 v1, pa2 v2, pa3 v3 with 
		| `Ok v1, `Ok v2, `Ok v3, `Ok v4 -> `Ok (v1, v2, v3, v4) 
		| `Error e, _, _, _ | _, `Error e, _, _ | _, _, `Error e, _ 
		| _, _, _, `Error e -> `Error (Err.element "quadruple" s e)
    in
    let print ppf (v0, v1, v2, v3) = 
      pr ppf "%a%c%a%c%a%c%a" pr0 v0 sep pr1 v1 sep pr2 v2 sep pr3 v3
    in
    parse, print
end

module Term = struct
  type info = term_info
  type 'a t = arg_info list * (eval_info -> cmdline -> 'a)
  type 'a result = [ 
    | `Ok of 'a | `Error of [`Parse | `Term | `Exn ] | `Version | `Help ]
	
  exception Term of [
    | `Help of [`Pager | `Plain | `Groff] * string option 
    | `Error of bool * string ]
	
  let info  ?(sdocs = "OPTIONS") ?(man = []) ?(docs = "COMMANDS") ?(doc = "") 
      ?version name = 
    { name = name; version = version; tdoc = doc; tdocs = docs; sdocs = sdocs;
      man = man }

  let name ti = ti.name
  let pure v = [], (fun _ _ -> v)
  let app (al, f) (al', v) = 
    List.rev_append al al', 
    fun ei cl -> (f ei cl) (v ei cl)

  let ( $ ) = app
  let ret (al, v) = al, 
    fun ei cl -> match v ei cl with 
    | `Ok v -> v 
    | `Error (u,e) -> raise (Term (`Error (u,e)))
    | `Help h -> raise (Term (`Help h))

  let main_name = [], (fun ei _ -> (fst ei.main).name)
  let choice_names = [], 
    fun ei _ -> List.rev_map (fun e -> (fst e).name) ei.choices

  let man_format =
    let fmts = ["pager", `Pager; "groff", `Groff; "plain", `Plain] in
    let doc = "Show output in format $(docv) (pager, plain or groff)."in
    Arg.(value & opt (enum fmts) `Pager & info ["man-format"] ~docv:"FMT" ~doc)

  (* Evaluation *)  

  let remove_exec argv =
    try List.tl (Array.to_list argv) with Failure _ -> invalid_arg err_argv

  let add_std_opts ei =
    let docs = (fst ei.term).sdocs in
    let args, v_lookup = 
      if (fst ei.main).version = None then [], None else 
      let (a, lookup) =
	Arg.flag (Arg.info ["version"] ~docs ~doc:"Show version information.")
      in
      a, Some lookup
    in
    let args, h_lookup =
      let (a, lookup) = 
	let fmt = Arg.enum ["pager",`Pager; "groff",`Groff; "plain",`Plain] in
        let doc = "Show this help in format $(docv) (pager, plain or groff)."in 
	let a = Arg.info ["help"] ~docv:"FMT" ~docs ~doc in
	Arg.opt ~vopt:(Some `Pager) (Arg.some fmt) None a
      in
      List.rev_append a args, lookup
    in
    h_lookup, v_lookup,
    { ei with term = (fst ei.term), List.rev_append args (snd ei.term) }
      
  let eval_term help err ei f args =
    let help_arg, vers_arg, ei = add_std_opts ei in
    try
      let cl = Cmdline.create (snd ei.term) args in
      match help_arg ei cl, vers_arg with 
      | Some fmt, _ -> Help.print fmt help ei; `Help
      | None, Some v_arg when v_arg ei cl -> Help.pr_version help ei; `Version 
      | _ -> `Ok (f ei cl)
    with
    | Cmdline.Error e -> Err.pr_usage err ei e; `Error `Parse
    | Term (`Error (usage, e)) -> 
	if usage then Err.pr_usage err ei e else Err.print err ei e;`Error `Term
    | Term (`Help (fmt, cmd)) ->
	let ei = match cmd with 
	| Some cmd -> 
	    let cmd = 
	      try List.find (fun (i, _) -> i.name = cmd) ei.choices
	      with Not_found -> invalid_arg (err_help cmd)
	    in
	    {ei with term = cmd }
	| None -> { ei with term = ei.main }
	in
	let _, _, ei = add_std_opts ei in 
        Help.print fmt help ei; `Help 
	 
  let eval ?(help = Format.std_formatter) ?(err = Format.err_formatter) 
      ?(catch = true) ?(argv = Sys.argv) ((al, f), ti)  =
    let term = ti, al in
    let ei = { term = term; main = term; choices = [] } in
    try eval_term help err ei f (remove_exec argv) with
    | e when catch ->
	Err.pr_backtrace err ei e (Printexc.get_backtrace ()); `Error `Exn

  let eval_choice ?(help = Format.std_formatter) ?(err = Format.err_formatter) 
      ?(catch = true) ?(argv = Sys.argv) (((al, f) as t), ti) choices =
    let ei_choices = List.rev_map (fun ((al, _), ti) -> ti, al) choices in 
    let main = (ti, al) in
    let ei = { term = main; main = main; choices = ei_choices } in
    try 
      let chosen, args = Cmdline.choose_term ti ei_choices (remove_exec argv) in
      let find_chosen (_, ti) = ti = chosen in  
      let (al, f), _ = List.find find_chosen ((t, ti) :: choices) in
      let ei = { ei with term = (chosen, al) } in
      eval_term help err ei f args
    with
    | Cmdline.Error e ->                    (* may be raised by choose_term. *)
	Err.pr_usage err ei e; `Error `Parse
    | e when catch ->
	Err.pr_backtrace err ei e (Printexc.get_backtrace ()); `Error `Exn
end

(*---------------------------------------------------------------------------
   Copyright (c) 2011-2012 Daniel C. Bünzli
   All rights reserved.

   Redistribution and use in source and binary forms, with or without
   modification, are permitted provided that the following conditions
   are met:
     
   1. Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

   2. Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

   3. Neither the name of Daniel C. Bünzli nor the names of
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
   LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
   DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
   THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
   (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
   OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  ---------------------------------------------------------------------------*)
