dune/src/jbuild_load.ml

open Import
open Jbuild

module Jbuilds = struct
  type script =
    { dir   : Path.t
    ; scope : Scope.t
    }

  type one =
    | Literal of (Path.t * Scope.t * Stanza.t list)
    | Script of script

  type t = one list

  let generated_jbuilds_dir = Path.(relative root) "_build/.jbuilds"

  let ensure_parent_dir_exists path =
    match Path.kind path with
    | Local path -> Path.Local.ensure_parent_directory_exists path
    | External _ -> ()

  let extract_requires ~fname str =
    let rec loop n lines acc =
      match lines with
      | [] -> acc
      | line :: lines ->
        let acc =
          match Scanf.sscanf line "#require %S" (fun x -> x) with
          | exception _ -> acc
          | s ->
            match String.split s ~on:',' with
            | [] -> acc
            | ["unix"] as l -> l
            | _ ->
              let start =
                { Lexing.
                  pos_fname = fname
                ; pos_lnum  = n
                ; pos_cnum  = 0
                ; pos_bol   = 0
                }
              in
              Loc.fail
                { start; stop = { start with pos_cnum = String.length line } }
                "Using libraries other that \"unix\" is not supported.\n\
                 See the manual for details.";
        in
        loop (n + 1) lines acc
    in
    loop 1 (String.split str ~on:'\n') []

  let create_plugin_wrapper (context : Context.t) ~exec_dir ~plugin ~wrapper ~target =
    let plugin = Path.to_string plugin in
    let plugin_contents = Io.read_file plugin in
    Io.with_file_out (Path.to_string wrapper) ~f:(fun oc ->
      Printf.fprintf oc {|
let () =
  Hashtbl.add Toploop.directive_table "require" (Toploop.Directive_string ignore);
  Hashtbl.add Toploop.directive_table "use" (Toploop.Directive_string (fun _ ->
    failwith "#use is not allowed inside jbuild in OCaml syntax"));
  Hashtbl.add Toploop.directive_table "use_mod" (Toploop.Directive_string (fun _ ->
    failwith "#use is not allowed inside jbuild in OCaml syntax"))

module Jbuild_plugin = struct
  module V1 = struct
    let context       = %S
    let ocaml_version = %S

    let ocamlc_config =
      [ %s
      ]

    let send s =
      let oc = open_out_bin %S in
      output_string oc s;
      close_out oc
  end
end
# 1 %S
%s|}
        context.name
        context.version
        (String.concat ~sep:"\n      ; "
           (let longest = List.longest_map context.ocamlc_config ~f:fst in
            List.map context.ocamlc_config ~f:(fun (k, v) ->
                Printf.sprintf "%-*S , %S" (longest + 2) k v)))
        (Path.reach ~from:exec_dir target)
        plugin plugin_contents);
    extract_requires ~fname:plugin plugin_contents

  let eval jbuilds ~(context : Context.t) =
    let open Future in
    List.map jbuilds ~f:(function
      | Literal x -> return x
      | Script { dir; scope } ->
        let file = Path.relative dir "jbuild" in
        let generated_jbuild =
          Path.append (Path.relative generated_jbuilds_dir context.name) file
        in
        let wrapper = Path.extend_basename generated_jbuild ~suffix:".ml" in
        ensure_parent_dir_exists generated_jbuild;
        let requires =
          create_plugin_wrapper context ~exec_dir:dir ~plugin:file ~wrapper
            ~target:generated_jbuild
        in
        let context = Option.value context.for_host ~default:context in
        let pkgs =
          List.map requires ~f:(Findlib.find_exn context.findlib
                                  ~required_by:[Utils.jbuild_name_in ~dir:dir])
          |> Findlib.closure ~required_by:dir ~local_public_libs:String_map.empty
        in
        let includes =
          List.fold_left pkgs ~init:Path.Set.empty ~f:(fun acc pkg ->
            Path.Set.add pkg.Findlib.dir acc)
          |> Path.Set.elements
          |> List.concat_map ~f:(fun path ->
              [ "-I"; Path.to_string path ])
        in
        let cmas =
          List.concat_map pkgs ~f:(fun pkg -> pkg.archives.byte)
        in
        let args =
          List.concat
            [ [ "-I"; "+compiler-libs" ]
            ; includes
            ; List.map cmas ~f:(Path.reach ~from:dir)
            ; [ Path.to_absolute_filename wrapper ]
            ]
        in
        (* CR-someday jdimino: if we want to allow plugins to use findlib:
           {[
             let args =
               match context.toplevel_path with
               | None -> args
               | Some path -> "-I" :: Path.reach ~from:dir path :: args
             in
           ]}
        *)
        Future.run Strict ~dir:(Path.to_string dir) ~env:context.env
          (Path.to_string context.ocaml)
          args
        >>= fun () ->
        if not (Path.exists generated_jbuild) then
          die "@{<error>Error:@} %s failed to produce a valid jbuild file.\n\
               Did you forgot to call [Jbuild_plugin.V*.send]?"
            (Path.to_string file);
        let sexps = Sexp.load ~fname:(Path.to_string generated_jbuild) ~mode:Many in
        return (dir, scope, Stanzas.parse scope sexps ~file:generated_jbuild))
    |> Future.all
