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, 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 -- Never used for Haskell-source DataCons, hence no ADataCon case
 286 tcLookupGlobalId name
 287   = tcLookupGlobal_maybe name   `thenM` \ maybe_thing ->
 288     case maybe_thing of
 289         Just (AnId id) -> returnM id
 290         other          -> notFound "tcLookupGlobal (id)" name
 291
 292 tcLookupDataCon :: Name -> TcM DataCon
 293 tcLookupDataCon con_name
 294   = tcLookupGlobal_maybe con_name       `thenM` \ maybe_thing ->
 295     case maybe_thing of
 296         Just (ADataCon data_con) -> returnM data_con
 297         other                    -> notFound "tcLookupDataCon" con_name
 298
 299 tcLookupClass :: Name -> TcM Class
 300 tcLookupClass name
 301   = tcLookupGlobal_maybe name   `thenM` \ maybe_clas ->
 302     case maybe_clas of
 303         Just (AClass clas) -> returnM clas
 304         other              -> notFound "tcLookupClass" name
 305
 306 tcLookupTyCon :: Name -> TcM TyCon
 307 tcLookupTyCon name
 308   = tcLookupGlobal_maybe name   `thenM` \ maybe_tc ->
 309     case maybe_tc of
 310         Just (ATyCon tc) -> returnM tc
 311         other            -> notFound "tcLookupTyCon" name
 312
 313
 314 getInGlobalScope :: TcRn m (Name -> Bool)
 315 -- Get all things in the global environment; used for deciding what
 316 -- rules to suck in.  Anything defined in this module (nameIsLocalOrFrom)
 317 -- is certainly in the envt, so we don't bother to look.
 318 getInGlobalScope
 319   = do { mod <- getModule
 320        ; eps <- getEps
 321        ; hpt <- getHpt
 322        ; return (\n -> nameIsLocalOrFrom mod n ||
 323                        isJust (lookupType hpt (eps_PTE eps) n)) }
 324 \end{code}
 325
 326
 327 %************************************************************************
 328 %*                                                                      *
 329 \subsection{The local environment}
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 \begin{code}
 334 tcLookup_maybe :: Name -> TcM (Maybe TcTyThing)
 335 tcLookup_maybe name
 336   = getLclEnv           `thenM` \ local_env ->
 337     case lookupNameEnv (tcl_env local_env) name of
 338         Just thing -> returnM (Just thing)
 339         Nothing    -> tcLookupGlobal_maybe name `thenM` \ mb_res ->
 340                       returnM (case mb_res of
 341                                  Just thing -> Just (AGlobal thing)
 342                                  Nothing    -> Nothing)
 343
 344 tcLookup :: Name -> TcM TcTyThing
 345 tcLookup name
 346   = tcLookup_maybe name         `thenM` \ maybe_thing ->
 347     case maybe_thing of
 348         Just thing -> returnM thing
 349         other      -> notFound "tcLookup" name
 350         -- Extract the IdInfo from an IfaceSig imported from an interface file
 351
 352 tcLookupId :: Name -> TcM Id
 353 -- Used when we aren't interested in the binding level
 354 -- Never a DataCon. (Why does that matter? see TcExpr.tcId)
 355 tcLookupId name
 356   = tcLookup name       `thenM` \ thing ->
 357     case thing of
 358         ATcId tc_id lvl   -> returnM tc_id
 359         AGlobal (AnId id) -> returnM id
 360         other             -> pprPanic "tcLookupId" (ppr name)
 361
 362 tcLookupIdLvl :: Name -> TcM (Id, Level)
 363 -- DataCons dealt with separately
 364 tcLookupIdLvl name
 365   = tcLookup name       `thenM` \ thing ->
 366     case thing of
 367         ATcId tc_id lvl   -> returnM (tc_id, lvl)
 368         AGlobal (AnId id) -> returnM (id, topIdLvl id)
 369         other             -> pprPanic "tcLookupIdLvl" (ppr name)
 370
 371 tcLookupLocalIds :: [Name] -> TcM [TcId]
 372 -- We expect the variables to all be bound, and all at
 373 -- the same level as the lookup.  Only used in one place...
 374 tcLookupLocalIds ns
 375   = getLclEnv           `thenM` \ env ->
 376     returnM (map (lookup (tcl_env env) (metaLevel (tcl_level env))) ns)
 377   where
 378     lookup lenv lvl name
 379         = case lookupNameEnv lenv name of
 380                 Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
 381                 other                -> pprPanic "tcLookupLocalIds" (ppr name)
 382
 383 lclEnvElts :: TcLclEnv -> [TcTyThing]
 384 lclEnvElts env = nameEnvElts (tcl_env env)
 385
 386 getInLocalScope :: TcM (Name -> Bool)
 387   -- Ids only
 388 getInLocalScope = getLclEnv     `thenM` \ env ->
 389                   let
 390                         lcl_env = tcl_env env
 391                   in
 392                   return (`elemNameEnv` lcl_env)
 393 \end{code}
 394
 395 \begin{code}
 396 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
 397 tcExtendKindEnv pairs thing_inside
 398   = updLclEnv upd thing_inside
 399   where
 400     upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
 401     extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- pairs]
 402         -- No need to extend global tyvars for kind checking
 403
 404 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 405 tcExtendTyVarEnv tvs thing_inside
 406   = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside
 407
 408 tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r
 409 tcExtendTyVarEnv2 tv_pairs thing_inside
 410   = tc_extend_tv_env [(getName tv1, ATyVar tv2) | (tv1,tv2) <- tv_pairs]
 411                      [tv | (_,tv) <- tv_pairs]
 412                      thing_inside
 413
 414 tc_extend_tv_env binds tyvars thing_inside
 415   = getLclEnv      `thenM` \ env@(TcLclEnv {tcl_env = le, tcl_tyvars = gtvs}) ->
 416     let
 417         le'        = extendNameEnvList le binds
 418         new_tv_set = mkVarSet tyvars
 419     in
 420         -- It's important to add the in-scope tyvars to the global tyvar set
 421         -- as well.  Consider
 422         --      f (x::r) = let g y = y::r in ...
 423         -- Here, g mustn't be generalised.  This is also important during
 424         -- class and instance decls, when we mustn't generalise the class tyvars
 425         -- when typechecking the methods.
 426     tc_extend_gtvs gtvs new_tv_set              `thenM` \ gtvs' ->
 427     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
 428 \end{code}
 429
 430
 431 \begin{code}
 432 tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a
 433 tcExtendLocalValEnv ids thing_inside
 434   = getLclEnv           `thenM` \ env ->
 435     let
 436         extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
 437         lvl                 = metaLevel (tcl_level env)
 438         extra_env           = [(idName id, ATcId id lvl) | id <- ids]
 439         le'                 = extendNameEnvList (tcl_env env) extra_env
 440     in
 441     tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
 442     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
 443
 444 tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
 445 tcExtendLocalValEnv2 names_w_ids thing_inside
 446   = getLclEnv           `thenM` \ env ->
 447     let
 448         extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
 449         lvl                 = metaLevel (tcl_level env)
 450         extra_env           = [(name, ATcId id lvl) | (name,id) <- names_w_ids]
 451         le'                 = extendNameEnvList (tcl_env env) extra_env
 452     in
 453     tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
 454     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
 455 \end{code}
 456
 457
 458 \begin{code}
 459 -----------------------
 460 -- findGlobals looks at the value environment and finds values
 461 -- whose types mention the offending type variable.  It has to be
 462 -- careful to zonk the Id's type first, so it has to be in the monad.
 463 -- We must be careful to pass it a zonked type variable, too.
 464
 465 findGlobals :: TcTyVarSet
 466              -> TidyEnv
 467              -> TcM (TidyEnv, [SDoc])
 468
 469 findGlobals tvs tidy_env
 470   = getLclEnv           `thenM` \ lcl_env ->
 471     go tidy_env [] (lclEnvElts lcl_env)
 472   where
 473     go tidy_env acc [] = returnM (tidy_env, acc)
 474     go tidy_env acc (thing : things)
 475       = find_thing ignore_it tidy_env thing     `thenM` \ (tidy_env1, maybe_doc) ->
 476         case maybe_doc of
 477           Just d  -> go tidy_env1 (d:acc) things
 478           Nothing -> go tidy_env1 acc     things
 479
 480     ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
 481
 482 -----------------------
 483 find_thing ignore_it tidy_env (ATcId id _)
 484   = zonkTcType  (idType id)     `thenM` \ id_ty ->
 485     if ignore_it id_ty then
 486         returnM (tidy_env, Nothing)
 487     else let
 488         (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
 489         msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
 490                    nest 2 (parens (ptext SLIT("bound at") <+>
 491                                    ppr (getSrcLoc id)))]
 492     in
 493     returnM (tidy_env', Just msg)
 494
 495 find_thing ignore_it tidy_env (ATyVar tv)
 496   = zonkTcTyVar tv              `thenM` \ tv_ty ->
 497     if ignore_it tv_ty then
 498         returnM (tidy_env, Nothing)
 499     else let
 500         (tidy_env1, tv1)     = tidyOpenTyVar tidy_env  tv
 501         (tidy_env2, tidy_ty) = tidyOpenType  tidy_env1 tv_ty
 502         msg = sep [ppr tv1 <+> eq_stuff, nest 2 bound_at]
 503
 504         eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, tv == tv' = empty
 505                  | otherwise                                        = equals <+> ppr tv_ty
 506                 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
 507
 508         bound_at = tyVarBindingInfo tv
 509     in
 510     returnM (tidy_env2, Just msg)
 511 \end{code}
 512
 513
 514 %************************************************************************
 515 %*                                                                      *
 516 \subsection{The global tyvars}
 517 %*                                                                      *
 518 %************************************************************************
 519
 520 \begin{code}
 521 tc_extend_gtvs gtvs extra_global_tvs
 522   = readMutVar gtvs             `thenM` \ global_tvs ->
 523     newMutVar (global_tvs `unionVarSet` extra_global_tvs)
 524 \end{code}
 525
 526 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 527 To improve subsequent calls to the same function it writes the zonked set back into
 528 the environment.
 529
 530 \begin{code}
 531 tcGetGlobalTyVars :: TcM TcTyVarSet
 532 tcGetGlobalTyVars
 533   = getLclEnv                                   `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
 534     readMutVar gtv_var                          `thenM` \ gbl_tvs ->
 535     zonkTcTyVarsAndFV (varSetElems gbl_tvs)     `thenM` \ gbl_tvs' ->
 536     writeMutVar gtv_var gbl_tvs'                `thenM_`
 537     returnM gbl_tvs'
 538 \end{code}
 539
 540
 541 %************************************************************************
 542 %*                                                                      *
 543 \subsection{The instance environment}
 544 %*                                                                      *
 545 %************************************************************************
 546
 547 The TcGblEnv holds a mutable variable containing the current full, instance environment.
 548 The ExtendInstEnv functions extend this environment by side effect, in case we are
 549 sucking in new instance declarations deep in the body of a TH splice, which are needed
 550 in another TH splice.  The tcg_insts field of the TcGblEnv contains just the dfuns
 551 from this module
 552
 553 \begin{code}
 554 tcGetInstEnv :: TcM InstEnv
 555 tcGetInstEnv = do { env <- getGblEnv; readMutVar (tcg_inst_env env) }
 556
 557 tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a
 558         -- Add instances from local or imported
 559         -- instances, and refresh the instance-env cache
 560 tcExtendInstEnv dfuns thing_inside
 561  = do { dflags <- getDOpts
 562       ; eps <- getEps
 563       ; env <- getGblEnv
 564       ; let ie_var = tcg_inst_env env
 565       ; inst_env <- readMutVar ie_var
 566       ; let
 567           -- Extend the total inst-env with the new dfuns
 568           (inst_env', errs) = extendInstEnv dflags inst_env dfuns
 569
 570           -- Sort the ones from this module from the others
 571           (lcl_dfuns, pkg_dfuns) = partition (isLocalThing mod) dfuns
 572           mod = tcg_mod env
 573
 574           -- And add the pieces to the right places
 575           (eps_inst_env', _) = extendInstEnv dflags (eps_inst_env eps) pkg_dfuns
 576           eps'               = eps { eps_inst_env = eps_inst_env' }
 577
 578           env'  = env { tcg_insts = lcl_dfuns ++ tcg_insts env }
 579
 580       ; traceDFuns dfuns
 581       ; addErrs errs
 582       ; writeMutVar ie_var inst_env'
 583       ; setEps eps'
 584       ; setGblEnv env' thing_inside }
 585
 586 tcExtendLocalInstEnv :: [InstInfo] -> TcM a -> TcM a
 587   -- Special case for local instance decls
 588 tcExtendLocalInstEnv infos thing_inside
 589  = do { dflags <- getDOpts
 590       ; env <- getGblEnv
 591       ; let ie_var = tcg_inst_env env
 592       ; inst_env <- readMutVar ie_var
 593       ; let
 594           dfuns             = map iDFunId infos
 595           (inst_env', errs) = extendInstEnv dflags inst_env dfuns
 596           env'              = env { tcg_insts = dfuns ++ tcg_insts env }
 597       ; traceDFuns dfuns
 598       ; addErrs errs
 599       ; writeMutVar ie_var inst_env'
 600       ; setGblEnv env' thing_inside }
 601
 602 tcExtendTempInstEnv :: [DFunId] -> TcM a -> TcM a
 603   -- Extend the instance envt, but with *no* permanent
 604   -- effect on mutable variables; also ignore errors
 605   -- Used during 'deriving' stuff
 606 tcExtendTempInstEnv dfuns thing_inside
 607  = do { dflags <- getDOpts
 608       ; env <- getGblEnv
 609       ; let ie_var = tcg_inst_env env
 610       ; inst_env <- readMutVar ie_var
 611       ; let (inst_env', errs) = extendInstEnv dflags inst_env dfuns
 612         -- Ignore the errors about duplicate instances.
 613         -- We don't want repeated error messages
 614         -- They'll appear later, when we do the top-level extendInstEnvs
 615       ; writeMutVar ie_var inst_env'
 616       ; result <- thing_inside
 617       ; writeMutVar ie_var inst_env     -- Restore!
 618       ; return result }
 619
 620 tcWithTempInstEnv :: TcM a -> TcM a
 621 -- Run thing_inside, discarding any effects on the instance environment
 622 tcWithTempInstEnv thing_inside
 623    = do { env <- getGblEnv
 624         ; let ie_var = tcg_inst_env env
 625         ; old_ie <- readMutVar  ie_var
 626         ; result <- thing_inside
 627         ; writeMutVar ie_var old_ie     -- Restore
 628         ; return result }
 629
 630 traceDFuns dfuns
 631   = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
 632   where
 633     pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
 634 \end{code}
 635
 636
 637 %************************************************************************
 638 %*                                                                      *
 639 \subsection{Rules}
 640 %*                                                                      *
 641 %************************************************************************
 642
 643 \begin{code}
 644 tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a
 645         -- Just pop the new rules into the EPS and envt resp
 646         -- All the rules come from an interface file, not soruce
 647         -- Nevertheless, some may be for this module, if we read
 648         -- its interface instead of its source code
 649 tcExtendRules rules thing_inside
 650  = do { eps <- getEps
 651       ; env <- getGblEnv
 652       ; let
 653           (lcl_rules, pkg_rules) = partition is_local_rule rules
 654           is_local_rule = isLocalThing mod . ifaceRuleDeclName
 655           mod = tcg_mod env
 656
 657           core_rules = [(id,rule) | IfaceRuleOut id rule <- pkg_rules]
 658           eps'   = eps { eps_rule_base = addIfaceRules (eps_rule_base eps) core_rules }
 659                   -- All the rules from an interface are of the IfaceRuleOut form
 660
 661           env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
 662
 663       ; setEps eps'
 664       ; setGblEnv env' thing_inside }
 665
 666 addIfaceRules :: RuleBase -> [IdCoreRule] -> RuleBase
 667 addIfaceRules rule_base rules
 668   = foldl extendRuleBase rule_base rules
 669 \end{code}
 670
 671
 672 %************************************************************************
 673 %*                                                                      *
 674 \subsection{The InstInfo type}
 675 %*                                                                      *
 676 %************************************************************************
 677
 678 The InstInfo type summarises the information in an instance declaration
 679
 680     instance c => k (t tvs) where b
 681
 682 It is used just for *local* instance decls (not ones from interface files).
 683 But local instance decls includes
 684         - derived ones
 685         - generic ones
 686 as well as explicit user written ones.
 687
 688 \begin{code}
 689 data InstInfo
 690   = InstInfo {
 691       iDFunId :: DFunId,                -- The dfun id
 692       iBinds  :: InstBindings
 693     }
 694
 695 data InstBindings
 696   = VanillaInst                 -- The normal case
 697         RenamedMonoBinds        -- Bindings
 698         [RenamedSig]            -- User pragmas recorded for generating
 699                                 -- specialised instances
 700
 701   | NewTypeDerived              -- Used for deriving instances of newtypes, where the
 702         [Type]                  -- witness dictionary is identical to the argument
 703                                 -- dictionary.  Hence no bindings, no pragmas
 704         -- The [Type] are the representation types
 705         -- See notes in TcDeriv
 706
 707 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
 708
 709 pprInstInfoDetails (InstInfo { iBinds = VanillaInst b _ }) = ppr b
 710 pprInstInfoDetails (InstInfo { iBinds = NewTypeDerived _}) = text "Derived from the representation type"
 711
 712 simpleInstInfoTy :: InstInfo -> Type
 713 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
 714                           (_, _, _, [ty]) -> ty
 715
 716 simpleInstInfoTyCon :: InstInfo -> TyCon
 717   -- Gets the type constructor for a simple instance declaration,
 718   -- i.e. one of the form       instance (...) => C (T a b c) where ...
 719 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
 720 \end{code}
 721
 722
 723 %************************************************************************
 724 %*                                                                      *
 725 \subsection{Errors}
 726 %*                                                                      *
 727 %************************************************************************
 728
 729 \begin{code}
 730 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
 731
 732 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
 733                                   ptext SLIT("is not in scope"))
 734 \end{code}