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