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