diff options
Diffstat (limited to 'compiler/deSugar/DsMonad.lhs')
| -rw-r--r-- | compiler/deSugar/DsMonad.lhs | 285 |
1 files changed, 285 insertions, 0 deletions
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs new file mode 100644 index 0000000000..f24dee4905 --- /dev/null +++ b/compiler/deSugar/DsMonad.lhs @@ -0,0 +1,285 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[DsMonad]{@DsMonad@: monadery used in desugaring} + +\begin{code} +module DsMonad ( + DsM, mappM, mapAndUnzipM, + initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, + foldlDs, foldrDs, + + newTyVarsDs, newLocalName, + duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, + newFailLocalDs, + getSrcSpanDs, putSrcSpanDs, + getModuleDs, + newUnique, + UniqSupply, newUniqueSupply, + getDOptsDs, + dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, + + DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, + + -- Warnings + DsWarning, dsWarn, + + -- Data types + DsMatchContext(..), + EquationInfo(..), MatchResult(..), DsWrapper, idWrapper, + CanItFail(..), orFail + ) where + +#include "HsVersions.h" + +import TcRnMonad +import CoreSyn ( CoreExpr ) +import HsSyn ( HsExpr, HsMatchContext, Pat ) +import TcIface ( tcIfaceGlobal ) +import RdrName ( GlobalRdrEnv ) +import HscTypes ( TyThing(..), TypeEnv, HscEnv, + tyThingId, tyThingTyCon, tyThingDataCon, unQualInScope ) +import Bag ( emptyBag, snocBag, Bag ) +import DataCon ( DataCon ) +import TyCon ( TyCon ) +import Id ( mkSysLocal, setIdUnique, Id ) +import Module ( Module ) +import Var ( TyVar, setTyVarUnique ) +import Outputable +import SrcLoc ( noSrcSpan, SrcSpan ) +import Type ( Type ) +import UniqSupply ( UniqSupply, uniqsFromSupply ) +import Name ( Name, nameOccName ) +import NameEnv +import OccName ( occNameFS ) +import DynFlags ( DynFlags ) +import ErrUtils ( WarnMsg, mkWarnMsg ) +import Bag ( mapBag ) + +import DATA_IOREF ( newIORef, readIORef ) + +infixr 9 `thenDs` +\end{code} + +%************************************************************************ +%* * + Data types for the desugarer +%* * +%************************************************************************ + +\begin{code} +data DsMatchContext + = DsMatchContext (HsMatchContext Name) SrcSpan + | NoMatchContext + deriving () + +data EquationInfo + = EqnInfo { eqn_wrap :: DsWrapper, -- Bindings + eqn_pats :: [Pat Id], -- The patterns for an eqn + eqn_rhs :: MatchResult } -- What to do after match + +type DsWrapper = CoreExpr -> CoreExpr +idWrapper e = e + +-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult +-- \fail. wrap (case vs of { pats -> rhs fail }) +-- where vs are not bound by wrap + + +-- A MatchResult is an expression with a hole in it +data MatchResult + = MatchResult + CanItFail -- Tells whether the failure expression is used + (CoreExpr -> DsM CoreExpr) + -- Takes a expression to plug in at the + -- failure point(s). The expression should + -- be duplicatable! + +data CanItFail = CanFail | CantFail + +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 + +-- Compatibility functions +fixDs = fixM +thenDs = thenM +returnDs = returnM +listDs = sequenceM +foldlDs = foldlM +foldrDs = foldrM +mapAndUnzipDs = mapAndUnzipM + + +type DsWarning = (SrcSpan, SDoc) + -- Not quite the same as a WarnMsg, we have an SDoc here + -- and we'll do the print_unqual stuff later on to turn it + -- into a Doc. + +data DsGblEnv = DsGblEnv { + ds_mod :: Module, -- For SCC profiling + ds_warns :: IORef (Bag DsWarning), -- Warning messages + ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, + -- possibly-imported things + } + +data DsLclEnv = DsLclEnv { + ds_meta :: DsMetaEnv, -- Template Haskell bindings + ds_loc :: SrcSpan -- to put in pattern-matching error msgs + } + +-- Inside [| |] brackets, the desugarer looks +-- up variables in the DsMetaEnv +type DsMetaEnv = NameEnv DsMetaVal + +data DsMetaVal + = Bound Id -- Bound by a pattern inside the [| |]. + -- Will be dynamically alpha renamed. + -- The Id has type THSyntax.Var + + | Splice (HsExpr Id) -- These bindings are introduced by + -- the PendingSplices on a HsBracketOut + +-- initDs returns the UniqSupply out the end (not just the result) + +initDs :: HscEnv + -> Module -> GlobalRdrEnv -> TypeEnv + -> DsM a + -> IO (a, Bag WarnMsg) + +initDs hsc_env mod rdr_env type_env thing_inside + = do { warn_var <- newIORef emptyBag + ; 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_warns = warn_var } + ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv, + ds_loc = noSrcSpan } } + + ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside + + ; warns <- readIORef warn_var + ; return (res, mapBag mk_warn warns) + } + where + print_unqual = unQualInScope rdr_env + + mk_warn :: (SrcSpan,SDoc) -> WarnMsg + mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc +\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} +-- Make a new Id with the same print name, but different type, and new unique +newUniqueId :: Name -> Type -> DsM Id +newUniqueId id ty + = newUnique `thenDs` \ uniq -> + returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty) + +duplicateLocalDs :: Id -> DsM Id +duplicateLocalDs old_local + = newUnique `thenDs` \ uniq -> + returnDs (setIdUnique old_local uniq) + +newSysLocalDs, newFailLocalDs :: Type -> DsM Id +newSysLocalDs ty + = newUnique `thenDs` \ uniq -> + returnDs (mkSysLocal FSLIT("ds") uniq ty) + +newSysLocalsDs tys = mappM newSysLocalDs tys + +newFailLocalDs ty + = newUnique `thenDs` \ uniq -> + returnDs (mkSysLocal FSLIT("fail") uniq ty) + -- The UserLocal bit just helps make the code a little clearer +\end{code} + +\begin{code} +newTyVarsDs :: [TyVar] -> DsM [TyVar] +newTyVarsDs tyvar_tmpls + = newUniqueSupply `thenDs` \ uniqs -> + returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs)) +\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 + +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 + +dsWarn :: SDoc -> DsM () +dsWarn warn = do { env <- getGblEnv + ; loc <- getSrcSpanDs + ; updMutVar (ds_warns env) (`snocBag` (loc,msg)) } + where + msg = ptext SLIT("Warning:") <+> warn +\end{code} + +\begin{code} +dsLookupGlobal :: Name -> DsM TyThing +-- Very like TcEnv.tcLookupGlobal +dsLookupGlobal name + = do { env <- getGblEnv + ; setEnvs (ds_if_env env) + (tcIfaceGlobal name) } + +dsLookupGlobalId :: Name -> DsM Id +dsLookupGlobalId name + = dsLookupGlobal name `thenDs` \ thing -> + returnDs (tyThingId thing) + +dsLookupTyCon :: Name -> DsM TyCon +dsLookupTyCon name + = dsLookupGlobal name `thenDs` \ thing -> + returnDs (tyThingTyCon thing) + +dsLookupDataCon :: Name -> DsM DataCon +dsLookupDataCon name + = dsLookupGlobal name `thenDs` \ thing -> + returnDs (tyThingDataCon thing) +\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} + + |