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