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