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