Source

rebildol / src / main.ml

Full commit
module DUMMY1 = Pre_post_templates;
(* to check correctness in compile-time *)

open Cd_Ops;
open Printf;
open Common;

value out_line outch fn ln =
  fprintf outch "# %i %S\n" ln fn
;

value output_lines_reb =
  let ln = ref 1 in
  fun outch lines ->
    ( out_line outch "rebildol-guts" ln.val
    ; List.iter
        (fun line -> (fprintf outch "%s\n" line; incr ln))
        lines
    )
;

value output_line_reb outch line = output_lines_reb outch [line]
;


value blank_modules =  (* ? todo: more fine-grained access control *)
  [ "Obj" ; "Marshal" ; "Dynlink" ; "Graphics" ; "GraphicsX11" ]
;


module Pkgidents
 =
  struct
    value ids = Hashtbl.create 7;

    value is_alpha = fun [ 'a'..'z' | 'A'..'Z' -> True | _ -> False ]
    ;

    value rec ident_of_fn fn =
      if fn = "" then ident_of_fn "Rebpkg" else
      if not (is_alpha fn.[0]) then ident_of_fn ("Rebpkg_" ^ fn) else
      let fn = String.capitalize fn in
      string_map
        (fun c ->
           match c with
           [ c when is_alpha c -> c
           | '0'..'9' | '_' | '\'' -> c
           | _ -> '_'
           ]
        )
        fn
    ;

    value try_add ident =
      if Hashtbl.mem ids ident
      then False
      else (Hashtbl.add ids ident (); True)
    ;

    value add fn =
      let i = ident_of_fn fn in
      if try_add i then i else
      loop 0
      where rec loop n =
        let i' = sprintf "%s%i" i n in
        if try_add i' then i' else
        loop (n + 1)
    ;

  end
;


value compile ~ml ~exe =
  if 0 = Sys.command (sprintf "ocamlc -o %s unix.cma %s" exe ml)
  then
    let b = Filename.chop_extension ml in
    (Sys.remove (b ^ ".cmi") ; Sys.remove (b ^ ".cmo"))
  else failwith "error compiling %S (see temporary file %S)\n" exe ml
;


value make_runner ~exe files =
  let () =
    List.iter
      (fun fn ->
         if Filew.is_exists fn
         then ()
         else failwith "can't find package description file %S" fn
      )
      files
  in
  let (out_fn, outch) = Filename.open_temp_file
    ~mode:[Open_binary]
    "rebildol" ".ml"
  in
  let output_module ident txt =
    Printf.fprintf outch "module %s = struct\n%s\nend\n\n"
      ident txt
  in
  ( output_module "Templates" Templates.oasis_depends_ml
  ; output_string outch Templates.common_template
  ; output_string outch Templates.pre_template
  ; output_lines_reb outch
      (List.map
         (fun m -> sprintf "module %s = struct end" m)
         blank_modules
      )
  ; let pkg_idents = List.map
      (fun in_fn ->
         let in_fn_base = Filename.basename in_fn in
         let in_fn_base_name =
           if Filename.check_suffix in_fn_base ".ml"
           then Filename.chop_extension in_fn_base
           else in_fn_base
         in
         let pkg_ident = Pkgidents.add in_fn_base_name in
         ( output_lines_reb outch
             [ sprintf "module %s : PKGDESC_ABS =" pkg_ident
             ; "functor (Context : CONTEXT) ->"
             ; "struct"
             ; "open Context"
             ; sprintf "let _this_name : string = %S" in_fn_base_name
             ]
         ; output_string outch Templates.pre_pkg
         ; Filew.with_file_in_bin in_fn
             (fun inch ->
                ( out_line outch in_fn 1
                ; Filew.copy_channels inch outch
                )
             )
         ; output_string outch "\n"
         ; output_lines_reb outch
            [ "let provides_pkgs = List.map Pkg.of_string provides"
            ; "end"
            ]
         ; pkg_ident
         )
      )
      files
    in
      ( output_lines_reb outch
          ( [ "module PkgList (Context : CONTEXT) (PkgProc : PKGDESC_PROC) ="
            ; "struct"
            ]
          @ (List.map
               (fun i -> sprintf "module I_%s = %s(Context)" i i)
               pkg_idents
            )
          @ (List.map
               (fun i -> sprintf "module R_%s = PkgProc(I_%s)" i i)
               pkg_idents
            )
          @ [ "end" ]
          )
      ; output_module "Venvs" Templates.venvs
      ; output_string outch Templates.post_template
      ; output_line_reb outch "let () = main ()"
      ; close_out outch
      ; compile ~ml:out_fn ~exe
      ; Sys.remove out_fn
      )
  )
;


value rec get_named_arg n args =
  match args with
  [ [] -> failwith "argument \"%s <arg>\" must be specified" n
  | [h :: t] ->
      if n = h
      then
        match t with
        [ [] -> failwith "argument %S must have value" n
        | [v :: t] -> (v, t)
        ]
      else
        let (v, t) = get_named_arg n t in
        (v, [h :: t])
  ]
;


value run_cmd ~venvs argv : int =
  let c =
    Venvs.with_findlib_env venvs
      (fun () ->
         Reb_sys.run
           ~show:True
           argv
      )
  in
  let () =
    if c = 0
    then ()
    else
      Printf.eprintf "rebildol: command [%s] exited with code %i\n%!"
        (String.concat "; " (Array.to_list (Array.map (sprintf "%S") argv))) c
  in
    c
;


value rebuild ~venvs files : int =
  let
    ( buildconf_prefix
    , buildconf_work_src  (* path to unpacked sources for building *)
    ) =
    (let open Venvs in
     match Venvs.dest venvs with
     [ Dsys -> failwith "rebuildol can't install to default ocamlfind place \
                         now.  If you want such functionality, discuss its \
                         design with rebildol authors."
     | Ddir d ->
         ( d
         , d</>"var"</>"src"
         )
     ]
    )
  in
  let exe = Filename.temp_dir_name
            </> sprintf "rebrunner_%s.exe" (Venvs.hash_hex venvs)
  in
  let () = make_runner ~exe files in
  run_cmd ~venvs
    [| exe ; "rebuild" ; buildconf_prefix ; buildconf_work_src |]
;


value main () =
  match List.tl & Array.to_list Sys.argv with
  [ [] | [("-help" | "--help") :: _] -> print_string Templates.usage

  | [("-version" | "--version") :: _] -> print_string "rebildol 0.1\n"

  | args ->
      let (venvs, args) = Venvs.venvs_of_args args in
      match args with
      [ ["rebuild" :: files] -> exit (rebuild ~venvs files)
      | ["run" :: argv] -> exit (run_cmd ~venvs (Array.of_list argv))
      | [c :: _] -> failwith "unknown command %S" c
      | [] -> failwith "no command"
      ]

(*
      let (exe, files) = get_named_arg "-o" args in
      proc_files ~exe files
*)
  ]
;

value () =
  let fail msg =
    (eprintf "rebildol error: %s\n%!" msg; exit 1)
  in
  try
    main ()
  with
  [ Failure msg -> fail msg
  | e -> fail & Printexc.to_string e
  ]
;