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