ghc/compiler/typecheck/TcEnv.lhs

   1 \begin{code}
   2 module TcEnv(
   3         TcId, TcIdSet, tcInstId,
   4         tcLookupDataCon,
   5
   6         TcEnv, ValueEnv, TcTyThing(..),
   7
   8         initEnv, getEnvTyCons, getEnvClasses, getEnvAllTyCons,
   9
  10         tcExtendUVarEnv, tcLookupUVar,
  11
  12         tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars,
  13
  14         tcLookupTy,
  15         tcLookupTyConByKey,
  16         tcLookupClassByKey, tcLookupClassByKey_maybe,
  17
  18         tcExtendGlobalValEnv, tcExtendLocalValEnv,
  19         tcGetValueEnv,        tcSetValueEnv,
  20         tcAddImportedIdInfo,
  21
  22         tcLookupValue,      tcLookupValueMaybe,
  23         tcLookupValueByKey, tcLookupValueByKeyMaybe,
  24         explicitLookupValueByKey, explicitLookupValue,
  25         valueEnvIds,
  26
  27         newLocalId, newSpecPragmaId,
  28         tcGetGlobalTyVars, tcExtendGlobalTyVars,
  29
  30         badCon, badPrimOp
  31   ) where
  32
  33 #include "HsVersions.h"
  34
  35 import HsTypes  ( HsTyVarBndr, getTyVarName )
  36 import Id       ( mkUserLocal, isDataConWrapId_maybe )
  37 import MkId     ( mkSpecPragmaId )
  38 import Var      ( TyVar, Id, setVarName,
  39                   idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
  40                 )
  41 import TcType   ( TcType, TcTyVar, TcTyVarSet, TcThetaType,
  42                   tcInstTyVars, zonkTcTyVars,
  43                   TcKind, kindToTcKind
  44                 )
  45 import VarEnv
  46 import VarSet
  47 import Type     ( Kind, superKind,
  48                   tyVarsOfType, tyVarsOfTypes, mkTyVarTy,
  49                   splitForAllTys, splitRhoTy, splitFunTys,
  50                   splitAlgTyConApp_maybe, getTyVar
  51                 )
  52 import Subst    ( substTy )
  53 import UsageSPUtils ( unannotTy )
  54 import DataCon  ( DataCon )
  55 import TyCon    ( TyCon, tyConKind, tyConArity, isSynTyCon )
  56 import Class    ( Class, classTyCon )
  57
  58 import TcMonad
  59
  60 import BasicTypes       ( Arity )
  61 import IdInfo           ( vanillaIdInfo )
  62 import Name             ( Name, OccName, nameOccName, getSrcLoc,
  63                           maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
  64                           NamedThing(..)
  65                         )
  66 import Unique           ( pprUnique10, Unique, Uniquable(..) )
  67 import FiniteMap        ( lookupFM, addToFM )
  68 import UniqFM
  69 import Unique           ( Uniquable(..) )
  70 import Util             ( zipEqual, zipWith3Equal, mapAccumL )
  71 import Bag              ( bagToList )
  72 import Maybes           ( maybeToBool, catMaybes )
  73 import SrcLoc           ( SrcLoc )
  74 import FastString       ( FastString )
  75 import Outputable
  76 \end{code}
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection{TcId}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84
  85 \begin{code}
  86 type TcId    = Id                       -- Type may be a TcType
  87 type TcIdSet = IdSet
  88
  89 tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType)
  90 tcLookupDataCon con_name
  91   = tcLookupValue con_name              `thenNF_Tc` \ con_id ->
  92     case isDataConWrapId_maybe con_id of {
  93         Nothing -> failWithTc (badCon con_id);
  94         Just data_con ->
  95
  96     tcInstId con_id                     `thenNF_Tc` \ (_, _, con_tau) ->
  97              -- Ignore the con_theta; overloaded constructors only
  98              -- behave differently when called, not when used for
  99              -- matching.
 100     let
 101         (arg_tys, result_ty) = splitFunTys con_tau
 102     in
 103     ASSERT( maybeToBool (splitAlgTyConApp_maybe result_ty) )
 104     returnTc (data_con, arg_tys, result_ty) }
 105
 106 -- A useful function that takes an occurrence of a global thing
 107 -- and instantiates its type with fresh type variables
 108 tcInstId :: Id
 109          -> NF_TcM s ([TcTyVar],        -- It's instantiated type
 110                       TcThetaType,      --
 111                       TcType)           --
 112 tcInstId id
 113   = let
 114       (tyvars, rho) = splitForAllTys (unannotTy (idType id))
 115     in
 116     tcInstTyVars tyvars         `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
 117     let
 118         rho'           = substTy tenv rho
 119         (theta', tau') = splitRhoTy rho'
 120     in
 121     returnNF_Tc (tyvars', theta', tau')
 122 \end{code}
 123
 124 Between the renamer and the first invocation of the UsageSP inference,
 125 identifiers read from interface files will have usage information in
 126 their types, whereas other identifiers will not.  The unannotTy here
 127 in @tcInstId@ prevents this information from pointlessly propagating
 128 further prior to the first usage inference.
 129
 130
 131 %************************************************************************
 132 %*                                                                      *
 133 \subsection{TcEnv}
 134 %*                                                                      *
 135 %************************************************************************
 136
 137 Data type declarations
 138 ~~~~~~~~~~~~~~~~~~~~~
 139
 140 \begin{code}
 141 data TcEnv = TcEnv
 142                   UsageEnv
 143                   TypeEnv
 144                   ValueEnv
 145                   (TcTyVarSet,          -- The in-scope TyVars
 146                    TcRef TcTyVarSet)    -- Free type variables of the value env
 147                                         -- ...why mutable? see notes with tcGetGlobalTyVars
 148                                         -- Includes the in-scope tyvars
 149
 150 type NameEnv val = UniqFM val           -- Keyed by Names
 151
 152 type UsageEnv   = NameEnv UVar
 153 type TypeEnv    = NameEnv (TcKind, TcTyThing)
 154 type ValueEnv   = NameEnv Id
 155
 156 valueEnvIds :: ValueEnv -> [Id]
 157 valueEnvIds ve = eltsUFM ve
 158
 159 data TcTyThing = ATyVar TcTyVar         -- Mutable only so that the kind can be mutable
 160                                         -- if the kind is mutable, the tyvar must be so that
 161                                         -- zonking works
 162                | ADataTyCon TyCon
 163                | ASynTyCon TyCon Arity
 164                | AClass Class Arity
 165
 166
 167 initEnv :: TcRef TcTyVarSet -> TcEnv
 168 initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM (emptyVarSet, mut)
 169
 170 getEnvClasses (TcEnv _ te _ _) = [cl | (_, AClass cl _) <- eltsUFM te]
 171
 172 getEnvTyCons  (TcEnv _ te _ _) = catMaybes (map get_tc (eltsUFM te))
 173     where
 174       get_tc (_, ADataTyCon tc)  = Just tc
 175       get_tc (_, ASynTyCon tc _) = Just tc
 176       get_tc other               = Nothing
 177
 178 getEnvAllTyCons te_list = catMaybes (map get_tc te_list)
 179         -- The 'all' means 'including the tycons from class decls'
 180     where
 181       get_tc (_, ADataTyCon tc)  = Just tc
 182       get_tc (_, ASynTyCon tc _) = Just tc
 183       get_tc (_, AClass cl _)    = Just (classTyCon cl)
 184       get_tc other               = Nothing
 185 \end{code}
 186
 187 The UsageEnv
 188 ~~~~~~~~~~~~
 189
 190 Extending the usage environment.
 191
 192 \begin{code}
 193 tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r
 194 tcExtendUVarEnv uv_name uv scope
 195   = tcGetEnv                                                 `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 196     tcSetEnv (TcEnv (addToUFM ue uv_name uv) te ve gtvs) scope
 197 \end{code}
 198
 199 Looking up in the environments.
 200
 201 \begin{code}
 202 tcLookupUVar :: Name -> NF_TcM s UVar
 203 tcLookupUVar uv_name
 204   = tcGetEnv    `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 205     case lookupUFM ue uv_name of
 206       Just uv -> returnNF_Tc uv
 207       Nothing -> failWithTc (uvNameOutOfScope uv_name)
 208 \end{code}
 209
 210
 211 The TypeEnv
 212 ~~~~~~~~~~~~
 213
 214 Extending the type environment.
 215
 216 \begin{code}
 217 tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r
 218 tcExtendTyVarEnv tyvars scope
 219   = tcGetEnv                            `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) ->
 220     let
 221         extend_list = [ (getName tv, (kindToTcKind (tyVarKind tv), ATyVar tv))
 222                       | tv <- tyvars
 223                       ]
 224         te'           = addListToUFM te extend_list
 225         new_tv_set    = mkVarSet tyvars
 226         in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set
 227     in
 228         -- It's important to add the in-scope tyvars to the global tyvar set
 229         -- as well.  Consider
 230         --      f (x::r) = let g y = y::r in ...
 231         -- Here, g mustn't be generalised.  This is also important during
 232         -- class and instance decls, when we mustn't generalise the class tyvars
 233         -- when typechecking the methods.
 234     tc_extend_gtvs gtvs new_tv_set              `thenNF_Tc` \ gtvs' ->
 235     tcSetEnv (TcEnv ue te' ve (in_scope_tvs', gtvs')) scope
 236
 237 -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars:
 238 --      the signature tyvars contain the original names
 239 --      the instance  tyvars are what those names should be mapped to
 240 -- It's needed when typechecking the method bindings of class and instance decls
 241 -- It does *not* extend the global tyvars; tcMethodBind does that for itself
 242
 243 tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r
 244 tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside
 245   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 246     let
 247         te' = addListToUFM te stuff
 248     in
 249     tcSetEnv (TcEnv ue te' ve gtvs) thing_inside
 250   where
 251     stuff = [ (getName sig_tv, (kindToTcKind (tyVarKind inst_tv), ATyVar inst_tv))
 252             | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars
 253             ]
 254
 255 tcExtendGlobalTyVars extra_global_tvs scope
 256   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv ue te ve (in_scope,gtvs)) ->
 257     tc_extend_gtvs gtvs extra_global_tvs        `thenNF_Tc` \ gtvs' ->
 258     tcSetEnv (TcEnv ue te ve (in_scope,gtvs')) scope
 259
 260 tc_extend_gtvs gtvs extra_global_tvs
 261   = tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 262     let
 263         new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs
 264     in
 265     tcNewMutVar new_global_tyvars
 266 \end{code}
 267
 268 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 269 To improve subsequent calls to the same function it writes the zonked set back into
 270 the environment.
 271
 272 \begin{code}
 273 tcGetGlobalTyVars :: NF_TcM s TcTyVarSet
 274 tcGetGlobalTyVars
 275   = tcGetEnv                                            `thenNF_Tc` \ (TcEnv ue te ve (_,gtvs)) ->
 276     tcReadMutVar gtvs                                   `thenNF_Tc` \ global_tvs ->
 277     zonkTcTyVars (varSetElems global_tvs)               `thenNF_Tc` \ global_tys' ->
 278     let
 279         global_tvs' = (tyVarsOfTypes global_tys')
 280     in
 281     tcWriteMutVar gtvs global_tvs'                      `thenNF_Tc_`
 282     returnNF_Tc global_tvs'
 283
 284 tcGetInScopeTyVars :: NF_TcM s [TcTyVar]
 285 tcGetInScopeTyVars
 286   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs, gtvs)) ->
 287     returnNF_Tc (varSetElems in_scope_tvs)
 288 \end{code}
 289
 290
 291 Type constructors and classes
 292
 293 \begin{code}
 294 tcExtendTypeEnv :: [(Name, (TcKind, TcTyThing))] -> TcM s r -> TcM s r
 295 tcExtendTypeEnv bindings scope
 296   = ASSERT( null [tv | (_, (_,ATyVar tv)) <- bindings] )
 297         -- Not for tyvars; use tcExtendTyVarEnv
 298     tcGetEnv                                    `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 299     let
 300         te' = addListToUFM te bindings
 301     in
 302     tcSetEnv (TcEnv ue te' ve gtvs) scope
 303 \end{code}
 304
 305
 306 Looking up in the environments.
 307
 308 \begin{code}
 309 tcLookupTy :: Name ->  NF_TcM s (TcKind, TcTyThing)
 310 tcLookupTy name
 311   = tcGetEnv    `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 312     case lookupUFM te name of {
 313         Just thing -> returnNF_Tc thing ;
 314         Nothing    ->
 315
 316     case maybeWiredInTyConName name of
 317         Just tc | isSynTyCon tc -> returnNF_Tc (kindToTcKind (tyConKind tc), ASynTyCon tc (tyConArity tc))
 318                 | otherwise     -> returnNF_Tc (kindToTcKind (tyConKind tc), ADataTyCon tc)
 319
 320         Nothing ->      -- This can happen if an interface-file
 321                         -- unfolding is screwed up
 322                    failWithTc (tyNameOutOfScope name)
 323     }
 324
 325 tcLookupClassByKey :: Unique -> NF_TcM s Class
 326 tcLookupClassByKey key
 327   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 328     case lookupUFM_Directly te key of
 329         Just (_, AClass cl _) -> returnNF_Tc cl
 330         other                 -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
 331
 332 tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class)
 333 tcLookupClassByKey_maybe key
 334   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 335     case lookupUFM_Directly te key of
 336         Just (_, AClass cl _) -> returnNF_Tc (Just cl)
 337         other                 -> returnNF_Tc Nothing
 338
 339 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
 340 tcLookupTyConByKey key
 341   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 342     case lookupUFM_Directly te key of
 343         Just (_, ADataTyCon tc)  -> returnNF_Tc tc
 344         Just (_, ASynTyCon tc _) -> returnNF_Tc tc
 345         other                    -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
 346 \end{code}
 347
 348
 349
 350
 351 %************************************************************************
 352 %*                                                                      *
 353 \subsection{The value environment}
 354 %*                                                                      *
 355 %************************************************************************
 356
 357 \begin{code}
 358 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
 359 tcExtendGlobalValEnv ids scope
 360   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 361     let
 362         ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
 363     in
 364     tcSetEnv (TcEnv ue te ve' gtvs) scope
 365
 366 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
 367 tcExtendLocalValEnv names_w_ids scope
 368   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs,gtvs)) ->
 369     tcReadMutVar gtvs   `thenNF_Tc` \ global_tvs ->
 370     let
 371         ve'                 = addListToUFM ve names_w_ids
 372         extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
 373     in
 374     tc_extend_gtvs gtvs extra_global_tyvars     `thenNF_Tc` \ gtvs' ->
 375     tcSetEnv (TcEnv ue te ve' (in_scope_tvs,gtvs')) scope
 376 \end{code}
 377
 378
 379 \begin{code}
 380 tcLookupValue :: Name -> NF_TcM s Id    -- Panics if not found
 381 tcLookupValue name
 382   = case maybeWiredInIdName name of
 383         Just id -> returnNF_Tc id
 384         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 385                    returnNF_Tc (lookupWithDefaultUFM ve def name)
 386   where
 387     def = pprPanic "tcLookupValue:" (ppr name)
 388
 389 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
 390 tcLookupValueMaybe name
 391   = case maybeWiredInIdName name of
 392         Just id -> returnNF_Tc (Just id)
 393         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 394                    returnNF_Tc (lookupUFM ve name)
 395
 396 tcLookupValueByKey :: Unique -> NF_TcM s Id     -- Panics if not found
 397 tcLookupValueByKey key
 398   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 399     returnNF_Tc (explicitLookupValueByKey ve key)
 400
 401 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
 402 tcLookupValueByKeyMaybe key
 403   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 404     returnNF_Tc (lookupUFM_Directly ve key)
 405
 406 tcGetValueEnv :: NF_TcM s ValueEnv
 407 tcGetValueEnv
 408   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 409     returnNF_Tc ve
 410
 411 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
 412 tcSetValueEnv ve scope
 413   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te _ gtvs) ->
 414     tcSetEnv (TcEnv ue te ve gtvs) scope
 415
 416 -- Non-monadic version, environment given explicitly
 417 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
 418 explicitLookupValueByKey ve key
 419   = lookupWithDefaultUFM_Directly ve def key
 420   where
 421     def = pprPanic "lookupValueByKey:" (pprUnique10 key)
 422
 423 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
 424 explicitLookupValue ve name
 425   = case maybeWiredInIdName name of
 426         Just id -> Just id
 427         Nothing -> lookupUFM ve name
 428
 429         -- Extract the IdInfo from an IfaceSig imported from an interface file
 430 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
 431 tcAddImportedIdInfo unf_env id
 432   | isLocallyDefined id         -- Don't look up locally defined Ids, because they
 433                                 -- have explicit local definitions, so we get a black hole!
 434   = id
 435   | otherwise
 436   = id `lazySetIdInfo` new_info
 437         -- The Id must be returned without a data dependency on maybe_id
 438   where
 439     new_info = -- pprTrace "tcAdd" (ppr id) $
 440                case explicitLookupValue unf_env (getName id) of
 441                      Nothing          -> vanillaIdInfo
 442                      Just imported_id -> idInfo imported_id
 443                 -- ToDo: could check that types are the same
 444 \end{code}
 445
 446
 447 %************************************************************************
 448 %*                                                                      *
 449 \subsection{Constructing new Ids}
 450 %*                                                                      *
 451 %************************************************************************
 452
 453 \begin{code}
 454 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId
 455 newLocalId name ty loc
 456   = tcGetUnique         `thenNF_Tc` \ uniq ->
 457     returnNF_Tc (mkUserLocal name uniq ty loc)
 458
 459 newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
 460 newSpecPragmaId name ty
 461   = tcGetUnique         `thenNF_Tc` \ uniq ->
 462     returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
 463 \end{code}
 464
 465
 466 %************************************************************************
 467 %*                                                                      *
 468 \subsection{Errors}
 469 %*                                                                      *
 470 %************************************************************************
 471
 472 \begin{code}
 473 badCon con_id
 474   = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
 475 badPrimOp op
 476   = quotes (ppr op) <+> ptext SLIT("is not a primop")
 477
 478 uvNameOutOfScope name
 479   = ptext SLIT("UVar") <+> quotes (ppr name) <+> ptext SLIT("is not in scope")
 480
 481 tyNameOutOfScope name
 482   = quotes (ppr name) <+> ptext SLIT("is not in scope")
 483 \end{code}