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