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, mapDs, listDs,
  10         mapAndUnzipDs, zipWithDs, foldlDs,
  11         uniqSMtoDsM,
  12         newTyVarsDs, cloneTyVarsDs,
  13         duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
  14         newFailLocalDs,
  15         getSrcLocDs, putSrcLocDs,
  16         getModuleDs,
  17         getUniqueDs, getUniquesDs,
  18         getDOptsDs,
  19         dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
  20
  21         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
  22
  23         dsWarn,
  24         DsWarnings,
  25         DsMatchContext(..)
  26     ) where
  27
  28 #include "HsVersions.h"
  29
  30 import TcHsSyn          ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
  31 import HscTypes         ( TyThing(..) )
  32 import Bag              ( emptyBag, snocBag, Bag )
  33 import TyCon            ( TyCon )
  34 import Id               ( mkSysLocal, setIdUnique, Id )
  35 import Module           ( Module )
  36 import Var              ( TyVar, setTyVarUnique )
  37 import Outputable
  38 import SrcLoc           ( noSrcLoc, SrcLoc )
  39 import Type             ( Type )
  40 import UniqSupply       ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs,
  41                           UniqSM, UniqSupply )
  42 import Unique           ( Unique )
  43 import Name             ( Name, nameOccName )
  44 import NameEnv
  45 import OccName          ( occNameFS )
  46 import CmdLineOpts      ( DynFlags )
  47
  48 infixr 9 `thenDs`
  49 \end{code}
  50
  51 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
  52 a @UniqueSupply@ and some annotations, which
  53 presumably include source-file location information:
  54 \begin{code}
  55 newtype DsM result
  56   = DsM (DsEnv -> DsWarnings -> UniqSM (result, DsWarnings))
  57
  58 unDsM (DsM x) = x
  59
  60 data DsEnv = DsEnv {
  61         ds_dflags :: DynFlags,
  62         ds_globals :: Name -> TyThing,  -- Lookup well-known Ids
  63         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
  64         ds_loc     :: SrcLoc,           -- to put in pattern-matching error msgs
  65         ds_mod     :: Module            -- module: for SCC profiling
  66      }
  67
  68 -- Inside [| |] brackets, the desugarer looks
  69 -- up variables in the DsMetaEnv
  70 type DsMetaEnv = NameEnv DsMetaVal
  71
  72 data DsMetaVal
  73    = Bound Id           -- Bound by a pattern inside the [| |].
  74                         -- Will be dynamically alpha renamed.
  75                         -- The Id has type String
  76
  77    | Splice TypecheckedHsExpr   -- These bindings are introduced by
  78                                 -- the PendingSplices on a HsBracketOut
  79
  80 instance Monad DsM where
  81   return = returnDs
  82   (>>=)  = thenDs
  83
  84 type DsWarnings = Bag DsWarning         -- The desugarer reports matches which are
  85                                         -- completely shadowed or incomplete patterns
  86 type DsWarning = (SrcLoc, SDoc)
  87
  88 {-# INLINE thenDs #-}
  89 {-# INLINE returnDs #-}
  90
  91 -- initDs returns the UniqSupply out the end (not just the result)
  92
  93 initDs  :: DynFlags
  94         -> UniqSupply
  95         -> (Name -> TyThing)
  96         -> Module   -- module name: for profiling
  97         -> DsM a
  98         -> (a, DsWarnings)
  99
 100 initDs dflags init_us lookup mod (DsM action)
 101   = initUs_ init_us (action ds_env emptyBag)
 102   where
 103     ds_env = DsEnv { ds_dflags = dflags, ds_globals = lookup,
 104                      ds_loc = noSrcLoc, ds_mod = mod,
 105                      ds_meta = emptyNameEnv }
 106
 107 thenDs :: DsM a -> (a -> DsM b) -> DsM b
 108
 109 thenDs (DsM m1) m2 = DsM( \ env warns ->
 110     m1 env warns        `thenUs` \ (result, warns1) ->
 111     unDsM (m2 result) env warns1)
 112
 113 returnDs :: a -> DsM a
 114 returnDs result = DsM (\ env warns -> returnUs (result, warns))
 115
 116 listDs :: [DsM a] -> DsM [a]
 117 listDs []     = returnDs []
 118 listDs (x:xs)
 119   = x           `thenDs` \ r  ->
 120     listDs xs   `thenDs` \ rs ->
 121     returnDs (r:rs)
 122
 123 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
 124
 125 mapDs f []     = returnDs []
 126 mapDs f (x:xs)
 127   = f x         `thenDs` \ r  ->
 128     mapDs f xs  `thenDs` \ rs ->
 129     returnDs (r:rs)
 130
 131 foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a
 132
 133 foldlDs k z []     = returnDs z
 134 foldlDs k z (x:xs) = k z x `thenDs` \ r ->
 135                      foldlDs k r xs
 136
 137 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
 138
 139 mapAndUnzipDs f []     = returnDs ([], [])
 140 mapAndUnzipDs f (x:xs)
 141   = f x                 `thenDs` \ (r1, r2)  ->
 142     mapAndUnzipDs f xs  `thenDs` \ (rs1, rs2) ->
 143     returnDs (r1:rs1, r2:rs2)
 144
 145 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
 146
 147 zipWithDs f []     ys = returnDs []
 148 zipWithDs f (x:xs) (y:ys)
 149   = f x y               `thenDs` \ r  ->
 150     zipWithDs f xs ys   `thenDs` \ rs ->
 151     returnDs (r:rs)
 152 \end{code}
 153
 154 And all this mysterious stuff is so we can occasionally reach out and
 155 grab one or more names.  @newLocalDs@ isn't exported---exported
 156 functions are defined with it.  The difference in name-strings makes
 157 it easier to read debugging output.
 158
 159 \begin{code}
 160 uniqSMtoDsM :: UniqSM a -> DsM a
 161 uniqSMtoDsM u_action = DsM(\ env warns ->
 162         u_action        `thenUs` \ res ->
 163         returnUs (res, warns))
 164
 165
 166 getUniqueDs :: DsM Unique
 167 getUniqueDs = DsM (\ env warns ->
 168     getUniqueUs         `thenUs` \ uniq ->
 169     returnUs (uniq, warns))
 170
 171 getUniquesDs :: DsM [Unique]
 172 getUniquesDs = DsM(\ env warns ->
 173     getUniquesUs                `thenUs` \ uniqs ->
 174     returnUs (uniqs, warns))
 175
 176 -- Make a new Id with the same print name, but different type, and new unique
 177 newUniqueId :: Name -> Type -> DsM Id
 178 newUniqueId id ty
 179   = getUniqueDs         `thenDs` \ uniq ->
 180     returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
 181
 182 duplicateLocalDs :: Id -> DsM Id
 183 duplicateLocalDs old_local
 184   = getUniqueDs         `thenDs` \ uniq ->
 185     returnDs (setIdUnique old_local uniq)
 186
 187 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 188 newSysLocalDs ty
 189   = getUniqueDs         `thenDs` \ uniq ->
 190     returnDs (mkSysLocal FSLIT("ds") uniq ty)
 191
 192 newSysLocalsDs tys = mapDs newSysLocalDs tys
 193
 194 newFailLocalDs ty
 195   = getUniqueDs         `thenDs` \ uniq ->
 196     returnDs (mkSysLocal FSLIT("fail") uniq ty)
 197         -- The UserLocal bit just helps make the code a little clearer
 198 \end{code}
 199
 200 \begin{code}
 201 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
 202 cloneTyVarsDs tyvars
 203   = getUniquesDs        `thenDs` \ uniqs ->
 204     returnDs (zipWith setTyVarUnique tyvars uniqs)
 205
 206 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 207 newTyVarsDs tyvar_tmpls
 208   = getUniquesDs        `thenDs` \ uniqs ->
 209     returnDs (zipWith setTyVarUnique tyvar_tmpls uniqs)
 210 \end{code}
 211
 212 We can also reach out and either set/grab location information from
 213 the @SrcLoc@ being carried around.
 214
 215 \begin{code}
 216 getDOptsDs :: DsM DynFlags
 217 getDOptsDs = DsM(\ env warns -> returnUs (ds_dflags env, warns))
 218
 219 getModuleDs :: DsM Module
 220 getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns))
 221
 222 getSrcLocDs :: DsM SrcLoc
 223 getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns))
 224
 225 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
 226 putSrcLocDs new_loc (DsM expr) = DsM(\ env warns ->
 227     expr (env { ds_loc = new_loc }) warns)
 228
 229 dsWarn :: DsWarning -> DsM ()
 230 dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn))
 231 \end{code}
 232
 233 \begin{code}
 234 dsLookupGlobal :: Name -> DsM TyThing
 235 dsLookupGlobal name
 236   = DsM(\ env warns -> returnUs (ds_globals env name, warns))
 237
 238 dsLookupGlobalId :: Name -> DsM Id
 239 dsLookupGlobalId name
 240   = dsLookupGlobal name         `thenDs` \ thing ->
 241     returnDs (get_id name thing)
 242
 243 dsLookupTyCon :: Name -> DsM TyCon
 244 dsLookupTyCon name
 245   = dsLookupGlobal name         `thenDs` \ thing ->
 246     returnDs (get_tycon name thing)
 247
 248 get_id name (AnId id) = id
 249 get_id name other     = pprPanic "dsLookupGlobalId" (ppr name)
 250
 251 get_tycon name (ATyCon tc) = tc
 252 get_tycon name other       = pprPanic "dsLookupTyCon" (ppr name)
 253 \end{code}
 254
 255 \begin{code}
 256 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 257 dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns))
 258
 259 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 260 dsExtendMetaEnv menv (DsM m)
 261   = DsM (\ env warns -> m (env { ds_meta = ds_meta env `plusNameEnv` menv }) warns)
 262 \end{code}
 263
 264
 265 %************************************************************************
 266 %*                                                                      *
 267 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
 268 %*                                                                      *
 269 %************************************************************************
 270
 271 \begin{code}
 272 data DsMatchContext
 273   = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
 274   | NoMatchContext
 275   deriving ()
 276 \end{code}