compiler/typecheck/TcEnv.lhs

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