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