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 #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         getModuleAndGroupDs,
  19         extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
  20         DsIdEnv(..),
  21         lookupId,
  22
  23         dsShadowError,
  24         DsMatchContext(..), DsMatchKind(..), pprDsWarnings
  25     ) where
  26
  27 IMP_Ubiq()
  28
  29 import Bag              ( emptyBag, snocBag, bagToList )
  30 import CmdLineOpts      ( opt_SccGroup )
  31 import CoreSyn          ( CoreExpr(..) )
  32 import CoreUtils        ( substCoreExpr )
  33 import HsSyn            ( OutPat )
  34 import Id               ( mkSysLocal, mkIdWithNewUniq,
  35                           lookupIdEnv, growIdEnvList, GenId, IdEnv(..)
  36                         )
  37 import PprType          ( GenType, GenTyVar )
  38 import PprStyle         ( PprStyle(..) )
  39 import Pretty
  40 import SrcLoc           ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
  41 import TcHsSyn          ( TypecheckedPat(..) )
  42 import TyVar            ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
  43 import Unique           ( Unique{-instances-} )
  44 import UniqSupply       ( splitUniqSupply, getUnique, getUniques,
  45                           mapUs, thenUs, returnUs, UniqSM(..) )
  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         -> (FAST_STRING, FAST_STRING)   -- "module"+"group" : for SCC profiling
  59         -> DsIdEnv
  60         -> DsWarnings
  61         -> (result, DsWarnings)
  62
  63 type DsWarnings = Bag DsMatchContext    -- The desugarer reports matches which are
  64                                         -- completely shadowed
  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         -> FAST_STRING -- module name: for profiling; (group name: from switches)
  74         -> DsM a
  75         -> (a, DsWarnings)
  76
  77 initDs init_us env mod_name action
  78   = action init_us mkUnknownSrcLoc module_and_group env emptyBag
  79   where
  80     module_and_group = (mod_name, grp_name)
  81     grp_name  = case opt_SccGroup of
  82                     Just xx -> _PK_ xx
  83                     Nothing -> mod_name -- default: module name
  84
  85 thenDs :: DsM a -> (a -> DsM b) -> DsM b
  86 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
  87
  88 thenDs 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 { (result, warns1) ->
  91     m2 result s2 loc mod_and_grp env warns1}}
  92
  93 andDs combiner m1 m2 us loc mod_and_grp env warns
  94   = case splitUniqSupply us                 of { (s1, s2) ->
  95     case (m1 s1 loc mod_and_grp env warns)  of { (result1, warns1) ->
  96     case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
  97     (combiner result1 result2, warns2) }}}
  98
  99 returnDs :: a -> DsM a
 100 returnDs result us loc mod_and_grp env warns = (result, warns)
 101
 102 listDs :: [DsM a] -> DsM [a]
 103 listDs []     = returnDs []
 104 listDs (x:xs)
 105   = x           `thenDs` \ r  ->
 106     listDs xs   `thenDs` \ rs ->
 107     returnDs (r:rs)
 108
 109 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
 110
 111 mapDs f []     = returnDs []
 112 mapDs f (x:xs)
 113   = f x         `thenDs` \ r  ->
 114     mapDs f xs  `thenDs` \ rs ->
 115     returnDs (r:rs)
 116
 117 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 118
 119 mapAndUnzipDs f []     = returnDs ([], [])
 120 mapAndUnzipDs f (x:xs)
 121   = f x                 `thenDs` \ (r1, r2)  ->
 122     mapAndUnzipDs f xs  `thenDs` \ (rs1, rs2) ->
 123     returnDs (r1:rs1, r2:rs2)
 124
 125 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 126
 127 zipWithDs f []     [] = returnDs []
 128 zipWithDs f (x:xs) (y:ys)
 129   = f x y               `thenDs` \ r  ->
 130     zipWithDs f xs ys   `thenDs` \ rs ->
 131     returnDs (r:rs)
 132 -- Note: crashes if lists not equal length (like zipWithEqual)
 133 \end{code}
 134
 135 And all this mysterious stuff is so we can occasionally reach out and
 136 grab one or more names.  @newLocalDs@ isn't exported---exported
 137 functions are defined with it.  The difference in name-strings makes
 138 it easier to read debugging output.
 139 \begin{code}
 140 newLocalDs :: FAST_STRING -> Type -> DsM Id
 141 newLocalDs nm ty us loc mod_and_grp env warns
 142   = case (getUnique us) of { assigned_uniq ->
 143     (mkSysLocal nm assigned_uniq ty loc, warns) }
 144
 145 newSysLocalDs       = newLocalDs SLIT("ds")
 146 newSysLocalsDs tys  = mapDs (newLocalDs SLIT("ds")) tys
 147 newFailLocalDs      = newLocalDs SLIT("fail")
 148
 149 duplicateLocalDs :: Id -> DsM Id
 150 duplicateLocalDs old_local us loc mod_and_grp env warns
 151   = case (getUnique us) of { assigned_uniq ->
 152     (mkIdWithNewUniq old_local assigned_uniq, warns) }
 153
 154 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 155 cloneTyVarsDs tyvars us loc mod_and_grp env warns
 156   = case (getUniques (length tyvars) us) of { uniqs ->
 157     (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
 158 \end{code}
 159
 160 \begin{code}
 161 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 162
 163 newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
 164   = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
 165     (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
 166 \end{code}
 167
 168 We can also reach out and either set/grab location information from
 169 the @SrcLoc@ being carried around.
 170 \begin{code}
 171 uniqSMtoDsM :: UniqSM a -> DsM a
 172
 173 uniqSMtoDsM u_action us loc mod_and_grp env warns
 174   = (u_action us, warns)
 175
 176 getSrcLocDs :: DsM (String, String)
 177 getSrcLocDs us loc mod_and_grp env warns
 178   = case (unpackSrcLoc loc) of { (x,y) ->
 179     ((_UNPK_ x, _UNPK_ y), warns) }
 180
 181 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 182 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
 183   = expr us new_loc mod_and_grp env warns
 184
 185 dsShadowError :: DsMatchContext -> DsM ()
 186 dsShadowError cxt us loc mod_and_grp env warns
 187   = ((), warns `snocBag` cxt)
 188 \end{code}
 189
 190 \begin{code}
 191 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
 192 getModuleAndGroupDs us loc mod_and_grp env warns
 193   = (mod_and_grp, warns)
 194 \end{code}
 195
 196 \begin{code}
 197 type DsIdEnv = IdEnv CoreExpr
 198
 199 extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
 200
 201 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
 202   = case splitUniqSupply us         of { (s1, s2) ->
 203     let
 204         revised_pairs = subst_all pairs s1
 205     in
 206     then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
 207     }
 208   where
 209     subst_all pairs = mapUs subst pairs
 210
 211     subst (v, expr)
 212       = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr ->
 213         returnUs (v, new_expr)
 214
 215 lookupEnvDs :: Id -> DsM (Maybe CoreExpr)
 216 lookupEnvDs id us loc mod_and_grp env warns
 217   = (lookupIdEnv env id, warns)
 218   -- Note: we don't assert anything about the Id
 219   -- being looked up.  There's not really anything
 220   -- much to say about it. (WDP 94/06)
 221
 222 lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
 223 lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
 224   = (case (lookupIdEnv env id) of
 225       Nothing -> deflt
 226       Just xx -> xx,
 227      warns)
 228
 229 lookupId :: [(Id, a)] -> Id -> a
 230 lookupId env id
 231   = assoc "lookupId" env id
 232 \end{code}
 233
 234 %************************************************************************
 235 %*                                                                      *
 236 %* type synonym EquationInfo and access functions for its pieces        *
 237 %*                                                                      *
 238 %************************************************************************
 239
 240 \begin{code}
 241 data DsMatchContext
 242   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
 243   | NoMatchContext
 244
 245 data DsMatchKind
 246   = FunMatch Id
 247   | CaseMatch
 248   | LambdaMatch
 249   | PatBindMatch
 250   | DoBindMatch
 251
 252 pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty
 253 pprDsWarnings sty warns
 254   = ppAboves (map pp_cxt (bagToList warns))
 255   where
 256     pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what")
 257     pp_cxt (DsMatchContext kind pats loc)
 258       = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
 259              4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:"))
 260                      4 (pp_match kind pats))
 261
 262     pp_match (FunMatch fun) pats
 263       = ppHang (ppr sty fun)
 264         4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")])
 265
 266     pp_match CaseMatch pats
 267       = ppHang (ppPStr SLIT("in a case alternative:"))
 268         4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 269
 270     pp_match PatBindMatch pats
 271       = ppHang (ppPStr SLIT("in a pattern binding:"))
 272         4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 273
 274     pp_match LambdaMatch pats
 275       = ppHang (ppPStr SLIT("in a lambda abstraction:"))
 276         4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 277
 278     pp_match DoBindMatch pats
 279       = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
 280         4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 281
 282     pp_arrow_dotdotdot = ppPStr SLIT("-> ...")
 283 \end{code}