ghc/compiler/deSugar/DsMonad.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
   5
   6 \begin{code}
   7 module DsMonad (
   8         DsM,
   9         initDs, returnDs, thenDs, andDs, mapDs, listDs,
  10         mapAndUnzipDs, zipWithDs, foldlDs,
  11         uniqSMtoDsM,
  12         newTyVarsDs, cloneTyVarsDs,
  13         duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
  14         newFailLocalDs,
  15         getSrcLocDs, putSrcLocDs,
  16         getModuleDs,
  17         getUniqueDs,
  18         getDOptsDs,
  19         dsLookupGlobalValue,
  20
  21         dsWarn,
  22         DsWarnings,
  23         DsMatchContext(..), DsMatchKind(..)
  24     ) where
  25
  26 #include "HsVersions.h"
  27
  28 import Bag              ( emptyBag, snocBag, Bag )
  29 import ErrUtils         ( WarnMsg )
  30 import Id               ( mkSysLocal, setIdUnique, Id )
  31 import Module           ( Module )
  32 import Var              ( TyVar, setTyVarUnique )
  33 import Outputable
  34 import SrcLoc           ( noSrcLoc, SrcLoc )
  35 import TcHsSyn          ( TypecheckedPat )
  36 import Type             ( Type )
  37 import UniqSupply       ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
  38                           UniqSM, UniqSupply )
  39 import Unique           ( Unique )
  40 import UniqFM           ( lookupWithDefaultUFM_Directly )
  41 import Util             ( zipWithEqual )
  42 import Name             ( Name, lookupNameEnv )
  43 import HscTypes         ( HomeSymbolTable, PersistentCompilerState(..),
  44                           TyThing(..), TypeEnv, lookupTypeEnv )
  45 import CmdLineOpts      ( DynFlags )
  46
  47 infixr 9 `thenDs`
  48 \end{code}
  49
  50 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
  51 a @UniqueSupply@ and some annotations, which
  52 presumably include source-file location information:
  53 \begin{code}
  54 type DsM result =
  55         DynFlags
  56         -> UniqSupply
  57         -> (Name -> Id)         -- Lookup well-known Ids
  58         -> SrcLoc               -- to put in pattern-matching error msgs
  59         -> Module               -- module: for SCC profiling
  60         -> DsWarnings
  61         -> (result, DsWarnings)
  62
  63 type DsWarnings = Bag WarnMsg           -- The desugarer reports matches which are
  64                                         -- completely shadowed or incomplete patterns
  65
  66 {-# INLINE andDs #-}
  67 {-# INLINE thenDs #-}
  68 {-# INLINE returnDs #-}
  69
  70 -- initDs returns the UniqSupply out the end (not just the result)
  71
  72 initDs  :: DynFlags
  73         -> UniqSupply
  74         -> (HomeSymbolTable, PersistentCompilerState, TypeEnv)
  75         -> Module   -- module name: for profiling
  76         -> DsM a
  77         -> (a, DsWarnings)
  78
  79 initDs dflags init_us (hst,pcs,local_type_env) mod action
  80   = action dflags init_us lookup noSrcLoc mod emptyBag
  81   where
  82         -- This lookup is used for well-known Ids,
  83         -- such as fold, build, cons etc, so the chances are
  84         -- it'll be found in the package symbol table.  That's
  85         -- why we don't merge all these tables
  86     pst = pcs_PST pcs
  87     lookup n = case lookupTypeEnv pst n of {
  88                  Just (AnId v) -> v ;
  89                  other ->
  90                case lookupTypeEnv hst n of {
  91                  Just (AnId v) -> v ;
  92                  other ->
  93                case lookupNameEnv local_type_env n of
  94                  Just (AnId v) -> v ;
  95                  other         -> pprPanic "initDS: lookup:" (ppr n)
  96                }}
  97
  98 thenDs :: DsM a -> (a -> DsM b) -> DsM b
  99 andDs  :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
 100
 101 thenDs m1 m2 dflags us genv loc mod warns
 102   = case splitUniqSupply us                 of { (s1, s2) ->
 103     case (m1 dflags s1 genv loc mod warns)  of { (result, warns1) ->
 104     m2 result dflags s2 genv loc mod warns1}}
 105
 106 andDs combiner m1 m2 dflags us genv loc mod warns
 107   = case splitUniqSupply us                 of { (s1, s2) ->
 108     case (m1 dflags s1 genv loc mod warns)  of { (result1, warns1) ->
 109     case (m2 dflags s2 genv loc mod warns1) of { (result2, warns2) ->
 110     (combiner result1 result2, warns2) }}}
 111
 112 returnDs :: a -> DsM a
 113 returnDs result dflags us genv loc mod warns = (result, warns)
 114
 115 listDs :: [DsM a] -> DsM [a]
 116 listDs []     = returnDs []
 117 listDs (x:xs)
 118   = x           `thenDs` \ r  ->
 119     listDs xs   `thenDs` \ rs ->
 120     returnDs (r:rs)
 121
 122 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
 123
 124 mapDs f []     = returnDs []
 125 mapDs f (x:xs)
 126   = f x         `thenDs` \ r  ->
 127     mapDs f xs  `thenDs` \ rs ->
 128     returnDs (r:rs)
 129
 130 foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a
 131
 132 foldlDs k z []     = returnDs z
 133 foldlDs k z (x:xs) = k z x `thenDs` \ r ->
 134                      foldlDs k r xs
 135
 136 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 137
 138 mapAndUnzipDs f []     = returnDs ([], [])
 139 mapAndUnzipDs f (x:xs)
 140   = f x                 `thenDs` \ (r1, r2)  ->
 141     mapAndUnzipDs f xs  `thenDs` \ (rs1, rs2) ->
 142     returnDs (r1:rs1, r2:rs2)
 143
 144 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 145
 146 zipWithDs f []     ys = returnDs []
 147 zipWithDs f (x:xs) (y:ys)
 148   = f x y               `thenDs` \ r  ->
 149     zipWithDs f xs ys   `thenDs` \ rs ->
 150     returnDs (r:rs)
 151 \end{code}
 152
 153 And all this mysterious stuff is so we can occasionally reach out and
 154 grab one or more names.  @newLocalDs@ isn't exported---exported
 155 functions are defined with it.  The difference in name-strings makes
 156 it easier to read debugging output.
 157
 158 \begin{code}
 159 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 160 newSysLocalDs ty dflags us genv loc mod warns
 161   = case uniqFromSupply us of { assigned_uniq ->
 162     (mkSysLocal SLIT("ds") assigned_uniq ty, warns) }
 163
 164 newSysLocalsDs tys = mapDs newSysLocalDs tys
 165
 166 newFailLocalDs ty dflags us genv loc mod warns
 167   = case uniqFromSupply us of { assigned_uniq ->
 168     (mkSysLocal SLIT("fail") assigned_uniq ty, warns) }
 169         -- The UserLocal bit just helps make the code a little clearer
 170
 171 getUniqueDs :: DsM Unique
 172 getUniqueDs dflags us genv loc mod warns
 173   = case (uniqFromSupply us) of { assigned_uniq ->
 174     (assigned_uniq, warns) }
 175
 176 getDOptsDs :: DsM DynFlags
 177 getDOptsDs dflags us genv loc mod warns
 178   = (dflags, warns)
 179
 180 duplicateLocalDs :: Id -> DsM Id
 181 duplicateLocalDs old_local dflags us genv loc mod warns
 182   = case uniqFromSupply us of { assigned_uniq ->
 183     (setIdUnique old_local assigned_uniq, warns) }
 184
 185 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 186 cloneTyVarsDs tyvars dflags us genv loc mod warns
 187   = case uniqsFromSupply (length tyvars) us of { uniqs ->
 188     (zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) }
 189 \end{code}
 190
 191 \begin{code}
 192 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 193
 194 newTyVarsDs tyvar_tmpls dflags us genv loc mod warns
 195   = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
 196     (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
 197 \end{code}
 198
 199 We can also reach out and either set/grab location information from
 200 the @SrcLoc@ being carried around.
 201 \begin{code}
 202 uniqSMtoDsM :: UniqSM a -> DsM a
 203
 204 uniqSMtoDsM u_action dflags us genv loc mod warns
 205   = (initUs_ us u_action, warns)
 206
 207 getSrcLocDs :: DsM SrcLoc
 208 getSrcLocDs dflags us genv loc mod warns
 209   = (loc, warns)
 210
 211 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 212 putSrcLocDs new_loc expr dflags us genv old_loc mod warns
 213   = expr dflags us genv new_loc mod warns
 214
 215 dsWarn :: WarnMsg -> DsM ()
 216 dsWarn warn dflags us genv loc mod warns = ((), warns `snocBag` warn)
 217
 218 \end{code}
 219
 220 \begin{code}
 221 getModuleDs :: DsM Module
 222 getModuleDs dflags us genv loc mod warns = (mod, warns)
 223 \end{code}
 224
 225 \begin{code}
 226 dsLookupGlobalValue :: Name -> DsM Id
 227 dsLookupGlobalValue name dflags us genv loc mod warns
 228   = (genv name, warns)
 229 \end{code}
 230
 231
 232 %************************************************************************
 233 %*                                                                      *
 234 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
 235 %*                                                                      *
 236 %************************************************************************
 237
 238 \begin{code}
 239 data DsMatchContext
 240   = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
 241   | NoMatchContext
 242   deriving ()
 243
 244 data DsMatchKind
 245   = FunMatch Id
 246   | CaseMatch
 247   | LambdaMatch
 248   | PatBindMatch
 249   | DoBindMatch
 250   | ListCompMatch
 251   | LetMatch
 252   | RecUpdMatch
 253   deriving ()
 254 \end{code}