compiler/typecheck/TcEnv.lhs

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