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