newtype fixes, coercions for non-recursive newtypes now optional

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

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 65c425d..fdf78cf 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -39,14 +39,15 @@ import Maybes               ( catMaybes )
 import RdrName         ( RdrName )
 import Name            ( Name, getSrcLoc )
 import NameSet         ( duDefs )
-import Kind            ( splitKindFunTys )
+import Type            ( splitKindFunTys )
 import TyCon           ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
                          tyConStupidTheta, isProductTyCon, isDataTyCon, newTyConRhs,
-                         isEnumerationTyCon, isRecursiveTyCon, TyCon
+                         isEnumerationTyCon, isRecursiveTyCon, TyCon, isNewTyCon,
+                          newTyConCo
                        )
 import TcType          ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon,
                          isUnLiftedType, mkClassPred, tyVarsOfType,
-                         isArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
+                         isSubArgTypeKind, tcEqTypes, tcSplitAppTys, mkAppTys )
 import Var             ( TyVar, tyVarKind, varName )
 import VarSet          ( mkVarSet, subVarSet )
 import PrelNames
@@ -350,6 +351,10 @@ makeDerivEqns overlap_flag tycl_decls
         mk_eqn_help gla_exts new_or_data tycon deriv_tvs clas tys
 
     ------------------------------------------------------------------
+    -- data/newtype T a = ... deriving( C t1 t2 )
+    --   leads to a call to mk_eqn_help with
+    --         tycon = T, deriv_tvs = ftv(t1,t2), clas = C, tys = [t1,t2]
+
     mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys
       | Just err <- checkSideConditions gla_exts tycon deriv_tvs clas tys
       = bale_out (derivingThingErr clas tys tycon (tyConTyVars tycon) err)
@@ -363,7 +368,7 @@ makeDerivEqns overlap_flag tycl_decls
           traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)     `thenM_`
                   new_dfun_name clas tycon             `thenM` \ dfun_name ->
           returnM (Nothing, Just (InstInfo { iSpec  = mk_inst_spec dfun_name,
-                                             iBinds = NewTypeDerived rep_tys }))
+                                             iBinds = NewTypeDerived (newTyConCo tycon) rep_tys }))
       | std_class gla_exts clas
       = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route
 
@@ -434,7 +439,7 @@ makeDerivEqns overlap_flag tycl_decls
                -- We must pass the superclasses; the newtype might be an instance
                -- of them in a different way than the representation type
                -- E.g.         newtype Foo a = Foo a deriving( Show, Num, Eq )
-               -- Then the Show instance is not done via isomprphism; it shows
+               -- Then the Show instance is not done via isomorphism; it shows
                --      Foo 3 as "Foo 3"
                -- The Num instance is derived via isomorphism, but the Show superclass
                -- dictionary must the Show instance for Foo, *not* the Show dictionary
@@ -649,7 +654,7 @@ cond_typeableOK :: Condition
 --           (b) 7 or fewer args
 cond_typeableOK (gla_exts, tycon)
   | tyConArity tycon > 7                                     = Just too_many
-  | not (all (isArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
+  | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
   | otherwise                                                = Nothing
   where
     too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments")