dataConSig, dataConStrictMarks, dataConWorkId,
splitProductType
)
-import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
- mkTemplateLocals, mkTemplateLocalsNum,
+import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkLocalId,
+ mkTemplateLocals, mkTemplateLocalsNum, setIdLocalExported,
mkTemplateLocal, idNewStrictness, idName
)
import IdInfo ( IdInfo, noCafIdInfo, hasCafIdInfo,
that they aren't discarded by the occurrence analyser.
\begin{code}
-mkDefaultMethodId dm_name ty = mkVanillaGlobal dm_name ty noCafIdInfo
+mkDefaultMethodId dm_name ty
+ = setIdLocalExported (mkLocalId dm_name ty)
mkDictFunId :: Name -- Name to use for the dict fun;
-> [TyVar]
-> Id
mkDictFunId dfun_name inst_tyvars dfun_theta clas inst_tys
- = mkVanillaGlobal dfun_name dfun_ty noCafIdInfo
+ = setIdLocalExported (mkLocalId dfun_name dfun_ty)
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
toClassOpSig (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
- ClassOpSig (getName sel_id) def_meth' (toHsType op_ty) noSrcLoc
+ ClassOpSig (getName sel_id) def_meth (toHsType op_ty) noSrcLoc
where
-- Be careful when splitting the type, because of things
-- like class Foo a where
-- op :: (Ord a) => a -> a
(sel_tyvars, rho_ty) = tcSplitForAllTys (idType sel_id)
op_ty = tcFunResultTy rho_ty
- def_meth' = case def_meth of
- NoDefMeth -> NoDefMeth
- GenDefMeth -> GenDefMeth
- DefMeth id -> DefMeth (getName id)
ifaceTyThing (ATyCon tycon) = ty_decl
where
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
- lookupInst, lookupSimpleInst, LookupInstResult(..),
+ lookupInst, LookupInstResult(..),
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
)
import TcRnMonad
-import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon )
+import TcEnv ( tcGetInstEnv, tcLookupId, tcLookupTyCon, checkWellStaged, topIdLvl )
import InstEnv ( InstLookupResult(..), lookupInstEnv )
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
-- Dictionaries
-lookupInst dict@(Dict _ (ClassP clas tys) loc)
+lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
= getDOpts `thenM` \ dflags ->
tcGetInstEnv `thenM` \ inst_env ->
case lookupInstEnv dflags inst_env clas tys of
-- instance C X a => D X where ...
-- (presumably there's a functional dependency in class C)
-- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
+ getStage `thenM` \ use_stage ->
+ checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
+ (topIdLvl dfun_id) use_stage `thenM_`
+ traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_`
let
(tyvars, rho) = tcSplitForAllTys (idType dfun_id)
mk_ty_arg tv = case lookupSubstEnv tenv tv of
returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit))
\end{code}
-There is a second, simpler interface, when you want an instance of a
-class at a given nullary type constructor. It just returns the
-appropriate dictionary if it exists. It is used only when resolving
-ambiguous dictionaries.
-
-\begin{code}
-lookupSimpleInst :: Class
- -> [Type] -- Look up (c,t)
- -> TcM (Maybe ThetaType) -- Here are the needed (c,t)s
-
-lookupSimpleInst clas tys
- = getDOpts `thenM` \ dflags ->
- tcGetInstEnv `thenM` \ inst_env ->
- case lookupInstEnv dflags inst_env clas tys of
- FoundInst tenv dfun
- -> returnM (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
- where
- (_, rho) = tcSplitForAllTys (idType dfun)
- (theta,_) = tcSplitPhiTy rho
-
- other -> returnM Nothing
-\end{code}
%************************************************************************
-- TyGenNever (in MkId). Ugh! KSW 1999-09.
theta = [mkClassPred clas inst_tys]
- dm_id = mkDefaultMethodId dm_name dm_ty
- local_dm_id = setIdLocalExported dm_id
- -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
- xtve = tyvars `zip` clas_tyvars
+ local_dm_id = mkDefaultMethodId dm_name dm_ty
+ xtve = tyvars `zip` clas_tyvars
in
newDicts origin theta `thenM` \ [this_dict] ->
emptyNameSet -- No inlines (yet)
(dict_binds `andMonoBinds` defm_bind)
in
- returnM (full_bind, [dm_id])
+ returnM (full_bind, [local_dm_id])
where
origin = ClassDeclOrigin
\end{code}
RecTcGblEnv, tcLookupRecId_maybe,
-- Template Haskell stuff
- wellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
+ checkWellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
+ topIdLvl,
-- New Ids
newLocalName, newDFunName,
metaLevel (Splice l) = l
metaLevel (Brack l _ _) = l
-wellStaged :: Level -- Binding level
- -> Level -- Use level
- -> Bool
-wellStaged bind_stage use_stage
- = bind_stage <= use_stage
+
+checkWellStaged :: SDoc -- What the stage check is for
+ -> Level -- Binding level
+ -> Stage -- Use stage
+ -> TcM () -- Fail if badly staged, adding an error
+checkWellStaged pp_thing bind_lvl use_stage
+ | bind_lvl <= use_lvl -- OK!
+ = returnM ()
+
+ | bind_lvl == topLevel -- GHC restriction on top level splices
+ = failWithTc $
+ sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
+ nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
+
+ | otherwise -- Badly staged
+ = failWithTc $
+ ptext SLIT("Stage error:") <+> pp_thing <+>
+ hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
+ ptext SLIT("but used at stage") <+> ppr use_lvl]
+ where
+ use_lvl = metaLevel use_stage
+
+
+topIdLvl :: Id -> Level
+-- Globals may either be imported, or may be from an earlier "chunk"
+-- (separated by declaration splices) of this module. The former
+-- *can* be used inside a top-level splice, but the latter cannot.
+-- Hence we give the former impLevel, but the latter topLevel
+-- E.g. this is bad:
+-- x = [| foo |]
+-- $( f x )
+-- By the time we are prcessing the $(f x), the binding for "x"
+-- will be in the global env, not the local one.
+topIdLvl id | isLocalId id = topLevel
+ | otherwise = impLevel
-- Indicates the legal transitions on bracket( [| |] ).
bracketOK :: Stage -> Maybe Level
returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
\end{code}
-Make a name for the dict fun for an instance decl.
-It's a *local* name for the moment. The CoreTidy pass
-will externalise it.
+Make a name for the dict fun for an instance decl. It's a *local*
+name for the moment. The CoreTidy pass will externalise it. Even in
+--make and ghci stuff, we rebuild the instance environment each time,
+so the dfun id is internal to begin with, and external when compiling
+other modules
\begin{code}
newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
= tcLookup name `thenM` \ thing ->
case thing of
ATcId tc_id lvl -> returnM (tc_id, lvl)
- AGlobal (AnId id) -- See [Note: Levels]
- | isLocalId id -> returnM (id, topLevel)
- | otherwise -> returnM (id, impLevel)
+ AGlobal (AnId id) -> returnM (id, topIdLvl id)
other -> pprPanic "tcLookupIdLvl" (ppr name)
--- [Note: Levels]
--- Globals may either be imported, or may be from an earlier "chunk"
--- (separated by declaration splices) of this module. The former
--- *can* be used inside a top-level splice, but the latter cannot.
--- Hence we give the former impLevel, but the latter topLevel
--- E.g. this is bad:
--- x = [| foo |]
--- $( f x )
--- By the time we are prcessing the $(f x), the binding for "x"
--- will be in the global env, not the local one.
-
tcLookupLocalIds :: [Name] -> TcM [TcId]
-- We expect the variables to all be bound, and all at
-- the same level as the lookup. Only used in one place...
import HsSyn ( HsReify(..), ReifyFlavour(..) )
import TcType ( isTauTy )
import TcEnv ( bracketOK, tcMetaTy, tcLookupGlobal,
- wellStaged, metaLevel )
+ checkWellStaged, metaLevel )
import TcSimplify ( tcSimplifyBracket )
import Name ( isExternalName )
import qualified DsMeta
-- If 'x' occurs many times we may get many identical
-- bindings of the same splice proxy, but that doesn't
-- matter, although it's a mite untidy.
- -- NB: isExernalName is true of top level things,
- -- and false of nested bindings
+ --
+ -- NB: During type-checking, isExernalName is true of
+ -- top level things, and false of nested bindings
+ -- Top-level things don't need lifting.
let
id_ty = idType id
returnM (HsVar id, id_ty))
other ->
- let
- use_lvl = metaLevel use_stage
- in
- checkTc (wellStaged bind_lvl use_lvl)
- (badStageErr id bind_lvl use_lvl) `thenM_`
+ checkWellStaged (quotes (ppr id)) bind_lvl use_stage `thenM_`
#endif
-- This is the bit that handles the no-Template-Haskell case
case isDataConWrapId_maybe id of
arithSeqCtxt expr
= hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
-
-badStageErr id bind_lvl use_lvl
- = ptext SLIT("Stage error:") <+> quotes (ppr id) <+>
- hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
- ptext SLIT("but used at stage") <+> ppr use_lvl]
-
parrSeqCtxt expr
= hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr)
header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
ptext SLIT("does not have the required strict field(s)")
-
missingFields :: DataCon -> [FieldLabel] -> SDoc
missingFields con fields
= ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
-- Create the result bindings
let
- local_dfun_id = setIdLocalExported dfun_id
- -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
-
dict_constr = classDataCon clas
scs_and_meths = map instToId sc_dicts ++ meth_ids
this_dict_id = instToId this_dict
main_bind = AbsBinds
zonked_inst_tyvars
(map instToId dfun_arg_dicts)
- [(inst_tyvars', local_dfun_id, this_dict_id)]
+ [(inst_tyvars', dfun_id, this_dict_id)]
inlines all_binds
in
showLIE "instance" `thenM_`
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
-import TcEnv ( RecTcGblEnv,
- tcExtendGlobalValEnv,
+import TcEnv ( tcExtendGlobalValEnv,
tcExtendGlobalEnv,
tcExtendInstEnv, tcExtendRules,
tcLookupTyCon, tcLookupGlobal,
impLevel, topLevel :: Level
-topLevel = 1 -- Things dedined at top level of this module
+topLevel = 1 -- Things defined at top level of this module
impLevel = 0 -- Imported things; they can be used inside a top level splice
--
-- For example:
-- inner escape before dealing with the outer one
tcTopSplice expr res_ty
- = checkNoErrs (
- -- checkNoErrs: must not try to run the thing
- -- if the type checker fails!
+ = tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
- tcMetaTy exprTyConName `thenM` \ meta_exp_ty ->
- setStage topSpliceStage (
- getLIE (tcMonoExpr expr meta_exp_ty)
- ) `thenM` \ (expr', lie) ->
-
- -- Solve the constraints
- tcSimplifyTop lie `thenM` \ const_binds ->
-
- -- Wrap the bindings around it and zonk
- zonkTopExpr (mkHsLet const_binds expr')
- ) `thenM` \ zonked_q_expr ->
+ -- Typecheck the expression
+ tcTopSpliceExpr expr meta_exp_ty `thenM` \ zonked_q_expr ->
-- Run the expression
traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
importSupportingDecls fvs `thenM` \ env ->
setGblEnv env (tcMonoExpr exp3 res_ty)
+
+
+tcTopSpliceExpr :: RenamedHsExpr -> TcType -> TcM TypecheckedHsExpr
+tcTopSpliceExpr expr meta_ty
+ = checkNoErrs $ -- checkNoErrs: must not try to run the thing
+ -- if the type checker fails!
+
+ setStage topSpliceStage $
+
+ -- Typecheck the expression
+ getLIE (tcMonoExpr expr meta_ty) `thenM` \ (expr', lie) ->
+
+ -- Solve the constraints
+ tcSimplifyTop lie `thenM` \ const_binds ->
+
+ -- And zonk it
+ zonkTopExpr (mkHsLet const_binds expr')
\end{code}
tcSpliceDecls expr
= tcMetaTy decTyConName `thenM` \ meta_dec_ty ->
tcMetaTy qTyConName `thenM` \ meta_q_ty ->
- setStage topSpliceStage (
- getLIE (tcMonoExpr expr (mkAppTy meta_q_ty (mkListTy meta_dec_ty)))
- ) `thenM` \ (expr', lie) ->
- -- Solve the constraints
- tcSimplifyTop lie `thenM` \ const_binds ->
- let
- q_expr = mkHsLet const_binds expr'
+ let
+ list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty)
in
- zonkTopExpr q_expr `thenM` \ zonked_q_expr ->
+ tcTopSpliceExpr expr list_q `thenM` \ zonked_q_expr ->
-- Run the expression
traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_`
data DefMeth id = NoDefMeth -- No default method
| DefMeth id -- A polymorphic default method (named id)
+ -- (Only instantiated to RdrName and Name, never Id)
| GenDefMeth -- A generic default method
deriving Eq
\end{code}
projects / ghc-hetmet.git / commitdiff