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