\begin{code}
module DsMonad (
DsM,
- initDs, returnDs, thenDs, andDs, mapDs, listDs,
+ initDs, returnDs, thenDs, mapDs, listDs, fixDs,
mapAndUnzipDs, zipWithDs, foldlDs,
uniqSMtoDsM,
newTyVarsDs, cloneTyVarsDs,
- duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
+ duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
newFailLocalDs,
getSrcLocDs, putSrcLocDs,
- getModuleAndGroupDs,
- getUniqueDs,
- dsLookupGlobalValue,
+ getModuleDs,
+ getUniqueDs, getUniquesDs,
+ UniqSupply, getUniqSupplyDs,
+ getDOptsDs,
+ dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
+
+ DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
- ValueEnv,
dsWarn,
DsWarnings,
- DsMatchContext(..), DsMatchKind(..), pprDsWarnings
+ DsMatchContext(..)
) where
#include "HsVersions.h"
-import Bag ( emptyBag, snocBag, bagToList, Bag )
-import ErrUtils ( WarnMsg )
-import HsSyn ( OutPat )
-import Id ( mkUserLocal, mkSysLocal, setIdUnique, Id )
-import Name ( Module, Name, maybeWiredInIdName )
+import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
+import HscTypes ( TyThing(..) )
+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 VarEnv
import Outputable
import SrcLoc ( noSrcLoc, SrcLoc )
-import TcHsSyn ( TypecheckedPat )
-import TcEnv ( ValueEnv )
import Type ( Type )
-import UniqSupply ( initUs, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
- UniqSM, UniqSupply )
-import Unique ( Unique )
-import UniqFM ( lookupWithDefaultUFM )
-import Util ( zipWithEqual )
+import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs,
+ fixUs, UniqSM, UniqSupply, getUs )
+import Unique ( Unique )
+import Name ( Name, nameOccName )
+import NameEnv
+import OccName ( occNameFS )
+import CmdLineOpts ( DynFlags )
infixr 9 `thenDs`
\end{code}
a @UniqueSupply@ and some annotations, which
presumably include source-file location information:
\begin{code}
-type DsM result =
- UniqSupply
- -> ValueEnv
- -> SrcLoc -- to put in pattern-matching error msgs
- -> (Module, Group) -- module + group name : for SCC profiling
- -> DsWarnings
- -> (result, DsWarnings)
-
-type DsWarnings = Bag WarnMsg -- The desugarer reports matches which are
- -- completely shadowed or incomplete patterns
+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
+ ds_meta :: DsMetaEnv, -- Template Haskell bindings
+ ds_loc :: SrcLoc, -- to put in pattern-matching error msgs
+ ds_mod :: Module -- module: for SCC profiling
+ }
+
+-- Inside [| |] brackets, the desugarer looks
+-- up variables in the DsMetaEnv
+type DsMetaEnv = NameEnv DsMetaVal
-type Group = FAST_STRING
+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
+
+type DsWarnings = Bag DsWarning -- The desugarer reports matches which are
+ -- completely shadowed or incomplete patterns
+type DsWarning = (SrcLoc, SDoc)
-{-# INLINE andDs #-}
{-# INLINE thenDs #-}
{-# INLINE returnDs #-}
-- initDs returns the UniqSupply out the end (not just the result)
-initDs :: UniqSupply
- -> ValueEnv
- -> (Module, Group) -- module name: for profiling; (group name: from switches)
+initDs :: DynFlags
+ -> UniqSupply
+ -> (Name -> TyThing)
+ -> Module -- module name: for profiling
-> DsM a
-> (a, DsWarnings)
-initDs init_us genv module_and_group action
- = action init_us genv noSrcLoc module_and_group emptyBag
+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
-andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
-
-thenDs m1 m2 us genv loc mod_and_grp warns
- = case splitUniqSupply us of { (s1, s2) ->
- case (m1 s1 genv loc mod_and_grp warns) of { (result, warns1) ->
- m2 result s2 genv loc mod_and_grp warns1}}
-andDs combiner m1 m2 us genv loc mod_and_grp warns
- = case splitUniqSupply us of { (s1, s2) ->
- case (m1 s1 genv loc mod_and_grp warns) of { (result1, warns1) ->
- case (m2 s2 genv loc mod_and_grp warns1) of { (result2, warns2) ->
- (combiner result1 result2, warns2) }}}
+thenDs (DsM m1) m2 = DsM( \ env warns ->
+ m1 env warns `thenUs` \ (result, warns1) ->
+ unDsM (m2 result) env warns1)
returnDs :: a -> DsM a
-returnDs result us genv loc mod_and_grp warns = (result, warns)
+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 []
it easier to read debugging output.
\begin{code}
-newSysLocalDs, newFailLocalDs :: Type -> DsM Id
-newSysLocalDs ty us genv loc mod_and_grp warns
- = case uniqFromSupply us of { assigned_uniq ->
- (mkSysLocal SLIT("ds") assigned_uniq ty, warns) }
-
-newSysLocalsDs tys = mapDs newSysLocalDs tys
-
-newFailLocalDs ty us genv loc mod_and_grp warns
- = case uniqFromSupply us of { assigned_uniq ->
- (mkSysLocal SLIT("fail") assigned_uniq ty, warns) }
- -- The UserLocal bit just helps make the code a little clearer
+uniqSMtoDsM :: UniqSM a -> DsM a
+uniqSMtoDsM u_action = DsM(\ env warns ->
+ u_action `thenUs` \ res ->
+ returnUs (res, warns))
+
getUniqueDs :: DsM Unique
-getUniqueDs us genv loc mod_and_grp warns
- = case (uniqFromSupply us) of { assigned_uniq ->
- (assigned_uniq, warns) }
+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 ->
+ returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
duplicateLocalDs :: Id -> DsM Id
-duplicateLocalDs old_local us genv loc mod_and_grp warns
- = case uniqFromSupply us of { assigned_uniq ->
- (setIdUnique old_local assigned_uniq, warns) }
+duplicateLocalDs old_local
+ = getUniqueDs `thenDs` \ uniq ->
+ returnDs (setIdUnique old_local uniq)
-cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
-cloneTyVarsDs tyvars us genv loc mod_and_grp warns
- = case uniqsFromSupply (length tyvars) us of { uniqs ->
- (zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) }
+newSysLocalDs, newFailLocalDs :: Type -> DsM Id
+newSysLocalDs ty
+ = getUniqueDs `thenDs` \ uniq ->
+ returnDs (mkSysLocal FSLIT("ds") uniq ty)
+
+newSysLocalsDs tys = mapDs newSysLocalDs tys
+
+newFailLocalDs ty
+ = getUniqueDs `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]
+cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
+cloneTyVarsDs tyvars
+ = getUniquesDs `thenDs` \ uniqs ->
+ returnDs (zipWith setTyVarUnique tyvars uniqs)
-newTyVarsDs tyvar_tmpls us genv loc mod_and_grp warns
- = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
- (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
+newTyVarsDs :: [TyVar] -> DsM [TyVar]
+newTyVarsDs tyvar_tmpls
+ = getUniquesDs `thenDs` \ uniqs ->
+ returnDs (zipWith setTyVarUnique tyvar_tmpls uniqs)
\end{code}
We can also reach out and either set/grab location information from
the @SrcLoc@ being carried around.
+
\begin{code}
-uniqSMtoDsM :: UniqSM a -> DsM a
+getDOptsDs :: DsM DynFlags
+getDOptsDs = DsM(\ env warns -> returnUs (ds_dflags env, warns))
-uniqSMtoDsM u_action us genv loc mod_and_grp warns
- = (initUs us u_action, warns)
+getModuleDs :: DsM Module
+getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns))
getSrcLocDs :: DsM SrcLoc
-getSrcLocDs us genv loc mod_and_grp warns
- = (loc, warns)
+getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns))
putSrcLocDs :: SrcLoc -> DsM a -> DsM a
-putSrcLocDs new_loc expr us genv old_loc mod_and_grp warns
- = expr us genv new_loc mod_and_grp warns
-
-dsWarn :: WarnMsg -> DsM ()
-dsWarn warn us genv loc mod_and_grp warns = ((), warns `snocBag` warn)
+putSrcLocDs new_loc (DsM expr) = DsM(\ env warns ->
+ expr (env { ds_loc = new_loc }) warns)
+dsWarn :: DsWarning -> DsM ()
+dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn))
\end{code}
\begin{code}
-getModuleAndGroupDs :: DsM (Module, Group)
-getModuleAndGroupDs us genv loc mod_and_grp warns
- = (mod_and_grp, warns)
+dsLookupGlobal :: Name -> DsM TyThing
+dsLookupGlobal name
+ = DsM(\ env warns -> returnUs (ds_globals env name, warns))
+
+dsLookupGlobalId :: Name -> DsM Id
+dsLookupGlobalId name
+ = dsLookupGlobal name `thenDs` \ thing ->
+ returnDs $ case thing of
+ AnId id -> id
+ other -> pprPanic "dsLookupGlobalId" (ppr name)
+
+dsLookupTyCon :: Name -> DsM TyCon
+dsLookupTyCon name
+ = dsLookupGlobal name `thenDs` \ thing ->
+ returnDs $ case thing of
+ ATyCon tc -> tc
+ other -> pprPanic "dsLookupTyCon" (ppr name)
+
+dsLookupDataCon :: Name -> DsM DataCon
+dsLookupDataCon name
+ = dsLookupGlobal name `thenDs` \ thing ->
+ returnDs $ case thing of
+ ADataCon dc -> dc
+ other -> pprPanic "dsLookupDataCon" (ppr name)
\end{code}
\begin{code}
-dsLookupGlobalValue :: Name -> DsM Id
-dsLookupGlobalValue name us genv loc mod_and_grp warns
- = case maybeWiredInIdName name of
- Just id -> (id, warns)
- Nothing -> (lookupWithDefaultUFM genv def name, warns)
- where
- def = pprPanic "tcLookupGlobalValue:" (ppr name)
+dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
+dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns))
+
+dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
+dsExtendMetaEnv menv (DsM m)
+ = DsM (\ env warns -> m (env { ds_meta = ds_meta env `plusNameEnv` menv }) warns)
\end{code}
%************************************************************************
%* *
-%* type synonym EquationInfo and access functions for its pieces *
+\subsection{Type synonym @EquationInfo@ and access functions for its pieces}
%* *
%************************************************************************
\begin{code}
data DsMatchContext
- = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
+ = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
| NoMatchContext
deriving ()
-
-data DsMatchKind
- = FunMatch Id
- | CaseMatch
- | LambdaMatch
- | PatBindMatch
- | DoBindMatch
- | ListCompMatch
- | LetMatch
- deriving ()
-
-pprDsWarnings :: DsWarnings -> SDoc
-pprDsWarnings warns = vcat (bagToList warns)
\end{code}
projects / ghc-hetmet.git / blobdiff