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