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