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