diff --git a/src/import.ml b/src/import.ml index 9e7e2718..2972d36d 100644 --- a/src/import.ml +++ b/src/import.ml @@ -96,62 +96,6 @@ module No_io = struct module Io = struct end end -module Fmt = struct - (* CR-someday diml: we should define a GADT for this: - - {[ - type 'a t = - | Int : int t - | Box : ... - | Colored : ... - ]} - - This way we could separate the creation of messages from the - actual rendering. - *) - type 'a t = Format.formatter -> 'a -> unit - - let kstrf f fmt = - let buf = Buffer.create 17 in - let f fmt = Format.pp_print_flush fmt () ; f (Buffer.contents buf) in - Format.kfprintf f (Format.formatter_of_buffer buf) fmt - - let failwith fmt = kstrf failwith fmt - - let list = Format.pp_print_list - let string s ppf = Format.pp_print_string ppf s - - let nl = Format.pp_print_newline - - let prefix f g ppf x = f ppf; g ppf x - - let ocaml_list pp fmt = function - | [] -> Format.pp_print_string fmt "[]" - | l -> - Format.fprintf fmt "@[[ %a@ ]@]" - (list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,; ") - pp) l - - let quoted fmt = Format.fprintf fmt "%S" - - let const - : 'a t -> 'a -> unit t - = fun pp a' fmt () -> pp fmt a' - - let record fmt = function - | [] -> Format.pp_print_string fmt "{}" - | xs -> - let pp fmt (field, pp) = - Format.fprintf fmt "@[%s@ =@ %a@]" - field pp () in - let pp_sep fmt () = Format.fprintf fmt "@,; " in - Format.fprintf fmt "@[{ %a@ }@]" - (Format.pp_print_list ~pp_sep pp) xs - - let tuple ppfa ppfb fmt (a, b) = - Format.fprintf fmt "@[(%a, %a)@]" ppfa a ppfb b -end - (* This is ugly *) let printer = ref (Printf.eprintf "%s%!") let print_to_console s = !printer s diff --git a/src/stdune/fmt.ml b/src/stdune/fmt.ml new file mode 100644 index 00000000..a0d26090 --- /dev/null +++ b/src/stdune/fmt.ml @@ -0,0 +1,54 @@ + +(* CR-someday diml: we should define a GADT for this: + + {[ + type 'a t = + | Int : int t + | Box : ... + | Colored : ... + ]} + + This way we could separate the creation of messages from the + actual rendering. +*) +type 'a t = Format.formatter -> 'a -> unit + +let kstrf f fmt = + let buf = Buffer.create 17 in + let f fmt = Format.pp_print_flush fmt () ; f (Buffer.contents buf) in + Format.kfprintf f (Format.formatter_of_buffer buf) fmt + +let failwith fmt = kstrf failwith fmt + +let list = Format.pp_print_list +let string s ppf = Format.pp_print_string ppf s + +let nl = Format.pp_print_newline + +let prefix f g ppf x = f ppf; g ppf x + +let ocaml_list pp fmt = function + | [] -> Format.pp_print_string fmt "[]" + | l -> + Format.fprintf fmt "@[[ %a@ ]@]" + (list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,; ") + pp) l + +let quoted fmt = Format.fprintf fmt "%S" + +let const + : 'a t -> 'a -> unit t + = fun pp a' fmt () -> pp fmt a' + +let record fmt = function + | [] -> Format.pp_print_string fmt "{}" + | xs -> + let pp fmt (field, pp) = + Format.fprintf fmt "@[%s@ =@ %a@]" + field pp () in + let pp_sep fmt () = Format.fprintf fmt "@,; " in + Format.fprintf fmt "@[{ %a@ }@]" + (Format.pp_print_list ~pp_sep pp) xs + +let tuple ppfa ppfb fmt (a, b) = + Format.fprintf fmt "@[(%a, %a)@]" ppfa a ppfb b diff --git a/src/stdune/fmt.mli b/src/stdune/fmt.mli new file mode 100644 index 00000000..8681035e --- /dev/null +++ b/src/stdune/fmt.mli @@ -0,0 +1,24 @@ +type 'a t = Format.formatter -> 'a -> unit + +val list : ?pp_sep:unit t -> 'a t -> 'a list t + +val failwith : ('a, Format.formatter, unit, 'b) format4 -> 'a + +val string : string -> Format.formatter -> unit + +val prefix + : (Format.formatter -> unit) + -> (Format.formatter -> 'b -> 'c) + -> (Format.formatter -> 'b -> 'c) + +val ocaml_list : 'a t -> 'a list t + +val quoted : string t + +val const : 'a t -> 'a -> unit t + +val record : (string * unit t) list t + +val tuple : 'a t -> 'b t -> ('a * 'b) t + +val nl : unit t diff --git a/src/stdune/stdune.ml b/src/stdune/stdune.ml index 4fc041f2..ef48991e 100644 --- a/src/stdune/stdune.ml +++ b/src/stdune/stdune.ml @@ -20,6 +20,7 @@ module String = String module Char = Char module Sexp = Sexp module Path = Path +module Fmt = Fmt external reraise : exn -> _ = "%reraise"