-
- non_std_err = derivingThingErr clas tys tycon tyvars_to_keep
- (vcat [non_std_why clas,
- ptext SLIT("Try -fglasgow-exts for GHC's newtype-deriving extension")])
-
- bale_out err = addErrTc err `thenM_` returnM (Nothing, Nothing)
-
-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
- = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)
- -- The type passed to newDFunName is only used to generate
- -- a suitable string; hence the empty type arg list
-
-------------------------------------------------------------------
-mkDataTypeEqn :: SrcSpan -> InstOrigin -> TyCon -> Class -> TcM DerivEqn
-mkDataTypeEqn loc orig tycon clas
- | clas `hasKey` typeableClassKey
- = -- The Typeable class is special in several ways
- -- data T a b = ... deriving( Typeable )
- -- gives
- -- instance Typeable2 T where ...
- -- Notice that:
- -- 1. There are no constraints in the instance
- -- 2. There are no type variables either
- -- 3. The actual class we want to generate isn't necessarily
- -- Typeable; it depends on the arity of the type
- do { real_clas <- tcLookupClass (typeableClassNames !! tyConArity tycon)
- ; dfun_name <- new_dfun_name real_clas tycon
- ; return (loc, orig, dfun_name, real_clas, tycon, [], []) }
-
- | otherwise
- = do { dfun_name <- new_dfun_name clas tycon
- ; return (loc, orig, dfun_name, clas, tycon, tyvars, constraints) }
- where
- tyvars = tyConTyVars tycon
- constraints = extra_constraints ++ ordinary_constraints
- extra_constraints = tyConStupidTheta tycon
- -- "extra_constraints": see note [Data decl contexts] above
-
- ordinary_constraints
- = [ mkClassPred clas [arg_ty]
- | data_con <- tyConDataCons tycon,
- arg_ty <- dataConInstOrigArgTys data_con (map mkTyVarTy (tyConTyVars tycon)),
- not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
- ]
-
-
-------------------------------------------------------------------
--- Check side conditions that dis-allow derivability for particular classes
--- This is *apart* from the newtype-deriving mechanism
-
-checkSideConditions :: Bool -> TyCon -> [TyVar] -> Class -> [TcType] -> Maybe SDoc
-checkSideConditions gla_exts tycon deriv_tvs clas tys
- | notNull deriv_tvs || notNull tys
- = Just ty_args_why -- e.g. deriving( Foo s )
- | otherwise
- = case [cond | (key,cond) <- sideConditions, key == getUnique clas] of
- [] -> Just (non_std_why clas)
- [cond] -> cond (gla_exts, tycon)
- other -> pprPanic "checkSideConditions" (ppr clas)
- where
- ty_args_why = quotes (ppr (mkClassPred clas tys)) <+> ptext SLIT("is not a class")
-
-non_std_why clas = quotes (ppr clas) <+> ptext SLIT("is not a derivable class")
-
-sideConditions :: [(Unique, Condition)]
-sideConditions
- = [ (eqClassKey, cond_std),
- (ordClassKey, cond_std),
- (readClassKey, cond_std),
- (showClassKey, cond_std),
- (enumClassKey, cond_std `andCond` cond_isEnumeration),
- (ixClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
- (boundedClassKey, cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
- (typeableClassKey, cond_glaExts `andCond` cond_typeableOK),
- (dataClassKey, cond_glaExts `andCond` cond_std)
- ]
-
-type Condition = (Bool, TyCon) -> Maybe SDoc -- Nothing => OK
-
-orCond :: Condition -> Condition -> Condition
-orCond c1 c2 tc
- = case c1 tc of
- Nothing -> Nothing -- c1 succeeds
- Just x -> case c2 tc of -- c1 fails
- Nothing -> Nothing
- Just y -> Just (x $$ ptext SLIT(" and") $$ y)
- -- Both fail
-
-andCond c1 c2 tc = case c1 tc of
- Nothing -> c2 tc -- c1 succeeds
- Just x -> Just x -- c1 fails
-
-cond_std :: Condition
-cond_std (gla_exts, tycon)
- | any (not . isVanillaDataCon) data_cons = Just existential_why
- | null data_cons = Just no_cons_why
- | otherwise = Nothing
- where
- data_cons = tyConDataCons tycon
- no_cons_why = quotes (ppr tycon) <+> ptext SLIT("has no data constructors")
- existential_why = quotes (ppr tycon) <+> ptext SLIT("has non-Haskell-98 constructor(s)")
-
-cond_isEnumeration :: Condition
-cond_isEnumeration (gla_exts, tycon)
- | isEnumerationTyCon tycon = Nothing
- | otherwise = Just why
- where
- why = quotes (ppr tycon) <+> ptext SLIT("has non-nullary constructors")
-
-cond_isProduct :: Condition
-cond_isProduct (gla_exts, tycon)
- | isProductTyCon tycon = Nothing
- | otherwise = Just why
- where
- why = quotes (ppr tycon) <+> ptext SLIT("has more than one constructor")
-
-cond_typeableOK :: Condition
--- OK for Typeable class
--- Currently: (a) args all of kind *
--- (b) 7 or fewer args
-cond_typeableOK (gla_exts, tycon)
- | tyConArity tycon > 7 = Just too_many
- | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tycon)) = Just bad_kind
- | otherwise = Nothing
- where
- too_many = quotes (ppr tycon) <+> ptext SLIT("has too many arguments")
- bad_kind = quotes (ppr tycon) <+> ptext SLIT("has arguments of kind other than `*'")
-
-cond_glaExts :: Condition
-cond_glaExts (gla_exts, tycon) | gla_exts = Nothing
- | otherwise = Just why
- where
- why = ptext SLIT("You need -fglasgow-exts to derive an instance for this class")