Source

spotinstall / spotinstall.ml

open Spotlib.Spot
open Unix
open Printf

type dest = 
  | Package of string
  | Path of string

let show_dest = function
  | Package s -> sprintf "package %s" s
  | Path s -> s

let dests, verbose = 
  match 
    imp [] & fun dests -> 
      imp_ false & fun verbose -> 
        Arg.parse 
          ["-v", Arg.Set verbose, "verbose"] 
          (fun x -> 
            let d = if Filename.is_relative x then Package x else Path x in
            dests := d :: !dests)
          "spotinstall <packages-or-abs-paths>\n  \
           Check the files installed as ocamlfind package <package>, or files in directory <abs-path> and if there are corresponding .cmt/.cmti/.spot/.spit files in the current and sub directories, copy them to the installation directory."
  with
  | [], v -> `All, v
  | dests, v -> `Some dests, v

module OCamlFind = struct

  let path = 
    match 
      imp_ None & fun ocamlfind_path ->
        ignore & shell_command "ocamlfind printconf destdir" ~f: (function
          | (`Out, `Read line) ->
              begin match !ocamlfind_path with
              | Some _ -> failwith "ocamlfind printconf destdir prints more than one line"
              | None -> ocamlfind_path := Some (String.chop_newline line)
              end
          | _ -> ())
    with
    | None -> failwith "No ocamlfind installtion path found. Check your ocamlfind."
    | Some p -> p
  
  let dest_dir package = 
    match 
      imp_ None & fun result ->
        ignore & shell_command (sprintf "ocamlfind query %s" package) ~f:(function
          | (`Out, `Read line) ->
              begin match !result with
              | Some _ -> failwith "ocamlfind query package prints more than one line"
              | None -> result := Some (String.chop_newline line)
              end
          | _ -> ())
    with
    | None -> failwithf "No ocamlfind installtion path for package \"%s\" found. Check your ocamlfind." package
    | Some p -> p

  let packages =
    StringSet.to_list
    & imp_ StringSet.empty 
    & fun packs ->
      ignore & shell_command "ocamlfind list" ~f:(function
        | (`Err, `Read s) -> prerr_endline s
        | (`Out, `Read s) ->
            begin 
              s |> <:m<\[(distributed with Ocaml|internal)\]>> -> () (* exclude bases *)
                | <:m<(^[^. ]+)>> as x -> packs := StringSet.add x#_1 !packs
                | _ -> ()
            end
        | _ -> ())
end

module OCaml = struct

  let where = 
    match 
      imp_ None & fun ocaml_where ->
        ignore & shell_command "ocamlc -where" ~f:(function
          | (`Out, `Read line) ->
              begin match !ocaml_where with
              | Some _ -> failwith "ocamlc -where prints more than one line"
              | None -> ocaml_where := Some (String.chop_newline line)
              end
          | _ -> ())
    with
    | None -> failwith "ocamlc -where failed."
    | Some p -> p

end

let exts_of_sp = function
  | ".cmx" | ".cmo" -> [ ".spot"; ".cmt" ]
  | ".cmi" -> [ ".spit"; ".cmti"; ".cmt" ] (* Packed .cmi has no .spit but .spot *)
  | ".ml" -> [ ".annot" ]
  | _ -> assert false

let find_installed_cms tbl package =
  eprintf "Finding cms of %s...\n%!" (show_dest package);
  let dest_dir = match package with 
    | Package "ocaml" -> OCaml.where 
    | Package package -> OCamlFind.dest_dir package 
    | Path p -> p
  in
  Find.find [dest_dir] &~ (fun path -> 
    if path#base = "site-lib" && package = Package "ocaml" then 
      Find.prune ()
    else match Filename.split_extension path#base with
    | body, (".cmx" | ".cmo" | ".cmi" as ext) -> 
        if verbose then Printf.eprintf "found %s\n" path#path;
        Hashtbl.add tbl (body, ext) (package, path#path)
    | _ -> ());
  !!% "Found %d entries@." & Hashtbl.length tbl

let dests = 
  match dests with
  | `Some dests -> dests
  | `All -> List.map (fun x -> Package x) OCamlFind.packages

let installed_cms = 
  let tbl = Hashtbl.create 107 in
  List.iter (fun package -> find_installed_cms tbl package) dests;
  tbl

(* For each installed *.cm* file, we try to find the same file in the current directory,
   then copy the accompanied .spot/.spit *)

let () =
  let copied = Hashset.create 107 in

  eprintf "Traversing the current directory to find compiled files...\n%!";

  Unix.Find.find ["."] ~f:(fun path ->
    match Filename.split_extension path#base with
    | body, (".cmx" | ".cmo" | ".cmi" | ".ml" as ext) -> 
        List.map (fun ext -> path#dir ^/ body ^ ext) (exts_of_sp ext)
        |> List.find_all Sys.file_exists 
        |> List.iter (fun spotspit ->
          Hashtbl.find_all installed_cms (body, ext) 
          |> List.iter (fun (_package, p) -> 
            match cmp p path#path with
            | `Different | `Error -> ()
            | `Same ->
                (* The file is installed! If there is .spot/.spit, copy it! *)
                let dirname = Filename.dirname p in
                let destfile = dirname ^/ Filename.basename spotspit in 
                let need_to_copy = 
                  not (Sys.file_exists destfile && cmp spotspit destfile = `Same)
                in
                if not need_to_copy then
                  Hashset.add copied p                
                else begin
                  match 
                    command ["/bin/cp"; spotspit; dirname] ~f:(function
                      | (`Err, `Read mes) -> eprintf "Failed to copy %s to %s: %s\n%!" spotspit dirname mes
                      | _ -> ())
                  with
                  | `Exited 0 -> 
                      Hashset.add copied p;
                      eprintf "Copied %s to %s\n%!" spotspit dirname
                  | `Exited n -> 
                      eprintf "cp returned with a strange status %d\n%!" n
                  | _ -> eprintf "Failed to copy %s to %s: SOME STRANGE READON\n%!" spotspit dirname
                end 
          ))
    | _ -> ());

  (* check not found *)
  Hashtbl.iter (fun _ (package, path) -> 
    if not (Hashset.mem copied path) then
      Printf.eprintf "No binannot file found %s (%s)\n" path (show_dest package)) 
    installed_cms