%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
@DsMonad@: monadery used in desugaring
\begin{code}
module DsMonad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, fixDs,
foldlM, foldrM, ifDOptM, unsetOptM,
Applicative(..),(<$>),
newLocalName,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
newFailLocalDs, newPredVarDs,
getSrcSpanDs, putSrcSpanDs,
getModuleDs,
newUnique,
UniqSupply, newUniqueSupply,
getDOptsDs, getGhcModeDs, doptDs,
dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
dsLookupClass,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
dsLoadModule,
DsWarning, warnDs, failWithDs,
DsMatchContext(..),
EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
CanItFail(..), orFail
) where
import TcRnMonad
import CoreSyn
import HsSyn
import TcIface
import LoadIface
import RdrName
import HscTypes
import Bag
import DataCon
import TyCon
import Class
import Id
import Module
import Var
import Outputable
import SrcLoc
import Type
import UniqSupply
import Name
import NameEnv
import DynFlags
import ErrUtils
import FastString
import Data.IORef
\end{code}
%************************************************************************
%* *
Data types for the desugarer
%* *
%************************************************************************
\begin{code}
data DsMatchContext
= DsMatchContext (HsMatchContext Name) SrcSpan
deriving ()
data EquationInfo
= EqnInfo { eqn_pats :: [Pat Id],
eqn_rhs :: MatchResult }
instance Outputable EquationInfo where
ppr (EqnInfo pats _) = ppr pats
type DsWrapper = CoreExpr -> CoreExpr
idDsWrapper :: DsWrapper
idDsWrapper e = e
data MatchResult
= MatchResult
CanItFail
(CoreExpr -> DsM CoreExpr)
data CanItFail = CanFail | CantFail
orFail :: CanItFail -> CanItFail -> CanItFail
orFail CantFail CantFail = CantFail
orFail _ _ = CanFail
\end{code}
%************************************************************************
%* *
Monad stuff
%* *
%************************************************************************
Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
a @UniqueSupply@ and some annotations, which
presumably include source-file location information:
\begin{code}
type DsM result = TcRnIf DsGblEnv DsLclEnv result
fixDs :: (a -> DsM a) -> DsM a
fixDs = fixM
type DsWarning = (SrcSpan, SDoc)
data DsGblEnv = DsGblEnv {
ds_mod :: Module,
ds_unqual :: PrintUnqualified,
ds_msgs :: IORef Messages,
ds_if_env :: (IfGblEnv, IfLclEnv)
}
data DsLclEnv = DsLclEnv {
ds_meta :: DsMetaEnv,
ds_loc :: SrcSpan
}
type DsMetaEnv = NameEnv DsMetaVal
data DsMetaVal
= Bound Id
| Splice (HsExpr Id)
initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> DsM a
-> IO (Messages, Maybe a)
initDs hsc_env mod rdr_env type_env thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag)
; let dflags = hsc_dflags hsc_env
; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
tryM thing_inside
; msgs <- readIORef msg_var
; let final_res | errorsFound dflags msgs = Nothing
| otherwise = case either_res of
Right res -> Just res
Left exn -> pprPanic "initDs" (text (show exn))
; return (msgs, final_res) }
initDsTc :: DsM a -> TcM a
initDsTc thing_inside
= do { this_mod <- getModule
; tcg_env <- getGblEnv
; msg_var <- getErrsVar
; dflags <- getDOpts
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var
; setEnvs ds_envs thing_inside }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env msg_var
= do
let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
gbl_env = DsGblEnv { ds_mod = mod,
ds_if_env = (if_genv, if_lenv),
ds_unqual = mkPrintUnqualified dflags rdr_env,
ds_msgs = msg_var}
lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
ds_loc = noSrcSpan }
return (gbl_env, lcl_env)
\end{code}
%************************************************************************
%* *
Operations in the monad
%* *
%************************************************************************
And all this mysterious stuff is so we can occasionally reach out and
grab one or more names. @newLocalDs@ isn't exported---exported
functions are defined with it. The difference in name-strings makes
it easier to read debugging output.
\begin{code}
newUniqueId :: Id -> Type -> DsM Id
newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
duplicateLocalDs :: Id -> DsM Id
duplicateLocalDs old_local
= do { uniq <- newUnique
; return (setIdUnique old_local uniq) }
newPredVarDs :: PredType -> DsM Var
newPredVarDs pred
| isEqPred pred
= do { uniq <- newUnique;
; let name = mkSystemName uniq (mkOccNameFS tcName (fsLit "co_pv"))
kind = mkPredTy pred
; return (mkCoVar name kind) }
| otherwise
= newSysLocalDs (mkPredTy pred)
newSysLocalDs, newFailLocalDs :: Type -> DsM Id
newSysLocalDs = mkSysLocalM (fsLit "ds")
newFailLocalDs = mkSysLocalM (fsLit "fail")
newSysLocalsDs :: [Type] -> DsM [Id]
newSysLocalsDs tys = mapM newSysLocalDs tys
\end{code}
We can also reach out and either set/grab location information from
the @SrcSpan@ being carried around.
\begin{code}
getDOptsDs :: DsM DynFlags
getDOptsDs = getDOpts
doptDs :: DynFlag -> TcRnIf gbl lcl Bool
doptDs = doptM
getGhcModeDs :: DsM GhcMode
getGhcModeDs = getDOptsDs >>= return . ghcMode
getModuleDs :: DsM Module
getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
warnDs :: SDoc -> DsM ()
warnDs warn = do { env <- getGblEnv
; loc <- getSrcSpanDs
; let msg = mkWarnMsg loc (ds_unqual env)
(ptext (sLit "Warning:") <+> warn)
; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
failWithDs :: SDoc -> DsM a
failWithDs err
= do { env <- getGblEnv
; loc <- getSrcSpanDs
; let msg = mkErrMsg loc (ds_unqual env) err
; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
; failM }
\end{code}
\begin{code}
instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
lookupThing = dsLookupGlobal
dsLookupGlobal :: Name -> DsM TyThing
dsLookupGlobal name
= do { env <- getGblEnv
; setEnvs (ds_if_env env)
(tcIfaceGlobal name) }
dsLookupGlobalId :: Name -> DsM Id
dsLookupGlobalId name
= tyThingId <$> dsLookupGlobal name
dsLookupTyCon :: Name -> DsM TyCon
dsLookupTyCon name
= tyThingTyCon <$> dsLookupGlobal name
dsLookupDataCon :: Name -> DsM DataCon
dsLookupDataCon name
= tyThingDataCon <$> dsLookupGlobal name
dsLookupClass :: Name -> DsM Class
dsLookupClass name
= tyThingClass <$> dsLookupGlobal name
\end{code}
\begin{code}
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv menv thing_inside
= updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
\end{code}
\begin{code}
dsLoadModule :: SDoc -> Module -> DsM ()
dsLoadModule doc mod
= do { env <- getGblEnv
; setEnvs (ds_if_env env)
(loadSysInterface doc mod >> return ())
}
\end{code}