X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsMonad.lhs;h=b82a30a7bcf1708debf72842a5f47b094a4abc6a;hb=6d36af4aff6e12afa50dae2fad3993c385f8081d;hp=531f72948caef8b9412f82b69447e8df98754db7;hpb=1f5e55804b97d2b9a77207d568d602ba88d8855d;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 531f729..b82a30a 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -11,7 +11,7 @@ module DsMonad ( newTyVarsDs, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, newFailLocalDs, - getSrcLocDs, putSrcLocDs, + getSrcSpanDs, putSrcSpanDs, getModuleDs, newUnique, UniqSupply, newUniqueSupply, @@ -20,40 +20,94 @@ module DsMonad ( DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, - dsWarn, - DsWarning, - DsMatchContext(..) + -- Warnings + DsWarning, dsWarn, + + -- Data types + DsMatchContext(..), + EquationInfo(..), MatchResult(..), DsWrapper, idWrapper, + CanItFail(..), orFail ) where #include "HsVersions.h" -import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr ) import TcRnMonad -import IfaceEnv ( tcIfaceGlobal ) +import CoreSyn ( CoreExpr ) +import HsSyn ( HsExpr, HsMatchContext, Pat ) +import TcIface ( tcIfaceGlobal ) +import RdrName ( GlobalRdrEnv ) import HscTypes ( TyThing(..), TypeEnv, HscEnv, - IsBootInterface, - tyThingId, tyThingTyCon, tyThingDataCon ) + 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, ModuleName, ModuleEnv ) +import Module ( Module ) import Var ( TyVar, setTyVarUnique ) import Outputable -import SrcLoc ( noSrcLoc, SrcLoc ) +import SrcLoc ( noSrcSpan, SrcSpan ) import Type ( Type ) import UniqSupply ( UniqSupply, uniqsFromSupply ) import Name ( Name, nameOccName ) import NameEnv import OccName ( occNameFS ) import CmdLineOpts ( 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) [Pat Id] 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 in the domain of 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: @@ -69,18 +123,21 @@ foldlDs = foldlM mapAndUnzipDs = mapAndUnzipM -type DsWarning = (SrcLoc, SDoc) +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 -- Used for looking up global, + 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_loc :: SrcSpan -- to put in pattern-matching error msgs } -- Inside [| |] brackets, the desugarer looks @@ -92,34 +149,44 @@ data DsMetaVal -- Will be dynamically alpha renamed. -- The Id has type THSyntax.Var - | Splice TypecheckedHsExpr -- These bindings are introduced by - -- the PendingSplices on a HsBracketOut + | 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 -> TypeEnv - -> ModuleEnv (ModuleName,IsBootInterface) + -> Module -> GlobalRdrEnv -> TypeEnv -> DsM a - -> IO (a, Bag DsWarning) + -> IO (a, Bag WarnMsg) -initDs hsc_env mod type_env is_boot thing_inside +initDs hsc_env mod rdr_env type_env thing_inside = do { warn_var <- newIORef emptyBag - ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env), - if_is_boot = is_boot } + ; 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_env, + ds_if_env = (if_genv, if_lenv), ds_warns = warn_var } ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv, - ds_loc = noSrcLoc } } + ds_loc = noSrcSpan } } ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside ; warns <- readIORef warn_var - ; return (res, warns) + ; 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 @@ -158,7 +225,7 @@ newTyVarsDs tyvar_tmpls \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 @@ -167,11 +234,11 @@ getDOptsDs = getDOpts getModuleDs :: DsM Module getModuleDs = do { env <- getGblEnv; return (ds_mod env) } -getSrcLocDs :: DsM SrcLoc -getSrcLocDs = do { env <- getLclEnv; return (ds_loc env) } +getSrcSpanDs :: DsM SrcSpan +getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) } -putSrcLocDs :: SrcLoc -> DsM a -> DsM a -putSrcLocDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside +putSrcSpanDs :: SrcSpan -> DsM a -> DsM a +putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside dsWarn :: DsWarning -> DsM () dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) } @@ -184,7 +251,7 @@ dsLookupGlobal :: Name -> DsM TyThing -- Very like TcEnv.tcLookupGlobal dsLookupGlobal name = do { env <- getGblEnv - ; setEnvs (ds_if_env env, ()) + ; setEnvs (ds_if_env env) (tcIfaceGlobal name) } dsLookupGlobalId :: Name -> DsM Id @@ -213,15 +280,3 @@ dsExtendMetaEnv 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}