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