ghc/compiler/typecheck/TcEnv.lhs

   1 \begin{code}
   2 module TcEnv(
   3         TcId, TcIdSet,
   4         TyThing(..), TyThingDetails(..),
   5
   6         -- Getting stuff from the environment
   7         TcEnv, initTcEnv,
   8         tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds,
   9
  10         -- Instance environment
  11         tcGetInstEnv, tcSetInstEnv,
  12
  13         -- Global environment
  14         tcExtendGlobalEnv, tcExtendGlobalValEnv,
  15         tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
  16         tcLookupGlobal_maybe,
  17
  18         -- Local environment
  19         tcExtendKindEnv,
  20         tcExtendTyVarEnv, tcExtendTyVarEnvForMeths,
  21         tcExtendLocalValEnv,
  22
  23         -- Global type variables
  24         tcGetGlobalTyVars, tcExtendGlobalTyVars,
  25
  26         -- Random useful things
  27         tcAddImportedIdInfo, tcInstId,
  28
  29         -- New Ids
  30         newLocalId, newSpecPragmaId,
  31         newDefaultMethodName, newDFunName
  32   ) where
  33
  34 #include "HsVersions.h"
  35
  36 import TcMonad
  37 import TcType   ( TcKind,  TcType, TcTyVar, TcTyVarSet, TcThetaType,
  38                   tcInstTyVars, zonkTcTyVars,
  39                 )
  40 import Id       ( mkUserLocal, isDataConWrapId_maybe )
  41 import IdInfo   ( vanillaIdInfo )
  42 import MkId     ( mkSpecPragmaId )
  43 import Var      ( TyVar, Id, setVarName,
  44                   idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
  45                 )
  46 import VarSet
  47 import VarEnv   ( TyVarSubstEnv )
  48 import Type     ( Kind, Type, superKind,
  49                   tyVarsOfType, tyVarsOfTypes,
  50                   splitForAllTys, splitRhoTy, splitFunTys,
  51                   splitAlgTyConApp_maybe, getTyVar, getDFunTyKey
  52                 )
  53 import DataCon  ( DataCon )
  54 import TyCon    ( TyCon, tyConKind, tyConArity, isSynTyCon )
  55 import Class    ( Class, ClassOpItem, ClassContext, classTyCon )
  56 import Subst    ( substTy )
  57 import Name     ( Name, OccName, Provenance(..), ExportFlag(..), NamedThing(..),
  58                   nameOccName, nameModule, getSrcLoc, mkGlobalName,
  59                   isLocallyDefined,
  60                   NameEnv, emptyNameEnv, lookupNameEnv, nameEnvElts,
  61                   extendNameEnv, extendNameEnvList
  62                 )
  63 import OccName  ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
  64 import Module   ( Module )
  65 import Unify    ( unifyTyListsX, matchTys )
  66 import HscTypes ( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..),
  67                   GlobalSymbolTable )
  68 import Unique   ( pprUnique10, Unique, Uniquable(..) )
  69 import UniqFM
  70 import Unique   ( Uniquable(..) )
  71 import Util     ( zipEqual, zipWith3Equal, mapAccumL )
  72 import SrcLoc   ( SrcLoc )
  73 import FastString       ( FastString )
  74 import Maybes
  75 import Outputable
  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   :: NameEnv TyThing,    -- The global type environment we've accumulated while
  96                                         -- 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 -> InstEnv -> IO TcEnv
 145 initTcEnv gst inst_env
 146   = do { gtv_var <- newIORef emptyVarSet ;
 147          return (TcEnv { tcGST    = gst,
 148                          tcGEnv   = emptyNameEnv,
 149                          tcInsts  = inst_env,
 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 -- This data type is used to help tie the knot
 161 -- when type checking type and class declarations
 162 data TyThingDetails = SynTyDetails Type
 163                     | DataTyDetails ClassContext [DataCon] [Class]
 164                     | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
 165 \end{code}
 166
 167
 168 %************************************************************************
 169 %*                                                                      *
 170 \subsection{Basic lookups}
 171 %*                                                                      *
 172 %************************************************************************
 173
 174 \begin{code}
 175 lookup_global :: TcEnv -> Name -> Maybe TyThing
 176         -- Try the global envt and then the global symbol table
 177 lookup_global env name
 178   = case lookupNameEnv (tcGEnv env) name of
 179         Just thing -> Just thing
 180         Nothing    -> lookupTypeEnv (tcGST env) name
 181
 182 lookup_local :: TcEnv -> Name -> Maybe TcTyThing
 183         -- Try the local envt and then try the global
 184 lookup_local env name
 185   = case lookupNameEnv (tcLEnv env) name of
 186         Just thing -> Just thing
 187         Nothing    -> case lookup_global env name of
 188                         Just thing -> Just (AGlobal thing)
 189                         Nothing    -> Nothing
 190
 191 explicitLookupId :: TcEnv -> Name -> Maybe Id
 192 explicitLookupId env name = case lookup_global env name of
 193                                 Just (AnId id) -> Just id
 194                                 other          -> Nothing
 195 \end{code}
 196
 197
 198 %************************************************************************
 199 %*                                                                      *
 200 \subsection{Random useful functions}
 201 %*                                                                      *
 202 %************************************************************************
 203
 204
 205 \begin{code}
 206 -- A useful function that takes an occurrence of a global thing
 207 -- and instantiates its type with fresh type variables
 208 tcInstId :: Id
 209          -> NF_TcM ([TcTyVar],  -- It's instantiated type
 210                       TcThetaType,      --
 211                       TcType)           --
 212 tcInstId id
 213   = let
 214       (tyvars, rho) = splitForAllTys (idType id)
 215     in
 216     tcInstTyVars tyvars         `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
 217     let
 218         rho'           = substTy tenv rho
 219         (theta', tau') = splitRhoTy rho'
 220     in
 221     returnNF_Tc (tyvars', theta', tau')
 222
 223 tcAddImportedIdInfo :: TcEnv -> Id -> Id
 224 tcAddImportedIdInfo unf_env id
 225   | isLocallyDefined id         -- Don't look up locally defined Ids, because they
 226                                 -- have explicit local definitions, so we get a black hole!
 227   = id
 228   | otherwise
 229   = id `lazySetIdInfo` new_info
 230         -- The Id must be returned without a data dependency on maybe_id
 231   where
 232     new_info = case explicitLookupId unf_env (getName id) of
 233                      Nothing          -> vanillaIdInfo
 234                      Just imported_id -> idInfo imported_id
 235                 -- ToDo: could check that types are the same
 236 \end{code}
 237
 238
 239 %************************************************************************
 240 %*                                                                      *
 241 \subsection{Making new Ids}
 242 %*                                                                      *
 243 %************************************************************************
 244
 245 Constructing new Ids
 246
 247 \begin{code}
 248 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId
 249 newLocalId name ty loc
 250   = tcGetUnique         `thenNF_Tc` \ uniq ->
 251     returnNF_Tc (mkUserLocal name uniq ty loc)
 252
 253 newSpecPragmaId :: Name -> TcType -> NF_TcM TcId
 254 newSpecPragmaId name ty
 255   = tcGetUnique         `thenNF_Tc` \ uniq ->
 256     returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
 257 \end{code}
 258
 259 Make a name for the dict fun for an instance decl
 260
 261 \begin{code}
 262 newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name
 263 newDFunName mod clas (ty:_) loc
 264   = tcGetDFunUniq dfun_string   `thenNF_Tc` \ inst_uniq ->
 265     tcGetUnique                 `thenNF_Tc` \ uniq ->
 266     returnNF_Tc (mkGlobalName uniq mod
 267                               (mkDFunOcc dfun_string inst_uniq)
 268                               (LocalDef loc Exported))
 269   where
 270         -- Any string that is somewhat unique will do
 271     dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
 272
 273 newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name
 274 newDefaultMethodName op_name loc
 275   = tcGetUnique                 `thenNF_Tc` \ uniq ->
 276     returnNF_Tc (mkGlobalName uniq (nameModule op_name)
 277                               (mkDefaultMethodOcc (getOccName op_name))
 278                               (LocalDef loc Exported))
 279 \end{code}
 280
 281
 282 %************************************************************************
 283 %*                                                                      *
 284 \subsection{The global environment}
 285 %*                                                                      *
 286 %************************************************************************
 287
 288 \begin{code}
 289 tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
 290 tcExtendGlobalEnv bindings thing_inside
 291   = tcGetEnv                            `thenNF_Tc` \ env ->
 292     let
 293         ge' = extendNameEnvList (tcGEnv env) bindings
 294     in
 295     tcSetEnv (env {tcGEnv = ge'}) thing_inside
 296
 297 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
 298 tcExtendGlobalValEnv ids thing_inside
 299   = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
 300 \end{code}
 301
 302
 303 \begin{code}
 304 tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing)
 305 tcLookupGlobal_maybe name
 306   = tcGetEnv            `thenNF_Tc` \ env ->
 307     returnNF_Tc (lookup_global env name)
 308 \end{code}
 309
 310 A variety of global lookups, when we know what we are looking for.
 311
 312 \begin{code}
 313 tcLookupGlobal :: Name -> NF_TcM TyThing
 314 tcLookupGlobal name
 315   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_thing ->
 316     case maybe_thing of
 317         Just thing -> returnNF_Tc thing
 318         other      -> notFound "tcLookupGlobal:" name
 319
 320 tcLookupGlobalId :: Name -> NF_TcM Id
 321 tcLookupGlobalId name
 322   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_id ->
 323     case maybe_id of
 324         Just (AnId clas) -> returnNF_Tc clas
 325         other            -> notFound "tcLookupGlobalId:" name
 326
 327 tcLookupDataCon :: Name -> TcM DataCon
 328 tcLookupDataCon con_name
 329   = tcLookupGlobalId con_name           `thenNF_Tc` \ con_id ->
 330     case isDataConWrapId_maybe con_id of
 331         Just data_con -> returnTc data_con
 332         Nothing       -> failWithTc (badCon con_id)
 333
 334
 335 tcLookupClass :: Name -> NF_TcM Class
 336 tcLookupClass name
 337   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_clas ->
 338     case maybe_clas of
 339         Just (AClass clas) -> returnNF_Tc clas
 340         other              -> notFound "tcLookupClass:" name
 341
 342 tcLookupTyCon :: Name -> NF_TcM TyCon
 343 tcLookupTyCon name
 344   = tcLookupGlobal_maybe name   `thenNF_Tc` \ maybe_tc ->
 345     case maybe_tc of
 346         Just (ATyCon tc) -> returnNF_Tc tc
 347         other            -> notFound "tcLookupTyCon:" name
 348 \end{code}
 349
 350
 351 %************************************************************************
 352 %*                                                                      *
 353 \subsection{The local environment}
 354 %*                                                                      *
 355 %************************************************************************
 356
 357 \begin{code}
 358 tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing)
 359 tcLookup_maybe name
 360   = tcGetEnv            `thenNF_Tc` \ env ->
 361     returnNF_Tc (lookup_local env name)
 362
 363 tcLookup :: Name -> NF_TcM TcTyThing
 364 tcLookup name
 365   = tcLookup_maybe name         `thenNF_Tc` \ maybe_thing ->
 366     case maybe_thing of
 367         Just thing -> returnNF_Tc thing
 368         other      -> notFound "tcLookup:" name
 369         -- Extract the IdInfo from an IfaceSig imported from an interface file
 370 \end{code}
 371
 372
 373 \begin{code}
 374 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
 375 tcExtendKindEnv pairs thing_inside
 376   = tcGetEnv                            `thenNF_Tc` \ env ->
 377     let
 378         le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs]
 379         -- No need to extend global tyvars for kind checking
 380     in
 381     tcSetEnv (env {tcLEnv = le'}) thing_inside
 382
 383 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 384 tcExtendTyVarEnv tyvars thing_inside
 385   = tcGetEnv                    `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) ->
 386     let
 387         le'        = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars]
 388         new_tv_set = mkVarSet tyvars
 389     in
 390         -- It's important to add the in-scope tyvars to the global tyvar set
 391         -- as well.  Consider
 392         --      f (x::r) = let g y = y::r in ...
 393         -- Here, g mustn't be generalised.  This is also important during
 394         -- class and instance decls, when we mustn't generalise the class tyvars
 395         -- when typechecking the methods.
 396     tc_extend_gtvs gtvs new_tv_set              `thenNF_Tc` \ gtvs' ->
 397     tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
 398
 399 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
 400 --      the signature tyvars contain the original names
 401 --      the instance  tyvars are what those names should be mapped to
 402 -- It's needed when typechecking the method bindings of class and instance decls
 403 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
 404
 405 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r
 406 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
 407   = tcGetEnv                                    `thenNF_Tc` \ env ->
 408     let
 409         le'   = extendNameEnvList (tcLEnv env) stuff
 410         stuff = [ (getName sig_tv, ATyVar inst_tv)
 411                 | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
 412                 ]
 413     in
 414     tcSetEnv (env {tcLEnv = le'}) thing_inside
 415 \end{code}
 416
 417
 418 \begin{code}
 419 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a
 420 tcExtendLocalValEnv names_w_ids thing_inside
 421   = tcGetEnv            `thenNF_Tc` \ env ->
 422     let
 423         extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
 424         extra_env           = [(name, ATcId id) | (name,id) <- names_w_ids]
 425         le'                 = extendNameEnvList (tcLEnv env) extra_env
 426     in
 427     tc_extend_gtvs (tcTyVars env) extra_global_tyvars   `thenNF_Tc` \ gtvs' ->
 428     tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside
 429 \end{code}
 430
 431
 432 %************************************************************************
 433 %*                                                                      *
 434 \subsection{The global tyvars}
 435 %*                                                                      *
 436 %************************************************************************
 437
 438 \begin{code}
 439 tcExtendGlobalTyVars extra_global_tvs thing_inside
 440   = tcGetEnv                                            `thenNF_Tc` \ env ->
 441     tc_extend_gtvs (tcTyVars env) extra_global_tvs      `thenNF_Tc` \ gtvs' ->
 442     tcSetEnv (env {tcTyVars = gtvs'}) thing_inside
 443
 444 tc_extend_gtvs gtvs extra_global_tvs
 445   = tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 446     tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)
 447 \end{code}
 448
 449 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 450 To improve subsequent calls to the same function it writes the zonked set back into
 451 the environment.
 452
 453 \begin{code}
 454 tcGetGlobalTyVars :: NF_TcM TcTyVarSet
 455 tcGetGlobalTyVars
 456   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) ->
 457     tcReadMutVar gtv_var                        `thenNF_Tc` \ global_tvs ->
 458     zonkTcTyVars (varSetElems global_tvs)       `thenNF_Tc` \ global_tys' ->
 459     let
 460         global_tvs' = (tyVarsOfTypes global_tys')
 461     in
 462     tcWriteMutVar gtv_var global_tvs'           `thenNF_Tc_`
 463     returnNF_Tc global_tvs'
 464 \end{code}
 465
 466
 467 %************************************************************************
 468 %*                                                                      *
 469 \subsection{The instance environment}
 470 %*                                                                      *
 471 %************************************************************************
 472
 473 \begin{code}
 474 tcGetInstEnv :: NF_TcM InstEnv
 475 tcGetInstEnv = tcGetEnv         `thenNF_Tc` \ env ->
 476                returnNF_Tc (tcInsts env)
 477
 478 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
 479 tcSetInstEnv ie thing_inside
 480   = tcGetEnv    `thenNF_Tc` \ env ->
 481     tcSetEnv (env {tcInsts = ie}) thing_inside
 482 \end{code}
 483
 484
 485 %************************************************************************
 486 %*                                                                      *
 487 \subsection{Errors}
 488 %*                                                                      *
 489 %************************************************************************
 490
 491 \begin{code}
 492 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
 493
 494 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
 495                                   ptext SLIT("is not in scope"))
 496 \end{code}