This BIG PATCH contains most of the work for the New Coercion Representation

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

diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 3676671..2721999 100644 (file)
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -41,6 +41,7 @@ import Name
 
 import HscTypes
 import PrelInfo
+import MkCore  ( eRROR_ID )
 import PrelNames
 import PrimOp
 import SrcLoc
@@ -49,7 +50,6 @@ import TcType
 import TysPrim
 import TysWiredIn
 import Type
-import Var( TyVar )
 import TypeRep
 import VarSet
 import State
@@ -167,7 +167,7 @@ gen_Eq_binds loc tycon
   where
     (nullary_cons, nonnullary_cons)
        | isNewTyCon tycon = ([], tyConDataCons tycon)
-       | otherwise           = partition isNullarySrcDataCon (tyConDataCons tycon)
+       | otherwise        = partition isNullarySrcDataCon (tyConDataCons tycon)
 
     no_nullary_cons = null nullary_cons
 
@@ -1456,11 +1456,13 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
             where (_, xc) = go co x
                   (yr,yc) = go co y
         go co ty@(TyConApp con args)
-               | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
-               | null args        = (caseTrivial,False)         -- T
-               | or (init xcs)    = (caseWrongArg,True)         -- T (..var..)    ty
-               | last xcs         =                     -- T (..no var..) ty
-                                   (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
+               | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur
+               -- At this point we know that xrs, xcs is not empty,
+               -- and at least one xr is True
+               | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs, True)
+               | or (init xcs)    = (caseWrongArg, True)   -- T (..var..)    ty
+               | otherwise        =                        -- T (..no var..) ty
+                                    (caseTyApp (fst (splitAppTy ty)) (last xrs), True)
             where (xrs,xcs) = unzip (map (go co) args)
         go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
             where (xr,xc) = go co x
@@ -1667,7 +1669,7 @@ genAuxBind loc (GenCon2Tag tycon)
     rdr_name = con2tag_RDR tycon
 
     sig_ty = HsCoreTy $ 
-             mkForAllTys (tyConTyVars tycon) $
+             mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
              mkParentType tycon `mkFunTy` intPrimTy
 
     lots_of_constructors = tyConFamilySize tycon > 8
@@ -1828,7 +1830,7 @@ assoc_ty_id cls_str _ tbl ty
                                              text "for primitive type" <+> ppr ty)
   | otherwise = head res
   where
-    res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
+    res = [id | (ty',id) <- tbl, ty `eqType` ty']
 
 -----------------------------------------------------------------------