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