%
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module TcEnv(
TyThing(..), TcTyThing(..), TcId,
InstBindings(..),
-- Global environment
- tcExtendGlobalEnv,
+ tcExtendGlobalEnv, setGlobalTypeEnv,
tcExtendGlobalValEnv,
tcLookupLocatedGlobal, tcLookupGlobal,
tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
- tcLookupLocatedClass, tcLookupFamInst,
+ tcLookupLocatedClass,
+ tcLookupFamInst, tcLookupDataFamInst,
-- Local environment
tcExtendKindEnv, tcExtendKindEnvTvs,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
- lclEnvElts, getInLocalScope, findGlobals,
+ getInLocalScope,
wrongThingErr, pprBinders,
- refineEnvironment,
+ getHetMetLevel,
tcExtendRecEnv, -- For knot-tying
-- Rules
tcExtendRules,
+ -- Defaults
+ tcGetDefaultTys,
+
-- Global type variables
tcGetGlobalTyVars,
-- Template Haskell stuff
- checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
- topIdLvl,
+ checkWellStaged, tcMetaTy, thLevel,
+ topIdLvl, thTopLevelId, thRnBrack, isBrackStage,
-- New Ids
- newLocalName, newDFunName, newFamInstTyConName,
+ newLocalName, newDFunName, newFamInstTyConName,
+ mkStableIdFromString, mkStableIdFromName
) where
#include "HsVersions.h"
import HsSyn
-import TcIface
import IfaceEnv
import TcRnMonad
import TcMType
import TcType
-import TcGadt
--- import TcSuspension
-import qualified Type
+import TcIface
+import PrelNames
+import TysWiredIn
+-- import qualified Type
+import Id
+import Coercion
import Var
import VarSet
-import VarEnv
+-- import VarEnv
import RdrName
import InstEnv
import FamInstEnv
import DataCon
import TyCon
import TypeRep
-import Coercion
import Class
import Name
-import PrelNames
import NameEnv
-import OccName
import HscTypes
+import DynFlags
import SrcLoc
import Outputable
-import Maybes
+import Unique
+import FastString
\end{code}
= do { env <- getGblEnv
-- Try local envt
- ; case lookupNameEnv (tcg_type_env env) name of {
+ ; case lookupNameEnv (tcg_type_env env) name of {
Just thing -> return thing ;
Nothing -> do
-- Try global envt
- { (eps,hpt) <- getEpsAndHpt
- ; dflags <- getDOpts
- ; case lookupType dflags hpt (eps_PTE eps) name of {
+ { hsc_env <- getTopEnv
+ ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
+ ; case mb_thing of {
Just thing -> return thing ;
Nothing -> do
-- Should it have been in the local envt?
{ case nameModule_maybe name of
- Nothing -> notFound name -- Internal names can happen in GHCi
+ Nothing -> notFound name -- Internal names can happen in GHCi
Just mod | mod == tcg_mod env -- Names from this module
- -> notFound name -- should be in tcg_type_env
- | mod == thFAKE -- Names bound in TH declaration brackets
- -> notFound name -- should be in tcg_env
+ -> notFound name -- should be in tcg_type_env
| otherwise
-> tcImportDecl name -- Go find it in an interface
}}}}}
tcLookupField :: Name -> TcM Id -- Returns the selector Id
-tcLookupField name
- = tcLookupGlobal name `thenM` \ thing ->
- case thing of
- AnId id -> return id
- other -> wrongThingErr "field name" (AGlobal thing) name
+tcLookupField name
+ = tcLookupId name -- Note [Record field lookup]
+
+{- Note [Record field lookup]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might think we should have tcLookupGlobal here, since record fields
+are always top level. But consider
+ f = e { f = True }
+Then the renamer (which does not keep track of what is a record selector
+and what is not) will rename the definition thus
+ f_7 = e { f_7 = True }
+Now the type checker will find f_7 in the *local* type environment, not
+the global (imported) one. It's wrong, of course, but we want to report a tidy
+error, not in TcEnv.notFound. -}
tcLookupDataCon :: Name -> TcM DataCon
-tcLookupDataCon name
- = tcLookupGlobal name `thenM` \ thing ->
+tcLookupDataCon name = do
+ thing <- tcLookupGlobal name
case thing of
ADataCon con -> return con
- other -> wrongThingErr "data constructor" (AGlobal thing) name
+ _ -> wrongThingErr "data constructor" (AGlobal thing) name
tcLookupClass :: Name -> TcM Class
-tcLookupClass name
- = tcLookupGlobal name `thenM` \ thing ->
+tcLookupClass name = do
+ thing <- tcLookupGlobal name
case thing of
AClass cls -> return cls
- other -> wrongThingErr "class" (AGlobal thing) name
-
+ _ -> wrongThingErr "class" (AGlobal thing) name
+
tcLookupTyCon :: Name -> TcM TyCon
-tcLookupTyCon name
- = tcLookupGlobal name `thenM` \ thing ->
+tcLookupTyCon name = do
+ thing <- tcLookupGlobal name
case thing of
ATyCon tc -> return tc
- other -> wrongThingErr "type constructor" (AGlobal thing) name
+ _ -> wrongThingErr "type constructor" (AGlobal thing) name
tcLookupLocatedGlobalId :: Located Name -> TcM Id
tcLookupLocatedGlobalId = addLocM tcLookupId
-- Look up the instance tycon of a family instance.
--
--- The match must be unique - ie, match exactly one instance - but the
--- type arguments used for matching may be more specific than those of
--- the family instance declaration.
+-- The match may be ambiguous (as we know that overlapping instances have
+-- identical right-hand sides under overlapping substitutions - see
+-- 'FamInstEnv.lookupFamInstEnvConflicts'). However, the type arguments used
+-- for matching must be equal to or be more specific than those of the family
+-- instance declaration. We pick one of the matches in case of ambiguity; as
+-- the right-hand sides are identical under the match substitution, the choice
+-- does not matter.
--
-- Return the instance tycon and its type instance. For example, if we have
--
--
tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (TyCon, [Type]))
tcLookupFamInst tycon tys
- | not (isOpenTyCon tycon)
+ | not (isFamilyTyCon tycon)
= return Nothing
| otherwise
= do { env <- getGblEnv
; eps <- getEps
; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
+ ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ ppr instEnv)
; case lookupFamInstEnv instEnv tycon tys of
- [(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst,
- rep_tys)
- other -> return Nothing
+ [] -> return Nothing
+ ((fam_inst, rep_tys):_)
+ -> return $ Just (famInstTyCon fam_inst, rep_tys)
}
+
+tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
+-- Find the instance of a data family
+-- Note [Looking up family instances for deriving]
+tcLookupDataFamInst tycon tys
+ | not (isFamilyTyCon tycon)
+ = return (tycon, tys)
+ | otherwise
+ = ASSERT( isAlgTyCon tycon )
+ do { maybeFamInst <- tcLookupFamInst tycon tys
+ ; case maybeFamInst of
+ Nothing -> famInstNotFound tycon tys
+ Just famInst -> return famInst }
+
+famInstNotFound :: TyCon -> [Type] -> TcM a
+famInstNotFound tycon tys
+ = failWithTc (ptext (sLit "No family instance for")
+ <+> quotes (pprTypeApp tycon tys))
+\end{code}
+
+Note [Looking up family instances for deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcLookupFamInstExact is an auxiliary lookup wrapper which requires
+that looked-up family instances exist. If called with a vanilla
+tycon, the old type application is simply returned.
+
+If we have
+ data instance F () = ... deriving Eq
+ data instance F () = ... deriving Eq
+then tcLookupFamInstExact will be confused by the two matches;
+but that can't happen because tcInstDecls1 doesn't call tcDeriving
+if there are any overlaps.
+
+There are two other things that might go wrong with the lookup.
+First, we might see a standalone deriving clause
+ deriving Eq (F ())
+when there is no data instance F () in scope.
+
+Note that it's OK to have
+ data instance F [a] = ...
+ deriving Eq (F [(a,b)])
+where the match is not exact; the same holds for ordinary data types
+with standalone deriving declrations.
+
+\begin{code}
+instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
+ lookupThing = tcLookupGlobal
\end{code}
%************************************************************************
\begin{code}
+setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
+-- Use this to update the global type env
+-- It updates both * the normal tcg_type_env field
+-- * the tcg_type_env_var field seen by interface files
+setGlobalTypeEnv tcg_env new_type_env
+ = do { -- Sync the type-envt variable seen by interface files
+ writeMutVar (tcg_type_env_var tcg_env) new_type_env
+ ; return (tcg_env { tcg_type_env = new_type_env }) }
+
tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
-- Given a mixture of Ids, TyCons, Classes, all from the
-- module being compiled, extend the global environment
tcExtendGlobalEnv things thing_inside
- = do { env <- getGblEnv
- ; let ge' = extendTypeEnvList (tcg_type_env env) things
- ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
+ = do { tcg_env <- getGblEnv
+ ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things
+ ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
+ ; setGblEnv tcg_env' thing_inside }
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
-- Same deal as tcExtendGlobalEnv, but for Ids
tcExtendGlobalValEnv ids thing_inside
= tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
-\end{code}
-\begin{code}
tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
-- Extend the global environments for the type/class knot tying game
+-- Just like tcExtendGlobalEnv, except the argument is a list of pairs
tcExtendRecEnv gbl_stuff thing_inside
- = updGblEnv upd thing_inside
- where
- upd env = env { tcg_type_env = extend (tcg_type_env env) }
- extend env = extendNameEnvList env gbl_stuff
+ = do { tcg_env <- getGblEnv
+ ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
+ ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
+ ; setGblEnv tcg_env' thing_inside }
\end{code}
tcLookupLocated = addLocM tcLookup
tcLookup :: Name -> TcM TcTyThing
-tcLookup name
- = getLclEnv `thenM` \ local_env ->
- case lookupNameEnv (tcl_env local_env) name of
- Just thing -> returnM thing
- Nothing -> tcLookupGlobal name `thenM` \ thing ->
- returnM (AGlobal thing)
+tcLookup name = do
+ local_env <- getLclTypeEnv
+ case lookupNameEnv local_env name of
+ Just thing -> return thing
+ Nothing -> AGlobal <$> tcLookupGlobal name
tcLookupTyVar :: Name -> TcM TcTyVar
-tcLookupTyVar name
- = tcLookup name `thenM` \ thing ->
+tcLookupTyVar name = do
+ thing <- tcLookup name
case thing of
ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
- other -> pprPanic "tcLookupTyVar" (ppr name)
+ _ -> pprPanic "tcLookupTyVar" (ppr name)
tcLookupId :: Name -> TcM Id
-- Used when we aren't interested in the binding level, nor refinement.
-- The "no refinement" part means that we return the un-refined Id regardless
--
-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
-tcLookupId name
- = tcLookup name `thenM` \ thing ->
+tcLookupId name = do
+ thing <- tcLookup name
case thing of
- ATcId { tct_id = id} -> returnM id
- AGlobal (AnId id) -> returnM id
- other -> pprPanic "tcLookupId" (ppr name)
+ ATcId { tct_id = id} -> return id
+ AGlobal (AnId id) -> return id
+ _ -> pprPanic "tcLookupId" (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) (thLevel (tcl_th_ctxt env))) ns)
+tcLookupLocalIds ns = do
+ env <- getLclEnv
+ return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
where
lookup lenv lvl name
= case lookupNameEnv lenv name of
Just (ATcId { tct_id = id, tct_level = lvl1 })
-> ASSERT( lvl == lvl1 ) id
- other -> pprPanic "tcLookupLocalIds" (ppr name)
-
-lclEnvElts :: TcLclEnv -> [TcTyThing]
-lclEnvElts env = nameEnvElts (tcl_env env)
+ _ -> pprPanic "tcLookupLocalIds" (ppr name)
getInLocalScope :: TcM (Name -> Bool)
-- Ids only
-getInLocalScope = getLclEnv `thenM` \ env ->
- let
- lcl_env = tcl_env env
- in
- return (`elemNameEnv` lcl_env)
+getInLocalScope = do { lcl_env <- getLclTypeEnv
+ ; return (`elemNameEnv` lcl_env) }
\end{code}
\begin{code}
upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
-tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
+tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r
tcExtendKindEnvTvs bndrs thing_inside
- = updLclEnv upd thing_inside
- where
- upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
- extend env = extendNameEnvList env pairs
- pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
+ = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs)
+ (thing_inside bndrs)
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
= tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
-tcExtendTyVarEnv2 binds thing_inside
- = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
- tcl_tyvars = gtvs,
- tcl_rdr = rdr_env}) ->
+tcExtendTyVarEnv2 binds thing_inside = do
+ env@(TcLclEnv {tcl_env = le,
+ tcl_tyvars = gtvs,
+ tcl_rdr = rdr_env}) <- getLclEnv
let
- rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
+ rdr_env' = extendLocalRdrEnvList rdr_env (map fst binds)
new_tv_set = tcTyVarsOfTypes (map snd binds)
le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
- in
+
-- It's important to add the in-scope tyvars to the global tyvar set
-- as well. Consider
-- f (_::r) = let g y = y::r in ...
-- Here, g mustn't be generalised. This is also important during
-- class and instance decls, when we mustn't generalise the class tyvars
-- when typechecking the methods.
- tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
+ gtvs' <- tcExtendGlobalTyVars gtvs new_tv_set
setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
getScopedTyVarBinds :: TcM [(Name, TcType)]
tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
+getHetMetLevel :: TcM [TyVar]
+getHetMetLevel =
+ do { env <- getEnv
+ ; return $ case env of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x
+ }
+
tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
-- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
tcExtendIdEnv2 names_w_ids thing_inside
= do { env <- getLclEnv
- ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside }
+ ; hetMetLevel <- getHetMetLevel
+ ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) hetMetLevel names_w_ids thing_inside }
+
tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
-- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
-- GHCi has already compiled it to bytecode
tcExtendGhciEnv ids thing_inside
= do { env <- getLclEnv
- ; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside }
+ ; hetMetLevel <- getHetMetLevel
+ ; tc_extend_local_id_env env impLevel hetMetLevel [(idName id, id) | id <- ids] thing_inside }
tc_extend_local_id_env -- This is the guy who does the work
:: TcLclEnv
-> ThLevel
+ -> [TyVar]
-> [(Name,TcId)]
-> TcM a -> TcM a
-- Invariant: the TcIds are fully zonked. Reasons:
-- in the types, because instantiation does not look through such things
-- (c) The call to tyVarsOfTypes is ok without looking through refs
-tc_extend_local_id_env env th_lvl names_w_ids thing_inside
- = do { traceTc (text "env2")
- ; traceTc (text "env3" <+> ppr extra_env)
- ; gtvs' <- tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars
+tc_extend_local_id_env env th_lvl hetMetLevel names_w_ids thing_inside
+ = do { traceTc "env2" (ppr extra_env)
+ ; gtvs' <- tcExtendGlobalTyVars (tcl_tyvars env) extra_global_tyvars
; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}
; setLclEnv env' thing_inside }
where
extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
extra_env = [ (name, ATcId { tct_id = id,
tct_level = th_lvl,
- tct_type = id_ty,
- tct_co = case isRefineableTy id_ty of
- (True,_) -> Unrefineable
- (_,True) -> Rigid idHsWrapper
- _ -> Wobbly})
- | (name,id) <- names_w_ids, let id_ty = idType id]
+ tct_hetMetLevel = hetMetLevel
+ })
+ | (name,id) <- names_w_ids]
le' = extendNameEnvList (tcl_env env) extra_env
- rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
-\end{code}
+ rdr_env' = extendLocalRdrEnvList (tcl_rdr env) [name | (name,_) <- names_w_ids]
-
-\begin{code}
------------------------
--- findGlobals looks at the value environment and finds values
--- whose types mention the offending type variable. It has to be
--- careful to zonk the Id's type first, so it has to be in the monad.
--- We must be careful to pass it a zonked type variable, too.
-
-findGlobals :: TcTyVarSet
- -> TidyEnv
- -> TcM (TidyEnv, [SDoc])
-
-findGlobals tvs tidy_env
- = getLclEnv `thenM` \ lcl_env ->
- go tidy_env [] (lclEnvElts lcl_env)
- where
- go tidy_env acc [] = returnM (tidy_env, acc)
- go tidy_env acc (thing : things)
- = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
- case maybe_doc of
- Just d -> go tidy_env1 (d:acc) things
- Nothing -> go tidy_env1 acc things
-
- ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
-
------------------------
-find_thing ignore_it tidy_env (ATcId { tct_id = id })
- = zonkTcType (idType id) `thenM` \ id_ty ->
- if ignore_it id_ty then
- returnM (tidy_env, Nothing)
- else let
- (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
- msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
- nest 2 (parens (ptext SLIT("bound at") <+>
- ppr (getSrcLoc id)))]
- in
- returnM (tidy_env', Just msg)
-
-find_thing ignore_it tidy_env (ATyVar tv ty)
- = zonkTcType ty `thenM` \ tv_ty ->
- if ignore_it tv_ty then
- returnM (tidy_env, Nothing)
- else let
- -- The name tv is scoped, so we don't need to tidy it
- (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
- msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
-
- eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
- getOccName tv == getOccName tv' = empty
- | otherwise = equals <+> ppr tidy_ty
- -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
- bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
- in
- returnM (tidy_env1, Just msg)
-
-find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
-\end{code}
-
-\begin{code}
-refineEnvironment
- :: Refinement
- -> Bool -- whether type equations are involved
- -> TcM a
- -> TcM a
--- I don't think I have to refine the set of global type variables in scope
--- Reason: the refinement never increases that set
-refineEnvironment reft otherEquations thing_inside
- | isEmptyRefinement reft -- Common case
- , not otherEquations
- = thing_inside
- | otherwise
- = do { env <- getLclEnv
- ; let le' = mapNameEnv refine (tcl_env env)
- ; setLclEnv (env {tcl_env = le'}) thing_inside }
- where
- refine elt@(ATcId { tct_co = Rigid co, tct_type = ty })
- | Just (co', ty') <- refineType reft ty
- = elt { tct_co = Rigid (WpCo co' <.> co), tct_type = ty' }
- refine elt@(ATcId { tct_co = Wobbly})
--- Main new idea: make wobbly things invisible whenever there
--- is a refinement of any sort
--- | otherEquations
- = elt { tct_co = WobblyInvisible}
- refine (ATyVar tv ty)
- | Just (_, ty') <- refineType reft ty
- = ATyVar tv ty' -- Ignore the coercion that refineType returns
-
- refine elt = elt -- Common case
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The global tyvars}
-%* *
-%************************************************************************
-
-\begin{code}
-tc_extend_gtvs gtvs extra_global_tvs
- = readMutVar gtvs `thenM` \ global_tvs ->
- newMutVar (global_tvs `unionVarSet` extra_global_tvs)
-\end{code}
-
-@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
-To improve subsequent calls to the same function it writes the zonked set back into
-the environment.
-
-\begin{code}
-tcGetGlobalTyVars :: TcM TcTyVarSet
-tcGetGlobalTyVars
- = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
- readMutVar gtv_var `thenM` \ gbl_tvs ->
- zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
- writeMutVar gtv_var gbl_tvs' `thenM_`
- returnM gbl_tvs'
+tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
+tcExtendGlobalTyVars gtv_var extra_global_tvs
+ = do { global_tvs <- readMutVar gtv_var
+ ; newMutVar (global_tvs `unionVarSet` extra_global_tvs) }
\end{code}
\begin{code}
tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
-- Just pop the new rules into the EPS and envt resp
- -- All the rules come from an interface file, not soruce
+ -- All the rules come from an interface file, not source
-- Nevertheless, some may be for this module, if we read
-- its interface instead of its source code
tcExtendRules lcl_rules thing_inside
%************************************************************************
\begin{code}
-instance Outputable ThStage where
- ppr Comp = text "Comp"
- ppr (Brack l _ _) = text "Brack" <+> int l
- ppr (Splice l) = text "Splice" <+> int l
-
-
-thLevel :: ThStage -> ThLevel
-thLevel Comp = topLevel
-thLevel (Splice l) = l
-thLevel (Brack l _ _) = l
-
-
checkWellStaged :: SDoc -- What the stage check is for
- -> ThLevel -- Binding level
- -> ThStage -- Use stage
+ -> ThLevel -- Binding level (increases inside brackets)
+ -> ThLevel -- Use stage
-> TcM () -- Fail if badly staged, adding an error
-checkWellStaged pp_thing bind_lvl use_stage
- | bind_lvl <= use_lvl -- OK!
- = returnM ()
+checkWellStaged pp_thing bind_lvl use_lvl
+ | use_lvl >= bind_lvl -- OK! Used later than bound
+ = return () -- E.g. \x -> [| $(f x) |]
- | bind_lvl == topLevel -- GHC restriction on top level splices
+ | bind_lvl == outerLevel -- 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"))]
+ sep [ptext (sLit "GHC stage restriction:") <+> pp_thing,
+ nest 2 (vcat [ ptext (sLit "is used in a top-level splice or annotation,")
+ , ptext (sLit "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 = thLevel use_stage
-
+ = failWithTc $ -- E.g. \x -> $(f x)
+ 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]
topIdLvl :: Id -> ThLevel
-- Globals may either be imported, or may be from an earlier "chunk"
-- $( 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
+topIdLvl id | isLocalId id = outerLevel
| otherwise = impLevel
--- Indicates the legal transitions on bracket( [| |] ).
-bracketOK :: ThStage -> Maybe ThLevel
-bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
-bracketOK stage = Just (thLevel stage + 1)
-
--- Indicates the legal transitions on splice($).
-spliceOK :: ThStage -> Maybe ThLevel
-spliceOK (Splice _) = Nothing -- Splice illegal inside splice
-spliceOK stage = Just (thLevel stage - 1)
-
tcMetaTy :: Name -> TcM Type
-- Given the name of a Template Haskell data type,
-- return the type
-- E.g. given the name "Expr" return the type "Expr"
-tcMetaTy tc_name
- = tcLookupTyCon tc_name `thenM` \ t ->
- returnM (mkTyConApp t [])
+tcMetaTy tc_name = do
+ t <- tcLookupTyCon tc_name
+ return (mkTyConApp t [])
+
+thRnBrack :: ThStage
+-- Used *only* to indicate that we are inside a TH bracket during renaming
+-- Tested by TcEnv.isBrackStage
+-- See Note [Top-level Names in Template Haskell decl quotes]
+thRnBrack = Brack (panic "thRnBrack1") (panic "thRnBrack2") (panic "thRnBrack3")
+
+isBrackStage :: ThStage -> Bool
+isBrackStage (Brack {}) = True
+isBrackStage _other = False
+
+thTopLevelId :: Id -> Bool
+-- See Note [What is a top-level Id?] in TcSplice
+thTopLevelId id = isGlobalId id || isExternalName (idName id)
\end{code}
%************************************************************************
%* *
+ getDefaultTys
+%* *
+%************************************************************************
+
+\begin{code}
+tcGetDefaultTys :: Bool -- True <=> interactive context
+ -> TcM ([Type], -- Default types
+ (Bool, -- True <=> Use overloaded strings
+ Bool)) -- True <=> Use extended defaulting rules
+tcGetDefaultTys interactive
+ = do { dflags <- getDOpts
+ ; let ovl_strings = xopt Opt_OverloadedStrings dflags
+ extended_defaults = interactive
+ || xopt Opt_ExtendedDefaultRules dflags
+ -- See also Trac #1974
+ flags = (ovl_strings, extended_defaults)
+
+ ; mb_defaults <- getDeclaredDefaultTys
+ ; case mb_defaults of {
+ Just tys -> return (tys, flags) ;
+ -- User-supplied defaults
+ Nothing -> do
+
+ -- No use-supplied default
+ -- Use [Integer, Double], plus modifications
+ { integer_ty <- tcMetaTy integerTyConName
+ ; checkWiredInTyCon doubleTyCon
+ ; string_ty <- tcMetaTy stringTyConName
+ ; let deflt_tys = opt_deflt extended_defaults unitTy -- Note [Default unitTy]
+ ++ [integer_ty, doubleTy]
+ ++ opt_deflt ovl_strings string_ty
+ ; return (deflt_tys, flags) } } }
+ where
+ opt_deflt True ty = [ty]
+ opt_deflt False _ = []
+\end{code}
+
+Note [Default unitTy]
+~~~~~~~~~~~~~~~~~~~~~
+In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
+try when defaulting. This has very little real impact, except in the following case.
+Consider:
+ Text.Printf.printf "hello"
+This has type (forall a. IO a); it prints "hello", and returns 'undefined'. We don't
+want the GHCi repl loop to try to print that 'undefined'. The neatest thing is to
+default the 'a' to (), rather than to Integer (which is what would otherwise happen;
+and then GHCi doesn't attempt to print the (). So in interactive mode, we add
+() to the list of defaulting types. See Trac #1200.
+
+
+%************************************************************************
+%* *
\subsection{The InstInfo type}
%* *
%************************************************************************
as well as explicit user written ones.
\begin{code}
-data InstInfo
+data InstInfo a
= InstInfo {
- iSpec :: Instance, -- Includes the dfun id. Its forall'd type
- iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
+ iSpec :: Instance, -- Includes the dfun id. Its forall'd type
+ iBinds :: InstBindings a -- variables scope over the stuff in InstBindings!
}
-iDFunId :: InstInfo -> DFunId
+iDFunId :: InstInfo a -> DFunId
iDFunId info = instanceDFunId (iSpec info)
-data InstBindings
+data InstBindings a
= VanillaInst -- The normal case
- (LHsBinds Name) -- Bindings
- [LSig Name] -- User pragmas recorded for generating
+ (LHsBinds a) -- Bindings for the instance methods
+ [LSig a] -- User pragmas recorded for generating
-- specialised instances
+ Bool -- True <=> This code came from a standalone deriving clause
+ -- Used only to improve error messages
+
+ | NewTypeDerived -- Used for deriving instances of newtypes, where the
+ -- witness dictionary is identical to the argument
+ -- dictionary. Hence no bindings, no pragmas.
+
+ Coercion -- The coercion maps from newtype to the representation type
+ -- (mentioning type variables bound by the forall'd iSpec variables)
+ -- E.g. newtype instance N [a] = N1 (Tree a)
+ -- co : N [a] ~ Tree a
+
+ TyCon -- The TyCon is the newtype N. If it's indexed, then it's the
+ -- representation TyCon, so that tyConDataCons returns [N1],
+ -- the "data constructor".
+ -- See Note [Newtype deriving and unused constructors]
+ -- in TcDeriv
+
+pprInstInfo :: InstInfo a -> SDoc
+pprInstInfo info = hang (ptext (sLit "instance"))
+ 2 (sep [ ifPprDebug (pprForAll tvs)
+ , pprThetaArrowTy theta, ppr tau
+ , ptext (sLit "where")])
+ where
+ (tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info))
- | NewTypeDerived -- Used for deriving instances of newtypes, where the
- -- witness dictionary is identical to the argument
- -- dictionary. Hence no bindings, no pragmas.
- (Maybe [PredType])
- -- Nothing => The newtype-derived instance involves type variables,
- -- and the dfun has a type like df :: forall a. Eq a => Eq (T a)
- -- Just (r:scs) => The newtype-defined instance has no type variables
- -- so the dfun is just a constant, df :: Eq T
- -- In this case we need to know waht the rep dict, r, and the
- -- superclasses, scs, are. (In the Nothing case these are in the
- -- dict fun's type.)
- -- Invariant: these PredTypes have no free variables
- -- NB: In both cases, the representation dict is the *first* dict.
-
-pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
+pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
where
- details (VanillaInst b _) = pprLHsBinds b
- details (NewTypeDerived _) = text "Derived from the representation type"
+ details (VanillaInst b _ _) = pprLHsBinds b
+ details (NewTypeDerived {}) = text "Derived from the representation type"
-simpleInstInfoClsTy :: InstInfo -> (Class, Type)
+simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
- (_, _, cls, [ty]) -> (cls, ty)
+ (_, _, cls, [ty]) -> (cls, ty)
+ _ -> panic "simpleInstInfoClsTy"
-simpleInstInfoTy :: InstInfo -> Type
+simpleInstInfoTy :: InstInfo a -> Type
simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
-simpleInstInfoTyCon :: InstInfo -> TyCon
+simpleInstInfoTyCon :: InstInfo a -> TyCon
-- Gets the type constructor for a simple instance declaration,
-- i.e. one of the form instance (...) => C (T a b c) where ...
simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
\begin{code}
newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
-newDFunName clas (ty:_) loc
- = do { index <- nextDFunIndex
- ; is_boot <- tcIsHsBoot
+newDFunName clas tys loc
+ = do { is_boot <- tcIsHsBoot
; mod <- getModule
; let info_string = occNameString (getOccName clas) ++
- occNameString (getDFunTyKey ty)
- dfun_occ = mkDFunOcc info_string is_boot index
-
+ concatMap (occNameString.getDFunTyKey) tys
+ ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
; newGlobalBinder mod dfun_occ loc }
-
-newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
\end{code}
Make a name for the representation tycon of a family instance. It's an
-*external* name, like otber top-level names, and hence must be made with
+*external* name, like other top-level names, and hence must be made with
newGlobalBinder.
\begin{code}
-newFamInstTyConName :: Name -> SrcSpan -> TcM Name
-newFamInstTyConName tc_name loc
- = do { index <- nextDFunIndex
- ; mod <- getModule
- ; let occ = nameOccName tc_name
- ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
+newFamInstTyConName :: Name -> [Type] -> SrcSpan -> TcM Name
+newFamInstTyConName tc_name tys loc
+ = do { mod <- getModule
+ ; let info_string = occNameString (getOccName tc_name) ++
+ concatMap (occNameString.getDFunTyKey) tys
+ ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
+ ; newGlobalBinder mod occ loc }
\end{code}
+Stable names used for foreign exports and annotations.
+For stable names, the name must be unique (see #1533). If the
+same thing has several stable Ids based on it, the
+top-level bindings generated must not have the same name.
+Hence we create an External name (doesn't change), and we
+append a Unique to the string right here.
+
+\begin{code}
+mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
+mkStableIdFromString str sig_ty loc occ_wrapper = do
+ uniq <- newUnique
+ mod <- getModule
+ let uniq_str = showSDoc (pprUnique uniq) :: String
+ occ = mkVarOcc (str ++ '_' : uniq_str) :: OccName
+ gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
+ id = mkExportedLocalId gnm sig_ty :: Id
+ return id
+
+mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
+mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
+\end{code}
%************************************************************************
%* *
pprBinders [bndr] = quotes (ppr bndr)
pprBinders bndrs = pprWithCommas ppr bndrs
+notFound :: Name -> TcM TyThing
notFound name
- = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
- ptext SLIT("is not in scope"))
-
+ = do { (gbl,lcl) <- getEnvs
+ ; failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+>
+ ptext (sLit "is not in scope during type checking, but it passed the renamer"),
+ ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env gbl),
+ ptext (sLit "tcl_env of environment:") <+> ppr (tcl_env lcl)]
+ ) }
+
+wrongThingErr :: String -> TcTyThing -> Name -> TcM a
wrongThingErr expected thing name
= failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
- ptext SLIT("used as a") <+> text expected)
+ ptext (sLit "used as a") <+> text expected)
\end{code}
projects / ghc-hetmet.git / blobdiff