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