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, getUniquesDs,
  18         getDOptsDs,
  19         dsLookupGlobalValue,
  20
  21         dsWarn,
  22         DsWarnings,
  23         DsMatchContext(..)
  24     ) where
  25
  26 #include "HsVersions.h"
  27
  28 import TcHsSyn          ( TypecheckedPat, TypecheckedMatchContext )
  29 import Bag              ( emptyBag, snocBag, Bag )
  30 import ErrUtils         ( WarnMsg )
  31 import Id               ( mkSysLocal, setIdUnique, Id )
  32 import Module           ( Module )
  33 import Var              ( TyVar, setTyVarUnique )
  34 import Outputable
  35 import SrcLoc           ( noSrcLoc, SrcLoc )
  36 import Type             ( Type )
  37 import UniqSupply       ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
  38                           UniqSM, UniqSupply )
  39 import Unique           ( Unique )
  40 import Name             ( Name )
  41 import CmdLineOpts      ( DynFlags )
  42
  43 infixr 9 `thenDs`
  44 \end{code}
  45
  46 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
  47 a @UniqueSupply@ and some annotations, which
  48 presumably include source-file location information:
  49 \begin{code}
  50 type DsM result =
  51         DynFlags
  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  :: DynFlags
  69         -> UniqSupply
  70         -> (Name -> Id)
  71         -> Module   -- module name: for profiling
  72         -> DsM a
  73         -> (a, DsWarnings)
  74
  75 initDs dflags init_us lookup mod action
  76   = action dflags init_us lookup noSrcLoc mod emptyBag
  77
  78 thenDs :: DsM a -> (a -> DsM b) -> DsM b
  79 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
  80
  81 thenDs m1 m2 dflags us genv loc mod warns
  82   = case splitUniqSupply us                 of { (s1, s2) ->
  83     case (m1 dflags s1 genv loc mod warns)  of { (result, warns1) ->
  84     m2 result dflags s2 genv loc mod warns1}}
  85
  86 andDs combiner m1 m2 dflags us genv loc mod warns
  87   = case splitUniqSupply us                 of { (s1, s2) ->
  88     case (m1 dflags s1 genv loc mod warns)  of { (result1, warns1) ->
  89     case (m2 dflags s2 genv loc mod warns1) of { (result2, warns2) ->
  90     (combiner result1 result2, warns2) }}}
  91
  92 returnDs :: a -> DsM a
  93 returnDs result dflags us genv loc mod warns = (result, warns)
  94
  95 listDs :: [DsM a] -> DsM [a]
  96 listDs []     = returnDs []
  97 listDs (x:xs)
  98   = x           `thenDs` \ r  ->
  99     listDs xs   `thenDs` \ rs ->
 100     returnDs (r:rs)
 101
 102 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
 103
 104 mapDs f []     = returnDs []
 105 mapDs f (x:xs)
 106   = f x         `thenDs` \ r  ->
 107     mapDs f xs  `thenDs` \ rs ->
 108     returnDs (r:rs)
 109
 110 foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a
 111
 112 foldlDs k z []     = returnDs z
 113 foldlDs k z (x:xs) = k z x `thenDs` \ r ->
 114                      foldlDs k r xs
 115
 116 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 117
 118 mapAndUnzipDs f []     = returnDs ([], [])
 119 mapAndUnzipDs f (x:xs)
 120   = f x                 `thenDs` \ (r1, r2)  ->
 121     mapAndUnzipDs f xs  `thenDs` \ (rs1, rs2) ->
 122     returnDs (r1:rs1, r2:rs2)
 123
 124 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 125
 126 zipWithDs f []     ys = returnDs []
 127 zipWithDs f (x:xs) (y:ys)
 128   = f x y               `thenDs` \ r  ->
 129     zipWithDs f xs ys   `thenDs` \ rs ->
 130     returnDs (r:rs)
 131 \end{code}
 132
 133 And all this mysterious stuff is so we can occasionally reach out and
 134 grab one or more names.  @newLocalDs@ isn't exported---exported
 135 functions are defined with it.  The difference in name-strings makes
 136 it easier to read debugging output.
 137
 138 \begin{code}
 139 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 140 newSysLocalDs ty dflags us genv loc mod warns
 141   = case uniqFromSupply us of { assigned_uniq ->
 142     (mkSysLocal FSLIT("ds") assigned_uniq ty, warns) }
 143
 144 newSysLocalsDs tys = mapDs newSysLocalDs tys
 145
 146 newFailLocalDs ty dflags us genv loc mod warns
 147   = case uniqFromSupply us of { assigned_uniq ->
 148     (mkSysLocal FSLIT("fail") assigned_uniq ty, warns) }
 149         -- The UserLocal bit just helps make the code a little clearer
 150
 151 getUniqueDs :: DsM Unique
 152 getUniqueDs dflags us genv loc mod warns
 153   = (uniqFromSupply us, warns)
 154
 155 getUniquesDs :: DsM [Unique]
 156 getUniquesDs dflags us genv loc mod warns
 157   = (uniqsFromSupply us, warns)
 158
 159 getDOptsDs :: DsM DynFlags
 160 getDOptsDs dflags us genv loc mod warns
 161   = (dflags, warns)
 162
 163 duplicateLocalDs :: Id -> DsM Id
 164 duplicateLocalDs old_local dflags us genv loc mod warns
 165   = case uniqFromSupply us of { assigned_uniq ->
 166     (setIdUnique old_local assigned_uniq, warns) }
 167
 168 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 169 cloneTyVarsDs tyvars dflags us genv loc mod warns
 170   = (zipWith setTyVarUnique tyvars (uniqsFromSupply us), warns)
 171 \end{code}
 172
 173 \begin{code}
 174 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 175 newTyVarsDs tyvar_tmpls dflags us genv loc mod warns
 176   = (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply us), warns)
 177 \end{code}
 178
 179 We can also reach out and either set/grab location information from
 180 the @SrcLoc@ being carried around.
 181 \begin{code}
 182 uniqSMtoDsM :: UniqSM a -> DsM a
 183
 184 uniqSMtoDsM u_action dflags us genv loc mod warns
 185   = (initUs_ us u_action, warns)
 186
 187 getSrcLocDs :: DsM SrcLoc
 188 getSrcLocDs dflags us genv loc mod warns
 189   = (loc, warns)
 190
 191 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 192 putSrcLocDs new_loc expr dflags us genv old_loc mod warns
 193   = expr dflags us genv new_loc mod warns
 194
 195 dsWarn :: WarnMsg -> DsM ()
 196 dsWarn warn dflags us genv loc mod warns = ((), warns `snocBag` warn)
 197
 198 \end{code}
 199
 200 \begin{code}
 201 getModuleDs :: DsM Module
 202 getModuleDs dflags us genv loc mod warns = (mod, warns)
 203 \end{code}
 204
 205 \begin{code}
 206 dsLookupGlobalValue :: Name -> DsM Id
 207 dsLookupGlobalValue name dflags us genv loc mod warns
 208   = (genv name, warns)
 209 \end{code}
 210
 211
 212 %************************************************************************
 213 %*                                                                      *
 214 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
 215 %*                                                                      *
 216 %************************************************************************
 217
 218 \begin{code}
 219 data DsMatchContext
 220   = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
 221   | NoMatchContext
 222   deriving ()
 223 \end{code}