open! Dune_rules__
open Import
open Memo.O
module Gen_rules = Build_config.Gen_rules

let install_stanza_rules ~ctx_dir ~expander (install_conf : Install_conf.t) =
  let action =
    (* XXX we're evaluating these stanzas here and [Install_rules]. Seems a bit
       sad to do that *)
    let files_and_dirs =
      let expand = Expander.No_deps.expand expander ~mode:Single in
      let+ files_expanded =
        Install_entry.File.to_file_bindings_expanded
          install_conf.files
          ~expand
          ~dir:ctx_dir
      and+ dirs_expanded =
        Install_entry.Dir.to_file_bindings_expanded
          install_conf.dirs
          ~expand
          ~dir:ctx_dir
          ~relative_dst_path_starts_with_parent_error_when:`Deprecation_warning_from_3_11
      in
      List.map (files_expanded @ dirs_expanded) ~f:(fun fb ->
        File_binding.Expanded.src fb |> Path.build)
    in
    let open Action_builder.O in
    Action_builder.of_memo files_and_dirs >>= Action_builder.paths
  in
  Rules.Produce.Alias.add_deps (Alias.make Alias0.all ~dir:ctx_dir) action
;;

module For_stanza : sig
  type ('merlin, 'cctx, 'js, 'source_dirs) t =
    { merlin : 'merlin
    ; cctx : 'cctx
    ; js : 'js
    ; source_dirs : 'source_dirs
    }

  val of_stanzas
    :  Stanza.t list
    -> cctxs:Compilation_context.t Loc.Map.t
    -> sctx:Super_context.t
    -> src_dir:Path.Source.t
    -> ctx_dir:Path.Build.t
    -> scope:Scope.t
    -> dir_contents:Dir_contents.t
    -> expander:Expander.t
    -> ( Merlin.t list
         , Compilation_context.t Loc.Map.t
         , Path.Build.t list
         , Path.Source.t list )
         t
         Memo.t
end = struct
  type ('merlin, 'cctx, 'js, 'source_dirs) t =
    { merlin : 'merlin
    ; cctx : 'cctx
    ; js : 'js
    ; source_dirs : 'source_dirs
    }

  let empty_none = { merlin = None; cctx = None; js = None; source_dirs = None }
  let empty_list = { merlin = []; cctx = Loc.Map.empty; js = []; source_dirs = [] }

  let add_map_maybe hd_o tl =
    match hd_o with
    | Some (loc, hd) -> Loc.Map.add_exn tl loc hd
    | None -> tl
  ;;

  let cons_maybe hd_o tl =
    match hd_o with
    | Some hd -> hd :: tl
    | None -> tl
  ;;

  let cons acc x =
    { merlin = cons_maybe x.merlin acc.merlin
    ; cctx = add_map_maybe x.cctx acc.cctx
    ; source_dirs = cons_maybe x.source_dirs acc.source_dirs
    ; js =
        (match x.js with
         | None -> acc.js
         | Some js -> List.rev_append acc.js js)
    }
  ;;

  let rev t = { t with merlin = List.rev t.merlin; source_dirs = List.rev t.source_dirs }

  let if_available f = function
    | false -> Memo.return empty_none
    | true -> f ()
  ;;

  let with_cctx_merlin ~loc (cctx, merlin) =
    { empty_none with merlin = Some merlin; cctx = Some (loc, cctx) }
  ;;

  let if_available_buildable ~loc f = function
    | false -> Memo.return empty_none
    | true -> f () >>| with_cctx_merlin ~loc
  ;;

  (* XXX it's weird how we're handling some [enabled_if] here, and others are
     being handled directly in the stanza. *)
  let of_stanza stanza ~sctx ~src_dir ~ctx_dir ~scope ~dir_contents ~expander =
    let dir = ctx_dir in
    match Stanza.repr stanza with
    | Toplevel_stanza.T toplevel ->
      let+ () = Toplevel.Stanza.setup ~sctx ~dir ~toplevel in
      empty_none
    | Library.T lib ->
      let* enabled_if =
        Lib.DB.available_by_lib_id
          (Scope.libs scope)
          (Local (Library.to_lib_id ~src_dir lib))
      in
      if_available_buildable
        ~loc:lib.buildable.loc
        (fun () -> Lib_rules.rules lib ~sctx ~scope ~dir_contents ~expander)
        enabled_if
    | Foreign_library.T lib ->
      Expander.eval_blang expander lib.enabled_if
      >>= if_available (fun () ->
        let+ () = Lib_rules.foreign_rules lib ~sctx ~dir ~dir_contents ~expander in
        empty_none)
    | Executables.T exes ->
      Expander.eval_blang expander exes.enabled_if
      >>= if_available (fun () ->
        let+ () =
          Memo.Option.iter exes.install_conf ~f:(install_stanza_rules ~expander ~ctx_dir)
        and+ cctx_merlin = Exe_rules.rules exes ~sctx ~scope ~expander ~dir_contents in
        { (with_cctx_merlin ~loc:exes.buildable.loc cctx_merlin) with
          js =
            Some
              (Nonempty_list.to_list exes.names
               |> List.concat_map ~f:(fun (_, exe) ->
                 List.map Js_of_ocaml.Mode.all ~f:(fun mode ->
                   Path.Build.relative
                     dir
                     (exe ^ Filename.Extension.to_string (Js_of_ocaml.Ext.exe ~mode)))))
        })
    | Alias_conf.T alias ->
      let+ () = Simple_rules.alias sctx alias ~dir ~expander in
      empty_none
    | Tests.T tests ->
      Expander.eval_blang expander tests.exes.enabled_if
      >>= if_available_buildable ~loc:tests.exes.buildable.loc (fun () ->
        Test_rules.rules tests ~sctx ~dir ~scope ~expander ~dir_contents)
    | Copy_files.T { files = glob; _ } ->
      let+ source_dirs =
        let+ src_glob = Expander.No_deps.expand_str expander glob in
        match Filename.is_relative src_glob with
        | false -> None
        | true ->
          (match
             let error_loc = String_with_vars.loc glob in
             Path.relative (Path.source src_dir) src_glob ~error_loc
           with
           | In_source_tree s -> Some (Path.Source.parent_exn s)
           | In_build_dir _ | External _ -> None)
      in
      { empty_none with source_dirs }
    | Install_conf.T i ->
      let+ () = install_stanza_rules ~ctx_dir ~expander i in
      empty_none
    (* There is probably something to do with documentation stanzas, as they
       also generate install rules. *)
    | Plugin.T p ->
      let+ () = Plugin_rules.setup_rules ~sctx ~dir p in
      empty_none
    | Cinaps.T cinaps ->
      let+ () = Cinaps.gen_rules sctx cinaps ~dir ~scope in
      empty_none
    | Mdx.T mdx ->
      Expander.eval_blang expander (Mdx.enabled_if mdx)
      >>= if_available (fun () ->
        let+ () = Mdx.gen_rules ~sctx ~dir ~scope ~expander mdx in
        empty_none)
    | Melange_stanzas.Emit.T mel ->
      Expander.eval_blang expander mel.enabled_if
      >>= if_available_buildable ~loc:mel.loc (fun () ->
        Melange_rules.setup_emit_cmj_rules ~dir_contents ~scope ~sctx ~expander mel)
    | _ -> Memo.return empty_none
  ;;

  let of_stanzas stanzas ~cctxs ~sctx ~src_dir ~ctx_dir ~scope ~dir_contents ~expander =
    Memo.parallel_map
      stanzas
      ~f:(of_stanza ~sctx ~src_dir ~ctx_dir ~scope ~dir_contents ~expander)
    >>| List.fold_left ~init:{ empty_list with cctx = cctxs } ~f:cons
    >>| rev
  ;;
end

let gen_rules_for_stanzas sctx dir_contents cctxs expander ~dune_file ~dir:ctx_dir =
  let src_dir = Dune_file.dir dune_file in
  let* stanzas = Dune_file.stanzas dune_file
  and* scope = Scope.DB.find_by_dir ctx_dir in
  let* { For_stanza.merlin = merlins; cctx = cctxs; js = js_targets; source_dirs } =
    For_stanza.of_stanzas
      stanzas
      ~cctxs
      ~sctx
      ~src_dir
      ~ctx_dir
      ~scope
      ~dir_contents
      ~expander
  in
  let+ () =
    let more_src_dirs =
      Merlin.more_src_dirs dir_contents ~source_dirs:(src_dir :: source_dirs)
    in
    Memo.parallel_iter
      merlins
      ~f:(Merlin.add_rules sctx ~dir:ctx_dir ~more_src_dirs ~expander)
  and+ () =
    Memo.parallel_iter stanzas ~f:(fun stanza ->
      match Stanza.repr stanza with
      | Parser_generators.Ocamllex.T ocamllex ->
        Expander.eval_blang expander ocamllex.enabled_if
        >>= (function
         | false -> Memo.return ()
         | true ->
           Parser_generator_rules.gen_rules
             sctx
             ~dir_contents
             ~dir:ctx_dir
             ~for_:(Ocamllex ocamllex))
      | Parser_generators.Ocamlyacc.T ocamlyacc ->
        Expander.eval_blang expander ocamlyacc.enabled_if
        >>= (function
         | false -> Memo.return ()
         | true ->
           Parser_generator_rules.gen_rules
             sctx
             ~dir_contents
             ~dir:ctx_dir
             ~for_:(Ocamlyacc ocamlyacc))
      | Menhir_stanza.T m ->
        Expander.eval_blang expander m.enabled_if
        >>= (function
         | false -> Memo.return ()
         | true ->
           (* TODO(anmonteiro): support Melange *)
           let* ml_sources = Dir_contents.ml dir_contents ~for_:Ocaml in
           let { Ml_sources.Parser_generators.deps = _; targets } =
             Ml_sources.Parser_generators.modules ml_sources ~for_:(Menhir m.loc)
           in
           Memo.List.find_map (Module_trie.to_list targets) ~f:(fun (_, m) ->
             let module_path = Module.Source.path m in
             Ml_sources.find_origin ml_sources ~libs:(Scope.libs scope) module_path
             >>| Option.bind ~f:(fun loc ->
               Loc.Map.find cctxs (Ml_sources.Origin.loc loc))
             >>| Option.map ~f:(fun cctx -> module_path, cctx))
           >>= (function
            | Some (module_path, cctx) ->
              let module_path, _ = Nonempty_list.destruct_last module_path in
              Menhir_rules.gen_rules cctx m ~dir:ctx_dir ~module_path
            | None ->
              (* This happens often when passing a [-p ...] option that hides a
                 library *)
              let file_targets =
                Module_trie.to_list_map targets ~f:(fun (_, m) ->
                  List.map (Module.Source.files m) ~f:(fun m ->
                    Module.File.path m |> Path.as_in_build_dir_exn))
                |> List.concat
              in
              Super_context.add_rule
                sctx
                ~dir:ctx_dir
                (Action_builder.fail
                   { fail =
                       (fun () ->
                         User_error.raise
                           ~loc:m.loc
                           [ Pp.text
                               "I can't determine what library/executable the files \
                                produced by this stanza are part of."
                           ])
                   }
                 |> Action_builder.with_file_targets ~file_targets)))
      | Coq_stanza.Theory.T m ->
        Expander.eval_blang expander m.enabled_if
        >>= (function
         | false -> Memo.return ()
         | true -> Coq_rules.setup_theory_rules ~sctx ~dir:ctx_dir ~dir_contents m)
      | Coq_stanza.Extraction.T m ->
        Coq_rules.setup_extraction_rules ~sctx ~dir:ctx_dir ~dir_contents m
      | Coq_stanza.Coqpp.T m -> Coq_rules.setup_coqpp_rules ~sctx ~dir:ctx_dir m
      | Rocq_stanza.Theory.T m ->
        Expander.eval_blang expander m.enabled_if
        >>= (function
         | false -> Memo.return ()
         | true -> Rocq_rules.setup_theory_rules ~sctx ~dir:ctx_dir ~dir_contents m)
      | Rocq_stanza.Extraction.T m ->
        Rocq_rules.setup_extraction_rules ~sctx ~dir:ctx_dir ~dir_contents m
      | Rocq_stanza.Rocqpp.T m -> Rocq_rules.setup_rocqpp_rules ~sctx ~dir:ctx_dir m
      | _ -> Memo.return ())
  and+ () =
    let project = Dune_file.project dune_file in
    Alias_builder.define_all_alias ~project ~js_targets ctx_dir
  in
  cctxs
;;

let gen_format_and_cram_rules sctx ~dir source_dir =
  let+ () = Format_rules.setup_alias ~dir
  and+ () = Cram_rules.rules source_dir ~sctx ~dir in
  ()
;;

let gen_rules_source_only sctx ~dir source_dir =
  Rules.collect_unit (fun () ->
    let* sctx = sctx in
    let+ () = gen_format_and_cram_rules sctx ~dir source_dir
    and+ () = Revdep_rules.add ~sctx ~dir
    and+ () =
      Alias_builder.define_all_alias
        ~js_targets:[]
        ~project:(Source_tree.Dir.project source_dir)
        dir
    in
    ())
;;

let gen_rules_group_part_or_root sctx dir_contents cctxs ~source_dir ~dir
  : Compilation_context.t Loc.Map.t Memo.t
  =
  let+ () = gen_format_and_cram_rules sctx ~dir source_dir
  and+ () = Revdep_rules.add ~sctx ~dir
  and+ contexts =
    (* CR-soon rgrinberg: we shouldn't have to fetch the stanzas yet again *)
    Dune_load.stanzas_in_dir dir
    >>= function
    | Some dune_file ->
      Super_context.expander sctx ~dir
      >>= gen_rules_for_stanzas sctx dir_contents cctxs ~dune_file ~dir
    | None ->
      let project = Source_tree.Dir.project source_dir in
      let+ () = Alias_builder.define_all_alias ~js_targets:[] ~project dir in
      Loc.Map.empty
  in
  contexts
;;

(* Warn whenever [(name <name>)]) is missing from the [dune-project] file *)
let missing_project_name =
  Warning.make
    ~default:(fun version -> if version >= (2, 8) then `Enabled else `Disabled)
    ~name:"missing_project_name"
    ~since:(3, 11)
;;

(* Warn about duplicate dependencies in package definitions *)
let duplicate_deps =
  Warning.make ~default:(fun _ -> `Enabled) ~name:"duplicate_deps" ~since:(3, 18)
