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         -- Warnings
  27         DsWarning, warnDs, failWithDs,
  28
  29         -- Data types
  30         DsMatchContext(..),
  31         EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
  32         CanItFail(..), orFail
  33     ) where
  34
  35 #include "HsVersions.h"
  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 Id
  47 import Module
  48 import Var
  49 import Outputable
  50 import SrcLoc
  51 import Type
  52 import UniqSupply
  53 import Name
  54 import NameEnv
  55 import OccName
  56 import DynFlags
  57 import ErrUtils
  58
  59 import Data.IORef
  60
  61 infixr 9 `thenDs`
  62 \end{code}
  63
  64 %************************************************************************
  65 %*                                                                      *
  66                 Data types for the desugarer
  67 %*                                                                      *
  68 %************************************************************************
  69
  70 \begin{code}
  71 data DsMatchContext
  72   = DsMatchContext (HsMatchContext Name) SrcSpan
  73   | NoMatchContext
  74   deriving ()
  75
  76 data EquationInfo
  77   = EqnInfo { eqn_pats :: [Pat Id],     -- The patterns for an eqn
  78               eqn_rhs  :: MatchResult } -- What to do after match
  79
  80 type DsWrapper = CoreExpr -> CoreExpr
  81 idDsWrapper e = e
  82
  83 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
  84 --      \fail. wrap (case vs of { pats -> rhs fail })
  85 -- where vs are not bound by wrap
  86
  87
  88 -- A MatchResult is an expression with a hole in it
  89 data MatchResult
  90   = MatchResult
  91         CanItFail       -- Tells whether the failure expression is used
  92         (CoreExpr -> DsM CoreExpr)
  93                         -- Takes a expression to plug in at the
  94                         -- failure point(s). The expression should
  95                         -- be duplicatable!
  96
  97 data CanItFail = CanFail | CantFail
  98
  99 orFail CantFail CantFail = CantFail
 100 orFail _        _        = CanFail
 101 \end{code}
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106                 Monad stuff
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
 111 a @UniqueSupply@ and some annotations, which
 112 presumably include source-file location information:
 113 \begin{code}
 114 type DsM result = TcRnIf DsGblEnv DsLclEnv result
 115
 116 -- Compatibility functions
 117 fixDs    = fixM
 118 thenDs   = thenM
 119 returnDs = returnM
 120 listDs   = sequenceM
 121 foldlDs  = foldlM
 122 foldrDs  = foldrM
 123 mapAndUnzipDs = mapAndUnzipM
 124
 125
 126 type DsWarning = (SrcSpan, SDoc)
 127         -- Not quite the same as a WarnMsg, we have an SDoc here
 128         -- and we'll do the print_unqual stuff later on to turn it
 129         -- into a Doc.
 130
 131 data DsGblEnv = DsGblEnv {
 132         ds_mod     :: Module,                   -- For SCC profiling
 133         ds_unqual  :: PrintUnqualified,
 134         ds_msgs    :: IORef Messages,           -- Warning messages
 135         ds_if_env  :: (IfGblEnv, IfLclEnv)      -- Used for looking up global,
 136                                                 -- possibly-imported things
 137     }
 138
 139 data DsLclEnv = DsLclEnv {
 140         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
 141         ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
 142      }
 143
 144 -- Inside [| |] brackets, the desugarer looks
 145 -- up variables in the DsMetaEnv
 146 type DsMetaEnv = NameEnv DsMetaVal
 147
 148 data DsMetaVal
 149    = Bound Id           -- Bound by a pattern inside the [| |].
 150                         -- Will be dynamically alpha renamed.
 151                         -- The Id has type THSyntax.Var
 152
 153    | Splice (HsExpr Id) -- These bindings are introduced by
 154                         -- the PendingSplices on a HsBracketOut
 155
 156 initDs  :: HscEnv
 157         -> Module -> GlobalRdrEnv -> TypeEnv
 158         -> DsM a
 159         -> IO (Maybe a)
 160 -- Print errors and warnings, if any arise
 161
 162 initDs hsc_env mod rdr_env type_env thing_inside
 163   = do  { msg_var <- newIORef (emptyBag, emptyBag)
 164         ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs 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         ; let dflags = hsc_dflags hsc_env
 172         ; msgs <- readIORef msg_var
 173         ; printErrorsAndWarnings dflags msgs
 174
 175         ; let final_res | errorsFound dflags msgs = Nothing
 176                         | otherwise = case either_res of
 177                                         Right res -> Just res
 178                                         Left exn -> pprPanic "initDs" (text (show exn))
 179                 -- The (Left exn) case happens when the thing_inside throws
 180                 -- a UserError exception.  Then it should have put an error
 181                 -- message in msg_var, so we just discard the exception
 182
 183         ; return final_res }
 184
 185 initDsTc :: DsM a -> TcM a
 186 initDsTc thing_inside
 187   = do  { this_mod <- getModule
 188         ; tcg_env  <- getGblEnv
 189         ; msg_var  <- getErrsVar
 190         ; let type_env = tcg_type_env tcg_env
 191               rdr_env  = tcg_rdr_env tcg_env
 192         ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var
 193         ; setEnvs ds_envs thing_inside }
 194
 195 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
 196 mkDsEnvs mod rdr_env type_env msg_var
 197   = do
 198        sites_var <- newIORef []
 199        let     if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
 200                if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
 201                gbl_env = DsGblEnv { ds_mod = mod,
 202                                     ds_if_env = (if_genv, if_lenv),
 203                                     ds_unqual = mkPrintUnqualified rdr_env,
 204                                     ds_msgs = msg_var}
 205                lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
 206                                     ds_loc = noSrcSpan }
 207
 208        return (gbl_env, lcl_env)
 209
 210 \end{code}
 211
 212 %************************************************************************
 213 %*                                                                      *
 214                 Operations in the monad
 215 %*                                                                      *
 216 %************************************************************************
 217
 218 And all this mysterious stuff is so we can occasionally reach out and
 219 grab one or more names.  @newLocalDs@ isn't exported---exported
 220 functions are defined with it.  The difference in name-strings makes
 221 it easier to read debugging output.
 222
 223 \begin{code}
 224 -- Make a new Id with the same print name, but different type, and new unique
 225 newUniqueId :: Name -> Type -> DsM Id
 226 newUniqueId id ty
 227   = newUnique   `thenDs` \ uniq ->
 228     returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
 229
 230 duplicateLocalDs :: Id -> DsM Id
 231 duplicateLocalDs old_local
 232   = newUnique   `thenDs` \ uniq ->
 233     returnDs (setIdUnique old_local uniq)
 234
 235 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 236 newSysLocalDs ty
 237   = newUnique   `thenDs` \ uniq ->
 238     returnDs (mkSysLocal FSLIT("ds") uniq ty)
 239
 240 newSysLocalsDs tys = mappM newSysLocalDs tys
 241
 242 newFailLocalDs ty
 243   = newUnique   `thenDs` \ uniq ->
 244     returnDs (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
 251   = newUniqueSupply     `thenDs` \ uniqs ->
 252     returnDs (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   = dsLookupGlobal name         `thenDs` \ thing ->
 306     returnDs (tyThingId thing)
 307
 308 dsLookupTyCon :: Name -> DsM TyCon
 309 dsLookupTyCon name
 310   = dsLookupGlobal name         `thenDs` \ thing ->
 311     returnDs (tyThingTyCon thing)
 312
 313 dsLookupDataCon :: Name -> DsM DataCon
 314 dsLookupDataCon name
 315   = dsLookupGlobal name         `thenDs` \ thing ->
 316     returnDs (tyThingDataCon thing)
 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}