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