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