;;

(* To be called once per project, when we are generating the rules for the root
   directory of the project *)
let gen_project_rules =
  let rules sctx project =
    let* sctx = sctx in
    let+ () = Install_rules.gen_project_rules sctx project
    and+ () = Odoc.gen_project_rules sctx project
    and+ () = Odoc_new.gen_project_rules sctx project
    and+ () = Ocaml_index.project_rule sctx project
    and+ () =
      let version = 2, 8 in
      match Dune_project.allow_approximate_merlin project with
      | None -> Memo.return ()
      | Some _ when Dune_project.dune_version project < version -> Memo.return ()
      | Some loc ->
        let+ vendored = Source_tree.is_vendored (Dune_project.root project) in
        if not vendored
        then
          Dune_lang.Syntax.Warning.deprecated_in
            ~extra_info:
              "It is useless since the Merlin configurations are not ambiguous anymore."
            loc
            Stanza.syntax
            version
            ~what:"This field"
    and+ () =
      match Dune_project_name.name (Dune_project.name project) with
      | Some _ -> Memo.return ()
      | None ->
        (match
           if
             Dune_project.dune_version project >= (2, 8)
             && Dune_project.generate_opam_files project
           then Dune_project.file project
           else None
         with
         | None -> Memo.return ()
         | Some project_file ->
           Warning_emit.emit
             missing_project_name
             (Warning_emit.Context.project project)
             (fun () ->
                let+ () = Memo.return () in
                let loc = Loc.in_file (Path.source project_file) in
                User_message.make
                  ~loc
                  [ Pp.text
                      "Project name is not specified. Add a (name <project-name>) field \
                       to your dune-project file to make sure that $ dune subst works in \
                       release or pinned builds"
                  ]))
    and+ () =
      (* Emit warnings for duplicate dependencies in packages *)
      let packages = Dune_project.packages project in
      Dune_lang.Package.Name.Map.values packages
      |> Memo.parallel_iter ~f:(fun pkg ->
        Dune_lang.Package.duplicate_dep_warnings pkg
        |> Memo.parallel_iter
             ~f:(fun (warning : Dune_lang.Package.Duplicate_dep_warning.t) ->
               Warning_emit.emit
                 duplicate_deps
                 (Warning_emit.Context.project project)
                 (fun () ->
                    Memo.return
                      (User_message.make
                         ~loc:warning.loc
                         [ Pp.textf
                             "Duplicate dependency on package %s in '%s' field. If you \
                              want to specify multiple constraints, combine them using \
                              (and ...)."
                             warning.dep_string
                             warning.field_name
                         ]))))
    in
    ()
  in
  fun sctx source_dir ->
    let* () = Memo.return () in
    let project = Source_tree.Dir.project source_dir in
    match
      Path.Source.equal (Source_tree.Dir.path source_dir) (Dune_project.root project)
    with
    | false -> Memo.return Rules.empty
    | true -> Rules.collect_unit (fun () -> rules sctx project)
;;

module Automatic_subdir = struct
  (* TODO Handle all of these subdirectories at the toplevel like [.topmod] *)

  (* Sub-dirs that are automatically generated in all directories. Or rather, all
     the ones that have a corresponding source directory. *)
  type t =
    | Utop
    | Formatted
    | Bin

  let map =
    Filename.Map.of_list_exn
      [ Utop.utop_dir_basename, Utop
      ; Format_rules.formatted_dir_basename, Formatted
      ; Artifacts.bin_dir_basename, Bin
      ]
  ;;

  let of_src_dir src_dir =
    match Path.Source.basename_opt src_dir with
    | None -> None
    | Some basename -> Filename.Map.find map basename
  ;;

  let subdirs components =
    match List.last components with
    | None -> Filename.Set.of_keys map
    | Some comp ->
      if Filename.Map.mem map comp then Filename.Set.empty else Filename.Set.of_keys map
  ;;

  let gen_rules ~sctx ~dir kind =
    match kind with
    | Utop -> sctx >>= Utop.setup ~dir:(Path.Build.parent_exn dir)
    | Formatted -> Format_rules.gen_rules sctx ~output_dir:dir
    | Bin ->
      let* sctx = sctx in
      Super_context.env_node sctx ~dir:(Path.Build.parent_exn dir)
      >>= Env_node.local_binaries
      >>= Memo.parallel_iter ~f:(fun t ->
        let loc = File_binding.Expanded.src_loc t in
        let src = Path.build (File_binding.Expanded.src t) in
        let dst = File_binding.Expanded.dst_path t ~dir in
        Super_context.add_rule sctx ~loc ~dir (Action_builder.symlink ~src ~dst))
  ;;
end

let has_rules ~dir subdirs f =
  let rules = Rules.collect_unit f in
  Memo.return
    (Gen_rules.make
       ~build_dir_only_sub_dirs:(Gen_rules.Build_only_sub_dirs.singleton ~dir subdirs)
       rules)
;;

let gen_rules_standalone_or_root sctx ~dir ~source_dir =
  let* sctx = sctx in
  let* standalone_or_root =
    Dir_contents.triage ~dir sctx
    >>| function
    | Group_part _ -> assert false
    | Standalone_or_root standalone_or_root -> standalone_or_root
  in
  let* () = Memo.Lazy.force Configurator_rules.force_files in
  let* rules' =
    Rules.collect_unit (fun () ->
      let* dir_contents = Dir_contents.Standalone_or_root.root standalone_or_root in
      let* cctxs =
        gen_rules_group_part_or_root sctx dir_contents Loc.Map.empty ~source_dir ~dir
      in
      Dir_contents.Standalone_or_root.subdirs standalone_or_root
      >>= Memo.parallel_iter ~f:(fun dc ->
        let source_dir = Option.value_exn (Dir_contents.source_dir dc) in
        let+ (_ : Compilation_context.t Loc.Map.t) =
          gen_rules_group_part_or_root
            sctx
            dir_contents
            cctxs
            ~source_dir
            ~dir:(Dir_contents.dir dc)
        in
        ()))
  in
  let+ rules = Dir_contents.Standalone_or_root.rules standalone_or_root in
  Rules.union rules rules'
;;

let gen_automatic_subdir_rules sctx ~dir ~nearest_src_dir ~src_dir =
  (* There is always a source dir at the root, so we can't be at the root if
     we are in this branch *)
  match
    match nearest_src_dir with
    | None -> None
    | Some _ -> Automatic_subdir.of_src_dir src_dir
  with
  | None -> Memo.return Rules.empty
  | Some kind -> Rules.collect_unit (fun () -> Automatic_subdir.gen_rules ~sctx ~dir kind)
;;

let gen_rules_regular_directory (sctx : Super_context.t Memo.t) ~src_dir ~components ~dir =
  Dir_status.DB.get ~dir
  >>= function
  | Lock_dir _ -> Memo.return Gen_rules.no_rules
  | dir_status ->
    let+ rules =
      let* st_dir = Source_tree.find_dir src_dir in
      let* nearest_src_dir =
        match st_dir with
        | Some dir -> Memo.return (Some dir)
        | None -> Source_tree.find_dir (Path.Source.parent_exn src_dir)
      in
      let+ rules =
        let+ make_rules =
          let+ directory_targets =
            Dir_status.directory_targets
              dir_status
              ~jsoo_enabled:Jsoo_rules.jsoo_enabled
              ~dir
          in
          let allowed_subdirs =
            let automatic = Automatic_subdir.subdirs components in
            let toplevel =
              match components with
              | _ :: _ -> Filename.Set.empty
              | [] ->
                (* XXX sync this list with the pattern matches above. It's quite ugly
                   we need this, we should rewrite this code to avoid this. *)
                Filename.Set.of_list
                  [ ".js"
                  ; "_doc"
                  ; "_doc_new"
                  ; ".ppx"
                  ; ".dune"
                  ; ".topmod"
                  ; Dune_lang.Oxcaml.parameterised_dir
                  ]
            in
            Filename.Set.union automatic toplevel
          in
          fun rules ->
            let rules =
              let+ automatic_subdir_rules =
                gen_automatic_subdir_rules sctx ~dir ~nearest_src_dir ~src_dir
              and+ project_rules =
                match st_dir with
                | None -> Memo.return Rules.empty
                | Some st_dir -> gen_project_rules sctx st_dir
              and+ compile_commands_rules =
                (* Generate compile_commands.json only for the merlin
                   context at the context root *)
                match components with
                | [] ->
                  let* sctx = sctx in
                  if Context.merlin (Super_context.context sctx)
                  then Rules.collect_unit (fun () -> Compile_commands.gen_rules sctx)
                  else Memo.return Rules.empty
                | _ -> Memo.return Rules.empty
              and+ rules = rules in
              Rules.union
                (Rules.union
                   (Rules.union project_rules automatic_subdir_rules)
                   compile_commands_rules)
                rules
            in
            Gen_rules.rules_for ~dir ~directory_targets ~allowed_subdirs rules
        in
        match dir_status with
        | Lock_dir _ -> Gen_rules.rules_here Gen_rules.Rules.empty
        | Source_only source_dir ->
          gen_rules_source_only sctx ~dir source_dir |> make_rules |> Gen_rules.rules_here
        | Generated | Is_component_of_a_group_but_not_the_root _ ->
          Memo.return Rules.empty |> make_rules |> Gen_rules.redirect_to_parent
        | Standalone (source_dir, _) | Group_root { source_dir; _ } ->
          gen_rules_standalone_or_root sctx ~dir ~source_dir
          |> make_rules
          |> Gen_rules.rules_here
      in
      match Opam_create.gen_rules sctx ~dir ~nearest_src_dir ~src_dir with
      | None -> rules
      | Some opam_rules ->
        Gen_rules.map_rules rules ~f:(Gen_rules.Rules.combine_exn opam_rules)
    and+ melange_rules = Melange_rules.setup_emit_js_rules sctx ~dir in
    Gen_rules.combine melange_rules rules
;;

(* Once [gen_rules] has decided what to do with the directory, it should end
   with [has_rules] or [redirect_to_parent] *)
let gen_rules ctx sctx ~dir components : Gen_rules.result Memo.t =
  let src_dir = Path.Build.drop_build_context_exn dir in
  match components with
  | [ ".dune"; "cc_vendor" ] ->
    has_rules ~dir Subdir_set.empty (fun () ->
      (* Add rules for C compiler detection *)
      let* sctx = sctx in
      Cc_rules.rules ~sctx ~dir)
  | ".js" :: rest ->
    has_rules
      ~dir
      (match rest with
       | [] | [ _ ] -> Subdir_set.all
       | [ _; ".runtime" ] -> Subdir_set.all
       | _ -> Subdir_set.empty)
      (fun () ->
         (* XXX the use of the super context is dubious here. We're using it to
           take into account the env stanza. But really, these are internal
           libraries that are being compiled and user settings should be
           ignored. *)
         let* sctx = sctx in
         Jsoo_rules.setup_separate_compilation_rules sctx rest)
  | "_doc" :: rest ->
    let* sctx = sctx in
    Odoc.gen_rules sctx rest ~dir
  | "_doc_new" :: rest ->
    let* sctx = sctx in
    Odoc_new.gen_rules sctx rest ~dir
  | ".topmod" :: comps ->
    has_rules
      ~dir
      (match comps with
       | [] -> Subdir_set.all
       | _ -> Subdir_set.empty)
      (fun () ->
         let* sctx = sctx in
         Top_module.gen_rules sctx ~dir ~comps)
  | ".ppx" :: rest ->
    has_rules
      ~dir
      (match rest with
       | [] -> Subdir_set.all
       | _ -> Subdir_set.empty)
      (fun () ->
         let* sctx = sctx in
         Pp_spec_rules.gen_rules sctx rest)
  | [ ".dune" ] ->
    has_rules
      ~dir
      (Subdir_set.of_set (Filename.Set.of_list [ "cc_vendor" ]))
      (fun () -> Configurator_rules.gen_rules ctx)
  | parameterised_dir :: rest
    when String.equal parameterised_dir Dune_lang.Oxcaml.parameterised_dir ->
    let* sctx = sctx in
    Parameterised_rules.gen_rules ~sctx ~dir rest
  | _ ->
    Jsoo_archive_rules.lib_archive_rules_for_dir ~dir
    >>= (function
     | Jsoo_archive_rules.Not_found ->
       gen_rules_regular_directory sctx ~src_dir ~components ~dir
     | Jsoo_archive_rules.Root ->
       let build_dir_only_sub_dirs =
         Gen_rules.Build_only_sub_dirs.singleton ~dir Subdir_set.all
       in
       Gen_rules.make ~build_dir_only_sub_dirs (Memo.return Rules.empty) |> Memo.return
     | Jsoo_archive_rules.Rules rules -> Gen_rules.make (Memo.return rules) |> Memo.return)
;;

let with_context ctx ~f =
  Super_context.find ctx
  >>= function
  | None -> Memo.return Gen_rules.unknown_context
  | Some ctx -> f ctx
;;

let analyze_private_context_path components =
  match components with
  | [] -> Memo.return `Root
  | ctx :: components ->
    (match Context_name.of_string_opt ctx with
     | None -> Memo.return `Invalid_context
     | Some ctx ->
       Per_context.valid ctx
       >>| (function
        | true -> `Valid (ctx, components)
        | false -> `Invalid_context))
;;

let private_context ~dir components _ctx =
  analyze_private_context_path components
  >>= function
  | `Invalid_context -> Memo.return Gen_rules.unknown_context
  | `Valid (ctx, components) ->
    let+ lock_rules = Lock_rules.setup_rules ~dir ~components
    and+ pkg_rules = Pkg_rules.setup_rules ctx ~dir ~components in
    Gen_rules.combine lock_rules pkg_rules
  | `Root ->
    let+ contexts = Per_context.list () in
    let build_dir_only_sub_dirs =
      Gen_rules.Build_only_sub_dirs.singleton
        ~dir
        (Subdir_set.of_list (List.rev_map contexts ~f:Context_name.to_string))
    in
    Gen_rules.make ~build_dir_only_sub_dirs (Memo.return Rules.empty)
;;

let raise_on_lock_dir_out_of_sync =
  Per_context.create_by_name ~name:"check-lock-dir" (fun ctx ->
    Memo.lazy_ (fun () ->
      let* lock_dir_available = Lock_dir.lock_dir_active ctx in
      if lock_dir_available
      then
        let* path, lock_dir = Lock_dir.get_with_path ctx >>| User_error.ok_exn in
        let+ local_packages =
          Dune_load.packages ()
          >>| Dune_lang.Package.Name.Map.map ~f:Dune_pkg.Local_package.of_package
        in
        match
          Dune_pkg.Package_universe.up_to_date
            local_packages
            ~dependency_hash:(Option.map ~f:snd lock_dir.dependency_hash)
        with
        | `Valid -> ()
        | `Invalid ->
          let source_path = Dune_pkg.Lock_dir.in_source_tree path in
          let loc_path = Path.source source_path in
          let loc = Loc.in_file (Path.relative loc_path "lock.dune") in
          let hints = Pp.[ text "run dune pkg lock" ] in
          User_error.raise
            ~loc
            ~hints
            [ Pp.text "The lock dir is not sync with your dune-project" ]
      else Memo.return ())
    |> Memo.Lazy.force)
  |> Staged.unstage
;;

let gen_rules ctx ~dir components =
  if Context_name.equal ctx Install.Context.install_context.name
  then (
    match components with
    | [] ->
      let+ build_dir_only_sub_dirs =
        let+ context_dirs =
          let+ workspace = Workspace.workspace () in
          Workspace.build_contexts workspace
          |> List.map ~f:(fun (ctx : Build_context.t) -> Context_name.to_string ctx.name)
          |> Subdir_set.of_list
        in
        Gen_rules.Build_only_sub_dirs.singleton ~dir context_dirs
      in
      Gen_rules.make ~build_dir_only_sub_dirs (Memo.return Rules.empty)
    | ctx :: _ ->
      let ctx = Context_name.of_string ctx in
      with_context ctx ~f:(fun sctx ->
        let+ subdirs, rules = Install_rules.symlink_rules sctx ~dir in
        let directory_targets = Rules.directory_targets rules in
        Gen_rules.make
          ~build_dir_only_sub_dirs:(Gen_rules.Build_only_sub_dirs.singleton ~dir subdirs)
          ~directory_targets
          (Memo.return rules)))
  else if Context_name.equal ctx Private_context.t.name
  then private_context ~dir components ctx
  else if Context_name.equal ctx Fetch_rules.context.name
  then Fetch_rules.gen_rules ~dir ~components
  else
    let* () = raise_on_lock_dir_out_of_sync ctx in
    let gen_pkg_alias_rule = Pkg_rules.setup_pkg_install_alias ~dir ctx in
    let+ sctx_rules = gen_rules ctx (Super_context.find_exn ctx) ~dir components in
    Gen_rules.combine sctx_rules gen_pkg_alias_rule
;;
