ghc/compiler/deSugar/DsMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
   5
   6 \begin{code}
   7 module DsMonad (
   8         DsM,
   9         initDs, returnDs, thenDs, andDs, mapDs, listDs,
  10         mapAndUnzipDs, zipWithDs, foldlDs,
  11         uniqSMtoDsM,
  12         newTyVarsDs, cloneTyVarsDs,
  13         duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
  14         newFailLocalDs,
  15         getSrcLocDs, putSrcLocDs,
  16         getModuleDs,
  17         getUniqueDs,
  18         dsLookupGlobalValue,
  19
  20         ValueEnv,
  21         dsWarn,
  22         DsWarnings,
  23         DsMatchContext(..), DsMatchKind(..)
  24     ) where
  25
  26 #include "HsVersions.h"
  27
  28 import Bag              ( emptyBag, snocBag, Bag )
  29 import ErrUtils         ( WarnMsg )
  30 import Id               ( mkSysLocal, setIdUnique, Id )
  31 import Module           ( Module )
  32 import Var              ( TyVar, setTyVarUnique )
  33 import Outputable
  34 import SrcLoc           ( noSrcLoc, SrcLoc )
  35 import TcHsSyn          ( TypecheckedPat )
  36 import TcEnv            ( ValueEnv )
  37 import Type             ( Type )
  38 import UniqSupply       ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
  39                           UniqSM, UniqSupply )
  40 import Unique           ( Unique )
  41 import UniqFM           ( lookupWithDefaultUFM_Directly )
  42 import Util             ( zipWithEqual )
  43
  44 infixr 9 `thenDs`
  45 \end{code}
  46
  47 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
  48 a @UniqueSupply@ and some annotations, which
  49 presumably include source-file location information:
  50 \begin{code}
  51 type DsM result =
  52         UniqSupply
  53         -> (Name -> Id)         -- Lookup well-known Ids
  54         -> SrcLoc               -- to put in pattern-matching error msgs
  55         -> Module               -- module: for SCC profiling
  56         -> DsWarnings
  57         -> (result, DsWarnings)
  58
  59 type DsWarnings = Bag WarnMsg           -- The desugarer reports matches which are
  60                                         -- completely shadowed or incomplete patterns
  61
  62 {-# INLINE andDs #-}
  63 {-# INLINE thenDs #-}
  64 {-# INLINE returnDs #-}
  65
  66 -- initDs returns the UniqSupply out the end (not just the result)
  67
  68 initDs  :: UniqSupply
  69         -> (HomeSymbolTable, PersistentCompilerState, TypeEnv)
  70         -> Module   -- module name: for profiling
  71         -> DsM a
  72         -> (a, DsWarnings)
  73
  74 initDs init_us (hst,pcs,local_type_env) mod action
  75   = action init_us lookup noSrcLoc mod emptyBag
  76   where
  77         -- This lookup is used for well-known Ids,
  78         -- such as fold, build, cons etc, so the chances are
  79         -- it'll be found in the package symbol table.  That's
  80         -- why we don't merge all these tables
  81     pst = pcsPST pcs
  82     lookup n = case lookupTypeEnv pst n of {
  83                  Just (AnId v) -> v ;
  84                  other ->
  85                case lookupTypeEnv hst n of {
  86                  Just (AnId v) -> v ;
  87                  other ->
  88                case lookupNameEnv local_type_env n of
  89                  Just (AnId v) -> v ;
  90                  other         -> pprPanic "initDS: lookup:" (ppr n)
  91
  92 thenDs :: DsM a -> (a -> DsM b) -> DsM b
  93 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
  94
  95 thenDs m1 m2 us genv loc mod warns
  96   = case splitUniqSupply us                 of { (s1, s2) ->
  97     case (m1 s1 genv loc mod warns)  of { (result, warns1) ->
  98     m2 result s2 genv loc mod warns1}}
  99
 100 andDs combiner m1 m2 us genv loc mod warns
 101   = case splitUniqSupply us                 of { (s1, s2) ->
 102     case (m1 s1 genv loc mod warns)  of { (result1, warns1) ->
 103     case (m2 s2 genv loc mod warns1) of { (result2, warns2) ->
 104     (combiner result1 result2, warns2) }}}
 105
 106 returnDs :: a -> DsM a
 107 returnDs result us genv loc mod warns = (result, warns)
 108
 109 listDs :: [DsM a] -> DsM [a]
 110 listDs []     = returnDs []
 111 listDs (x:xs)
 112   = x           `thenDs` \ r  ->
 113     listDs xs   `thenDs` \ rs ->
 114     returnDs (r:rs)
 115
 116 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
 117
 118 mapDs f []     = returnDs []
 119 mapDs f (x:xs)
 120   = f x         `thenDs` \ r  ->
 121     mapDs f xs  `thenDs` \ rs ->
 122     returnDs (r:rs)
 123
 124 foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a
 125
 126 foldlDs k z []     = returnDs z
 127 foldlDs k z (x:xs) = k z x `thenDs` \ r ->
 128                      foldlDs k r xs
 129
 130 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 131
 132 mapAndUnzipDs f []     = returnDs ([], [])
 133 mapAndUnzipDs f (x:xs)
 134   = f x                 `thenDs` \ (r1, r2)  ->
 135     mapAndUnzipDs f xs  `thenDs` \ (rs1, rs2) ->
 136     returnDs (r1:rs1, r2:rs2)
 137
 138 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 139
 140 zipWithDs f []     ys = returnDs []
 141 zipWithDs f (x:xs) (y:ys)
 142   = f x y               `thenDs` \ r  ->
 143     zipWithDs f xs ys   `thenDs` \ rs ->
 144     returnDs (r:rs)
 145 \end{code}
 146
 147 And all this mysterious stuff is so we can occasionally reach out and
 148 grab one or more names.  @newLocalDs@ isn't exported---exported
 149 functions are defined with it.  The difference in name-strings makes
 150 it easier to read debugging output.
 151
 152 \begin{code}
 153 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 154 newSysLocalDs ty us genv loc mod warns
 155   = case uniqFromSupply us of { assigned_uniq ->
 156     (mkSysLocal SLIT("ds") assigned_uniq ty, warns) }
 157
 158 newSysLocalsDs tys = mapDs newSysLocalDs tys
 159
 160 newFailLocalDs ty us genv loc mod warns
 161   = case uniqFromSupply us of { assigned_uniq ->
 162     (mkSysLocal SLIT("fail") assigned_uniq ty, warns) }
 163         -- The UserLocal bit just helps make the code a little clearer
 164
 165 getUniqueDs :: DsM Unique
 166 getUniqueDs us genv loc mod warns
 167   = case (uniqFromSupply us) of { assigned_uniq ->
 168     (assigned_uniq, warns) }
 169
 170 duplicateLocalDs :: Id -> DsM Id
 171 duplicateLocalDs old_local us genv loc mod warns
 172   = case uniqFromSupply us of { assigned_uniq ->
 173     (setIdUnique old_local assigned_uniq, warns) }
 174
 175 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 176 cloneTyVarsDs tyvars us genv loc mod warns
 177   = case uniqsFromSupply (length tyvars) us of { uniqs ->
 178     (zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) }
 179 \end{code}
 180
 181 \begin{code}
 182 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 183
 184 newTyVarsDs tyvar_tmpls us genv loc mod warns
 185   = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
 186     (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
 187 \end{code}
 188
 189 We can also reach out and either set/grab location information from
 190 the @SrcLoc@ being carried around.
 191 \begin{code}
 192 uniqSMtoDsM :: UniqSM a -> DsM a
 193
 194 uniqSMtoDsM u_action us genv loc mod warns
 195   = (initUs_ us u_action, warns)
 196
 197 getSrcLocDs :: DsM SrcLoc
 198 getSrcLocDs us genv loc mod warns
 199   = (loc, warns)
 200
 201 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 202 putSrcLocDs new_loc expr us genv old_loc mod warns
 203   = expr us genv new_loc mod warns
 204
 205 dsWarn :: WarnMsg -> DsM ()
 206 dsWarn warn us genv loc mod warns = ((), warns `snocBag` warn)
 207
 208 \end{code}
 209
 210 \begin{code}
 211 getModuleDs :: DsM Module
 212 getModuleDs us genv loc mod warns = (mod, warns)
 213 \end{code}
 214
 215 \begin{code}
 216 dsLookupGlobalValue :: Name -> DsM Id
 217 dsLookupGlobalValue key us genv loc mod warns
 218   = (result, warns)
 219   where
 220     result = case lookupNameEnv genv name of
 221                 Just (AnId v) -> v
 222                 Nothing       -> pprPanic "dsLookupGlobalValue:" (ppr name)
 223 \end{code}
 224
 225
 226 %************************************************************************
 227 %*                                                                      *
 228 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
 229 %*                                                                      *
 230 %************************************************************************
 231
 232 \begin{code}
 233 data DsMatchContext
 234   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
 235   | NoMatchContext
 236   deriving ()
 237
 238 data DsMatchKind
 239   = FunMatch Id
 240   | CaseMatch
 241   | LambdaMatch
 242   | PatBindMatch
 243   | DoBindMatch
 244   | ListCompMatch
 245   | LetMatch
 246   | RecUpdMatch
 247   deriving ()
 248 \end{code}