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