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