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,
  11         uniqSMtoDsM,
  12         newTyVarsDs, cloneTyVarsDs,
  13         duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
  14         newFailLocalDs,
  15         getSrcLocDs, putSrcLocDs,
  16         getModuleAndGroupDs,
  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 Id               ( mkSysLocal, mkIdWithNewUniq,
  32                           lookupIdEnv, growIdEnvList, GenId, IdEnv,
  33                           Id
  34                         )
  35 import PprType          ( GenType, GenTyVar )
  36 import Outputable
  37 import SrcLoc           ( noSrcLoc, SrcLoc )
  38 import TcHsSyn          ( TypecheckedPat )
  39 import Type             ( Type )
  40 import TyVar            ( cloneTyVar, TyVar )
  41 import UniqSupply       ( splitUniqSupply, getUnique, getUniques,
  42                           UniqSM, UniqSupply )
  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 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 113
 114 mapAndUnzipDs f []     = returnDs ([], [])
 115 mapAndUnzipDs f (x:xs)
 116   = f x                 `thenDs` \ (r1, r2)  ->
 117     mapAndUnzipDs f xs  `thenDs` \ (rs1, rs2) ->
 118     returnDs (r1:rs1, r2:rs2)
 119
 120 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 121
 122 zipWithDs f []     ys = returnDs []
 123 zipWithDs f (x:xs) (y:ys)
 124   = f x y               `thenDs` \ r  ->
 125     zipWithDs f xs ys   `thenDs` \ rs ->
 126     returnDs (r:rs)
 127 \end{code}
 128
 129 And all this mysterious stuff is so we can occasionally reach out and
 130 grab one or more names.  @newLocalDs@ isn't exported---exported
 131 functions are defined with it.  The difference in name-strings makes
 132 it easier to read debugging output.
 133
 134 \begin{code}
 135 newLocalDs :: FAST_STRING -> Type -> DsM Id
 136 newLocalDs nm ty us loc mod_and_grp env warns
 137   = case (getUnique us) of { assigned_uniq ->
 138     (mkSysLocal nm assigned_uniq ty loc, warns) }
 139
 140 newSysLocalDs       = newLocalDs SLIT("ds")
 141 newSysLocalsDs tys  = mapDs (newLocalDs SLIT("ds")) tys
 142 newFailLocalDs      = newLocalDs SLIT("fail")
 143
 144 duplicateLocalDs :: Id -> DsM Id
 145 duplicateLocalDs old_local us loc mod_and_grp env warns
 146   = case (getUnique us) of { assigned_uniq ->
 147     (mkIdWithNewUniq old_local assigned_uniq, warns) }
 148
 149 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 150 cloneTyVarsDs tyvars us loc mod_and_grp env warns
 151   = case (getUniques (length tyvars) us) of { uniqs ->
 152     (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
 153 \end{code}
 154
 155 \begin{code}
 156 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 157
 158 newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
 159   = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
 160     (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
 161 \end{code}
 162
 163 We can also reach out and either set/grab location information from
 164 the @SrcLoc@ being carried around.
 165 \begin{code}
 166 uniqSMtoDsM :: UniqSM a -> DsM a
 167
 168 uniqSMtoDsM u_action us loc mod_and_grp env warns
 169   = (u_action us, warns)
 170
 171 getSrcLocDs :: DsM SrcLoc
 172 getSrcLocDs us loc mod_and_grp env warns
 173   = (loc, warns)
 174
 175 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 176 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
 177   = expr us new_loc mod_and_grp env warns
 178
 179 dsWarn :: WarnMsg -> DsM ()
 180 dsWarn warn us loc mod_and_grp env warns = ((), warns `snocBag` warn)
 181
 182 \end{code}
 183
 184 \begin{code}
 185 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
 186 getModuleAndGroupDs us loc mod_and_grp env warns
 187   = (mod_and_grp, warns)
 188 \end{code}
 189
 190 \begin{code}
 191 type DsIdEnv = IdEnv Id
 192
 193 extendEnvDs :: [(Id, Id)] -> DsM a -> DsM a
 194
 195 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
 196   = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns
 197
 198 lookupEnvDs :: Id -> DsM Id
 199 lookupEnvDs id us loc mod_and_grp env warns
 200   = (case (lookupIdEnv env id) of
 201       Nothing -> id
 202       Just xx -> xx,
 203      warns)
 204 \end{code}
 205
 206 %************************************************************************
 207 %*                                                                      *
 208 %* type synonym EquationInfo and access functions for its pieces        *
 209 %*                                                                      *
 210 %************************************************************************
 211
 212 \begin{code}
 213 data DsMatchContext
 214   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
 215   | NoMatchContext
 216   deriving ()
 217
 218 data DsMatchKind
 219   = FunMatch Id
 220   | CaseMatch
 221   | LambdaMatch
 222   | PatBindMatch
 223   | DoBindMatch
 224   | ListCompMatch
 225   | LetMatch
 226   deriving ()
 227
 228 pprDsWarnings :: DsWarnings -> SDoc
 229 pprDsWarnings warns = vcat (bagToList warns)
 230 \end{code}