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