X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=f24dee4905257e0dbb16c1c0a4f45fc4e697eca0;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=088910904967ecfc28f44181dcc776e1e243ddf0;hpb=16e4ce4c0c02650082f2e11982017c903c549ad5;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 0889109..f24dee4 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -5,67 +5,140 @@ \begin{code} module DsMonad ( - DsM, - initDs, returnDs, thenDs, mapDs, listDs, fixDs, - mapAndUnzipDs, zipWithDs, foldlDs, - uniqSMtoDsM, - newTyVarsDs, cloneTyVarsDs, + DsM, mappM, mapAndUnzipM, + initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, + foldlDs, foldrDs, + + newTyVarsDs, newLocalName, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, newFailLocalDs, - getSrcLocDs, putSrcLocDs, + getSrcSpanDs, putSrcSpanDs, getModuleDs, - getUniqueDs, getUniquesDs, - UniqSupply, getUniqSupplyDs, + newUnique, + UniqSupply, newUniqueSupply, getDOptsDs, dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, - dsWarn, - DsWarnings, - DsMatchContext(..) + -- Warnings + DsWarning, dsWarn, + + -- Data types + DsMatchContext(..), + EquationInfo(..), MatchResult(..), DsWrapper, idWrapper, + CanItFail(..), orFail ) where #include "HsVersions.h" -import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr ) -import HscTypes ( TyThing(..) ) +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 DataCon ( DataCon ) import Id ( mkSysLocal, setIdUnique, Id ) import Module ( Module ) import Var ( TyVar, setTyVarUnique ) import Outputable -import SrcLoc ( noSrcLoc, SrcLoc ) +import SrcLoc ( noSrcSpan, SrcSpan ) import Type ( Type ) -import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs, - fixUs, UniqSM, UniqSupply, getUs ) -import Unique ( Unique ) +import UniqSupply ( UniqSupply, uniqsFromSupply ) import Name ( Name, nameOccName ) import NameEnv import OccName ( occNameFS ) -import CmdLineOpts ( DynFlags ) +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} -newtype DsM result - = DsM (DsEnv -> DsWarnings -> UniqSM (result, DsWarnings)) - -unDsM (DsM x) = x - -data DsEnv = DsEnv { - ds_dflags :: DynFlags, - ds_globals :: Name -> TyThing, -- Lookup well-known Ids +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 :: SrcLoc, -- to put in pattern-matching error msgs - ds_mod :: Module -- module: for SCC profiling + ds_loc :: SrcSpan -- to put in pattern-matching error msgs } -- Inside [| |] brackets, the desugarer looks @@ -75,218 +148,138 @@ type DsMetaEnv = NameEnv DsMetaVal data DsMetaVal = Bound Id -- Bound by a pattern inside the [| |]. -- Will be dynamically alpha renamed. - -- The Id has type String - - | Splice TypecheckedHsExpr -- These bindings are introduced by - -- the PendingSplices on a HsBracketOut - -instance Monad DsM where - return = returnDs - (>>=) = thenDs + -- The Id has type THSyntax.Var -type DsWarnings = Bag DsWarning -- The desugarer reports matches which are - -- completely shadowed or incomplete patterns -type DsWarning = (SrcLoc, SDoc) - -{-# INLINE thenDs #-} -{-# INLINE returnDs #-} + | 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 :: DynFlags - -> UniqSupply - -> (Name -> TyThing) - -> Module -- module name: for profiling +initDs :: HscEnv + -> Module -> GlobalRdrEnv -> TypeEnv -> DsM a - -> (a, DsWarnings) - -initDs dflags init_us lookup mod (DsM action) - = initUs_ init_us (action ds_env emptyBag) - where - ds_env = DsEnv { ds_dflags = dflags, ds_globals = lookup, - ds_loc = noSrcLoc, ds_mod = mod, - ds_meta = emptyNameEnv } - -thenDs :: DsM a -> (a -> DsM b) -> DsM b - -thenDs (DsM m1) m2 = DsM( \ env warns -> - m1 env warns `thenUs` \ (result, warns1) -> - unDsM (m2 result) env warns1) - -returnDs :: a -> DsM a -returnDs result = DsM (\ env warns -> returnUs (result, warns)) - -fixDs :: (a -> DsM a) -> DsM a -fixDs f = DsM (\env warns -> fixUs (\ ~(a, _warns') -> unDsM (f a) env warns)) - -listDs :: [DsM a] -> DsM [a] -listDs [] = returnDs [] -listDs (x:xs) - = x `thenDs` \ r -> - listDs xs `thenDs` \ rs -> - returnDs (r:rs) - -mapDs :: (a -> DsM b) -> [a] -> DsM [b] - -mapDs f [] = returnDs [] -mapDs f (x:xs) - = f x `thenDs` \ r -> - mapDs f xs `thenDs` \ rs -> - returnDs (r:rs) - -foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a - -foldlDs k z [] = returnDs z -foldlDs k z (x:xs) = k z x `thenDs` \ r -> - foldlDs k r xs - -mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c]) - -mapAndUnzipDs f [] = returnDs ([], []) -mapAndUnzipDs f (x:xs) - = f x `thenDs` \ (r1, r2) -> - mapAndUnzipDs f xs `thenDs` \ (rs1, rs2) -> - returnDs (r1:rs1, r2:rs2) - -zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c] - -zipWithDs f [] ys = returnDs [] -zipWithDs f (x:xs) (y:ys) - = f x y `thenDs` \ r -> - zipWithDs f xs ys `thenDs` \ rs -> - returnDs (r:rs) + -> 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} -uniqSMtoDsM :: UniqSM a -> DsM a -uniqSMtoDsM u_action = DsM(\ env warns -> - u_action `thenUs` \ res -> - returnUs (res, warns)) - - -getUniqueDs :: DsM Unique -getUniqueDs = DsM (\ env warns -> - getUniqueUs `thenUs` \ uniq -> - returnUs (uniq, warns)) - -getUniquesDs :: DsM [Unique] -getUniquesDs = DsM(\ env warns -> - getUniquesUs `thenUs` \ uniqs -> - returnUs (uniqs, warns)) - -getUniqSupplyDs :: DsM UniqSupply -getUniqSupplyDs = DsM(\ env warns -> - getUs `thenUs` \ uniqs -> - returnUs (uniqs, warns)) - -- Make a new Id with the same print name, but different type, and new unique newUniqueId :: Name -> Type -> DsM Id newUniqueId id ty - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty) duplicateLocalDs :: Id -> DsM Id duplicateLocalDs old_local - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (setIdUnique old_local uniq) newSysLocalDs, newFailLocalDs :: Type -> DsM Id newSysLocalDs ty - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (mkSysLocal FSLIT("ds") uniq ty) -newSysLocalsDs tys = mapDs newSysLocalDs tys +newSysLocalsDs tys = mappM newSysLocalDs tys newFailLocalDs ty - = getUniqueDs `thenDs` \ uniq -> + = newUnique `thenDs` \ uniq -> returnDs (mkSysLocal FSLIT("fail") uniq ty) -- The UserLocal bit just helps make the code a little clearer \end{code} \begin{code} -cloneTyVarsDs :: [TyVar] -> DsM [TyVar] -cloneTyVarsDs tyvars - = getUniquesDs `thenDs` \ uniqs -> - returnDs (zipWith setTyVarUnique tyvars uniqs) - newTyVarsDs :: [TyVar] -> DsM [TyVar] newTyVarsDs tyvar_tmpls - = getUniquesDs `thenDs` \ uniqs -> - returnDs (zipWith setTyVarUnique tyvar_tmpls uniqs) + = 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 @SrcLoc@ being carried around. +the @SrcSpan@ being carried around. \begin{code} getDOptsDs :: DsM DynFlags -getDOptsDs = DsM(\ env warns -> returnUs (ds_dflags env, warns)) +getDOptsDs = getDOpts getModuleDs :: DsM Module -getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns)) +getModuleDs = do { env <- getGblEnv; return (ds_mod env) } -getSrcLocDs :: DsM SrcLoc -getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns)) +getSrcSpanDs :: DsM SrcSpan +getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) } -putSrcLocDs :: SrcLoc -> DsM a -> DsM a -putSrcLocDs new_loc (DsM expr) = DsM(\ env warns -> - expr (env { ds_loc = new_loc }) warns) +putSrcSpanDs :: SrcSpan -> DsM a -> DsM a +putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside -dsWarn :: DsWarning -> DsM () -dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn)) +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 - = DsM(\ env warns -> returnUs (ds_globals env name, warns)) + = do { env <- getGblEnv + ; setEnvs (ds_if_env env) + (tcIfaceGlobal name) } dsLookupGlobalId :: Name -> DsM Id dsLookupGlobalId name = dsLookupGlobal name `thenDs` \ thing -> - returnDs $ case thing of - AnId id -> id - other -> pprPanic "dsLookupGlobalId" (ppr name) + returnDs (tyThingId thing) dsLookupTyCon :: Name -> DsM TyCon dsLookupTyCon name = dsLookupGlobal name `thenDs` \ thing -> - returnDs $ case thing of - ATyCon tc -> tc - other -> pprPanic "dsLookupTyCon" (ppr name) + returnDs (tyThingTyCon thing) dsLookupDataCon :: Name -> DsM DataCon dsLookupDataCon name = dsLookupGlobal name `thenDs` \ thing -> - returnDs $ case thing of - ADataCon dc -> dc - other -> pprPanic "dsLookupDataCon" (ppr name) + returnDs (tyThingDataCon thing) \end{code} \begin{code} dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) -dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns)) +dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) } dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a -dsExtendMetaEnv menv (DsM m) - = DsM (\ env warns -> m (env { ds_meta = ds_meta env `plusNameEnv` menv }) warns) +dsExtendMetaEnv menv thing_inside + = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside \end{code} -%************************************************************************ -%* * -\subsection{Type synonym @EquationInfo@ and access functions for its pieces} -%* * -%************************************************************************ - -\begin{code} -data DsMatchContext - = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc - | NoMatchContext - deriving () -\end{code}