compiler/typecheck/TcEnv.lhs

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