compiler/deSugar/DsMonad.lhs

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