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