import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifySuperClasses )
import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy,
- splitFunTys, TyThing )
+ splitFunTys, TyThing(ATyCon) )
import Coercion ( mkSymCoercion )
-import TyCon ( TyCon, newTyConCo, tyConTyVars )
+import TyCon ( TyCon, tyConName, newTyConCo, tyConTyVars,
+ isAssocTyCon, tyConFamInst_maybe )
import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys )
import Class ( classBigSig )
import Var ( TyVar, Id, idName, idType, tyVarKind )
import UniqSupply ( uniqsFromSupply, splitUniqSupply )
import MkId ( mkDictFunId )
import Name ( Name, getSrcLoc )
-import Maybe ( catMaybes )
+import Maybe ( isNothing, fromJust, catMaybes )
+import Monad ( when )
import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
import ListSetOps ( minusList )
import Outputable
-- (1) Do the ordinary instance declarations and instances of
-- indexed types
; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
- ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
- ; idxty_info_tycons <- mappM tcIdxTyInstDecl idxty_decls
+ ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
+ ; idxty_info_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
; let { (local_infos,
local_tycons) = unzip local_info_tycons
generic_inst_info ++ deriv_inst_info ++ local_idxty_info,
deriv_binds)
}}}}}
+ where
+ -- Make sure that toplevel type instance are not for associated types.
+ -- !!!TODO: Need to perform this check for the InstInfo structures of type
+ -- functions, too.
+ tcIdxTyInstDeclTL ldecl@(L loc decl) =
+ do { (info, tything) <- tcIdxTyInstDecl ldecl
+ ; setSrcSpan loc $
+ when (isAssocFamily tything) $
+ addErr $ assocInClassErr (tcdName decl)
+ ; return (info, tything)
+ }
+ isAssocFamily (Just (ATyCon tycon)) =
+ case tyConFamInst_maybe tycon of
+ Nothing -> panic "isAssocFamily: no family?!?"
+ Just (fam, _) -> isAssocTyCon fam
+ isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?"
+ isAssocFamily Nothing = False
+
+assocInClassErr name =
+ ptext SLIT("Associated type must be inside class instance") <+>
+ quotes (ppr name)
addInsts :: [InstInfo] -> TcM a -> TcM a
addInsts infos thing_inside
tyConDataCons, mkForeignTyCon, isProductTyCon,
isRecursiveTyCon, isOpenTyCon,
tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName,
- isNewTyCon, tyConKind )
+ isNewTyCon, tyConKind, makeTyConAssoc, isAssocTyCon )
import DataCon ( DataCon, dataConUserType, dataConName,
dataConFieldLabels, dataConTyCon, dataConAllTyVars,
dataConFieldType, dataConResTys )
-- Check that we don't use kind signatures without Glasgow extensions
; checkTc gla_exts $ badSigTyDecl tc_name
- ; return [ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))]
+ ; return [ATyCon $ buildSynTyCon tc_name tvs' (OpenSynTyCon kind)]
}
-- kind signature for an indexed data type
{ ctxt' <- tcHsKindedContext ctxt
; fds' <- mappM (addLocM tc_fundep) fundeps
; atss <- mappM (addLocM (tcTyClDecl1 (const Recursive))) ats
- ; let ats' = concat atss
+ ; let ats' = map makeTyThingAssoc . concat $ atss
; sig_stuff <- tcClassSigs class_name sigs meths
; clas <- fixM (\ clas ->
let -- This little knot is just so we can get
tc_fundep (tvs1, tvs2) = do { tvs1' <- mappM tcLookupTyVar tvs1 ;
; tvs2' <- mappM tcLookupTyVar tvs2 ;
; return (tvs1', tvs2') }
+ makeTyThingAssoc (ATyCon tycon) = ATyCon (makeTyConAssoc tycon)
+ makeTyThingAssoc _ = panic "makeTyThingAssoc"
tcTyClDecl1 calc_isrec
isFunTyCon, isUnLiftedTyCon, isProductTyCon,
isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
- isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
+ isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isAssocTyCon,
+ makeTyConAssoc,
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
isHiBootTyCon, isSuperKindTyCon,
tyConName :: Name,
tyConKind :: Kind,
tyConArity :: Arity,
-
+
tyConTyVars :: [TyVar], -- Scopes over (a) the algTcStupidTheta
-- (b) the cached types in
-- algTyConRhs.NewTyCon
-- But not over the data constructors
+
+ tyConIsAssoc :: Bool, -- for families: declared in a class?
+
algTcSelIds :: [Id], -- Its record selectors (empty if none)
algTcGadtSyntax :: Bool, -- True <=> the data type was declared using GADT syntax
}
| SynTyCon {
- tyConUnique :: Unique,
- tyConName :: Name,
- tyConKind :: Kind,
- tyConArity :: Arity,
-
- tyConTyVars :: [TyVar], -- Bound tyvars
- synTcRhs :: SynTyConRhs -- Expanded type in here
+ tyConUnique :: Unique,
+ tyConName :: Name,
+ tyConKind :: Kind,
+ tyConArity :: Arity,
+
+ tyConTyVars :: [TyVar], -- Bound tyvars
+ tyConIsAssoc :: Bool, -- for families: declared in a class?
+ synTcRhs :: SynTyConRhs -- Expanded type in here
}
| PrimTyCon { -- Primitive types; cannot be defined in Haskell
tyConKind = kind,
tyConArity = length tyvars,
tyConTyVars = tyvars,
+ tyConIsAssoc = False,
algTcStupidTheta = stupid,
algTcRhs = rhs,
algTcSelIds = sel_ids,
tyConKind = kind,
tyConArity = length tyvars,
tyConTyVars = tyvars,
+ tyConIsAssoc = False,
synTcRhs = rhs
}
isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon }) = True
isOpenTyCon _ = False
+isAssocTyCon :: TyCon -> Bool
+isAssocTyCon (AlgTyCon { tyConIsAssoc = isAssoc }) = isAssoc
+isAssocTyCon (SynTyCon { tyConIsAssoc = isAssoc }) = isAssoc
+isAssocTyCon _ = False
+
+makeTyConAssoc :: TyCon -> TyCon
+makeTyConAssoc tc@(AlgTyCon {}) = tc { tyConIsAssoc = True }
+makeTyConAssoc tc@(SynTyCon {}) = tc { tyConIsAssoc = True }
+makeTyConAssoc tc = pprPanic "makeTyConAssoc" (ppr tc)
+
isTupleTyCon :: TyCon -> Bool
-- The unit tycon didn't used to be classed as a tuple tycon
-- but I thought that was silly so I've undone it