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, mappM, mapAndUnzipM,
   9         initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
  10         foldlDs, foldrDs,
  11
  12         newTyVarsDs, newLocalName,
  13         duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
  14         newFailLocalDs,
  15         getSrcSpanDs, putSrcSpanDs,
  16         getModuleDs,
  17         newUnique,
  18         UniqSupply, newUniqueSupply,
  19         getDOptsDs,
  20         dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
  21
  22         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
  23
  24         -- Warnings
  25         DsWarning, dsWarn,
  26
  27         -- Data types
  28         DsMatchContext(..),
  29         EquationInfo(..), MatchResult(..), DsWrapper, idWrapper,
  30         CanItFail(..), orFail
  31     ) where
  32
  33 #include "HsVersions.h"
  34
  35 import TcRnMonad
  36 import CoreSyn          ( CoreExpr )
  37 import HsSyn            ( HsExpr, HsMatchContext, Pat )
  38 import TcIface          ( tcIfaceGlobal )
  39 import RdrName          ( GlobalRdrEnv )
  40 import HscTypes         ( TyThing(..), TypeEnv, HscEnv,
  41                           tyThingId, tyThingTyCon, tyThingDataCon, unQualInScope )
  42 import Bag              ( emptyBag, snocBag, Bag )
  43 import DataCon          ( DataCon )
  44 import TyCon            ( TyCon )
  45 import Id               ( mkSysLocal, setIdUnique, Id )
  46 import Module           ( Module )
  47 import Var              ( TyVar, setTyVarUnique )
  48 import Outputable
  49 import SrcLoc           ( noSrcSpan, SrcSpan )
  50 import Type             ( Type )
  51 import UniqSupply       ( UniqSupply, uniqsFromSupply )
  52 import Name             ( Name, nameOccName )
  53 import NameEnv
  54 import OccName          ( occNameFS )
  55 import DynFlags ( DynFlags )
  56 import ErrUtils         ( WarnMsg, mkWarnMsg )
  57 import Bag              ( mapBag )
  58
  59 import DATA_IOREF       ( newIORef, readIORef )
  60
  61 infixr 9 `thenDs`
  62 \end{code}
  63
  64 %************************************************************************
  65 %*                                                                      *
  66                 Data types for the desugarer
  67 %*                                                                      *
  68 %************************************************************************
  69
  70 \begin{code}
  71 data DsMatchContext
  72   = DsMatchContext (HsMatchContext Name) SrcSpan
  73   | NoMatchContext
  74   deriving ()
  75
  76 data EquationInfo
  77   = EqnInfo { eqn_wrap :: DsWrapper,    -- Bindings
  78               eqn_pats :: [Pat Id],     -- The patterns for an eqn
  79               eqn_rhs  :: MatchResult } -- What to do after match
  80
  81 type DsWrapper = CoreExpr -> CoreExpr
  82 idWrapper e = e
  83
  84 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
  85 --      \fail. wrap (case vs of { pats -> rhs fail })
  86 -- where vs are not bound by wrap
  87
  88
  89 -- A MatchResult is an expression with a hole in it
  90 data MatchResult
  91   = MatchResult
  92         CanItFail       -- Tells whether the failure expression is used
  93         (CoreExpr -> DsM CoreExpr)
  94                         -- Takes a expression to plug in at the
  95                         -- failure point(s). The expression should
  96                         -- be duplicatable!
  97
  98 data CanItFail = CanFail | CantFail
  99
 100 orFail CantFail CantFail = CantFail
 101 orFail _        _        = CanFail
 102 \end{code}
 103
 104
 105 %************************************************************************
 106 %*                                                                      *
 107                 Monad stuff
 108 %*                                                                      *
 109 %************************************************************************
 110
 111 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
 112 a @UniqueSupply@ and some annotations, which
 113 presumably include source-file location information:
 114 \begin{code}
 115 type DsM result = TcRnIf DsGblEnv DsLclEnv result
 116
 117 -- Compatibility functions
 118 fixDs    = fixM
 119 thenDs   = thenM
 120 returnDs = returnM
 121 listDs   = sequenceM
 122 foldlDs  = foldlM
 123 foldrDs  = foldrM
 124 mapAndUnzipDs = mapAndUnzipM
 125
 126
 127 type DsWarning = (SrcSpan, SDoc)
 128         -- Not quite the same as a WarnMsg, we have an SDoc here
 129         -- and we'll do the print_unqual stuff later on to turn it
 130         -- into a Doc.
 131
 132 data DsGblEnv = DsGblEnv {
 133         ds_mod     :: Module,                   -- For SCC profiling
 134         ds_warns   :: IORef (Bag DsWarning),    -- Warning messages
 135         ds_if_env  :: (IfGblEnv, IfLclEnv)      -- Used for looking up global,
 136                                                 -- possibly-imported things
 137     }
 138
 139 data DsLclEnv = DsLclEnv {
 140         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
 141         ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
 142      }
 143
 144 -- Inside [| |] brackets, the desugarer looks
 145 -- up variables in the DsMetaEnv
 146 type DsMetaEnv = NameEnv DsMetaVal
 147
 148 data DsMetaVal
 149    = Bound Id           -- Bound by a pattern inside the [| |].
 150                         -- Will be dynamically alpha renamed.
 151                         -- The Id has type THSyntax.Var
 152
 153    | Splice (HsExpr Id) -- These bindings are introduced by
 154                         -- the PendingSplices on a HsBracketOut
 155
 156 -- initDs returns the UniqSupply out the end (not just the result)
 157
 158 initDs  :: HscEnv
 159         -> Module -> GlobalRdrEnv -> TypeEnv
 160         -> DsM a
 161         -> IO (a, Bag WarnMsg)
 162
 163 initDs hsc_env mod rdr_env type_env thing_inside
 164   = do  { warn_var <- newIORef emptyBag
 165         ; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
 166               ; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
 167               ; gbl_env = DsGblEnv { ds_mod = mod,
 168                                      ds_if_env = (if_genv, if_lenv),
 169                                      ds_warns = warn_var }
 170               ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
 171                                      ds_loc = noSrcSpan } }
 172
 173         ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
 174
 175         ; warns <- readIORef warn_var
 176         ; return (res, mapBag mk_warn warns)
 177         }
 178    where
 179     print_unqual = unQualInScope rdr_env
 180
 181     mk_warn :: (SrcSpan,SDoc) -> WarnMsg
 182     mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
 183 \end{code}
 184
 185 %************************************************************************
 186 %*                                                                      *
 187                 Operations in the monad
 188 %*                                                                      *
 189 %************************************************************************
 190
 191 And all this mysterious stuff is so we can occasionally reach out and
 192 grab one or more names.  @newLocalDs@ isn't exported---exported
 193 functions are defined with it.  The difference in name-strings makes
 194 it easier to read debugging output.
 195
 196 \begin{code}
 197 -- Make a new Id with the same print name, but different type, and new unique
 198 newUniqueId :: Name -> Type -> DsM Id
 199 newUniqueId id ty
 200   = newUnique   `thenDs` \ uniq ->
 201     returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
 202
 203 duplicateLocalDs :: Id -> DsM Id
 204 duplicateLocalDs old_local
 205   = newUnique   `thenDs` \ uniq ->
 206     returnDs (setIdUnique old_local uniq)
 207
 208 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 209 newSysLocalDs ty
 210   = newUnique   `thenDs` \ uniq ->
 211     returnDs (mkSysLocal FSLIT("ds") uniq ty)
 212
 213 newSysLocalsDs tys = mappM newSysLocalDs tys
 214
 215 newFailLocalDs ty
 216   = newUnique   `thenDs` \ uniq ->
 217     returnDs (mkSysLocal FSLIT("fail") uniq ty)
 218         -- The UserLocal bit just helps make the code a little clearer
 219 \end{code}
 220
 221 \begin{code}
 222 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 223 newTyVarsDs tyvar_tmpls
 224   = newUniqueSupply     `thenDs` \ uniqs ->
 225     returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
 226 \end{code}
 227
 228 We can also reach out and either set/grab location information from
 229 the @SrcSpan@ being carried around.
 230
 231 \begin{code}
 232 getDOptsDs :: DsM DynFlags
 233 getDOptsDs = getDOpts
 234
 235 getModuleDs :: DsM Module
 236 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
 237
 238 getSrcSpanDs :: DsM SrcSpan
 239 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 240
 241 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
 242 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 243
 244 dsWarn :: SDoc -> DsM ()
 245 dsWarn warn = do { env <- getGblEnv
 246                  ; loc <- getSrcSpanDs
 247                  ; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
 248             where
 249               msg = ptext SLIT("Warning:") <+> warn
 250 \end{code}
 251
 252 \begin{code}
 253 dsLookupGlobal :: Name -> DsM TyThing
 254 -- Very like TcEnv.tcLookupGlobal
 255 dsLookupGlobal name
 256   = do  { env <- getGblEnv
 257         ; setEnvs (ds_if_env env)
 258                   (tcIfaceGlobal name) }
 259
 260 dsLookupGlobalId :: Name -> DsM Id
 261 dsLookupGlobalId name
 262   = dsLookupGlobal name         `thenDs` \ thing ->
 263     returnDs (tyThingId thing)
 264
 265 dsLookupTyCon :: Name -> DsM TyCon
 266 dsLookupTyCon name
 267   = dsLookupGlobal name         `thenDs` \ thing ->
 268     returnDs (tyThingTyCon thing)
 269
 270 dsLookupDataCon :: Name -> DsM DataCon
 271 dsLookupDataCon name
 272   = dsLookupGlobal name         `thenDs` \ thing ->
 273     returnDs (tyThingDataCon thing)
 274 \end{code}
 275
 276 \begin{code}
 277 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 278 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 279
 280 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 281 dsExtendMetaEnv menv thing_inside
 282   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 283 \end{code}
 284
 285