unikernel/duniverse/dune_/bin/print_rules.ml

@@ -0,0 +1,306 @@
+open Import
+
+let doc = "Dump rules."
+
+let man =
+  [ `S "DESCRIPTION"
+  ; `P
+      {|Dump Dune rules for the given targets.
+           If no targets are given, dump all the rules.|}
+  ; `P
+      {|By default the output is a list of S-expressions,
+           one S-expression per rule. Each S-expression is of the form:|}
+  ; `Pre
+      "  ((deps    (<dependencies>))\n\
+      \   (targets (<targets>))\n\
+      \   (context <context-name>)\n\
+      \   (action  <action>))"
+  ; `P
+      {|$(b,<context-name>) is the context is which the action is executed.
+           It is omitted if the action is independent from the context.|}
+  ; `P
+      {|$(b,<action>) is the action following the same syntax as user actions,
+           as described in the manual.|}
+  ; `Blocks Common.help_secs
+  ]
+;;
+
+let info = Cmd.info "rules" ~doc ~man
+
+let print_rule_makefile ppf (rule : Dune_engine.Reflection.Rule.t) =
+  let action =
+    Action.For_shell.Progn
+      [ Mkdir (Path.to_string (Path.build rule.targets.root))
+      ; Action.for_shell rule.action
+      ]
+  in
+  (* Makefiles seem to allow directory targets, so we include them. *)
+  let targets =
+    Filename.Set.union rule.targets.files rule.targets.dirs
+    |> Filename.Set.to_list_map ~f:(fun basename ->
+      Path.Build.relative rule.targets.root basename |> Path.build)
+  in
+  Format.fprintf
+    ppf
+    "@[<hov 2>@{<makefile-stuff>%a:%t@}@]@,@<0>\t@{<makefile-action>%a@}\n"
+    (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf p ->
+       Format.pp_print_string ppf (Path.to_string p)))
+    targets
+    (fun ppf ->
+       Path.Set.iter rule.expanded_deps ~f:(fun dep ->
+         Format.fprintf ppf "@ %s" (Path.to_string dep)))
+    Pp.to_fmt
+    (Action_to_sh.pp action)
+;;
+
+let rec encode : Action.For_shell.t -> Dune_lang.t =
+  let module Outputs = Dune_lang.Action.Outputs in
+  let module File_perm = Dune_lang.Action.File_perm in
+  let module Inputs = Dune_lang.Action.Inputs in
+  let open Dune_lang in
+  let program = Encoder.string in
+  let string = Encoder.string in
+  let path = Encoder.string in
+  let target = Encoder.string in
+  function
+  | Run (a, xs) ->
+    List (atom "run" :: program a :: List.map (Array.Immutable.to_list xs) ~f:string)
+  | With_accepted_exit_codes (pred, t) ->
+    List
+      [ atom "with-accepted-exit-codes"
+      ; Predicate_lang.encode Dune_sexp.Encoder.int pred
+      ; encode t
+      ]
+  | Dynamic_run (a, xs) -> List (atom "run_dynamic" :: program a :: List.map xs ~f:string)
+  | Chdir (a, r) -> List [ atom "chdir"; path a; encode r ]
+  | Setenv (k, v, r) -> List [ atom "setenv"; string k; string v; encode r ]
+  | Redirect_out (outputs, fn, perm, r) ->
+    List
+      [ atom (sprintf "with-%s-to%s" (Outputs.to_string outputs) (File_perm.suffix perm))
+      ; target fn
+      ; encode r
+      ]
+  | Redirect_in (inputs, fn, r) ->
+    List [ atom (sprintf "with-%s-from" (Inputs.to_string inputs)); path fn; encode r ]
+  | Ignore (outputs, r) ->
+    List [ atom (sprintf "ignore-%s" (Outputs.to_string outputs)); encode r ]
+  | Progn l -> List (atom "progn" :: List.map l ~f:encode)
+  | Concurrent l -> List (atom "concurrent" :: List.map l ~f:encode)
+  | Echo xs -> List (atom "echo" :: List.map xs ~f:string)
+  | Cat xs -> List (atom "cat" :: List.map xs ~f:path)
+  | Copy (x, y) -> List [ atom "copy"; path x; target y ]
+  | Symlink (x, y) -> List [ atom "symlink"; path x; target y ]
+  | Hardlink (x, y) -> List [ atom "hardlink"; path x; target y ]
+  | Bash x -> List [ atom "bash"; string x ]
+  | Write_file (x, perm, y) ->
+    List [ atom ("write-file" ^ File_perm.suffix perm); target x; string y ]
+  | Rename (x, y) -> List [ atom "rename"; target x; target y ]
+  | Remove_tree x -> List [ atom "remove-tree"; target x ]
+  | Mkdir x -> List [ atom "mkdir"; target x ]
+  | Pipe (outputs, l) ->
+    List (atom (sprintf "pipe-%s" (Outputs.to_string outputs)) :: List.map l ~f:encode)
+  | Extension ext -> List [ atom "ext"; Dune_sexp.Quoted_string (Sexp.to_string ext) ]
+;;
+
+let encode_path p =
+  let make constr arg =
+    Dune_sexp.List [ Dune_sexp.atom constr; Dune_sexp.atom_or_quoted_string arg ]
+  in
+  let open Path in
+  match p with
+  | In_build_dir p -> make "In_build_dir" (Path.Build.to_string p)
+  | In_source_tree p -> make "In_source_tree" (Path.Source.to_string p)
+  | External p -> make "External" (Path.External.to_string p)
+;;
+
+let encode_file_selector file_selector =
+  let open Dune_sexp.Encoder in
+  let module File_selector = Dune_engine.File_selector in
+  let dir = File_selector.dir file_selector in
+  let predicate = File_selector.predicate file_selector in
+  let only_generated_files = File_selector.only_generated_files file_selector in
+  record
+    [ "dir", encode_path dir
+    ; "predicate", Predicate_lang.Glob.encode predicate
+    ; "only_generated_files", bool only_generated_files
+    ]
+;;
+
+let encode_alias alias =
+  let open Dune_sexp.Encoder in
+  let dir = Dune_engine.Alias.dir alias in
+  let name = Dune_engine.Alias.name alias in
+  record
+    [ "dir", encode_path (Path.build dir)
+    ; "name", Dune_sexp.atom_or_quoted_string (Dune_util.Alias_name.to_string name)
+    ]
+;;
+
+let encode_dep_set deps =
+  Dune_sexp.List
+    (Dep.Set.to_list_map
+       deps
+       ~f:
+         (let open Dune_sexp.Encoder in
+          function
+          | File_selector g -> pair string encode_file_selector ("glob", g)
+          | Env e -> pair string string ("Env", e)
+          | File f -> pair string encode_path ("File", f)
+          | Alias a -> pair string encode_alias ("Alias", a)
+          | Universe -> string "Universe"))
+;;
+
+let print_rule_sexp ppf (rule : Dune_engine.Reflection.Rule.t) =
+  let sexp_of_action action = Action.for_shell action |> encode in
+  let paths ps =
+    Dune_sexp.Encoder.list
+      (fun p ->
+         Path.Build.relative rule.targets.root p
+         |> Path.Build.to_string
+         |> Dune_sexp.atom_or_quoted_string)
+      (Filename.Set.to_list ps)
+  in
+  let sexp =
+    Dune_sexp.Encoder.record
+      (List.concat
+         [ [ "deps", encode_dep_set rule.deps
+           ; ( "targets"
+             , Dune_sexp.Encoder.record
+                 [ "files", paths rule.targets.files
+                 ; "directories", paths rule.targets.dirs
+                 ] )
+           ]
+         ; (match Path.Build.extract_build_context rule.targets.root with
+            | None -> []
+            | Some (c, _) -> [ "context", Dune_sexp.atom_or_quoted_string c ])
+         ; [ "action", sexp_of_action rule.action ]
+         ])
+  in
+  Format.fprintf ppf "%a@," Pp.to_fmt (Dune_lang.pp sexp)
+;;
+
+module Syntax = struct
+  type t =
+    | Makefile
+    | Sexp
+
+  let term =
+    let doc = "Output the rules in Makefile syntax." in
+    let+ makefile = Arg.(value & flag & info [ "m"; "makefile" ] ~doc) in
+    if makefile then Makefile else Sexp
+  ;;
+
+  let print_rule = function
+    | Makefile -> print_rule_makefile
+    | Sexp -> print_rule_sexp
+  ;;
+
+  type formatter_state =
+    | In_atom
+    | In_makefile_action
+    | In_makefile_stuff
+
+  let prepare_formatter ppf =
+    let state = ref [] in
+    Format.pp_set_mark_tags ppf true;
+    let ofuncs = Format.pp_get_formatter_out_functions ppf () in
+    let tfuncs = Format.pp_get_formatter_stag_functions ppf () in
+    Format.pp_set_formatter_stag_functions
+      ppf
+      { tfuncs with
+        mark_open_stag =
+          (function
+            | Format.String_tag "atom" ->
+              state := In_atom :: !state;
+              ""
+            | Format.String_tag "makefile-action" ->
+              state := In_makefile_action :: !state;
+              ""
+            | Format.String_tag "makefile-stuff" ->
+              state := In_makefile_stuff :: !state;
+              ""
+            | s -> tfuncs.mark_open_stag s)
+      ; mark_close_stag =
+          (function
+            | Format.String_tag "atom"
+            | Format.String_tag "makefile-action"
+            | Format.String_tag "makefile-stuff" ->
+              state := List.tl !state;
+              ""
+            | s -> tfuncs.mark_close_stag s)
+      };
+    Format.pp_set_formatter_out_functions
+      ppf
+      { ofuncs with
+        out_newline =
+          (fun () ->
+            match !state with
+            | [ In_atom; In_makefile_action ] -> ofuncs.out_string "\\\n\t" 0 3
+            | [ In_atom ] -> ofuncs.out_string "\\\n" 0 2
+            | [ In_makefile_action ] -> ofuncs.out_string " \\\n\t" 0 4
+            | [ In_makefile_stuff ] -> ofuncs.out_string " \\\n" 0 3
+            | [] -> ofuncs.out_string "\n" 0 1
+            | _ -> assert false)
+      ; out_spaces =
+          (fun n ->
+            ofuncs.out_spaces
+              (match !state with
+               | In_atom :: _ -> max 0 (n - 2)
+               | _ -> n))
+      }
+  ;;
+
+  let print_rules syntax ppf rules =
+    prepare_formatter ppf;
+    Format.pp_open_vbox ppf 0;
+    Format.pp_print_list (print_rule syntax) ppf rules;
+    Format.pp_print_flush ppf ()
+  ;;
+end
+
+let term =
+  let+ builder = Common.Builder.term
+  and+ out =
+    Arg.(
+      value
+      & opt (some string) None
+      & info [ "o" ] ~docv:"FILE" ~doc:"Output to a file instead of stdout.")
+  and+ recursive =
+    Arg.(
+      value
+      & flag
+      & info
+          [ "r"; "recursive" ]
+          ~doc:
+            "Print all rules needed to build the transitive dependencies of the given \
+             targets.")
+  and+ syntax = Syntax.term
+  and+ targets = Arg.(value & pos_all dep [] & Arg.info [] ~docv:"TARGET") in
+  let common, config = Common.init builder in
+  let out = Option.map ~f:Path.of_string out in
+  Scheduler.go_with_rpc_server ~common ~config (fun () ->
+    let open Fiber.O in
+    let* setup = Import.Main.setup () in
+    build_exn (fun () ->
+      let open Memo.O in
+      let* setup = setup in
+      let* request =
+        match targets with
+        | [] ->
+          Target.all_direct_targets None
+          >>| Path.Build.Map.foldi ~init:[] ~f:(fun p _ acc -> Path.build p :: acc)
+          >>| Action_builder.paths
+        | _ ->
+          Memo.return (Target.interpret_targets (Common.root common) config setup targets)
+      in
+      let+ rules = Dune_engine.Reflection.eval ~request ~recursive in
+      let print oc =
+        let ppf = Format.formatter_of_out_channel oc in
+        Syntax.print_rules syntax ppf rules
+      in
+      match out with
+      | None -> print stdout
+      | Some fn -> Io.with_file_out fn ~f:print))
+;;
+
+let command = Cmd.v info term