ghc/compiler/deSugar/DsMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[DesugarMonad]{@DesugarMonad@: monadery used in desugaring}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module DsMonad (
  10         DsM(..),
  11         initDs, returnDs, thenDs, andDs, mapDs, listDs,
  12         mapAndUnzipDs, zipWithDs,
  13         uniqSMtoDsM,
  14         newTyVarsDs, cloneTyVarsDs,
  15         duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
  16         newFailLocalDs,
  17         getSrcLocDs, putSrcLocDs,
  18         getSwitchCheckerDs, ifSwitchSetDs,
  19         getModuleAndGroupDs,
  20         extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
  21         DsIdEnv(..),
  22         lookupId,
  23
  24         dsShadowError,
  25         DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
  26
  27 #ifdef DPH
  28         listDs,
  29 #endif
  30
  31         -- and to make the interface self-sufficient...
  32         Id, DataCon(..), SrcLoc, TyVar, TyVarTemplate, UniType, TauType(..),
  33         ThetaType(..), SigmaType(..), SplitUniqSupply, UniqSM(..),
  34         PlainCoreExpr(..), CoreExpr, GlobalSwitch, SwitchResult
  35
  36         IF_ATTACK_PRAGMAS(COMMA lookupUFM COMMA lookupIdEnv)
  37         IF_ATTACK_PRAGMAS(COMMA mkIdWithNewUniq COMMA mkSysLocal)
  38         IF_ATTACK_PRAGMAS(COMMA unpackSrcLoc COMMA mkUniqueSupplyGrimily)
  39         IF_ATTACK_PRAGMAS(COMMA mkUniqueGrimily)
  40         IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA getSUnique)
  41     ) where
  42
  43 import AbsSyn
  44 import AbsUniType       ( cloneTyVarFromTemplate, cloneTyVar,
  45                           TyVar, TyVarTemplate, UniType, TauType(..),
  46                           ThetaType(..), SigmaType(..), Class
  47                           IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
  48                         )
  49 import Bag
  50 import CmdLineOpts      -- ( GlobalSwitch(..), SwitchResult(..), switchIsOn )
  51 import Id               ( mkIdWithNewUniq, mkSysLocal, Id, DataCon(..) )
  52 import IdEnv            -- ( mkIdEnv, IdEnv )
  53 import Maybes           ( assocMaybe, Maybe(..) )
  54 import Outputable
  55 import PlainCore
  56 import Pretty
  57 import SrcLoc           ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
  58 import TyVarEnv         -- ( nullTyVarEnv, TyVarEnv )
  59 import SplitUniq
  60 import Unique
  61 import Util
  62
  63 infixr 9 `thenDs`
  64 \end{code}
  65
  66 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
  67 a @UniqueSupply@ and some annotations, which
  68 presumably include source-file location information:
  69 \begin{code}
  70 type DsM result =
  71         SplitUniqSupply
  72         -> SrcLoc                           -- to put in pattern-matching error msgs
  73         -> (GlobalSwitch -> SwitchResult)   -- so we can consult global switches
  74         -> (FAST_STRING, FAST_STRING)               -- "module"+"group" : for SCC profiling
  75         -> DsIdEnv
  76         -> DsWarnings
  77         -> (result, DsWarnings)
  78
  79 type DsWarnings = Bag DsMatchContext    -- The desugarer reports matches which are
  80                                         -- completely shadowed
  81
  82 #ifdef __GLASGOW_HASKELL__
  83 {-# INLINE andDs #-}
  84 {-# INLINE thenDs #-}
  85 {-# INLINE returnDs #-}
  86 #endif
  87
  88 -- initDs returns the UniqSupply out the end (not just the result)
  89
  90 initDs  :: SplitUniqSupply
  91         -> DsIdEnv
  92         -> (GlobalSwitch -> SwitchResult)
  93         -> FAST_STRING -- module name: for profiling; (group name: from switches)
  94         -> DsM a
  95         -> (a, DsWarnings)
  96
  97 initDs init_us env sw_chkr mod_name action
  98   = action init_us mkUnknownSrcLoc sw_chkr module_and_group env emptyBag
  99   where
 100     module_and_group = (mod_name, grp_name)
 101     grp_name  = case (stringSwitchSet sw_chkr SccGroup) of
 102                     Just xx -> _PK_ xx
 103                     Nothing -> mod_name -- default: module name
 104
 105 thenDs :: DsM a -> (a -> DsM b) -> DsM b
 106 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
 107
 108 thenDs expr cont us loc sw_chkr mod_and_grp env warns
 109   = case splitUniqSupply us         of { (s1, s2) ->
 110     case (expr s1 loc sw_chkr mod_and_grp env warns)  of { (result, warns1) ->
 111     cont result s2 loc sw_chkr mod_and_grp env warns1}}
 112
 113 andDs combiner m1 m2 us loc sw_chkr mod_and_grp env warns
 114   = case splitUniqSupply us         of { (s1, s2) ->
 115     case (m1 s1 loc sw_chkr mod_and_grp env warns)    of { (result1, warns1) ->
 116     case (m2 s2 loc sw_chkr mod_and_grp env warns1)   of { (result2, warns2) ->
 117     (combiner result1 result2, warns2) }}}
 118
 119 returnDs :: a -> DsM a
 120 returnDs result us loc sw_chkr mod_and_grp env warns = (result, warns)
 121
 122 listDs :: [DsM a] -> DsM [a]
 123 listDs []     = returnDs []
 124 listDs (x:xs)
 125   = x           `thenDs` \ r  ->
 126     listDs xs   `thenDs` \ rs ->
 127     returnDs (r:rs)
 128
 129 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
 130
 131 mapDs f []     = returnDs []
 132 mapDs f (x:xs)
 133   = f x         `thenDs` \ r  ->
 134     mapDs f xs  `thenDs` \ rs ->
 135     returnDs (r:rs)
 136
 137 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 138
 139 mapAndUnzipDs f []     = returnDs ([], [])
 140 mapAndUnzipDs f (x:xs)
 141   = f x                 `thenDs` \ (r1, r2)  ->
 142     mapAndUnzipDs f xs  `thenDs` \ (rs1, rs2) ->
 143     returnDs (r1:rs1, r2:rs2)
 144
 145 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 146
 147 zipWithDs f []     [] = returnDs []
 148 zipWithDs f (x:xs) (y:ys)
 149   = f x y               `thenDs` \ r  ->
 150     zipWithDs f xs ys   `thenDs` \ rs ->
 151     returnDs (r:rs)
 152 \end{code}
 153
 154 And all this mysterious stuff is so we can occasionally reach out and
 155 grab one or more names.  @newLocalDs@ isn't exported---exported
 156 functions are defined with it.  The difference in name-strings makes
 157 it easier to read debugging output.
 158 \begin{code}
 159 newLocalDs :: FAST_STRING -> UniType -> DsM Id
 160 newLocalDs nm ty us loc sw_chkr mod_and_grp env warns
 161   = case (getSUnique us) of { assigned_uniq ->
 162     (mkSysLocal nm assigned_uniq ty loc, warns) }
 163
 164 newSysLocalDs       = newLocalDs SLIT("ds")
 165 newSysLocalsDs tys  = mapDs (newLocalDs SLIT("ds")) tys
 166 newFailLocalDs      = newLocalDs SLIT("fail")
 167
 168 duplicateLocalDs :: Id -> DsM Id
 169 duplicateLocalDs old_local us loc sw_chkr mod_and_grp env warns
 170   = case (getSUnique us) of { assigned_uniq ->
 171     (mkIdWithNewUniq old_local assigned_uniq, warns) }
 172
 173 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 174 cloneTyVarsDs tyvars us loc sw_chkr mod_and_grp env warns
 175   = case (getSUniques (length tyvars) us) of { uniqs ->
 176     (zipWith cloneTyVar tyvars uniqs, warns) }
 177 \end{code}
 178
 179 \begin{code}
 180 newTyVarsDs :: [TyVarTemplate] -> DsM [TyVar]
 181
 182 newTyVarsDs tyvar_tmpls us loc sw_chkr mod_and_grp env warns
 183   = case (getSUniques (length tyvar_tmpls) us) of { uniqs ->
 184     (zipWith cloneTyVarFromTemplate tyvar_tmpls uniqs, warns) }
 185 \end{code}
 186
 187 We can also reach out and either set/grab location information from
 188 the @SrcLoc@ being carried around.
 189 \begin{code}
 190 uniqSMtoDsM :: UniqSM a -> DsM a
 191
 192 uniqSMtoDsM u_action us loc sw_chkr mod_and_grp env warns
 193   = let
 194         us_to_use = mkUniqueSupplyGrimily us
 195     in
 196     (snd (u_action us_to_use), warns)
 197
 198 getSrcLocDs :: DsM (String, String)
 199 getSrcLocDs us loc sw_chkr mod_and_grp env warns
 200   = case (unpackSrcLoc loc) of { (x,y) ->
 201     ((_UNPK_ x, _UNPK_ y), warns) }
 202
 203 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 204 putSrcLocDs new_loc expr us old_loc sw_chkr mod_and_grp env warns
 205   = expr us new_loc sw_chkr mod_and_grp env warns
 206
 207 dsShadowError :: DsMatchContext -> DsM ()
 208 dsShadowError cxt us loc sw_chkr mod_and_grp env warns
 209   = ((), warns `snocBag` cxt)
 210 \end{code}
 211
 212 \begin{code}
 213 getSwitchCheckerDs :: DsM (GlobalSwitch -> Bool)
 214 getSwitchCheckerDs us loc sw_chkr mod_and_grp env warns
 215   = (switchIsOn sw_chkr, warns)
 216
 217 ifSwitchSetDs :: GlobalSwitch -> DsM a -> DsM a -> DsM a
 218 ifSwitchSetDs switch then_ else_ us loc sw_chkr mod_and_grp env warns
 219   = (if switchIsOn sw_chkr switch then then_ else else_)
 220         us loc sw_chkr mod_and_grp env warns
 221
 222 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
 223 getModuleAndGroupDs us loc sw_chkr mod_and_grp env warns
 224   = (mod_and_grp, warns)
 225 \end{code}
 226
 227 \begin{code}
 228 type DsIdEnv = IdEnv PlainCoreExpr
 229
 230 extendEnvDs :: [(Id, PlainCoreExpr)] -> DsM a -> DsM a
 231
 232 extendEnvDs pairs expr us loc sw_chkr mod_and_grp old_env warns
 233   = case splitUniqSupply us         of { (s1, s2) ->
 234     case (mapAccumL subst s1 pairs) of { (_, revised_pairs) ->
 235     expr s2 loc sw_chkr mod_and_grp (growIdEnvList old_env revised_pairs) warns
 236     }}
 237   where
 238     subst us (v, expr)
 239       = case splitUniqSupply us of { (s1, s2) ->
 240         let
 241             us_to_use = mkUniqueSupplyGrimily s1
 242         in
 243         case (substCoreExpr us_to_use old_env nullTyVarEnv expr) of { (_, expr2) ->
 244         (s2, (v, expr2)) }}
 245
 246 lookupEnvDs :: Id -> DsM (Maybe PlainCoreExpr)
 247 lookupEnvDs id us loc sw_chkr mod_and_grp env warns
 248   = (lookupIdEnv env id, warns)
 249   -- Note: we don't assert anything about the Id
 250   -- being looked up.  There's not really anything
 251   -- much to say about it. (WDP 94/06)
 252
 253 lookupEnvWithDefaultDs :: Id -> PlainCoreExpr -> DsM PlainCoreExpr
 254 lookupEnvWithDefaultDs id deflt us loc sw_chkr mod_and_grp env warns
 255   = (case (lookupIdEnv env id) of
 256       Nothing -> deflt
 257       Just xx -> xx,
 258      warns)
 259
 260 lookupId :: [(Id, a)] -> Id -> a
 261 lookupId env id
 262   = assoc "lookupId" env id
 263 \end{code}
 264
 265 %************************************************************************
 266 %*                                                                      *
 267 %* type synonym EquationInfo and access functions for its pieces        *
 268 %*                                                                      *
 269 %************************************************************************
 270
 271 \begin{code}
 272 data DsMatchContext
 273   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
 274   | NoMatchContext
 275
 276 data DsMatchKind
 277   = FunMatch Id
 278   | CaseMatch
 279   | LambdaMatch
 280   | PatBindMatch
 281
 282 pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty
 283 pprDsWarnings sty warns
 284   = ppAboves (map pp_cxt (bagToList warns))
 285   where
 286     pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what")
 287     pp_cxt (DsMatchContext kind pats loc)
 288       = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
 289              4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:"))
 290                      4 (pp_match kind pats))
 291
 292     pp_match (FunMatch fun) pats
 293       = ppHang (ppr sty fun)
 294         4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")])
 295
 296     pp_match CaseMatch pats
 297       = ppHang (ppPStr SLIT("in a case alternative:"))
 298         4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 299
 300     pp_match PatBindMatch pats
 301       = ppHang (ppPStr SLIT("in a pattern binding:"))
 302         4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 303
 304     pp_match LambdaMatch pats
 305       = ppHang (ppPStr SLIT("in a lambda abstraction:"))
 306         4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 307
 308     pp_arrow_dotdotdot = ppPStr SLIT("-> ...")
 309 \end{code}