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         SYN_IE(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,
  20         SYN_IE(DsIdEnv),
  21
  22         dsShadowWarn, dsIncompleteWarn,
  23         SYN_IE(DsWarnings),
  24         DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
  25         DsWarnFlavour -- Nuke with 1.4
  26
  27     ) where
  28
  29 IMP_Ubiq()
  30
  31 import Bag              ( emptyBag, snocBag, bagToList, Bag )
  32 import CmdLineOpts      ( opt_SccGroup )
  33 import CoreSyn          ( SYN_IE(CoreExpr) )
  34 import CoreUtils        ( substCoreExpr )
  35 import HsSyn            ( OutPat )
  36 import Id               ( mkSysLocal, mkIdWithNewUniq,
  37                           lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv),
  38                           SYN_IE(Id)
  39                         )
  40 import PprType          ( GenType, GenTyVar )
  41 import PprStyle         ( PprStyle(..) )
  42 import Outputable       ( pprQuote, Outputable(..) )
  43 import Pretty
  44 import SrcLoc           ( noSrcLoc, SrcLoc )
  45 import TcHsSyn          ( SYN_IE(TypecheckedPat) )
  46 import Type             ( SYN_IE(Type) )
  47 import TyVar            ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
  48 import Unique           ( Unique{-instances-} )
  49 import UniqSupply       ( splitUniqSupply, getUnique, getUniques,
  50                           mapUs, thenUs, returnUs, SYN_IE(UniqSM),
  51                           UniqSupply )
  52 import Util             ( assoc, mapAccumL, zipWithEqual, panic )
  53
  54 infixr 9 `thenDs`
  55 \end{code}
  56
  57 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
  58 a @UniqueSupply@ and some annotations, which
  59 presumably include source-file location information:
  60 \begin{code}
  61 type DsM result =
  62         UniqSupply
  63         -> SrcLoc                       -- to put in pattern-matching error msgs
  64         -> (FAST_STRING, FAST_STRING)   -- "module"+"group" : for SCC profiling
  65         -> DsIdEnv
  66         -> DsWarnings
  67         -> (result, DsWarnings)
  68
  69 type DsWarnings = Bag (DsWarnFlavour, DsMatchContext)
  70                                         -- The desugarer reports matches which are
  71                                         -- completely shadowed or incomplete patterns
  72 {-# INLINE andDs #-}
  73 {-# INLINE thenDs #-}
  74 {-# INLINE returnDs #-}
  75
  76 -- initDs returns the UniqSupply out the end (not just the result)
  77
  78 initDs  :: UniqSupply
  79         -> DsIdEnv
  80         -> FAST_STRING -- module name: for profiling; (group name: from switches)
  81         -> DsM a
  82         -> (a, DsWarnings)
  83
  84 initDs init_us env mod_name action
  85   = action init_us noSrcLoc module_and_group env emptyBag
  86   where
  87     module_and_group = (mod_name, grp_name)
  88     grp_name  = case opt_SccGroup of
  89                     Just xx -> _PK_ xx
  90                     Nothing -> mod_name -- default: module name
  91
  92 thenDs :: DsM a -> (a -> DsM b) -> DsM b
  93 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
  94
  95 thenDs m1 m2 us loc mod_and_grp env warns
  96   = case splitUniqSupply us                 of { (s1, s2) ->
  97     case (m1 s1 loc mod_and_grp env warns)  of { (result, warns1) ->
  98     m2 result s2 loc mod_and_grp env warns1}}
  99
 100 andDs combiner m1 m2 us loc mod_and_grp env warns
 101   = case splitUniqSupply us                 of { (s1, s2) ->
 102     case (m1 s1 loc mod_and_grp env warns)  of { (result1, warns1) ->
 103     case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
 104     (combiner result1 result2, warns2) }}}
 105
 106 returnDs :: a -> DsM a
 107 returnDs result us loc mod_and_grp env warns = (result, warns)
 108
 109 listDs :: [DsM a] -> DsM [a]
 110 listDs []     = returnDs []
 111 listDs (x:xs)
 112   = x           `thenDs` \ r  ->
 113     listDs xs   `thenDs` \ rs ->
 114     returnDs (r:rs)
 115
 116 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
 117
 118 mapDs f []     = returnDs []
 119 mapDs f (x:xs)
 120   = f x         `thenDs` \ r  ->
 121     mapDs f xs  `thenDs` \ rs ->
 122     returnDs (r:rs)
 123
 124 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 125
 126 mapAndUnzipDs f []     = returnDs ([], [])
 127 mapAndUnzipDs f (x:xs)
 128   = f x                 `thenDs` \ (r1, r2)  ->
 129     mapAndUnzipDs f xs  `thenDs` \ (rs1, rs2) ->
 130     returnDs (r1:rs1, r2:rs2)
 131
 132 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 133
 134 zipWithDs f []     ys = returnDs []
 135 zipWithDs f (x:xs) (y:ys)
 136   = f x y               `thenDs` \ r  ->
 137     zipWithDs f xs ys   `thenDs` \ rs ->
 138     returnDs (r:rs)
 139 \end{code}
 140
 141 And all this mysterious stuff is so we can occasionally reach out and
 142 grab one or more names.  @newLocalDs@ isn't exported---exported
 143 functions are defined with it.  The difference in name-strings makes
 144 it easier to read debugging output.
 145
 146 \begin{code}
 147 newLocalDs :: FAST_STRING -> Type -> DsM Id
 148 newLocalDs nm ty us loc mod_and_grp env warns
 149   = case (getUnique us) of { assigned_uniq ->
 150     (mkSysLocal nm assigned_uniq ty loc, warns) }
 151
 152 newSysLocalDs       = newLocalDs SLIT("ds")
 153 newSysLocalsDs tys  = mapDs (newLocalDs SLIT("ds")) tys
 154 newFailLocalDs      = newLocalDs SLIT("fail")
 155
 156 duplicateLocalDs :: Id -> DsM Id
 157 duplicateLocalDs old_local us loc mod_and_grp env warns
 158   = case (getUnique us) of { assigned_uniq ->
 159     (mkIdWithNewUniq old_local assigned_uniq, warns) }
 160
 161 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 162 cloneTyVarsDs tyvars us loc mod_and_grp env warns
 163   = case (getUniques (length tyvars) us) of { uniqs ->
 164     (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
 165 \end{code}
 166
 167 \begin{code}
 168 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 169
 170 newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
 171   = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
 172     (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
 173 \end{code}
 174
 175 We can also reach out and either set/grab location information from
 176 the @SrcLoc@ being carried around.
 177 \begin{code}
 178 uniqSMtoDsM :: UniqSM a -> DsM a
 179
 180 uniqSMtoDsM u_action us loc mod_and_grp env warns
 181   = (u_action us, warns)
 182
 183 getSrcLocDs :: DsM SrcLoc
 184 getSrcLocDs us loc mod_and_grp env warns
 185   = (loc, warns)
 186
 187 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 188 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
 189   = expr us new_loc mod_and_grp env warns
 190
 191 dsShadowWarn :: DsMatchContext -> DsM ()
 192 dsShadowWarn cxt us loc mod_and_grp env warns
 193   = ((), warns `snocBag` (Shadowed, cxt))
 194
 195 dsIncompleteWarn :: DsMatchContext -> DsM ()
 196 dsIncompleteWarn cxt us loc mod_and_grp env warns
 197   = ((), warns `snocBag` (Incomplete, cxt))
 198 \end{code}
 199
 200 \begin{code}
 201 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
 202 getModuleAndGroupDs us loc mod_and_grp env warns
 203   = (mod_and_grp, warns)
 204 \end{code}
 205
 206 \begin{code}
 207 type DsIdEnv = IdEnv Id
 208
 209 extendEnvDs :: [(Id, Id)] -> DsM a -> DsM a
 210
 211 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
 212   = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns
 213
 214 lookupEnvDs :: Id -> DsM Id
 215 lookupEnvDs id us loc mod_and_grp env warns
 216   = (case (lookupIdEnv env id) of
 217       Nothing -> id
 218       Just xx -> xx,
 219      warns)
 220 \end{code}
 221
 222 %************************************************************************
 223 %*                                                                      *
 224 %* type synonym EquationInfo and access functions for its pieces        *
 225 %*                                                                      *
 226 %************************************************************************
 227
 228 \begin{code}
 229 data DsWarnFlavour = Shadowed | Incomplete deriving ()
 230
 231 data DsMatchContext
 232   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
 233   | NoMatchContext
 234   deriving ()
 235
 236 data DsMatchKind
 237   = FunMatch Id
 238   | CaseMatch
 239   | LambdaMatch
 240   | PatBindMatch
 241   | DoBindMatch
 242   deriving ()
 243
 244 pprDsWarnings :: PprStyle -> DsWarnings -> Doc
 245 pprDsWarnings sty warns
 246   = vcat (map pp_warn (bagToList warns))
 247   where
 248     pp_warn (flavour, NoMatchContext) = sep [ptext SLIT("Warning: Some match is"),
 249                                                case flavour of
 250                                                         Shadowed   -> ptext SLIT("shadowed")
 251                                                         Incomplete -> ptext SLIT("possibly incomplete")]
 252
 253     pp_warn (flavour, DsMatchContext kind pats loc)
 254        = hang (hcat [ppr PprForUser loc, ptext SLIT(": ")])
 255              4 (hang msg
 256                      4 (pp_match kind pats))
 257        where
 258         msg = case flavour of
 259                 Shadowed   -> ptext SLIT("Warning: Pattern match(es) completely overlapped")
 260                 Incomplete -> ptext SLIT("Warning: Possibly incomplete patterns")
 261
 262     pp_match (FunMatch fun) pats
 263       = hsep [ptext SLIT("in the definition of function"), ppr sty fun]
 264
 265     pp_match CaseMatch pats
 266       = hang (ptext SLIT("in a group of case alternatives beginning:"))
 267         4 (ppr_pats pats)
 268
 269     pp_match PatBindMatch pats
 270       = hang (ptext SLIT("in a pattern binding:"))
 271         4 (ppr_pats pats)
 272
 273     pp_match LambdaMatch pats
 274       = hang (ptext SLIT("in a lambda abstraction:"))
 275         4 (ppr_pats pats)
 276
 277     pp_match DoBindMatch pats
 278       = hang (ptext SLIT("in a `do' pattern binding:"))
 279         4 (ppr_pats pats)
 280
 281     ppr_pats pats = pprQuote sty $ \ sty ->
 282                     sep [sep (map (ppr sty) pats), ptext SLIT("-> ...")]
 283 \end{code}