[project @ 2001-10-25 02:13:10 by sof]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcMType.lhs

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 0e18104..9d27e67 100644 (file)
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -60,7 +60,7 @@ import TcType         ( tcEqType, tcCmpPred,
 
                          liftedTypeKind, unliftedTypeKind, openTypeKind, defaultKind, superKind,
                          superBoxity, liftedBoxity, hasMoreBoxityInfo, typeKind,
-                         tyVarsOfType, tyVarsOfTypes, tidyOpenType, tidyOpenTypes, tidyTyVar,
+                         tyVarsOfType, tyVarsOfTypes, tidyOpenType, tidyOpenTypes, tidyOpenTyVar,
                          eqKind, isTypeKind,
 
                          isFFIArgumentTy, isFFIImportResultTy
@@ -88,7 +88,7 @@ import BasicTypes     ( Boxity, Arity, isBoxed )
 import CmdLineOpts     ( dopt, DynFlag(..) )
 import Unique          ( Uniquable(..) )
 import SrcLoc          ( noSrcLoc )
-import Util            ( nOfThem )
+import Util            ( nOfThem, isSingleton, equalLength )
 import ListSetOps      ( removeDups )
 import Outputable
 \end{code}
@@ -522,7 +522,8 @@ to a Type, performing kind checking, and then check various things that should
 be true about it.  We don't want to perform these checks at the same time
 as the initial translation because (a) they are unnecessary for interface-file
 types and (b) when checking a mutually recursive group of type and class decls,
-we can't "look" at the tycons/classes yet.
+we can't "look" at the tycons/classes yet.  Also, the checks are are rather
+diverse, and used to really mess up the other code.
 
 One thing we check for is 'rank'.  
 
@@ -537,7 +538,13 @@ One thing we check for is 'rank'.
        r1  ::= forall tvs. cxt => r0
        r0  ::= r0 -> r0 | basic
        
+Another thing is to check that type synonyms are saturated. 
+This might not necessarily show up in kind checking.
+       type A i = i
+       data T k = MkT (k Int)
+       f :: T A        -- BAD!
 
+       
 \begin{code}
 data UserTypeCtxt 
   = FunSigCtxt Name    -- Function type signature
@@ -930,11 +937,11 @@ check_inst_head dflags clas tys
   = check_tyvars dflags clas tys
 
        -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
-  | length tys == 1,
+  | isSingleton tys,
     Just (tycon, arg_tys) <- tcSplitTyConApp_maybe first_ty,
     not (isSynTyCon tycon),            -- ...but not a synonym
     all tcIsTyVarTy arg_tys,           -- Applied to type variables
-    length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
+    equalLength (varSetElems (tyVarsOfTypes arg_tys)) arg_tys
           -- This last condition checks that all the type variables are distinct
   = returnTc ()
 
@@ -1107,7 +1114,7 @@ uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2)
 
        -- Type constructors must match
 uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2)
-  | con1 == con2 && length tys1 == length tys2
+  | con1 == con2 && equalLength tys1 tys2
   = unifyTauTyLists tys1 tys2
 
   | con1 == openKindCon
@@ -1436,7 +1443,7 @@ unifyKindCtxt swapped tv1 ty2 tidy_env    -- not swapped => tv1 expected, ty2 infer
            where
              (pp_expected, pp_actual) | swapped   = (pp2, pp1)
                                       | otherwise = (pp1, pp2)
-             (env1, tv1') = tidyTyVar tidy_env tv1
+             (env1, tv1') = tidyOpenTyVar tidy_env tv1
              (env2, ty2') = tidyOpenType  env1 ty2
              pp1 = ppr tv1'
              pp2 = ppr ty2'
@@ -1457,13 +1464,13 @@ unifyWithSigErr tyvar ty
   = (env2, hang (ptext SLIT("Cannot unify the type-signature variable") <+> quotes (ppr tidy_tyvar))
              4 (ptext SLIT("with the type") <+> quotes (ppr tidy_ty)))
   where
-    (env1, tidy_tyvar) = tidyTyVar emptyTidyEnv tyvar
-    (env2, tidy_ty)    = tidyOpenType  env1     ty
+    (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar
+    (env2, tidy_ty)    = tidyOpenType  env1         ty
 
 unifyOccurCheck tyvar ty
   = (env2, hang (ptext SLIT("Occurs check: cannot construct the infinite type:"))
              4 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty]))
   where
-    (env1, tidy_tyvar) = tidyTyVar emptyTidyEnv tyvar
-    (env2, tidy_ty)    = tidyOpenType  env1     ty
+    (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar
+    (env2, tidy_ty)    = tidyOpenType  env1         ty
 \end{code}