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