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