import InstEnv ( mkLocalInstance, instanceDFunId )
import TcDeriv ( tcDeriving )
import TcEnv ( InstInfo(..), InstBindings(..),
- newDFunName, tcExtendIdEnv
+ newDFunName, tcExtendIdEnv, tcExtendGlobalEnv
)
import TcHsType ( kcHsSigType, tcHsKindedType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifySuperClasses )
import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy,
- splitFunTys )
+ 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
import Bag
import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) )
+import HscTypes ( implicitTyThings )
import FastString
\end{code}
-- (1) Do the ordinary instance declarations and instances of
-- indexed types
; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
- ; local_inst_infos <- mappM tcLocalInstDecl1 inst_decls
- ; idxty_inst_infos <- mappM tcIdxTyInstDecl idxty_decls
-
- ; let { local_inst_info = concat local_inst_infos ++
- catMaybes idxty_inst_infos
- ; clas_decls = filter (isClassDecl.unLoc) tycl_decls }
-
- -- (2) Instances from generic class declarations
+ ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
+ ; idxty_info_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
+
+ ; let { (local_infos,
+ local_tycons) = unzip local_info_tycons
+ ; (idxty_infos,
+ idxty_tycons) = unzip idxty_info_tycons
+ ; local_idxty_info = concat local_infos ++ catMaybes idxty_infos
+ ; local_idxty_tycon = concat local_tycons ++
+ catMaybes idxty_tycons
+ ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
+ ; implicit_things = concatMap implicitTyThings local_idxty_tycon
+ }
+
+ -- (2) Add the tycons of associated types and their implicit
+ -- tythings to the global environment
+ ; tcExtendGlobalEnv (local_idxty_tycon ++ implicit_things) $ do {
+
+ -- (3) Instances from generic class declarations
; generic_inst_info <- getGenericInstances clas_decls
-- Next, construct the instance environment so far, consisting
-- of
-- a) local instance decls
-- b) generic instances
- ; addInsts local_inst_info $ do {
+ ; addInsts local_idxty_info $ do {
; addInsts generic_inst_info $ do {
- -- (3) Compute instances from "deriving" clauses;
+ -- (4) Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
-- decl, so it needs to know about all the instances possible
; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls
; gbl_env <- getGblEnv
; returnM (gbl_env,
- generic_inst_info ++ deriv_inst_info ++ local_inst_info,
+ 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
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
- -> TcM [InstInfo] -- [] if there was an error
+ -> TcM ([InstInfo], [TyThing]) -- [] if there was an error
-- A source-file instance declaration
-- Type-check all the stuff before the "where"
--
-- We check for respectable instance type, and context
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
= -- Prime error recovery, set source location
- recoverM (returnM []) $
+ recoverM (returnM ([], [])) $
setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
; checkValidInstance tyvars theta clas inst_tys
-- Next, process any associated types.
- ; idxty_inst_info <- mappM tcIdxTyInstDecl ats
+ ; idxty_info_tycons <- mappM tcIdxTyInstDecl ats
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
; overlap_flag <- getOverlapFlag
- ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
- ispec = mkLocalInstance dfun overlap_flag
-
- ; return $ [InstInfo { iSpec = ispec,
- iBinds = VanillaInst binds uprags }] ++
- catMaybes idxty_inst_info }
+ ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
+ ispec = mkLocalInstance dfun overlap_flag
+ (idxty_infos,
+ idxty_tycons) = unzip idxty_info_tycons
+
+ ; return ([InstInfo { iSpec = ispec,
+ iBinds = VanillaInst binds uprags }] ++
+ catMaybes idxty_infos,
+ catMaybes idxty_tycons)
+ }
\end{code}
projects / ghc-hetmet.git / blobdiff