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