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_GHC -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/WorkingConventions#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         ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var
 174
 175         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
 176                         tryM thing_inside       -- Catch exceptions (= errors during desugaring)
 177
 178         -- Display any errors and warnings
 179         -- Note: if -Werror is used, we don't signal an error here.
 180         ; let dflags = hsc_dflags hsc_env
 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         ; let type_env = tcg_type_env tcg_env
 200               rdr_env  = tcg_rdr_env tcg_env
 201         ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var
 202         ; setEnvs ds_envs thing_inside }
 203
 204 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
 205 mkDsEnvs mod rdr_env type_env msg_var
 206   = do
 207        sites_var <- newIORef []
 208        let     if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
 209                if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
 210                gbl_env = DsGblEnv { ds_mod = mod,
 211                                     ds_if_env = (if_genv, if_lenv),
 212                                     ds_unqual = mkPrintUnqualified rdr_env,
 213                                     ds_msgs = msg_var}
 214                lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
 215                                     ds_loc = noSrcSpan }
 216
 217        return (gbl_env, lcl_env)
 218
 219 \end{code}
 220
 221 %************************************************************************
 222 %*                                                                      *
 223                 Operations in the monad
 224 %*                                                                      *
 225 %************************************************************************
 226
 227 And all this mysterious stuff is so we can occasionally reach out and
 228 grab one or more names.  @newLocalDs@ isn't exported---exported
 229 functions are defined with it.  The difference in name-strings makes
 230 it easier to read debugging output.
 231
 232 \begin{code}
 233 -- Make a new Id with the same print name, but different type, and new unique
 234 newUniqueId :: Name -> Type -> DsM Id
 235 newUniqueId id ty
 236   = newUnique   `thenDs` \ uniq ->
 237     returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
 238
 239 duplicateLocalDs :: Id -> DsM Id
 240 duplicateLocalDs old_local
 241   = newUnique   `thenDs` \ uniq ->
 242     returnDs (setIdUnique old_local uniq)
 243
 244 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 245 newSysLocalDs ty
 246   = newUnique   `thenDs` \ uniq ->
 247     returnDs (mkSysLocal FSLIT("ds") uniq ty)
 248
 249 newSysLocalsDs tys = mappM newSysLocalDs tys
 250
 251 newFailLocalDs ty
 252   = newUnique   `thenDs` \ uniq ->
 253     returnDs (mkSysLocal FSLIT("fail") uniq ty)
 254         -- The UserLocal bit just helps make the code a little clearer
 255 \end{code}
 256
 257 \begin{code}
 258 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 259 newTyVarsDs tyvar_tmpls
 260   = newUniqueSupply     `thenDs` \ uniqs ->
 261     returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
 262 \end{code}
 263
 264 We can also reach out and either set/grab location information from
 265 the @SrcSpan@ being carried around.
 266
 267 \begin{code}
 268 getDOptsDs :: DsM DynFlags
 269 getDOptsDs = getDOpts
 270
 271 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
 272 doptDs = doptM
 273
 274 getGhcModeDs :: DsM GhcMode
 275 getGhcModeDs =  getDOptsDs >>= return . ghcMode
 276
 277 getModuleDs :: DsM Module
 278 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
 279
 280 getSrcSpanDs :: DsM SrcSpan
 281 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 282
 283 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
 284 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 285
 286 warnDs :: SDoc -> DsM ()
 287 warnDs warn = do { env <- getGblEnv
 288                  ; loc <- getSrcSpanDs
 289                  ; let msg = mkWarnMsg loc (ds_unqual env)
 290                                       (ptext SLIT("Warning:") <+> warn)
 291                  ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
 292             where
 293
 294 failWithDs :: SDoc -> DsM a
 295 failWithDs err
 296   = do  { env <- getGblEnv
 297         ; loc <- getSrcSpanDs
 298         ; let msg = mkErrMsg loc (ds_unqual env) err
 299         ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
 300         ; failM }
 301         where
 302 \end{code}
 303
 304 \begin{code}
 305 dsLookupGlobal :: Name -> DsM TyThing
 306 -- Very like TcEnv.tcLookupGlobal
 307 dsLookupGlobal name
 308   = do  { env <- getGblEnv
 309         ; setEnvs (ds_if_env env)
 310                   (tcIfaceGlobal name) }
 311
 312 dsLookupGlobalId :: Name -> DsM Id
 313 dsLookupGlobalId name
 314   = dsLookupGlobal name         `thenDs` \ thing ->
 315     returnDs (tyThingId thing)
 316
 317 dsLookupTyCon :: Name -> DsM TyCon
 318 dsLookupTyCon name
 319   = dsLookupGlobal name         `thenDs` \ thing ->
 320     returnDs (tyThingTyCon thing)
 321
 322 dsLookupDataCon :: Name -> DsM DataCon
 323 dsLookupDataCon name
 324   = dsLookupGlobal name         `thenDs` \ thing ->
 325     returnDs (tyThingDataCon thing)
 326
 327 dsLookupClass :: Name -> DsM Class
 328 dsLookupClass name
 329   = dsLookupGlobal name         `thenDs` \ thing ->
 330     returnDs (tyThingClass thing)
 331 \end{code}
 332
 333 \begin{code}
 334 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 335 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 336
 337 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 338 dsExtendMetaEnv menv thing_inside
 339   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 340 \end{code}