end

type conf =
  { file_tree : File_tree.t
  ; jbuilds   : Jbuilds.t
  ; packages  : Package.t String_map.t
  ; scopes    : Scope.t list
  }

let load ~dir ~scope =
  let file = Path.relative dir "jbuild" in
  match Sexp.load_many_or_ocaml_script (Path.to_string file) with
  | Sexps sexps ->
    Jbuilds.Literal (dir, scope, Stanzas.parse scope sexps ~file)
  | Ocaml_script ->
    Script { dir; scope }

let load ?extra_ignored_subtrees () =
  let ftree = File_tree.load Path.root ?extra_ignored_subtrees in
  let packages =
    File_tree.fold ftree ~traverse_ignored_dirs:false ~init:[] ~f:(fun dir pkgs ->
      let path = File_tree.Dir.path dir in
      let files = File_tree.Dir.files dir in
      String_set.fold files ~init:pkgs ~f:(fun fn acc ->
        match Filename.split_extension fn with
        | (pkg, ".opam") when pkg <> "" ->
          let version_from_opam_file =
            let opam = Opam_file.load (Path.relative path fn |> Path.to_string) in
            match Opam_file.get_field opam "version" with
            | Some (String (_, s)) -> Some s
            | _ -> None
          in
          (pkg,
           { Package. name = pkg
           ; path
           ; version_from_opam_file
           }) :: acc
        | _ -> acc))
  in
  let packages =
    String_map.of_alist_multi packages
    |> String_map.mapi ~f:(fun name pkgs ->
      match pkgs with
      | [pkg] -> pkg
      | _ ->
        die "Too many opam files for package %S:\n%s"
          name
          (String.concat ~sep:"\n"
             (List.map pkgs ~f:(fun pkg ->
                sprintf "- %s" (Path.to_string (Package.opam_file pkg))))))
  in
  let scopes =
    String_map.values packages
    |> List.map ~f:(fun pkg -> (pkg.Package.path, pkg))
    |> Path.Map.of_alist_multi
    |> Path.Map.map ~f:Scope.make
  in
  let scopes =
    if Path.Map.mem Path.root scopes then
      scopes
    else
      Path.Map.add scopes ~key:Path.root ~data:Scope.empty
  in
  let rec walk dir jbuilds scope =
    if File_tree.Dir.ignored dir then
      jbuilds
    else begin
      let path = File_tree.Dir.path dir in
      let files = File_tree.Dir.files dir in
      let sub_dirs = File_tree.Dir.sub_dirs dir in
      let scope = Path.Map.find_default path scopes ~default:scope in
      let jbuilds =
        if String_set.mem "jbuild" files then
          let jbuild = load ~dir:path ~scope in
          jbuild :: jbuilds
        else
          jbuilds
      in
      String_map.fold sub_dirs ~init:jbuilds
        ~f:(fun ~key:_ ~data:dir jbuilds ->
          walk dir jbuilds scope)
    end
  in
  let jbuilds = walk (File_tree.root ftree) [] Scope.empty in
  { file_tree = ftree
  ; jbuilds
  ; packages
  ; scopes = Path.Map.values scopes
  }