ghc/compiler/typecheck/TcEnv.lhs

   1 \begin{code}
   2 module TcEnv(
   3         TyThing(..), TyThingDetails(..), TcTyThing(..), TcId,
   4
   5         -- Instance environment, and InstInfo type
   6         tcGetInstEnv, tcSetInstEnv,
   7         InstInfo(..), pprInstInfo, pprInstInfoDetails,
   8         simpleInstInfoTy, simpleInstInfoTyCon,
   9         InstBindings(..),
  10
  11         -- Global environment
  12         tcExtendGlobalEnv,
  13         tcExtendGlobalValEnv,
  14         tcExtendGlobalTypeEnv,
  15         tcLookupTyCon, tcLookupClass, tcLookupDataCon,
  16         tcLookupGlobal_maybe, tcLookupGlobal, tcLookupGlobalId,
  17         getInGlobalScope,
  18
  19         -- Local environment
  20         tcExtendKindEnv,
  21         tcExtendTyVarEnv,    tcExtendTyVarEnv2,
  22         tcExtendLocalValEnv, tcExtendLocalValEnv2,
  23         tcLookup, tcLookupLocalIds, tcLookup_maybe,
  24         tcLookupId, tcLookupIdLvl,
  25         lclEnvElts, getInLocalScope, findGlobals,
  26
  27         -- Instance environment
  28         tcExtendLocalInstEnv, tcExtendInstEnv,
  29
  30         -- Rules
  31         tcExtendRules,
  32
  33         -- Global type variables
  34         tcGetGlobalTyVars,
  35
  36         -- Template Haskell stuff
  37         checkWellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
  38         topIdLvl,
  39
  40         -- New Ids
  41         newLocalName, newDFunName,
  42
  43         -- Misc
  44         isLocalThing
  45   ) where
  46
  47 #include "HsVersions.h"
  48
  49 import RnHsSyn          ( RenamedMonoBinds, RenamedSig )
  50 import HsSyn            ( RuleDecl(..), ifaceRuleDeclName )
  51 import TcRnMonad
  52 import TcMType          ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
  53 import TcType           ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
  54                           tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
  55                           getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo,
  56                           tidyOpenType, tidyOpenTyVar
  57                         )
  58 import qualified Type   ( getTyVar_maybe )
  59 import Rules            ( extendRuleBase )
  60 import Id               ( idName, isLocalId, isDataConWrapId_maybe )
  61 import Var              ( TyVar, Id, idType )
  62 import VarSet
  63 import VarEnv
  64 import CoreSyn          ( IdCoreRule )
  65 import DataCon          ( DataCon, dataConWrapId )
  66 import TyCon            ( TyCon, DataConDetails )
  67 import Class            ( Class, ClassOpItem )
  68 import Name             ( Name, NamedThing(..),
  69                           getSrcLoc, mkInternalName, nameIsLocalOrFrom
  70                         )
  71 import NameEnv
  72 import OccName          ( mkDFunOcc, occNameString )
  73 import HscTypes         ( DFunId, TypeEnv, extendTypeEnvList, lookupType,
  74                           TyThing(..), ExternalPackageState(..) )
  75 import Rules            ( RuleBase )
  76 import BasicTypes       ( EP )
  77 import Module           ( Module )
  78 import InstEnv          ( InstEnv, extendInstEnv )
  79 import Maybes           ( seqMaybe )
  80 import SrcLoc           ( SrcLoc )
  81 import Outputable
  82 import Maybe            ( isJust )
  83 import List             ( partition )
  84 \end{code}
  85
  86
  87 %************************************************************************
  88 %*                                                                      *
  89                 Meta level
  90 %*                                                                      *
  91 %************************************************************************
  92
  93 \begin{code}
  94 instance Outputable Stage where
  95    ppr Comp          = text "Comp"
  96    ppr (Brack l _ _) = text "Brack" <+> int l
  97    ppr (Splice l)    = text "Splice" <+> int l
  98
  99
 100 metaLevel :: Stage -> Level
 101 metaLevel Comp          = topLevel
 102 metaLevel (Splice l)    = l
 103 metaLevel (Brack l _ _) = l
 104
 105
 106 checkWellStaged :: SDoc         -- What the stage check is for
 107                 -> Level        -- Binding level
 108                 -> Stage        -- Use stage
 109                 -> TcM ()       -- Fail if badly staged, adding an error
 110 checkWellStaged pp_thing bind_lvl use_stage
 111   | bind_lvl <= use_lvl         -- OK!
 112   = returnM ()
 113
 114   | bind_lvl == topLevel        -- GHC restriction on top level splices
 115   = failWithTc $
 116     sep [ptext SLIT("GHC stage restriction:") <+>  pp_thing,
 117          nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
 118
 119   | otherwise                   -- Badly staged
 120   = failWithTc $
 121     ptext SLIT("Stage error:") <+> pp_thing <+>
 122         hsep   [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
 123                 ptext SLIT("but used at stage") <+> ppr use_lvl]
 124   where
 125     use_lvl = metaLevel use_stage
 126
 127
 128 topIdLvl :: Id -> Level
 129 -- Globals may either be imported, or may be from an earlier "chunk"
 130 -- (separated by declaration splices) of this module.  The former
 131 -- *can* be used inside a top-level splice, but the latter cannot.
 132 -- Hence we give the former impLevel, but the latter topLevel
 133 -- E.g. this is bad:
 134 --      x = [| foo |]
 135 --      $( f x )
 136 -- By the time we are prcessing the $(f x), the binding for "x"
 137 -- will be in the global env, not the local one.
 138 topIdLvl id | isLocalId id = topLevel
 139             | otherwise    = impLevel
 140
 141 -- Indicates the legal transitions on bracket( [| |] ).
 142 bracketOK :: Stage -> Maybe Level
 143 bracketOK (Brack _ _ _) = Nothing       -- Bracket illegal inside a bracket
 144 bracketOK stage         = (Just (metaLevel stage + 1))
 145
 146 -- Indicates the legal transitions on splice($).
 147 spliceOK :: Stage -> Maybe Level
 148 spliceOK (Splice _) = Nothing   -- Splice illegal inside splice
 149 spliceOK stage      = Just (metaLevel stage - 1)
 150
 151 tcMetaTy :: Name -> TcM Type
 152 -- Given the name of a Template Haskell data type,
 153 -- return the type
 154 -- E.g. given the name "Expr" return the type "Expr"
 155 tcMetaTy tc_name
 156   = tcLookupTyCon tc_name       `thenM` \ t ->
 157     returnM (mkGenTyConApp t [])
 158         -- Use mkGenTyConApp because it might be a synonym
 159 \end{code}
 160
 161
 162 %************************************************************************
 163 %*                                                                      *
 164 \subsection{TyThingDetails}
 165 %*                                                                      *
 166 %************************************************************************
 167
 168 This data type is used to help tie the knot
 169  when type checking type and class declarations
 170
 171 \begin{code}
 172 data TyThingDetails = SynTyDetails  Type
 173                     | DataTyDetails ThetaType (DataConDetails DataCon) [Id] (Maybe (EP Id))
 174                     | ClassDetails  ThetaType [Id] [ClassOpItem] DataCon Name
 175                                 -- The Name is the Name of the implicit TyCon for the class
 176                     | ForeignTyDetails  -- Nothing yet
 177 \end{code}
 178
 179
 180 %************************************************************************
 181 %*                                                                      *
 182 \subsection{Making new Ids}
 183 %*                                                                      *
 184 %************************************************************************
 185
 186 Constructing new Ids
 187
 188 \begin{code}
 189 newLocalName :: Name -> TcM Name
 190 newLocalName name       -- Make a clone
 191   = newUnique           `thenM` \ uniq ->
 192     returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
 193 \end{code}
 194
 195 Make a name for the dict fun for an instance decl.  It's a *local*
 196 name for the moment.  The CoreTidy pass will externalise it.  Even in
 197 --make and ghci stuff, we rebuild the instance environment each time,
 198 so the dfun id is internal to begin with, and external when compiling
 199 other modules
 200
 201 \begin{code}
 202 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
 203 newDFunName clas (ty:_) loc
 204   = newUnique                   `thenM` \ uniq ->
 205     returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc)
 206   where
 207         -- Any string that is somewhat unique will do
 208     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
 209
 210 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
 211 \end{code}
 212
 213 \begin{code}
 214 isLocalThing :: NamedThing a => Module -> a -> Bool
 215 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
 216 \end{code}
 217
 218 %************************************************************************
 219 %*                                                                      *
 220 \subsection{The global environment}
 221 %*                                                                      *
 222 %************************************************************************
 223
 224 \begin{code}
 225 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
 226   -- Given a mixture of Ids, TyCons, Classes, perhaps from the
 227   -- module being compiled, perhaps from a package module,
 228   -- extend the global environment, and update the EPS
 229 tcExtendGlobalEnv things thing_inside
 230    = do { eps <- getEps
 231         ; hpt <- getHpt
 232         ; env <- getGblEnv
 233         ; let mod = tcg_mod env
 234               (lcl_things, pkg_things) = partition (isLocalThing mod) things
 235               ge'  = extendTypeEnvList (tcg_type_env env) lcl_things
 236               eps' = eps { eps_PTE = extendTypeEnvList (eps_PTE eps) pkg_things }
 237         ; setEps eps'
 238         ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
 239
 240 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
 241   -- Same deal as tcExtendGlobalEnv, but for Ids
 242 tcExtendGlobalValEnv ids thing_inside
 243   = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
 244
 245 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
 246   -- Top-level things of the interactive context
 247   -- No need to extend the package env
 248 tcExtendGlobalTypeEnv extra_env thing_inside
 249  = do { env <- getGblEnv
 250       ; let ge' = tcg_type_env env `plusNameEnv` extra_env
 251       ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
 252 \end{code}
 253
 254
 255 \begin{code}
 256 tcLookupGlobal_maybe :: Name -> TcRn m (Maybe TyThing)
 257 -- This is a rather heavily-used function, so I've inlined a few things (e.g. getEps)
 258 -- Notice that for imported things we read the current version from the EPS
 259 -- mutable variable.  This is important in situations like
 260 --      ...$(e1)...$(e2)...
 261 -- where the code that e1 expands to might import some defns that
 262 -- also turn out to be needed by the code that e2 expands to.
 263 tcLookupGlobal_maybe name
 264   = do { env <- getGblEnv
 265        ; if nameIsLocalOrFrom (tcg_mod env) name then
 266                 -- Defined in this module
 267               return (lookupNameEnv (tcg_type_env env) name)
 268          else
 269          do { env <- getTopEnv
 270             ; eps <- readMutVar (top_eps env)
 271             ; return (lookupType (top_hpt env) (eps_PTE eps) name) }}
 272 \end{code}
 273
 274 A variety of global lookups, when we know what we are looking for.
 275
 276 \begin{code}
 277 tcLookupGlobal :: Name -> TcM TyThing
 278 tcLookupGlobal name
 279   = tcLookupGlobal_maybe name   `thenM` \ maybe_thing ->
 280     case maybe_thing of
 281         Just thing -> returnM thing
 282         other      -> notFound "tcLookupGlobal" name
 283
 284 tcLookupGlobalId :: Name -> TcM Id
 285 tcLookupGlobalId name
 286   = tcLookupGlobal_maybe name   `thenM` \ maybe_thing ->
 287     case maybe_thing of
 288         Just (AnId id)     -> returnM id
 289
 290         -- When typechecking Haskell source, occurrences of
 291         -- data constructors use the "source name", which maps
 292         -- to ADataCon; we want the wrapper instead
 293         Just (ADataCon dc) -> returnM (dataConWrapId dc)
 294
 295         other              -> notFound "tcLookupGlobal (id)" name
 296
 297 tcLookupDataCon :: Name -> TcM DataCon
 298 tcLookupDataCon con_name
 299   = tcLookupGlobal_maybe con_name       `thenM` \ maybe_thing ->
 300     case maybe_thing of
 301         Just (ADataCon data_con) -> returnM data_con
 302         other                    -> notFound "tcLookupDataCon" con_name
 303
 304 tcLookupClass :: Name -> TcM Class
 305 tcLookupClass name
 306   = tcLookupGlobal_maybe name   `thenM` \ maybe_clas ->
 307     case maybe_clas of
 308         Just (AClass clas) -> returnM clas
 309         other              -> notFound "tcLookupClass" name
 310
 311 tcLookupTyCon :: Name -> TcM TyCon
 312 tcLookupTyCon name
 313   = tcLookupGlobal_maybe name   `thenM` \ maybe_tc ->
 314     case maybe_tc of
 315         Just (ATyCon tc) -> returnM tc
 316         other            -> notFound "tcLookupTyCon" name
 317
 318
 319 getInGlobalScope :: TcRn m (Name -> Bool)
 320 -- Get all things in the global environment; used for deciding what
 321 -- rules to suck in.  Anything defined in this module (nameIsLocalOrFrom)
 322 -- is certainly in the envt, so we don't bother to look.
 323 getInGlobalScope
 324   = do { mod <- getModule
 325        ; eps <- getEps
 326        ; hpt <- getHpt
 327        ; return (\n -> nameIsLocalOrFrom mod n ||
 328                        isJust (lookupType hpt (eps_PTE eps) n)) }
 329 \end{code}
 330
 331
 332 %************************************************************************
 333 %*                                                                      *
 334 \subsection{The local environment}
 335 %*                                                                      *
 336 %************************************************************************
 337
 338 \begin{code}
 339 tcLookup_maybe :: Name -> TcM (Maybe TcTyThing)
 340 tcLookup_maybe name
 341   = getLclEnv           `thenM` \ local_env ->
 342     case lookupNameEnv (tcl_env local_env) name of
 343         Just thing -> returnM (Just thing)
 344         Nothing    -> tcLookupGlobal_maybe name `thenM` \ mb_res ->
 345                       returnM (case mb_res of
 346                                  Just thing -> Just (AGlobal thing)
 347                                  Nothing    -> Nothing)
 348
 349 tcLookup :: Name -> TcM TcTyThing
 350 tcLookup name
 351   = tcLookup_maybe name         `thenM` \ maybe_thing ->
 352     case maybe_thing of
 353         Just thing -> returnM thing
 354         other      -> notFound "tcLookup" name
 355         -- Extract the IdInfo from an IfaceSig imported from an interface file
 356
 357 tcLookupId :: Name -> TcM Id
 358 -- Used when we aren't interested in the binding level
 359 tcLookupId name
 360   = tcLookup name       `thenM` \ thing ->
 361     case thing of
 362         ATcId tc_id lvl       -> returnM tc_id
 363         AGlobal (AnId id)     -> returnM id
 364         AGlobal (ADataCon dc) -> returnM (dataConWrapId dc)
 365                 -- C.f. tcLookupGlobalId
 366         other                 -> pprPanic "tcLookupId" (ppr name)
 367
 368 tcLookupIdLvl :: Name -> TcM (Id, Level)
 369 tcLookupIdLvl name
 370   = tcLookup name       `thenM` \ thing ->
 371     case thing of
 372         ATcId tc_id lvl       -> returnM (tc_id, lvl)
 373         AGlobal (AnId id)     -> returnM (id, topIdLvl id)
 374         AGlobal (ADataCon dc) -> returnM (dataConWrapId dc, impLevel)
 375         other             -> pprPanic "tcLookupIdLvl" (ppr name)
 376
 377 tcLookupLocalIds :: [Name] -> TcM [TcId]
 378 -- We expect the variables to all be bound, and all at
 379 -- the same level as the lookup.  Only used in one place...
 380 tcLookupLocalIds ns
 381   = getLclEnv           `thenM` \ env ->
 382     returnM (map (lookup (tcl_env env) (metaLevel (tcl_level env))) ns)
 383   where
 384     lookup lenv lvl name
 385         = case lookupNameEnv lenv name of
 386                 Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
 387                 other                -> pprPanic "tcLookupLocalIds" (ppr name)
 388
 389 lclEnvElts :: TcLclEnv -> [TcTyThing]
 390 lclEnvElts env = nameEnvElts (tcl_env env)
 391
 392 getInLocalScope :: TcM (Name -> Bool)
 393   -- Ids only
 394 getInLocalScope = getLclEnv     `thenM` \ env ->
 395                   let
 396                         lcl_env = tcl_env env
 397                   in
 398                   return (`elemNameEnv` lcl_env)
 399 \end{code}
 400
 401 \begin{code}
 402 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
 403 tcExtendKindEnv pairs thing_inside
 404   = updLclEnv upd thing_inside
 405   where
 406     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
 407     extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- pairs]
 408         -- No need to extend global tyvars for kind checking
 409
 410 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 411 tcExtendTyVarEnv tvs thing_inside
 412   = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside
 413
 414 tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r
 415 tcExtendTyVarEnv2 tv_pairs thing_inside
 416   = tc_extend_tv_env [(getName tv1, ATyVar tv2) | (tv1,tv2) <- tv_pairs]
 417                      [tv | (_,tv) <- tv_pairs]
 418                      thing_inside
 419
 420 tc_extend_tv_env binds tyvars thing_inside
 421   = getLclEnv      `thenM` \ env@(TcLclEnv {tcl_env = le, tcl_tyvars = gtvs}) ->
 422     let
 423         le'        = extendNameEnvList le binds
 424         new_tv_set = mkVarSet tyvars
 425     in
 426         -- It's important to add the in-scope tyvars to the global tyvar set
 427         -- as well.  Consider
 428         --      f (x::r) = let g y = y::r in ...
 429         -- Here, g mustn't be generalised.  This is also important during
 430         -- class and instance decls, when we mustn't generalise the class tyvars
 431         -- when typechecking the methods.
 432     tc_extend_gtvs gtvs new_tv_set              `thenM` \ gtvs' ->
 433     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
 434 \end{code}
 435
 436
 437 \begin{code}
 438 tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a
 439 tcExtendLocalValEnv ids thing_inside
 440   = getLclEnv           `thenM` \ env ->
 441     let
 442         extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
 443         lvl                 = metaLevel (tcl_level env)
 444         extra_env           = [(idName id, ATcId id lvl) | id <- ids]
 445         le'                 = extendNameEnvList (tcl_env env) extra_env
 446     in
 447     tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
 448     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
 449
 450 tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
 451 tcExtendLocalValEnv2 names_w_ids thing_inside
 452   = getLclEnv           `thenM` \ env ->
 453     let
 454         extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
 455         lvl                 = metaLevel (tcl_level env)
 456         extra_env           = [(name, ATcId id lvl) | (name,id) <- names_w_ids]
 457         le'                 = extendNameEnvList (tcl_env env) extra_env
 458     in
 459     tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
 460     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
 461 \end{code}
 462
 463
 464 \begin{code}
 465 -----------------------
 466 -- findGlobals looks at the value environment and finds values
 467 -- whose types mention the offending type variable.  It has to be
 468 -- careful to zonk the Id's type first, so it has to be in the monad.
 469 -- We must be careful to pass it a zonked type variable, too.
 470
 471 findGlobals :: TcTyVarSet
 472              -> TidyEnv
 473              -> TcM (TidyEnv, [SDoc])
 474
 475 findGlobals tvs tidy_env
 476   = getLclEnv           `thenM` \ lcl_env ->
 477     go tidy_env [] (lclEnvElts lcl_env)
 478   where
 479     go tidy_env acc [] = returnM (tidy_env, acc)
 480     go tidy_env acc (thing : things)
 481       = find_thing ignore_it tidy_env thing     `thenM` \ (tidy_env1, maybe_doc) ->
 482         case maybe_doc of
 483           Just d  -> go tidy_env1 (d:acc) things
 484           Nothing -> go tidy_env1 acc     things
 485
 486     ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
 487
 488 -----------------------
 489 find_thing ignore_it tidy_env (ATcId id _)
 490   = zonkTcType  (idType id)     `thenM` \ id_ty ->
 491     if ignore_it id_ty then
 492         returnM (tidy_env, Nothing)
 493     else let
 494         (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 495         msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
 496                    nest 2 (parens (ptext SLIT("bound at") <+>
 497                                    ppr (getSrcLoc id)))]
 498     in
 499     returnM (tidy_env', Just msg)
 500
 501 find_thing ignore_it tidy_env (ATyVar tv)
 502   = zonkTcTyVar tv              `thenM` \ tv_ty ->
 503     if ignore_it tv_ty then
 504         returnM (tidy_env, Nothing)
 505     else let
 506         (tidy_env1, tv1)     = tidyOpenTyVar tidy_env  tv
 507         (tidy_env2, tidy_ty) = tidyOpenType  tidy_env1 tv_ty
 508         msg = sep [ppr tv1 <+> eq_stuff, nest 2 bound_at]
 509
 510         eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, tv == tv' = empty
 511                  | otherwise                                        = equals <+> ppr tv_ty
 512                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 513
 514         bound_at = tyVarBindingInfo tv
 515     in
 516     returnM (tidy_env2, Just msg)
 517 \end{code}
 518
 519
 520 %************************************************************************
 521 %*                                                                      *
 522 \subsection{The global tyvars}
 523 %*                                                                      *
 524 %************************************************************************
 525
 526 \begin{code}
 527 tc_extend_gtvs gtvs extra_global_tvs
 528   = readMutVar gtvs             `thenM` \ global_tvs ->
 529     newMutVar (global_tvs `unionVarSet` extra_global_tvs)
 530 \end{code}
 531
 532 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 533 To improve subsequent calls to the same function it writes the zonked set back into
 534 the environment.
 535
 536 \begin{code}
 537 tcGetGlobalTyVars :: TcM TcTyVarSet
 538 tcGetGlobalTyVars
 539   = getLclEnv                                   `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
 540     readMutVar gtv_var                          `thenM` \ gbl_tvs ->
 541     zonkTcTyVarsAndFV (varSetElems gbl_tvs)     `thenM` \ gbl_tvs' ->
 542     writeMutVar gtv_var gbl_tvs'                `thenM_`
 543     returnM gbl_tvs'
 544 \end{code}
 545
 546
 547 %************************************************************************
 548 %*                                                                      *
 549 \subsection{The instance environment}
 550 %*                                                                      *
 551 %************************************************************************
 552
 553 The TcGblEnv holds a mutable variable containing the current full, instance environment.
 554 The ExtendInstEnv functions extend this environment by side effect, in case we are
 555 sucking in new instance declarations deep in the body of a TH splice, which are needed
 556 in another TH splice.  The tcg_insts field of the TcGblEnv contains just the dfuns
 557 from this module
 558
 559 \begin{code}
 560 tcGetInstEnv :: TcM InstEnv
 561 tcGetInstEnv = getGblEnv        `thenM` \ env ->
 562                readMutVar (tcg_inst_env env)
 563
 564 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
 565 -- Horribly imperative;
 566 -- but used only when temporarily enhancing the instance
 567 -- envt during 'deriving' context inference
 568 tcSetInstEnv ie thing_inside
 569   = getGblEnv   `thenM` \ env ->
 570     let
 571         ie_var = tcg_inst_env env
 572     in
 573     readMutVar  ie_var          `thenM` \ old_ie ->
 574     writeMutVar ie_var ie       `thenM_`
 575     thing_inside                `thenM` \ result ->
 576     writeMutVar ie_var old_ie   `thenM_`
 577     returnM result
 578
 579 tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a
 580         -- Add instances from local or imported
 581         -- instances, and refresh the instance-env cache
 582 tcExtendInstEnv dfuns thing_inside
 583  = do { dflags <- getDOpts
 584       ; eps <- getEps
 585       ; env <- getGblEnv
 586       ; let ie_var = tcg_inst_env env
 587       ; inst_env <- readMutVar ie_var
 588       ; let
 589           -- Extend the total inst-env with the new dfuns
 590           (inst_env', errs) = extendInstEnv dflags inst_env dfuns
 591
 592           -- Sort the ones from this module from the others
 593           (lcl_dfuns, pkg_dfuns) = partition (isLocalThing mod) dfuns
 594           mod = tcg_mod env
 595
 596           -- And add the pieces to the right places
 597           (eps_inst_env', _) = extendInstEnv dflags (eps_inst_env eps) pkg_dfuns
 598           eps'               = eps { eps_inst_env = eps_inst_env' }
 599
 600           env'  = env { tcg_insts = lcl_dfuns ++ tcg_insts env }
 601
 602       ; traceDFuns dfuns
 603       ; addErrs errs
 604       ; writeMutVar ie_var inst_env'
 605       ; setEps eps'
 606       ; setGblEnv env' thing_inside }
 607
 608 tcExtendLocalInstEnv :: [InstInfo] -> TcM a -> TcM a
 609   -- Special case for local instance decls
 610 tcExtendLocalInstEnv infos thing_inside
 611  = do { dflags <- getDOpts
 612       ; env <- getGblEnv
 613       ; let ie_var = tcg_inst_env env
 614       ; inst_env <- readMutVar ie_var
 615       ; let
 616           dfuns             = map iDFunId infos
 617           (inst_env', errs) = extendInstEnv dflags inst_env dfuns
 618           env'              = env { tcg_insts = dfuns ++ tcg_insts env }
 619       ; traceDFuns dfuns
 620       ; addErrs errs
 621       ; writeMutVar ie_var inst_env'
 622       ; setGblEnv env' thing_inside }
 623
 624 traceDFuns dfuns
 625   = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
 626   where
 627     pp dfun   = ppr dfun <+> dcolon <+> ppr (idType dfun)
 628 \end{code}
 629
 630
 631 %************************************************************************
 632 %*                                                                      *
 633 \subsection{Rules}
 634 %*                                                                      *
 635 %************************************************************************
 636
 637 \begin{code}
 638 tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a
 639         -- Just pop the new rules into the EPS and envt resp
 640         -- All the rules come from an interface file, not soruce
 641         -- Nevertheless, some may be for this module, if we read
 642         -- its interface instead of its source code
 643 tcExtendRules rules thing_inside
 644  = do { eps <- getEps
 645       ; env <- getGblEnv
 646       ; let
 647           (lcl_rules, pkg_rules) = partition is_local_rule rules
 648           is_local_rule = isLocalThing mod . ifaceRuleDeclName
 649           mod = tcg_mod env
 650
 651           core_rules = [(id,rule) | IfaceRuleOut id rule <- pkg_rules]
 652           eps'   = eps { eps_rule_base = addIfaceRules (eps_rule_base eps) core_rules }
 653                   -- All the rules from an interface are of the IfaceRuleOut form
 654
 655           env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
 656
 657       ; setEps eps'
 658       ; setGblEnv env' thing_inside }
 659
 660 addIfaceRules :: RuleBase -> [IdCoreRule] -> RuleBase
 661 addIfaceRules rule_base rules
 662   = foldl extendRuleBase rule_base rules
 663 \end{code}
 664
 665
 666 %************************************************************************
 667 %*                                                                      *
 668 \subsection{The InstInfo type}
 669 %*                                                                      *
 670 %************************************************************************
 671
 672 The InstInfo type summarises the information in an instance declaration
 673
 674     instance c => k (t tvs) where b
 675
 676 It is used just for *local* instance decls (not ones from interface files).
 677 But local instance decls includes
 678         - derived ones
 679         - generic ones
 680 as well as explicit user written ones.
 681
 682 \begin{code}
 683 data InstInfo
 684   = InstInfo {
 685       iDFunId :: DFunId,                -- The dfun id
 686       iBinds  :: InstBindings
 687     }
 688
 689 data InstBindings
 690   = VanillaInst                 -- The normal case
 691         RenamedMonoBinds        -- Bindings
 692         [RenamedSig]            -- User pragmas recorded for generating
 693                                 -- specialised instances
 694
 695   | NewTypeDerived              -- Used for deriving instances of newtypes, where the
 696         [Type]                  -- witness dictionary is identical to the argument
 697                                 -- dictionary.  Hence no bindings, no pragmas
 698         -- The [Type] are the representation types
 699         -- See notes in TcDeriv
 700
 701 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
 702
 703 pprInstInfoDetails (InstInfo { iBinds = VanillaInst b _ }) = ppr b
 704 pprInstInfoDetails (InstInfo { iBinds = NewTypeDerived _}) = text "Derived from the representation type"
 705
 706 simpleInstInfoTy :: InstInfo -> Type
 707 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
 708                           (_, _, _, [ty]) -> ty
 709
 710 simpleInstInfoTyCon :: InstInfo -> TyCon
 711   -- Gets the type constructor for a simple instance declaration,
 712   -- i.e. one of the form       instance (...) => C (T a b c) where ...
 713 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
 714 \end{code}
 715
 716
 717 %************************************************************************
 718 %*                                                                      *
 719 \subsection{Errors}
 720 %*                                                                      *
 721 %************************************************************************
 722
 723 \begin{code}
 724 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
 725
 726 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
 727                                   ptext SLIT("is not in scope"))
 728 \end{code}