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