[project @ 2002-06-21 13:31:50 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index da56ca9..80dbea9 100644 (file)
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -43,7 +43,7 @@ import RdrName                ( RdrName )
 
 import TyCon           ( tyConTyVars, tyConDataCons, tyConArity, newTyConRep,
                          tyConTheta, maybeTyConSingleCon, isDataTyCon,
-                         isEnumerationTyCon, TyCon
+                         isEnumerationTyCon, isRecursiveTyCon, TyCon
                        )
 import TcType          ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe,
                          isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, 
@@ -51,11 +51,10 @@ import TcType               ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_mayb
 import Var             ( TyVar, tyVarKind )
 import VarSet          ( mkVarSet, subVarSet )
 import PrelNames
-import Util            ( zipWithEqual, sortLt )
+import Util            ( zipWithEqual, sortLt, notNull )
 import ListSetOps      ( removeDups,  assoc )
 import Outputable
 import Maybe           ( isJust )
-import FastString      ( FastString )
 \end{code}
 
 %************************************************************************
@@ -178,6 +177,12 @@ context to the instance decl.  The "offending classes" are
 
        Read, Enum?
 
+FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
+pattern matching against a constructor from a data type with a context
+gives rise to the constraints for that context -- or at least the thinned
+version.  So now all classes are "offending".
+
+
 
 %************************************************************************
 %*                                                                     *
@@ -221,8 +226,11 @@ tcDeriving prs mod inst_env get_fixity tycl_decls
   where
     ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
     ddump_deriving inst_infos extra_binds
-      = vcat (map pprInstInfo inst_infos) $$ ppr extra_binds
+      = vcat (map ppr_info inst_infos) $$ ppr extra_binds
 
+    ppr_info inst_info = pprInstInfo inst_info $$ 
+                        nest 4 (ppr (iBinds inst_info))
+       -- pprInstInfo doesn't print much: only the type
 
 -----------------------------------------
 deriveOrdinaryStuff mod prs inst_env_in get_fixity []  -- Short cut
@@ -348,12 +356,12 @@ makeDerivEqns tycl_decls
                        not (isUnLiftedType arg_ty)     -- No constraints for unlifted types?
                      ]
 
-       
         -- "extra_constraints": see notes above about contexts on data decls
-       extra_constraints | offensive_class = tyConTheta tycon
-                         | otherwise       = []
-       
-       offensive_class = classKey clas `elem` needsDataDeclCtxtClassKeys
+       extra_constraints = tyConTheta tycon
+
+       --    | offensive_class = tyConTheta tycon
+       --    | otherwise           = []
+       -- offensive_class = classKey clas `elem` needsDataDeclCtxtClassKeys
 
 
     mk_eqn_help NewType tycon clas tys
@@ -418,6 +426,10 @@ makeDerivEqns tycl_decls
           && n_args_to_keep   >= 0             -- Well kinded: 
                                                -- eg not: newtype T a = T Int deriving( Monad )
           && eta_ok                            -- Eta reduction works
+          && not (isRecursiveTyCon tycon)      -- Does not work for recursive tycons:
+                                               --      newtype A = MkA [A]
+                                               -- Don't want
+                                               --      instance Eq [A] => Eq A !!
 
        -- Check that eta reduction is OK
        --      (a) the dropped-off args are identical
@@ -427,15 +439,14 @@ makeDerivEqns tycl_decls
              && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep) 
 
        cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
-                                          SLIT("too hard for cunning newtype deriving")
-
+                               (ptext SLIT("too hard for cunning newtype deriving"))
 
     bale_out err = addErrTc err `thenNF_Tc_` returnNF_Tc (Nothing, Nothing) 
 
     ------------------------------------------------------------------
-    chk_out :: Class -> TyCon -> [TcType] -> Maybe FastString
+    chk_out :: Class -> TyCon -> [TcType] -> Maybe SDoc
     chk_out clas tycon tys
-       | not (null tys)                                                = Just non_std_why
+       | notNull tys                                                   = Just non_std_why
        | not (getUnique clas `elem` derivableClassKeys)                = Just non_std_why
        | clas `hasKey` enumClassKey    && not is_enumeration           = Just nullary_why
        | clas `hasKey` boundedClassKey && not is_enumeration_or_single = Just single_nullary_why
@@ -449,11 +460,11 @@ makeDerivEqns tycl_decls
            is_single_con  = maybeToBool (maybeTyConSingleCon tycon)
            is_enumeration_or_single = is_enumeration || is_single_con
 
-    single_nullary_why = SLIT("one constructor data type or type with all nullary constructors expected")
-    nullary_why        = SLIT("data type with all nullary constructors expected")
-    no_cons_why               = SLIT("type has no data constructors")
-    non_std_why               = SLIT("not a derivable class")
-    existential_why    = SLIT("it has existentially-quantified constructor(s)")
+    single_nullary_why = ptext SLIT("one constructor data type or type with all nullary constructors expected")
+    nullary_why        = ptext SLIT("data type with all nullary constructors expected")
+    no_cons_why               = ptext SLIT("type has no data constructors")
+    non_std_why               = ptext SLIT("not a derivable class")
+    existential_why    = ptext SLIT("it has existentially-quantified constructor(s)")
 
 new_dfun_name clas tycon       -- Just a simple wrapper
   = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)
@@ -719,7 +730,7 @@ gen_taggery_Names dfuns
 \begin{code}
 derivingThingErr clas tys tycon tyvars why
   = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)],
-        parens (ptext why)]
+        parens why]
   where
     pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])