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, initDsTc, 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, warnDs, failWithDs,
  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, mkPrintUnqualified )
  42 import Bag              ( emptyBag, snocBag )
  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         ( Messages, mkWarnMsg, mkErrMsg,
  57                           printErrorsAndWarnings, errorsFound )
  58 import DATA_IOREF       ( newIORef, readIORef )
  59
  60 infixr 9 `thenDs`
  61 \end{code}
  62
  63 %************************************************************************
  64 %*                                                                      *
  65                 Data types for the desugarer
  66 %*                                                                      *
  67 %************************************************************************
  68
  69 \begin{code}
  70 data DsMatchContext
  71   = DsMatchContext (HsMatchContext Name) SrcSpan
  72   | NoMatchContext
  73   deriving ()
  74
  75 data EquationInfo
  76   = EqnInfo { eqn_wrap :: DsWrapper,    -- Bindings
  77               eqn_pats :: [Pat Id],     -- The patterns for an eqn
  78               eqn_rhs  :: MatchResult } -- What to do after match
  79
  80 type DsWrapper = CoreExpr -> CoreExpr
  81 idWrapper e = e
  82
  83 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
  84 --      \fail. wrap (case vs of { pats -> rhs fail })
  85 -- where vs are not bound by wrap
  86
  87
  88 -- A MatchResult is an expression with a hole in it
  89 data MatchResult
  90   = MatchResult
  91         CanItFail       -- Tells whether the failure expression is used
  92         (CoreExpr -> DsM CoreExpr)
  93                         -- Takes a expression to plug in at the
  94                         -- failure point(s). The expression should
  95                         -- be duplicatable!
  96
  97 data CanItFail = CanFail | CantFail
  98
  99 orFail CantFail CantFail = CantFail
 100 orFail _        _        = CanFail
 101 \end{code}
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106                 Monad stuff
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
 111 a @UniqueSupply@ and some annotations, which
 112 presumably include source-file location information:
 113 \begin{code}
 114 type DsM result = TcRnIf DsGblEnv DsLclEnv result
 115
 116 -- Compatibility functions
 117 fixDs    = fixM
 118 thenDs   = thenM
 119 returnDs = returnM
 120 listDs   = sequenceM
 121 foldlDs  = foldlM
 122 foldrDs  = foldrM
 123 mapAndUnzipDs = mapAndUnzipM
 124
 125
 126 type DsWarning = (SrcSpan, SDoc)
 127         -- Not quite the same as a WarnMsg, we have an SDoc here
 128         -- and we'll do the print_unqual stuff later on to turn it
 129         -- into a Doc.
 130
 131 data DsGblEnv = DsGblEnv {
 132         ds_mod     :: Module,                   -- For SCC profiling
 133         ds_unqual  :: PrintUnqualified,
 134         ds_msgs    :: IORef Messages,           -- 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  :: HscEnv
 157         -> Module -> GlobalRdrEnv -> TypeEnv
 158         -> DsM a
 159         -> IO (Maybe a)
 160 -- Print errors and warnings, if any arise
 161
 162 initDs hsc_env mod rdr_env type_env thing_inside
 163   = do  { msg_var <- newIORef (emptyBag, emptyBag)
 164         ; let (ds_gbl_env, ds_lcl_env) = mkDsEnvs mod rdr_env type_env msg_var
 165
 166         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
 167                         tryM thing_inside       -- Catch exceptions (= errors during desugaring)
 168
 169         -- Display any errors and warnings
 170         -- Note: if -Werror is used, we don't signal an error here.
 171         ; let dflags = hsc_dflags hsc_env
 172         ; msgs <- readIORef msg_var
 173         ; printErrorsAndWarnings dflags msgs
 174
 175         ; let final_res | errorsFound dflags msgs = Nothing
 176                         | otherwise = case either_res of
 177                                         Right res -> Just res
 178                                         Left exn -> pprPanic "initDs" (text (show exn))
 179                 -- The (Left exn) case happens when the thing_inside throws
 180                 -- a UserError exception.  Then it should have put an error
 181                 -- message in msg_var, so we just discard the exception
 182
 183         ; return final_res }
 184
 185 initDsTc :: DsM a -> TcM a
 186 initDsTc thing_inside
 187   = do  { this_mod <- getModule
 188         ; tcg_env  <- getGblEnv
 189         ; msg_var  <- getErrsVar
 190         ; let type_env = tcg_type_env tcg_env
 191               rdr_env  = tcg_rdr_env tcg_env
 192         ; setEnvs (mkDsEnvs this_mod rdr_env type_env msg_var) thing_inside }
 193
 194 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv
 195          -> IORef Messages -> (DsGblEnv, DsLclEnv)
 196 mkDsEnvs mod rdr_env type_env msg_var
 197   = (gbl_env, lcl_env)
 198   where
 199     if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
 200     if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
 201     gbl_env = DsGblEnv { ds_mod = mod,
 202                          ds_if_env = (if_genv, if_lenv),
 203                          ds_unqual = mkPrintUnqualified rdr_env,
 204                          ds_msgs = msg_var }
 205     lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
 206                          ds_loc = noSrcSpan }
 207 \end{code}
 208
 209 %************************************************************************
 210 %*                                                                      *
 211                 Operations in the monad
 212 %*                                                                      *
 213 %************************************************************************
 214
 215 And all this mysterious stuff is so we can occasionally reach out and
 216 grab one or more names.  @newLocalDs@ isn't exported---exported
 217 functions are defined with it.  The difference in name-strings makes
 218 it easier to read debugging output.
 219
 220 \begin{code}
 221 -- Make a new Id with the same print name, but different type, and new unique
 222 newUniqueId :: Name -> Type -> DsM Id
 223 newUniqueId id ty
 224   = newUnique   `thenDs` \ uniq ->
 225     returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
 226
 227 duplicateLocalDs :: Id -> DsM Id
 228 duplicateLocalDs old_local
 229   = newUnique   `thenDs` \ uniq ->
 230     returnDs (setIdUnique old_local uniq)
 231
 232 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 233 newSysLocalDs ty
 234   = newUnique   `thenDs` \ uniq ->
 235     returnDs (mkSysLocal FSLIT("ds") uniq ty)
 236
 237 newSysLocalsDs tys = mappM newSysLocalDs tys
 238
 239 newFailLocalDs ty
 240   = newUnique   `thenDs` \ uniq ->
 241     returnDs (mkSysLocal FSLIT("fail") uniq ty)
 242         -- The UserLocal bit just helps make the code a little clearer
 243 \end{code}
 244
 245 \begin{code}
 246 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 247 newTyVarsDs tyvar_tmpls
 248   = newUniqueSupply     `thenDs` \ uniqs ->
 249     returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
 250 \end{code}
 251
 252 We can also reach out and either set/grab location information from
 253 the @SrcSpan@ being carried around.
 254
 255 \begin{code}
 256 getDOptsDs :: DsM DynFlags
 257 getDOptsDs = getDOpts
 258
 259 getModuleDs :: DsM Module
 260 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
 261
 262 getSrcSpanDs :: DsM SrcSpan
 263 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 264
 265 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
 266 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 267
 268 warnDs :: SDoc -> DsM ()
 269 warnDs warn = do { env <- getGblEnv
 270                  ; loc <- getSrcSpanDs
 271                  ; let msg = mkWarnMsg loc (ds_unqual env)
 272                                       (ptext SLIT("Warning:") <+> warn)
 273                  ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
 274             where
 275
 276 failWithDs :: SDoc -> DsM a
 277 failWithDs err
 278   = do  { env <- getGblEnv
 279         ; loc <- getSrcSpanDs
 280         ; let msg = mkErrMsg loc (ds_unqual env) err
 281         ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
 282         ; failM }
 283         where
 284 \end{code}
 285
 286 \begin{code}
 287 dsLookupGlobal :: Name -> DsM TyThing
 288 -- Very like TcEnv.tcLookupGlobal
 289 dsLookupGlobal name
 290   = do  { env <- getGblEnv
 291         ; setEnvs (ds_if_env env)
 292                   (tcIfaceGlobal name) }
 293
 294 dsLookupGlobalId :: Name -> DsM Id
 295 dsLookupGlobalId name
 296   = dsLookupGlobal name         `thenDs` \ thing ->
 297     returnDs (tyThingId thing)
 298
 299 dsLookupTyCon :: Name -> DsM TyCon
 300 dsLookupTyCon name
 301   = dsLookupGlobal name         `thenDs` \ thing ->
 302     returnDs (tyThingTyCon thing)
 303
 304 dsLookupDataCon :: Name -> DsM DataCon
 305 dsLookupDataCon name
 306   = dsLookupGlobal name         `thenDs` \ thing ->
 307     returnDs (tyThingDataCon thing)
 308 \end{code}
 309
 310 \begin{code}
 311 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 312 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 313
 314 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 315 dsExtendMetaEnv menv thing_inside
 316   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 317 \end{code}
 318
 319