ghc/compiler/envs/E.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[E]{Main typechecker environment}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module E (
  10         E,
  11         mkE, nullE,
  12         getE_GlobalVals, getE_TCE, getE_CE,
  13         plusE_TCE, plusE_CE,
  14
  15         growE_LVE, plusE_GVE, tvOfE,
  16
  17         lookupE_Value, lookupE_ValueQuietly,
  18         lookupE_ClassOpByKey, lookupE_Binder,
  19
  20         GVE(..), LVE(..),
  21         plusLVE, nullLVE,
  22         plusGVE, nullGVE, unitGVE, -- UNUSED: rngGVE,
  23
  24         -- and to make the interface self-sufficient...
  25         CE(..), Id, Name, TCE(..), TyVar, Maybe, UniqFM
  26     ) where
  27
  28 import CE
  29 import TCE
  30 import UniqFM           -- basic env handling code
  31
  32 import AbsPrel          ( PrimOp
  33                           IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
  34                           IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
  35                         )
  36 import AbsUniType       ( getClassOps, extractTyVarsFromTy,
  37                           getClassBigSig, getClassOpString, TyVar,
  38                           TyVarTemplate, ClassOp, Class, Arity(..),
  39                           TauType(..)
  40                           IF_ATTACK_PRAGMAS(COMMA cmpTyVar COMMA cmpClass)
  41                         )
  42 import Id               ( getIdUniType, Id, IdInfo )
  43 import Maybes           ( MaybeErr(..), Maybe(..) )
  44 import Name             -- Name(..), etc.
  45 import Outputable       -- def of ppr, etc.
  46 import Pretty           -- to pretty-print error messages
  47 import UniqSet          -- this use of Sets is a HACK (WDP 94/05)
  48 import Unique           -- *Key stuff
  49 import Util
  50 \end{code}
  51
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{Type declarations}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59
  60 \begin{code}
  61 data E
  62   = MkE TCE         -- type environment
  63         GVB         -- "global" value bindings; no free type vars
  64         LVB         -- "local" value bindings; may have free type vars
  65         CE          -- class environment
  66
  67 mkE :: TCE -> CE -> E
  68 mkE tce ce = MkE tce nullGVB nullLVB ce
  69
  70 nullE :: E
  71 nullE = MkE nullTCE nullGVB nullLVB nullCE
  72 \end{code}
  73
  74 The ``local'' and ``global'' bindings, @LVB@ and @GVB@, are
  75 non-exported synonyms.  The important thing is that @GVB@ doesn't
  76 contain any free type variables.  This is used (only) in @tvOfE@,
  77 which extracts free type variables from the environment.  It's quite a
  78 help to have this separation because there may be quite a large bunch
  79 of imported things in the @GVB@, all of which are guaranteed
  80 polymorphic.
  81
  82 \begin{code}
  83 type LVB = UniqFM Id -- Locals just have a Unique
  84 type GVB = UniqFM Id -- Globals might be a prelude thing; hence IdKey
  85
  86 nullLVB = (emptyUFM :: LVB)
  87 nullGVB = (emptyUFM :: GVB)
  88 \end{code}
  89
  90 The ``local'' and ``global'' value environments are not part of @E@ at
  91 all, but is used to provide increments to the value bindings.  GVE are
  92 carries the implication that there are no free type variables.
  93
  94 \begin{code}
  95 type LVE = [(Name, Id)] -- Maps Names to Ids
  96 type GVE = [(Name, Id)] -- Maps Names to Ids
  97
  98 nullLVE     = ([] :: LVE)
  99 plusLVE a b = a ++ b
 100 nullGVE     = ([] :: GVE)
 101 unitGVE n i = ( [(n, i)] :: GVE )
 102 -- UNUSED: rngGVE  gve = map snd gve
 103 plusGVE a b = a ++ b
 104 \end{code}
 105
 106 %************************************************************************
 107 %*                                                                      *
 108 \subsection{Value environment stuff}
 109 %*                                                                      *
 110 %************************************************************************
 111
 112 Looking up things should mostly succeed, because the renamer should
 113 have spotted all out-of-scope names.  The exception is instances.
 114
 115 The ``Quietly'' version is for pragmas, where lookups very well may
 116 fail. @lookup_val@ is the internal function that does the work.
 117
 118 \begin{code}
 119 lookupE_Value        :: E -> Name -> Id
 120 lookupE_ValueQuietly :: E -> Name -> Maybe Id
 121
 122 lookupE_Value e nm
 123   = case lookup_val e nm of
 124       Succeeded id -> id
 125       Failed (should_panic, msg)
 126         -> if should_panic then panic msg else error msg
 127
 128 lookupE_ValueQuietly e nm
 129   = case lookup_val e nm of
 130       Succeeded id -> Just id
 131       Failed _     -> Nothing
 132 \end{code}
 133
 134 \begin{code}
 135 lookup_val (MkE _ gvb lvb ce) name
 136   = case name of
 137
 138       WiredInVal id   -> Succeeded id
 139       PreludeVal key _ -> case (lookupDirectlyUFM gvb key) of
 140                             Just id -> Succeeded id
 141                             Nothing -> Failed (False, prelude_err_msg)
 142
 143       ClassOpName uniq clas_name _ tag -> id_from_env uniq
 144
 145       -- You might think that top-level ids are guaranteed to have no
 146       -- free tyvars, so look only in gvb; but you'd be wrong!  When
 147       -- type-checking the RHS of recursive top-level defns, the name
 148       -- of the thing is bound to a *monomorphic* type, which is later
 149       -- generalised.  So we have to look in the LVE too.
 150
 151       OtherTopId uniq _ -> id_from_env uniq
 152
 153       -- Short names could be in either GVB or LVB
 154       Short uniq _      -> id_from_env uniq
 155
 156       funny_name -> pprPanic "lookup_val: funny Name" (ppr PprDebug funny_name)
 157   where
 158     prelude_err_msg = "ERROR: in looking up a built-in Prelude value!\n(This can happen if you use `-fno-implicit-prelude'\nor you hide the system's Prelude.hi in some way.)"
 159
 160     id_from_env uniq
 161       = case (lookupDirectlyUFM lvb uniq) of
 162           Just id -> Succeeded id
 163           Nothing ->
 164             case (lookupDirectlyUFM gvb uniq) of
 165               Just id -> Succeeded id
 166               Nothing -> Failed (True, -- should panic
 167                           ("lookupE_Value: unbound name: "++(ppShow 80 (ppr PprShowAll name))))
 168 \end{code}
 169
 170 For Prelude things that we reach out and grab, we have only an @Unique@.
 171 \begin{code}
 172 lookupE_ClassOpByKey :: E -> Unique{-ClassKey-} -> FAST_STRING -> Id
 173
 174 lookupE_ClassOpByKey (MkE _ gvb lvb ce) clas_key op_str
 175   = let
 176         clas   = lookupCE ce (PreludeClass clas_key bottom)
 177         bottom = pprPanic ("lookupE_ClassOpByKey: "++(_UNPK_ op_str))
 178                           (ppAbove (pprUnique clas_key) (ppr PprShowAll (rngCE ce)))
 179
 180         (clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
 181           = getClassBigSig clas
 182     in
 183     case [ op_sel_id | (op, op_sel_id) <- ops `zip` op_sel_ids,
 184                        op_str == getClassOpString op ] of
 185       [op] -> op
 186     -- Seems a rather horrible way to do it (ToDo)
 187 \end{code}
 188
 189 @lookupE_Binder@ is like @lookupE_Value@, but it is used for {\em
 190 binding} occurrences of a variable, rather than {\em uses}.  The
 191 difference is that there should always be an entry in the LVE for
 192 binding occurrences.  Just a sanity check now, really.
 193
 194 \begin{code}
 195 lookupE_Binder :: E -> Name -> Id
 196 lookupE_Binder (MkE _ _ lvb _) name
 197   = case (lookupDirectlyUFM lvb (name2uniq name)) of
 198       Just id -> id
 199       Nothing -> pprPanic "lookupE_Binder: unbound name: " (ppr PprShowAll name)
 200 \end{code}
 201
 202 \begin{code}
 203 getE_GlobalVals :: E -> [Id]
 204 getE_GlobalVals  (MkE tce gvb lvb ce)
 205   = let
 206         result = eltsUFM gvb ++ eltsUFM lvb
 207     in
 208     -- pprTrace "Global Ids:" (ppr PprShowAll result)
 209     result
 210
 211 plusE_GVE :: E -> GVE -> E
 212 plusE_GVE (MkE tce gvb lvb ce) gve
 213   = let
 214         new_stuff = listToUFM_Directly [(name2idkey n, i) | (n,i) <- gve ]
 215     in
 216     MkE tce (plusUFM gvb new_stuff) lvb ce
 217   where
 218     name2idkey (PreludeVal k _) = k
 219     name2idkey (OtherTopId u _) = u
 220     name2idkey (ClassOpName u _ _ _) = u
 221
 222 growE_LVE :: E -> LVE -> E
 223 growE_LVE (MkE tce gvb lvb ce) lve
 224   = let
 225         new_stuff = listToUFM_Directly [(name2uniq n, i) | (n,i) <- lve ]
 226     in
 227     MkE tce gvb (plusUFM lvb new_stuff) ce
 228
 229 -- ToDo: move this elsewhere??
 230 name2uniq (Short u _)           = u
 231 name2uniq (OtherTopId u _)      = u
 232 name2uniq (ClassOpName u _ _ _) = panic "growE_LVE:name2uniq"
 233 \end{code}
 234
 235 Return the free type variables of an LVE; there are no duplicates in
 236 the result---hence all the @Set@ bozo-ery.  The free tyvars can only
 237 occur in the LVB part.
 238
 239 \begin{code}
 240 tvOfE :: E -> [TyVar]
 241 tvOfE (MkE tce gvb lvb ce)
 242   = uniqSetToList (mkUniqSet (
 243         foldr ((++) . extractTyVarsFromTy . getIdUniType) [] (eltsUFM lvb)
 244     ))
 245 \end{code}
 246
 247 %************************************************************************
 248 %*                                                                      *
 249 %*
 250 \subsection{Type and class environments}
 251 %*                                                                      *
 252 %************************************************************************
 253
 254 \begin{code}
 255 getE_TCE :: E -> TCE
 256 getE_TCE (MkE tce gvb lvb ce) = tce
 257
 258 getE_CE :: E -> CE
 259 getE_CE  (MkE tce gvb lvb ce) = ce
 260
 261 plusE_TCE :: E -> TCE -> E
 262 plusE_TCE (MkE tce gvb lvb ce) tce'
 263   = MkE (plusTCE tce' tce) gvb lvb ce
 264
 265 plusE_CE :: E -> CE -> E
 266 plusE_CE (MkE tce gvb lvb ce) ce'
 267   = MkE tce gvb lvb (plusCE ce ce')
 268 \end{code}