(* $Id$
* ----------------------------------------------------------------------
*
*)
let predicates = ref ("toploop" :: Findlib.recorded_predicates());;
(* We also want things like "syntax" here which are not allowed in
Findlib, hence we maintain our own list
*)
let ocaml_stdlib = lazy (Findlib.ocaml_stdlib ());;
let directories = ref [ ] ;;
(* 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 log = ref (if real_toploop then prerr_endline else ignore)
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);
Findlib.record_package_predicates !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
let ocaml_stdlib = Lazy.force ocaml_stdlib in
if d <> ocaml_stdlib && not (List.mem d !directories) then begin
Topdirs.dir_directory d;
directories := d :: !directories;
!log (d ^ ": added to search path")
end
;;
let exec_string s =
let l = Lexing.from_string s in
let ph = !Toploop.parse_toplevel_phrase l in
(* PPXOPT_BEGIN *)
let ph = Toploop.preprocess_phrase Format.err_formatter ph in
(* PPXOPT_END *)
let fmt = Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) in
try
Toploop.execute_phrase false fmt ph
with
_ -> false
;;
let load pkglist =
List.iter
(fun pkg ->
let _stdlibdir = Findlib.ocaml_stdlib() in
let loaded =
Findlib.is_recorded_package pkg &&
Findlib.type_of_recorded_package pkg = Findlib.Record_load in
let incore =
Findlib.is_recorded_package pkg &&
Findlib.type_of_recorded_package pkg = Findlib.Record_core in
if not 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 incore 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
!log (arch' ^ ": loaded");
Topdirs.dir_load
Format.std_formatter arch')
archives;
(* Determine the 'ppx' property: *)
let ppx =
try
Some(Findlib.resolve_path
~base:d ~explicit:true
(Findlib.package_property !predicates pkg "ppx")
)
with Not_found -> None
and ppxopts =
try
List.map
(fun opt ->
match Fl_split.in_words opt with
| pkg :: opts ->
pkg,
List.map
(Findlib.resolve_path ~base:d ~explicit:true) opts
| _ -> assert false)
(Fl_split.in_words_ws
(Findlib.package_property !predicates pkg "ppxopt"))
with Not_found -> [] in
(* Feed the 'ppx' property into the toplevel. To remain compatible
with pre-4.01 OCaml, construct and execute a phrase instead of directly
altering Clflags. *)
begin match ppx with
| Some ppx ->
begin try
match Hashtbl.find Toploop.directive_table "ppx" with
| Toploop.Directive_string fn ->
fn ppx; !log (ppx ^ ": activated")
| _ -> assert false
with Not_found ->
failwith "Package defines a ppx preprocessor, but OCaml is too old. \
Use OCaml >= 4.02.0 for ppx support."
end
| None -> ()
end;
(* Feed the 'ppxopt' property into the toplevel. *)
match ppxopts with
| [] -> ()
| _ ->
(* PPXOPT_BEGIN *)
List.iter
(fun (pkg, opts) ->
ignore (exec_string ("[@@@findlib.ppxopt " ^
(String.concat ", "
(List.map (Printf.sprintf "%S") (pkg :: opts))) ^
"];;"));
!log (pkg ^ ": " ^ (String.concat " " opts) ^
": option added"))
ppxopts
(*
(* PPXOPT_END *)
failwith "Package defines a ppx preprocessor option, but OCaml is too old. \
Use OCaml >=4.02.1 for ppxopt support."
(* PPXOPT_BEGIN *)
*)
(* PPXOPT_END *)
end;
(* The package is loaded: *)
Findlib.record_package Findlib.Record_load pkg
end)
pkglist
;;
let load_deeply pkglist =
(* Get the sorted list of ancestors *)
let eff_pkglist =
Findlib.package_deep_ancestors !predicates pkglist in
List.iter (fun pkg ->
try let error = Findlib.package_property !predicates pkg "error" in
failwith ("Error from package `" ^ pkg ^ "': " ^ error)
with Not_found -> ()) eff_pkglist ;
(* Load the packages in turn: *)
load eff_pkglist
;;
let check_existence pkglist =
List.iter
(fun pkg ->
let _ = Findlib.package_directory pkg in ()
)
pkglist
;;
let don't_load pkglist =
check_existence pkglist;
List.iter (Findlib.record_package Findlib.Record_core) pkglist
;;
let don't_load_deeply pkglist =
(* Check if packages exist: *)
check_existence pkglist;
(* Get the sorted list of ancestors *)
let eff_pkglist =
Findlib.package_deep_ancestors !predicates pkglist in
(* Add this to the list of core packages: *)
List.iter (Findlib.record_package Findlib.Record_core) eff_pkglist
;;
let reset() =
Findlib.reset_recordings()
;;
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(Findlib.is_recorded_package "threads") 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 ;;
