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,
  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, isDataConId_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 isDataConId_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 tcLookupTyConByKey :: Unique -> NF_TcM s TyCon
 336 tcLookupTyConByKey key
 337   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 338     case lookupUFM_Directly te key of
 339         Just (_, _, ATyCon tc) -> returnNF_Tc tc
 340         other                  -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key)
 341 \end{code}
 342
 343
 344
 345
 346 %************************************************************************
 347 %*                                                                      *
 348 \subsection{The value environment}
 349 %*                                                                      *
 350 %************************************************************************
 351
 352 \begin{code}
 353 tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a
 354 tcExtendGlobalValEnv ids scope
 355   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 356     let
 357         ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids]
 358     in
 359     tcSetEnv (TcEnv ue te ve' gtvs) scope
 360
 361 tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a
 362 tcExtendLocalValEnv names_w_ids scope
 363   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve (in_scope_tvs,gtvs)) ->
 364     tcReadMutVar gtvs   `thenNF_Tc` \ global_tvs ->
 365     let
 366         ve'                 = addListToUFM ve names_w_ids
 367         extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids)
 368     in
 369     tc_extend_gtvs gtvs extra_global_tyvars     `thenNF_Tc` \ gtvs' ->
 370     tcSetEnv (TcEnv ue te ve' (in_scope_tvs,gtvs')) scope
 371 \end{code}
 372
 373
 374 \begin{code}
 375 tcLookupValue :: Name -> NF_TcM s Id    -- Panics if not found
 376 tcLookupValue name
 377   = case maybeWiredInIdName name of
 378         Just id -> returnNF_Tc id
 379         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 380                    returnNF_Tc (lookupWithDefaultUFM ve def name)
 381   where
 382     def = pprPanic "tcLookupValue:" (ppr name)
 383
 384 tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id)
 385 tcLookupValueMaybe name
 386   = case maybeWiredInIdName name of
 387         Just id -> returnNF_Tc (Just id)
 388         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 389                    returnNF_Tc (lookupUFM ve name)
 390
 391 tcLookupValueByKey :: Unique -> NF_TcM s Id     -- Panics if not found
 392 tcLookupValueByKey key
 393   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 394     returnNF_Tc (explicitLookupValueByKey ve key)
 395
 396 tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
 397 tcLookupValueByKeyMaybe key
 398   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 399     returnNF_Tc (lookupUFM_Directly ve key)
 400
 401 tcGetValueEnv :: NF_TcM s ValueEnv
 402 tcGetValueEnv
 403   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te ve gtvs) ->
 404     returnNF_Tc ve
 405
 406 tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a
 407 tcSetValueEnv ve scope
 408   = tcGetEnv            `thenNF_Tc` \ (TcEnv ue te _ gtvs) ->
 409     tcSetEnv (TcEnv ue te ve gtvs) scope
 410
 411 -- Non-monadic version, environment given explicitly
 412 explicitLookupValueByKey :: ValueEnv -> Unique -> Id
 413 explicitLookupValueByKey ve key
 414   = lookupWithDefaultUFM_Directly ve def key
 415   where
 416     def = pprPanic "lookupValueByKey:" (pprUnique10 key)
 417
 418 explicitLookupValue :: ValueEnv -> Name -> Maybe Id
 419 explicitLookupValue ve name
 420   = case maybeWiredInIdName name of
 421         Just id -> Just id
 422         Nothing -> lookupUFM ve name
 423
 424         -- Extract the IdInfo from an IfaceSig imported from an interface file
 425 tcAddImportedIdInfo :: ValueEnv -> Id -> Id
 426 tcAddImportedIdInfo unf_env id
 427   | isLocallyDefined id         -- Don't look up locally defined Ids, because they
 428                                 -- have explicit local definitions, so we get a black hole!
 429   = id
 430   | otherwise
 431   = id `lazySetIdInfo` new_info
 432         -- The Id must be returned without a data dependency on maybe_id
 433   where
 434     new_info = -- pprTrace "tcAdd" (ppr id) $
 435                case explicitLookupValue unf_env (getName id) of
 436                      Nothing          -> vanillaIdInfo
 437                      Just imported_id -> idInfo imported_id
 438                 -- ToDo: could check that types are the same
 439 \end{code}
 440
 441
 442 %************************************************************************
 443 %*                                                                      *
 444 \subsection{Constructing new Ids}
 445 %*                                                                      *
 446 %************************************************************************
 447
 448 \begin{code}
 449 newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId
 450 newLocalId name ty loc
 451   = tcGetUnique         `thenNF_Tc` \ uniq ->
 452     returnNF_Tc (mkUserLocal name uniq ty loc)
 453
 454 newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId
 455 newSpecPragmaId name ty
 456   = tcGetUnique         `thenNF_Tc` \ uniq ->
 457     returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name))
 458 \end{code}
 459
 460
 461 %************************************************************************
 462 %*                                                                      *
 463 \subsection{Errors}
 464 %*                                                                      *
 465 %************************************************************************
 466
 467 \begin{code}
 468 badCon con_id
 469   = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
 470 badPrimOp op
 471   = quotes (ppr op) <+> ptext SLIT("is not a primop")
 472
 473 uvNameOutOfScope name
 474   = ptext SLIT("UVar") <+> quotes (ppr name) <+> ptext SLIT("is not in scope")
 475
 476 tyNameOutOfScope name
 477   = quotes (ppr name) <+> ptext SLIT("is not in scope")
 478 \end{code}