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