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