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         dsWarn,
  23         SYN_IE(DsWarnings),
  24         DsMatchContext(..), DsMatchKind(..), pprDsWarnings
  25
  26     ) where
  27
  28 IMP_Ubiq()
  29
  30 import Bag              ( emptyBag, snocBag, bagToList, Bag )
  31 import BasicTypes       ( SYN_IE(Module) )
  32 import CmdLineOpts      ( opt_PprUserLength )
  33 import CoreSyn          ( SYN_IE(CoreExpr) )
  34 import CoreUtils        ( substCoreExpr )
  35 import ErrUtils         ( SYN_IE(Warning) )
  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 Warning           -- The desugarer reports matches which are
  70                                         -- completely shadowed or incomplete patterns
  71
  72 type Group = FAST_STRING
  73
  74 {-# INLINE andDs #-}
  75 {-# INLINE thenDs #-}
  76 {-# INLINE returnDs #-}
  77
  78 -- initDs returns the UniqSupply out the end (not just the result)
  79
  80 initDs  :: UniqSupply
  81         -> DsIdEnv
  82         -> (Module, Group)      -- module name: for profiling; (group name: from switches)
  83         -> DsM a
  84         -> (a, DsWarnings)
  85
  86 initDs init_us env module_and_group action
  87   = action init_us noSrcLoc module_and_group env emptyBag
  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 []     ys = 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 \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
 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 dsWarn :: Warning -> DsM ()
 189 dsWarn warn us loc mod_and_grp env warns = ((), warns `snocBag` warn)
 190
 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 Id
 201
 202 extendEnvDs :: [(Id, Id)] -> DsM a -> DsM a
 203
 204 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
 205   = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns
 206
 207 lookupEnvDs :: Id -> DsM Id
 208 lookupEnvDs id us loc mod_and_grp env warns
 209   = (case (lookupIdEnv env id) of
 210       Nothing -> id
 211       Just xx -> xx,
 212      warns)
 213 \end{code}
 214
 215 %************************************************************************
 216 %*                                                                      *
 217 %* type synonym EquationInfo and access functions for its pieces        *
 218 %*                                                                      *
 219 %************************************************************************
 220
 221 \begin{code}
 222 data DsMatchContext
 223   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
 224   | NoMatchContext
 225   deriving ()
 226
 227 data DsMatchKind
 228   = FunMatch Id
 229   | CaseMatch
 230   | LambdaMatch
 231   | PatBindMatch
 232   | DoBindMatch
 233   | ListCompMatch
 234   | LetMatch
 235   deriving ()
 236
 237 pprDsWarnings :: PprStyle -> DsWarnings -> Doc
 238 pprDsWarnings sty warns = vcat [ warn sty | warn <- (bagToList warns)]
 239
 240 \end{code}