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         dsLookupClass,
  24
  25         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
  26
  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 Class
  48 import Id
  49 import Module
  50 import Var
  51 import Outputable
  52 import SrcLoc
  53 import Type
  54 import UniqSupply
  55 import Name
  56 import NameEnv
  57 import OccName
  58 import DynFlags
  59 import ErrUtils
  60
  61 import Data.IORef
  62
  63 infixr 9 `thenDs`
  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 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 CantFail CantFail = CantFail
 102 orFail _        _        = CanFail
 103 \end{code}
 104
 105
 106 %************************************************************************
 107 %*                                                                      *
 108                 Monad stuff
 109 %*                                                                      *
 110 %************************************************************************
 111
 112 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
 113 a @UniqueSupply@ and some annotations, which
 114 presumably include source-file location information:
 115 \begin{code}
 116 type DsM result = TcRnIf DsGblEnv DsLclEnv result
 117
 118 -- Compatibility functions
 119 fixDs    = fixM
 120 thenDs   = thenM
 121 returnDs = returnM
 122 listDs   = sequenceM
 123 foldlDs  = foldlM
 124 foldrDs  = foldrM
 125 mapAndUnzipDs = mapAndUnzipM
 126
 127
 128 type DsWarning = (SrcSpan, SDoc)
 129         -- Not quite the same as a WarnMsg, we have an SDoc here
 130         -- and we'll do the print_unqual stuff later on to turn it
 131         -- into a Doc.
 132
 133 data DsGblEnv = DsGblEnv {
 134         ds_mod     :: Module,                   -- For SCC profiling
 135         ds_unqual  :: PrintUnqualified,
 136         ds_msgs    :: IORef Messages,           -- Warning messages
 137         ds_if_env  :: (IfGblEnv, IfLclEnv)      -- Used for looking up global,
 138                                                 -- possibly-imported things
 139     }
 140
 141 data DsLclEnv = DsLclEnv {
 142         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
 143         ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
 144      }
 145
 146 -- Inside [| |] brackets, the desugarer looks
 147 -- up variables in the DsMetaEnv
 148 type DsMetaEnv = NameEnv DsMetaVal
 149
 150 data DsMetaVal
 151    = Bound Id           -- Bound by a pattern inside the [| |].
 152                         -- Will be dynamically alpha renamed.
 153                         -- The Id has type THSyntax.Var
 154
 155    | Splice (HsExpr Id) -- These bindings are introduced by
 156                         -- the PendingSplices on a HsBracketOut
 157
 158 initDs  :: HscEnv
 159         -> Module -> GlobalRdrEnv -> TypeEnv
 160         -> DsM a
 161         -> IO (Maybe a)
 162 -- Print errors and warnings, if any arise
 163
 164 initDs hsc_env mod rdr_env type_env thing_inside
 165   = do  { msg_var <- newIORef (emptyBag, emptyBag)
 166         ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var
 167
 168         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
 169                         tryM thing_inside       -- Catch exceptions (= errors during desugaring)
 170
 171         -- Display any errors and warnings
 172         -- Note: if -Werror is used, we don't signal an error here.
 173         ; let dflags = hsc_dflags hsc_env
 174         ; msgs <- readIORef msg_var
 175         ; printErrorsAndWarnings dflags msgs
 176
 177         ; let final_res | errorsFound dflags msgs = Nothing
 178                         | otherwise = case either_res of
 179                                         Right res -> Just res
 180                                         Left exn -> pprPanic "initDs" (text (show exn))
 181                 -- The (Left exn) case happens when the thing_inside throws
 182                 -- a UserError exception.  Then it should have put an error
 183                 -- message in msg_var, so we just discard the exception
 184
 185         ; return final_res }
 186
 187 initDsTc :: DsM a -> TcM a
 188 initDsTc thing_inside
 189   = do  { this_mod <- getModule
 190         ; tcg_env  <- getGblEnv
 191         ; msg_var  <- getErrsVar
 192         ; let type_env = tcg_type_env tcg_env
 193               rdr_env  = tcg_rdr_env tcg_env
 194         ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var
 195         ; setEnvs ds_envs thing_inside }
 196
 197 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
 198 mkDsEnvs mod rdr_env type_env msg_var
 199   = do
 200        sites_var <- newIORef []
 201        let     if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
 202                if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
 203                gbl_env = DsGblEnv { ds_mod = mod,
 204                                     ds_if_env = (if_genv, if_lenv),
 205                                     ds_unqual = mkPrintUnqualified rdr_env,
 206                                     ds_msgs = msg_var}
 207                lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
 208                                     ds_loc = noSrcSpan }
 209
 210        return (gbl_env, lcl_env)
 211
 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
 320 dsLookupClass :: Name -> DsM Class
 321 dsLookupClass name
 322   = dsLookupGlobal name         `thenDs` \ thing ->
 323     returnDs (tyThingClass thing)
 324 \end{code}
 325
 326 \begin{code}
 327 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 328 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 329
 330 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 331 dsExtendMetaEnv menv thing_inside
 332   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 333 \end{code}