Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Use a nominal datatype for CamlinternalFormat.format6

This should make the type-checking of formats simpler and more robust:
instead of trying to find a pair as previously, we can now use the
path of the format6 type directly.

A nice side-effect of the change is that the internal definition of
formats (as a pair) is not printed in error messages anymore.
Because format6 is in fact defined in the CamlinternalFormatBasics
submodule of Pervasives, and has an alias at the toplevel of
Pervasives, error messages still expand the definition:

> Error: This expression has type
>          ('a, 'b, 'c, 'd, 'd, 'a) format6 =
>            ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6
>        but an expression was expected of type ...

Passing the option `-short-paths` does avoid this expansion and
returns exactly the same error message as 4.01:

> Error: This expression has type ('a, 'b, 'c, 'd, 'd, 'a) format6
>        but an expression was expected of type ...

(To get this error message without -short-paths, one would need to
define format6 directly in Pervasives; but this type is mutually
recursive with several GADT types that we don't want to add in the
Pervasives namespace unqualified. This is why I'll keep the alias
for now.)

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14868 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
commit 3ffa399b3714c7ce084d05415a0faa0a6c976aa3 1 parent fb8aecb
Gabriel Scherer authored
View
BIN  boot/ocamlc
Binary file not shown
View
BIN  boot/ocamldep
Binary file not shown
View
BIN  boot/ocamllex
Binary file not shown
View
16 otherlibs/threads/pervasives.ml
@@ -843,7 +843,8 @@ and ('a, 'b, 'c, 'd, 'e, 'f) ignored =
| Ignored_scan_get_counter : (* %_[nlNL] *)
counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
-and ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
+and ('a, 'b, 'c, 'd, 'e, 'f) format6 =
+ Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
(******************************************************************************)
(* Format type concatenation *)
@@ -952,21 +953,24 @@ fun fmt1 fmt2 -> match fmt1 with
fmt2
end
-type ('a, 'b, 'c, 'd, 'e, 'f) format6 =
- ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+type ('a, 'b, 'c, 'd, 'e, 'f) format6
+ = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+ = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt
+ * string
type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
-let string_of_format (fmt, str) = str
+let string_of_format (Format (fmt, str)) = str
external format_of_string :
('a, 'b, 'c, 'd, 'e, 'f) format6 ->
('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
-let (^^) (fmt1, str1) (fmt2, str2) =
- (CamlinternalFormatBasics.concat_fmt fmt1 fmt2, str1 ^ "%," ^ str2)
+let (^^) (Format (fmt1, str1)) (Format (fmt2, str2)) =
+ Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2,
+ str1 ^ "%," ^ str2)
(* Miscellaneous *)
View
13 stdlib/camlinternalFormat.ml
@@ -1116,7 +1116,7 @@ fun k o acc fmt -> match fmt with
make_printf k o (Acc_string (acc, ty)) rest)
| Format_subst (_, _, fmtty, rest) ->
(* Call to type_format can't fail (raise Type_mismatch). *)
- fun (fmt, _) -> make_printf k o acc
+ fun (Format (fmt, _)) -> make_printf k o acc
(concat_fmt (type_format fmt fmtty) rest)
| Scan_char_set (_, _, rest) ->
@@ -1356,8 +1356,7 @@ let rec strput_acc b acc = match acc with
(* Error managment *)
(* Raise a Failure with a pretty-printed error message. *)
-let failwith_message
- ((fmt, _) : ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6) =
+let failwith_message (Format (fmt, _)) =
let buf = Buffer.create 256 in
let k () acc = strput_acc buf acc; failwith (Buffer.contents buf) in
make_printf k () End_of_acc fmt
@@ -2265,15 +2264,17 @@ let fmt_ebb_of_string str =
(* Raise a Failure with an error message in case of type mismatch. *)
let format_of_string_fmtty str fmtty =
let Fmt_EBB fmt = fmt_ebb_of_string str in
- try (type_format fmt fmtty, str) with Type_mismatch ->
+ try Format (type_format fmt fmtty, str)
+ with Type_mismatch ->
failwith_message
"bad input: format type mismatch between %S and %S"
str (string_of_fmtty fmtty)
(* Convert a string to a format compatible with an other format. *)
(* Raise a Failure with an error message in case of type mismatch. *)
-let format_of_string_format str (fmt', str') =
+let format_of_string_format str (Format (fmt', str')) =
let Fmt_EBB fmt = fmt_ebb_of_string str in
- try (type_format fmt (fmtty_of_fmt fmt'), str) with Type_mismatch ->
+ try Format (type_format fmt (fmtty_of_fmt fmt'), str)
+ with Type_mismatch ->
failwith_message
"bad input: format type mismatch between %S and %S" str str'
View
10 stdlib/format.ml
@@ -1130,9 +1130,9 @@ let rec strput_acc ppf acc = match acc with
**************************************************************)
-let kfprintf k o (fmt, _) =
+let kfprintf k o (Format (fmt, _)) =
make_printf (fun o acc -> output_acc o acc; k o) o End_of_acc fmt
-let ikfprintf k x (fmt, _) =
+let ikfprintf k x (Format (fmt, _)) =
make_printf (fun _ _ -> k x) x End_of_acc fmt
let fprintf ppf fmt = kfprintf ignore ppf fmt
@@ -1140,7 +1140,7 @@ let ifprintf ppf fmt = ikfprintf ignore ppf fmt
let printf fmt = fprintf std_formatter fmt
let eprintf fmt = fprintf err_formatter fmt
-let ksprintf k (fmt, _) =
+let ksprintf k (Format (fmt, _)) =
let k' () acc =
let b = Buffer.create 512 in
let ppf = formatter_of_buffer b in
@@ -1152,7 +1152,7 @@ let ksprintf k (fmt, _) =
let sprintf fmt =
ksprintf (fun s -> s) fmt
-let asprintf (fmt, _) =
+let asprintf (Format (fmt, _)) =
let b = Buffer.create 512 in
let ppf = formatter_of_buffer b in
let k' : (formatter -> (formatter, unit) acc -> string)
@@ -1169,7 +1169,7 @@ let asprintf (fmt, _) =
**************************************************************)
(* Deprecated error prone function bprintf. *)
-let bprintf b ((fmt, _) : ('a, formatter, unit) format) =
+let bprintf b (Format (fmt, _) : ('a, formatter, unit) format) =
let k ppf acc = output_acc ppf acc; pp_flush_queue ppf false in
make_printf k (formatter_of_buffer b) End_of_acc fmt
View
19 stdlib/pervasives.ml
@@ -81,7 +81,7 @@ external succ : int -> int = "%succint"
external pred : int -> int = "%predint"
external ( + ) : int -> int -> int = "%addint"
external ( - ) : int -> int -> int = "%subint"
-external ( * ) : int -> int -> int = "%mulint"
+external ( * ) : int -> int -> int = "%mulint"
external ( / ) : int -> int -> int = "%divint"
external ( mod ) : int -> int -> int = "%modint"
@@ -588,6 +588,7 @@ type ('a, 'b, 'c, 'd, 'e, 'f) fmtty =
| Bool_ty : (* %B *)
('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
(bool -> 'a, 'b, 'c, 'd, 'e, 'f) fmtty
+
| Format_arg_ty : (* %{...%} *)
('g, 'h, 'i, 'j, 'k, 'l) fmtty *
('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
@@ -744,7 +745,8 @@ and ('a, 'b, 'c, 'd, 'e, 'f) ignored =
| Ignored_scan_get_counter : (* %_[nlNL] *)
counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
-and ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
+and ('a, 'b, 'c, 'd, 'e, 'f) format6 =
+ Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
(******************************************************************************)
(* Format type concatenation *)
@@ -853,21 +855,24 @@ fun fmt1 fmt2 -> match fmt1 with
fmt2
end
-type ('a, 'b, 'c, 'd, 'e, 'f) format6 =
- ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+type ('a, 'b, 'c, 'd, 'e, 'f) format6
+ = ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.format6
+ = Format of ('a, 'b, 'c, 'd, 'e, 'f) CamlinternalFormatBasics.fmt
+ * string
type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6
type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4
-let string_of_format (fmt, str) = str
+let string_of_format (Format (fmt, str)) = str
external format_of_string :
('a, 'b, 'c, 'd, 'e, 'f) format6 ->
('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity"
-let (^^) (fmt1, str1) (fmt2, str2) =
- (CamlinternalFormatBasics.concat_fmt fmt1 fmt2, str1 ^ "%," ^ str2)
+let (^^) (Format (fmt1, str1)) (Format (fmt2, str2)) =
+ Format (CamlinternalFormatBasics.concat_fmt fmt1 fmt2,
+ str1 ^ "%," ^ str2)
(* Miscellaneous *)
View
3  stdlib/pervasives.mli
@@ -1181,7 +1181,8 @@ module CamlinternalFormatBasics : sig
| Ignored_scan_get_counter :
counter -> ('a, 'b, 'c, 'd, 'd, 'a) ignored
- and ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
+ and ('a, 'b, 'c, 'd, 'e, 'f) format6 =
+ Format of ('a, 'b, 'c, 'd, 'e, 'f) fmt * string
val concat_fmtty :
('a, 'b, 'c, 'd, 'e, 'f) fmtty ->
View
9 stdlib/printf.ml
@@ -11,13 +11,14 @@
(* *)
(***********************************************************************)
+open CamlinternalFormatBasics
open CamlinternalFormat
-let kfprintf k o (fmt, _) =
+let kfprintf k o (Format (fmt, _)) =
make_printf (fun o acc -> output_acc o acc; k o) o End_of_acc fmt
-let kbprintf k b (fmt, _) =
+let kbprintf k b (Format (fmt, _)) =
make_printf (fun b acc -> bufput_acc b acc; k b) b End_of_acc fmt
-let ikfprintf k oc (fmt, _) =
+let ikfprintf k oc (Format (fmt, _)) =
make_printf (fun oc _ -> k oc) oc End_of_acc fmt
let fprintf oc fmt = kfprintf ignore oc fmt
@@ -26,7 +27,7 @@ let ifprintf oc fmt = ikfprintf ignore oc fmt
let printf fmt = fprintf stdout fmt
let eprintf fmt = fprintf stderr fmt
-let ksprintf k (fmt, _) =
+let ksprintf k (Format (fmt, _)) =
let k' () acc =
let buf = Buffer.create 64 in
strput_acc buf acc;
View
5 stdlib/scanf.ml
@@ -1261,7 +1261,8 @@ fun ib fmt readers -> match fmt with
type_format fmt fmtty, type_format fmt fmtty'
with Failure msg -> bad_input msg
in
- Cons ((fmt', s), make_scanf ib (concat_fmt fmt rest) readers)
+ Cons (Format (fmt', s),
+ make_scanf ib (concat_fmt fmt rest) readers)
| Scan_char_set (width_opt, char_set, Formatting (fmting, rest)) ->
let stp, str = stopper_of_formatting fmting in
@@ -1333,7 +1334,7 @@ fun ib fmt readers pad prec scan token -> match pad, prec with
type 'a kscanf_result = Args of 'a | Exc of exn
-let kscanf ib ef (fmt, str) =
+let kscanf ib ef (Format (fmt, str)) =
let rec apply : type a b . a -> (a, b) heter_list -> b =
fun f args -> match args with
| Cons (x, r) -> apply (f x) r
View
2  testsuite/tests/typing-warnings/coercions.ml.principal.reference
@@ -5,7 +5,7 @@
^^^^^^^^^^^^^^^^^^^^
Error: This expression has type
('a, 'b, 'c, 'd, 'd, 'a) format6 =
- ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.fmt * string
+ ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6
but an expression was expected of type string
# - : bool -> ('a, 'b, 'a) format = <fun>
#
View
2  testsuite/tests/typing-warnings/coercions.ml.reference
@@ -5,7 +5,7 @@
^^^^^^^^^^^^^^^^^^^^
Error: This expression has type
('a, 'b, 'c, 'd, 'd, 'a) format6 =
- ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.fmt * string
+ ('a, 'b, 'c, 'd, 'd, 'a) CamlinternalFormatBasics.format6
but an expression was expected of type string
# - : bool -> ('a, 'b, 'a) format = <fun>
#
View
20 typing/typecore.ml
@@ -1778,21 +1778,15 @@ and type_expect_ ?in_function env sexp ty_expected =
end
| Pexp_constant(Const_string (str, _) as cst) -> (
(* Terrible hack for format strings *)
- let expected_ty = (repr (expand_head env ty_expected)).desc
- and fmt6_path = get_camlinternalFormat_path env "format6"
- and fmt_path = get_camlinternalFormat_path env "fmt" in
- let is_format = match expected_ty, fmt6_path, fmt_path with
- | Tconstr(path, _, _), Some pf6, _ when Path.same path pf6 -> true
- | Ttuple [ fmt_ty; str_ty ], _, Some pf ->
- ignore (unify env str_ty Predef.type_string);
- begin match (repr (expand_head env fmt_ty)).desc with
- | Tconstr (path, _, _) when Path.same path pf -> true
- | _ -> false
- end
+ let ty_expected_desc = (repr (expand_head env ty_expected)).desc in
+ let fmt6_path = get_camlinternalFormat_path env "format6" in
+ let is_format = match ty_expected_desc, fmt6_path with
+ | Tconstr(path, _, _), Some pf6 when Path.same path pf6 -> true
| _ -> false
in
if is_format then
- let format_parsetree = { sexp with pexp_desc = type_format loc str env } in
+ let format_parsetree =
+ { sexp with pexp_desc = type_format loc str env } in
type_expect ?in_function env format_parsetree ty_expected
else
rue {
@@ -2979,7 +2973,7 @@ and type_format loc str env =
| End_of_format ->
mk_constr "End_of_format" [] in
let mk_format fmt str =
- mk_exp_loc (Pexp_tuple [ mk_fmt fmt; mk_string str ]) in
+ mk_constr "Format" [ mk_fmt fmt; mk_string str ] in
let Fmt_EBB fmt = fmt_ebb_of_string str in
let exp = { (mk_format fmt str) with pexp_loc = loc } in
let pervasives_format6_ty =
Please sign in to comment.
Something went wrong with that request. Please try again.