compiler/typecheck/TcEnv.lhs

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