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