Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

refactor(pkg): move [Run_with_path] to separate module #11306

Merged
merged 1 commit into from
Jan 16, 2025
Merged

refactor(pkg): move [Run_with_path] to separate module #11306

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
184 changes: 1 addition & 183 deletions src/dune_rules/pkg_rules.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -588,188 +588,6 @@ module Substitute = struct
;;
end

let depexts_hint = function
| [] -> None
| depexts ->
[ Pp.textf "You may want to verify the following depexts are installed:"
; Pp.enumerate ~f:Pp.verbatim depexts
]
|> Pp.concat_map ~sep:Pp.cut ~f:(fun pp -> Pp.box pp)
|> Option.some
;;

module Run_with_path = struct
module Output : sig
type error

val io : error -> Process.Io.output Process.Io.t

val with_error
: accepted_exit_codes:int Predicate.t
-> pkg:Dune_pkg.Package_name.t * Loc.t
-> depexts:string list
-> display:Display.t
-> (error -> 'a)
-> 'a

val prerr : rc:int -> error -> unit
end = struct
type error =
{ pkg : Dune_pkg.Package_name.t * Loc.t
; depexts : string list
; filename : Dpath.t
; io : Process.Io.output Process.Io.t
; accepted_exit_codes : int Predicate.t
; display : Display.t
}

let io t = t.io

let with_error ~accepted_exit_codes ~pkg ~depexts ~display f =
let filename = Temp.create File ~prefix:"dune-pkg" ~suffix:"stderr" in
let io = Process.Io.(file filename Out) in
let t = { filename; io; accepted_exit_codes; display; pkg; depexts } in
let result = f t in
Temp.destroy File filename;
result
;;

let to_paragraphs t error =
let pp_pkg = Pp.textf "Logs for package %s" (Package.Name.to_string (fst t.pkg)) in
[ pp_pkg; Pp.verbatim error ]
;;

let prerr ~rc error =
let hints =
lazy
(match depexts_hint error.depexts with
| None -> []
| Some h -> [ h ])
in
let loc = snd error.pkg in
match Predicate.test error.accepted_exit_codes rc, error.display with
| false, _ ->
let paragraphs = Stdune.Io.read_file error.filename |> to_paragraphs error in
User_warning.emit ~hints:(Lazy.force hints) ~loc ~is_error:true paragraphs
| true, Display.Verbose ->
let content = Stdune.Io.read_file error.filename in
if not (String.is_empty content)
then (
let paragraphs = to_paragraphs error content in
User_warning.emit ~hints:(Lazy.force hints) ~loc paragraphs)
| true, _ -> ()
;;
end

module Spec = struct
type 'path chunk =
| String of string
| Path of 'path

type 'path arg = 'path chunk Array.Immutable.t

type ('path, 'target) t =
{ prog : Action.Prog.t
; args : 'path arg Array.Immutable.t
; ocamlfind_destdir : 'path
; pkg : Dune_pkg.Package_name.t * Loc.t
; depexts : string list
}

let name = "run-with-path"
let version = 2

let map_arg arg ~f =
Array.Immutable.map arg ~f:(function
| String _ as s -> s
| Path p -> Path (f p))
;;

let bimap t f _g =
{ t with
args = Array.Immutable.map t.args ~f:(map_arg ~f)
; ocamlfind_destdir = f t.ocamlfind_destdir
}
;;

let is_useful_to ~memoize:_ = true

let encode { prog; args; ocamlfind_destdir; pkg = _; depexts = _ } path _ : Sexp.t =
let prog : Sexp.t =
Atom
(match prog with
| Ok p -> Path.reach p ~from:Path.root
| Error e -> e.program)
in
let args =
Array.Immutable.to_list_map args ~f:(fun x ->
Sexp.List
(Array.Immutable.to_list_map x ~f:(function
| String s -> Sexp.Atom s
| Path p -> path p)))
in
List [ List ([ prog ] @ args); path ocamlfind_destdir ]
;;

let action
{ prog; args; ocamlfind_destdir; pkg; depexts }
~(ectx : Action.context)
~(eenv : Action.env)
=
let open Fiber.O in
let display = !Clflags.display in
match prog with
| Error e -> Action.Prog.Not_found.raise e
| Ok prog ->
let args =
Array.Immutable.to_list_map args ~f:(fun arg ->
Array.Immutable.to_list_map arg ~f:(function
| String s -> s
| Path p -> Path.to_absolute_filename p)
|> String.concat ~sep:"")
in
let metadata = Process.create_metadata ~purpose:ectx.metadata.purpose () in
let env =
Env.add
eenv.env
~var:"OCAMLFIND_DESTDIR"
~value:(Path.to_absolute_filename ocamlfind_destdir)
in
Output.with_error
~accepted_exit_codes:eenv.exit_codes
~pkg
~depexts
~display
(fun error ->
let stdout_to =
match !Clflags.debug_package_logs, display with
| true, _ | false, Display.Verbose -> eenv.stdout_to
| _ -> Process.Io.(null Out)
in
Process.run
Return
prog
args
~display
~metadata
~stdout_to
~stderr_to:(Output.io error)
~stdin_from:eenv.stdin_from
~dir:eenv.working_dir
~env
>>= fun (_, rc) ->
Output.prerr ~rc error;
Fiber.return ())
;;
end

module A = Action_ext.Make (Spec)

let action ~pkg ~depexts prog args ~ocamlfind_destdir =
A.action { Spec.prog; args; ocamlfind_destdir; pkg; depexts }
;;
end

module Action_expander = struct
module Expander = struct
include Expander0
Expand Down Expand Up @@ -963,7 +781,7 @@ module Action_expander = struct
| Some p -> Ok p
| None ->
let hint =
depexts_hint t.depexts
Run_with_path.depexts_hint t.depexts
|> Option.map ~f:(fun pp -> Format.asprintf "%a" Pp.to_fmt pp)
in
Error
Expand Down
182 changes: 182 additions & 0 deletions src/dune_rules/run_with_path.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,182 @@
open Import
module Display = Dune_engine.Display

let depexts_hint = function
| [] -> None
| depexts ->
[ Pp.textf "You may want to verify the following depexts are installed:"
; Pp.enumerate ~f:Pp.verbatim depexts
]
|> Pp.concat_map ~sep:Pp.cut ~f:(fun pp -> Pp.box pp)
|> Option.some
;;

module Output : sig
type error

val io : error -> Process.Io.output Process.Io.t

val with_error
: accepted_exit_codes:int Predicate.t
-> pkg:Dune_pkg.Package_name.t * Loc.t
-> depexts:string list
-> display:Display.t
-> (error -> 'a)
-> 'a

val prerr : rc:int -> error -> unit
end = struct
type error =
{ pkg : Dune_pkg.Package_name.t * Loc.t
; depexts : string list
; filename : Dpath.t
; io : Process.Io.output Process.Io.t
; accepted_exit_codes : int Predicate.t
; display : Display.t
}

let io t = t.io

let with_error ~accepted_exit_codes ~pkg ~depexts ~display f =
let filename = Temp.create File ~prefix:"dune-pkg" ~suffix:"stderr" in
let io = Process.Io.(file filename Out) in
let t = { filename; io; accepted_exit_codes; display; pkg; depexts } in
let result = f t in
Temp.destroy File filename;
result
;;

let to_paragraphs t error =
let pp_pkg = Pp.textf "Logs for package %s" (Package.Name.to_string (fst t.pkg)) in
[ pp_pkg; Pp.verbatim error ]
;;

let prerr ~rc error =
let hints =
lazy
(match depexts_hint error.depexts with
| None -> []
| Some h -> [ h ])
in
let loc = snd error.pkg in
match Predicate.test error.accepted_exit_codes rc, error.display with
| false, _ ->
let paragraphs = Stdune.Io.read_file error.filename |> to_paragraphs error in
User_warning.emit ~hints:(Lazy.force hints) ~loc ~is_error:true paragraphs
| true, Display.Verbose ->
let content = Stdune.Io.read_file error.filename in
if not (String.is_empty content)
then (
let paragraphs = to_paragraphs error content in
User_warning.emit ~hints:(Lazy.force hints) ~loc paragraphs)
| true, _ -> ()
;;
end

module Spec = struct
type 'path chunk =
| String of string
| Path of 'path

type 'path arg = 'path chunk Array.Immutable.t

type ('path, 'target) t =
{ prog : Action.Prog.t
; args : 'path arg Array.Immutable.t
; ocamlfind_destdir : 'path
; pkg : Dune_pkg.Package_name.t * Loc.t
; depexts : string list
}

let name = "run-with-path"
let version = 2

let map_arg arg ~f =
Array.Immutable.map arg ~f:(function
| String _ as s -> s
| Path p -> Path (f p))
;;

let bimap t f _g =
{ t with
args = Array.Immutable.map t.args ~f:(map_arg ~f)
; ocamlfind_destdir = f t.ocamlfind_destdir
}
;;

let is_useful_to ~memoize:_ = true

let encode { prog; args; ocamlfind_destdir; pkg = _; depexts = _ } path _ : Sexp.t =
let prog : Sexp.t =
Atom
(match prog with
| Ok p -> Path.reach p ~from:Path.root
| Error e -> e.program)
in
let args =
Array.Immutable.to_list_map args ~f:(fun x ->
Sexp.List
(Array.Immutable.to_list_map x ~f:(function
| String s -> Sexp.Atom s
| Path p -> path p)))
in
List [ List ([ prog ] @ args); path ocamlfind_destdir ]
;;

let action
{ prog; args; ocamlfind_destdir; pkg; depexts }
~(ectx : Action.context)
~(eenv : Action.env)
=
let open Fiber.O in
let display = !Clflags.display in
match prog with
| Error e -> Action.Prog.Not_found.raise e
| Ok prog ->
let args =
Array.Immutable.to_list_map args ~f:(fun arg ->
Array.Immutable.to_list_map arg ~f:(function
| String s -> s
| Path p -> Path.to_absolute_filename p)
|> String.concat ~sep:"")
in
let metadata = Process.create_metadata ~purpose:ectx.metadata.purpose () in
let env =
Env.add
eenv.env
~var:"OCAMLFIND_DESTDIR"
~value:(Path.to_absolute_filename ocamlfind_destdir)
in
Output.with_error
~accepted_exit_codes:eenv.exit_codes
~pkg
~depexts
~display
(fun error ->
let stdout_to =
match !Clflags.debug_package_logs, display with
| true, _ | false, Display.Verbose -> eenv.stdout_to
| _ -> Process.Io.(null Out)
in
Process.run
Return
prog
args
~display
~metadata
~stdout_to
~stderr_to:(Output.io error)
~stdin_from:eenv.stdin_from
~dir:eenv.working_dir
~env
>>= fun (_, rc) ->
Output.prerr ~rc error;
Fiber.return ())
;;
end

module A = Action_ext.Make (Spec)

let action ~pkg ~depexts prog args ~ocamlfind_destdir =
A.action { Spec.prog; args; ocamlfind_destdir; pkg; depexts }
;;
Loading
Loading