Commit 8f212ab5 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Rejig the way in which generic default method signatures are checked

- Check GenericSig in tcClassSigs, along with TypeSig
- Add the generic default methods to the type envt
- Look them up via tcLookupId in TcClassDcl.tcDefMeth

Much nicer!
parent 99e9c36b
......@@ -222,8 +222,8 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
------------------------------------------------------
\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
......
......@@ -1036,7 +1036,9 @@ implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
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:]
......
......@@ -27,6 +27,8 @@ import BuildTyCl( TcMethInfo )
import Class
import Id
import Name
import NameEnv
import NameSet
import Var
import Outputable
import DynFlags
......@@ -81,39 +83,43 @@ Death to "ExpandingDicts".
%************************************************************************
\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}
......@@ -151,7 +157,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
; 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 $
......@@ -161,7 +167,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
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)
......@@ -170,15 +176,12 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name]
-- 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
......@@ -193,13 +196,13 @@ tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
-- 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
......@@ -215,23 +218,6 @@ tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
; 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
......
......@@ -245,7 +245,6 @@ tcRnImports hsc_env this_mod import_decls
-- 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")
......@@ -299,7 +298,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
-- 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
......@@ -500,10 +499,9 @@ tcRnHsBootDecls decls
-- 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
......@@ -837,11 +835,10 @@ tcTopSrcDecls boot_details
-- 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
......@@ -877,7 +874,7 @@ tcTopSrcDecls boot_details
-- 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 ;
......@@ -1387,7 +1384,6 @@ tcGetModuleExports mod directlyImpMods
-- 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.
......
......@@ -35,6 +35,7 @@ import IdInfo
import Var
import VarSet
import Name
import NameEnv
import Outputable
import Maybes
import Unify
......@@ -65,9 +66,7 @@ tcTyAndClassDecls :: ModDetails
-> [[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
......@@ -109,11 +108,10 @@ 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
......@@ -524,7 +522,7 @@ tcTyClDecl1 _parent calc_isrec
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
......@@ -537,7 +535,18 @@ tcTyClDecl1 _parent calc_isrec
; 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.
}
......@@ -802,6 +811,8 @@ checkValidTyCl decl
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)
}
......@@ -964,7 +975,7 @@ checkValidClass cls
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
......@@ -982,6 +993,11 @@ checkValidClass cls
; 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
......
......@@ -30,7 +30,7 @@ import NameSet
import Digraph
import BasicTypes
import SrcLoc
import Outputable
import Maybes( mapCatMaybes )
import Util ( isSingleton )
import Data.List
\end{code}
......@@ -253,11 +253,10 @@ calcRecFlags boot_details tyclss
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.
......@@ -321,10 +320,10 @@ calcRecFlags boot_details tyclss
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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment