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