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