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