collectLocatedMonoBinders )
import RdrHsSyn ( RdrNameMonoBinds )
import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl, RenamedHsPred )
-import CmdLineOpts ( DynFlag(..), DynFlags )
+import CmdLineOpts ( DynFlag(..) )
import TcMonad
import TcEnv ( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo,
- tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
+ tcLookupTyCon, tcExtendTyVarEnv
)
import TcGenDeriv -- Deriv stuff
import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
import RnEnv ( bindLocatedLocalsRn )
import RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn )
-import HscTypes ( DFunId, PersistentRenamerState )
+import HscTypes ( DFunId, PersistentRenamerState, FixityEnv )
-import BasicTypes ( Fixity, NewOrData(..) )
+import BasicTypes ( NewOrData(..) )
import Class ( className, classKey, classTyVars, Class )
-import ErrUtils ( dumpIfSet_dyn, Message )
+import ErrUtils ( dumpIfSet_dyn )
import MkId ( mkDictFunId )
import DataCon ( dataConRepArgTys, isNullaryDataCon, isExistentialDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
)
import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe,
isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys,
- tcSplitTyConApp_maybe, tcEqTypes, tyVarsOfTheta )
+ tcSplitTyConApp_maybe, tcEqTypes )
import Var ( TyVar, tyVarKind )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
-import Util ( zipWithEqual, sortLt, eqListBy )
+import Util ( zipWithEqual, sortLt, notNull )
import ListSetOps ( removeDups, assoc )
import Outputable
import Maybe ( isJust )
-import List ( nub )
-import FastString ( FastString )
\end{code}
%************************************************************************
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".
+
+
%************************************************************************
%* *
tcDeriving :: PersistentRenamerState
-> Module -- name of module under scrutiny
-> InstEnv -- What we already know about instances
- -> (Name -> Maybe Fixity) -- used in deriving Show and Read
+ -> FixityEnv -- used in deriving Show and Read
-> [RenamedTyClDecl] -- All type constructors
-> TcM ([InstInfo], -- The generated "instance decls".
RenamedHsBinds) -- Extra generated bindings
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
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
&& (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
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)
-- Generate the method bindings for the required instance
-- (paired with class name, as we need that when renaming
-- the method binds)
-gen_bind :: (Name -> Maybe Fixity) -> DFunId -> (Name, RdrNameMonoBinds)
+gen_bind :: FixityEnv -> DFunId -> (Name, RdrNameMonoBinds)
gen_bind get_fixity dfun
= (cls_nm, binds)
where
\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)])
projects / ghc-hetmet.git / blobdiff