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