Commit 924f8517 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor default methods (Trac #11105)

This patch does some signficant refactoring to the treatment
of default methods in class declarations, and more generally
to the type checking of type/class decls.

Highlights:

* When the class has a generic-default method, such as
     class C a where
       op :: a -> a -> Bool
       default op :: Ord a => a -> a -> a
  the ClassOpItem records the type of the generic-default,
  in this case the type (Ord a => a -> a -> a)

* I killed off Class.DefMeth in favour of the very-similar
  BasicTypes.DefMethSpec.  However it turned out to be better
  to use a Maybe, thus
      Maybe (DefMethSpec Type)
  with Nothing meaning "no default method".

* In TcTyClsDecls.tcTyClGroup, we used to accumulate a [TyThing],
  but I found a way to make it much simpler, accumulating only
  a [TyCon].  Much less wrapping and unwrapping.

* On the way I also fixed Trac #10896 in a better way. Instead
  of killing off all ambiguity checks whenever there are any type
  errors (the fix in commit 8e8b9ed9), I instead recover in
  TcTyClsDecls.checkValidTyCl.

There was a lot of associated simplification all round
parent 9032d056
......@@ -765,19 +765,17 @@ instance Outputable OccInfo where
The DefMethSpec enumeration just indicates what sort of default method
is used for a class. It is generated from source code, and present in
interface files; it is converted to Class.DefMeth before begin put in a
interface files; it is converted to Class.DefMethInfo before begin put in a
Class object.
-}
data DefMethSpec = NoDM -- No default method
| VanillaDM -- Default method given with polymorphic code
| GenericDM -- Default method given with generic code
deriving Eq
data DefMethSpec ty
= VanillaDM -- Default method given with polymorphic code
| GenericDM ty -- Default method given with code of this type
instance Outputable DefMethSpec where
ppr NoDM = empty
ppr VanillaDM = ptext (sLit "{- Has default method -}")
ppr GenericDM = ptext (sLit "{- Has generic default method -}")
instance Outputable (DefMethSpec ty) where
ppr VanillaDM = ptext (sLit "{- Has default method -}")
ppr (GenericDM {}) = ptext (sLit "{- Has generic default method -}")
{-
************************************************************************
......
......@@ -368,8 +368,8 @@ Default methods
E.g. $dmmax
- If there is a default method name at all, it's recorded in
the ClassOpSig (in HsBinds), in the DefMeth field.
(DefMeth is defined in Class.hs)
the ClassOpSig (in HsBinds), in the DefMethInfo field.
(DefMethInfo is defined in Class.hs)
Source-code class decls and interface-code class decls are treated subtly
differently, which has given me a great deal of confusion over the years.
......@@ -390,7 +390,8 @@ In *source-code* class declarations:
op2 :: <type>
op1 = ...
We generate a binding for $dmop1 but not for $dmop2.
The Class for Foo has a NoDefMeth for op2 and a DefMeth for op1.
The Class for Foo has a Nothing for op2 and
a Just ($dm_op1, VanillaDM) for op1.
The Name for $dmop2 is simply discarded.
In *interface-file* class declarations:
......
......@@ -230,7 +230,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
-- ------------------------------------------------------
type TcMethInfo = (Name, DefMethSpec, Type)
type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
-- A temporary intermediate, to communicate between
-- tcClassSigs and buildClass.
......@@ -279,7 +279,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
-- class C a => D a
-- we don't get a newtype with no arguments!
args = sc_sel_names ++ op_names
op_tys = [ty | (_,_,ty) <- sig_stuff]
op_tys = [ty | (_,ty,_) <- sig_stuff]
op_names = [op | (op,_,_) <- sig_stuff]
arg_tys = sc_theta ++ op_tys
rec_tycon = classTyCon rec_clas
......@@ -327,13 +327,11 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
mk_op_item rec_clas (op_name, dm_spec, _)
mk_op_item rec_clas (op_name, _, dm_spec)
= do { dm_info <- case dm_spec of
NoDM -> return NoDefMeth
GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc
; return (GenDefMeth dm_name) }
VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (DefMeth dm_name) }
Nothing -> return Nothing
Just spec -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (Just (dm_name, spec)) }
; return (mkDictSelId op_name rec_clas, dm_info) }
{-
......
......@@ -173,10 +173,13 @@ data IfaceFamTyConFlav
| IfaceAbstractClosedSynFamilyTyCon
| IfaceBuiltInSynFamTyCon -- for pretty printing purposes only
data IfaceClassOp = IfaceClassOp IfaceTopBndr DefMethSpec IfaceType
-- Nothing => no default method
-- Just False => ordinary polymorphic default method
-- Just True => generic default method
data IfaceClassOp
= IfaceClassOp IfaceTopBndr
IfaceType -- Class op type
(Maybe (DefMethSpec IfaceType)) -- Default method
-- The types of both the class op itself,
-- and the default method, are *not* quantifed
-- over the class variables
data IfaceAT = IfaceAT -- See Class.ClassATItem
IfaceDecl -- The associated type declaration
......@@ -814,9 +817,14 @@ instance Outputable IfaceClassOp where
ppr = pprIfaceClassOp showAll
pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc
pprIfaceClassOp ss (IfaceClassOp n dm ty) = hang opHdr 2 (pprIfaceSigmaType ty)
where opHdr = pprPrefixIfDeclBndr ss n
<+> ppShowIface ss (ppr dm) <+> dcolon
pprIfaceClassOp ss (IfaceClassOp n ty dm)
= pp_sig n ty $$ generic_dm
where
generic_dm | Just (GenericDM dm_ty) <- dm
= ptext (sLit "default") <+> pp_sig n dm_ty
| otherwise
= empty
pp_sig n ty = pprPrefixIfDeclBndr ss n <+> dcolon <+> pprIfaceSigmaType ty
instance Outputable IfaceAT where
ppr = pprIfaceAT showAll
......@@ -1182,7 +1190,11 @@ freeNamesIfAT (IfaceAT decl mb_def)
Just rhs -> freeNamesIfType rhs
freeNamesIfClsSig :: IfaceClassOp -> NameSet
freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm
freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet
freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty
freeNamesDM _ = emptyNameSet
freeNamesIfConDecls :: IfaceConDecls -> NameSet
freeNamesIfConDecls (IfDataTyCon c _ _) = fnList freeNamesIfConDecl c
......@@ -1538,16 +1550,16 @@ instance Binary IfaceFamTyConFlav where
(ppr (fromIntegral h :: Int)) }
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
put_ bh (IfaceClassOp n ty def) = do
put_ bh (occNameFS n)
put_ bh def
put_ bh ty
put_ bh def
get bh = do
n <- get bh
def <- get bh
ty <- get bh
def <- get bh
occ <- return $! mkVarOccFS n
return (IfaceClassOp occ def ty)
return (IfaceClassOp occ ty def)
instance Binary IfaceAT where
put_ bh (IfaceAT dec defs) = do
......
......@@ -6,7 +6,9 @@
This module defines interface types and binders
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP, FlexibleInstances #-}
-- FlexibleInstances for Binary (DefMethSpec IfaceType)
module IfaceType (
IfExtName, IfLclName,
......@@ -1007,6 +1009,15 @@ instance Binary IfaceCoercion where
return $ IfaceAxiomRuleCo a b c
_ -> panic ("get IfaceCoercion " ++ show tag)
instance Binary (DefMethSpec IfaceType) where
put_ bh VanillaDM = putByte bh 0
put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t
get bh = do
h <- getByte bh
case h of
0 -> return VanillaDM
_ -> do { t <- get bh; return (GenericDM t) }
{-
************************************************************************
* *
......
......@@ -1529,8 +1529,9 @@ classToIfaceDecl env clas
toIfaceClassOp (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
IfaceClassOp (getOccName sel_id) (toDmSpec def_meth)
IfaceClassOp (getOccName sel_id)
(tidyToIfaceType env1 op_ty)
(fmap toDmSpec def_meth)
where
-- Be careful when splitting the type, because of things
-- like class Foo a where
......@@ -1540,9 +1541,9 @@ classToIfaceDecl env clas
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
toDmSpec NoDefMeth = NoDM
toDmSpec (GenDefMeth _) = GenericDM
toDmSpec (DefMeth _) = VanillaDM
toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
toDmSpec (_, VanillaDM) = VanillaDM
toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)
toIfaceFD (tvs1, tvs2) = (map (getFS . tidyTyVar env1) tvs1,
map (getFS . tidyTyVar env1) tvs2)
......
......@@ -50,7 +50,7 @@ import PrelNames
import TysWiredIn
import TysPrim ( superKindTyConName )
import BasicTypes ( strongLoopBreaker, Arity, TupleSort(..)
, Boxity(..), pprRuleName )
, Boxity(..), DefMethSpec(..), pprRuleName )
import Literal
import qualified Var
import VarEnv
......@@ -419,13 +419,23 @@ tc_iface_decl _parent ignore_prags
-- Here the associated type T is knot-tied with the class, and
-- so we must not pull on T too eagerly. See Trac #5970
tc_sig (IfaceClassOp occ dm rdr_ty)
tc_sig :: IfaceClassOp -> IfL TcMethInfo
tc_sig (IfaceClassOp occ rdr_ty dm)
= do { op_name <- lookupIfaceTop occ
; op_ty <- forkM (mk_op_doc op_name rdr_ty) (tcIfaceType rdr_ty)
; ~(op_ty, dm') <- forkM (mk_op_doc op_name rdr_ty) $
do { ty <- tcIfaceType rdr_ty
; dm' <- tc_dm dm
; return (ty, dm') }
-- Must be done lazily for just the same reason as the
-- type of a data con; to avoid sucking in types that
-- it mentions unless it's necessary to do so
; return (op_name, dm, op_ty) }
; return (op_name, op_ty, dm') }
tc_dm :: Maybe (DefMethSpec IfaceType) -> IfL (Maybe (DefMethSpec Type))
tc_dm Nothing = return Nothing
tc_dm (Just VanillaDM) = return (Just VanillaDM)
tc_dm (Just (GenericDM ty)) = do { ty' <- tcIfaceType ty
; return (Just (GenericDM ty')) }
tc_at cls (IfaceAT tc_decl if_def)
= do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
......
......@@ -1721,7 +1721,8 @@ implicitTyConThings tc
= class_stuff ++
-- fields (names of selectors)
-- (possibly) implicit newtype coercion
-- (possibly) implicit newtype axioms
-- or type family axioms
implicitCoTyCon tc ++
-- for each data constructor in order,
......
......@@ -97,16 +97,16 @@ Death to "ExpandingDicts".
************************************************************************
-}
tcClassSigs :: Name -- Name of the class
tcClassSigs :: Name -- Name of the class
-> [LSig Name]
-> LHsBinds Name
-> TcM ([TcMethInfo], -- Exactly one for each method
NameEnv Type) -- Types of the generic-default methods
-> TcM [TcMethInfo] -- Exactly one for each method
tcClassSigs clas sigs def_methods
= do { traceTc "tcClassSigs 1" (ppr clas)
; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
; let gen_dm_env = mkNameEnv gen_dm_prs
; let gen_dm_env :: NameEnv Type
gen_dm_env = mkNameEnv gen_dm_prs
; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
......@@ -120,22 +120,22 @@ tcClassSigs clas sigs def_methods
-- Generic signature without value binding
; traceTc "tcClassSigs 2" (ppr clas)
; return (op_info, gen_dm_env) }
; return op_info }
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]
tc_sig genop_env (op_names, op_hs_ty)
tc_sig gen_dm_env (op_names, op_hs_ty)
= do { traceTc "ClsSig 1" (ppr op_names)
; op_ty <- tcClassSigType op_hs_ty -- Class tyvars already in scope
; traceTc "ClsSig 2" (ppr op_names)
; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] }
; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
where
f nm | nm `elemNameEnv` genop_env = GenericDM
| nm `elem` dm_bind_names = VanillaDM
| otherwise = NoDM
f nm | Just ty <- lookupNameEnv gen_dm_env nm = Just (GenericDM ty)
| nm `elem` dm_bind_names = Just VanillaDM
| otherwise = Nothing
tc_gen_sig (op_names, gen_hs_ty)
= do { gen_op_ty <- tcClassSigType gen_hs_ty
......@@ -173,19 +173,8 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
pred = mkClassPred clas (mkTyVarTys clas_tyvars)
; this_dict <- newEvVar pred
; let tc_item (sel_id, dm_info)
= case dm_info of
DefMeth dm_name -> tc_dm sel_id dm_name False
GenDefMeth dm_name -> tc_dm sel_id dm_name True
-- For GenDefMeth, warn if the user specifies a signature
-- with redundant constraints; but not for DefMeth, where
-- the default method may well be 'error' or something
NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id))
(lookupPragEnv prag_fn (idName sel_id))
; return emptyBag }
tc_dm = tcDefMeth clas clas_tyvars this_dict
default_binds sig_fn prag_fn
; let tc_item = tcDefMeth clas clas_tyvars this_dict
default_binds sig_fn prag_fn
; dm_binds <- tcExtendTyVarEnv clas_tyvars $
mapM tc_item op_items
......@@ -194,19 +183,25 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
-> HsSigFun -> TcPragEnv -> Id -> Name -> Bool
-> HsSigFun -> TcPragEnv -> ClassOpItem
-> TcM (LHsBinds TcId)
-- Generate code for polymorphic default methods only (hence DefMeth)
-- (Generic default methods have turned into instance decls by now.)
-- Generate code for default methods
-- This is incompatible with Hugs, which expects a polymorphic
-- 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
hs_sig_fn prag_fn sel_id dm_name warn_redundant
tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
= do { -- No default method
mapM_ (addLocM (badDmPrag sel_id))
(lookupPragEnv prag_fn (idName sel_id))
; return emptyBag }
tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
(sel_id, Just (dm_name, dm_spec))
| Just (L bind_loc dm_bind, bndr_loc) <- findMethodBind sel_name binds_in
-- First look up the default method -- it should be there!
= do { global_dm_id <- tcLookupId dm_name
= do { -- First look up the default method -- It should be there!
global_dm_id <- tcLookupId dm_name
; global_dm_id <- addInlinePrags global_dm_id prags
; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
-- Base the local_dm_name on the selector name, because
......@@ -235,6 +230,13 @@ tcDefMeth clas tyvars this_dict binds_in
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
warn_redundant = case dm_spec of
GenericDM {} -> True
VanillaDM -> False
-- For GenericDM, warn if the user specifies a signature
-- with redundant constraints; but not for VanillaDM, where
-- the default method may well be 'error' or something
ctxt = FunSigCtxt sel_name warn_redundant
; local_dm_sig <- instTcTySig ctxt hs_ty local_dm_ty Nothing [] local_dm_name
......@@ -283,7 +285,7 @@ tcClassMinimalDef _clas sigs op_info
-- implementation whose names don't start with '_'
defMindef :: ClassMinimalDef
defMindef = mkAnd [ noLoc (mkVar name)
| (name, NoDM, _) <- op_info
| (name, _, Nothing) <- op_info
, not (startsWithUnderscore (getOccName name)) ]
instantiateMethod :: Class -> Id -> [TcType] -> TcType
......
......@@ -410,9 +410,9 @@ tcDeriving deriv_infos deriv_decls
liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
(ddump_deriving inst_info rn_binds newTyCons famInsts))
; let all_tycons = map ATyCon (bagToList newTyCons)
; gbl_env <- tcExtendGlobalEnv all_tycons $
tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $
; let all_tycons = bagToList newTyCons
; gbl_env <- tcExtendTyConEnv all_tycons $
tcExtendGlobalEnvImplicit (concatMap implicitTyConThings all_tycons) $
tcExtendLocalFamInstEnv (bagToList famInsts) $
tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) getGblEnv
; let all_dus = rn_dus `plusDU` usesOnly (mkFVs $ catMaybes maybe_fvs)
......
......@@ -12,7 +12,8 @@ module TcEnv(
InstBindings(..),
-- Global environment
tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
tcExtendGlobalEnv, tcExtendTyConEnv,
tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
tcExtendGlobalValEnv,
tcLookupLocatedGlobal, tcLookupGlobal,
tcLookupTyCon, tcLookupClass,
......@@ -260,10 +261,8 @@ setGlobalTypeEnv tcg_env new_type_env
tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
-- Extend the global environment with some TyThings that can be obtained
-- via implicitTyThings from other entities in the environment. Examples
-- are dfuns, famInstTyCons, data cons, etc.
-- These TyThings are not added to tcg_tcs.
-- Just extend the global environment with some TyThings
-- Do not extend tcg_tcs etc
tcExtendGlobalEnvImplicit things thing_inside
= do { tcg_env <- getGblEnv
; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things
......@@ -281,6 +280,16 @@ tcExtendGlobalEnv things thing_inside
tcExtendGlobalEnvImplicit things thing_inside
}
tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
-- Given a mixture of Ids, TyCons, Classes, all defined in the
-- module being compiled, extend the global environment
tcExtendTyConEnv tycons thing_inside
= do { env <- getGblEnv
; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }
; setGblEnv env' $
tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
}
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
-- Same deal as tcExtendGlobalEnv, but for Ids
tcExtendGlobalValEnv ids thing_inside
......
......@@ -36,14 +36,13 @@ import MkCore ( nO_METHOD_BINDING_ERROR_ID )
import Type
import TcEvidence
import TyCon
import CoAxiom
import CoAxiom( toBranchedAxiom )
import DataCon
import Class
import Var
import VarEnv
import VarSet
import PrelNames ( typeableClassName, genericClassNames )
-- , knownNatClassName, knownSymbolClassName )
import Bag
import BasicTypes
import DynFlags
......@@ -462,14 +461,17 @@ addFamInsts :: [FamInst] -> TcM a -> TcM a
-- (b) the type envt with stuff from data type decls
addFamInsts fam_insts thing_inside
= tcExtendLocalFamInstEnv fam_insts $
tcExtendGlobalEnv things $
tcExtendGlobalEnv axioms $
tcExtendTyConEnv data_rep_tycons $
do { traceTc "addFamInsts" (pprFamInsts fam_insts)
; tcg_env <- tcAddImplicits things
; tcg_env <- tcAddImplicits data_rep_tycons
-- Does not add its axiom; that comes from
-- adding the 'axioms' above
; setGblEnv tcg_env thing_inside }
where
axioms = map (toBranchedAxiom . famInstAxiom) fam_insts
tycons = famInstsRepTyCons fam_insts
things = map ATyCon tycons ++ map ACoAxiom axioms
axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
data_rep_tycons = famInstsRepTyCons fam_insts
-- The representation tycons for 'data instances' declarations
{-
Note [Deriving inside TH brackets]
......@@ -1228,7 +1230,7 @@ tcMethods :: DFunId -> Class
-> [TcType]
-> TcEvBinds
-> ([Located TcSpecPrag], TcPragEnv)
-> [(Id, DefMeth)]
-> [ClassOpItem]
-> InstBindings Name
-> TcM ([Id], LHsBinds Id, Bag Implication)
-- The returned inst_meth_ids all have types starting
......@@ -1255,7 +1257,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
inst_loc = getSrcSpan dfun_id
----------------------
tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id, Maybe Implication)
tc_item :: ClassOpItem -> TcM (Id, LHsBind Id, Maybe Implication)
tc_item (sel_id, dm_info)
| Just (user_bind, bndr_loc) <- findMethodBind (idName sel_id) binds
= tcMethodBody clas tyvars dfun_ev_vars inst_tys
......@@ -1266,15 +1268,15 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
; tc_default sel_id dm_info }
----------------------
tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id, Maybe Implication)
tc_default :: Id -> DefMethInfo -> TcM (TcId, LHsBind Id, Maybe Implication)
tc_default sel_id (GenDefMeth dm_name)
tc_default sel_id (Just (dm_name, GenericDM {}))
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
; tcMethodBody clas tyvars dfun_ev_vars inst_tys
dfun_ev_binds is_derived hs_sig_fn prags
sel_id meth_bind inst_loc }
tc_default sel_id NoDefMeth -- No default method at all
tc_default sel_id Nothing -- No default method at all
= do { traceTc "tc_def: warn" (ppr sel_id)
; (meth_id, _, _) <- mkMethIds hs_sig_fn clas tyvars dfun_ev_vars
inst_tys sel_id
......@@ -1292,7 +1294,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
(hcat [ppr inst_loc, vbar, ppr sel_id ])
lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
tc_default sel_id (Just (dm_name, VanillaDM)) -- A polymorphic default method
= do { -- Build the typechecked version directly,
-- without calling typecheck_method;
-- see Note [Default methods in instances]
......
......@@ -931,7 +931,7 @@ checkBootTyCon tc1 tc2
check (eqTypeX env op_ty1 op_ty2)
(text "The types of" <+> pname1 <+>
text "are different") `andThenCheck`
check (def_meth1 == def_meth2)
check (eqMaybeBy eqDM def_meth1 def_meth2)
(text "The default methods associated with" <+> pname1 <+>
text "are different")
where
......@@ -949,6 +949,10 @@ checkBootTyCon tc1 tc2
check (eqATDef def_ats1 def_ats2)
(text "The associated type defaults differ")
eqDM (_, VanillaDM) (_, VanillaDM) = True
eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2
eqDM _ _ = False
-- Ignore the location of the defaults
eqATDef Nothing Nothing = True
eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2
......
......@@ -1214,10 +1214,9 @@ reifyClass cls
= do { ty <- reifyType (idType op)
; let nm' = reifyName op
; case def_meth of
GenDefMeth gdm_nm ->
do { gdm_id <- tcLookupId gdm_nm
; gdm_ty <- reifyType (idType gdm_id)
; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty] }
Just (_, GenericDM gdm_ty) ->
do { gdm_ty' <- reifyType gdm_ty
; return [TH.SigD nm' ty, TH.DefaultSigD nm' gdm_ty'] }
_ -> return [TH.SigD nm' ty] }
reifyAT :: ClassATItem -> TcM [TH.Dec]
......
This diff is collapsed.
......@@ -375,18 +375,17 @@ data RecTyInfo = RTI { rti_promotable :: Bool
, rti_is_rec :: Name -> RecFlag }
calcRecFlags :: SelfBootInfo -> Bool -- hs-boot file?
-> RoleAnnots -> [TyThing] -> RecTyInfo
-> RoleAnnots -> [TyCon] -> RecTyInfo
-- The 'boot_names' are the things declared in M.hi-boot, if M is the current module.
-- Any type constructors in boot_names are automatically considered loop breakers
calcRecFlags boot_details is_boot mrole_env tyclss
-- Recursion of newtypes/data types can happen via
-- the class TyCon, so all_tycons includes the class tycons
calcRecFlags boot_details is_boot mrole_env all_tycons
= RTI { rti_promotable = is_promotable
, rti_roles = roles
, rti_is_rec = is_rec }
where
rec_tycon_names = mkNameSet (map tyConName all_tycons)
all_tycons = mapMaybe getTyCon tyclss
-- Recursion of newtypes/data types can happen via
-- the class TyCon, so tyclss includes the class tycons
is_promotable = all (computeTyConPromotability rec_tycon_names) all_tycons
......@@ -466,10 +465,6 @@ calcRecFlags boot_details is_boot mrole_env tyclss
new_tc_rhs :: TyCon -> Type
new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables
getTyCon :: TyThing -> Maybe TyCon
getTyCon (ATyCon tc) = Just tc
getTyCon _ = Nothing
findLoopBreakers :: [(TyCon, [TyCon])] -> [Name]
-- Finds a set of tycons that cut all loops
findLoopBreakers deps
......@@ -811,19 +806,39 @@ updateRoleEnv name n role
* *
********************************************************************* -}
tcAddImplicits :: [TyThing] -> TcM TcGblEnv
tcAddImplicits tyclss
tcAddImplicits :: [TyCon] -> TcM TcGblEnv
tcAddImplicits tycons
= discardWarnings $
tcExtendGlobalEnvImplicit implicit_things $
tcExtendGlobalValEnv def_meth_ids $
do { (typeable_ids, typeable_binds) <- mkTypeableBinds tycons
do { traceTc "tcAddImplicits" $ vcat
[ text "tycons" <+> ppr tycons
, text "implicits" <+> ppr implicit_things ]
; (typeable_ids, typeable_binds) <- mkTypeableBinds tycons
; gbl_env <- tcExtendGlobalValEnv typeable_ids
$ tcRecSelBinds $ mkRecSelBinds tycons
; return (gbl_env `addTypecheckedBinds` typeable_binds) }
where
implicit_things = concatMap implicitTyThings tyclss
tycons = [tc | ATyCon tc <- tyclss]
def_meth_ids = mkDefaultMethodIds tyclss
implicit_things = concatMap implicitTyConThings tycons
def_meth_ids = mkDefaultMethodIds tycons
mkDefaultMethodIds :: [TyCon] -> [Id]
-- We want to put the default-method Ids (both vanilla and generic)
-- into the type environment so that they are found when we typecheck
-- the filled-in default methods of each instance declaration
-- See Note [Default method Ids and Template Haskell]
mkDefaultMethodIds tycons
= [ mkExportedLocalId VanillaId dm_name (mk_dm_ty cls sel_id dm_spec)
| tc <- tycons
, Just cls <- [tyConClass_maybe tc]
, (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ]
where
mk_dm_ty :: Class -> Id -> DefMethSpec Type -> Type
mk_dm_ty _ sel_id VanillaDM = idType sel_id
mk_dm_ty cls _ (GenericDM dm_ty) = mkSigmaTy cls_tvs [pred] dm_ty
where
cls_tvs = classTyVars cls
pred = mkClassPred cls (mkTyVarTys cls_tvs)
{-
************************************************************************
......@@ -833,14 +848,8 @@ tcAddImplicits tyclss
************************************************************************
-}
mkDefaultMethodIds :: [TyThing] -> [Id]
-- See Note [Default method Ids and Template Haskell]
mkDefaultMethodIds things
= [ mkExportedLocalId VanillaId dm_name (idType sel_id)
| ATyCon tc <- things
, Just cls <- [tyConClass_maybe tc]
, (sel_id, DefMeth dm_name) <- classOpItems cls ]
{-
-}
{-
Note [Default method Ids and Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -147,7 +147,9 @@ mkTypeableBinds tycons
Just mod_id -> nlHsVar mod_id
Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons)
stuff = (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon)
tc_binds = map (mk_typeable_binds stuff) tycons
all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ]
-- We need type representations for any associated types
tc_binds = map (mk_typeable_binds stuff) all_tycons
tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds
; return (tycon_rep_ids, tc_binds) } }
......
......@@ -217,11 +217,7 @@ checkAmbiguity ctxt ty
; (_wrap, wanted) <- addErrCtxtM (mk_msg ty') $
captureConstraints $
tcSubType_NC ctxt ty' ty'
; whenNoErrs $ -- only run the simplifier if we have a clean
-- environment. Otherwise we might trip.
-- example: indexed-types/should_fail/BadSock
-- fails in DEBUG mode without this
simplifyAmbiguityCheck ty wanted
; simplifyAmbiguityCheck ty wanted
; traceTc "Done ambiguity check for" (ppr ty) }
where
......
......@@ -7,10 +7,10 @@
module Class (
Class,
ClassOpItem, DefMeth (..),
ClassOpItem,
ClassATItem(..),
ClassMinimalDef,
defMethSpecOfDefMeth,
DefMethInfo, pprDefMethInfo, defMethSpecOfDefMeth,
FunDep, pprFundeps, pprFunDep,
......@@ -90,14 +90,17 @@ data Class
-- For details on above see note [Api annotations] in ApiAnnotation
type FunDep a = ([a],[a])
type ClassOpItem = (Id, DefMeth)