Arity,
- FunctionOrData(..),
+ FunctionOrData(..),
WarningTxt(..),
HsBang(..), isBanged, isMarkedUnboxed,
StrictnessMark(..), isMarkedStrict,
+ DefMethSpec(..),
+
CompilerPhase,
Activation(..), isActive, isNeverActive, isAlwaysActive, isEarlyActive,
RuleMatchInfo(..), isConLike, isFunLike,
%************************************************************************
%* *
-\subsection{Strictness indication}
+ Strictness indication
%* *
%************************************************************************
%************************************************************************
%* *
+ 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}
%* *
%************************************************************************
mkRdrUnqual, mkRdrQual,
mkUnqual, mkVarUnqual, mkQual, mkOrig,
nameRdrName, getRdrName,
- mkDerivedRdrName,
-- ** Destruction
rdrNameOcc, rdrNameSpace, setRdrNameSpace,
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
mkUnqual :: NameSpace -> FastString -> RdrName
import Module
import Name
import VarEnv
-import Class
import DynFlags
import UniqFM
import UniqSupply
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
\begin{code}
module BuildTyCl (
buildSynTyCon, buildAlgTyCon, buildDataCon,
- buildClass,
+ TcMethInfo, buildClass,
mkAbstractTyConRhs, mkOpenDataTyConRhs,
mkNewTyConRhs, mkDataTyConRhs, setAssocFamilyPermutation
) where
------------------------------------------------------
\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
; 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
-- 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)
; 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]
-- 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
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
(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)
-> 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
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
%*********************************************************
\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
-- 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
; 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}
%*********************************************************
; 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]
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
import Constants ( mAX_TUPLE_SIZE )
import Name
import NameSet
-import Module
import RdrName
+import BasicTypes
import ListSetOps ( removeDups, minusList )
import Outputable
import SrcLoc
| 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
; 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] $
\begin{code}
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody,
- mkGenericDefMethBind, getGenericInstances, mkDefMethRdrName,
+ mkGenericDefMethBind, getGenericInstances,
tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
import HsSyn
import RnHsSyn
import RnExpr
-import RnEnv
import Inst
import InstEnv
import TcEnv
import TcMType
import TcType
import TcRnMonad
+import BuildTyCl( TcMethInfo )
import Generics
import Class
import TyCon
import Var
import NameEnv
import NameSet
-import RdrName
import Outputable
import PrelNames
import DynFlags
-> 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}
; 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]
; 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
(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
\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
import FamInstEnv
import TcDeriv
import TcEnv
-import RnEnv ( lookupGlobalOccRn )
import RnSource ( addTcgDUs )
import TcHsType
import TcUnify
= 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]
-- 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) $
-- 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
= 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)
-- 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}
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
projects / ghc-hetmet.git / commitdiff