Source

spotinstall / spotinstall.ml

Full commit
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, meth = 
  let dests = ref [] in
  let verbose = ref false in
  let meth = Once.create () in
    
  Arg.parse 
      [ "-v", Arg.Set verbose, "verbose"
      ; "-c", Arg.Unit (fun () -> Once.set meth `Copy), "use cp"
      ; "-l", Arg.Unit (fun () -> Once.set meth `Link), "use ln  (default)"
      ; "-s", Arg.Unit (fun () -> Once.set meth `Sym),  "use ln -s"
      ] 
      (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.";
    
  let dests = match !dests with
    | [] -> `All
    | dests -> `Some dests
  in
  let verbose = !verbose in
  let meth = match Once.get meth with
      | Some v -> v
      | None -> `Link
  in
  dests, verbose, meth

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
                  let comm = match meth with
                    | `Copy -> ["/bin/cp"]
                    | `Link -> ["/bin/ln"]
                    | `Sym  -> ["/bin/ln"; "-s"]
                  in
                  match 
                    command (comm @ [spotspit; dirname])
                      ~f:(function
                        | (`Err, `Read mes) -> eprintf "Failed to install %s to %s: %s\n%!" spotspit dirname mes
                        | _ -> ())
                  with
                  | `Exited 0 -> 
                      Hashset.add copied p;
                      eprintf "Installed %s to %s\n%!" spotspit dirname
                  | `Exited n -> 
                      eprintf "%s returned with a strange status %d\n%!" 
                        (String.concat " " comm)
                        n
                  | _ -> 
                      eprintf "Failed to %s %s to %s: SOME STRANGE REASON\n%!" 
                        (String.concat " " comm)
                        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