TyThing(..), TyThingDetails(..), TcTyThing(..), TcId,
-- Instance environment, and InstInfo type
- tcGetInstEnv, tcSetInstEnv,
+ tcGetInstEnv,
InstInfo(..), pprInstInfo, pprInstInfoDetails,
simpleInstInfoTy, simpleInstInfoTyCon,
InstBindings(..),
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendLocalValEnv, tcExtendLocalValEnv2,
tcLookup, tcLookupLocalIds, tcLookup_maybe,
- tcLookupId, tcLookupIdLvl,
+ tcLookupId,
lclEnvElts, getInLocalScope, findGlobals,
-- Instance environment
- tcExtendLocalInstEnv, tcExtendInstEnv,
+ tcExtendLocalInstEnv, tcExtendInstEnv, tcExtendTempInstEnv, tcWithTempInstEnv,
-- Rules
tcExtendRules,
-- Global type variables
tcGetGlobalTyVars,
- -- Random useful things
- RecTcGblEnv, tcLookupRecId_maybe,
-
-- Template Haskell stuff
- checkWellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
+ checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
topIdLvl,
+ -- Arrow stuff
+ checkProcLevel,
+
-- New Ids
newLocalName, newDFunName,
)
import qualified Type ( getTyVar_maybe )
import Rules ( extendRuleBase )
-import Id ( idName, isLocalId, isDataConWrapId_maybe )
+import Id ( idName, isLocalId )
import Var ( TyVar, Id, idType )
import VarSet
import VarEnv
)
import NameEnv
import OccName ( mkDFunOcc, occNameString )
-import HscTypes ( DFunId, TypeEnv, extendTypeEnvList,
+import HscTypes ( DFunId, TypeEnv, extendTypeEnvList, lookupType,
TyThing(..), ExternalPackageState(..) )
import Rules ( RuleBase )
import BasicTypes ( EP )
import Module ( Module )
import InstEnv ( InstEnv, extendInstEnv )
-import Maybes ( seqMaybe )
import SrcLoc ( SrcLoc )
import Outputable
import Maybe ( isJust )
%************************************************************************
%* *
+ Arrow notation proc levels
+%* *
+%************************************************************************
+
+\begin{code}
+checkProcLevel :: TcId -> ProcLevel -> TcM ()
+checkProcLevel id id_lvl
+ = do { banned <- getBannedProcLevels
+ ; checkTc (not (id_lvl `elem` banned))
+ (procLevelErr id id_lvl) }
+
+procLevelErr id id_lvl
+ = hang (ptext SLIT("Command-bound variable") <+> quotes (ppr id) <+> ptext SLIT("is not in scope here"))
+ 4 (ptext SLIT("Reason: it is used in the left argument of (-<)"))
+\end{code}
+
+
+%************************************************************************
+%* *
Meta level
%* *
%************************************************************************
\begin{code}
-instance Outputable Stage where
+instance Outputable ThStage where
ppr Comp = text "Comp"
ppr (Brack l _ _) = text "Brack" <+> int l
ppr (Splice l) = text "Splice" <+> int l
-metaLevel :: Stage -> Level
-metaLevel Comp = topLevel
-metaLevel (Splice l) = l
-metaLevel (Brack l _ _) = l
+thLevel :: ThStage -> ThLevel
+thLevel Comp = topLevel
+thLevel (Splice l) = l
+thLevel (Brack l _ _) = l
checkWellStaged :: SDoc -- What the stage check is for
- -> Level -- Binding level
- -> Stage -- Use stage
+ -> ThLevel -- Binding level
+ -> ThStage -- Use stage
-> TcM () -- Fail if badly staged, adding an error
checkWellStaged pp_thing bind_lvl use_stage
| bind_lvl <= use_lvl -- OK!
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
+ use_lvl = thLevel use_stage
-topIdLvl :: Id -> Level
+topIdLvl :: Id -> ThLevel
-- 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.
| otherwise = impLevel
-- Indicates the legal transitions on bracket( [| |] ).
-bracketOK :: Stage -> Maybe Level
+bracketOK :: ThStage -> Maybe ThLevel
bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
-bracketOK stage = (Just (metaLevel stage + 1))
+bracketOK stage = (Just (thLevel stage + 1))
-- Indicates the legal transitions on splice($).
-spliceOK :: Stage -> Maybe Level
+spliceOK :: ThStage -> Maybe ThLevel
spliceOK (Splice _) = Nothing -- Splice illegal inside splice
-spliceOK stage = Just (metaLevel stage - 1)
+spliceOK stage = Just (thLevel stage - 1)
tcMetaTy :: Name -> TcM Type
-- Given the name of a Template Haskell data type,
%************************************************************************
%* *
-\subsection{Basic lookups}
-%* *
-%************************************************************************
-
-\begin{code}
-type RecTcGblEnv = TcGblEnv
--- This environment is used for getting the 'right' IdInfo
--- on imported things and for looking up Ids in unfoldings
--- The environment doesn't have any local Ids in it
-
-tcLookupRecId_maybe :: RecTcGblEnv -> Name -> Maybe Id
-tcLookupRecId_maybe env name = case lookup_global env name of
- Just (AnId id) -> Just id
- other -> Nothing
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Making new Ids}
%* *
%************************************************************************
(lcl_things, pkg_things) = partition (isLocalThing mod) things
ge' = extendTypeEnvList (tcg_type_env env) lcl_things
eps' = eps { eps_PTE = extendTypeEnvList (eps_PTE eps) pkg_things }
- ist' = mkImpTypeEnv eps' hpt
; setEps eps'
- ; setGblEnv (env {tcg_type_env = ge', tcg_ist = ist'}) thing_inside }
+ ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
-- Same deal as tcExtendGlobalEnv, but for Ids
\begin{code}
-lookup_global :: TcGblEnv -> Name -> Maybe TyThing
- -- Try the global envt and then the global symbol table
-lookup_global env name
- = lookupNameEnv (tcg_type_env env) name
- `seqMaybe`
- tcg_ist env name
-
tcLookupGlobal_maybe :: Name -> TcRn m (Maybe TyThing)
+-- This is a rather heavily-used function, so I've inlined a few things (e.g. getEps)
+-- Notice that for imported things we read the current version from the EPS
+-- mutable variable. This is important in situations like
+-- ...$(e1)...$(e2)...
+-- where the code that e1 expands to might import some defns that
+-- also turn out to be needed by the code that e2 expands to.
tcLookupGlobal_maybe name
- = getGblEnv `thenM` \ env ->
- returnM (lookup_global env name)
+ = do { env <- getGblEnv
+ ; if nameIsLocalOrFrom (tcg_mod env) name then
+ -- Defined in this module
+ return (lookupNameEnv (tcg_type_env env) name)
+ else
+ do { env <- getTopEnv
+ ; eps <- readMutVar (top_eps env)
+ ; return (lookupType (top_hpt env) (eps_PTE eps) name) }}
\end{code}
A variety of global lookups, when we know what we are looking for.
other -> notFound "tcLookupGlobal" name
tcLookupGlobalId :: Name -> TcM Id
+-- Never used for Haskell-source DataCons, hence no ADataCon case
tcLookupGlobalId name
= tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
case maybe_thing of
Just (AnId id) -> returnM id
- other -> notFound "tcLookupGlobal" name
+ other -> notFound "tcLookupGlobal (id)" name
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon con_name
- = tcLookupGlobalId con_name `thenM` \ con_id ->
- case isDataConWrapId_maybe con_id of
- Just data_con -> returnM data_con
- Nothing -> failWithTc (badCon con_id)
+ = tcLookupGlobal_maybe con_name `thenM` \ maybe_thing ->
+ case maybe_thing of
+ Just (ADataCon data_con) -> returnM data_con
+ other -> notFound "tcLookupDataCon" con_name
tcLookupClass :: Name -> TcM Class
tcLookupClass name
getInGlobalScope :: TcRn m (Name -> Bool)
-getInGlobalScope = do { gbl_env <- getGblEnv ;
- return (\n -> isJust (lookup_global gbl_env n)) }
+-- Get all things in the global environment; used for deciding what
+-- rules to suck in. Anything defined in this module (nameIsLocalOrFrom)
+-- is certainly in the envt, so we don't bother to look.
+getInGlobalScope
+ = do { mod <- getModule
+ ; eps <- getEps
+ ; hpt <- getHpt
+ ; return (\n -> nameIsLocalOrFrom mod n ||
+ isJust (lookupType hpt (eps_PTE eps) n)) }
\end{code}
tcLookupId :: Name -> TcM Id
-- Used when we aren't interested in the binding level
+-- Never a DataCon. (Why does that matter? see TcExpr.tcId)
tcLookupId name
= tcLookup name `thenM` \ thing ->
case thing of
- ATcId tc_id lvl -> returnM tc_id
+ ATcId tc_id _ _ -> returnM tc_id
AGlobal (AnId id) -> returnM id
other -> pprPanic "tcLookupId" (ppr name)
-tcLookupIdLvl :: Name -> TcM (Id, Level)
-tcLookupIdLvl name
- = tcLookup name `thenM` \ thing ->
- case thing of
- ATcId tc_id lvl -> returnM (tc_id, lvl)
- AGlobal (AnId id) -> returnM (id, topIdLvl id)
- other -> pprPanic "tcLookupIdLvl" (ppr name)
-
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...
tcLookupLocalIds ns
= getLclEnv `thenM` \ env ->
- returnM (map (lookup (tcl_env env) (metaLevel (tcl_level env))) ns)
+ returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
where
lookup lenv lvl name
= case lookupNameEnv lenv name of
- Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
- other -> pprPanic "tcLookupLocalIds" (ppr name)
+ Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id
+ other -> pprPanic "tcLookupLocalIds" (ppr name)
lclEnvElts :: TcLclEnv -> [TcTyThing]
lclEnvElts env = nameEnvElts (tcl_env env)
= getLclEnv `thenM` \ env ->
let
extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
- lvl = metaLevel (tcl_level env)
- extra_env = [(idName id, ATcId id lvl) | id <- ids]
+ th_lvl = thLevel (tcl_th_ctxt env)
+ proc_lvl = proc_level (tcl_arrow_ctxt env)
+ extra_env = [(idName id, ATcId id th_lvl proc_lvl) | id <- ids]
le' = extendNameEnvList (tcl_env env) extra_env
in
tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
= getLclEnv `thenM` \ env ->
let
extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
- lvl = metaLevel (tcl_level env)
- extra_env = [(name, ATcId id lvl) | (name,id) <- names_w_ids]
+ th_lvl = thLevel (tcl_th_ctxt env)
+ proc_lvl = proc_level (tcl_arrow_ctxt env)
+ extra_env = [(name, ATcId id th_lvl proc_lvl) | (name,id) <- names_w_ids]
le' = extendNameEnvList (tcl_env env) extra_env
in
tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
-----------------------
-find_thing ignore_it tidy_env (ATcId id _)
+find_thing ignore_it tidy_env (ATcId id _ _)
= zonkTcType (idType id) `thenM` \ id_ty ->
if ignore_it id_ty then
returnM (tidy_env, Nothing)
%* *
%************************************************************************
+The TcGblEnv holds a mutable variable containing the current full, instance environment.
+The ExtendInstEnv functions extend this environment by side effect, in case we are
+sucking in new instance declarations deep in the body of a TH splice, which are needed
+in another TH splice. The tcg_insts field of the TcGblEnv contains just the dfuns
+from this module
+
\begin{code}
tcGetInstEnv :: TcM InstEnv
-tcGetInstEnv = getGblEnv `thenM` \ env ->
- returnM (tcg_inst_env env)
-
-tcSetInstEnv :: InstEnv -> TcM a -> TcM a
-tcSetInstEnv ie thing_inside
- = getGblEnv `thenM` \ env ->
- setGblEnv (env {tcg_inst_env = ie}) thing_inside
+tcGetInstEnv = do { env <- getGblEnv; readMutVar (tcg_inst_env env) }
tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a
-- Add instances from local or imported
= do { dflags <- getDOpts
; eps <- getEps
; env <- getGblEnv
+ ; let ie_var = tcg_inst_env env
+ ; inst_env <- readMutVar ie_var
; let
-- Extend the total inst-env with the new dfuns
- (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
+ (inst_env', errs) = extendInstEnv dflags inst_env dfuns
-- Sort the ones from this module from the others
(lcl_dfuns, pkg_dfuns) = partition (isLocalThing mod) dfuns
(eps_inst_env', _) = extendInstEnv dflags (eps_inst_env eps) pkg_dfuns
eps' = eps { eps_inst_env = eps_inst_env' }
- env' = env { tcg_inst_env = inst_env',
- tcg_insts = lcl_dfuns ++ tcg_insts env }
+ env' = env { tcg_insts = lcl_dfuns ++ tcg_insts env }
; traceDFuns dfuns
; addErrs errs
+ ; writeMutVar ie_var inst_env'
; setEps eps'
; setGblEnv env' thing_inside }
tcExtendLocalInstEnv infos thing_inside
= do { dflags <- getDOpts
; env <- getGblEnv
+ ; let ie_var = tcg_inst_env env
+ ; inst_env <- readMutVar ie_var
; let
dfuns = map iDFunId infos
- (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
- env' = env { tcg_inst_env = inst_env',
- tcg_insts = dfuns ++ tcg_insts env }
+ (inst_env', errs) = extendInstEnv dflags inst_env dfuns
+ env' = env { tcg_insts = dfuns ++ tcg_insts env }
; traceDFuns dfuns
; addErrs errs
+ ; writeMutVar ie_var inst_env'
; setGblEnv env' thing_inside }
+tcExtendTempInstEnv :: [DFunId] -> TcM a -> TcM a
+ -- Extend the instance envt, but with *no* permanent
+ -- effect on mutable variables; also ignore errors
+ -- Used during 'deriving' stuff
+tcExtendTempInstEnv dfuns thing_inside
+ = do { dflags <- getDOpts
+ ; env <- getGblEnv
+ ; let ie_var = tcg_inst_env env
+ ; inst_env <- readMutVar ie_var
+ ; let (inst_env', errs) = extendInstEnv dflags inst_env dfuns
+ -- Ignore the errors about duplicate instances.
+ -- We don't want repeated error messages
+ -- They'll appear later, when we do the top-level extendInstEnvs
+ ; writeMutVar ie_var inst_env'
+ ; result <- thing_inside
+ ; writeMutVar ie_var inst_env -- Restore!
+ ; return result }
+
+tcWithTempInstEnv :: TcM a -> TcM a
+-- Run thing_inside, discarding any effects on the instance environment
+tcWithTempInstEnv thing_inside
+ = do { env <- getGblEnv
+ ; let ie_var = tcg_inst_env env
+ ; old_ie <- readMutVar ie_var
+ ; result <- thing_inside
+ ; writeMutVar ie_var old_ie -- Restore
+ ; return result }
+
traceDFuns dfuns
= traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
where
- pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
+ pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
\end{code}
projects / ghc-hetmet.git / blobdiff