InstBindings(..),
-- Global environment
- tcExtendGlobalEnv,
+ tcExtendGlobalEnv, setGlobalTypeEnv,
tcExtendGlobalValEnv,
tcLookupLocatedGlobal, tcLookupGlobal,
tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
-- Template Haskell stuff
checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
- topIdLvl, thTopLevelId,
+ topIdLvl, thTopLevelId, thRnBrack, isBrackStage,
-- New Ids
- newLocalName, newDFunName, newFamInstTyConName,
+ newLocalName, newDFunName, newFamInstTyConName,
+ mkStableIdFromString, mkStableIdFromName
) where
#include "HsVersions.h"
import TcType
-- import TcSuspension
import qualified Type
+import Id
+import Coercion
import Var
import VarSet
import VarEnv
import TypeRep
import Class
import Name
-import PrelNames
import NameEnv
import OccName
import HscTypes
import SrcLoc
import Outputable
import Maybes
+import Unique
import FastString
\end{code}
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
Just mod | mod == tcg_mod env -- Names from this module
-> notFound name env -- should be in tcg_type_env
- | mod == thFAKE -- Names bound in TH declaration brackets
- -> notFound name env -- should be in tcg_env
| otherwise
-> tcImportDecl name -- Go find it in an interface
}}}}}
tcLookupField :: Name -> TcM Id -- Returns the selector Id
-tcLookupField name = do
- thing <- tcLookup name -- Note [Record field lookup]
- case thing of
- AGlobal (AnId id) -> return id
- thing -> wrongThingErr "field name" thing name
+tcLookupField name
+ = tcLookupId name -- Note [Record field lookup]
{- Note [Record field lookup]
~~~~~~~~~~~~~~~~~~~~~~~~~~
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 one. It's wrong, of course, but we want to report a tidy
+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
}
\end{code}
+\begin{code}
+instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
+ lookupThing = tcLookupGlobal
+\end{code}
+
%************************************************************************
%* *
Extending the global environment
\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}
\begin{code}
instance Outputable ThStage where
- ppr Comp = text "Comp"
+ ppr (Comp l) = text "Comp" <+> int l
ppr (Brack l _ _) = text "Brack" <+> int l
ppr (Splice l) = text "Splice" <+> int l
thLevel :: ThStage -> ThLevel
-thLevel Comp = topLevel
+thLevel (Comp l) = l
thLevel (Splice l) = l
thLevel (Brack l _ _) = l
| 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"))]
+ nest 2 (ptext (sLit "is used in") <+> use_lvl_doc <> ptext (sLit ", and must be imported, not defined locally"))]
| otherwise -- Badly staged
= failWithTc $ -- E.g. \x -> $(f x)
ptext (sLit "but used at stage") <+> ppr use_lvl]
where
use_lvl = thLevel use_stage
-
+ use_lvl_doc | use_lvl == thLevel topStage = ptext (sLit "a top-level splice")
+ | use_lvl == thLevel topAnnStage = ptext (sLit "an annotation")
+ | otherwise = panic "checkWellStaged"
topIdLvl :: Id -> ThLevel
-- Globals may either be imported, or may be from an earlier "chunk"
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)
-- specialised instances
| NewTypeDerived -- Used for deriving instances of newtypes, where the
- -- witness dictionary is identical to the argument
+ CoercionI -- witness dictionary is identical to the argument
-- dictionary. Hence no bindings, no pragmas.
+ -- 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
pprInstInfo :: InstInfo a -> SDoc
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 a -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
; newGlobalBinder mod (mkInstTyTcOcc index 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}
%************************************************************************
%* *
projects / ghc-hetmet.git / blobdiff