[MLton-commit] r6335
Vesa Karvonen
vesak at mlton.org
Thu Jan 17 05:48:37 PST 2008
Slightly generalized MLton's overload mechanism and improved checking of
overload definitions.
An overload now carries a (type) scheme rather than a type. This allows
polymorphic values to be overloaded. For example, an overloaded sub could
be defined as follows:
_overload 2 sub : 'a * int -> 'b
as List.nth
and Array.sub
and Vector.sub
and CharArray.sub
and CharVector.sub
The list of variants for an overload is now allowed to include other
overload definitions. This allows overload definitions to be (re)defined
incrementally. For example, the overload for + could be extended with a
new function as follows:
_overload 2 + : 'a * 'a -> 'a as + and My.plus
When elaborating an overload definition, it will now be checked that all
the given variants unify with the scheme given for the overload. For
example, the invalid definition:
_overload 2 funny : int -> int as Real.+ and CharVector.sub
now gives the following errors:
Error: [...]
Variant does not unify with overload.
overload: [int] -> [int]
variant: [real * real] -> [real]
in: _overload 2 funny: (int -> int) as Real.+ and CharVector.sub
Error: [...]
Variant does not unify with overload.
overload: [int] -> [int]
variant: [string * int] -> [char]
in: _overload 2 funny: (int -> int) as Real.+ and CharVector.sub
----------------------------------------------------------------------
U mlton/trunk/mlton/ast/ast-core.fun
U mlton/trunk/mlton/ast/ast-core.sig
U mlton/trunk/mlton/elaborate/elaborate-core.fun
U mlton/trunk/mlton/elaborate/elaborate-env.fun
U mlton/trunk/mlton/elaborate/elaborate-env.sig
U mlton/trunk/mlton/front-end/ml.grm
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/ast/ast-core.fun
===================================================================
--- mlton/trunk/mlton/ast/ast-core.fun 2008-01-17 10:56:32 UTC (rev 6334)
+++ mlton/trunk/mlton/ast/ast-core.fun 2008-01-17 13:48:35 UTC (rev 6335)
@@ -322,7 +322,7 @@
| Open of Longstrid.t vector
| Overload of Priority.t * Var.t *
Tyvar.t vector * Type.t *
- Longvar.t vector
+ Longvid.t vector
| SeqDec of dec vector
| Type of TypBind.t
| Val of {tyvars: Tyvar.t vector,
@@ -478,7 +478,7 @@
seq [str "_overload ", Priority.layout p, str " ",
align [layoutConstraint (Var.layout x, t),
layoutAnds ("as", xs, fn (prefix, x) =>
- seq [prefix, Longvar.layout x])]]
+ seq [prefix, Longvid.layout x])]]
| SeqDec ds => align (Vector.toListMap (ds, layoutDec))
| Type typBind => TypBind.layout typBind
| Val {tyvars, vbs, rvbs} =>
Modified: mlton/trunk/mlton/ast/ast-core.sig
===================================================================
--- mlton/trunk/mlton/ast/ast-core.sig 2008-01-17 10:56:32 UTC (rev 6334)
+++ mlton/trunk/mlton/ast/ast-core.sig 2008-01-17 13:48:35 UTC (rev 6335)
@@ -206,7 +206,7 @@
| Overload of Priority.t *
Var.t *
Tyvar.t vector * Type.t *
- Longvar.t vector
+ Longvid.t vector
| SeqDec of t vector
| Type of TypBind.t
| Val of {rvbs: {match: Match.t,
Modified: mlton/trunk/mlton/elaborate/elaborate-core.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-core.fun 2008-01-17 10:56:32 UTC (rev 6334)
+++ mlton/trunk/mlton/elaborate/elaborate-core.fun 2008-01-17 13:48:35 UTC (rev 6335)
@@ -2088,15 +2088,44 @@
* x appears in the xs.
*)
val ovlds =
- Vector.map (xs, fn x => Env.lookupLongvar (E, x))
+ Vector.concatV
+ (Vector.map
+ (xs, fn x =>
+ case Env.lookupLongvid (E, x)
+ of (Vid.Var v, t) => Vector.new1 (Longvid.region x, (v, t))
+ | (Vid.Overload (_, vs), _) =>
+ Vector.map (vs, fn vt => (Longvid.region x, vt))
+ | _ =>
+ (Control.error
+ (Longvid.region x,
+ str "cannot overload",
+ seq [str "constructor: ", Longvid.layout x])
+ ; Vector.new0 ())))
+ val s =
+ Scheme.make {canGeneralize = false,
+ tyvars = tyvars,
+ ty = elabType ty}
val _ =
+ Vector.foreach
+ (ovlds,
+ fn (_, (_, NONE)) => ()
+ | (r, (_, SOME s')) => let
+ val is = Scheme.instantiate s
+ val is' = Scheme.instantiate s'
+ in
+ unify
+ (#instance is,
+ #instance is',
+ fn (l1, l2) =>
+ (r,
+ str "variant does not unify with overload",
+ align [seq [str "overload: ", l1],
+ seq [str "variant: ", l2],
+ lay ()]))
+ end)
+ val _ =
Env.extendOverload
- (E, p, x,
- Vector.map (ovlds, fn (x, s) =>
- (x, Option.map (s, Scheme.ty))),
- Scheme.make {canGeneralize = false,
- tyvars = tyvars,
- ty = elabType ty})
+ (E, p, x, Vector.map (ovlds, fn (_, vt) => vt), s)
in
Decs.empty
end)
@@ -3007,13 +3036,19 @@
val resolve =
Promise.lazy
(fn () =>
- case (Vector.peek
- (yts, fn (_, t) =>
- case t of
- NONE => false
- | SOME t =>
- Type.canUnify
- (instance, t))) of
+ case Vector.peekMap
+ (yts,
+ fn (x, s) =>
+ case s of
+ NONE => NONE
+ | SOME s => let
+ val is = Scheme.instantiate s
+ in
+ if Type.canUnify
+ (instance, #instance is)
+ then SOME (x, SOME is)
+ else NONE
+ end) of
NONE =>
let
val _ =
@@ -3023,17 +3058,18 @@
str (Longvid.toString id)],
Type.layoutPretty instance)
in
- Var.newNoname ()
+ {id = Var.newNoname (),
+ args = Vector.new0 ()}
end
- | SOME (y, t) =>
+ | SOME (y, is) =>
(unify (instance,
- valOf t, fn _ =>
+ #instance (valOf is), fn _ =>
Error.bug "ElaborateCore.elabExp: Var:overload unify")
- ; y))
+ ; {id = y, args = #args (valOf is) ()}))
val _ =
List.push (overloads, (p, ignore o resolve))
in
- Cexp.Var (resolve, fn () => Vector.new0 ())
+ Cexp.Var (#id o resolve, #args o resolve)
end
| Vid.Var x =>
Cexp.Var (fn () => x,
Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun 2008-01-17 10:56:32 UTC (rev 6334)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun 2008-01-17 13:48:35 UTC (rev 6335)
@@ -240,7 +240,7 @@
datatype t =
Con of Con.t
| Exn of Con.t
- | Overload of Priority.t * (Var.t * Type.t option) vector
+ | Overload of Priority.t * (Var.t * Scheme.t option) vector
| Var of Var.t
val statusPretty =
@@ -263,7 +263,7 @@
Layout.toString (Priority.layout p),
")"],
Vector.layout (Layout.tuple2 (Var.layout,
- Option.layout Type.layout))
+ Option.layout Scheme.layout))
xts)
| Var v => ("Var", Var.layout v)
in
Modified: mlton/trunk/mlton/elaborate/elaborate-env.sig
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.sig 2008-01-17 10:56:32 UTC (rev 6334)
+++ mlton/trunk/mlton/elaborate/elaborate-env.sig 2008-01-17 13:48:35 UTC (rev 6335)
@@ -48,7 +48,7 @@
datatype t =
Con of CoreML.Con.t
| Exn of CoreML.Con.t
- | Overload of Ast.Priority.t * (CoreML.Var.t * Type.t option) vector
+ | Overload of Ast.Priority.t * (CoreML.Var.t * Scheme.t option) vector
| Var of CoreML.Var.t
val layout: t -> Layout.t
@@ -172,7 +172,7 @@
val extendVar:
t * Ast.Var.t * CoreML.Var.t * Scheme.t * {isRebind: bool} -> unit
val extendOverload:
- t * Ast.Priority.t * Ast.Var.t * (CoreML.Var.t * Type.t option) vector
+ t * Ast.Priority.t * Ast.Var.t * (CoreML.Var.t * Scheme.t option) vector
* Scheme.t
-> unit
val forceUsed: t -> unit
Modified: mlton/trunk/mlton/front-end/ml.grm
===================================================================
--- mlton/trunk/mlton/front-end/ml.grm 2008-01-17 10:56:32 UTC (rev 6334)
+++ mlton/trunk/mlton/front-end/ml.grm 2008-01-17 13:48:35 UTC (rev 6335)
@@ -310,8 +310,7 @@
| longstrids of Longstrid.t list
| longtycon of Longtycon.t
| longtyconeqns of Longtycon.t list
- | longvar of Longvar.t
- | longvarands of Longvar.t list
+ | longvidands of Longvid.t list
| longvid of Longvid.t
| longvidNoEqual of Longvid.t
| match of Match.t
@@ -742,12 +741,12 @@
| OPEN longstrids (Dec.Open (Vector.fromList longstrids))
| fixity vids (Dec.Fix {fixity = fixity,
ops = Vector.fromList vids})
- | OVERLOAD priority var COLON ty AS longvarands
+ | OVERLOAD priority var COLON ty AS longvidands
(Dec.Overload (priority,
var,
Vector.new0 (),
ty,
- Vector.fromList longvarands))
+ Vector.fromList longvidands))
valbindTop : valbind (let
val (vbs, rvbs) = valbind
@@ -949,8 +948,8 @@
| WITHTYPE typBind
(typBind)
-longvarands : longvar ([longvar])
- | longvar AND longvarands (longvar :: longvarands)
+longvidands : longvid ([longvid])
+ | longvid AND longvidands (longvid :: longvidands)
match : rules (Match.makeRegion' (Match.T (Vector.fromList rules),
rulesleft, rulesright))
@@ -1266,7 +1265,6 @@
fctid : id (Fctid.fromSymbol id)
longtycon : longidNoAsterisk (Longtycon.fromSymbols longidNoAsterisk)
-longvar : longidEqual (Longvar.fromSymbols longidEqual)
longvid : longidEqual (Longvid.fromSymbols longidEqual)
longvidNoEqual : longid (Longvid.fromSymbols longid)
longcon : longid (Longcon.fromSymbols longid)
More information about the MLton-commit
mailing list