ghc/compiler/deSugar/DsMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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, getUniqueDs,
  17         extendEnvDs, lookupEnvDs,
  18         DsIdEnv,
  19
  20         dsWarn,
  21         DsWarnings,
  22         DsMatchContext(..), DsMatchKind(..), pprDsWarnings
  23     ) where
  24
  25 #include "HsVersions.h"
  26
  27 import Bag              ( emptyBag, snocBag, bagToList, Bag )
  28 import BasicTypes       ( Module )
  29 import ErrUtils         ( WarnMsg )
  30 import HsSyn            ( OutPat )
  31 import MkId             ( mkSysLocal )
  32 import Id               ( mkIdWithNewUniq,
  33                           lookupIdEnv, growIdEnvList, IdEnv, Id
  34                         )
  35 import Outputable
  36 import SrcLoc           ( noSrcLoc, SrcLoc )
  37 import TcHsSyn          ( TypecheckedPat )
  38 import Type             ( Type )
  39 import TyVar            ( cloneTyVar, TyVar )
  40 import UniqSupply       ( splitUniqSupply, getUnique, getUniques,
  41                           UniqSM, UniqSupply )
  42 import Unique           ( Unique )
  43 import Util             ( zipWithEqual, panic )
  44
  45 infixr 9 `thenDs`
  46 \end{code}
  47
  48 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
  49 a @UniqueSupply@ and some annotations, which
  50 presumably include source-file location information:
  51 \begin{code}
  52 type DsM result =
  53         UniqSupply
  54         -> SrcLoc                -- to put in pattern-matching error msgs
  55         -> (Module, Group)       -- module + group name : for SCC profiling
  56         -> DsIdEnv
  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 type Group = FAST_STRING
  64
  65 {-# INLINE andDs #-}
  66 {-# INLINE thenDs #-}
  67 {-# INLINE returnDs #-}
  68
  69 -- initDs returns the UniqSupply out the end (not just the result)
  70
  71 initDs  :: UniqSupply
  72         -> DsIdEnv
  73         -> (Module, Group)      -- module name: for profiling; (group name: from switches)
  74         -> DsM a
  75         -> (a, DsWarnings)
  76
  77 initDs init_us env module_and_group action
  78   = action init_us noSrcLoc module_and_group env emptyBag
  79
  80 thenDs :: DsM a -> (a -> DsM b) -> DsM b
  81 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
  82
  83 thenDs m1 m2 us loc mod_and_grp env warns
  84   = case splitUniqSupply us                 of { (s1, s2) ->
  85     case (m1 s1 loc mod_and_grp env warns)  of { (result, warns1) ->
  86     m2 result s2 loc mod_and_grp env warns1}}
  87
  88 andDs combiner m1 m2 us loc mod_and_grp env warns
  89   = case splitUniqSupply us                 of { (s1, s2) ->
  90     case (m1 s1 loc mod_and_grp env warns)  of { (result1, warns1) ->
  91     case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
  92     (combiner result1 result2, warns2) }}}
  93
  94 returnDs :: a -> DsM a
  95 returnDs result us loc mod_and_grp env warns = (result, warns)
  96
  97 listDs :: [DsM a] -> DsM [a]
  98 listDs []     = returnDs []
  99 listDs (x:xs)
 100   = x           `thenDs` \ r  ->
 101     listDs xs   `thenDs` \ rs ->
 102     returnDs (r:rs)
 103
 104 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
 105
 106 mapDs f []     = returnDs []
 107 mapDs f (x:xs)
 108   = f x         `thenDs` \ r  ->
 109     mapDs f xs  `thenDs` \ rs ->
 110     returnDs (r:rs)
 111
 112 foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a
 113
 114 foldlDs k z []     = returnDs z
 115 foldlDs k z (x:xs) = k z x `thenDs` \ r ->
 116                      foldlDs k r xs
 117
 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 newLocalDs :: FAST_STRING -> Type -> DsM Id
 143 newLocalDs nm ty us loc mod_and_grp env warns
 144   = case (getUnique us) of { assigned_uniq ->
 145     (mkSysLocal nm assigned_uniq ty loc, warns) }
 146
 147 newSysLocalDs       = newLocalDs SLIT("ds")
 148 newSysLocalsDs tys  = mapDs (newLocalDs SLIT("ds")) tys
 149 newFailLocalDs      = newLocalDs SLIT("fail")
 150
 151 getUniqueDs :: DsM Unique
 152 getUniqueDs us loc mod_and_grp env warns
 153   = case (getUnique us) of { assigned_uniq ->
 154     (assigned_uniq, warns) }
 155
 156 duplicateLocalDs :: Id -> DsM Id
 157 duplicateLocalDs old_local us loc mod_and_grp env warns
 158   = case (getUnique us) of { assigned_uniq ->
 159     (mkIdWithNewUniq old_local assigned_uniq, warns) }
 160
 161 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 162 cloneTyVarsDs tyvars us loc mod_and_grp env warns
 163   = case (getUniques (length tyvars) us) of { uniqs ->
 164     (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
 165 \end{code}
 166
 167 \begin{code}
 168 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 169
 170 newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
 171   = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
 172     (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
 173 \end{code}
 174
 175 We can also reach out and either set/grab location information from
 176 the @SrcLoc@ being carried around.
 177 \begin{code}
 178 uniqSMtoDsM :: UniqSM a -> DsM a
 179
 180 uniqSMtoDsM u_action us loc mod_and_grp env warns
 181   = (u_action us, warns)
 182
 183 getSrcLocDs :: DsM SrcLoc
 184 getSrcLocDs us loc mod_and_grp env warns
 185   = (loc, warns)
 186
 187 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 188 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
 189   = expr us new_loc mod_and_grp env warns
 190
 191 dsWarn :: WarnMsg -> DsM ()
 192 dsWarn warn us loc mod_and_grp env warns = ((), warns `snocBag` warn)
 193
 194 \end{code}
 195
 196 \begin{code}
 197 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
 198 getModuleAndGroupDs us loc mod_and_grp env warns
 199   = (mod_and_grp, warns)
 200 \end{code}
 201
 202 \begin{code}
 203 type DsIdEnv = IdEnv Id
 204
 205 extendEnvDs :: [(Id, Id)] -> DsM a -> DsM a
 206
 207 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
 208   = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns
 209
 210 lookupEnvDs :: Id -> DsM Id
 211 lookupEnvDs id us loc mod_and_grp env warns
 212   = (case (lookupIdEnv env id) of
 213       Nothing -> id
 214       Just xx -> xx,
 215      warns)
 216 \end{code}
 217
 218 %************************************************************************
 219 %*                                                                      *
 220 %* type synonym EquationInfo and access functions for its pieces        *
 221 %*                                                                      *
 222 %************************************************************************
 223
 224 \begin{code}
 225 data DsMatchContext
 226   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
 227   | NoMatchContext
 228   deriving ()
 229
 230 data DsMatchKind
 231   = FunMatch Id
 232   | CaseMatch
 233   | LambdaMatch
 234   | PatBindMatch
 235   | DoBindMatch
 236   | ListCompMatch
 237   | LetMatch
 238   deriving ()
 239
 240 pprDsWarnings :: DsWarnings -> SDoc
 241 pprDsWarnings warns = vcat (bagToList warns)
 242 \end{code}