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