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 ->      -- This can happen if an interface-file
 269                         -- unfolding is screwed up
 270                    failWithTc (tyNameOutOfScope name)
 271     }
 272
 273 tcLookupClass :: Name -> NF_TcM s Class
 274 tcLookupClass name
 275   = tcLookupTy name     `thenNF_Tc` \ (_, _, AClass clas) ->
 276     returnNF_Tc clas
 277
 278 tcLookupTyCon :: Name -> NF_TcM s TyCon
 279 tcLookupTyCon name
 280   = tcLookupTy name     `thenNF_Tc` \ (_, _, ATyCon tycon) ->
 281     returnNF_Tc tycon
 282
 283 tcLookupClassByKey :: Unique -> NF_TcM s Class
 284 tcLookupClassByKey key
 285   = tcGetEnv            `thenNF_Tc` \ (TcEnv te ve gtvs) ->
 286     case lookupUFM_Directly te key of
 287         Just (_, _, AClass cl) -> returnNF_Tc cl
 288         other                  -> pprPanic "tcLookupClassByKey:" (pprUnique10 key)
 289
 290 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
 291 tcLookupTyConByKey key
 292   = tcGetEnv            `thenNF_Tc` \ (TcEnv te ve gtvs) ->
 293     case lookupUFM_Directly te key of
 294         Just (_, _, ATyCon tc) -> returnNF_Tc tc
 295         other                  -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
 296 \end{code}
 297
 298
 299
 300
 301 %************************************************************************
 302 %*                                                                      *
 303 \subsection{The value environment}
 304 %*                                                                      *
 305 %************************************************************************
 306
 307 \begin{code}
 308 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
 309 tcExtendGlobalValEnv ids scope
 310   = tcGetEnv            `thenNF_Tc` \ (TcEnv te ve gtvs) ->
 311     let
 312         ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
 313     in
 314     tcSetEnv (TcEnv te ve' gtvs) scope
 315
 316 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
 317 tcExtendLocalValEnv names_w_ids scope
 318   = tcGetEnv            `thenNF_Tc` \ (TcEnv te ve (in_scope_tvs,gtvs)) ->
 319     tcReadMutVar gtvs   `thenNF_Tc` \ global_tvs ->
 320     let
 321         ve'                 = addListToUFM ve names_w_ids
 322         extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
 323     in
 324     tc_extend_gtvs gtvs extra_global_tyvars     `thenNF_Tc` \ gtvs' ->
 325     tcSetEnv (TcEnv te ve' (in_scope_tvs,gtvs')) scope
 326 \end{code}
 327
 328
 329 \begin{code}
 330 tcLookupValue :: Name -> NF_TcM s Id    -- Panics if not found
 331 tcLookupValue name
 332   = case maybeWiredInIdName name of
 333         Just id -> returnNF_Tc id
 334         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv te ve gtvs) ->
 335                    returnNF_Tc (lookupWithDefaultUFM ve def name)
 336   where
 337     def = pprPanic "tcLookupValue:" (ppr name)
 338
 339 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
 340 tcLookupValueMaybe name
 341   = case maybeWiredInIdName name of
 342         Just id -> returnNF_Tc (Just id)
 343         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv te ve gtvs) ->
 344                    returnNF_Tc (lookupUFM ve name)
 345
 346 tcLookupValueByKey :: Unique -> NF_TcM s Id     -- Panics if not found
 347 tcLookupValueByKey key
 348   = tcGetEnv            `thenNF_Tc` \ (TcEnv te ve gtvs) ->
 349     returnNF_Tc (explicitLookupValueByKey ve key)
 350
 351 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
 352 tcLookupValueByKeyMaybe key
 353   = tcGetEnv            `thenNF_Tc` \ (TcEnv te ve gtvs) ->
 354     returnNF_Tc (lookupUFM_Directly ve key)
 355
 356 tcGetValueEnv :: NF_TcM s ValueEnv
 357 tcGetValueEnv
 358   = tcGetEnv            `thenNF_Tc` \ (TcEnv te ve gtvs) ->
 359     returnNF_Tc ve
 360
 361 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
 362 tcSetValueEnv ve scope
 363   = tcGetEnv            `thenNF_Tc` \ (TcEnv te _ gtvs) ->
 364     tcSetEnv (TcEnv te ve gtvs) scope
 365
 366 -- Non-monadic version, environment given explicitly
 367 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
 368 explicitLookupValueByKey ve key
 369   = lookupWithDefaultUFM_Directly ve def key
 370   where
 371     def = pprPanic "lookupValueByKey:" (pprUnique10 key)
 372
 373 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
 374 explicitLookupValue ve name
 375   = case maybeWiredInIdName name of
 376         Just id -> Just id
 377         Nothing -> lookupUFM ve name
 378
 379         -- Extract the IdInfo from an IfaceSig imported from an interface file
 380 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
 381 tcAddImportedIdInfo unf_env id
 382   | isLocallyDefined id         -- Don't look up locally defined Ids, because they
 383                                 -- have explicit local definitions, so we get a black hole!
 384   = id
 385   | otherwise
 386   = id `setIdInfo` new_info
 387         -- The Id must be returned without a data dependency on maybe_id
 388   where
 389     new_info = -- pprTrace "tcAdd" (ppr id) $
 390                case explicitLookupValue unf_env (getName id) of
 391                      Nothing          -> noIdInfo
 392                      Just imported_id -> idInfo imported_id
 393                 -- ToDo: could check that types are the same
 394 \end{code}
 395
 396
 397 %************************************************************************
 398 %*                                                                      *
 399 \subsection{Constructing new Ids}
 400 %*                                                                      *
 401 %************************************************************************
 402
 403 \begin{code}
 404 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId
 405 newLocalId name ty loc
 406   = tcGetUnique         `thenNF_Tc` \ uniq ->
 407     returnNF_Tc (mkUserLocal name uniq ty loc)
 408
 409 newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
 410 newSpecPragmaId name ty
 411   = tcGetUnique         `thenNF_Tc` \ uniq ->
 412     returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
 413 \end{code}
 414
 415
 416 %************************************************************************
 417 %*                                                                      *
 418 \subsection{Errors}
 419 %*                                                                      *
 420 %************************************************************************
 421
 422 \begin{code}
 423 badCon con_id
 424   = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
 425 badPrimOp op
 426   = quotes (ppr op) <+> ptext SLIT("is not a primop")
 427
 428 tyNameOutOfScope name
 429   = quotes (ppr name) <+> ptext SLIT("is not in scope")
 430 \end{code}