compiler/typecheck/TcEnv.lhs

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