------------------------------------------------------
\begin{code}
type TcMethInfo = (Name, DefMethSpec, Type)
- -- A temporary intermediate, to communicate between tcClassSigs and
- -- buildClass.
+ -- A temporary intermediate, to communicate between
+ -- tcClassSigs and buildClass.
buildClass :: Bool -- True <=> do not include unfoldings
-- on dict selectors
implicitClassThings :: Class -> [TyThing]
implicitClassThings cl
- = -- dictionary datatype:
+ = -- Does not include default methods, because those Ids may have
+ -- their own pragmas, unfoldings etc, not derived from the Class object
+ -- Dictionary datatype:
-- [extras_plus:]
-- type constructor
-- [recursive call:]
import Class
import Id
import Name
+import NameEnv
+import NameSet
import Var
import Outputable
import DynFlags
%************************************************************************
\begin{code}
-tcClassSigs :: Name -- Name of the class
+tcClassSigs :: Name -- Name of the class
-> [LSig Name]
-> LHsBinds Name
- -> TcM [TcMethInfo] -- One for each method
-
+ -> TcM ([TcMethInfo], -- Exactly one for each method
+ NameEnv Type) -- Types of the generic-default methods
tcClassSigs clas sigs def_methods
- = do { -- Check that all def_methods are in the class
- ; op_info <- mapM (addLocM tc_sig) [sig | sig@(L _ (TypeSig _ _)) <- sigs]
- ; let op_names = [ n | (n,_,_) <- op_info ]
+ = do { gen_dm_prs <- mapM (addLocM tc_gen_sig) gen_sigs
+ ; let gen_dm_env = mkNameEnv gen_dm_prs
+
+ ; op_info <- mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
+ ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
; sequence_ [ failWithTc (badMethodErr clas n)
- | n <- dm_bind_names, not (n `elem` op_names) ]
+ | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
-- Value binding for non class-method (ie no TypeSig)
; sequence_ [ failWithTc (badGenericMethod clas n)
- | n <- genop_names, not (n `elem` dm_bind_names) ]
+ | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
-- Generic signature without value binding
- ; return op_info }
+ ; return (op_info, gen_dm_env) }
where
+ vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs]
+ gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
dm_bind_names :: [Name] -- These ones have a value binding in the class decl
dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
- genop_names :: [Name] -- These ones have a generic signature
- genop_names = [n | L _ (GenericSig (L _ n) _) <- sigs]
-
- tc_sig (TypeSig (L _ op_name) op_hs_ty)
+ tc_sig genop_env (L _ op_name, op_hs_ty)
= do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
- ; let dm | op_name `elem` genop_names = GenericDM
- | op_name `elem` dm_bind_names = VanillaDM
- | otherwise = NoDM
+ ; let dm | op_name `elemNameEnv` genop_env = GenericDM
+ | op_name `elem` dm_bind_names = VanillaDM
+ | otherwise = NoDM
; return (op_name, dm, op_ty) }
- tc_sig sig = pprPanic "tc_cls_sig" (ppr sig)
+
+ tc_gen_sig (L _ op_name, gen_hs_ty)
+ = do { gen_op_ty <- tcHsKindedType gen_hs_ty
+ ; return (op_name, gen_op_ty) }
\end{code}
; traceTc "TIM2" (ppr sigs)
; let tc_dm = tcDefMeth clas clas_tyvars
- this_dict default_binds sigs
+ this_dict default_binds
sig_fn prag_fn
; dm_binds <- tcExtendTyVarEnv clas_tyvars $
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
-tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name]
+tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-> SigFun -> PragFun -> ClassOpItem
-> TcM (LHsBinds TcId)
-- Generate code for polymorphic default methods only (hence DefMeth)
-- default method for every class op, regardless of whether or not
-- the programmer supplied an explicit default decl for the class.
-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
-tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
+tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
= case dm_info of
NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
; return emptyBag }
- DefMeth dm_name -> tc_dm dm_name (instantiateMethod clas sel_id (mkTyVarTys tyvars))
- GenDefMeth dm_name -> do { tau <- tc_genop_ty (findGenericSig sigs sel_name)
- ; tc_dm dm_name tau }
- -- In the case of a generic default, we have to get the type from the signature
- -- Otherwise we can get it by instantiating the method selector
+ DefMeth dm_name -> tc_dm dm_name
+ GenDefMeth dm_name -> tc_dm dm_name
where
sel_name = idName sel_id
prags = prag_fn sel_name
-- The "local_dm_ty" is precisely the type in the above
-- type signatures, ie with no "forall a. C a =>" prefix
- tc_dm dm_name local_dm_ty
- = do { local_dm_name <- newLocalName sel_name
+ tc_dm dm_name
+ = do { dm_id <- tcLookupId dm_name
+ ; local_dm_name <- newLocalName sel_name
-- Base the local_dm_name on the selector name, because
-- type errors from tcInstanceMethodBody come from here
- ; let dm_ty = mkSigmaTy tyvars [mkClassPred clas (mkTyVarTys tyvars)] local_dm_ty
- dm_id = mkExportedLocalId dm_name dm_ty
+ ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
local_dm_id = mkLocalId local_dm_name local_dm_ty
; dm_id_w_inline <- addInlinePrags dm_id prags
; return (unitBag tc_bind) }
- tc_genop_ty :: LHsType Name -> TcM Type
- tc_genop_ty hs_ty
- = setSrcSpan (getLoc hs_ty) $
- do { tau <- tcHsKindedType hs_ty
- ; checkValidType (FunSigCtxt sel_name) tau
- ; return tau }
-
-findGenericSig :: [LSig Name] -> Name -> LHsType Name
--- Find the 'generic op :: ty' signature among the sigs
--- If dm_info is GenDefMeth, the corresponding signature
--- should jolly well exist! Hence the panic
-findGenericSig sigs sel_name
- = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
- , n == sel_name ] of
- [lty] -> lty
- _ -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
-
---------------
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
-> Id -> Id
-- interfaces, so that their rules and instance decls will be
-- found.
; loadOrphanModules (imp_orphs imports) False
- ; loadOrphanModules (imp_finsts imports) True
-- Check type-familily consistency
; traceRn (text "rn1: checking family instance consistency")
-- any mutually recursive types are done right
-- Just discard the auxiliary bindings; they are generated
-- only for Haskell source code, and should already be in Core
- (tcg_env, _aux_binds, _dm_ids, _) <- tcTyAndClassDecls emptyModDetails rn_decls ;
+ (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
setGblEnv tcg_env $ do {
-- Make the new type env available to stuff slurped from interface files
-- Typecheck type/class decls
; traceTc "Tc2" empty
- ; (tcg_env, aux_binds, dm_ids, _)
+ ; (tcg_env, aux_binds)
<- tcTyAndClassDecls emptyModDetails tycl_decls
- ; setGblEnv tcg_env $
- tcExtendIdEnv dm_ids $ do {
+ ; setGblEnv tcg_env $ do {
-- Typecheck instance decls
-- Family instance declarations are rejected here
-- The latter come in via tycl_decls
traceTc "Tc2" empty ;
- (tcg_env, aux_binds, dm_ids, kc_decls) <- tcTyAndClassDecls boot_details tycl_decls ;
+ (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
-- If there are any errors, tcTyAndClassDecls fails here
- setGblEnv tcg_env $
- tcExtendIdEnv dm_ids $ do {
+ setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
-- and import the supporting declarations
-- Second pass over class and instance declarations,
-- now using the kind-checked decls
traceTc "Tc6" empty ;
- inst_binds <- tcInstDecls2 kc_decls inst_infos ;
+ inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
-- Foreign exports
traceTc "Tc7" empty ;
-- Load any orphan-module and family instance-module
-- interfaces, so their instances are visible.
; loadOrphanModules (dep_orphs (mi_deps iface)) False
- ; loadOrphanModules (dep_finsts (mi_deps iface)) True
-- Check that the family instances of all directly loaded
-- modules are consistent.
import Var
import VarSet
import Name
+import NameEnv
import Outputable
import Maybes
import Unify
-> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order
-> TcM (TcGblEnv, -- Input env extended by types and classes
-- and their implicit Ids,DataCons
- HsValBinds Name, -- Renamed bindings for record selectors
- [Id], -- Default method ids
- [LTyClDecl Name]) -- Kind-checked declarations
+ HsValBinds Name) -- Renamed bindings for record selectors
-- Fails if there are any errors
tcTyAndClassDecls boot_details decls_s
; rec_sel_binds = mkRecSelBinds [tc | ATyCon tc <- tyclss]
; dm_ids = mkDefaultMethodIds tyclss }
- ; env <- tcExtendGlobalEnv implicit_things getGblEnv
- -- We need the kind-checked declarations later, so we return them
- -- from here
- ; kc_decls <- kcTyClDecls tyclds_s
- ; return (env, rec_sel_binds, dm_ids, kc_decls) } }
+ ; env <- tcExtendGlobalEnv implicit_things $
+ tcExtendGlobalValEnv dm_ids $
+ getGblEnv
+ ; return (env, rec_sel_binds) } }
zipRecTyClss :: [[LTyClDecl Name]]
-> [TyThing] -- Knot-tied
tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
; fds' <- mapM (addLocM tc_fundep) fundeps
- ; sig_stuff <- tcClassSigs class_name sigs meths
+ ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
; clas <- fixM $ \ clas -> do
{ let -- This little knot is just so we can get
-- hold of the name of the class TyCon, which we
; buildClass False {- Must include unfoldings for selectors -}
class_name tvs' ctxt' fds' (concat atss')
sig_stuff tc_isrec }
- ; return (AClass clas : map ATyCon (classATs clas))
+
+ ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
+ | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
+ , let gen_dm_tau = expectJust "tcTyClDecl1" $
+ lookupNameEnv gen_dm_env (idName sel_id)
+ , let gen_dm_ty = mkSigmaTy tvs'
+ [mkClassPred clas (mkTyVarTys tvs')]
+ gen_dm_tau
+ ]
+ class_ats = map ATyCon (classATs clas)
+
+ ; return (AClass clas : gen_dm_ids ++ class_ats )
-- NB: Order is important due to the call to `mkGlobalThings' when
-- tying the the type and class declaration type checking knot.
}
ATyCon tc -> checkValidTyCon tc
AClass cl -> do { checkValidClass cl
; mapM_ (addLocM checkValidTyCl) (tcdATs decl) }
+ AnId _ -> return () -- Generic default methods are checked
+ -- with their parent class
_ -> panic "checkValidTyCl"
; traceTc "Done validity of" (ppr thing)
}
unary = isSingleton tyvars
no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
- check_op constrained_class_methods (sel_id, _)
+ check_op constrained_class_methods (sel_id, dm)
= addErrCtxt (classOpCtxt sel_id tau) $ do
{ checkValidTheta SigmaCtxt (tail theta)
-- The 'tail' removes the initial (C a) from the
; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars)
; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars)
(noClassTyVarErr cls sel_id)
+
+ ; case dm of
+ GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name
+ ; checkValidType (FunSigCtxt op_name) (idType dm_id) }
+ _ -> return ()
}
where
op_name = idName sel_id
import Digraph
import BasicTypes
import SrcLoc
-import Outputable
+import Maybes( mapCatMaybes )
import Util ( isSingleton )
import Data.List
\end{code}
nt_loop_breakers `unionNameSets`
prod_loop_breakers
- all_tycons = [ tc | tycls <- tyclss,
+ all_tycons = [ tc | tc <- mapCatMaybes getTyCon tyclss
-- Recursion of newtypes/data types can happen via
-- the class TyCon, so tyclss includes the class tycons
- let tc = getTyCon tycls,
- not (tyConName tc `elemNameSet` boot_name_set) ]
+ , not (tyConName tc `elemNameSet` boot_name_set) ]
-- Remove the boot_name_set because they are going
-- to be loop breakers regardless.
new_tc_rhs :: TyCon -> Type
new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
-getTyCon :: TyThing -> TyCon
-getTyCon (ATyCon tc) = tc
-getTyCon (AClass cl) = classTyCon cl
-getTyCon _ = panic "getTyCon"
+getTyCon :: TyThing -> Maybe TyCon
+getTyCon (ATyCon tc) = Just tc
+getTyCon (AClass cl) = Just (classTyCon cl)
+getTyCon _ = Nothing
findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
-- Finds a set of tycons that cut all loops
projects / ghc-hetmet.git / commitdiff