2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
9 initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, foldlDs,
12 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
14 getSrcSpanDs, putSrcSpanDs,
17 UniqSupply, newUniqueSupply,
19 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
21 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
28 #include "HsVersions.h"
31 import HsSyn ( HsExpr, HsMatchContext, Pat )
32 import TcIface ( tcIfaceGlobal )
33 import HscTypes ( TyThing(..), TypeEnv, HscEnv,
35 tyThingId, tyThingTyCon, tyThingDataCon )
36 import Bag ( emptyBag, snocBag, Bag )
37 import DataCon ( DataCon )
38 import TyCon ( TyCon )
39 import DataCon ( DataCon )
40 import Id ( mkSysLocal, setIdUnique, Id )
41 import Module ( Module, ModuleName, ModuleEnv )
42 import Var ( TyVar, setTyVarUnique )
44 import SrcLoc ( noSrcSpan, SrcSpan )
46 import UniqSupply ( UniqSupply, uniqsFromSupply )
47 import Name ( Name, nameOccName )
49 import OccName ( occNameFS )
50 import CmdLineOpts ( DynFlags )
52 import DATA_IOREF ( newIORef, readIORef )
57 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
58 a @UniqueSupply@ and some annotations, which
59 presumably include source-file location information:
61 type DsM result = TcRnIf DsGblEnv DsLclEnv result
63 -- Compatibility functions
69 mapAndUnzipDs = mapAndUnzipM
72 type DsWarning = (SrcSpan, SDoc)
73 -- Not quite the same as a WarnMsg, we have an SDoc here
74 -- and we'll do the print_unqual stuff later on to turn it
77 data DsGblEnv = DsGblEnv {
78 ds_mod :: Module, -- For SCC profiling
79 ds_warns :: IORef (Bag DsWarning), -- Warning messages
80 ds_if_env :: IfGblEnv -- Used for looking up global,
81 -- possibly-imported things
84 data DsLclEnv = DsLclEnv {
85 ds_meta :: DsMetaEnv, -- Template Haskell bindings
86 ds_loc :: SrcSpan -- to put in pattern-matching error msgs
89 -- Inside [| |] brackets, the desugarer looks
90 -- up variables in the DsMetaEnv
91 type DsMetaEnv = NameEnv DsMetaVal
94 = Bound Id -- Bound by a pattern inside the [| |].
95 -- Will be dynamically alpha renamed.
96 -- The Id has type THSyntax.Var
98 | Splice (HsExpr Id) -- These bindings are introduced by
99 -- the PendingSplices on a HsBracketOut
101 -- initDs returns the UniqSupply out the end (not just the result)
106 -> IO (a, Bag DsWarning)
108 initDs hsc_env mod type_env thing_inside
109 = do { warn_var <- newIORef emptyBag
110 ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env) }
111 ; gbl_env = DsGblEnv { ds_mod = mod,
113 ds_warns = warn_var }
114 ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
115 ds_loc = noSrcSpan } }
117 ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
119 ; warns <- readIORef warn_var
120 ; return (res, warns)
124 And all this mysterious stuff is so we can occasionally reach out and
125 grab one or more names. @newLocalDs@ isn't exported---exported
126 functions are defined with it. The difference in name-strings makes
127 it easier to read debugging output.
130 -- Make a new Id with the same print name, but different type, and new unique
131 newUniqueId :: Name -> Type -> DsM Id
133 = newUnique `thenDs` \ uniq ->
134 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
136 duplicateLocalDs :: Id -> DsM Id
137 duplicateLocalDs old_local
138 = newUnique `thenDs` \ uniq ->
139 returnDs (setIdUnique old_local uniq)
141 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
143 = newUnique `thenDs` \ uniq ->
144 returnDs (mkSysLocal FSLIT("ds") uniq ty)
146 newSysLocalsDs tys = mappM newSysLocalDs tys
149 = newUnique `thenDs` \ uniq ->
150 returnDs (mkSysLocal FSLIT("fail") uniq ty)
151 -- The UserLocal bit just helps make the code a little clearer
155 newTyVarsDs :: [TyVar] -> DsM [TyVar]
156 newTyVarsDs tyvar_tmpls
157 = newUniqueSupply `thenDs` \ uniqs ->
158 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
161 We can also reach out and either set/grab location information from
162 the @SrcSpan@ being carried around.
165 getDOptsDs :: DsM DynFlags
166 getDOptsDs = getDOpts
168 getModuleDs :: DsM Module
169 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
171 getSrcSpanDs :: DsM SrcSpan
172 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
174 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
175 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
177 dsWarn :: DsWarning -> DsM ()
178 dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
180 msg = ptext SLIT("Warning:") <+> warn
184 dsLookupGlobal :: Name -> DsM TyThing
185 -- Very like TcEnv.tcLookupGlobal
187 = do { env <- getGblEnv
188 ; setEnvs (ds_if_env env, ())
189 (tcIfaceGlobal name) }
191 dsLookupGlobalId :: Name -> DsM Id
192 dsLookupGlobalId name
193 = dsLookupGlobal name `thenDs` \ thing ->
194 returnDs (tyThingId thing)
196 dsLookupTyCon :: Name -> DsM TyCon
198 = dsLookupGlobal name `thenDs` \ thing ->
199 returnDs (tyThingTyCon thing)
201 dsLookupDataCon :: Name -> DsM DataCon
203 = dsLookupGlobal name `thenDs` \ thing ->
204 returnDs (tyThingDataCon thing)
208 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
209 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
211 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
212 dsExtendMetaEnv menv thing_inside
213 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
217 %************************************************************************
219 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
221 %************************************************************************
225 = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan