open! Dune_rules__
open Import
open Memo.O

module Alias_rules = struct
  let check_empty ~loc ~dir alias =
    match Alias.Name.compare (Alias.name alias) Alias0.empty with
    | Lt | Gt -> Memo.return ()
    | Eq ->
      let* project = Dune_load.find_project ~dir in
      if Dune_project.dune_version project >= (3, 20)
      then
        User_error.raise
          ~loc
          [ Pp.text "User-defined rules cannot be added to the 'empty' alias" ]
      else Memo.return ()
  ;;

  let add sctx ~alias ~loc build =
    let dir = Alias.dir alias in
    check_empty ~loc ~dir alias
    >>> Super_context.add_alias_action sctx alias ~dir ~loc build
  ;;

  let add_empty sctx ~loc ~alias =
    let action = Action_builder.return (Action.Full.make Action.empty) in
    add sctx ~loc ~alias action
  ;;
end

let check_filename =
  let not_in_dir ~kind ~error_loc s =
    User_error.raise
      ~loc:error_loc
      [ (match kind with
         | Targets_spec.Kind.File ->
           Pp.textf "%S does not denote a file in the current directory." s
         | Directory -> Pp.textf "Directory targets must have exactly one path component.")
      ]
  in
  fun ~kind ~error_loc ~dir -> function
    | Value.String ("." | "..") ->
      User_error.raise ~loc:error_loc [ Pp.text "'.' and '..' are not valid targets" ]
    | String s ->
      if Filename.dirname s <> Filename.current_dir_name
      then not_in_dir ~kind ~error_loc s;
      Path.Build.relative ~error_loc dir s
    | Path p ->
      (match Option.equal Path.equal (Path.parent p) (Some (Path.build dir)) with
       | true -> Path.as_in_build_dir_exn p
       | false -> not_in_dir ~kind ~error_loc (Path.to_string p))
    | Dir p -> not_in_dir ~kind ~error_loc (Path.to_string p)
;;

type rule_kind =
  | Aliases_only of Alias.Name.t list
  | Aliases_with_targets of Alias.Name.t list * Path.Build.t
  | No_alias

let rule_kind ~(rule : Rule_conf.t) ~(action : _ Action_builder.With_targets.t) =
  match rule.aliases with
  | [] -> No_alias
  | aliases ->
    (match Targets.head action.targets with
     | None -> Aliases_only aliases
     | Some target -> Aliases_with_targets (aliases, target))
;;

let interpret_and_add_locks ~expander locks action =
  let open Action_builder.O in
  Expander.expand_locks expander locks
  >>= function
  | [] -> action
  | locks -> Action_builder.map action ~f:(Action.Full.add_locks locks)
;;

let add_user_rule
      sctx
      ~dir
      ~(rule : Rule_conf.t)
      ~(action : Action.Full.t Action_builder.With_targets.t)
      ~expander
  =
  let action =
    let build = interpret_and_add_locks ~expander rule.locks action.build in
    { action with Action_builder.With_targets.build }
  in
  let* mode = Rule_mode_expand.expand_path ~expander ~dir rule.mode in
  Super_context.add_rule_get_targets sctx ~dir ~mode ~loc:rule.loc action
;;

let dep_uses_patch_back_source_tree (d : Dep_conf.t) =
  match d with
  | Sandbox_config config ->
    Dep_conf.Sandbox_config.fold config ~init:false ~f:(fun mode acc ->
      acc || Poly.equal mode `Patch_back_source_tree)
  | _ -> false
;;

let rule_uses_patch_back_source_tree (rule : Rule_conf.t) =
  (* CR-someday rgrinberg: early exit from fold *)
  Bindings.fold rule.deps ~init:false ~f:(fun one acc ->
    acc
    ||
    match one with
    | Unnamed dep -> dep_uses_patch_back_source_tree dep
    | Named (_, deps) -> List.exists deps ~f:dep_uses_patch_back_source_tree)
;;

let validate_corrections ~(rule : Rule_conf.t) =
  match rule.corrections with
  | None -> ()
  | Some Ignore -> ()
  | Some Produce ->
    if rule_uses_patch_back_source_tree rule
    then
      User_error.raise
        ~loc:rule.loc
        [ Pp.text
            "Only (corrections ignore) is allowed on rules using patch-back-source-tree \
             sandboxing."
        ]
;;

let add_corrections ~(rule : Rule_conf.t) action =
  match rule.corrections with
  | None -> action
  | Some Ignore -> Action.Full.add_corrections Ignore action
  | Some Produce ->
    action
    |> Action.Full.add_sandbox Sandbox_config.needs_sandboxing
    |> Action.Full.add_corrections Produce
;;

let user_rule sctx ~dir ~expander (rule : Rule_conf.t) =
  Expander.eval_blang expander rule.enabled_if
  >>= function
  | false ->
    let+ () =
      Memo.parallel_iter rule.aliases ~f:(fun alias ->
        let alias = Alias.make ~dir alias in
        Alias_rules.add_empty sctx ~loc:rule.loc ~alias)
    in
    None
  | true ->
    let* targets =
      match rule.targets with
      | Infer -> Memo.return Targets_spec.Infer
      | Static { targets; multiplicity } ->
        let+ targets =
          Memo.List.concat_map targets ~f:(fun (target, kind) ->
            (match multiplicity with
             | One ->
               Expander.No_deps.expand expander ~mode:Single target >>| List.singleton
             | Multiple -> Expander.No_deps.expand expander ~mode:Many target)
            >>|
            let error_loc = String_with_vars.loc target in
            List.map ~f:(fun value -> check_filename ~kind ~dir ~error_loc value, kind))
        in
        Targets_spec.Static { multiplicity; targets }
    in
    let sandbox =
      if
        rule_uses_patch_back_source_tree rule
        || Dune_project.dune_version (Expander.project expander) >= (3, 23)
      then Sandbox_config.needs_sandboxing
      else Sandbox_config.no_special_requirements
    in
    let () = validate_corrections ~rule in
    let* action =
      let chdir = Expander.dir expander in
      Action_unexpanded.expand
        (snd rule.action)
        sandbox
        ~loc:(fst rule.action)
        ~chdir
        ~expander
        ~deps:rule.deps
        ~targets
        ~targets_dir:dir
    in
    let action = Action_builder.With_targets.map action ~f:(add_corrections ~rule) in
    (match rule_kind ~rule ~action with
     | No_alias ->
       let+ targets = add_user_rule sctx ~dir ~rule ~action ~expander in
       Some targets
     | Aliases_with_targets (aliases, alias_target) ->
       let+ () =
         Memo.parallel_iter aliases ~f:(fun alias ->
           let loc =
             (* standard aliases don't have a loc *)
             match Alias0.is_standard alias with
             | true -> Loc.none
             | false -> rule.loc
           in
           let alias = Alias.make ~dir alias in
           Rules.Produce.Alias.add_deps
             alias
             ~loc
             (Action_builder.path (Path.build alias_target)))
       and+ targets = add_user_rule sctx ~dir ~rule ~action ~expander in
       Some targets
     | Aliases_only aliases ->
       let+ () =
         match List.map ~f:(Alias.make ~dir) aliases with
         | [] -> Code_error.raise "empty list of aliases" []
         | alias :: extra_aliases ->
           let loc = rule.loc in
           interpret_and_add_locks ~expander rule.locks action.build
           |> Alias_rules.add sctx ~alias ~loc
           >>> Memo.parallel_iter extra_aliases ~f:(fun extra_alias ->
             Dep.alias alias
             |> Action_builder.dep
             |> Rules.Produce.Alias.add_deps ~loc extra_alias)
       in
       None)
;;

let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) =
  let loc = String_with_vars.loc def.files in
  let* glob_in_src =
    let+ src_glob = Expander.No_deps.expand_str expander def.files in
    if Filename.is_relative src_glob
    then Path.relative (Path.source src_dir) src_glob ~error_loc:loc
    else (
      let since = 2, 7 in
      if def.syntax_version < since
      then
        Dune_lang.Syntax.Error.since
          loc
          Stanza.syntax
          since
          ~what:(sprintf "%s is an absolute path. This" src_glob);
      Path.external_ (Path.External.of_string src_glob))
  in
  let since = 1, 3 in
  if
    def.syntax_version < since
    && not (Path.is_descendant glob_in_src ~of_:(Path.source src_dir))
  then
    Dune_lang.Syntax.Error.since
      loc
      Stanza.syntax
      since
      ~what:
        (sprintf
           "%s is not a sub-directory of %s. This"
           (Path.to_string_maybe_quoted glob_in_src)
           (Path.Source.to_string_maybe_quoted src_dir));
  let src_in_src = Path.parent_exn glob_in_src in
  let glob = Path.basename glob_in_src |> Glob.of_string_exn loc in
  let src_in_build =
    match Path.as_in_source_tree src_in_src with
    | None -> src_in_src
    | Some src_in_src ->
      let context = Super_context.context sctx in
      Path.Build.append_source (Context.build_dir context) src_in_src |> Path.build
  in
  let* exists_or_generated =
    match src_in_src with
    | In_build_dir _ -> assert false
    | External ext -> Fs_memo.dir_exists (External ext)
    | In_source_tree src_in_src ->
      Source_tree.find_dir src_in_src
      >>= (function
       | Some _ -> Memo.return true
       | None -> Load_rules.is_under_directory_target src_in_build)
  in
  if not exists_or_generated
  then
    User_error.raise
      ~loc
      [ Pp.textf "Cannot find directory: %s" (Path.to_string src_in_src) ];
  if Path.equal src_in_src (Path.source src_dir)
  then
    User_error.raise
      ~loc
      [ Pp.textf
          "Cannot copy files onto themselves. The format is <dir>/<glob> where <dir> is \
           not the current directory."
      ];
  (* add rules *)
  let* only_sources = Expander.eval_blang expander def.only_sources in
  let* files =
    let dir =
      match only_sources with
      | true -> src_in_src
      | false -> src_in_build
    in
    Build_system.eval_pred (File_selector.of_glob ~dir glob)
  in
  if def.syntax_version >= (3, 17) && Filename_set.is_empty files
  then User_error.raise ~loc [ Pp.textf "Does not match any files" ];
  let* mode = Rule_mode_expand.expand_path ~dir ~expander def.mode in
  (* CR-someday amokhov: We currently traverse the set [files] twice: first, to
     add the corresponding rules, and then to convert the files to [targets]. To
     do only one traversal we need [Memo.parallel_map_set]. *)
  let* () =
    Memo.parallel_iter_seq
      (Filename.Set.to_seq (Filename_set.filenames files))
      ~f:(fun basename ->
        let file_src = Path.relative src_in_build basename in
        let file_dst = Path.Build.relative dir basename in
        let context = Super_context.context sctx in
        Super_context.add_rule
          sctx
          ~loc
          ~dir
          ~mode
          ((if def.add_line_directive
            then Copy_line_directive.builder context
            else Action_builder.copy)
             ~src:file_src
             ~dst:file_dst))
  in
  let targets =
    Filename.Set.to_list_map (Filename_set.filenames files) ~f:(fun basename ->
      let file_dst = Path.Build.relative dir basename in
      Path.build file_dst)
    |> Path.Set.of_list
  in
  let+ () =
    Memo.Option.iter def.alias ~f:(fun alias ->
      let alias = Alias.make alias ~dir in
      Alias_rules.check_empty ~loc ~dir alias
      >>> Rules.Produce.Alias.add_deps alias (Action_builder.path_set targets))
  in
  targets
;;

let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) =
  Expander.eval_blang expander def.enabled_if
  >>= function
  | true -> copy_files sctx ~dir ~expander ~src_dir def
  | false -> Memo.return Path.Set.empty
;;

let alias sctx ~dir ~expander (alias_conf : Alias_conf.t) =
  let alias = Alias.make ~dir alias_conf.name in
  let loc = alias_conf.loc in
  Alias_rules.check_empty ~loc ~dir alias
  >>> Expander.eval_blang expander alias_conf.enabled_if
  >>= function
  | false -> Alias_rules.add_empty sctx ~loc ~alias
  | true ->
    (match alias_conf.action with
     | None ->
       (* Sandboxing options don't make sense for deps, only for actions *)
       let builder, _expander, _sandbox =
         Dep_conf_eval.named
           ~expander
           Sandbox_config.no_special_requirements
           alias_conf.deps
       in
       Rules.Produce.Alias.add_deps alias ~loc builder
     | Some (action_loc, action) ->
       let action =
         let chdir = Expander.dir expander in
         Action_unexpanded.expand_no_targets
           action
           Sandbox_config.no_special_requirements
           ~loc:action_loc
           ~expander
           ~chdir
           ~deps:alias_conf.deps
           ~what:"aliases"
       in
       interpret_and_add_locks ~expander alias_conf.locks action
       |> Alias_rules.add sctx ~loc ~alias)
;;
