\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,
- getSrcLocDs, putSrcLocDs,
+ getSrcSpanDs, putSrcSpanDs,
getModuleDs,
newUnique,
UniqSupply, newUniqueSupply,
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 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) [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 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
-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
data DsMetaVal
= Bound Id -- Bound by a pattern inside the [| |].
-- Will be dynamically alpha renamed.
- -- The Id has type String
+ -- 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
\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
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 warn = do { env <- getGblEnv; updMutVar (ds_warns env) (`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}
-- 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 TypecheckedMatchContext [TypecheckedPat] SrcLoc
- | NoMatchContext
- deriving ()
-\end{code}
projects / ghc-hetmet.git / blobdiff