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