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