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