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