[MLton-commit] r6047

[Matthew Fluet]

When required to conjure up a bogus type, do so at the appropriate
arity.

This avoids both cascading type-errors and an Error.bug abort of
elaboration.

The following program demonstrates the cascading type-error;
uncommenting the 'where type' constraint demonstrates the Error.bug.

signature Z = sig type ('a, 'b) zzz end
functor cpZ (Arg : Z) : Z (* where type ('a, 'b) zzz = ('a, 'b) Arg.zzz *) = 
struct 
   open Arg
end
structure Z1 = struct datatype ('a, 'b) zzz = Z end
structure Z2 = cpZ(structure Arg = Z1)

Previously, this would yield:
[fluet at shadow temp]$ mlton z.sml
Error: z.sml 7.20.
  Type zzz in argument signature but not in structure.
Error: z.sml 2.25.
  Type zzz has arity n-ary in structure but arity 2 in signature.
compilation aborted: parseAndElaborate reported errors
[fluet at shadow temp]$ mlton z.sml 
Error: z.sml 7.20.
  Type zzz in argument signature but not in structure.
ElaborateEnv.transparentCut.handleType: Nary tycon

Now, this yields:
[fluet at shadow temp]$ ../mlton.svn.trunk/build/bin/mlton z.sml
Error: z.sml 7.20.
  Type zzz in argument signature but not in structure.
compilation aborted: parseAndElaborate reported errors
[fluet at shadow temp]$ ../mlton.svn.trunk/build/bin/mlton z.sml
Error: z.sml 7.20.
  Type zzz in argument signature but not in structure.
compilation aborted: parseAndElaborate reported errors


----------------------------------------------------------------------

U   mlton/trunk/mlton/elaborate/elaborate-env.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun	2007-09-20 22:16:47 UTC (rev 6046)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun	2007-09-22 16:33:06 UTC (rev 6047)
@@ -404,11 +404,6 @@
 
       fun tycon (c, kind) = T {kind = kind,
                                node = Tycon c}
-
-      fun ignoreNone (s: t option): t =
-         case s of
-            NONE => tycon (Tycon.tuple, Kind.Nary)
-          | SOME s => s
    end
 
 local
@@ -575,6 +570,11 @@
 
             val toEnv = typeStrToEnv
 
+            fun toEnvNoNone s =
+               case toEnv s of
+                  NONE => EtypeStr.tycon (EtypeStr.Tycon.tuple, TypeStr.kind s)
+                | SOME s => s
+
             fun fromEnv (s: EtypeStr.t) =
                let
                   val kind = EtypeStr.kind s
@@ -588,10 +588,6 @@
                    | EtypeStr.Tycon c =>
                         tycon (Tycon.fromEnv (c, kind), kind)
                end
-
-            val fromEnv =
-               Trace.trace ("ElaborateEnv.Interface.TypeStr.fromEnv", EtypeStr.layout, layout)
-               fromEnv
          end
    end
 
@@ -1519,8 +1515,7 @@
               val types =
                  Array.map (types, fn (name, s) =>
                             {domain = name,
-                             range = (TypeStr.ignoreNone
-                                      (Interface.TypeStr.toEnv s)),
+                             range = Interface.TypeStr.toEnvNoNone s,
                              time = time,
                              uses = Uses.new ()})
               val vals =
@@ -2849,7 +2844,7 @@
             val types =
                map (structTypes, sigTypes, strids,
                     "type", Ast.Tycon.equals, Ast.Tycon.layout,
-                    TypeStr.ignoreNone o Interface.TypeStr.toEnv,
+                    Interface.TypeStr.toEnvNoNone,
                     fn (name, s, s') => handleType (s, s', strids, name))
             val vals =
                map