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