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