Improve error reporting for kind errors (fix Trac #1633)

[ghc-hetmet.git] / compiler / types / Type.lhs

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 79a561a..3705914 100644 (file)
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -41,10 +41,10 @@ module Type (
        applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
        
        -- (Newtypes)
-       newTyConInstRhs,
+       newTyConInstRhs, carefullySplitNewType_maybe,
        
        -- (Type families)
-        tyFamInsts,
+        tyFamInsts, predFamInsts,
 
         -- (Source types)
         mkPredTy, mkPredTys, mkFamilyTyConApp,
@@ -534,7 +534,7 @@ splitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 splitTyConApp_maybe _                 = Nothing
 
 newTyConInstRhs :: TyCon -> [Type] -> Type
--- ^ Unwrap one 'layer' of newtype on a type constructor and it's arguments, using an 
+-- ^ Unwrap one 'layer' of newtype on a type constructor and its arguments, using an 
 -- eta-reduced version of the @newtype@ if possible
 newTyConInstRhs tycon tys 
     = ASSERT2( equalLength tvs tys1, ppr tycon $$ ppr tys $$ ppr tvs )
@@ -596,14 +596,9 @@ newtype at outermost level; and bale out if we see it again.
 -- | Looks through:
 --
 --     1. For-alls
---
 --     2. Synonyms
---
 --     3. Predicates
---
---     4. Usage annotations
---
---     5. All newtypes, including recursive ones, but not newtype families
+--     4. All newtypes, including recursive ones, but not newtype families
 --
 -- It's useful in the back end of the compiler.
 repType :: Type -> Type
@@ -618,19 +613,25 @@ repType ty
     go rec_nts (ForAllTy _ ty)                 -- Look through foralls
        = go rec_nts ty
 
-    go rec_nts ty@(TyConApp tc tys)            -- Expand newtypes
-       | Just _co_con <- newTyConCo_maybe tc   -- See Note [Expanding newtypes]
-       = if tc `elem` rec_nts                  --  in Type.lhs
-         then ty
-         else go rec_nts' nt_rhs
-       where
-         nt_rhs = newTyConInstRhs tc tys
-         rec_nts' | isRecursiveTyCon tc = tc:rec_nts
-                  | otherwise           = rec_nts
+    go rec_nts (TyConApp tc tys)               -- Expand newtypes
+      | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys
+      = go rec_nts' ty'
 
     go _ ty = ty
 
 
+carefullySplitNewType_maybe :: [TyCon] -> TyCon -> [Type] -> Maybe ([TyCon],Type)
+-- Return the representation of a newtype, unless 
+-- we've seen it already: see Note [Expanding newtypes]
+carefullySplitNewType_maybe rec_nts tc tys
+  | isNewTyCon tc
+  , not (tc `elem` rec_nts)  = Just (rec_nts', newTyConInstRhs tc tys)
+  | otherwise               = Nothing
+  where
+    rec_nts' | isRecursiveTyCon tc = tc:rec_nts
+            | otherwise           = rec_nts
+
+
 -- ToDo: this could be moved to the code generator, using splitTyConApp instead
 -- of inspecting the type directly.
 
@@ -739,8 +740,8 @@ applyTysD doc orig_fun_ty arg_tys
                (mkForAllTys (drop n_args tvs) rho_ty)
   | otherwise          -- Too many type args
   = ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty )       -- Zero case gives infnite loop!
-    applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
-            (drop n_tvs arg_tys)
+    applyTysD doc (substTyWith tvs (take n_tvs arg_tys) rho_ty)
+                 (drop n_tvs arg_tys)
   where
     (tvs, rho_ty) = splitForAllTys orig_fun_ty 
     n_tvs = length tvs
@@ -887,6 +888,14 @@ tyFamInsts (TyConApp tc tys)
 tyFamInsts (FunTy ty1 ty2)      = tyFamInsts ty1 ++ tyFamInsts ty2
 tyFamInsts (AppTy ty1 ty2)      = tyFamInsts ty1 ++ tyFamInsts ty2
 tyFamInsts (ForAllTy _ ty)      = tyFamInsts ty
+tyFamInsts (PredTy pty)         = predFamInsts pty
+
+-- | Finds type family instances occuring in a predicate type after expanding 
+-- synonyms.
+predFamInsts :: PredType -> [(TyCon, [Type])]
+predFamInsts (ClassP _cla tys) = concat (map tyFamInsts tys)
+predFamInsts (IParam _ ty)     = tyFamInsts ty
+predFamInsts (EqPred ty1 ty2)  = tyFamInsts ty1 ++ tyFamInsts ty2
 \end{code}
 
 
@@ -1147,14 +1156,16 @@ coreEqType t1 t2
 
 \begin{code}
 tcEqType :: Type -> Type -> Bool
--- ^ Type equality on source types. Does not look through @newtypes@ or 'PredType's
+-- ^ Type equality on source types. Does not look through @newtypes@ or 
+-- 'PredType's, but it does look through type synonyms.
 tcEqType t1 t2 = isEqual $ cmpType t1 t2
 
 tcEqTypes :: [Type] -> [Type] -> Bool
 tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2
 
 tcCmpType :: Type -> Type -> Ordering
--- ^ Type ordering on source types. Does not look through @newtypes@ or 'PredType's
+-- ^ Type ordering on source types. Does not look through @newtypes@ or 
+-- 'PredType's, but it does look through type synonyms.
 tcCmpType t1 t2 = cmpType t1 t2
 
 tcCmpTypes :: [Type] -> [Type] -> Ordering