\begin{code}
module DsMonad (
DsM,
- initDs, returnDs, thenDs, mapDs, listDs,
+ initDs, returnDs, thenDs, mapDs, listDs, fixDs,
mapAndUnzipDs, zipWithDs, foldlDs,
uniqSMtoDsM,
newTyVarsDs, cloneTyVarsDs,
getSrcLocDs, putSrcLocDs,
getModuleDs,
getUniqueDs, getUniquesDs,
+ UniqSupply, getUniqSupplyDs,
getDOptsDs,
- dsLookupGlobalId, dsLookupTyCon,
+ dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
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 SrcLoc ( noSrcLoc, SrcLoc )
import Type ( Type )
import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs,
- UniqSM, UniqSupply )
+ fixUs, UniqSM, UniqSupply, getUs )
import Unique ( Unique )
import Name ( Name, nameOccName )
import NameEnv
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)
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
\end{code}
\begin{code}
+dsLookupGlobal :: Name -> DsM TyThing
+dsLookupGlobal name
+ = DsM(\ env warns -> returnUs (ds_globals env name, warns))
+
dsLookupGlobalId :: Name -> DsM Id
-dsLookupGlobalId name = DsM(\ env warns ->
- returnUs (get_id name (ds_globals env name), warns))
+dsLookupGlobalId name
+ = dsLookupGlobal name `thenDs` \ thing ->
+ returnDs $ case thing of
+ AnId id -> id
+ other -> pprPanic "dsLookupGlobalId" (ppr name)
dsLookupTyCon :: Name -> DsM TyCon
-dsLookupTyCon name = DsM(\ env warns ->
- returnUs (get_tycon name (ds_globals env name), warns))
-
-get_id name (AnId id) = id
-get_id name other = pprPanic "dsLookupGlobalId" (ppr name)
-
-get_tycon name (ATyCon tc) = tc
-get_tycon name other = pprPanic "dsLookupTyCon" (ppr name)
+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}