Commit 78693246 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Refactor (again) the handling of default methods

This patch fixes Trac #4056, by 

 a) tidying up the treatment of default method names
 b) removing the 'module' argument to newTopSrcBinder

The details aren't that interesting, but the result
is much tidier. The original bug was a 'nameModule' panic,
caused by trying to find the module of a top-level name.
But TH quotes generate Internal top-level names that don't
have a module, and that is generally a good thing.  

Fixing that in turn led to the default-method refactoring,
which also makes the Name for a default method be handled
in the same way as other derived names, generated in BuildTyCl
via a call newImplicitBinder.  Hurrah.
parent f03b9562
......@@ -21,7 +21,7 @@ module BasicTypes(
Arity,
FunctionOrData(..),
FunctionOrData(..),
WarningTxt(..),
......@@ -57,6 +57,8 @@ module BasicTypes(
HsBang(..), isBanged, isMarkedUnboxed,
StrictnessMark(..), isMarkedStrict,
DefMethSpec(..),
CompilerPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
RuleMatchInfo(..), isConLike, isFunLike,
......@@ -522,7 +524,7 @@ instance Show OccInfo where
%************************************************************************
%* *
\subsection{Strictness indication}
Strictness indication
%* *
%************************************************************************
......@@ -573,6 +575,28 @@ isMarkedStrict _ = True -- All others are strict
\end{code}
%************************************************************************
%* *
Default method specfication
%* *
%************************************************************************
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
Class object.
\begin{code}
data DefMethSpec = NoDM -- No default method
| VanillaDM -- Default method given with polymorphic code
| GenericDM -- Default method given with generic code
instance Outputable DefMethSpec where
ppr NoDM = empty
ppr VanillaDM = ptext (sLit "{- Has default method -}")
ppr GenericDM = ptext (sLit "{- Has generic default method -}")
\end{code}
%************************************************************************
%* *
\subsection{Success flag}
......
......@@ -30,7 +30,6 @@ module RdrName (
mkRdrUnqual, mkRdrQual,
mkUnqual, mkVarUnqual, mkQual, mkOrig,
nameRdrName, getRdrName,
mkDerivedRdrName,
-- ** Destruction
rdrNameOcc, rdrNameSpace, setRdrNameSpace,
......@@ -163,14 +162,6 @@ mkRdrQual mod occ = Qual mod occ
mkOrig :: Module -> OccName -> RdrName
mkOrig mod occ = Orig mod occ
---------------
-- | Produce an original 'RdrName' whose module that of a parent 'Name' but its 'OccName'
-- is derived from that of it's parent using the supplied function
mkDerivedRdrName :: Name -> (OccName -> OccName) -> RdrName
mkDerivedRdrName parent mk_occ
= ASSERT2( isExternalName parent, ppr parent )
mkOrig (nameModule parent) (mk_occ (nameOccName parent))
---------------
-- These two are used when parsing source files
-- They do encode the module and occurrence names
......
......@@ -23,7 +23,6 @@ import IfaceSyn
import Module
import Name
import VarEnv
import Class
import DynFlags
import UniqFM
import UniqSupply
......@@ -655,16 +654,16 @@ instance Binary RecFlag where
0 -> do return Recursive
_ -> do return NonRecursive
instance Binary DefMeth where
put_ bh NoDefMeth = putByte bh 0
put_ bh DefMeth = putByte bh 1
put_ bh GenDefMeth = putByte bh 2
instance Binary DefMethSpec where
put_ bh NoDM = putByte bh 0
put_ bh VanillaDM = putByte bh 1
put_ bh GenericDM = putByte bh 2
get bh = do
h <- getByte bh
case h of
0 -> return NoDefMeth
1 -> return DefMeth
_ -> return GenDefMeth
0 -> return NoDM
1 -> return VanillaDM
_ -> return GenericDM
instance Binary FixityDirection where
put_ bh InfixL = do
......
......@@ -6,7 +6,7 @@
\begin{code}
module BuildTyCl (
buildSynTyCon, buildAlgTyCon, buildDataCon,
buildClass,
TcMethInfo, buildClass,
mkAbstractTyConRhs, mkOpenDataTyConRhs,
mkNewTyConRhs, mkDataTyConRhs, setAssocFamilyPermutation
) where
......@@ -246,14 +246,17 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
------------------------------------------------------
\begin{code}
type TcMethInfo = (Name, DefMethSpec, Type) -- A temporary intermediate, to communicate
-- between tcClassSigs and buildClass
buildClass :: Bool -- True <=> do not include unfoldings
-- on dict selectors
-- Used when importing a class without -O
-> Name -> [TyVar] -> ThetaType
-> [FunDep TyVar] -- Functional dependencies
-> [TyThing] -- Associated types
-> [(Name, DefMeth, Type)] -- Method info
-> RecFlag -- Info for type constructor
-> [FunDep TyVar] -- Functional dependencies
-> [TyThing] -- Associated types
-> [TcMethInfo] -- Method info
-> RecFlag -- Info for type constructor
-> TcRnIf m n Class
buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
......@@ -266,11 +269,7 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
; fixM (\ rec_clas -> do { -- Only name generation inside loop
let { rec_tycon = classTyCon rec_clas
; op_tys = [ty | (_,_,ty) <- sig_stuff]
; op_names = [op | (op,_,_) <- sig_stuff]
; op_items = [ (mkDictSelId no_unf op_name rec_clas, dm_info)
| (op_name, dm_info, _) <- sig_stuff ] }
; op_items <- mapM (mk_op_item rec_clas) sig_stuff
-- Build the selector id and default method id
; let n_value_preds = count (not . isEqPred) sc_theta
......@@ -301,9 +300,12 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
-- as ordinary arguments. That means that in the case of
-- class C a => D a
-- we don't get a newtype with no arguments!
args = sc_sel_names ++ op_names
arg_tys = map mkPredTy sc_theta ++ op_tys
args = sc_sel_names ++ op_names
arg_tys = map mkPredTy sc_theta ++ op_tys
op_tys = [ty | (_,_,ty) <- sig_stuff]
op_names = [op | (op,_,_) <- sig_stuff]
rec_tycon = classTyCon rec_clas
; dict_con <- buildDataCon datacon_name
False -- Not declared infix
(map (const HsNoBang) args)
......@@ -339,6 +341,15 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
; traceIf (text "buildClass" <+> ppr tycon)
; return result
})}
where
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
mk_op_item rec_clas (op_name, dm_spec, _)
= do { dm_info <- case dm_spec of
NoDM -> return NoDefMeth
GenericDM -> return GenDefMeth
VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (DefMeth dm_name) }
; return (mkDictSelId no_unf op_name rec_clas, dm_info) }
\end{code}
Note [Class newtypes and equality predicates]
......
......@@ -105,7 +105,7 @@ data IfaceDecl
-- beyond .NET
ifExtName :: Maybe FastString }
data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
-- Nothing => no default method
-- Just False => ordinary polymorphic default method
-- Just True => generic default method
......
......@@ -1333,7 +1333,7 @@ tyThingToIfaceDecl (AClass clas)
toIfaceClassOp (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty)
IfaceClassOp (getOccName sel_id) (toDmSpec def_meth) (toIfaceType op_ty)
where
-- Be careful when splitting the type, because of things
-- like class Foo a where
......@@ -1343,6 +1343,10 @@ tyThingToIfaceDecl (AClass clas)
(sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
op_ty = funResultTy rho_ty
toDmSpec NoDefMeth = NoDM
toDmSpec GenDefMeth = GenericDM
toDmSpec (DefMeth _) = VanillaDM
toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2)
tyThingToIfaceDecl (ATyCon tycon)
......
......@@ -158,8 +158,7 @@ rnTopBindsLHS :: MiniFixityEnv
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
rnTopBindsLHS fix_env binds
= do { mod <- getModule
; rnValBindsLHSFromDoc (topRecNameMaker mod fix_env) binds }
= rnValBindsLHSFromDoc (topRecNameMaker fix_env) binds
rnTopBindsRHS :: NameSet -- Names bound by these binds
-> HsValBindsLR Name RdrName
......
......@@ -51,7 +51,7 @@ import NameEnv
import UniqFM
import DataCon ( dataConFieldLabels )
import OccName
import Module ( Module, ModuleName )
import Module ( ModuleName )
import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE,
consDataConKey, forall_tv_RDR )
import Unique
......@@ -82,8 +82,8 @@ thenM = (>>=)
%*********************************************************
\begin{code}
newTopSrcBinder :: Module -> Located RdrName -> RnM Name
newTopSrcBinder this_mod (L loc rdr_name)
newTopSrcBinder :: Located RdrName -> RnM Name
newTopSrcBinder (L loc rdr_name)
| Just name <- isExact_maybe rdr_name
= -- This is here to catch
-- (a) Exact-name binders created by Template Haskell
......@@ -95,13 +95,15 @@ newTopSrcBinder this_mod (L loc rdr_name)
-- data T = (,) Int Int
-- unless we are in GHC.Tup
ASSERT2( isExternalName name, ppr name )
do { unless (this_mod == nameModule name)
do { this_mod <- getModule
; unless (this_mod == nameModule name)
(addErrAt loc (badOrigBinding rdr_name))
; return name }
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
= do { this_mod <- getModule
; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
(addErrAt loc (badOrigBinding rdr_name))
-- When reading External Core we get Orig names as binders,
-- but they should agree with the module gotten from the monad
......@@ -137,7 +139,8 @@ newTopSrcBinder this_mod (L loc rdr_name)
; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
else
-- Normal case
newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }
do { this_mod <- getModule
; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } }
\end{code}
%*********************************************************
......
......@@ -410,7 +410,6 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs,
; val_names <- mapM new_simple val_bndrs
; return (val_names ++ tc_names ++ ti_names) }
where
mod = tcg_mod gbl_env
is_hs_boot = isHsBoot (tcg_src gbl_env) ;
for_hs_bndrs :: [Located RdrName]
......@@ -424,19 +423,19 @@ get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs,
new_simple :: Located RdrName -> RnM (GenAvailInfo Name)
new_simple rdr_name = do
nm <- newTopSrcBinder mod rdr_name
nm <- newTopSrcBinder rdr_name
return (Avail nm)
new_tc tc_decl -- NOT for type/data instances
= do { main_name <- newTopSrcBinder mod main_rdr
; sub_names <- mapM (newTopSrcBinder mod) sub_rdrs
= do { main_name <- newTopSrcBinder main_rdr
; sub_names <- mapM newTopSrcBinder sub_rdrs
; return (AvailTC main_name (main_name : sub_names)) }
where
(main_rdr : sub_rdrs) = hsTyClDeclBinders tc_decl
new_ti tc_name_env ti_decl -- ONLY for type/data instances
= do { main_name <- lookupFamInstDeclBndr tc_name_env main_rdr
; sub_names <- mapM (newTopSrcBinder mod) sub_rdrs
; sub_names <- mapM newTopSrcBinder sub_rdrs
; return (AvailTC main_name sub_names) }
-- main_name is not bound here!
where
......
......@@ -45,8 +45,8 @@ import PrelNames
import Constants ( mAX_TUPLE_SIZE )
import Name
import NameSet
import Module
import RdrName
import BasicTypes
import ListSetOps ( removeDups, minusList )
import Outputable
import SrcLoc
......@@ -135,15 +135,14 @@ data NameMaker
| LetMk -- Let bindings, incl top level
-- Do *not* check for unused bindings
(Maybe Module) -- Just m => top level of module m
-- Nothing => not top level
TopLevelFlag
MiniFixityEnv
topRecNameMaker :: Module -> MiniFixityEnv -> NameMaker
topRecNameMaker mod fix_env = LetMk (Just mod) fix_env
topRecNameMaker :: MiniFixityEnv -> NameMaker
topRecNameMaker fix_env = LetMk TopLevel fix_env
localRecNameMaker :: MiniFixityEnv -> NameMaker
localRecNameMaker fix_env = LetMk Nothing fix_env
localRecNameMaker fix_env = LetMk NotTopLevel fix_env
matchNameMaker :: HsMatchContext a -> NameMaker
matchNameMaker ctxt = LamMk report_unused
......@@ -162,11 +161,11 @@ newName (LamMk report_unused) rdr_name
; when report_unused $ warnUnusedMatches [name] fvs
; return (res, name `delFV` fvs) })
newName (LetMk mb_top fix_env) rdr_name
newName (LetMk is_top fix_env) rdr_name
= CpsRn (\ thing_inside ->
do { name <- case mb_top of
Nothing -> newLocalBndrRn rdr_name
Just mod -> newTopSrcBinder mod rdr_name
do { name <- case is_top of
NotTopLevel -> newLocalBndrRn rdr_name
TopLevel -> newTopSrcBinder rdr_name
; bindLocalName name $ -- Do *not* use bindLocalNameFV here
-- See Note [View pattern usage]
addLocalFixities fix_env [name] $
......
......@@ -8,7 +8,7 @@ Typechecking class declarations
\begin{code}
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody,
mkGenericDefMethBind, getGenericInstances, mkDefMethRdrName,
mkGenericDefMethBind, getGenericInstances,
tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
......@@ -17,7 +17,6 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
import HsSyn
import RnHsSyn
import RnExpr
import RnEnv
import Inst
import InstEnv
import TcEnv
......@@ -27,6 +26,7 @@ import TcHsType
import TcMType
import TcType
import TcRnMonad
import BuildTyCl( TcMethInfo )
import Generics
import Class
import TyCon
......@@ -36,7 +36,6 @@ import Name
import Var
import NameEnv
import NameSet
import RdrName
import Outputable
import PrelNames
import DynFlags
......@@ -99,54 +98,44 @@ tcClassSigs :: Name -- Name of the class
-> LHsBinds Name
-> TcM [TcMethInfo]
type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate
-- between tcClassSigs and buildClass
tcClassSigs clas sigs def_methods
= do { dm_env <- checkDefaultBinds clas op_names def_methods
; mapM (tcClassSig dm_env) op_sigs }
= do { dm_env <- mapM (addLocM (checkDefaultBind clas op_names))
(bagToList def_methods)
; mapM (tcClassSig (mkNameEnv dm_env)) op_sigs }
where
op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs]
op_names = [n | (L _ (TypeSig (L _ n) _)) <- op_sigs]
checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, DefMethSpec)
-- Check default bindings
-- a) must be for a class op for this class
-- b) must be all generic or all non-generic
-- and return a mapping from class-op to Bool
-- where True <=> it's a generic default method
checkDefaultBinds clas ops binds
= do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
return (mkNameEnv dm_infos)
checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, Bool)
checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
= do { -- Check that the op is from this class
checkTc (op `elem` ops) (badMethodErr clas op)
checkTc (op `elem` ops) (badMethodErr clas op)
-- Check that all the defns ar generic, or none are
; checkTc (all_generic || none_generic) (mixedGenericErr op)
; return (op, all_generic)
; case (none_generic, all_generic) of
(True, _) -> return (op, VanillaDM)
(_, True) -> return (op, GenericDM)
_ -> failWith (mixedGenericErr op)
}
where
n_generic = count (isJust . maybeGenericMatch) matches
none_generic = n_generic == 0
all_generic = matches `lengthIs` n_generic
checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
tcClassSig :: NameEnv Bool -- Info about default methods;
tcClassSig :: NameEnv DefMethSpec -- Info about default methods;
-> LSig Name
-> TcM TcMethInfo
tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
= setSrcSpan loc $ do
{ op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
; let dm = case lookupNameEnv dm_env op_name of
Nothing -> NoDefMeth
Just False -> DefMeth
Just True -> GenDefMeth
; let dm = lookupNameEnv dm_env op_name `orElse` NoDM
; return (op_name, dm, op_ty) }
tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
\end{code}
......@@ -189,32 +178,32 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
; let tc_dm = tcDefMeth clas clas_tyvars
this_dict default_binds
sig_fn prag_fn
-- tc_dm is called only for a sel_id
-- that has a binding in default_binds
dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
-- Generate code for polymorphic default methods only (hence DefMeth)
-- (Generic default methods have turned into instance decls by now.)
-- 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.)
; (dm_ids, defm_binds) <- tcExtendTyVarEnv clas_tyvars $
mapAndUnzipM tc_dm dm_sel_ids
; dm_stuff <- tcExtendTyVarEnv clas_tyvars $
mapM tc_dm op_items
; let (dm_ids, defm_binds) = unzip (catMaybes dm_stuff)
; return (dm_ids, listToBag defm_binds) }
tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
tcDefMeth :: Class -> [TyVar] -> Inst -> LHsBinds Name
-> TcSigFun -> TcPragFun -> Id
-> TcM (Id, LHsBind Id)
tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn sel_id
= do { let sel_name = idName sel_id
; dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name)
; local_dm_name <- newLocalName sel_name
-- Base the local_dm_name on the selector name, becuase
-> TcSigFun -> TcPragFun -> ClassOpItem
-> TcM (Maybe (Id, LHsBind Id))
-- Generate code for polymorphic default methods only (hence DefMeth)
-- (Generic default methods have turned into instance decls by now.)
-- 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 sig_fn prag_fn (sel_id, dm_info)
= case dm_info of
NoDefMeth -> return Nothing
GenDefMeth -> return Nothing
DefMeth dm_name -> do
{ let sel_name = idName sel_id
; local_dm_name <- newLocalName sel_name
-- Base the local_dm_name on the selector name, because
-- type errors from tcInstanceMethodBody come from here
-- See Note [Silly default-method bind]
......@@ -222,8 +211,7 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn sel_id
; let meth_bind = findMethodBind sel_name local_dm_name binds_in
`orElse` pprPanic "tcDefMeth" (ppr sel_id)
-- We only call tcDefMeth on selectors for which
-- there is a binding in binds_in
-- dm_info = DefMeth dm_name only if there is a binding in binds_in
dm_sig_fn _ = sig_fn sel_name
dm_ty = idType sel_id
......@@ -238,7 +226,8 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn sel_id
(ptext (sLit "Ignoring SPECIALISE pragmas on default method")
<+> quotes (ppr sel_name))
; tcInstanceMethodBody (instLoc this_dict)
; liftM Just $
tcInstanceMethodBody (instLoc this_dict)
tyvars [this_dict]
([], emptyBag)
dm_id_w_inline local_dm_id
......@@ -282,9 +271,6 @@ tcInstanceMethodBody inst_loc tyvars dfun_dicts
\end{code}
\begin{code}
mkDefMethRdrName :: Name -> RdrName
mkDefMethRdrName sel_name = mkDerivedRdrName sel_name mkDefaultMethodOcc
instantiateMethod :: Class -> Id -> [TcType] -> TcType
-- Take a class operation, say
-- op :: forall ab. C a => forall c. Ix c => (b,c) -> a
......
......@@ -21,7 +21,6 @@ import FamInst
import FamInstEnv
import TcDeriv
import TcEnv
import RnEnv ( lookupGlobalOccRn )
import RnSource ( addTcgDUs )
import TcHsType
import TcUnify
......@@ -1026,7 +1025,7 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
; tc_body meth_bind }
tc_default DefMeth -- An polymorphic default method
tc_default (DefMeth dm_name) -- An polymorphic default method
= do { -- Build the typechecked version directly,
-- without calling typecheck_method;
-- see Note [Default methods in instances]
......@@ -1034,8 +1033,7 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys
-- in $dm inst_tys this
-- The 'let' is necessary only because HsSyn doesn't allow
-- you to apply a function to a dictionary *expression*.
dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
-- Might not be imported, but will be an OrigName
; dm_id <- tcLookupId dm_name
; let dm_inline_prag = idInlinePragma dm_id
rhs = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
......
......@@ -338,9 +338,12 @@ tcBracket brack res_ty
-- it again when we actually use it.
; pending_splices <- newMutVar []
; lie_var <- getLIEVar
; let brack_stage = Brack cur_stage pending_splices lie_var
; (meta_ty, lie) <- setStage brack_stage $
getLIE $
tc_bracket cur_stage brack
; (meta_ty, lie) <- setStage (Brack cur_stage pending_splices lie_var)
(getLIE (tc_bracket cur_stage brack))
; tcSimplifyBracket lie
-- Make the expected type have the right shape
......@@ -381,6 +384,10 @@ tc_bracket _ (DecBrG decls)
= do { _ <- tcTopSrcDecls emptyModDetails decls
-- Typecheck the declarations, dicarding the result
-- We'll get all that stuff later, when we splice it in
-- Top-level declarations in the bracket get unqualified names
-- See Note [Top-level Names in Template Haskell decl quotes] in RnNames
; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
tc_bracket _ (PatBr pat)
......
......@@ -71,7 +71,7 @@ type ClassOpItem = (Id, DefMeth)
-- Default-method info
data DefMeth = NoDefMeth -- No default method
| DefMeth -- A polymorphic default method
| DefMeth Name -- A polymorphic default method
| GenDefMeth -- A generic default method
deriving Eq
\end{code}
......@@ -173,8 +173,8 @@ instance Show Class where
showsPrec p c = showsPrecSDoc p (ppr c)
instance Outputable DefMeth where
ppr DefMeth = text "{- has default method -}"
ppr GenDefMeth = text "{- has generic method -}"
ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n
ppr GenDefMeth = ptext (sLit "Generic default method")
ppr NoDefMeth = empty -- No default method
pprFundeps :: Outputable a => [FunDep a] -> SDoc
......
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