ghc/compiler/typecheck/TcEnv.lhs

   1 \begin{code}
   2 #include "HsVersions.h"
   3
   4 module TcEnv(
   5         TcEnv,
   6
   7         initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
   8
   9         tcExtendTyVarEnv, tcLookupTyVar,
  10
  11         tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey,
  12         tcExtendClassEnv, tcLookupClass, tcLookupClassByKey,
  13         tcGetTyConsAndClasses,
  14
  15         tcExtendGlobalValEnv, tcExtendLocalValEnv,
  16         tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
  17         tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
  18         tcAddImportedIdInfo,
  19         tcLookupGlobalValueByKeyMaybe,
  20
  21         newMonoIds, newLocalIds, newLocalId,
  22         tcGetGlobalTyVars, tcExtendGlobalTyVars
  23   ) where
  24
  25
  26 IMP_Ubiq()
  27 IMPORT_DELOOPER(TcMLoop)  -- for paranoia checking
  28
  29 import HsTypes  ( HsTyVar(..) )
  30 import Id       ( SYN_IE(Id), GenId, idType, mkUserLocal, mkUserId, replaceIdInfo, getIdInfo )
  31 import PragmaInfo ( PragmaInfo(..) )
  32 import TcHsSyn  ( SYN_IE(TcIdBndr), TcIdOcc(..) )
  33 import TcKind   ( TcKind, newKindVars, newKindVar, tcDefaultKind, kindToTcKind )
  34 import TcType   ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
  35                   newTyVarTys, tcInstTyVars, zonkTcTyVars
  36                 )
  37 import TyVar    ( unionTyVarSets, emptyTyVarSet )
  38 import Type     ( tyVarsOfTypes, splitForAllTy )
  39 import TyCon    ( TyCon, tyConKind, synTyConArity )
  40 import Class    ( SYN_IE(Class), GenClass, classSig )
  41
  42 import TcMonad
  43
  44 import IdInfo           ( noIdInfo )
  45 import Name             ( Name, OccName(..), getSrcLoc, occNameString,
  46                           maybeWiredInTyConName, maybeWiredInIdName, pprSym
  47                         )
  48 import PprStyle
  49 import Pretty
  50 import Unique           ( pprUnique10{-, pprUnique ToDo:rm-} )
  51 import UniqFM
  52 import Util             ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
  53                           panic, pprPanic{-, pprTrace ToDo:rm-}
  54                         )
  55 \end{code}
  56
  57 Data type declarations
  58 ~~~~~~~~~~~~~~~~~~~~~
  59
  60 \begin{code}
  61 data TcEnv s = TcEnv
  62                   (TyVarEnv s)
  63                   (TyConEnv s)
  64                   (ClassEnv s)
  65                   (ValueEnv Id)                 -- Globals
  66                   (ValueEnv (TcIdBndr s))       -- Locals
  67                   (MutableVar s (TcTyVarSet s)) -- Free type variables of locals
  68                                                 -- ...why mutable? see notes with tcGetGlobalTyVars
  69
  70 type TyVarEnv s  = UniqFM (TcKind s, TyVar)
  71 type TyConEnv s  = UniqFM (TcKind s, Maybe Arity, TyCon)        -- Arity present for Synonyms only
  72 type ClassEnv s  = UniqFM (TcKind s, Class)
  73 type ValueEnv id = UniqFM id
  74
  75 initEnv :: MutableVar s (TcTyVarSet s) -> TcEnv s
  76 initEnv mut = TcEnv emptyUFM emptyUFM emptyUFM emptyUFM emptyUFM mut
  77
  78 getEnv_LocalIds (TcEnv _ _ _ _ ls _) = eltsUFM ls
  79 getEnv_TyCons   (TcEnv _ ts _ _ _ _) = [tycon | (_, _, tycon) <- eltsUFM ts]
  80 getEnv_Classes  (TcEnv _ _ cs _ _ _) = [clas  | (_, clas)     <- eltsUFM cs]
  81 \end{code}
  82
  83 Type variable env
  84 ~~~~~~~~~~~~~~~~~
  85 \begin{code}
  86 tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r
  87 tcExtendTyVarEnv names kinds_w_types scope
  88   = tcGetEnv                                    `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
  89     let
  90         tve' = addListToUFM tve (zipEqual "tcTyVarScope" names kinds_w_types)
  91     in
  92     tcSetEnv (TcEnv tve' tce ce gve lve gtvs) scope
  93 \end{code}
  94
  95 The Kind, TyVar, Class and TyCon envs
  96 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  97
  98 Extending the environments.  Notice the uses of @zipLazy@, which makes sure
  99 that the knot-tied TyVars, TyCons and Classes aren't looked at too early.
 100
 101 \begin{code}
 102 tcExtendTyConEnv :: [(Name,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r
 103
 104 tcExtendTyConEnv names_w_arities tycons scope
 105   = newKindVars (length names_w_arities)        `thenNF_Tc` \ kinds ->
 106     tcGetEnv                                    `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 107     let
 108         tce' = addListToUFM tce [ (name, (kind, arity, tycon))
 109                                 | ((name,arity), (kind,tycon))
 110                                   <- zipEqual "tcExtendTyConEnv" names_w_arities (kinds `zipLazy` tycons)
 111                                 ]
 112     in
 113     tcSetEnv (TcEnv tve tce' ce gve lve gtvs) scope     `thenTc` \ result ->
 114     mapNF_Tc tcDefaultKind kinds                        `thenNF_Tc_`
 115     returnTc result
 116
 117
 118 tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r
 119 tcExtendClassEnv names classes scope
 120   = newKindVars (length names)  `thenNF_Tc` \ kinds ->
 121     tcGetEnv                    `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 122     let
 123         ce' = addListToUFM ce (zipEqual "tcExtendClassEnv" names (kinds `zipLazy` classes))
 124     in
 125     tcSetEnv (TcEnv tve tce ce' gve lve gtvs) scope     `thenTc` \ result ->
 126     mapNF_Tc tcDefaultKind kinds                        `thenNF_Tc_`
 127     returnTc result
 128 \end{code}
 129
 130
 131 Looking up in the environments.
 132
 133 \begin{code}
 134 tcLookupTyVar name
 135   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 136     returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr PprShowAll name)) name)
 137
 138
 139 tcLookupTyCon name
 140   = case maybeWiredInTyConName name of
 141         Just tc -> returnTc (kindToTcKind (tyConKind tc), synTyConArity tc, tc)
 142         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 143                    case lookupUFM tce name of
 144                         Just stuff -> returnTc stuff
 145                         Nothing    ->   -- Could be that he's using a class name as a type constructor
 146                                       case lookupUFM ce name of
 147                                         Just _  -> failTc (classAsTyConErr name)
 148                                         Nothing -> pprPanic "tcLookupTyCon:" (ppr PprDebug name)
 149
 150 tcLookupTyConByKey uniq
 151   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 152     let
 153        (kind, arity, tycon) =  lookupWithDefaultUFM_Directly tce
 154                                         (pprPanic "tcLookupTyCon:" (pprUnique10 uniq))
 155                                         uniq
 156     in
 157     returnNF_Tc tycon
 158
 159 tcLookupClass name
 160   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 161 --  pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique10 (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique10 . fst) (ufmToList ce))]) $
 162 --  pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique . fst) (ufmToList ce))]) $
 163     case lookupUFM ce name of
 164         Just stuff -> returnTc stuff
 165         Nothing    ->   -- Could be that he's using a type constructor as a class
 166                         case lookupUFM tce name of
 167                           Just _ ->  failTc (tyConAsClassErr name)
 168                           Nothing -> pprPanic "tcLookupClass:" (ppr PprShowAll name)
 169
 170 tcLookupClassByKey uniq
 171   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 172     let
 173         (kind, clas) = lookupWithDefaultUFM_Directly ce
 174                                 (pprPanic "tcLookupClassByKey:" (pprUnique10 uniq))
 175                                 uniq
 176     in
 177     returnNF_Tc clas
 178
 179 tcGetTyConsAndClasses :: NF_TcM s ([TyCon], [Class])
 180 tcGetTyConsAndClasses
 181   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 182     returnNF_Tc ([tc | (_, _, tc) <- eltsUFM tce],
 183                  [c  | (_, c)     <- eltsUFM ce])
 184 \end{code}
 185
 186
 187
 188 Extending and consulting the value environment
 189 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 190 \begin{code}
 191 tcExtendGlobalValEnv ids scope
 192   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 193     let
 194         gve' = addListToUFM_Directly gve [(uniqueOf id, id) | id <- ids]
 195     in
 196     tcSetEnv (TcEnv tve tce ce gve' lve gtvs) scope
 197
 198 tcExtendLocalValEnv names ids scope
 199   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 200     tcReadMutVar gtvs   `thenNF_Tc` \ global_tvs ->
 201     let
 202         lve' = addListToUFM lve (zipEqual "tcExtendLocalValEnv" names ids)
 203         extra_global_tyvars = tyVarsOfTypes (map idType ids)
 204         new_global_tyvars   = global_tvs `unionTyVarSets` extra_global_tyvars
 205     in
 206     tcNewMutVar new_global_tyvars       `thenNF_Tc` \ gtvs' ->
 207
 208     tcSetEnv (TcEnv tve tce ce gve lve' gtvs') scope
 209 \end{code}
 210
 211 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
 212 To improve subsequent calls to the same function it writes the zonked set back into
 213 the environment.
 214
 215 \begin{code}
 216 tcGetGlobalTyVars :: NF_TcM s (TcTyVarSet s)
 217 tcGetGlobalTyVars
 218   = tcGetEnv                            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 219     tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 220     zonkTcTyVars global_tvs             `thenNF_Tc` \ global_tvs' ->
 221     tcWriteMutVar gtvs global_tvs'      `thenNF_Tc_`
 222     returnNF_Tc global_tvs'
 223
 224 tcExtendGlobalTyVars extra_global_tvs scope
 225   = tcGetEnv                            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 226     tcReadMutVar gtvs                   `thenNF_Tc` \ global_tvs ->
 227     let
 228         new_global_tyvars = global_tvs `unionTyVarSets` extra_global_tvs
 229     in
 230     tcNewMutVar new_global_tyvars       `thenNF_Tc` \ gtvs' ->
 231     tcSetEnv (TcEnv tve tce ce gve lve gtvs') scope
 232 \end{code}
 233
 234 \begin{code}
 235 tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
 236 tcLookupLocalValue name
 237   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 238     returnNF_Tc (lookupUFM lve name)
 239
 240 tcLookupLocalValueByKey :: Unique -> NF_TcM s (Maybe (TcIdBndr s))
 241 tcLookupLocalValueByKey uniq
 242   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 243     returnNF_Tc (lookupUFM_Directly lve uniq)
 244
 245 tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
 246 tcLookupLocalValueOK err name
 247   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 248     returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
 249
 250
 251 tcLookupGlobalValue :: Name -> NF_TcM s Id
 252
 253 tcLookupGlobalValue name
 254   = case maybeWiredInIdName name of
 255         Just id -> returnNF_Tc id
 256         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 257                    returnNF_Tc (lookupWithDefaultUFM gve def name)
 258   where
 259     def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name)
 260
 261 tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id)
 262
 263 tcLookupGlobalValueMaybe name
 264   = case maybeWiredInIdName name of
 265         Just id -> returnNF_Tc (Just id)
 266         Nothing -> tcGetEnv             `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 267                    returnNF_Tc (lookupUFM gve name)
 268
 269
 270 tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
 271 tcLookupGlobalValueByKey uniq
 272   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 273     returnNF_Tc (lookupWithDefaultUFM_Directly gve def uniq)
 274   where
 275 #ifdef DEBUG
 276     def = pprPanic "tcLookupGlobalValueByKey:" (pprUnique10 uniq)
 277 #else
 278     def = panic "tcLookupGlobalValueByKey"
 279 #endif
 280
 281 tcLookupGlobalValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
 282 tcLookupGlobalValueByKeyMaybe uniq
 283   = tcGetEnv            `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
 284     returnNF_Tc (lookupUFM_Directly gve uniq)
 285
 286         -- Extract the IdInfo from an IfaceSig imported from an interface file
 287 tcAddImportedIdInfo :: Id -> NF_TcM s Id
 288 tcAddImportedIdInfo id
 289   = tcLookupGlobalValueMaybe (getName id)       `thenNF_Tc` \ maybe_id ->
 290     let
 291         new_info = case maybe_id of
 292                      Nothing          -> noIdInfo
 293                      Just imported_id -> getIdInfo imported_id
 294                 -- ToDo: could check that types are the same
 295     in
 296     returnNF_Tc (id `replaceIdInfo` new_info)
 297         -- The Id must be returned without a data dependency on maybe_id
 298 \end{code}
 299
 300
 301 Constructing new Ids
 302 ~~~~~~~~~~~~~~~~~~~~
 303
 304 \begin{code}
 305 -- Uses the Name as the Name of the Id
 306 newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
 307
 308 newMonoIds names kind m
 309   = newTyVarTys no_of_names kind        `thenNF_Tc` \ tys ->
 310     let
 311         new_ids       = zipWithEqual "newMonoIds" mk_id names tys
 312         mk_id name ty = mkUserId name ty NoPragmaInfo
 313     in
 314     tcExtendLocalValEnv names new_ids (m new_ids)
 315   where
 316     no_of_names = length names
 317
 318 newLocalId :: OccName -> TcType s -> NF_TcM s (TcIdBndr s)
 319 newLocalId name ty
 320   = tcGetSrcLoc         `thenNF_Tc` \ loc ->
 321     tcGetUnique         `thenNF_Tc` \ uniq ->
 322     returnNF_Tc (mkUserLocal name uniq ty loc)
 323
 324 newLocalIds :: [OccName] -> [TcType s] -> NF_TcM s [TcIdBndr s]
 325 newLocalIds names tys
 326   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 327     tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
 328     let
 329         new_ids            = zipWith3Equal "newLocalIds" mk_id names uniqs tys
 330         mk_id name uniq ty = mkUserLocal name uniq ty loc
 331     in
 332     returnNF_Tc new_ids
 333 \end{code}
 334
 335 \begin{code}
 336 classAsTyConErr name sty
 337   = ppBesides [ppPStr SLIT("Class used as a type constructor: "), pprSym sty name]
 338
 339 tyConAsClassErr name sty
 340   = ppBesides [ppPStr SLIT("Type constructor used as a class: "), pprSym sty name]
 341 \end{code}