(* $Id: topfind.ml 62 2004-01-11 12:20:15Z gerd $
 * ----------------------------------------------------------------------
 *
 *)

let predicates = ref [];;
let forbidden = ref [];;
let loaded = ref [];;
let directories = ref [ Findlib.ocaml_stdlib() ];;


(* Note: Sys.interactive is always _true_ during toploop startup.
 * When a script is executed, it is set to false just before the
 * script starts. This is important for ocamlmktop-generated toploops:
 * For initialization code linked into the toploop, Sys.interactive
 * is _true_. It is set to false just before the script starts.
 *)

let real_toploop = 
  !Sys.interactive;;

let rec remove_dups l =
  match l with
    x :: l' ->
      if List.mem x l' then remove_dups l' else x::remove_dups l'
  | [] -> []
;;

let add_predicates pl =
  predicates := remove_dups (pl @ !predicates);;

let syntax s =
  add_predicates [ "syntax"; s ];;

let standard_syntax () = syntax "camlp4o";;
let revised_syntax () = syntax "camlp4r";;


let add_dir d =
  let d = Fl_split.norm_dir d in
  if not (List.mem d !directories) then begin
    Topdirs.dir_directory d;
    directories := d :: !directories;
    if real_toploop then
      prerr_endline (d ^ ": added to search path")
  end
;;


let load pkglist =
  List.iter
    (fun pkg ->
      let stdlibdir = Findlib.ocaml_stdlib() in
      if not (List.mem pkg !loaded) then begin
        (* Determine the package directory: *)
	let d = Findlib.package_directory pkg in
	add_dir d;
        (* Leave pkg out if mentioned in !forbidden *)
	if not (List.mem pkg !forbidden) then begin
	  (* Determine the 'archive' property: *)
	  let archive =
	    try Findlib.package_property !predicates pkg "archive"
	    with
	      Not_found -> ""
	  in
	  (* Split the 'archive' property and load the files: *)
	  let archives = Fl_split.in_words archive in
	  List.iter
	    (fun arch -> 
	       let arch' = Findlib.resolve_path ~base:d arch in
	       if real_toploop then
		 prerr_endline (arch' ^ ": loaded");
	       Topdirs.dir_load
		 Format.std_formatter arch')
	    archives;
	end;
	(* The package is loaded: *)
	loaded := pkg :: !loaded
      end)
    pkglist
;;


let load_deeply pkglist =
  (* Get the sorted list of ancestors *)
  let eff_pkglist =
    Findlib.package_deep_ancestors !predicates pkglist in
  (* Load the packages in turn: *)
  load eff_pkglist
;;


let don't_load pkglist =
  forbidden := remove_dups (pkglist @ !forbidden);
  List.iter
    (fun pkg ->
       let d = Findlib.package_directory pkg in
       ()
    )
    pkglist
;;


let don't_load_deeply pkglist =
  (* Check if packages exist: *)
  List.iter
    (fun pkg ->
       let _ = Findlib.package_directory pkg in ()
    )
    pkglist;
  (* Get the sorted list of ancestors *)
  let eff_pkglist =
    Findlib.package_deep_ancestors !predicates pkglist in
  (* Add this to the list of forbidden packages: *)
  don't_load eff_pkglist
;;


let reset() =
  loaded := []
;;


let have_mt_support() =
  Findlib.package_property [] "threads" "type_of_threads" = "posix"
;;


let load_mt_support() =
  (* Load only if package "threads" is not yet loaded. *)
  if not(List.mem "threads" !loaded) then (
    (* This works only for POSIX threads. *)
    if have_mt_support() then (
      add_predicates ["mt"; "mt_posix"];
      add_dir (Filename.concat (Findlib.ocaml_stdlib()) "threads");
      load_deeply ["unix"];
      load_deeply ["threads"];
    )
    else (
      failwith "It is not possible to load support for vmthreads dynamically. Use\n
'ocamlfind ocamlmktop -o vmtop -package threads,findlib -linkpkg -vmthread'\n
to create a toploop with integrated vmthreads library."
    )
  )
;;


let list_packages() =
  Findlib.list_packages stdout;
  flush stdout
;;


let protect f arg =
  try
    let _ = f arg in ()
  with
      Failure s ->
	print_endline s
    | Fl_package_base.No_such_package(pkg, reason) ->
	print_endline ("No such package: " ^ pkg ^ 
		       (if reason <> "" then " - " ^ reason else ""))
    | Fl_package_base.Package_loop pkg ->
	print_endline ("Package requires itself: " ^ pkg)
;;


(* Add "#require" directive: *)

Hashtbl.add
    Toploop.directive_table
    "require"
    (Toploop.Directive_string
       (fun s ->
	  protect load_deeply (Fl_split.in_words s)
       ))
;;

(* Add "#predicates" directive: *)
Hashtbl.add
    Toploop.directive_table
    "predicates"
    (Toploop.Directive_string
       (fun s ->
	  protect add_predicates (Fl_split.in_words s)
       ))
;;


(* Add "#camlp4o" directive: *)

Hashtbl.add
    Toploop.directive_table
    "camlp4o"
    (Toploop.Directive_none
       (fun () ->
	  protect (fun () ->
		     standard_syntax();
		     load_deeply ["camlp4"]) ()
       ))
;;

(* Add "#camlp4r" directive: *)

Hashtbl.add
    Toploop.directive_table
    "camlp4r"
    (Toploop.Directive_none
       (fun () ->
	  protect (fun () ->
		     revised_syntax();
		     load_deeply ["camlp4"]) ()
       ))
;;


(* Add "#list" directive: *)

Hashtbl.add
    Toploop.directive_table
    "list"
    (Toploop.Directive_none
       (fun () ->
	  protect list_packages ()
       ))
;;


(* Add "#thread" directive: *)

Hashtbl.add
    Toploop.directive_table
    "thread"
    (Toploop.Directive_none
       (fun () ->
	  protect load_mt_support ()
       ))
;;


let announce() =
  if real_toploop then begin
    (* Assume we are in a toploop and not a script *)
    let msg_thread =
      "  #thread;;                 to enable threads\n" in
    print_endline
      ("Findlib has been successfully loaded. Additional directives:\n" ^
       "  #require \"package\";;      to load a package\n" ^
       "  #list;;                   to list the available packages\n" ^
       "  #camlp4o;;                to load camlp4 (standard syntax)\n" ^
       "  #camlp4r;;                to load camlp4 (revised syntax)\n" ^
       "  #predicates \"p,q,...\";;   to set these predicates\n" ^
       "  Topfind.reset();;         to force that packages will be reloaded\n" ^
       (if have_mt_support() then msg_thread else ""))
  end ;;