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