compiler/typecheck/TcEnv.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 %
   4
   5 \begin{code}
   6 module TcEnv(
   7         TyThing(..), TcTyThing(..), TcId,
   8
   9         -- Instance environment, and InstInfo type
  10         InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
  11         simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
  12         InstBindings(..),
  13
  14         -- Global environment
  15         tcExtendGlobalEnv,
  16         tcExtendGlobalValEnv,
  17         tcLookupLocatedGlobal,  tcLookupGlobal,
  18         tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
  19         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
  20         tcLookupLocatedClass, tcLookupFamInst,
  21
  22         -- Local environment
  23         tcExtendKindEnv, tcExtendKindEnvTvs,
  24         tcExtendTyVarEnv, tcExtendTyVarEnv2,
  25         tcExtendGhciEnv,
  26         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
  27         tcLookup, tcLookupLocated, tcLookupLocalIds,
  28         tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
  29         lclEnvElts, getInLocalScope, findGlobals,
  30         wrongThingErr, pprBinders,
  31
  32         tcExtendRecEnv,         -- For knot-tying
  33
  34         -- Rules
  35         tcExtendRules,
  36
  37         -- Global type variables
  38         tcGetGlobalTyVars,
  39
  40         -- Template Haskell stuff
  41         checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
  42         topIdLvl, thTopLevelId,
  43
  44         -- New Ids
  45         newLocalName, newDFunName, newFamInstTyConName,
  46         mkStableIdFromString, mkStableIdFromName
  47   ) where
  48
  49 #include "HsVersions.h"
  50
  51 import HsSyn
  52 import TcIface
  53 import IfaceEnv
  54 import TcRnMonad
  55 import TcMType
  56 import TcType
  57 -- import TcSuspension
  58 import qualified Type
  59 import Id
  60 import Var
  61 import VarSet
  62 import VarEnv
  63 import RdrName
  64 import InstEnv
  65 import FamInstEnv
  66 import DataCon
  67 import TyCon
  68 import TypeRep
  69 import Class
  70 import Name
  71 import PrelNames
  72 import NameEnv
  73 import OccName
  74 import HscTypes
  75 import SrcLoc
  76 import Outputable
  77 import Maybes
  78 import Unique
  79 import FastString
  80 \end{code}
  81
  82
  83 %************************************************************************
  84 %*                                                                      *
  85 %*                      tcLookupGlobal                                  *
  86 %*                                                                      *
  87 %************************************************************************
  88
  89 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
  90 unless you know that the SrcSpan in the monad is already set to the
  91 span of the Name.
  92
  93 \begin{code}
  94 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
  95 -- c.f. IfaceEnvEnv.tcIfaceGlobal
  96 tcLookupLocatedGlobal name
  97   = addLocM tcLookupGlobal name
  98
  99 tcLookupGlobal :: Name -> TcM TyThing
 100 -- The Name is almost always an ExternalName, but not always
 101 -- In GHCi, we may make command-line bindings (ghci> let x = True)
 102 -- that bind a GlobalId, but with an InternalName
 103 tcLookupGlobal name
 104   = do  { env <- getGblEnv
 105
 106                 -- Try local envt
 107         ; case lookupNameEnv (tcg_type_env env) name of {
 108                 Just thing -> return thing ;
 109                 Nothing    -> do
 110
 111                 -- Try global envt
 112         { hsc_env <- getTopEnv
 113         ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
 114         ; case mb_thing of  {
 115             Just thing -> return thing ;
 116             Nothing    -> do
 117
 118                 -- Should it have been in the local envt?
 119         { case nameModule_maybe name of
 120                 Nothing -> notFound name env -- Internal names can happen in GHCi
 121
 122                 Just mod | mod == tcg_mod env   -- Names from this module
 123                          -> notFound name env -- should be in tcg_type_env
 124                          | mod == thFAKE        -- Names bound in TH declaration brackets
 125                          -> notFound name env -- should be in tcg_env
 126                          | otherwise
 127                          -> tcImportDecl name   -- Go find it in an interface
 128         }}}}}
 129
 130 tcLookupField :: Name -> TcM Id         -- Returns the selector Id
 131 tcLookupField name = do
 132     thing <- tcLookup name      -- Note [Record field lookup]
 133     case thing of
 134         AGlobal (AnId id) -> return id
 135         thing -> wrongThingErr "field name" thing name
 136
 137 {- Note [Record field lookup]
 138    ~~~~~~~~~~~~~~~~~~~~~~~~~~
 139 You might think we should have tcLookupGlobal here, since record fields
 140 are always top level.  But consider
 141         f = e { f = True }
 142 Then the renamer (which does not keep track of what is a record selector
 143 and what is not) will rename the definition thus
 144         f_7 = e { f_7 = True }
 145 Now the type checker will find f_7 in the *local* type environment, not
 146 the global one. It's wrong, of course, but we want to report a tidy
 147 error, not in TcEnv.notFound.  -}
 148
 149 tcLookupDataCon :: Name -> TcM DataCon
 150 tcLookupDataCon name = do
 151     thing <- tcLookupGlobal name
 152     case thing of
 153         ADataCon con -> return con
 154         _            -> wrongThingErr "data constructor" (AGlobal thing) name
 155
 156 tcLookupClass :: Name -> TcM Class
 157 tcLookupClass name = do
 158     thing <- tcLookupGlobal name
 159     case thing of
 160         AClass cls -> return cls
 161         _          -> wrongThingErr "class" (AGlobal thing) name
 162
 163 tcLookupTyCon :: Name -> TcM TyCon
 164 tcLookupTyCon name = do
 165     thing <- tcLookupGlobal name
 166     case thing of
 167         ATyCon tc -> return tc
 168         _         -> wrongThingErr "type constructor" (AGlobal thing) name
 169
 170 tcLookupLocatedGlobalId :: Located Name -> TcM Id
 171 tcLookupLocatedGlobalId = addLocM tcLookupId
 172
 173 tcLookupLocatedClass :: Located Name -> TcM Class
 174 tcLookupLocatedClass = addLocM tcLookupClass
 175
 176 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
 177 tcLookupLocatedTyCon = addLocM tcLookupTyCon
 178
 179 -- Look up the instance tycon of a family instance.
 180 --
 181 -- The match must be unique - ie, match exactly one instance - but the
 182 -- type arguments used for matching may be more specific than those of
 183 -- the family instance declaration.
 184 --
 185 -- Return the instance tycon and its type instance.  For example, if we have
 186 --
 187 --  tcLookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
 188 --
 189 -- then we have a coercion (ie, type instance of family instance coercion)
 190 --
 191 --  :Co:R42T Int :: T [Int] ~ :R42T Int
 192 --
 193 -- which implies that :R42T was declared as 'data instance T [a]'.
 194 --
 195 tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (TyCon, [Type]))
 196 tcLookupFamInst tycon tys
 197   | not (isOpenTyCon tycon)
 198   = return Nothing
 199   | otherwise
 200   = do { env <- getGblEnv
 201        ; eps <- getEps
 202        ; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
 203        ; case lookupFamInstEnv instEnv tycon tys of
 204            [(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst,
 205                                                    rep_tys)
 206            _                     -> return Nothing
 207        }
 208 \end{code}
 209
 210 %************************************************************************
 211 %*                                                                      *
 212                 Extending the global environment
 213 %*                                                                      *
 214 %************************************************************************
 215
 216
 217 \begin{code}
 218 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
 219   -- Given a mixture of Ids, TyCons, Classes, all from the
 220   -- module being compiled, extend the global environment
 221 tcExtendGlobalEnv things thing_inside
 222    = do { env <- getGblEnv
 223         ; let ge'  = extendTypeEnvList (tcg_type_env env) things
 224         ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
 225
 226 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
 227   -- Same deal as tcExtendGlobalEnv, but for Ids
 228 tcExtendGlobalValEnv ids thing_inside
 229   = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
 230 \end{code}
 231
 232 \begin{code}
 233 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
 234 -- Extend the global environments for the type/class knot tying game
 235 tcExtendRecEnv gbl_stuff thing_inside
 236  = updGblEnv upd thing_inside
 237  where
 238    upd env = env { tcg_type_env = extend (tcg_type_env env) }
 239    extend env = extendNameEnvList env gbl_stuff
 240 \end{code}
 241
 242
 243 %************************************************************************
 244 %*                                                                      *
 245 \subsection{The local environment}
 246 %*                                                                      *
 247 %************************************************************************
 248
 249 \begin{code}
 250 tcLookupLocated :: Located Name -> TcM TcTyThing
 251 tcLookupLocated = addLocM tcLookup
 252
 253 tcLookup :: Name -> TcM TcTyThing
 254 tcLookup name = do
 255     local_env <- getLclEnv
 256     case lookupNameEnv (tcl_env local_env) name of
 257         Just thing -> return thing
 258         Nothing    -> AGlobal <$> tcLookupGlobal name
 259
 260 tcLookupTyVar :: Name -> TcM TcTyVar
 261 tcLookupTyVar name = do
 262     thing <- tcLookup name
 263     case thing of
 264         ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
 265         _           -> pprPanic "tcLookupTyVar" (ppr name)
 266
 267 tcLookupId :: Name -> TcM Id
 268 -- Used when we aren't interested in the binding level, nor refinement.
 269 -- The "no refinement" part means that we return the un-refined Id regardless
 270 --
 271 -- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
 272 tcLookupId name = do
 273     thing <- tcLookup name
 274     case thing of
 275         ATcId { tct_id = id} -> return id
 276         AGlobal (AnId id)    -> return id
 277         _                    -> pprPanic "tcLookupId" (ppr name)
 278
 279 tcLookupLocalIds :: [Name] -> TcM [TcId]
 280 -- We expect the variables to all be bound, and all at
 281 -- the same level as the lookup.  Only used in one place...
 282 tcLookupLocalIds ns = do
 283     env <- getLclEnv
 284     return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
 285   where
 286     lookup lenv lvl name
 287         = case lookupNameEnv lenv name of
 288                 Just (ATcId { tct_id = id, tct_level = lvl1 })
 289                         -> ASSERT( lvl == lvl1 ) id
 290                 _ -> pprPanic "tcLookupLocalIds" (ppr name)
 291
 292 lclEnvElts :: TcLclEnv -> [TcTyThing]
 293 lclEnvElts env = nameEnvElts (tcl_env env)
 294
 295 getInLocalScope :: TcM (Name -> Bool)
 296   -- Ids only
 297 getInLocalScope = do
 298     env <- getLclEnv
 299     let lcl_env = tcl_env env
 300     return (`elemNameEnv` lcl_env)
 301 \end{code}
 302
 303 \begin{code}
 304 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
 305 tcExtendKindEnv things thing_inside
 306   = updLclEnv upd thing_inside
 307   where
 308     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
 309     extend env  = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
 310
 311 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
 312 tcExtendKindEnvTvs bndrs thing_inside
 313   = updLclEnv upd thing_inside
 314   where
 315     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
 316     extend env  = extendNameEnvList env pairs
 317     pairs       = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
 318
 319 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 320 tcExtendTyVarEnv tvs thing_inside
 321   = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
 322
 323 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
 324 tcExtendTyVarEnv2 binds thing_inside = do
 325     env@(TcLclEnv {tcl_env = le,
 326                    tcl_tyvars = gtvs,
 327                    tcl_rdr = rdr_env}) <- getLclEnv
 328     let
 329         rdr_env'   = extendLocalRdrEnv rdr_env (map fst binds)
 330         new_tv_set = tcTyVarsOfTypes (map snd binds)
 331         le'        = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
 332
 333         -- It's important to add the in-scope tyvars to the global tyvar set
 334         -- as well.  Consider
 335         --      f (_::r) = let g y = y::r in ...
 336         -- Here, g mustn't be generalised.  This is also important during
 337         -- class and instance decls, when we mustn't generalise the class tyvars
 338         -- when typechecking the methods.
 339     gtvs' <- tc_extend_gtvs gtvs new_tv_set
 340     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
 341
 342 getScopedTyVarBinds :: TcM [(Name, TcType)]
 343 getScopedTyVarBinds
 344   = do  { lcl_env <- getLclEnv
 345         ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
 346 \end{code}
 347
 348
 349 \begin{code}
 350 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
 351 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
 352
 353 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
 354 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
 355
 356 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
 357 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
 358 tcExtendIdEnv2 names_w_ids thing_inside
 359   = do  { env <- getLclEnv
 360         ; tc_extend_local_id_env env (thLevel (tcl_th_ctxt env)) names_w_ids thing_inside }
 361
 362 tcExtendGhciEnv :: [TcId] -> TcM a -> TcM a
 363 -- Used to bind Ids for GHCi identifiers bound earlier in the user interaction
 364 -- Note especially that we bind them at TH level 'impLevel'.  That's because it's
 365 -- OK to use a variable bound earlier in the interaction in a splice, becuase
 366 -- GHCi has already compiled it to bytecode
 367 tcExtendGhciEnv ids thing_inside
 368   = do  { env <- getLclEnv
 369         ; tc_extend_local_id_env env impLevel [(idName id, id) | id <- ids] thing_inside }
 370
 371 tc_extend_local_id_env          -- This is the guy who does the work
 372         :: TcLclEnv
 373         -> ThLevel
 374         -> [(Name,TcId)]
 375         -> TcM a -> TcM a
 376 -- Invariant: the TcIds are fully zonked. Reasons:
 377 --      (a) The kinds of the forall'd type variables are defaulted
 378 --          (see Kind.defaultKind, done in zonkQuantifiedTyVar)
 379 --      (b) There are no via-Indirect occurrences of the bound variables
 380 --          in the types, because instantiation does not look through such things
 381 --      (c) The call to tyVarsOfTypes is ok without looking through refs
 382
 383 tc_extend_local_id_env env th_lvl names_w_ids thing_inside
 384   = do  { traceTc (text "env2")
 385         ; traceTc (text "env3" <+> ppr extra_env)
 386         ; gtvs' <- tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars
 387         ; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}
 388         ; setLclEnv env' thing_inside }
 389   where
 390     extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
 391     extra_env       = [ (name, ATcId { tct_id = id,
 392                                        tct_level = th_lvl,
 393                                        tct_type = id_ty,
 394                                        tct_co = case isRefineableTy id_ty of
 395                                                   (True,_) -> Unrefineable
 396                                                   (_,True) -> Rigid idHsWrapper
 397                                                   _        -> Wobbly})
 398                       | (name,id) <- names_w_ids, let id_ty = idType id]
 399     le'             = extendNameEnvList (tcl_env env) extra_env
 400     rdr_env'        = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
 401 \end{code}
 402
 403
 404 \begin{code}
 405 -----------------------
 406 -- findGlobals looks at the value environment and finds values
 407 -- whose types mention the offending type variable.  It has to be
 408 -- careful to zonk the Id's type first, so it has to be in the monad.
 409 -- We must be careful to pass it a zonked type variable, too.
 410
 411 findGlobals :: TcTyVarSet
 412             -> TidyEnv
 413             -> TcM (TidyEnv, [SDoc])
 414
 415 findGlobals tvs tidy_env = do
 416     lcl_env <- getLclEnv
 417     go tidy_env [] (lclEnvElts lcl_env)
 418   where
 419     go tidy_env acc [] = return (tidy_env, acc)
 420     go tidy_env acc (thing : things) = do
 421         (tidy_env1, maybe_doc) <- find_thing ignore_it tidy_env thing
 422         case maybe_doc of
 423           Just d  -> go tidy_env1 (d:acc) things
 424           Nothing -> go tidy_env1 acc     things
 425
 426     ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
 427
 428 -----------------------
 429 find_thing :: (TcType -> Bool) -> TidyEnv -> TcTyThing
 430            -> TcM (TidyEnv, Maybe SDoc)
 431 find_thing ignore_it tidy_env (ATcId { tct_id = id }) = do
 432     id_ty <- zonkTcType  (idType id)
 433     if ignore_it id_ty then
 434         return (tidy_env, Nothing)
 435      else let
 436         (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 437         msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
 438                    nest 2 (parens (ptext (sLit "bound at") <+>
 439                                    ppr (getSrcLoc id)))]
 440      in
 441       return (tidy_env', Just msg)
 442
 443 find_thing ignore_it tidy_env (ATyVar tv ty) = do
 444     tv_ty <- zonkTcType ty
 445     if ignore_it tv_ty then
 446         return (tidy_env, Nothing)
 447      else let
 448         -- The name tv is scoped, so we don't need to tidy it
 449         (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
 450         msg = sep [ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
 451
 452         eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
 453                    getOccName tv == getOccName tv' = empty
 454                  | otherwise = equals <+> ppr tidy_ty
 455                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 456         bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
 457      in
 458        return (tidy_env1, Just msg)
 459
 460 find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
 461 \end{code}
 462
 463 %************************************************************************
 464 %*                                                                      *
 465 \subsection{The global tyvars}
 466 %*                                                                      *
 467 %************************************************************************
 468
 469 \begin{code}
 470 tc_extend_gtvs :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
 471 tc_extend_gtvs gtvs extra_global_tvs = do
 472     global_tvs <- readMutVar gtvs
 473     newMutVar (global_tvs `unionVarSet` extra_global_tvs)
 474 \end{code}
 475
 476 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 477 To improve subsequent calls to the same function it writes the zonked set back into
 478 the environment.
 479
 480 \begin{code}
 481 tcGetGlobalTyVars :: TcM TcTyVarSet
 482 tcGetGlobalTyVars = do
 483     (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
 484     gbl_tvs  <- readMutVar gtv_var
 485     gbl_tvs' <- zonkTcTyVarsAndFV (varSetElems gbl_tvs)
 486     writeMutVar gtv_var gbl_tvs'
 487     return gbl_tvs'
 488 \end{code}
 489
 490
 491 %************************************************************************
 492 %*                                                                      *
 493 \subsection{Rules}
 494 %*                                                                      *
 495 %************************************************************************
 496
 497 \begin{code}
 498 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
 499         -- Just pop the new rules into the EPS and envt resp
 500         -- All the rules come from an interface file, not soruce
 501         -- Nevertheless, some may be for this module, if we read
 502         -- its interface instead of its source code
 503 tcExtendRules lcl_rules thing_inside
 504  = do { env <- getGblEnv
 505       ; let
 506           env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
 507       ; setGblEnv env' thing_inside }
 508 \end{code}
 509
 510
 511 %************************************************************************
 512 %*                                                                      *
 513                 Meta level
 514 %*                                                                      *
 515 %************************************************************************
 516
 517 \begin{code}
 518 instance Outputable ThStage where
 519    ppr Comp          = text "Comp"
 520    ppr (Brack l _ _) = text "Brack" <+> int l
 521    ppr (Splice l)    = text "Splice" <+> int l
 522
 523
 524 thLevel :: ThStage -> ThLevel
 525 thLevel Comp          = topLevel
 526 thLevel (Splice l)    = l
 527 thLevel (Brack l _ _) = l
 528
 529
 530 checkWellStaged :: SDoc         -- What the stage check is for
 531                 -> ThLevel      -- Binding level (increases inside brackets)
 532                 -> ThStage      -- Use stage
 533                 -> TcM ()       -- Fail if badly staged, adding an error
 534 checkWellStaged pp_thing bind_lvl use_stage
 535   | use_lvl >= bind_lvl         -- OK! Used later than bound
 536   = return ()                   -- E.g.  \x -> [| $(f x) |]
 537
 538   | bind_lvl == topLevel        -- GHC restriction on top level splices
 539   = failWithTc $
 540     sep [ptext (sLit "GHC stage restriction:") <+>  pp_thing,
 541          nest 2 (ptext (sLit "is used in a top-level splice, and must be imported, not defined locally"))]
 542
 543   | otherwise                   -- Badly staged
 544   = failWithTc $                -- E.g.  \x -> $(f x)
 545     ptext (sLit "Stage error:") <+> pp_thing <+>
 546         hsep   [ptext (sLit "is bound at stage") <+> ppr bind_lvl,
 547                 ptext (sLit "but used at stage") <+> ppr use_lvl]
 548   where
 549     use_lvl = thLevel use_stage
 550
 551
 552 topIdLvl :: Id -> ThLevel
 553 -- Globals may either be imported, or may be from an earlier "chunk"
 554 -- (separated by declaration splices) of this module.  The former
 555 --  *can* be used inside a top-level splice, but the latter cannot.
 556 -- Hence we give the former impLevel, but the latter topLevel
 557 -- E.g. this is bad:
 558 --      x = [| foo |]
 559 --      $( f x )
 560 -- By the time we are prcessing the $(f x), the binding for "x"
 561 -- will be in the global env, not the local one.
 562 topIdLvl id | isLocalId id = topLevel
 563             | otherwise    = impLevel
 564
 565 -- Indicates the legal transitions on bracket( [| |] ).
 566 bracketOK :: ThStage -> Maybe ThLevel
 567 bracketOK (Brack _ _ _) = Nothing       -- Bracket illegal inside a bracket
 568 bracketOK stage         = Just (thLevel stage + 1)
 569
 570 -- Indicates the legal transitions on splice($).
 571 spliceOK :: ThStage -> Maybe ThLevel
 572 spliceOK (Splice _) = Nothing   -- Splice illegal inside splice
 573 spliceOK stage      = Just (thLevel stage - 1)
 574
 575 tcMetaTy :: Name -> TcM Type
 576 -- Given the name of a Template Haskell data type,
 577 -- return the type
 578 -- E.g. given the name "Expr" return the type "Expr"
 579 tcMetaTy tc_name = do
 580     t <- tcLookupTyCon tc_name
 581     return (mkTyConApp t [])
 582
 583 thTopLevelId :: Id -> Bool
 584 -- See Note [What is a top-level Id?] in TcSplice
 585 thTopLevelId id = isGlobalId id || isExternalName (idName id)
 586 \end{code}
 587
 588
 589 %************************************************************************
 590 %*                                                                      *
 591 \subsection{The InstInfo type}
 592 %*                                                                      *
 593 %************************************************************************
 594
 595 The InstInfo type summarises the information in an instance declaration
 596
 597     instance c => k (t tvs) where b
 598
 599 It is used just for *local* instance decls (not ones from interface files).
 600 But local instance decls includes
 601         - derived ones
 602         - generic ones
 603 as well as explicit user written ones.
 604
 605 \begin{code}
 606 data InstInfo a
 607   = InstInfo {
 608       iSpec  :: Instance,               -- Includes the dfun id.  Its forall'd type
 609       iBinds :: InstBindings a          -- variables scope over the stuff in InstBindings!
 610     }
 611
 612 iDFunId :: InstInfo a -> DFunId
 613 iDFunId info = instanceDFunId (iSpec info)
 614
 615 data InstBindings a
 616   = VanillaInst                 -- The normal case
 617         (LHsBinds a)            -- Bindings for the instance methods
 618         [LSig a]                -- User pragmas recorded for generating
 619                                 -- specialised instances
 620
 621   | NewTypeDerived              -- Used for deriving instances of newtypes, where the
 622                                 -- witness dictionary is identical to the argument
 623                                 -- dictionary.  Hence no bindings, no pragmas.
 624
 625 pprInstInfo :: InstInfo a -> SDoc
 626 pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))]
 627
 628 pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
 629 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
 630   where
 631     details (VanillaInst b _) = pprLHsBinds b
 632     details NewTypeDerived    = text "Derived from the representation type"
 633
 634 simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
 635 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
 636                            (_, _, cls, [ty]) -> (cls, ty)
 637                            _ -> panic "simpleInstInfoClsTy"
 638
 639 simpleInstInfoTy :: InstInfo a -> Type
 640 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
 641
 642 simpleInstInfoTyCon :: InstInfo a -> TyCon
 643   -- Gets the type constructor for a simple instance declaration,
 644   -- i.e. one of the form       instance (...) => C (T a b c) where ...
 645 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
 646 \end{code}
 647
 648 Make a name for the dict fun for an instance decl.  It's an *external*
 649 name, like otber top-level names, and hence must be made with newGlobalBinder.
 650
 651 \begin{code}
 652 newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
 653 newDFunName clas (ty:_) loc
 654   = do  { index   <- nextDFunIndex
 655         ; is_boot <- tcIsHsBoot
 656         ; mod     <- getModule
 657         ; let info_string = occNameString (getOccName clas) ++
 658                             occNameString (getDFunTyKey ty)
 659               dfun_occ = mkDFunOcc info_string is_boot index
 660
 661         ; newGlobalBinder mod dfun_occ loc }
 662
 663 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
 664 \end{code}
 665
 666 Make a name for the representation tycon of a family instance.  It's an
 667 *external* name, like otber top-level names, and hence must be made with
 668 newGlobalBinder.
 669
 670 \begin{code}
 671 newFamInstTyConName :: Name -> SrcSpan -> TcM Name
 672 newFamInstTyConName tc_name loc
 673   = do  { index <- nextDFunIndex
 674         ; mod   <- getModule
 675         ; let occ = nameOccName tc_name
 676         ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
 677 \end{code}
 678
 679 Stable names used for foreign exports and annotations.
 680 For stable names, the name must be unique (see #1533).  If the
 681 same thing has several stable Ids based on it, the
 682 top-level bindings generated must not have the same name.
 683 Hence we create an External name (doesn't change), and we
 684 append a Unique to the string right here.
 685
 686 \begin{code}
 687 mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
 688 mkStableIdFromString str sig_ty loc occ_wrapper = do
 689     uniq <- newUnique
 690     mod <- getModule
 691     let uniq_str = showSDoc (pprUnique uniq) :: String
 692         occ = mkVarOcc (str ++ '_' : uniq_str) :: OccName
 693         gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
 694         id  = mkExportedLocalId gnm sig_ty :: Id
 695     return id
 696
 697 mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
 698 mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
 699 \end{code}
 700
 701 %************************************************************************
 702 %*                                                                      *
 703 \subsection{Errors}
 704 %*                                                                      *
 705 %************************************************************************
 706
 707 \begin{code}
 708 pprBinders :: [Name] -> SDoc
 709 -- Used in error messages
 710 -- Use quotes for a single one; they look a bit "busy" for several
 711 pprBinders [bndr] = quotes (ppr bndr)
 712 pprBinders bndrs  = pprWithCommas ppr bndrs
 713
 714 notFound :: Name -> TcGblEnv -> TcM TyThing
 715 notFound name env
 716   = failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+>
 717                      ptext (sLit "is not in scope during type checking, but it passed the renamer"),
 718                      ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env env)]
 719                     )
 720
 721 wrongThingErr :: String -> TcTyThing -> Name -> TcM a
 722 wrongThingErr expected thing name
 723   = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
 724                 ptext (sLit "used as a") <+> text expected)
 725 \end{code}