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, lookupEnvWithDefaultDs,
  20         SYN_IE(DsIdEnv),
  21         lookupId,
  22
  23         dsShadowWarn, dsIncompleteWarn,
  24         DsWarnings(..),
  25         DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
  26         DsWarnFlavour -- Nuke with 1.4
  27
  28     ) where
  29
  30 IMP_Ubiq()
  31
  32 import Bag              ( emptyBag, snocBag, bagToList )
  33 import CmdLineOpts      ( opt_SccGroup )
  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                         )
  40 import PprType          ( GenType, GenTyVar )
  41 import PprStyle         ( PprStyle(..) )
  42 import Pretty
  43 import SrcLoc           ( noSrcLoc, SrcLoc )
  44 import TcHsSyn          ( SYN_IE(TypecheckedPat) )
  45 import TyVar            ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
  46 import Unique           ( Unique{-instances-} )
  47 import UniqSupply       ( splitUniqSupply, getUnique, getUniques,
  48                           mapUs, thenUs, returnUs, SYN_IE(UniqSM) )
  49 import Util             ( assoc, mapAccumL, zipWithEqual, panic )
  50
  51 infixr 9 `thenDs`
  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 (DsWarnFlavour, DsMatchContext)
  67                                         -- The desugarer reports matches which are
  68                                         -- completely shadowed or incomplete patterns
  69 {-# INLINE andDs #-}
  70 {-# INLINE thenDs #-}
  71 {-# INLINE returnDs #-}
  72
  73 -- initDs returns the UniqSupply out the end (not just the result)
  74
  75 initDs  :: UniqSupply
  76         -> DsIdEnv
  77         -> FAST_STRING -- module name: for profiling; (group name: from switches)
  78         -> DsM a
  79         -> (a, DsWarnings)
  80
  81 initDs init_us env mod_name action
  82   = action init_us noSrcLoc module_and_group env emptyBag
  83   where
  84     module_and_group = (mod_name, grp_name)
  85     grp_name  = case opt_SccGroup of
  86                     Just xx -> _PK_ xx
  87                     Nothing -> mod_name -- default: module name
  88
  89 thenDs :: DsM a -> (a -> DsM b) -> DsM b
  90 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
  91
  92 thenDs m1 m2 us loc mod_and_grp env warns
  93   = case splitUniqSupply us                 of { (s1, s2) ->
  94     case (m1 s1 loc mod_and_grp env warns)  of { (result, warns1) ->
  95     m2 result s2 loc mod_and_grp env warns1}}
  96
  97 andDs combiner m1 m2 us loc mod_and_grp env warns
  98   = case splitUniqSupply us                 of { (s1, s2) ->
  99     case (m1 s1 loc mod_and_grp env warns)  of { (result1, warns1) ->
 100     case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
 101     (combiner result1 result2, warns2) }}}
 102
 103 returnDs :: a -> DsM a
 104 returnDs result us loc mod_and_grp env warns = (result, warns)
 105
 106 listDs :: [DsM a] -> DsM [a]
 107 listDs []     = returnDs []
 108 listDs (x:xs)
 109   = x           `thenDs` \ r  ->
 110     listDs xs   `thenDs` \ rs ->
 111     returnDs (r:rs)
 112
 113 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
 114
 115 mapDs f []     = returnDs []
 116 mapDs f (x:xs)
 117   = f x         `thenDs` \ r  ->
 118     mapDs f xs  `thenDs` \ rs ->
 119     returnDs (r:rs)
 120
 121 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 122
 123 mapAndUnzipDs f []     = returnDs ([], [])
 124 mapAndUnzipDs f (x:xs)
 125   = f x                 `thenDs` \ (r1, r2)  ->
 126     mapAndUnzipDs f xs  `thenDs` \ (rs1, rs2) ->
 127     returnDs (r1:rs1, r2:rs2)
 128
 129 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 130
 131 zipWithDs f []     [] = returnDs []
 132 zipWithDs f (x:xs) (y:ys)
 133   = f x y               `thenDs` \ r  ->
 134     zipWithDs f xs ys   `thenDs` \ rs ->
 135     returnDs (r:rs)
 136 -- Note: crashes if lists not equal length (like zipWithEqual)
 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 \begin{code}
 144 newLocalDs :: FAST_STRING -> Type -> DsM Id
 145 newLocalDs nm ty us loc mod_and_grp env warns
 146   = case (getUnique us) of { assigned_uniq ->
 147     (mkSysLocal nm assigned_uniq ty loc, warns) }
 148
 149 newSysLocalDs       = newLocalDs SLIT("ds")
 150 newSysLocalsDs tys  = mapDs (newLocalDs SLIT("ds")) tys
 151 newFailLocalDs      = newLocalDs SLIT("fail")
 152
 153 duplicateLocalDs :: Id -> DsM Id
 154 duplicateLocalDs old_local us loc mod_and_grp env warns
 155   = case (getUnique us) of { assigned_uniq ->
 156     (mkIdWithNewUniq old_local assigned_uniq, warns) }
 157
 158 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 159 cloneTyVarsDs tyvars us loc mod_and_grp env warns
 160   = case (getUniques (length tyvars) us) of { uniqs ->
 161     (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
 162 \end{code}
 163
 164 \begin{code}
 165 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 166
 167 newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
 168   = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
 169     (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
 170 \end{code}
 171
 172 We can also reach out and either set/grab location information from
 173 the @SrcLoc@ being carried around.
 174 \begin{code}
 175 uniqSMtoDsM :: UniqSM a -> DsM a
 176
 177 uniqSMtoDsM u_action us loc mod_and_grp env warns
 178   = (u_action us, warns)
 179
 180 getSrcLocDs :: DsM SrcLoc
 181 getSrcLocDs us loc mod_and_grp env warns
 182   = (loc, 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 dsShadowWarn :: DsMatchContext -> DsM ()
 189 dsShadowWarn cxt us loc mod_and_grp env warns
 190   = ((), warns `snocBag` (Shadowed, cxt))
 191
 192 dsIncompleteWarn :: DsMatchContext -> DsM ()
 193 dsIncompleteWarn cxt us loc mod_and_grp env warns
 194   = ((), warns `snocBag` (Incomplete, cxt))
 195 \end{code}
 196
 197 \begin{code}
 198 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
 199 getModuleAndGroupDs us loc mod_and_grp env warns
 200   = (mod_and_grp, warns)
 201 \end{code}
 202
 203 \begin{code}
 204 type DsIdEnv = IdEnv CoreExpr
 205
 206 extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
 207
 208 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
 209   = case splitUniqSupply us         of { (s1, s2) ->
 210     let
 211         revised_pairs = subst_all pairs s1
 212     in
 213     then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
 214     }
 215   where
 216     subst_all pairs = mapUs subst pairs
 217
 218     subst (v, expr)
 219       = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr ->
 220         returnUs (v, new_expr)
 221
 222 lookupEnvDs :: Id -> DsM (Maybe CoreExpr)
 223 lookupEnvDs id us loc mod_and_grp env warns
 224   = (lookupIdEnv env id, warns)
 225   -- Note: we don't assert anything about the Id
 226   -- being looked up.  There's not really anything
 227   -- much to say about it. (WDP 94/06)
 228
 229 lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
 230 lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
 231   = (case (lookupIdEnv env id) of
 232       Nothing -> deflt
 233       Just xx -> xx,
 234      warns)
 235
 236 lookupId :: [(Id, a)] -> Id -> a
 237 lookupId env id
 238   = assoc "lookupId" env id
 239 \end{code}
 240
 241 %************************************************************************
 242 %*                                                                      *
 243 %* type synonym EquationInfo and access functions for its pieces        *
 244 %*                                                                      *
 245 %************************************************************************
 246
 247 \begin{code}
 248 data DsWarnFlavour = Shadowed | Incomplete deriving ()
 249
 250 data DsMatchContext
 251   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
 252   | NoMatchContext
 253   deriving ()
 254
 255 data DsMatchKind
 256   = FunMatch Id
 257   | CaseMatch
 258   | LambdaMatch
 259   | PatBindMatch
 260   | DoBindMatch
 261   deriving ()
 262
 263 pprDsWarnings :: PprStyle -> DsWarnings -> Pretty
 264 pprDsWarnings sty warns
 265   = ppAboves (map pp_warn (bagToList warns))
 266   where
 267     pp_warn (flavour, NoMatchContext) = ppSep [ppPStr SLIT("Warning: Some match is"),
 268                                                case flavour of
 269                                                         Shadowed   -> ppPStr SLIT("shadowed")
 270                                                         Incomplete -> ppPStr SLIT("possibly incomplete")]
 271
 272     pp_warn (flavour, DsMatchContext kind pats loc)
 273        = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
 274              4 (ppHang msg
 275                      4 (pp_match kind pats))
 276        where
 277         msg = case flavour of
 278                 Shadowed   -> ppPStr SLIT("Warning: Pattern match(es) completely overlapped")
 279                 Incomplete -> ppPStr SLIT("Warning: Possibly incomplete patterns")
 280
 281     pp_match (FunMatch fun) pats
 282       = ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)]
 283
 284     pp_match CaseMatch pats
 285       = ppHang (ppPStr SLIT("in a group of case alternatives beginning:"))
 286         4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 287
 288     pp_match PatBindMatch pats
 289       = ppHang (ppPStr SLIT("in a pattern binding:"))
 290         4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 291
 292     pp_match LambdaMatch pats
 293       = ppHang (ppPStr SLIT("in a lambda abstraction:"))
 294         4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 295
 296     pp_match DoBindMatch pats
 297       = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
 298         4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
 299
 300     pp_arrow_dotdotdot = ppPStr SLIT("-> ...")
 301 \end{code}