(* A utility to gather information from caml compiled interface files

   Copyright (C) 2007 Eric Stokes

   This library is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License as
   published by the Free Software Foundation; either version 2.1 of
   the License, or (at your option) any later version.
   
   This library is distributed in the hope that it will be useful,             
   but WITHOUT ANY WARRANTY; without even the implied warranty of              
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU           
   Lesser General Public License for more details.                             
   
   You should have received a copy of the GNU General Public License
   along with this library; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
   USA
*)

open Types

module Ordpath = struct
  type t = string
  let trailing_slash = Pcre.regexp "/\\s*$|\\\\\\s*$"
  let compare p1 p2 = 
    let p1' = Pcre.replace ~rex:trailing_slash ~templ:"" p1 in
    let p2' = Pcre.replace ~rex:trailing_slash ~templ:"" p2 in
    String.compare p1' p2'
end
module Strset = Set.Make(Ordpath)

(* the standard library should not be so deficient *)
module My_list = struct
  include List

  exception Break

  let filter_map f l = 
    List.fold_left
      (fun acc item -> 
         match f item with
         | Some x -> x :: acc
         | None -> acc)
      []
      l

  let find_map f l = 
    let res = ref None in
    try
      List.iter
        (fun x -> 
           match f x with
           | None -> ()
           | Some y -> res := Some y; raise Break)
        l;
      raise Not_found
    with Break -> 
      begin match !res with
      | Some y -> y
      | None -> raise Break
      end

  let map f l = 
    let r = rev_map f l in
    rev r
end

module My_unix = struct
  include Unix

  let fold_path ~f ~init path = 
    let dir = Unix.opendir path in
    let acc = ref init in
    try
      while true do
        let file = Unix.readdir dir in
        acc := f file !acc
      done;
      !acc
    with 
    | End_of_file -> Unix.closedir dir; !acc
    | exn -> Unix.closedir dir; raise exn
end

module List = My_list
module Unix = My_unix

type mode = 
  | Find_type of Pcre.regexp
  | Find_constructor of Pcre.regexp
  | Find_polymorphic_variant of Pcre.regexp
  | Find_record_label of Pcre.regexp
  | Find_value of Pcre.regexp
  | Find_exception of Pcre.regexp
  | Find_module
  | Find_class of Pcre.regexp
  | Find_all of Pcre.regexp

type module_expression = 
  | Exact of string
  | Begins_with of string * Pcre.regexp
  | Ends_with of string * Pcre.regexp
  | Begins_and_ends of string * Pcre.regexp
  | Contains of string * Pcre.regexp
  | Any

type module_tree = 
  | Leaf of string * signature
  | Node of string * signature * module_tree list

type args = {
  mode: mode;
  path: Strset.t;
  context: module_expression list list; (* open modules *)
  modname: module_expression list list;
}

let module_expression_to_string e = 
  match e with
  | Exact m -> m
  | Begins_with (s, _) 
  | Ends_with (s, _)
  | Begins_and_ends (s, _)
  | Contains (s, _) -> s
  | Any -> "*"

(* ModA,ModB,Foo*.Make *)
let comma = Pcre.regexp "\\s*,\\s*"
let dot = Pcre.regexp "\\."
let capname = Pcre.regexp "^[A-Z][A-Za-z_'0-9]*$"
let starend = Pcre.regexp "^[A-Z][A-Za-z0-9_']*\\*$"
let starbegin = Pcre.regexp "^\\*[A-Za-z0-9_']+$"
let starboth = Pcre.regexp "^\\*[A-Za-z0-9_']+\\*$"
let starmiddle = Pcre.regexp "^([A-Z][A-Za-z0-9_']*)\\*([A-Za-z0-9_']+)$"
let star = Pcre.regexp "\\*"
let parse_module_expression exp = 
  List.map
    (fun token ->
       let token_no_star = Pcre.replace ~rex:star ~templ:"" token in
       if token = "*" then
         Any
       else if Pcre.pmatch ~rex:capname token then
         Exact token
       else if Pcre.pmatch ~rex:starboth token then
         Contains (token, Pcre.regexp ("^.*" ^ token_no_star ^ ".*$"))
       else if Pcre.pmatch ~rex:starmiddle token then
         begin match Pcre.extract ~rex:starmiddle token with
         | [|_whole; begins; ends |] -> 
             let rex = Pcre.regexp (Printf.sprintf "^%s.*%s$" begins ends) in
             Begins_and_ends (token, rex)
         | _ -> failwith "invalid begins and ends with match"
         end
       else if Pcre.pmatch ~rex:starbegin token then
         Ends_with (token, Pcre.regexp (Printf.sprintf "%s$" token_no_star))
       else if Pcre.pmatch ~rex:starend token then
         Begins_with (token, Pcre.regexp (Printf.sprintf "^%s" token_no_star))
       else
         failwith "invalid module expression")
    (Pcre.split ~rex:dot exp)

