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