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