let parse_args () =
  let module Parse = struct
    open Arg
    let mode = ref None
    let path = ref (Strset.add "." (Strset.singleton Config.standard_library))
    let context = ref ["Pervasives"]
    let modname = ref []

    let set_mode m =
      match !mode with
      | None -> mode := Some m;
      | Some _ -> raise (Invalid_argument "the mode is already set")

    let add_packages p = 
      Findlib.init ();
      let packages = Pcre.split ~rex:comma p in
      List.iter
        (fun package ->
           let dir = Findlib.package_directory package in
           path := Strset.add dir !path)
        packages

    let add_opens s = context := Pcre.split ~rex:comma s

    let args = 
      Arg.align
        [("-t", String (fun s -> set_mode (Find_type (Pcre.regexp s))),
          "      (regexp) print types with matching names");
         ("-r", String (fun s -> set_mode (Find_record_label (Pcre.regexp s))),
          "      (regexp) print record field labels with matching names");
         ("-c", String (fun s -> set_mode (Find_constructor (Pcre.regexp s))), 
          "      (regexp) print constructors with matching names");
         ("-p", String (fun s -> 
                         set_mode 
                           (Find_polymorphic_variant 
                             (Pcre.regexp s))),
          "      (regexp) print polymorphic variants with matching names");
         ("-m", Unit (fun () -> set_mode Find_module),
          "      (regexp) print all matching module names in the path");
         ("-v", String (fun s -> set_mode (Find_value (Pcre.regexp s))), 
          "      (regexp) print values with matching names");
         ("-e", String (fun s -> set_mode (Find_exception (Pcre.regexp s))), 
          "      (regexp) print exceptions with matching constructors");
         ("-o", String (fun s -> set_mode (Find_class (Pcre.regexp s))),
          "      (regexp) print all classes with matching names");
         ("-a", String (fun s -> set_mode (Find_all (Pcre.regexp s))),
          "      (regexp) print all names which match the given expression");
         ("-I", String (fun s -> path := Strset.add s !path), 
          "      (directory) add additional directory to the search path");
         ("-package", String (fun s -> add_packages s),
          "      (packages) comma seperated list of findlib packages to search");
         ("-open", String (fun s -> add_opens s), 
          "      (modules) comma seperated list of open modules (in order!)")]
    let usage = 
      Printf.sprintf
        ("%s: <args> <module-expr> \n" ^^
           "extract information from caml compiled interface files\n" ^^
           " <module-expr> can be an exact module name, " ^^
           " or a shell wildcard. Multiple modules can be specified " ^^
           "E.G. \"ModA ModB Foo*.Make\" means to search ModA, ModB, and " ^^
           "any submodule Make of a module that starts with Foo.")
        Sys.argv.(0)

    let parse () = 
      Arg.parse args
        (fun anon -> modname := (parse_module_expression anon) :: !modname)
        usage

    let error msg = 
      prerr_endline msg;
      Arg.usage args usage;
      exit 1
  end
  in
  Parse.parse ();
  let mode = 
    match !Parse.mode with
    | Some m -> m
    | None -> Parse.error "you must specify a search mode"
  in
  {mode = mode;
   path = 
      if Strset.is_empty !Parse.path then Parse.error "you must specify a search path"
      else !Parse.path;
   context = 
      List.map 
        (fun m -> List.map (fun m -> Exact m) (Pcre.split ~rex:dot m))
        !Parse.context;
   modname = 
      (match !Parse.modname with
       | [] -> 
           if !Parse.context = [] then
             Parse.error "you must specify a module expression, or a list of open modules"
           else 
             []
       | name -> name)}

let match_ident exp id = Pcre.pmatch ~rex:exp (Ident.name id)

let whsp = Pcre.regexp ~study:true "\\s+|$"

let print_type print_path path s