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, mapM, mapAndUnzipM,
  18         initDs, initDsTc, fixDs, mapAndUnzipM,
  19         foldlM, foldrM, ifOptM,
  20         Applicative(..),(<$>),
  21
  22         newTyVarsDs, newLocalName,
  23         duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
  24         newFailLocalDs,
  25         getSrcSpanDs, putSrcSpanDs,
  26         getModuleDs,
  27         newUnique,
  28         UniqSupply, newUniqueSupply,
  29         getDOptsDs, getGhcModeDs, doptDs,
  30         dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
  31         dsLookupClass,
  32
  33         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
  34
  35         -- Warnings
  36         DsWarning, warnDs, failWithDs,
  37
  38         -- Data types
  39         DsMatchContext(..),
  40         EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
  41         CanItFail(..), orFail
  42     ) where
  43
  44 #include "HsVersions.h"
  45
  46 import TcRnMonad
  47 import CoreSyn
  48 import HsSyn
  49 import TcIface
  50 import RdrName
  51 import HscTypes
  52 import Bag
  53 import DataCon
  54 import TyCon
  55 import Class
  56 import Id
  57 import Module
  58 import Var
  59 import Outputable
  60 import SrcLoc
  61 import Type
  62 import UniqSupply
  63 import Name
  64 import NameEnv
  65 import OccName
  66 import DynFlags
  67 import ErrUtils
  68 import MonadUtils
  69
  70 import Data.IORef
  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
 128 type DsWarning = (SrcSpan, SDoc)
 129         -- Not quite the same as a WarnMsg, we have an SDoc here
 130         -- and we'll do the print_unqual stuff later on to turn it
 131         -- into a Doc.
 132
 133 data DsGblEnv = DsGblEnv {
 134         ds_mod     :: Module,                   -- For SCC profiling
 135         ds_unqual  :: PrintUnqualified,
 136         ds_msgs    :: IORef Messages,           -- Warning messages
 137         ds_if_env  :: (IfGblEnv, IfLclEnv)      -- Used for looking up global,
 138                                                 -- possibly-imported things
 139     }
 140
 141 data DsLclEnv = DsLclEnv {
 142         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
 143         ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
 144      }
 145
 146 -- Inside [| |] brackets, the desugarer looks
 147 -- up variables in the DsMetaEnv
 148 type DsMetaEnv = NameEnv DsMetaVal
 149
 150 data DsMetaVal
 151    = Bound Id           -- Bound by a pattern inside the [| |].
 152                         -- Will be dynamically alpha renamed.
 153                         -- The Id has type THSyntax.Var
 154
 155    | Splice (HsExpr Id) -- These bindings are introduced by
 156                         -- the PendingSplices on a HsBracketOut
 157
 158 initDs  :: HscEnv
 159         -> Module -> GlobalRdrEnv -> TypeEnv
 160         -> DsM a
 161         -> IO (Maybe a)
 162 -- Print errors and warnings, if any arise
 163
 164 initDs hsc_env mod rdr_env type_env thing_inside
 165   = do  { msg_var <- newIORef (emptyBag, emptyBag)
 166         ; let dflags = hsc_dflags hsc_env
 167         ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var
 168
 169         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
 170                         tryM thing_inside       -- Catch exceptions (= errors during desugaring)
 171
 172         -- Display any errors and warnings
 173         -- Note: if -Werror is used, we don't signal an error here.
 174         ; msgs <- readIORef msg_var
 175         ; printErrorsAndWarnings dflags msgs
 176
 177         ; let final_res | errorsFound dflags msgs = Nothing
 178                         | otherwise = case either_res of
 179                                         Right res -> Just res
 180                                         Left exn -> pprPanic "initDs" (text (show exn))
 181                 -- The (Left exn) case happens when the thing_inside throws
 182                 -- a UserError exception.  Then it should have put an error
 183                 -- message in msg_var, so we just discard the exception
 184
 185         ; return final_res }
 186
 187 initDsTc :: DsM a -> TcM a
 188 initDsTc thing_inside
 189   = do  { this_mod <- getModule
 190         ; tcg_env  <- getGblEnv
 191         ; msg_var  <- getErrsVar
 192         ; dflags   <- getDOpts
 193         ; let type_env = tcg_type_env tcg_env
 194               rdr_env  = tcg_rdr_env tcg_env
 195         ; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var
 196         ; setEnvs ds_envs thing_inside }
 197
 198 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
 199 mkDsEnvs dflags mod rdr_env type_env msg_var
 200   = do
 201        sites_var <- newIORef []
 202        let     if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
 203                if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
 204                gbl_env = DsGblEnv { ds_mod = mod,
 205                                     ds_if_env = (if_genv, if_lenv),
 206                                     ds_unqual = mkPrintUnqualified dflags rdr_env,
 207                                     ds_msgs = msg_var}
 208                lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
 209                                     ds_loc = noSrcSpan }
 210
 211        return (gbl_env, lcl_env)
 212
 213 \end{code}
 214
 215 %************************************************************************
 216 %*                                                                      *
 217                 Operations in the monad
 218 %*                                                                      *
 219 %************************************************************************
 220
 221 And all this mysterious stuff is so we can occasionally reach out and
 222 grab one or more names.  @newLocalDs@ isn't exported---exported
 223 functions are defined with it.  The difference in name-strings makes
 224 it easier to read debugging output.
 225
 226 \begin{code}
 227 -- Make a new Id with the same print name, but different type, and new unique
 228 newUniqueId :: Name -> Type -> DsM Id
 229 newUniqueId id ty = do
 230     uniq <- newUnique
 231     return (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
 232
 233 duplicateLocalDs :: Id -> DsM Id
 234 duplicateLocalDs old_local = do
 235     uniq <- newUnique
 236     return (setIdUnique old_local uniq)
 237
 238 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 239 newSysLocalDs ty = do
 240     uniq <- newUnique
 241     return (mkSysLocal FSLIT("ds") uniq ty)
 242
 243 newSysLocalsDs tys = mapM newSysLocalDs tys
 244
 245 newFailLocalDs ty = do
 246     uniq <- newUnique
 247     return (mkSysLocal FSLIT("fail") uniq ty)
 248         -- The UserLocal bit just helps make the code a little clearer
 249 \end{code}
 250
 251 \begin{code}
 252 newTyVarsDs :: [TyVar] -> DsM [TyVar]
 253 newTyVarsDs tyvar_tmpls = do
 254     uniqs <- newUniqueSupply
 255     return (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
 256 \end{code}
 257
 258 We can also reach out and either set/grab location information from
 259 the @SrcSpan@ being carried around.
 260
 261 \begin{code}
 262 getDOptsDs :: DsM DynFlags
 263 getDOptsDs = getDOpts
 264
 265 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
 266 doptDs = doptM
 267
 268 getGhcModeDs :: DsM GhcMode
 269 getGhcModeDs =  getDOptsDs >>= return . ghcMode
 270
 271 getModuleDs :: DsM Module
 272 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
 273
 274 getSrcSpanDs :: DsM SrcSpan
 275 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 276
 277 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
 278 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 279
 280 warnDs :: SDoc -> DsM ()
 281 warnDs warn = do { env <- getGblEnv
 282                  ; loc <- getSrcSpanDs
 283                  ; let msg = mkWarnMsg loc (ds_unqual env)
 284                                       (ptext SLIT("Warning:") <+> warn)
 285                  ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
 286             where
 287
 288 failWithDs :: SDoc -> DsM a
 289 failWithDs err
 290   = do  { env <- getGblEnv
 291         ; loc <- getSrcSpanDs
 292         ; let msg = mkErrMsg loc (ds_unqual env) err
 293         ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
 294         ; failM }
 295         where
 296 \end{code}
 297
 298 \begin{code}
 299 dsLookupGlobal :: Name -> DsM TyThing
 300 -- Very like TcEnv.tcLookupGlobal
 301 dsLookupGlobal name
 302   = do  { env <- getGblEnv
 303         ; setEnvs (ds_if_env env)
 304                   (tcIfaceGlobal name) }
 305
 306 dsLookupGlobalId :: Name -> DsM Id
 307 dsLookupGlobalId name
 308   = tyThingId <$> dsLookupGlobal name
 309
 310 dsLookupTyCon :: Name -> DsM TyCon
 311 dsLookupTyCon name
 312   = tyThingTyCon <$> dsLookupGlobal name
 313
 314 dsLookupDataCon :: Name -> DsM DataCon
 315 dsLookupDataCon name
 316   = tyThingDataCon <$> dsLookupGlobal name
 317
 318 dsLookupClass :: Name -> DsM Class
 319 dsLookupClass name
 320   = tyThingClass <$> dsLookupGlobal name
 321 \end{code}
 322
 323 \begin{code}
 324 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 325 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 326
 327 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 328 dsExtendMetaEnv menv thing_inside
 329   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 330 \end{code}