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, mapM, mapAndUnzipM,
  11         initDs, initDsTc, fixDs,
  12         foldlM, foldrM, ifOptM,
  13         Applicative(..),(<$>),
  14
  15         newTyVarsDs, newLocalName,
  16         duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
  17         newFailLocalDs,
  18         getSrcSpanDs, putSrcSpanDs,
  19         getModuleDs,
  20         newUnique,
  21         UniqSupply, newUniqueSupply,
  22         getDOptsDs, getGhcModeDs, doptDs,
  23         dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
  24         dsLookupClass,
  25
  26         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
  27
  28         -- Warnings
  29         DsWarning, warnDs, failWithDs,
  30
  31         -- Data types
  32         DsMatchContext(..),
  33         EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
  34         CanItFail(..), orFail
  35     ) where
  36
  37 #include "HsVersions.h"
  38
  39 import TcRnMonad
  40 import CoreSyn
  41 import HsSyn
  42 import TcIface
  43 import RdrName
  44 import HscTypes
  45 import Bag
  46 import DataCon
  47 import TyCon
  48 import Class
  49 import Id
  50 import Module
  51 import Var
  52 import Outputable
  53 import SrcLoc
  54 import Type
  55 import UniqSupply
  56 import Name
  57 import NameEnv
  58 import OccName
  59 import DynFlags
  60 import ErrUtils
  61 import MonadUtils
  62 import FastString
  63
  64 import Data.IORef
  65 \end{code}
  66
  67 %************************************************************************
  68 %*                                                                      *
  69                 Data types for the desugarer
  70 %*                                                                      *
  71 %************************************************************************
  72
  73 \begin{code}
  74 data DsMatchContext
  75   = DsMatchContext (HsMatchContext Name) SrcSpan
  76   | NoMatchContext
  77   deriving ()
  78
  79 data EquationInfo
  80   = EqnInfo { eqn_pats :: [Pat Id],     -- The patterns for an eqn
  81               eqn_rhs  :: MatchResult } -- What to do after match
  82
  83 type DsWrapper = CoreExpr -> CoreExpr
  84 idDsWrapper :: DsWrapper
  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 :: CanItFail -> CanItFail -> CanItFail
 104 orFail CantFail CantFail = CantFail
 105 orFail _        _        = CanFail
 106 \end{code}
 107
 108
 109 %************************************************************************
 110 %*                                                                      *
 111                 Monad stuff
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
 116 a @UniqueSupply@ and some annotations, which
 117 presumably include source-file location information:
 118 \begin{code}
 119 type DsM result = TcRnIf DsGblEnv DsLclEnv result
 120
 121 -- Compatibility functions
 122 fixDs :: (a -> DsM a) -> DsM a
 123 fixDs    = fixM
 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 dflags = hsc_dflags hsc_env
 164         ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags 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         ; 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         ; dflags   <- getDOpts
 190         ; let type_env = tcg_type_env tcg_env
 191               rdr_env  = tcg_rdr_env tcg_env
 192         ; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var
 193         ; setEnvs ds_envs thing_inside }
 194
 195 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
 196 mkDsEnvs dflags mod rdr_env type_env msg_var
 197   = do -- TODO: unnecessarily monadic
 198        let     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 dflags rdr_env,
 203                                     ds_msgs = msg_var}
 204                lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
 205                                     ds_loc = noSrcSpan }
 206
 207        return (gbl_env, lcl_env)
 208
 209 \end{code}
 210
 211 %************************************************************************
 212 %*                                                                      *
 213                 Operations in the monad
 214 %*                                                                      *
 215 %************************************************************************
 216
 217 And all this mysterious stuff is so we can occasionally reach out and
 218 grab one or more names.  @newLocalDs@ isn't exported---exported
 219 functions are defined with it.  The difference in name-strings makes
 220 it easier to read debugging output.
 221
 222 \begin{code}
 223 -- Make a new Id with the same print name, but different type, and new unique
 224 newUniqueId :: Name -> Type -> DsM Id
 225 newUniqueId id ty = do
 226     uniq <- newUnique
 227     return (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
 228
 229 duplicateLocalDs :: Id -> DsM Id
 230 duplicateLocalDs old_local = do
 231     uniq <- newUnique
 232     return (setIdUnique old_local uniq)
 233
 234 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 235 newSysLocalDs ty = do
 236     uniq <- newUnique
 237     return (mkSysLocal FSLIT("ds") uniq ty)
 238
 239 newSysLocalsDs :: [Type] -> DsM [Id]
 240 newSysLocalsDs tys = mapM newSysLocalDs tys
 241
 242 newFailLocalDs ty = do
 243     uniq <- newUnique
 244     return (mkSysLocal FSLIT("fail") uniq ty)
 245         -- The UserLocal bit just helps make the code a little clearer
 246 \end{code}
 247
 248 \begin{code}
 249 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 250 newTyVarsDs tyvar_tmpls = do
 251     uniqs <- newUniqueSupply
 252     return (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
 253 \end{code}
 254
 255 We can also reach out and either set/grab location information from
 256 the @SrcSpan@ being carried around.
 257
 258 \begin{code}
 259 getDOptsDs :: DsM DynFlags
 260 getDOptsDs = getDOpts
 261
 262 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
 263 doptDs = doptM
 264
 265 getGhcModeDs :: DsM GhcMode
 266 getGhcModeDs =  getDOptsDs >>= return . ghcMode
 267
 268 getModuleDs :: DsM Module
 269 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
 270
 271 getSrcSpanDs :: DsM SrcSpan
 272 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 273
 274 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
 275 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 276
 277 warnDs :: SDoc -> DsM ()
 278 warnDs warn = do { env <- getGblEnv
 279                  ; loc <- getSrcSpanDs
 280                  ; let msg = mkWarnMsg loc (ds_unqual env)
 281                                       (ptext SLIT("Warning:") <+> warn)
 282                  ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
 283             where
 284
 285 failWithDs :: SDoc -> DsM a
 286 failWithDs err
 287   = do  { env <- getGblEnv
 288         ; loc <- getSrcSpanDs
 289         ; let msg = mkErrMsg loc (ds_unqual env) err
 290         ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
 291         ; failM }
 292         where
 293 \end{code}
 294
 295 \begin{code}
 296 dsLookupGlobal :: Name -> DsM TyThing
 297 -- Very like TcEnv.tcLookupGlobal
 298 dsLookupGlobal name
 299   = do  { env <- getGblEnv
 300         ; setEnvs (ds_if_env env)
 301                   (tcIfaceGlobal name) }
 302
 303 dsLookupGlobalId :: Name -> DsM Id
 304 dsLookupGlobalId name
 305   = tyThingId <$> dsLookupGlobal name
 306
 307 dsLookupTyCon :: Name -> DsM TyCon
 308 dsLookupTyCon name
 309   = tyThingTyCon <$> dsLookupGlobal name
 310
 311 dsLookupDataCon :: Name -> DsM DataCon
 312 dsLookupDataCon name
 313   = tyThingDataCon <$> dsLookupGlobal name
 314
 315 dsLookupClass :: Name -> DsM Class
 316 dsLookupClass name
 317   = tyThingClass <$> dsLookupGlobal name
 318 \end{code}
 319
 320 \begin{code}
 321 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 322 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 323
 324 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 325 dsExtendMetaEnv menv thing_inside
 326   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 327 \end{code}