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