ghc/compiler/typecheck/TcEnv.lhs

   1 \begin{code}
   2 module TcEnv(
   3         TcId, TcIdSet,
   4         TyThing(..), TyThingDetails(..), TcTyThing(..),
   5
   6         -- Getting stuff from the environment
   7         TcEnv, initTcEnv,
   8         tcEnvTyCons, tcEnvClasses, tcEnvIds, tcLEnvElts,
   9         getTcGEnv,
  10
  11         -- Instance environment, and InstInfo type
  12         tcGetInstEnv, tcSetInstEnv,
  13         InstInfo(..), pprInstInfo,
  14         simpleInstInfoTy, simpleInstInfoTyCon,
  15
  16         -- Global environment
  17         tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv,
  18         tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
  19         tcLookupGlobal_maybe, tcLookupGlobal,
  20
  21         -- Local environment
  22         tcExtendKindEnv,  tcLookupLocalIds, tcInLocalScope,
  23         tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
  24         tcExtendLocalValEnv, tcLookup, tcLookup_maybe, tcLookupId,
  25
  26         -- Global type variables
  27         tcGetGlobalTyVars, tcExtendGlobalTyVars,
  28
  29         -- Random useful things
  30         RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe,
  31
  32         -- New Ids
  33         newLocalName, newDFunName,
  34
  35         -- Misc
  36         isLocalThing, tcSetEnv
  37   ) where
  38
  39 #include "HsVersions.h"
  40
  41 import RnHsSyn          ( RenamedMonoBinds, RenamedSig )
  42 import TcMonad
  43 import TcMType          ( zonkTcTyVarsAndFV )
  44 import TcType           ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
  45                           tyVarsOfTypes, tcSplitDFunTy,
  46                           getDFunTyKey, tcTyConAppTyCon
  47                         )
  48 import Id               ( idName, isDataConWrapId_maybe )
  49 import IdInfo           ( vanillaIdInfo )
  50 import Var              ( TyVar, Id, idType, lazySetIdInfo, idInfo )
  51 import VarSet
  52 import DataCon          ( DataCon )
  53 import TyCon            ( TyCon )
  54 import Class            ( Class, ClassOpItem )
  55 import Name             ( Name, NamedThing(..),
  56                           getSrcLoc, mkLocalName, isLocalName, nameIsLocalOrFrom
  57                         )
  58 import NameEnv          ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv,
  59                           extendNameEnvList, emptyNameEnv, plusNameEnv )
  60 import OccName          ( mkDFunOcc, occNameString )
  61 import HscTypes         ( DFunId,
  62                           PackageTypeEnv, TypeEnv,
  63                           extendTypeEnvList, extendTypeEnvWithIds,
  64                           typeEnvTyCons, typeEnvClasses, typeEnvIds,
  65                           HomeSymbolTable
  66                         )
  67 import Module           ( Module )
  68 import InstEnv          ( InstEnv, emptyInstEnv )
  69 import HscTypes         ( lookupType, TyThing(..) )
  70 import Util             ( zipEqual )
  71 import SrcLoc           ( SrcLoc )
  72 import Outputable
  73
  74 import IOExts           ( newIORef )
  75 \end{code}
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection{TcEnv}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 type TcId    = Id                       -- Type may be a TcType
  85 type TcIdSet = IdSet
  86
  87 data TcEnv
  88   = TcEnv {
  89         tcGST    :: Name -> Maybe TyThing,      -- The type environment at the moment we began this compilation
  90
  91         tcInsts  :: InstEnv,            -- All instances (both imported and in this module)
  92
  93         tcGEnv   :: TypeEnv,            -- The global type environment we've accumulated while
  94                  {- NameEnv TyThing-}   -- compiling this module:
  95                                         --      types and classes (both imported and local)
  96                                         --      imported Ids
  97                                         -- (Ids defined in this module start in the local envt,
  98                                         --  though they move to the global envt during zonking)
  99
 100         tcLEnv   :: NameEnv TcTyThing,  -- The local type environment: Ids and TyVars
 101                                         -- defined in this module
 102
 103         tcTyVars :: TcRef TcTyVarSet    -- The "global tyvars"
 104                                         -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars
 105                                         -- mentioned in the types of Ids bound in tcLEnv
 106                                         -- Why mutable? see notes with tcGetGlobalTyVars
 107     }
 108
 109 \end{code}
 110
 111 The Global-Env/Local-Env story
 112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 113 During type checking, we keep in the GlobalEnv
 114         * All types and classes
 115         * All Ids derived from types and classes (constructors, selectors)
 116         * Imported Ids
 117
 118 At the end of type checking, we zonk the local bindings,
 119 and as we do so we add to the GlobalEnv
 120         * Locally defined top-level Ids
 121
 122 Why?  Because they are now Ids not TcIds.  This final GlobalEnv is
 123 used thus:
 124         a) fed back (via the knot) to typechecking the
 125            unfoldings of interface signatures
 126
 127         b) used to augment the GlobalSymbolTable
 128
 129
 130 \begin{code}
 131 initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
 132 initTcEnv hst pte
 133   = do { gtv_var <- newIORef emptyVarSet ;
 134          return (TcEnv { tcGST    = lookup,
 135                          tcGEnv   = emptyNameEnv,
 136                          tcInsts  = emptyInstEnv,
 137                          tcLEnv   = emptyNameEnv,
 138                          tcTyVars = gtv_var
 139          })}
 140   where
 141     lookup name | isLocalName name = Nothing
 142                 | otherwise        = lookupType hst pte name
 143
 144
 145 tcEnvClasses env = typeEnvClasses (tcGEnv env)
 146 tcEnvTyCons  env = typeEnvTyCons  (tcGEnv env)
 147 tcEnvIds     env = typeEnvIds     (tcGEnv env)
 148 tcLEnvElts   env = nameEnvElts (tcLEnv env)
 149
 150 getTcGEnv (TcEnv { tcGEnv = genv }) = genv
 151
 152 tcInLocalScope :: TcEnv -> Name -> Bool
 153 tcInLocalScope env v = v `elemNameEnv` (tcLEnv env)
 154 \end{code}
 155
 156 \begin{code}
 157 data TcTyThing
 158   = AGlobal TyThing             -- Used only in the return type of a lookup
 159   | ATcId   TcId                -- Ids defined in this module
 160   | ATyVar  TyVar               -- Type variables
 161   | AThing  TcKind              -- Used temporarily, during kind checking
 162 -- Here's an example of how the AThing guy is used
 163 -- Suppose we are checking (forall a. T a Int):
 164 --      1. We first bind (a -> AThink kv), where kv is a kind variable.
 165 --      2. Then we kind-check the (T a Int) part.
 166 --      3. Then we zonk the kind variable.
 167 --      4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
 168
 169 \end{code}
 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 [DataCon] [Id]
 177                     | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
 178                     | ForeignTyDetails  -- Nothing yet
 179 \end{code}
 180
 181 %************************************************************************
 182 %*                                                                      *
 183 \subsection{Basic lookups}
 184 %*                                                                      *
 185 %************************************************************************
 186
 187 \begin{code}
 188 lookup_global :: TcEnv -> Name -> Maybe TyThing
 189         -- Try the global envt and then the global symbol table
 190 lookup_global env name
 191   = case lookupNameEnv (tcGEnv env) name of
 192         Just thing -> Just thing
 193         Nothing    -> tcGST env name
 194
 195 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
 196         -- Try the local envt and then try the global
 197 lookup_local env name
 198   = case lookupNameEnv (tcLEnv env) name of
 199         Just thing -> Just thing
 200         Nothing    -> case lookup_global env name of
 201                         Just thing -> Just (AGlobal thing)
 202                         Nothing    -> Nothing
 203 \end{code}
 204
 205 \begin{code}
 206 type RecTcEnv = TcEnv
 207 -- This environment is used for getting the 'right' IdInfo
 208 -- on imported things and for looking up Ids in unfoldings
 209 -- The environment doesn't have any local Ids in it
 210
 211 tcAddImportedIdInfo :: RecTcEnv -> Id -> Id
 212 tcAddImportedIdInfo env id
 213   = id `lazySetIdInfo` new_info
 214         -- The Id must be returned without a data dependency on maybe_id
 215   where
 216     new_info = case tcLookupRecId_maybe env (idName id) of
 217                   Nothing          -> pprTrace "tcAddIdInfo" (ppr id) vanillaIdInfo
 218                   Just imported_id -> idInfo imported_id
 219                 -- ToDo: could check that types are the same
 220
 221 tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
 222 tcLookupRecId_maybe env name = case lookup_global env name of
 223                                    Just (AnId id) -> Just id
 224                                    other          -> Nothing
 225
 226 tcLookupRecId ::  RecTcEnv -> Name -> Id
 227 tcLookupRecId env name = case lookup_global env name of
 228                                 Just (AnId id) -> id
 229                                 Nothing        -> pprPanic "tcLookupRecId" (ppr name)
 230 \end{code}
 231
 232 %************************************************************************
 233 %*                                                                      *
 234 \subsection{Making new Ids}
 235 %*                                                                      *
 236 %************************************************************************
 237
 238 Constructing new Ids
 239
 240 \begin{code}
 241 newLocalName :: Name -> NF_TcM Name
 242 newLocalName name       -- Make a clone
 243   = tcGetUnique         `thenNF_Tc` \ uniq ->
 244     returnNF_Tc (mkLocalName uniq (getOccName name) (getSrcLoc name))
 245 \end{code}
 246
 247 Make a name for the dict fun for an instance decl.
 248 It's a *local* name for the moment.  The CoreTidy pass
 249 will globalise it.
 250
 251 \begin{code}
 252 newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name
 253 newDFunName clas (ty:_) loc
 254   = tcGetUnique                 `thenNF_Tc` \ uniq ->
 255     returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc)
 256   where
 257         -- Any string that is somewhat unique will do
 258     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
 259
 260 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
 261 \end{code}
 262
 263 \begin{code}
 264 isLocalThing :: NamedThing a => Module -> a -> Bool
 265 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
 266 \end{code}
 267
 268 %************************************************************************
 269 %*                                                                      *
 270 \subsection{The global environment}
 271 %*                                                                      *
 272 %************************************************************************
 273
 274 \begin{code}
 275 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
 276 tcExtendGlobalEnv things thing_inside
 277   = tcGetEnv                            `thenNF_Tc` \ env ->
 278     let
 279         ge' = extendTypeEnvList (tcGEnv env) things
 280     in
 281     tcSetEnv (env {tcGEnv = ge'}) thing_inside
 282
 283
 284 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
 285 tcExtendGlobalTypeEnv extra_env thing_inside
 286   = tcGetEnv                            `thenNF_Tc` \ env ->
 287     let
 288         ge' = tcGEnv env `plusNameEnv` extra_env
 289     in
 290     tcSetEnv (env {tcGEnv = ge'}) thing_inside
 291
 292 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
 293 tcExtendGlobalValEnv ids thing_inside
 294   = tcGetEnv                            `thenNF_Tc` \ env ->
 295     let
 296         ge' = extendTypeEnvWithIds (tcGEnv env) ids
 297     in
 298     tcSetEnv (env {tcGEnv = ge'}) thing_inside
 299 \end{code}
 300
 301
 302 \begin{code}
 303 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
 304 tcLookupGlobal_maybe name
 305   = tcGetEnv            `thenNF_Tc` \ env ->
 306     returnNF_Tc (lookup_global env name)
 307 \end{code}
 308
 309 A variety of global lookups, when we know what we are looking for.
 310
 311 \begin{code}
 312 tcLookupGlobal :: Name -> NF_TcM TyThing
 313 tcLookupGlobal name
 314   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_thing ->
 315     case maybe_thing of
 316         Just thing -> returnNF_Tc thing
 317         other      -> notFound "tcLookupGlobal" name
 318
 319 tcLookupGlobalId :: Name -> NF_TcM Id
 320 tcLookupGlobalId name
 321   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_id ->
 322     case maybe_id of
 323         Just (AnId id) -> returnNF_Tc id
 324         other          -> notFound "tcLookupGlobalId" name
 325
 326 tcLookupDataCon :: Name -> TcM DataCon
 327 tcLookupDataCon con_name
 328   = tcLookupGlobalId con_name           `thenNF_Tc` \ con_id ->
 329     case isDataConWrapId_maybe con_id of
 330         Just data_con -> returnTc data_con
 331         Nothing       -> failWithTc (badCon con_id)
 332
 333
 334 tcLookupClass :: Name -> NF_TcM Class
 335 tcLookupClass name
 336   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_clas ->
 337     case maybe_clas of
 338         Just (AClass clas) -> returnNF_Tc clas
 339         other              -> notFound "tcLookupClass" name
 340
 341 tcLookupTyCon :: Name -> NF_TcM TyCon
 342 tcLookupTyCon name
 343   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_tc ->
 344     case maybe_tc of
 345         Just (ATyCon tc) -> returnNF_Tc tc
 346         other            -> notFound "tcLookupTyCon" name
 347
 348 tcLookupId :: Name -> NF_TcM Id
 349 tcLookupId name
 350   = tcLookup name       `thenNF_Tc` \ thing ->
 351     case thing of
 352         ATcId tc_id       -> returnNF_Tc tc_id
 353         AGlobal (AnId id) -> returnNF_Tc id
 354         other             -> pprPanic "tcLookupId" (ppr name)
 355
 356 tcLookupLocalIds :: [Name] -> NF_TcM [TcId]
 357 tcLookupLocalIds ns
 358   = tcGetEnv            `thenNF_Tc` \ env ->
 359     returnNF_Tc (map (lookup (tcLEnv env)) ns)
 360   where
 361     lookup lenv name = case lookupNameEnv lenv name of
 362                         Just (ATcId id) -> id
 363                         other           -> pprPanic "tcLookupLocalIds" (ppr name)
 364 \end{code}
 365
 366
 367 %************************************************************************
 368 %*                                                                      *
 369 \subsection{The local environment}
 370 %*                                                                      *
 371 %************************************************************************
 372
 373 \begin{code}
 374 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
 375 tcLookup_maybe name
 376   = tcGetEnv            `thenNF_Tc` \ env ->
 377     returnNF_Tc (lookup_local env name)
 378
 379 tcLookup :: Name -> NF_TcM TcTyThing
 380 tcLookup name
 381   = tcLookup_maybe name         `thenNF_Tc` \ maybe_thing ->
 382     case maybe_thing of
 383         Just thing -> returnNF_Tc thing
 384         other      -> notFound "tcLookup" name
 385         -- Extract the IdInfo from an IfaceSig imported from an interface file
 386 \end{code}
 387
 388
 389 \begin{code}
 390 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
 391 tcExtendKindEnv pairs thing_inside
 392   = tcGetEnv                            `thenNF_Tc` \ env ->
 393     let
 394         le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
 395         -- No need to extend global tyvars for kind checking
 396     in
 397     tcSetEnv (env {tcLEnv = le'}) thing_inside
 398
 399 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 400 tcExtendTyVarEnv tyvars thing_inside
 401   = tcGetEnv                    `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
 402     let
 403         le'        = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
 404         new_tv_set = mkVarSet tyvars
 405     in
 406         -- It's important to add the in-scope tyvars to the global tyvar set
 407         -- as well.  Consider
 408         --      f (x::r) = let g y = y::r in ...
 409         -- Here, g mustn't be generalised.  This is also important during
 410         -- class and instance decls, when we mustn't generalise the class tyvars
 411         -- when typechecking the methods.
 412     tc_extend_gtvs gtvs new_tv_set              `thenNF_Tc` \ gtvs' ->
 413     tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
 414
 415 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
 416 --      the signature tyvars contain the original names
 417 --      the instance  tyvars are what those names should be mapped to
 418 -- It's needed when typechecking the method bindings of class and instance decls
 419 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
 420
 421 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
 422 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
 423   = tcGetEnv                                    `thenNF_Tc` \ env ->
 424     let
 425         le'   = extendNameEnvList (tcLEnv env) stuff
 426         stuff = [ (getName sig_tv, ATyVar inst_tv)
 427                 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
 428                 ]
 429     in
 430     tcSetEnv (env {tcLEnv = le'}) thing_inside
 431 \end{code}
 432
 433
 434 \begin{code}
 435 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
 436 tcExtendLocalValEnv names_w_ids thing_inside
 437   = tcGetEnv            `thenNF_Tc` \ env ->
 438     let
 439         extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
 440         extra_env           = [(name, ATcId id) | (name,id) <- names_w_ids]
 441         le'                 = extendNameEnvList (tcLEnv env) extra_env
 442     in
 443     tc_extend_gtvs (tcTyVars env) extra_global_tyvars   `thenNF_Tc` \ gtvs' ->
 444     tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
 445 \end{code}
 446
 447
 448 %************************************************************************
 449 %*                                                                      *
 450 \subsection{The global tyvars}
 451 %*                                                                      *
 452 %************************************************************************
 453
 454 \begin{code}
 455 tcExtendGlobalTyVars extra_global_tvs thing_inside
 456   = tcGetEnv                                            `thenNF_Tc` \ env ->
 457     tc_extend_gtvs (tcTyVars env) extra_global_tvs      `thenNF_Tc` \ gtvs' ->
 458     tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
 459
 460 tc_extend_gtvs gtvs extra_global_tvs
 461   = tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 462     tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
 463 \end{code}
 464
 465 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 466 To improve subsequent calls to the same function it writes the zonked set back into
 467 the environment.
 468
 469 \begin{code}
 470 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
 471 tcGetGlobalTyVars
 472   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
 473     tcReadMutVar gtv_var                        `thenNF_Tc` \ gbl_tvs ->
 474     zonkTcTyVarsAndFV (varSetElems gbl_tvs)     `thenNF_Tc` \ gbl_tvs' ->
 475     tcWriteMutVar gtv_var gbl_tvs'              `thenNF_Tc_`
 476     returnNF_Tc gbl_tvs'
 477 \end{code}
 478
 479
 480 %************************************************************************
 481 %*                                                                      *
 482 \subsection{The instance environment}
 483 %*                                                                      *
 484 %************************************************************************
 485
 486 \begin{code}
 487 tcGetInstEnv :: NF_TcM InstEnv
 488 tcGetInstEnv = tcGetEnv         `thenNF_Tc` \ env ->
 489                returnNF_Tc (tcInsts env)
 490
 491 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
 492 tcSetInstEnv ie thing_inside
 493   = tcGetEnv    `thenNF_Tc` \ env ->
 494     tcSetEnv (env {tcInsts = ie}) thing_inside
 495 \end{code}
 496
 497
 498 %************************************************************************
 499 %*                                                                      *
 500 \subsection{The InstInfo type}
 501 %*                                                                      *
 502 %************************************************************************
 503
 504 The InstInfo type summarises the information in an instance declaration
 505
 506     instance c => k (t tvs) where b
 507
 508 \begin{code}
 509 data InstInfo
 510   = InstInfo {
 511       iDFunId :: DFunId,                -- The dfun id
 512       iBinds  :: RenamedMonoBinds,      -- Bindings, b
 513       iPrags  :: [RenamedSig]           -- User pragmas recorded for generating specialised instances
 514     }
 515
 516 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
 517                          nest 4 (ppr (iBinds info))]
 518
 519 simpleInstInfoTy :: InstInfo -> Type
 520 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
 521                           (_, _, _, [ty]) -> ty
 522
 523 simpleInstInfoTyCon :: InstInfo -> TyCon
 524   -- Gets the type constructor for a simple instance declaration,
 525   -- i.e. one of the form       instance (...) => C (T a b c) where ...
 526 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
 527 \end{code}
 528
 529
 530 %************************************************************************
 531 %*                                                                      *
 532 \subsection{Errors}
 533 %*                                                                      *
 534 %************************************************************************
 535
 536 \begin{code}
 537 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
 538
 539 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
 540                                   ptext SLIT("is not in scope"))
 541 \end{code}