[MLton] cvs commit: -type-error {concise|full}
sweeks@mlton.org
sweeks@mlton.org
Thu, 18 Dec 2003 21:03:13 -0800
sweeks 03/12/18 21:03:12
Modified: mlton/control control.sig control.sml
mlton/elaborate type-env.fun
mlton/main main.fun
Log:
MAIL -type-error {concise|full}
Added a switch that controls the display of type error messages. With
-type-error concise, only the components that don't unify are shown.
With -type-error full, all of the type is shown. In both cases, to
make it easier to visually spot the differences, brackets are placed
around the parts that aren't unifiable.
Consider this program
fun f {w: int, x: int, y: real} = 13
val _ = f {w = 13, x = 13.0, z = 14}
fun f (x: int, y: real) = 13
val _ = f (1, 2, 3)
fun f (x: int, y: real) = 13
val _ = f (1, 2)
With -type-error concise, the error messages are:
Error: z.sml 2.9: function applied to incorrect argument
expects: {x: [int], [y]: _, ...}
but got: {x: [real], [z]: _, ...}
in: f {w = 13, x = 13.0, z = 14}
Error: z.sml 4.9: function applied to incorrect argument
expects: [int * real]
but got: [int * int * int]
in: f (1, 2, 3)
Error: z.sml 6.9: function applied to incorrect argument
expects: _ * [real]
but got: _ * [int]
in: f (1, 2)
With -type-error full, the error messages are:
Error: z.sml 2.9: function applied to incorrect argument
expects: {w: int, x: [int], [y]: real}
but got: {w: int, x: [real], [z]: int}
in: f {w = 13, x = 13.0, z = 14}
Error: z.sml 4.9: function applied to incorrect argument
expects: [int * real]
but got: [int * int * int]
in: f (1, 2, 3)
Error: z.sml 6.9: function applied to incorrect argument
expects: int * [real]
but got: int * [int]
in: f (1, 2)
For now, -type-error concise is the default. Unlike some of our
earlier ideas based on print-graph from Scheme, I chose to bracket the
parts of the types that are different, instead of those that are the
same. I think that makes more sense since we care more about the
differences when there is a unification error. I decided to use
brackets because {} and () are already taken and I want something that
matches.
I'd like people to try these out and send
* bug reports
* thoughts on which should be the default. Do we even need both?
* thoughts on other improvements
Once we sort this out (soon), I'd like to make an experimental release
and announce it on MLton-user to start getting more feedback on the
front end (and all the other improvements).
Revision Changes Path
1.84 +3 -0 mlton/mlton/control/control.sig
Index: control.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sig,v
retrieving revision 1.83
retrieving revision 1.84
diff -u -r1.83 -r1.84
--- control.sig 22 Nov 2003 23:21:49 -0000 1.83
+++ control.sig 19 Dec 2003 05:03:10 -0000 1.84
@@ -237,6 +237,9 @@
(* Type check ILs. *)
val typeCheck: bool ref
+
+ datatype typeError = Concise | Full
+ val typeError: typeError ref
(* Should the basis library be prefixed onto the program. *)
val useBasisLibrary: bool ref
1.103 +15 -0 mlton/mlton/control/control.sml
Index: control.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/control/control.sml,v
retrieving revision 1.102
retrieving revision 1.103
diff -u -r1.102 -r1.103
--- control.sml 22 Nov 2003 23:21:50 -0000 1.102
+++ control.sml 19 Dec 2003 05:03:10 -0000 1.103
@@ -450,6 +450,21 @@
val typeCheck = control {name = "type check",
default = false,
toString = Bool.toString}
+
+structure TypeError =
+ struct
+ datatype t = Concise | Full
+
+ val toString =
+ fn Concise => "concise"
+ | Full => "full"
+ end
+
+datatype typeError = datatype TypeError.t
+
+val typeError = control {name = "type error",
+ default = Concise,
+ toString = TypeError.toString}
val useBasisLibrary = control {name = "use basis library",
default = true,
1.13 +143 -95 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -r1.12 -r1.13
--- type-env.fun 19 Dec 2003 03:29:52 -0000 1.12
+++ type-env.fun 19 Dec 2003 05:03:11 -0000 1.13
@@ -357,7 +357,8 @@
fun simple (l: Layout.t): z =
(l, {isChar = false, needsParen = false})
val dontCare: z = simple (str "_")
- fun layoutRecord (ds: (Field.t * z) list, flexible: bool) =
+ fun bracket l = seq [str "[", l, str "]"]
+ fun layoutRecord (ds: (Field.t * bool * z) list, flexible: bool) =
simple (case ds of
[] => str "{...}"
| _ =>
@@ -365,9 +366,15 @@
mayAlign
(separateRight
(List.map
- (QuickSort.sortList (ds, fn ((f, _), (f', _)) =>
+ (QuickSort.sortList (ds, fn ((f, _, _), (f', _, _)) =>
Field.<= (f, f')),
- fn (f, (l, _)) => seq [Field.layout f, str ": ", l]),
+ fn (f, b, (l, _)) =>
+ let
+ val f = Field.layout f
+ val f = if b then bracket f else f
+ in
+ seq [f, str ": ", l]
+ end),
",")),
str (if flexible
then ", ...}"
@@ -564,23 +571,25 @@
(List.fold
(fields,
Spine.foldOverNew (spine, fields, [], fn (f, ac) =>
- (f, simple (str "unit"))
+ (f, false, simple (str "unit"))
:: ac),
- fn ((f, t), ac) => (f, t) :: ac),
+ fn ((f, t), ac) => (f, false, t) :: ac),
Spine.canAddFields spine)
fun genFlexRecord (_, {extra, fields, spine}) =
layoutRecord
(List.fold
(fields,
List.revMap (extra (), fn {field, tyvar} =>
- (field, simple (Tyvar.layout tyvar))),
- fn ((f, t), ac) => (f, t) :: ac),
+ (field, false, simple (Tyvar.layout tyvar))),
+ fn ((f, t), ac) => (f, false, t) :: ac),
Spine.canAddFields spine)
fun real _ = simple (str "real")
fun record (_, r) =
case Srecord.detupleOpt r of
NONE =>
- layoutRecord (Vector.toList (Srecord.toVector r), false)
+ layoutRecord (Vector.toListMap (Srecord.toVector r,
+ fn (f, t) => (f, false, t)),
+ false)
| SOME ts => Tycon.layoutApp (Tycon.tuple, ts)
fun recursive _ = simple (str "<recur>")
fun unknown (_, u) = simple (str "???")
@@ -839,7 +848,15 @@
fun unify (t, t'): UnifyResult.t =
let
val {destroy, lay = layoutPretty} = makeLayoutPretty ()
- val layoutRecord = fn z => layoutRecord (z, true)
+ val dontCare' =
+ case !Control.typeError of
+ Control.Concise => (fn _ => dontCare)
+ | Control.Full => layoutPretty
+ val layoutRecord =
+ fn z => layoutRecord (z,
+ case !Control.typeError of
+ Control.Concise => true
+ | Control.Full => false)
fun unify arg =
traceUnify
(fn (outer as T s, outer' as T s') =>
@@ -850,44 +867,58 @@
fun notUnifiable (l: Lay.t, l': Lay.t) =
(NotUnifiable (l, l'),
Unknown (Unknown.new {canGeneralize = true}))
+ val bracket = fn (l, z) => (bracket l, z)
+ fun notUnifiableBracket (l, l') =
+ notUnifiable (bracket l, bracket l')
fun oneFlex ({fields, spine, time}, r, outer, swap) =
let
val _ = minTime (outer, !time)
- val differences =
+ val (ac, ac') =
List.fold
(fields, ([], []), fn ((f, t), (ac, ac')) =>
case Srecord.peek (r, f) of
- NONE => ((f, dontCare) :: ac, ac')
+ NONE => ((f, true, dontCare' t) :: ac, ac')
| SOME t' =>
case unify (t, t') of
NotUnifiable (l, l') =>
- ((f, l) :: ac, (f, l') :: ac')
- | Unified => (ac, ac'))
- val (ac, ac') =
+ ((f, false, l) :: ac,
+ (f, false, l') :: ac')
+ | Unified =>
+ (case !Control.typeError of
+ Control.Concise => (ac, ac')
+ | Control.Full =>
+ let
+ val z =
+ (f, false,
+ layoutPretty t)
+ in
+ (z :: ac, z :: ac')
+ end))
+ val ac =
List.fold
- (Spine.fields spine, differences,
- fn (f, (ac, ac')) =>
+ (Spine.fields spine, ac,
+ fn (f, ac) =>
if List.exists (fields, fn (f', _) =>
Field.equals (f, f'))
- then (ac, ac')
+ then ac
else
case Srecord.peek (r, f) of
- NONE => ((f, dontCare) :: ac, ac')
- | SOME _ => (ac, ac'))
+ NONE => (f, true, dontCare) :: ac
+ | SOME _ => ac)
val ac' =
Srecord.foldi
(r, ac', fn (f, t, ac') =>
if Spine.ensureField (spine, f)
then ac'
- else (f, dontCare) :: ac')
+ else (f, true, dontCare' t) :: ac')
val _ = Spine.noMoreFields spine
in
- case differences of
+ case (ac, ac') of
([], []) => (Unified, Record r)
- | (ds, ds') =>
+ | _ =>
let
- val ds = layoutRecord ds
- val ds' = layoutRecord ds'
+ val ds = layoutRecord ac
+ val ds' = layoutRecord ac'
in
notUnifiable (if swap then (ds', ds)
else (ds, ds'))
@@ -903,15 +934,41 @@
* hand, if we choose layoutPretty, then we see the
* whole type that didn't unify.
*)
- notUnifiable
+ notUnifiableBracket
(if true
then (layoutPretty outer, layoutPretty outer')
else (layoutTopLevel t, layoutTopLevel t'))
+ fun unifys (ts, ts', yes, no) =
+ let
+ val us = Vector.map2 (ts, ts', unify)
+ in
+ if Vector.forall
+ (us, fn Unified => true | _ => false)
+ then yes ()
+ else
+ let
+ val (ls, ls') =
+ Vector.unzip
+ (Vector.mapi
+ (us, fn (i, u) =>
+ case u of
+ Unified =>
+ let
+ val z =
+ dontCare' (Vector.sub (ts, i))
+ in
+ (z, z)
+ end
+ | NotUnifiable (l, l') => (l, l')))
+ in
+ no (ls, ls')
+ end
+ end
fun conAnd (c, ts, t, t', swap) =
let
- val notUnifiable =
- fn (z, z') =>
- notUnifiable (if swap then (z', z) else (z, z'))
+ fun notUnifiable (z, z') =
+ notUnifiableBracket
+ (if swap then (z', z) else (z, z'))
in
case t of
Con (c', ts') =>
@@ -933,33 +990,16 @@
notUnifiable (lay ts, lay ts')
end
else
- let
- val us =
- Vector.map2 (ts, ts', unify)
- in
- if Vector.forall
- (us,
- fn Unified => true
- | _ => false)
- then (Unified, t)
- else
- let
- val (ls, ls') =
- Vector.unzip
- (Vector.map
- (us,
- fn Unified =>
- (dontCare,
- dontCare)
- | NotUnifiable (l, l') =>
- (l, l')))
- fun lay ls =
- Tycon.layoutApp (c, ls)
- in
- notUnifiable (lay ls,
- lay ls')
- end
- end
+ unifys
+ (ts, ts',
+ fn () => (Unified, t),
+ fn (ls, ls') =>
+ let
+ fun lay ls =
+ Tycon.layoutApp (c, ls)
+ in
+ notUnifiable (lay ls, lay ls')
+ end)
else not ()
| Int =>
if Tycon.isIntX c andalso Vector.isEmpty ts
@@ -1004,10 +1044,11 @@
Field.equals (f, f'))
orelse Spine.ensureField (spine', f)
then ac
- else (f, dontCare) :: ac)
+ else (f, true, dontCare) :: ac)
val ac = subsetSpine (fields, s, s')
val ac' = subsetSpine (fields', s', s)
- fun subset (fields, fields', spine', ac, ac') =
+ fun subset (fields, fields', spine', ac, ac',
+ skipBoth) =
List.fold
(fields, (ac, ac'),
fn ((f, t), (ac, ac')) =>
@@ -1016,16 +1057,31 @@
NONE =>
if Spine.ensureField (spine', f)
then (ac, ac')
- else ((f, dontCare) :: ac, ac')
+ else ((f, true, dontCare) :: ac, ac')
| SOME (_, t') =>
- case unify (t, t') of
- NotUnifiable (l, l') =>
- ((f, l) :: ac, (f, l) :: ac')
- | Unified => (ac, ac'))
- val (ac, ac') =
- subset (fields, fields', s', ac, ac')
+ if skipBoth
+ then (ac, ac')
+ else
+ case unify (t, t') of
+ NotUnifiable (l, l') =>
+ ((f, false, l) :: ac,
+ (f, false, l) :: ac')
+ | Unified =>
+ (case !Control.typeError of
+ Control.Concise =>
+ (ac, ac')
+ | Control.Full =>
+ let
+ val z =
+ (f, false,
+ layoutPretty t)
+ in
+ (z :: ac, z :: ac')
+ end))
val (ac, ac') =
- subset (fields', fields, s, [], [])
+ subset (fields, fields', s', ac, ac', false)
+ val (ac', ac) =
+ subset (fields', fields, s, ac', ac, true)
val _ = Spine.unify (s, s')
val fields =
List.fold
@@ -1060,16 +1116,28 @@
fn ((f, t), (ac, ac')) =>
case Srecord.peek (r', f) of
NONE =>
- ((f, dontCare) :: ac, ac')
+ ((f, true, dontCare' t) :: ac,
+ ac')
| SOME t' =>
if skipBoth
then (ac, ac')
else
case unify (t, t') of
NotUnifiable (l, l') =>
- ((f, l) :: ac,
- (f, l') :: ac')
- | Unified => (ac, ac'))
+ ((f, false, l) :: ac,
+ (f, false, l') :: ac')
+ | Unified =>
+ case !Control.typeError of
+ Control.Concise => (ac, ac')
+ | Control.Full =>
+ let
+ val z =
+ (f, false,
+ layoutPretty t)
+ in
+ (z :: ac,
+ z :: ac')
+ end)
val (ac, ac') =
diffs (r, r', false, [], [])
val (ac', ac) =
@@ -1085,32 +1153,12 @@
| (SOME ts, SOME ts') =>
if Vector.length ts = Vector.length ts'
then
- let
- val us =
- Vector.map2 (ts, ts', unify)
- in
- if Vector.forall
- (us,
- fn Unified => true
- | _ => false)
- then (Unified, Record r)
- else
- let
- val (ls, ls') =
- Vector.unzip
- (Vector.map
- (us,
- fn Unified =>
- (dontCare,
- dontCare)
- | NotUnifiable (l, l') =>
- (l, l')))
- in
- notUnifiable
- (layoutTuple ls,
- layoutTuple ls')
- end
- end
+ unifys
+ (ts, ts',
+ fn () => (Unified, Record r),
+ fn (ls, ls') =>
+ notUnifiable (layoutTuple ls,
+ layoutTuple ls'))
else not ()
| _ => not ())
| (Var a, Var a') =>
1.11 +8 -0 mlton/mlton/main/main.fun
Index: main.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/main.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- main.fun 18 Dec 2003 03:14:25 -0000 1.10
+++ main.fun 19 Dec 2003 05:03:12 -0000 1.11
@@ -368,6 +368,14 @@
intRef textIOBufSize),
(Expert, "type-check", " {false|true}", "type check ILs",
boolRef typeCheck),
+ (Normal, "type-error", " {concise|full}", "type error verbosity",
+ SpaceString
+ (fn s =>
+ typeError := (case s of
+ "concise" => Concise
+ | "full" => Full
+ | _ => usage (concat
+ ["invalid -type-error arg: ", s])))),
(Normal, "verbose", " {0|1|2|3}", "how verbose to be",
SpaceString
(fn s =>