Commit 0877011a authored by simonpj's avatar simonpj
Browse files

[project @ 2003-01-13 17:01:22 by simonpj]

------------------------------------
	(a) Improve reporting of staging errors
	(b) Tidy up the construction of dict funs
			and default methods
	------------------------------------
parent 61d8dc50
......@@ -68,8 +68,8 @@ import DataCon ( DataCon,
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,
......@@ -755,7 +755,8 @@ BUT make sure they are *exported* LocalIds (setIdLocalExported) so
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]
......@@ -765,7 +766,7 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-> 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)
......
......@@ -250,7 +250,7 @@ ifaceTyThing (AClass clas) = cls_decl
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
......@@ -259,10 +259,6 @@ ifaceTyThing (AClass clas) = cls_decl
-- 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
......
......@@ -21,7 +21,7 @@ module Inst (
ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
instLoc, getDictClassTys, dictPred,
lookupInst, lookupSimpleInst, LookupInstResult(..),
lookupInst, LookupInstResult(..),
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
......@@ -43,7 +43,7 @@ import TcHsSyn ( TcExpr, TcId, TcIdSet, TypecheckedHsExpr,
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
......@@ -540,7 +540,7 @@ lookupInst :: Inst -> TcM (LookupInstResult s)
-- 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
......@@ -551,6 +551,10 @@ lookupInst dict@(Dict _ (ClassP clas tys) loc)
-- 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
......@@ -616,28 +620,6 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
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}
%************************************************************************
......
......@@ -385,10 +385,8 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
-- 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] ->
......@@ -416,7 +414,7 @@ tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
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}
......
......@@ -37,7 +37,8 @@ module TcEnv(
RecTcGblEnv, tcLookupRecId_maybe,
-- Template Haskell stuff
wellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
checkWellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
topIdLvl,
-- New Ids
newLocalName, newDFunName,
......@@ -104,11 +105,41 @@ metaLevel Comp = topLevel
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
......@@ -182,9 +213,11 @@ newLocalName name -- Make a clone
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
......@@ -339,22 +372,9 @@ tcLookupIdLvl 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...
......
......@@ -13,7 +13,7 @@ import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
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
......@@ -805,8 +805,10 @@ tcId name -- Look up the Id and instantiate its type
-- 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
......@@ -829,11 +831,7 @@ tcId name -- Look up the Id and instantiate its type
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
......@@ -1050,12 +1048,6 @@ Boring and alphabetical:
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)
......@@ -1123,7 +1115,6 @@ missingStrictFields con fields
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:")
......
......@@ -545,9 +545,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
-- 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
......@@ -593,7 +590,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
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_`
......
......@@ -57,8 +57,7 @@ import Inst ( showLIE )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
import TcEnv ( RecTcGblEnv,
tcExtendGlobalValEnv,
import TcEnv ( tcExtendGlobalValEnv,
tcExtendGlobalEnv,
tcExtendInstEnv, tcExtendRules,
tcLookupTyCon, tcLookupGlobal,
......
......@@ -355,7 +355,7 @@ topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level spli
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:
......
......@@ -129,21 +129,10 @@ tcSpliceExpr name expr res_ty
-- 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_`
......@@ -163,6 +152,23 @@ tcTopSplice expr res_ty
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}
......@@ -177,15 +183,10 @@ tcTopSplice expr res_ty
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_`
......
......@@ -63,6 +63,7 @@ type ClassOpItem = (Id, DefMeth Name)
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}
......
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