X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=47b8c31f3c2900977f27614a7530793a7746cdb4;hp=1a9e054448fbecb95ec91eccf83a18165ed775c6;hb=215ce9f15215399ce30ae55c9521087847d78646;hpb=d95190caa3e09b33bca8544051043954ebd89c73 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 1a9e054..47b8c31 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -13,7 +13,6 @@ module TcTyClsDecls ( #include "HsVersions.h" import HsSyn -import HsTypes import HscTypes import BuildTyCl import TcUnify @@ -25,7 +24,6 @@ import TcHsType import TcMType import TcType import TysWiredIn ( unitTy ) -import FunDeps import Type import Generics import Class @@ -37,10 +35,8 @@ import IdInfo import Var import VarSet import Name -import OccName import Outputable import Maybes -import Monad import Unify import Util import SrcLoc @@ -52,8 +48,8 @@ import Unique ( mkBuiltinUnique ) import BasicTypes import Bag +import Control.Monad import Data.List -import Control.Monad ( mplus ) \end{code} @@ -253,8 +249,8 @@ tcFamInstDecl (L loc decl) = -- Prime error recovery, set source location setSrcSpan loc $ tcAddDeclCtxt decl $ - do { -- type families require -XTypeFamilies and can't be in an - -- hs-boot file + do { -- type family instances require -XTypeFamilies + -- and can't (currently) be in an hs-boot file ; type_families <- doptM Opt_TypeFamilies ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; checkTc type_families $ badFamInstDecl (tcdLName decl) @@ -272,11 +268,12 @@ tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> do { -- check that the family declaration is for a synonym - unless (isSynTyCon family) $ - addErr (wrongKindOfFamily family) + checkTc (isOpenTyCon family) (notFamily family) + ; checkTc (isSynTyCon family) (wrongKindOfFamily family) ; -- (1) kind check the right-hand side of the type equation - ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) resKind + ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) + -- ToDo: the ExpKind could be better -- we need the exact same number of type parameters as the family -- declaration @@ -293,7 +290,7 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) ; checkValidTypeInst t_typats t_rhs -- (4) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name loc + ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) (typeKind t_rhs) (Just (family, t_typats)) }} @@ -303,8 +300,8 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, tcdCons = cons}) = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon -> do { -- check that the family declaration is for the right kind - unless (isAlgTyCon fam_tycon) $ - addErr (wrongKindOfFamily fam_tycon) + checkTc (isOpenTyCon fam_tycon) (notFamily fam_tycon) + ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon) ; -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs @@ -337,7 +334,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, newtypeConError tc_name (length k_cons) -- (4) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name loc + ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc ; let ex_ok = True -- Existentials ok for type families! ; fixM (\ rep_tycon -> do { let orig_res_ty = mkTyConApp fam_tycon t_typats @@ -379,7 +376,8 @@ kcIdxTyPats :: TyClDecl Name -> TcM a kcIdxTyPats decl thing_inside = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { fam_tycon <- tcLookupLocatedTyCon (tcdLName decl) + do { let tc_name = tcdLName decl + ; fam_tycon <- tcLookupLocatedTyCon tc_name ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) ; hs_typats = fromJust $ tcdTyPats decl } @@ -389,10 +387,11 @@ kcIdxTyPats decl thing_inside -- type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- zipWithM kcCheckLHsType hs_typats kinds + ; typats <- zipWithM kcCheckLHsType hs_typats + [ EK kind (EkArg (ppr tc_name) n) + | (kind,n) <- kinds `zip` [1..]] ; thing_inside tvs typats resultKind fam_tycon } - where \end{code} @@ -482,7 +481,7 @@ getInitialKind decl ; res_kind <- mk_res_kind decl ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) } where - mk_arg_kind (UserTyVar _) = newKindVar + mk_arg_kind (UserTyVar _ _) = newKindVar mk_arg_kind (KindedTyVar _ kind) = return kind mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind @@ -514,7 +513,7 @@ kcSynDecl (AcyclicSCC (L loc decl)) <+> brackets (ppr k_tvs)) ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl) ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl))) - ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs + ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }), (unLoc (tcdLName decl), tc_kind)) }) @@ -522,10 +521,6 @@ kcSynDecl (CyclicSCC decls) = do { recSynErr decls; failM } -- Fail here to avoid error cascade -- of out-of-scope tycons -kindedTyVarKind :: LHsTyVarBndr Name -> Kind -kindedTyVarKind (L _ (KindedTyVar _ k)) = k -kindedTyVarKind x = pprPanic "kindedTyVarKind" (ppr x) - ------------------------------------------------------------------------ kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) -- Not used for type synonyms (see kcSynDecl) @@ -567,14 +562,16 @@ kcTyClDeclBody decl thing_inside = tcAddDeclCtxt decl $ do { tc_ty_thing <- tcLookupLocated (tcdLName decl) ; let tc_kind = case tc_ty_thing of - AThing k -> k - _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing) + AThing k -> k + _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing) (kinds, _) = splitKindFunTys tc_kind hs_tvs = tcdTyVars decl kinded_tvs = ASSERT( length kinds >= length hs_tvs ) - [ L loc (KindedTyVar (hsTyVarName tv) k) - | (L loc tv, k) <- zip hs_tvs kinds] - ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) } + zipWith add_kind hs_tvs kinds + ; tcExtendKindEnvTvs kinded_tvs thing_inside } + where + add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k) + add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k) -- Kind check a data declaration, assuming that we already extended the -- kind environment with the type variables of the left-hand side (these @@ -588,7 +585,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) ; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) } where -- doc comments are typechecked to Nothing here - kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) + kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs + , con_cxt = ex_ctxt, con_details = details, con_res = res }) = addErrCtxt (dataConCtxt name) $ kcHsTyVars ex_tvs $ \ex_tvs' -> do do { ex_ctxt' <- kcHsContext ex_ctxt @@ -596,7 +594,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) ; res' <- case res of ResTyH98 -> return ResTyH98 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') } - ; return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) } + ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt' + , con_details = details', con_res = res' }) } kc_con_details (PrefixCon btys) = do { btys' <- mapM kc_larg_ty btys @@ -632,11 +631,13 @@ kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) -- default result kind is '*' } where - unifyClassParmKinds (L _ (KindedTyVar n k)) - | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind - | otherwise = return () - unifyClassParmKinds x = pprPanic "kcFamilyDecl/unifyClassParmKinds" (ppr x) - classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs] + unifyClassParmKinds (L _ tv) + | (n,k) <- hsTyVarNameKind tv + , Just classParmKind <- lookup n classTyKinds + = unifyKind k classParmKind + | otherwise = return () + classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs] + kcFamilyDecl _ (TySynonym {}) -- type family defaults = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet" kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) @@ -689,9 +690,6 @@ tcTyClDecl1 _calc_isrec ; idx_tys <- doptM Opt_TypeFamilies ; checkTc idx_tys $ badFamInstDecl tc_name - -- Check for no type indices - ; checkTc (not (null tvs)) (noIndexTypes tc_name) - ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing ; return [ATyCon tycon] } @@ -710,9 +708,6 @@ tcTyClDecl1 _calc_isrec ; idx_tys <- doptM Opt_TypeFamilies ; checkTc idx_tys $ badFamInstDecl tc_name - -- Check for no type indices - ; checkTc (not (null tvs)) (noIndexTypes tc_name) - ; tycon <- buildAlgTyCon tc_name final_tvs [] mkOpenDataTyConRhs Recursive False True Nothing ; return [ATyCon tycon] @@ -827,7 +822,8 @@ tcConDecl :: Bool -- True <=> -funbox-strict_fields -> TcM DataCon tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types - (ConDecl name _ tvs ctxt details res_ty _) + (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt + , con_details = details, con_res = res_ty }) = addErrCtxt (dataConCtxt name) $ tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt @@ -929,11 +925,12 @@ consUseH98Syntax _ = True ------------------- tcConArg :: Bool -- True <=> -funbox-strict_fields -> LHsType Name - -> TcM (TcType, StrictnessMark) + -> TcM (TcType, HsBang) tcConArg unbox_strict bty = do { arg_ty <- tcHsBangType bty ; let bang = getBangStrictness bty - ; return (arg_ty, chooseBoxingStrategy unbox_strict arg_ty bang) } + ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang + ; return (arg_ty, strict_mark) } -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or @@ -941,27 +938,47 @@ tcConArg unbox_strict bty -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: Bool -> TcType -> HsBang -> StrictnessMark +chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang chooseBoxingStrategy unbox_strict_fields arg_ty bang = case bang of - HsNoBang -> NotMarkedStrict - HsStrict | unbox_strict_fields - && can_unbox arg_ty -> MarkedUnboxed - HsUnbox | can_unbox arg_ty -> MarkedUnboxed - _ -> MarkedStrict + HsNoBang -> HsNoBang + HsUnpack -> can_unbox HsUnpackFailed arg_ty + HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty + | otherwise -> HsStrict + HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) + -- Source code never has shtes where - -- we can unbox if the type is a chain of newtypes with a product tycon - -- at the end - can_unbox arg_ty = case splitTyConApp_maybe arg_ty of - Nothing -> False - Just (arg_tycon, tycon_args) -> - not (isRecursiveTyCon arg_tycon) && -- Note [Recusive unboxing] - isProductTyCon arg_tycon && - (if isNewTyCon arg_tycon then - can_unbox (newTyConInstRhs arg_tycon tycon_args) - else True) + can_unbox :: HsBang -> TcType -> HsBang + -- Returns HsUnpack if we can unpack arg_ty + -- fail_bang if we know what arg_ty is but we can't unpack it + -- HsStrict if it's abstract, so we don't know whether or not we can unbox it + can_unbox fail_bang arg_ty + = case splitTyConApp_maybe arg_ty of + Nothing -> fail_bang + + Just (arg_tycon, tycon_args) + | isAbstractTyCon arg_tycon -> HsStrict + -- See Note [Don't complain about UNPACK on abstract TyCons] + | not (isRecursiveTyCon arg_tycon) -- Note [Recusive unboxing] + , isProductTyCon arg_tycon + -- We can unbox if the type is a chain of newtypes + -- with a product tycon at the end + -> if isNewTyCon arg_tycon + then can_unbox fail_bang (newTyConInstRhs arg_tycon tycon_args) + else HsUnpack + + | otherwise -> fail_bang \end{code} +Note [Don't complain about UNPACK on abstract TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are going to complain about UnpackFailed, but if we say + data T = MkT {-# UNPACK #-} !Wobble +and Wobble is a newtype imported from a module that was compiled +without optimisation, we don't want to complain. Because it might +be fine when optimsation is on. I think this happens when Haddock +is working over (say) GHC souce files. + Note [Recursive unboxing] ~~~~~~~~~~~~~~~~~~~~~~~~~ Be careful not to try to unbox this! @@ -1096,7 +1113,8 @@ checkValidDataCon :: TyCon -> DataCon -> TcM () checkValidDataCon tc con = setSrcSpan (srcLocSpan (getSrcLoc con)) $ addErrCtxt (dataConCtxt con) $ - do { let tc_tvs = tyConTyVars tc + do { traceTc (ptext (sLit "Validity of data con") <+> ppr con) + ; let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) actual_res_ty = dataConOrigResTy con ; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs) @@ -1108,9 +1126,15 @@ checkValidDataCon tc con -- Reason: it's really the argument of an equality constraint ; checkValidType ctxt (dataConUserType con) ; when (isNewTyCon tc) (checkNewDataCon con) + ; mapM_ check_bang (dataConStrictMarks con `zip` [1..]) } where ctxt = ConArgCtxt (dataConName con) + check_bang (HsUnpackFailed, n) = addWarnTc (cant_unbox_msg n) + check_bang _ = return () + + cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the") + , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)] ------------------------------- checkNewDataCon :: DataCon -> TcM () @@ -1122,7 +1146,7 @@ checkNewDataCon con -- Return type is (T a b c) ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con) -- No existentials - ; checkTc (not (any isMarkedStrict (dataConStrictMarks con))) + ; checkTc (not (any isBanged (dataConStrictMarks con))) (newtypeStrictError con) -- No strictness } @@ -1172,7 +1196,7 @@ checkValidClass cls -- class Error e => Game b mv e | b -> mv e where -- newBoard :: MonadState b m => m () -- Here, MonadState has a fundep m->b, so newBoard is fine - ; let grown_tyvars = grow theta (mkVarSet tyvars) + ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars) ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars) (noClassTyVarErr cls sel_id) @@ -1205,6 +1229,9 @@ checkValidClass cls \begin{code} mkAuxBinds :: [TyThing] -> HsValBinds Name +-- NB We produce *un-typechecked* bindings, rather like 'deriving' +-- This makes life easier, because the later type checking will add +-- all necessary type abstractions and applications mkAuxBinds ty_things = ValBindsOut [(NonRecursive, b) | b <- binds] sigs where @@ -1213,57 +1240,63 @@ mkAuxBinds ty_things | ATyCon tc <- ty_things , fld <- tyConFields tc ] - mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) mkRecSelBind (tycon, sel_name) = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) where - loc = getSrcSpan tycon - sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo + loc = getSrcSpan tycon + sel_id = Var.mkLocalVar rec_details sel_name sel_ty vanillaIdInfo rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } -- Find a representative constructor, con1 - all_cons = tyConDataCons tycon + all_cons = tyConDataCons tycon cons_w_field = [ con | con <- all_cons , sel_name `elem` dataConFieldLabels con ] con1 = ASSERT( not (null cons_w_field) ) head cons_w_field -- Selector type; Note [Polymorphic selectors] - field_ty = dataConFieldType con1 sel_name - (field_tvs, field_theta, field_tau) - | is_naughty = ([], [], unitTy) - | otherwise = tcSplitSigmaTy field_ty + field_ty = dataConFieldType con1 sel_name data_ty = dataConOrigResTy con1 data_tvs = tyVarsOfType data_ty is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs) - sel_ty = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ - mkPhiTy (dataConStupidTheta con1) $ -- Urgh! - mkPhiTy field_theta $ -- Urgh! - mkFunTy data_ty field_tau + (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty + sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] + | otherwise = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ + mkPhiTy (dataConStupidTheta con1) $ -- Urgh! + mkPhiTy field_theta $ -- Urgh! + mkFunTy data_ty field_tau -- Make the binding: sel (C2 { fld = x }) = x -- sel (C7 { fld = x }) = x -- where cons_w_field = [C2,C7] - sel_bind = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt) + sel_bind | is_naughty = mkFunBind sel_lname [mkSimpleMatch [] unit_rhs] + | otherwise = mkFunBind sel_lname (map mk_match cons_w_field ++ deflt) mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] - (L loc match_body) + (L loc (HsVar field_var)) mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = HsRecField { hsRecFieldId = sel_lname , hsRecFieldArg = nlVarPat field_var , hsRecPun = False } - match_body | is_naughty = ExplicitTuple [] Boxed - | otherwise = HsVar field_var sel_lname = L loc sel_name field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc -- Add catch-all default case unless the case is exhaustive -- We do this explicitly so that we get a nice error message that -- mentions this particular record selector - deflt | length cons_w_field == length all_cons = [] + deflt | not (any is_unused all_cons) = [] | otherwise = [mkSimpleMatch [nlWildPat] (nlHsApp (nlHsVar (getName rEC_SEL_ERROR_ID)) (nlHsLit msg_lit))] + + -- Do not add a default case unless there are unmatched + -- constructors. We must take account of GADTs, else we + -- get overlap warning messages from the pattern-match checker + is_unused con = not (con `elem` cons_w_field + || dataConCannotMatch inst_tys con) + inst_tys = tyConAppArgs data_ty + + unit_rhs = mkLHsTupleExpr [] msg_lit = HsStringPrim $ mkFastString $ occNameString (getOccName sel_name) @@ -1297,11 +1330,16 @@ so that if the user tries to use 'x' as a selector we can bleat helpfully, rather than saying unhelpfully that 'x' is not in scope. Hence the sel_naughty flag, to identify record selectors that don't really exist. -In general, a field is naughty if its type mentions a type variable that -isn't in the result type of the constructor. +In general, a field is "naughty" if its type mentions a type variable that +isn't in the result type of the constructor. Note that this *allows* +GADT record selectors (Note [GADT record selectors]) whose types may look +like sel :: T [a] -> a -We make a dummy binding for naughty selectors, so that they can be treated -uniformly, apart from their sel_naughty field. The function is never called. +For naughty selectors we make a dummy binding + sel = () +for naughty selectors, so that the later type-check will add them to the +environment, and they'll be exported. The function is never called, because +the tyepchecker spots the sel_naughty field. Note [GADT record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1487,11 +1525,6 @@ badSigTyDecl tc_name quotes (ppr tc_name) , nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ] -noIndexTypes :: Name -> SDoc -noIndexTypes tc_name - = ptext (sLit "Type family constructor") <+> quotes (ppr tc_name) - <+> ptext (sLit "must have at least one type index parameter") - badFamInstDecl :: Outputable a => a -> SDoc badFamInstDecl tc_name = vcat [ ptext (sLit "Illegal family instance for") <+> @@ -1514,13 +1547,18 @@ wrongNumberOfParmsErr exp_arity <+> ppr exp_arity badBootFamInstDeclErr :: SDoc -badBootFamInstDeclErr = - ptext (sLit "Illegal family instance in hs-boot file") - +badBootFamInstDeclErr + = ptext (sLit "Illegal family instance in hs-boot file") + +notFamily :: TyCon -> SDoc +notFamily tycon + = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] + wrongKindOfFamily :: TyCon -> SDoc -wrongKindOfFamily family = - ptext (sLit "Wrong category of family instance; declaration was for a") <+> - kindOfFamily +wrongKindOfFamily family + = ptext (sLit "Wrong category of family instance; declaration was for a") + <+> kindOfFamily where kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") | isAlgTyCon family = ptext (sLit "data type")