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 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 Util             ( zipWithEqual, panic )
  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         UniqSupply
  53         -> SrcLoc                -- to put in pattern-matching error msgs
  54         -> (Module, Group)       -- module + group name : for SCC profiling
  55         -> DsIdEnv
  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 type Group = FAST_STRING
  63
  64 {-# INLINE andDs #-}
  65 {-# INLINE thenDs #-}
  66 {-# INLINE returnDs #-}
  67
  68 -- initDs returns the UniqSupply out the end (not just the result)
  69
  70 initDs  :: UniqSupply
  71         -> DsIdEnv
  72         -> (Module, Group)      -- module name: for profiling; (group name: from switches)
  73         -> DsM a
  74         -> (a, DsWarnings)
  75
  76 initDs init_us env module_and_group action
  77   = action init_us noSrcLoc module_and_group env 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 us loc mod_and_grp env warns
  83   = case splitUniqSupply us                 of { (s1, s2) ->
  84     case (m1 s1 loc mod_and_grp env warns)  of { (result, warns1) ->
  85     m2 result s2 loc mod_and_grp env warns1}}
  86
  87 andDs combiner m1 m2 us loc mod_and_grp env warns
  88   = case splitUniqSupply us                 of { (s1, s2) ->
  89     case (m1 s1 loc mod_and_grp env warns)  of { (result1, warns1) ->
  90     case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
  91     (combiner result1 result2, warns2) }}}
  92
  93 returnDs :: a -> DsM a
  94 returnDs result us loc mod_and_grp env 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 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 112
 113 mapAndUnzipDs f []     = returnDs ([], [])
 114 mapAndUnzipDs f (x:xs)
 115   = f x                 `thenDs` \ (r1, r2)  ->
 116     mapAndUnzipDs f xs  `thenDs` \ (rs1, rs2) ->
 117     returnDs (r1:rs1, r2:rs2)
 118
 119 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 120
 121 zipWithDs f []     ys = returnDs []
 122 zipWithDs f (x:xs) (y:ys)
 123   = f x y               `thenDs` \ r  ->
 124     zipWithDs f xs ys   `thenDs` \ rs ->
 125     returnDs (r:rs)
 126 \end{code}
 127
 128 And all this mysterious stuff is so we can occasionally reach out and
 129 grab one or more names.  @newLocalDs@ isn't exported---exported
 130 functions are defined with it.  The difference in name-strings makes
 131 it easier to read debugging output.
 132
 133 \begin{code}
 134 newLocalDs :: FAST_STRING -> Type -> DsM Id
 135 newLocalDs nm ty us loc mod_and_grp env warns
 136   = case (getUnique us) of { assigned_uniq ->
 137     (mkSysLocal nm assigned_uniq ty loc, warns) }
 138
 139 newSysLocalDs       = newLocalDs SLIT("ds")
 140 newSysLocalsDs tys  = mapDs (newLocalDs SLIT("ds")) tys
 141 newFailLocalDs      = newLocalDs SLIT("fail")
 142
 143 duplicateLocalDs :: Id -> DsM Id
 144 duplicateLocalDs old_local us loc mod_and_grp env warns
 145   = case (getUnique us) of { assigned_uniq ->
 146     (mkIdWithNewUniq old_local assigned_uniq, warns) }
 147
 148 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 149 cloneTyVarsDs tyvars us loc mod_and_grp env warns
 150   = case (getUniques (length tyvars) us) of { uniqs ->
 151     (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
 152 \end{code}
 153
 154 \begin{code}
 155 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 156
 157 newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
 158   = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
 159     (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
 160 \end{code}
 161
 162 We can also reach out and either set/grab location information from
 163 the @SrcLoc@ being carried around.
 164 \begin{code}
 165 uniqSMtoDsM :: UniqSM a -> DsM a
 166
 167 uniqSMtoDsM u_action us loc mod_and_grp env warns
 168   = (u_action us, warns)
 169
 170 getSrcLocDs :: DsM SrcLoc
 171 getSrcLocDs us loc mod_and_grp env warns
 172   = (loc, warns)
 173
 174 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 175 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
 176   = expr us new_loc mod_and_grp env warns
 177
 178 dsWarn :: WarnMsg -> DsM ()
 179 dsWarn warn us loc mod_and_grp env warns = ((), warns `snocBag` warn)
 180
 181 \end{code}
 182
 183 \begin{code}
 184 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
 185 getModuleAndGroupDs us loc mod_and_grp env warns
 186   = (mod_and_grp, warns)
 187 \end{code}
 188
 189 \begin{code}
 190 type DsIdEnv = IdEnv Id
 191
 192 extendEnvDs :: [(Id, Id)] -> DsM a -> DsM a
 193
 194 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
 195   = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns
 196
 197 lookupEnvDs :: Id -> DsM Id
 198 lookupEnvDs id us loc mod_and_grp env warns
 199   = (case (lookupIdEnv env id) of
 200       Nothing -> id
 201       Just xx -> xx,
 202      warns)
 203 \end{code}
 204
 205 %************************************************************************
 206 %*                                                                      *
 207 %* type synonym EquationInfo and access functions for its pieces        *
 208 %*                                                                      *
 209 %************************************************************************
 210
 211 \begin{code}
 212 data DsMatchContext
 213   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
 214   | NoMatchContext
 215   deriving ()
 216
 217 data DsMatchKind
 218   = FunMatch Id
 219   | CaseMatch
 220   | LambdaMatch
 221   | PatBindMatch
 222   | DoBindMatch
 223   | ListCompMatch
 224   | LetMatch
 225   deriving ()
 226
 227 pprDsWarnings :: DsWarnings -> SDoc
 228 pprDsWarnings warns = vcat (bagToList warns)
 229 \end{code}