[project @ 2004-01-23 13:55:28 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 85f0688..38567e6 100644 (file)
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -40,14 +40,14 @@ import RdrName              ( RdrName )
 import Name            ( Name, getSrcLoc )
 import NameSet         ( NameSet, emptyNameSet, duDefs )
 import Unique          ( Unique, getUnique )
-
+import Kind            ( splitKindFunTys )
 import TyCon           ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
                          tyConTheta, isProductTyCon, isDataTyCon,
                          isEnumerationTyCon, isRecursiveTyCon, TyCon
                        )
 import TcType          ( TcType, ThetaType, mkTyVarTy, mkTyVarTys, mkTyConApp, 
                          getClassPredTys_maybe, tcTyConAppTyCon,
-                         isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, isTypeKind,
+                         isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind,
                          tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy )
 import Var             ( TyVar, tyVarKind, idType, varName )
 import VarSet          ( mkVarSet, subVarSet )
@@ -358,13 +358,13 @@ makeDerivEqns tycl_decls
            ]
 
     mk_eqn_help gla_exts NewType tycon clas tys
-      | can_derive_via_isomorphism && (gla_exts || standard_class gla_exts clas)
+      | can_derive_via_isomorphism && (gla_exts || std_class_via_iso clas)
       =                -- Go ahead and use the isomorphism
           traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)     `thenM_`
                   new_dfun_name clas tycon             `thenM` \ dfun_name ->
           returnM (Nothing, Just (InstInfo { iDFunId = mk_dfun dfun_name,
                                              iBinds = NewTypeDerived rep_tys }))
-      | standard_class gla_exts clas
+      | std_class gla_exts clas
       = mk_eqn_help gla_exts DataType tycon clas tys   -- Go via bale-out route
 
       | otherwise                              -- Non-standard instance
@@ -391,7 +391,7 @@ makeDerivEqns tycl_decls
                -- Kind of the thing we want to instance
                --   e.g. argument kind of Monad, *->*
 
-       (arg_kinds, _) = tcSplitFunTys kind
+       (arg_kinds, _) = splitKindFunTys kind
        n_args_to_drop = length arg_kinds       
                -- Want to drop 1 arg from (T s a) and (ST s a)
                -- to get       instance Monad (ST s) => Monad (T s)
@@ -509,12 +509,18 @@ makeDerivEqns tycl_decls
                                       ptext SLIT("Try -fglasgow-exts for GHC's newtype-deriving extension")])
 
     bale_out err = addErrTc err `thenM_` returnM (Nothing, Nothing) 
-    standard_class gla_exts clas =  key `elem` derivableClassKeys
-                                || (gla_exts && (key == typeableClassKey || key == dataClassKey))
-       where
-         key = classKey clas
-
 
+std_class gla_exts clas 
+  =  key `elem` derivableClassKeys
+  || (gla_exts && (key == typeableClassKey || key == dataClassKey))
+  where
+     key = classKey clas
+    
+std_class_via_iso clas -- These standard classes can be derived for a newtype
+                       -- using the isomorphism trick *even if no -fglasgow-exts*
+  = classKey clas `elem`  [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
+       -- Not Read/Show because they respect the type
+       -- Not Enum, becuase newtypes are never in Enum
 
 
 new_dfun_name clas tycon       -- Just a simple wrapper
@@ -594,7 +600,7 @@ cond_isProduct (gla_exts, tycon)
 
 cond_allTypeKind :: Condition
 cond_allTypeKind (gla_exts, tycon)
-  | all (isTypeKind . tyVarKind) (tyConTyVars tycon) = Nothing
+  | all (isArgTypeKind . tyVarKind) (tyConTyVars tycon) = Nothing
   | otherwise                                       = Just why
   where
     why  = quotes (ppr tycon) <+> ptext SLIT("is parameterised over arguments of kind other than `*'")