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