[MLton] cvs commit: improved type constructor names in type errors
sweeks@mlton.org
sweeks@mlton.org
Fri, 26 Dec 2003 15:40:24 -0800
sweeks 03/12/26 15:40:23
Modified: mlton/atoms id.fun id.sig
mlton/elaborate elaborate-core.fun elaborate-env.fun
elaborate-env.sig type-env.fun type-env.sig
mlton/main compile.fun
Log:
MAIL improved type constructor names in type errors
Display type constructor names based on the environment currently in
scope. Choose a shortest (in terms of dots) name for each type
constructor. So, when the type name is in scope, the short name will
be used, as in
structure S =
struct
datatype t = T
fun f T = ()
val _ = f 13
end
Error: z.sml 5.15: function applied to incorrect argument
expects: [t]
but got: [int]
in: f 13
However, once we are outside the structure S, then the full name will
be used:
structure S =
struct
datatype t = T
fun f T = ()
end
val _ = S.f 13
Error: z.sml 6.9: function applied to incorrect argument
expects: [S.t]
but got: [int]
in: S.f 13
Also, use a "?." to prefix type constructors that are not currently
accessible. For example:
datatype t = T
fun f T = ()
type t = unit
val _ = f 13
Error: z.sml 4.9: function applied to incorrect argument
expects: [?.t]
but got: [int]
in: f 13
Revision Changes Path
1.9 +2 -0 mlton/mlton/atoms/id.fun
Index: id.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.fun,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- id.fun 11 Dec 2003 03:20:51 -0000 1.8
+++ id.fun 26 Dec 2003 23:40:22 -0000 1.9
@@ -33,6 +33,8 @@
val originalName = make #originalName
end
+fun setPrintName (T {printName, ...}, s) = printName := SOME s
+
fun toString (T {printName, originalName, ...}) =
case !printName of
NONE =>
1.6 +3 -2 mlton/mlton/atoms/id.sig
Index: id.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/atoms/id.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- id.sig 11 Dec 2003 03:20:51 -0000 1.5
+++ id.sig 26 Dec 2003 23:40:22 -0000 1.6
@@ -21,12 +21,13 @@
val equals: t * t -> bool
val fromString: string -> t (* doesn't add uniquefying suffix *)
val layout: t -> Layout.t
- val new: t -> t (* with the same prefix *)
- val newNoname: unit -> t (* prefix is "x" *)
+ val new: t -> t (* with the same prefix *)
+ val newNoname: unit -> t (* prefix is noname *)
val newString: string -> t (* given prefix *)
val originalName: t -> string (* raw destructor *)
val plist: t -> PropertyList.t
val sameName: t * t -> bool
+ val setPrintName: t * string -> unit
val toString: t -> string
end
1.53 +30 -17 mlton/mlton/elaborate/elaborate-core.fun
Index: elaborate-core.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-core.fun,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -r1.52 -r1.53
--- elaborate-core.fun 30 Nov 2003 23:39:09 -0000 1.52
+++ elaborate-core.fun 26 Dec 2003 23:40:22 -0000 1.53
@@ -279,6 +279,7 @@
val unify = Type.unify
fun unifyList (trs: (Type.t * Region.t) vector,
+ preError: unit -> unit,
lay: unit -> Layout.t): Type.t =
if 0 = Vector.length trs
then Type.list (Type.new ())
@@ -288,7 +289,7 @@
val _ =
Vector.foreach
(trs, fn (t', r) =>
- unify (t, t', fn (l, l') =>
+ unify (t, t', preError, fn (l, l') =>
(r,
str "list elements of different types",
align [seq [str "element: ", l'],
@@ -334,7 +335,7 @@
else concat [String.prefix (s, 35), " ... ", String.suffix (s, 25)])
end
-fun elaboratePat (p: Apat.t, E: Env.t, amInRvb: bool)
+fun elaboratePat (p: Apat.t, E: Env.t, preError: unit -> unit, amInRvb: bool)
: Cpat.t * (Avar.t * Var.t * Type.t) vector =
let
val region = Apat.region p
@@ -372,6 +373,7 @@
(fn p: Apat.t =>
let
val region = Apat.region p
+ val unify = fn (t, t', f) => unify (t, t', preError, f)
fun unifyPatternConstraint (p, lay, c) =
unify
(p, c, fn (l1, l2) =>
@@ -393,7 +395,8 @@
val resultType = Type.new ()
val _ =
unify
- (instance, Type.arrow (argType, resultType), fn _ =>
+ (instance, Type.arrow (argType, resultType),
+ fn _ =>
(region,
str "constant constructor applied to argument",
seq [str "pattern: ", lay ()]))
@@ -459,6 +462,7 @@
unifyList
(Vector.map2 (ps, ps', fn (p, p') =>
(Cpat.ty p', Apat.region p)),
+ preError,
fn () => seq [str "pattern: ", lay ()]))
end
| Apat.Record {flexible, items} =>
@@ -992,6 +996,8 @@
Layout.ignore, Trace.assertTrue)
(fn (d, nest, isTop) =>
let
+ val preError = Promise.lazy (fn () => Env.setTyconNames E)
+ val unify = fn (t, t', f) => unify (t, t', preError, f)
fun lay () = seq [str "in: ", approximate (Adec.layout d)]
val region = Adec.region d
fun checkSchemes (v: (Var.t * Scheme.t) vector): unit =
@@ -1218,7 +1224,8 @@
val pats =
Vector.map
(args, fn p =>
- {pat = #1 (elaboratePat (p, E, false)),
+ {pat = #1 (elaboratePat
+ (p, E, preError, false)),
region = Apat.region p})
val bodyRegion = Aexp.region body
val body = elabExp (body, nest)
@@ -1466,7 +1473,8 @@
(rvbs, fn {pat, match} =>
let
val region = Apat.region pat
- val (pat, bound) = elaboratePat (pat, E, true)
+ val (pat, bound) =
+ elaboratePat (pat, E, preError, true)
val (nest, var, ty) =
if 0 = Vector.length bound
then ("anon" :: nest,
@@ -1500,7 +1508,7 @@
(rvbs, fn {bound, match, nest, pat, region, var, ...} =>
let
val {argType, region, resultType, rules} =
- elabMatch (match, nest)
+ elabMatch (match, preError, nest)
val _ =
unify
(Cpat.ty pat,
@@ -1542,7 +1550,8 @@
(vbs,
fn {exp = e, expRegion, lay, pat, patRegion, ...} =>
let
- val (p, bound) = elaboratePat (pat, E, false)
+ val (p, bound) =
+ elaboratePat (pat, E, preError, false)
val _ =
unify
(Cpat.ty p, Cexp.ty e, fn (p, e) =>
@@ -1596,6 +1605,8 @@
Trace.assertTrue)
(fn (e: Aexp.t, nest) =>
let
+ val preError = Promise.lazy (fn () => Env.setTyconNames E)
+ val unify = fn (t, t', f) => unify (t, t', preError, f)
fun lay () = seq [str "in: ", approximate (Aexp.layout e)]
val unify =
fn (a, b, f) => unify (a, b, fn z =>
@@ -1662,7 +1673,7 @@
let
val e = elab e
val {argType, resultType, rules, ...} =
- elabMatch (m, nest)
+ elabMatch (m, preError, nest)
val _ =
unify
(Cexp.ty e, argType, fn (l1, l2) =>
@@ -1695,7 +1706,8 @@
| Aexp.Fn m =>
let
val {arg, argType, body} =
- elabMatchFn (m, nest, "function", lay, Cexp.RaiseMatch)
+ elabMatchFn (m, preError, nest, "function", lay,
+ Cexp.RaiseMatch)
val body =
Cexp.enterLeave
(body, SourceInfo.function {name = nest,
@@ -1710,7 +1722,7 @@
let
val try = elab try
val {arg, argType, body} =
- elabMatchFn (match, nest, "handler", lay,
+ elabMatchFn (match, preError, nest, "handler", lay,
Cexp.RaiseAgain)
val _ =
unify
@@ -1769,7 +1781,7 @@
unifyList
(Vector.map2 (es, es', fn (e, e') =>
(Cexp.ty e', Aexp.region e)),
- lay))
+ preError, lay))
end
| Aexp.Orelse (e, e') =>
let
@@ -2001,10 +2013,11 @@
Cexp.whilee {expr = expr, test = test'}
end
end) arg
- and elabMatchFn (m: Amatch.t, nest, kind, lay, noMatch) =
+ and elabMatchFn (m: Amatch.t, preError, nest, kind, lay, noMatch) =
let
val arg = Var.newNoname ()
- val {argType, region, resultType, rules} = elabMatch (m, nest)
+ val {argType, region, resultType, rules} =
+ elabMatch (m, preError, nest)
val body =
Cexp.casee {kind = kind,
lay = lay,
@@ -2017,7 +2030,7 @@
argType = argType,
body = body}
end
- and elabMatch (m: Amatch.t, nest: Nest.t) =
+ and elabMatch (m: Amatch.t, preError, nest: Nest.t) =
let
val region = Amatch.region m
val Amatch.T rules = Amatch.node m
@@ -2036,10 +2049,10 @@
approximate
(seq [Apat.layout pat, str " => ", Aexp.layout exp])
end
- val (p, xts) = elaboratePat (pat, E, false)
+ val (p, xts) = elaboratePat (pat, E, preError, false)
val _ =
unify
- (Cpat.ty p, argType, fn (l1, l2) =>
+ (Cpat.ty p, argType, preError, fn (l1, l2) =>
(Apat.region pat,
str "rule patterns of different types",
align [seq [str "pattern: ", l1],
@@ -2048,7 +2061,7 @@
val e = elabExp (exp, nest)
val _ =
unify
- (Cexp.ty e, resultType, fn (l1, l2) =>
+ (Cexp.ty e, resultType, preError, fn (l1, l2) =>
(Aexp.region exp,
str "rule results of different types",
align [seq [str "result: ", l1],
1.24 +68 -1 mlton/mlton/elaborate/elaborate-env.fun
Index: elaborate-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.fun,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -r1.23 -r1.24
--- elaborate-env.fun 19 Dec 2003 00:40:56 -0000 1.23
+++ elaborate-env.fun 26 Dec 2003 23:40:22 -0000 1.24
@@ -266,12 +266,14 @@
values = values}))
end
+val allTycons: Tycon.t list ref = ref []
val newTycons: (Tycon.t * Kind.t) list ref = ref []
val newTycon: string * Kind.t -> Tycon.t =
fn (s, k) =>
let
val c = Tycon.fromString s
+ val _ = List.push (allTycons, c)
val _ = List.push (newTycons, (c, k))
in
c
@@ -1083,6 +1085,64 @@
; doit (types, types')
end
+fun setTyconNames (T {strs, types, ...}) =
+ let
+ val {get = seen: Tycon.t -> bool ref, ...} =
+ Property.get (Tycon.plist, Property.initFun (fn _ => ref false))
+ fun doType (typeStr: TypeStr.t,
+ name: Ast.Tycon.t,
+ strids: Strid.t list): unit =
+ case TypeStr.toTyconOpt typeStr of
+ NONE => ()
+ | SOME c =>
+ let
+ val r = seen c
+ in
+ if !r
+ then ()
+ else
+ let
+ val _ = r := true
+ val name =
+ Ast.Longtycon.toString
+ (Ast.Longtycon.long (strids, name))
+ in
+ Tycon.setPrintName (c, name)
+ end
+ end
+ fun foreach (NameSpace.T {table, ...}, f) =
+ HashSet.foreach
+ (table, fn Values.T {domain, ranges} =>
+ case !ranges of
+ [] => ()
+ | {value, ...} :: _ => f (domain, value))
+ val _ = foreach (types, fn (name, typeStr) => doType (typeStr, name, []))
+ val {get = strSeen: Structure.t -> bool ref, ...} =
+ Property.get (Structure.plist, Property.initFun (fn _ => ref false))
+ fun loopStr (s as Structure.T {strs, types, ...}, strids: Strid.t list)
+ : unit =
+ let
+ val r = strSeen s
+ in
+ if !r
+ then ()
+ else
+ (r := true
+ ; Info.foreach (types, fn (name, typeStr) =>
+ doType (typeStr, name, strids))
+ ; Info.foreach (strs, fn (strid, str) =>
+ loopStr (str, strids @ [strid])))
+ end
+ val _ = foreach (strs, fn (strid, str) => loopStr (str, [strid]))
+ val _ =
+ List.foreach
+ (!allTycons, fn c =>
+ if ! (seen c)
+ then ()
+ else Tycon.setPrintName (c, concat ["?.", Tycon.originalName c]))
+ in
+ ()
+ end
val propertyFun:
('a -> PropertyList.t) * ('a * 'b * ('a * 'b -> 'c) -> 'c)
@@ -1183,6 +1243,12 @@
{opaque: bool, prefix: string}, region)
: Structure.t * Decs.t =
let
+ val preError =
+ Promise.lazy
+ (fn () =>
+ scope (E, fn () =>
+ (openStructure (E, S)
+ ; setTyconNames E)))
val decs = ref []
fun error (name, l) =
let
@@ -1211,6 +1277,7 @@
ty = ty',
tyvars = tyvars'},
tyvars),
+ preError,
fn (l1, l2) =>
let
open Layout
@@ -1437,7 +1504,7 @@
Scheme.instantiate s'
val _ =
Type.unify
- (t, t', fn (l, l') =>
+ (t, t', preError, fn (l, l') =>
let
open Layout
in
1.14 +1 -0 mlton/mlton/elaborate/elaborate-env.sig
Index: elaborate-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/elaborate-env.sig,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- elaborate-env.sig 19 Dec 2003 00:40:56 -0000 1.13
+++ elaborate-env.sig 26 Dec 2003 23:40:22 -0000 1.14
@@ -134,6 +134,7 @@
val scope: t * (unit -> 'a) -> 'a
(* like scope, but works for signatures and functors as well *)
val scopeAll: t * (unit -> 'a) -> 'a
+ val setTyconNames: t -> unit
val sizeMessage: t -> Layout.t
end
1.15 +119 -170 mlton/mlton/elaborate/type-env.fun
Index: type-env.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.fun,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- type-env.fun 20 Dec 2003 02:24:35 -0000 1.14
+++ type-env.fun 26 Dec 2003 23:40:22 -0000 1.15
@@ -845,7 +845,7 @@
val traceUnify = Trace.trace2 ("unify", layout, layout, UnifyResult.layout)
- fun unify (t, t'): UnifyResult.t =
+ fun unify (t, t', preError: unit -> unit): UnifyResult.t =
let
val {destroy, lay = layoutPretty} = makeLayoutPretty ()
val dontCare' =
@@ -874,74 +874,41 @@
needsParen = false})
fun notUnifiableBracket (l, l') =
notUnifiable (bracket l, bracket l')
+ fun flexToRecord (fields, spine) =
+ (Vector.fromList fields,
+ Vector.fromList
+ (List.fold
+ (Spine.fields spine, [], fn (f, ac) =>
+ if List.exists (fields, fn (f', _) =>
+ Field.equals (f, f'))
+ then ac
+ else f :: ac)),
+ fn f => Spine.ensureField (spine, f))
+ fun rigidToRecord r =
+ (Srecord.toVector r,
+ Vector.new0 (),
+ fn f => isSome (Srecord.peek (r, f)))
fun oneFlex ({fields, spine, time}, r, outer, swap) =
let
val _ = minTime (outer, !time)
- val (ac, ac') =
- List.fold
- (fields, ([], []), fn ((f, t), (ac, ac')) =>
- case Srecord.peek (r, f) of
- NONE => ((f, true, dontCare' t) :: ac, ac')
- | SOME t' =>
- 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 =
- List.fold
- (Spine.fields spine, ac,
- fn (f, ac) =>
- if List.exists (fields, fn (f', _) =>
- Field.equals (f, f'))
- then ac
- else
- case Srecord.peek (r, f) of
- 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, true, dontCare' t) :: ac')
- val _ = Spine.noMoreFields spine
in
- case (ac, ac') of
- ([], []) => (Unified, Record r)
- | _ =>
- let
- val ds = layoutRecord ac
- val ds' = layoutRecord ac'
- in
- notUnifiable (if swap then (ds', ds)
- else (ds, ds'))
- end
+ unifyRecords
+ (flexToRecord (fields, spine),
+ rigidToRecord r,
+ fn () => (Spine.noMoreFields spine
+ ; (Unified, Record r)),
+ fn (l, l') => notUnifiable (if swap
+ then (l', l)
+ else (l, l')))
end
fun genFlexError () =
Error.bug "GenFlexRecord seen in unify"
val {equality = e, ty = t, plist} = Set.value s
val {equality = e', ty = t', ...} = Set.value s'
fun not () =
- (* By choosing layoutTopLevel, when two types don't
- * unify, we only see the outermost bits. On the other
- * hand, if we choose layoutPretty, then we see the
- * whole type that didn't unify.
- *)
- notUnifiableBracket
- (if true
- then (layoutPretty outer, layoutPretty outer')
- else (layoutTopLevel t, layoutTopLevel t'))
+ (preError ()
+ ; notUnifiableBracket (layoutPretty outer,
+ layoutPretty outer'))
fun unifys (ts, ts', yes, no) =
let
val us = Vector.map2 (ts, ts', unify)
@@ -989,6 +956,7 @@
(Vector.length ts),
" args> "]),
Tycon.layout c])
+ val _ = preError ()
in
notUnifiableBracket
(maybe (lay ts, lay ts'))
@@ -1041,71 +1009,30 @@
| (FlexRecord {fields = fields, spine = s, time = t},
FlexRecord {fields = fields', spine = s',
time = t', ...}) =>
- let
- fun subsetSpine (fields, spine, spine') =
- List.fold
- (Spine.fields spine, [], fn (f, ac) =>
- if List.exists (fields, fn (f', _) =>
- Field.equals (f, f'))
- orelse Spine.ensureField (spine', f)
- then 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',
- skipBoth) =
- List.fold
- (fields, (ac, ac'),
- fn ((f, t), (ac, ac')) =>
- case List.peek (fields', fn (f', _) =>
- Field.equals (f, f')) of
- NONE =>
- if Spine.ensureField (spine', f)
- then (ac, ac')
- else ((f, true, dontCare) :: ac, ac')
- | SOME (_, t') =>
- 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', ac, ac', false)
- val (ac', ac) =
- subset (fields', fields, s, ac', ac, true)
- val _ = Spine.unify (s, s')
- val fields =
- List.fold
- (fields, fields', fn ((f, t), ac) =>
- if List.exists (fields', fn (f', _) =>
- Field.equals (f, f'))
- then ac
- else (f, t) :: ac)
- in
- case (ac, ac') of
- ([], []) =>
- (Unified,
- FlexRecord
- {fields = fields,
- spine = s,
- time = ref (Time.min (!t, !t'))})
- | _ => notUnifiable (layoutRecord ac,
- layoutRecord ac')
- end
+ let
+ fun yes () =
+ let
+ val _ = Spine.unify (s, s')
+ val fields =
+ List.fold
+ (fields, fields', fn ((f, t), ac) =>
+ if List.exists (fields', fn (f', _) =>
+ Field.equals (f, f'))
+ then ac
+ else (f, t) :: ac)
+ in
+ (Unified,
+ FlexRecord
+ {fields = fields,
+ spine = s,
+ time = ref (Time.min (!t, !t'))})
+ end
+ in
+ unifyRecords
+ (flexToRecord (fields, s),
+ flexToRecord (fields', s'),
+ yes, notUnifiable)
+ end
| (GenFlexRecord _, _) => genFlexError ()
| (_, GenFlexRecord _) => genFlexError ()
| (Int, Int) => (Unified, Int)
@@ -1114,47 +1041,10 @@
(case (Srecord.detupleOpt r,
Srecord.detupleOpt r') of
(NONE, NONE) =>
- let
- fun diffs (r, r', skipBoth, ac, ac') =
- Vector.fold
- (Srecord.toVector r, (ac, ac'),
- fn ((f, t), (ac, ac')) =>
- case Srecord.peek (r', f) of
- NONE =>
- ((f, true, dontCare' t) :: ac,
- ac')
- | SOME t' =>
- 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') =
- diffs (r, r', false, [], [])
- val (ac', ac) =
- diffs (r', r, true, ac', ac)
- in
- case (ac, ac') of
- ([], []) =>
- (Unified, Record r)
- | _ =>
- notUnifiable (layoutRecord ac,
- layoutRecord ac')
- end
+ unifyRecords
+ (rigidToRecord r, rigidToRecord r',
+ fn () => (Unified, Record r),
+ notUnifiable)
| (SOME ts, SOME ts') =>
if Vector.length ts = Vector.length ts'
then
@@ -1192,6 +1082,65 @@
in
res
end) arg
+ and unifyRecords ((fields: (Field.t * t) vector,
+ extra: Field.t vector,
+ ensureField: Field.t -> bool),
+ (fields': (Field.t * t) vector,
+ extra': Field.t vector,
+ ensureField': Field.t -> bool),
+ yes, no) =
+ let
+ fun extras (extra, ensureField') =
+ Vector.fold
+ (extra, [], fn (f, ac) =>
+ if ensureField' f
+ then ac
+ else (preError (); (f, true, dontCare) :: ac))
+ val ac = extras (extra, ensureField')
+ val ac' = extras (extra', ensureField)
+ fun subset (fields, fields', ensureField', ac, ac',
+ both, skipBoth) =
+ Vector.fold
+ (fields, (ac, ac', both), fn ((f, t), (ac, ac', both)) =>
+ case Vector.peek (fields', fn (f', _) =>
+ Field.equals (f, f')) of
+ NONE =>
+ if ensureField' f
+ then (ac, ac', both)
+ else (preError ()
+ ; ((f, true, dontCare' t) :: ac, ac', both))
+ | SOME (_, t') =>
+ if skipBoth
+ then (ac, ac', both)
+ else
+ case unify (t, t') of
+ NotUnifiable (l, l') =>
+ ((f, false, l) :: ac,
+ (f, false, l') :: ac',
+ both)
+ | Unified =>
+ (ac, ac',
+ case !Control.typeError of
+ Control.Concise => []
+ | Control.Full => (f, t) :: both))
+ val (ac, ac', both) =
+ subset (fields, fields', ensureField', ac, ac', [], false)
+ val (ac', ac, both) =
+ subset (fields', fields, ensureField, ac', ac, both, true)
+ in
+ case (ac, ac') of
+ ([], []) => yes ()
+ | _ =>
+ let
+ val _ = preError ()
+ fun doit ac =
+ layoutRecord (List.fold
+ (both, ac, fn ((f, t), ac) =>
+ (f, false, layoutPretty t) :: ac))
+ in
+ no (doit ac, doit ac')
+ end
+ end
val _ = destroy ()
in
unify (t, t')
@@ -1215,8 +1164,8 @@
datatype unifyResult = datatype UnifyResult'.t
val unify =
- fn (t, t') =>
- case unify (t, t') of
+ fn (t, t', preError) =>
+ case unify (t, t', preError) of
UnifyResult.NotUnifiable ((l, _), (l', _)) => NotUnifiable (l, l')
| UnifyResult.Unified => Unified
@@ -1627,7 +1576,7 @@
List.foreach
(!Type.freeUnknowns, fn t =>
case Type.toType t of
- Type.Unknown _ => (Type.unify (t, Type.unit)
+ Type.Unknown _ => (Type.unify (t, Type.unit, fn () => ())
; ())
| _ => ())
val _ = Type.freeUnknowns := []
@@ -1728,9 +1677,9 @@
expandOpaque
val unify =
- fn (t1: t, t2: t,
+ fn (t1: t, t2: t, preError: unit -> unit,
f: Layout.t * Layout.t -> Region.t * Layout.t * Layout.t) =>
- case unify (t1, t2) of
+ case unify (t1, t2, preError) of
NotUnifiable z => Control.error (f z)
| Unified => ()
end
1.7 +4 -2 mlton/mlton/elaborate/type-env.sig
Index: type-env.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/elaborate/type-env.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- type-env.sig 14 Nov 2003 03:48:18 -0000 1.6
+++ type-env.sig 26 Dec 2003 23:40:22 -0000 1.7
@@ -47,8 +47,10 @@
val string: t
val toString: t -> string
(* make two types identical (recursively). side-effecting. *)
- val unify: t * t * (Layout.t * Layout.t
- -> Region.t * Layout.t * Layout.t) -> unit
+ val unify:
+ t * t * (unit -> unit)
+ * (Layout.t * Layout.t -> Region.t * Layout.t * Layout.t)
+ -> unit
val unresolvedInt: unit -> t
val unresolvedReal: unit -> t
val unresolvedWord: unit -> t
1.11 +5 -2 mlton/mlton/main/compile.fun
Index: compile.fun
===================================================================
RCS file: /cvsroot/mlton/mlton/mlton/main/compile.fun,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -r1.10 -r1.11
--- compile.fun 14 Nov 2003 03:48:18 -0000 1.10
+++ compile.fun 26 Dec 2003 23:40:23 -0000 1.11
@@ -424,8 +424,11 @@
end
fun layoutBasisLibrary () =
- let val _ = selectBasisLibrary ()
- in Env.layoutPretty basisEnv
+ let
+ val _ = selectBasisLibrary ()
+ val _ = Env.setTyconNames basisEnv
+ in
+ Env.layoutPretty basisEnv
end
(* ------------------------------------------------- *)