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