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