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         getDOptsDs,
  19         dsLookupGlobalValue,
  20
  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 Type             ( Type )
  37 import UniqSupply       ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
  38                           UniqSM, UniqSupply )
  39 import Unique           ( Unique )
  40 import Util             ( zipWithEqual )
  41 import Name             ( Name )
  42 import CmdLineOpts      ( DynFlags )
  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         DynFlags
  53         -> UniqSupply
  54         -> (Name -> Id)         -- Lookup well-known Ids
  55         -> SrcLoc               -- to put in pattern-matching error msgs
  56         -> Module               -- module: for SCC profiling
  57         -> DsWarnings
  58         -> (result, DsWarnings)
  59
  60 type DsWarnings = Bag WarnMsg           -- The desugarer reports matches which are
  61                                         -- completely shadowed or incomplete patterns
  62
  63 {-# INLINE andDs #-}
  64 {-# INLINE thenDs #-}
  65 {-# INLINE returnDs #-}
  66
  67 -- initDs returns the UniqSupply out the end (not just the result)
  68
  69 initDs  :: DynFlags
  70         -> UniqSupply
  71         -> (Name -> Id)
  72         -> Module   -- module name: for profiling
  73         -> DsM a
  74         -> (a, DsWarnings)
  75
  76 initDs dflags init_us lookup mod action
  77   = action dflags init_us lookup noSrcLoc mod emptyBag
  78
  79 thenDs :: DsM a -> (a -> DsM b) -> DsM b
  80 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
  81
  82 thenDs m1 m2 dflags us genv loc mod warns
  83   = case splitUniqSupply us                 of { (s1, s2) ->
  84     case (m1 dflags s1 genv loc mod warns)  of { (result, warns1) ->
  85     m2 result dflags s2 genv loc mod warns1}}
  86
  87 andDs combiner m1 m2 dflags us genv loc mod warns
  88   = case splitUniqSupply us                 of { (s1, s2) ->
  89     case (m1 dflags s1 genv loc mod warns)  of { (result1, warns1) ->
  90     case (m2 dflags s2 genv loc mod warns1) of { (result2, warns2) ->
  91     (combiner result1 result2, warns2) }}}
  92
  93 returnDs :: a -> DsM a
  94 returnDs result dflags us genv loc mod warns = (result, warns)
  95
  96 listDs :: [DsM a] -> DsM [a]
  97 listDs []     = returnDs []
  98 listDs (x:xs)
  99   = x           `thenDs` \ r  ->
 100     listDs xs   `thenDs` \ rs ->
 101     returnDs (r:rs)
 102
 103 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
 104
 105 mapDs f []     = returnDs []
 106 mapDs f (x:xs)
 107   = f x         `thenDs` \ r  ->
 108     mapDs f xs  `thenDs` \ rs ->
 109     returnDs (r:rs)
 110
 111 foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a
 112
 113 foldlDs k z []     = returnDs z
 114 foldlDs k z (x:xs) = k z x `thenDs` \ r ->
 115                      foldlDs k r xs
 116
 117 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 118
 119 mapAndUnzipDs f []     = returnDs ([], [])
 120 mapAndUnzipDs f (x:xs)
 121   = f x                 `thenDs` \ (r1, r2)  ->
 122     mapAndUnzipDs f xs  `thenDs` \ (rs1, rs2) ->
 123     returnDs (r1:rs1, r2:rs2)
 124
 125 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 126
 127 zipWithDs f []     ys = returnDs []
 128 zipWithDs f (x:xs) (y:ys)
 129   = f x y               `thenDs` \ r  ->
 130     zipWithDs f xs ys   `thenDs` \ rs ->
 131     returnDs (r:rs)
 132 \end{code}
 133
 134 And all this mysterious stuff is so we can occasionally reach out and
 135 grab one or more names.  @newLocalDs@ isn't exported---exported
 136 functions are defined with it.  The difference in name-strings makes
 137 it easier to read debugging output.
 138
 139 \begin{code}
 140 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 141 newSysLocalDs ty dflags us genv loc mod warns
 142   = case uniqFromSupply us of { assigned_uniq ->
 143     (mkSysLocal SLIT("ds") assigned_uniq ty, warns) }
 144
 145 newSysLocalsDs tys = mapDs newSysLocalDs tys
 146
 147 newFailLocalDs ty dflags us genv loc mod warns
 148   = case uniqFromSupply us of { assigned_uniq ->
 149     (mkSysLocal SLIT("fail") assigned_uniq ty, warns) }
 150         -- The UserLocal bit just helps make the code a little clearer
 151
 152 getUniqueDs :: DsM Unique
 153 getUniqueDs dflags us genv loc mod warns
 154   = case (uniqFromSupply us) of { assigned_uniq ->
 155     (assigned_uniq, warns) }
 156
 157 getDOptsDs :: DsM DynFlags
 158 getDOptsDs dflags us genv loc mod warns
 159   = (dflags, warns)
 160
 161 duplicateLocalDs :: Id -> DsM Id
 162 duplicateLocalDs old_local dflags us genv loc mod warns
 163   = case uniqFromSupply us of { assigned_uniq ->
 164     (setIdUnique old_local assigned_uniq, warns) }
 165
 166 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 167 cloneTyVarsDs tyvars dflags us genv loc mod warns
 168   = case uniqsFromSupply (length tyvars) us of { uniqs ->
 169     (zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) }
 170 \end{code}
 171
 172 \begin{code}
 173 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 174
 175 newTyVarsDs tyvar_tmpls dflags us genv loc mod warns
 176   = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
 177     (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
 178 \end{code}
 179
 180 We can also reach out and either set/grab location information from
 181 the @SrcLoc@ being carried around.
 182 \begin{code}
 183 uniqSMtoDsM :: UniqSM a -> DsM a
 184
 185 uniqSMtoDsM u_action dflags us genv loc mod warns
 186   = (initUs_ us u_action, warns)
 187
 188 getSrcLocDs :: DsM SrcLoc
 189 getSrcLocDs dflags us genv loc mod warns
 190   = (loc, warns)
 191
 192 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 193 putSrcLocDs new_loc expr dflags us genv old_loc mod warns
 194   = expr dflags us genv new_loc mod warns
 195
 196 dsWarn :: WarnMsg -> DsM ()
 197 dsWarn warn dflags us genv loc mod warns = ((), warns `snocBag` warn)
 198
 199 \end{code}
 200
 201 \begin{code}
 202 getModuleDs :: DsM Module
 203 getModuleDs dflags us genv loc mod warns = (mod, warns)
 204 \end{code}
 205
 206 \begin{code}
 207 dsLookupGlobalValue :: Name -> DsM Id
 208 dsLookupGlobalValue name dflags us genv loc mod warns
 209   = (genv name, warns)
 210 \end{code}
 211
 212
 213 %************************************************************************
 214 %*                                                                      *
 215 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
 216 %*                                                                      *
 217 %************************************************************************
 218
 219 \begin{code}
 220 data DsMatchContext
 221   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
 222   | NoMatchContext
 223   deriving ()
 224
 225 data DsMatchKind
 226   = FunMatch Id
 227   | CaseMatch
 228   | LambdaMatch
 229   | PatBindMatch
 230   | DoBindMatch
 231   | ListCompMatch
 232   | LetMatch
 233   | RecUpdMatch
 234   deriving ()
 235 \end{code}