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