\begin{code}
module DsMonad (
- DsM, mappM,
- initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, foldlDs,
+ DsM, mappM, mapAndUnzipM,
+ initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
+ foldlDs, foldrDs,
- newTyVarsDs,
+ newTyVarsDs, newLocalName,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
newFailLocalDs,
getSrcSpanDs, putSrcSpanDs,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
- dsWarn,
- DsWarning,
- DsMatchContext(..)
+ -- 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,
- 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 ( noSrcSpan, SrcSpan )
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:
returnDs = returnM
listDs = sequenceM
foldlDs = foldlM
+foldrDs = foldrM
mapAndUnzipDs = mapAndUnzipM
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
}
-- initDs returns the UniqSupply out the end (not just the result)
initDs :: HscEnv
- -> Module -> TypeEnv
+ -> Module -> GlobalRdrEnv -> TypeEnv
-> DsM a
- -> IO (a, Bag DsWarning)
+ -> IO (a, Bag WarnMsg)
-initDs hsc_env mod type_env 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) }
+ ; 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 = 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
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)) }
+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}
-- 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
\end{code}
-%************************************************************************
-%* *
-\subsection{Type synonym @EquationInfo@ and access functions for its pieces}
-%* *
-%************************************************************************
-
-\begin{code}
-data DsMatchContext
- = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
- | NoMatchContext
- deriving ()
-\end{code}
projects / ghc-hetmet.git / blobdiff