TcInstDecls: Typechecking instance declarations
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
import HsSyn
import DataCon
import Class
import Var
+import Id
import MkId
import Name
import NameSet
\item
$alpha$ is the class variable
\item
-$LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$
+$LIE_cop' = LIE_cop [X gammas_bar \/ alpha, fresh betas_bar]$
\item
-$tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$
+$tau_cop' = tau_cop [X gammas_bar \/ alpha, fresh betas_bar]$
\end{enumerate}
ToDo: Update the list above with names actually in the code.
\begin{enumerate}
\item
First, make the LIEs for the class and instance contexts, which means
-instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC',
+instantiate $thetaC [X inst_tyvars \/ alpha ]$, yielding LIElistC' and LIEC',
and make LIElistI and LIEI.
\item
Then process each method in turn.
-> [LInstDecl Name] -- Source code instance decls
-> [LDerivDecl Name] -- Source code stand-alone deriving decls
-> TcM (TcGblEnv, -- The full inst env
- [InstInfo], -- Source-code instance decls to process;
+ [InstInfo Name], -- Source-code instance decls to process;
-- contains all dfuns for this module
HsValBinds Name) -- Supporting bindings for derived instances
-- (1) Do class and family instance declarations
; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
- ; local_info_tycons <- mapM tcLocalInstDecl1 inst_decls
- ; idx_tycons <- mapM tcIdxTyInstDeclTL idxty_decls
+ ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
+ ; idx_tycons <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls
- ; let { (local_infos,
- at_tycons) = unzip local_info_tycons
- ; local_info = concat local_infos
- ; at_idx_tycon = concat at_tycons ++ catMaybes idx_tycons
+ ; let { (local_info,
+ at_tycons_s) = unzip local_info_tycons
+ ; at_idx_tycon = concat at_tycons_s ++ idx_tycons
; clas_decls = filter (isClassDecl.unLoc) tycl_decls
; implicit_things = concatMap implicitTyThings at_idx_tycon
}
-- decl, so it needs to know about all the instances possible
-- NB: class instance declarations can contain derivings as
-- part of associated data type declarations
+ failIfErrsM -- If the addInsts stuff gave any errors, don't
+ -- try the deriving stuff, becuase that may give
+ -- more errors still
; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls
deriv_decls
; addInsts deriv_inst_info $ do {
addErr $ assocInClassErr (tcdName decl)
; return tything
}
- isAssocFamily (Just (ATyCon tycon)) =
+ isAssocFamily (ATyCon tycon) =
case tyConFamInst_maybe tycon of
Nothing -> panic "isAssocFamily: no family?!?"
Just (fam, _) -> isTyConAssoc fam
- isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?"
- isAssocFamily Nothing = False
+ isAssocFamily _ = panic "isAssocFamily: no tycon?!?"
+assocInClassErr :: Name -> SDoc
assocInClassErr name =
ptext (sLit "Associated type") <+> quotes (ppr name) <+>
ptext (sLit "must be inside a class instance")
-addInsts :: [InstInfo] -> TcM a -> TcM a
+addInsts :: [InstInfo Name] -> TcM a -> TcM a
addInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
- -> TcM ([InstInfo], [TyThing]) -- [] if there was an error
+ -> TcM (InstInfo Name, [TyThing])
-- 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 (return ([], [])) $
- setSrcSpan loc $
+tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
+ = setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
do { is_boot <- tcIsHsBoot
; (tyvars, theta, tau) <- tcHsInstHead poly_ty
- -- Next, process any associated types.
- ; idx_tycons <- mapM tcFamInstDecl ats
-
-- Now, check the validity of the instance.
; (clas, inst_tys) <- checkValidInstHead tau
; checkValidInstance tyvars theta clas inst_tys
- ; checkValidAndMissingATs clas (tyvars, inst_tys)
- (zip ats idx_tycons)
+
+ -- Next, process any associated types.
+ ; idx_tycons <- recoverM (return []) $
+ do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats
+ ; checkValidAndMissingATs clas (tyvars, inst_tys)
+ (zip ats idx_tycons)
+ ; return idx_tycons }
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
- ; dfun_name <- newDFunName clas inst_tys loc
+ ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
+ -- Dfun location is that of instance *header*
; overlap_flag <- getOverlapFlag
; let (eq_theta,dict_theta) = partition isEqPred theta
theta' = eq_theta ++ dict_theta
dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
ispec = mkLocalInstance dfun overlap_flag
- ; return ([InstInfo { iSpec = ispec,
- iBinds = VanillaInst binds uprags }],
- catMaybes idx_tycons)
+ ; return (InstInfo { iSpec = ispec,
+ iBinds = VanillaInst binds uprags },
+ idx_tycons)
}
where
-- We pass in the source form and the type checked form of the ATs. We
checkValidAndMissingATs :: Class
-> ([TyVar], [TcType]) -- instance types
-> [(LTyClDecl Name, -- source form of AT
- Maybe TyThing)] -- Core form of AT
+ TyThing)] -- Core form of AT
-> TcM ()
checkValidAndMissingATs clas inst_tys ats
= do { -- Issue a warning for each class AT that is not defined in this
; mapM_ (checkIndexes clas inst_tys) ats
}
- checkIndexes _ _ (hsAT, Nothing) =
- return () -- skip, we already had an error here
- checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) =
+ checkIndexes clas inst_tys (hsAT, ATyCon tycon) =
-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
checkIndexes' clas inst_tys hsAT
(tyConTyVars tycon,
%************************************************************************
\begin{code}
-tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo]
+tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
-> TcM (LHsBinds Id, TcLclEnv)
-- (a) From each class declaration,
-- generate any default-method bindings
\begin{code}
-tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
+tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
-- Returns a binding for the dfun
------------------------
-- inst_head_ty is a PredType
; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
- (class_tyvars, sc_theta, _, op_items) = classBigSig cls
+ (class_tyvars, sc_theta, _, _) = classBigSig cls
cls_tycon = classTyCon cls
sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
dfun_id = instanceDFunId ispec
rigid_info = InstSkol
inst_ty = idType dfun_id
- loc = srcLocSpan (getSrcLoc dfun_id)
+ loc = getSrcSpan dfun_id
in
-- Prime error recovery
recoverM (return emptyLHsBinds) $
eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars"
+tcMethods :: InstOrigin -> Class -> [TcTyVar] -> TcThetaType -> [TcType]
+ -> Inst -> [Inst] -> [(Id, DefMeth)] -> LHsBindsLR Name Name
+ -> [LSig Name]
+ -> TcM ([Id], Bag (LHsBind Id))
tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
this_dict extra_insts op_items monobinds uprags = do
-- Check that all the method bindings come from this class
let
prag_fn = mkPragFun uprags
all_insts = extra_insts ++ catMaybes meth_insts
- sig_fn n = Just [] -- No scoped type variables, but every method has
+ sig_fn _ = Just [] -- No scoped type variables, but every method has
-- a type signature, in effect, so that we check
-- the method has the right type
tc_method_bind = tcMethodBind origin inst_tyvars' dfun_theta' this_dict
%************************************************************************
\begin{code}
+instDeclCtxt1 :: LHsType Name -> SDoc
instDeclCtxt1 hs_inst_ty
= inst_decl_ctxt (case unLoc hs_inst_ty of
HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
HsPredTy pred -> ppr pred
- other -> ppr hs_inst_ty) -- Don't expect this
+ _ -> ppr hs_inst_ty) -- Don't expect this
+instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 dfun_ty
= inst_decl_ctxt (ppr (mkClassPred cls tys))
where
(_,_,cls,tys) = tcSplitDFunTy dfun_ty
+inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
+superClassCtxt :: SDoc
superClassCtxt = ptext (sLit "When checking the super-classes of an instance declaration")
+atInstCtxt :: Name -> SDoc
atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
quotes (ppr name)
+mustBeVarArgErr :: Type -> SDoc
mustBeVarArgErr ty =
sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
ptext (sLit "must be variables")
, ptext (sLit "Instead of a variable, found") <+> ppr ty
]
+wrongATArgErr :: Type -> Type -> SDoc
wrongATArgErr ty instTy =
sep [ ptext (sLit "Type indexes must match class instance head")
, ptext (sLit "Found") <+> ppr ty <+> ptext (sLit "but expected") <+>
projects / ghc-hetmet.git / blobdiff