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 IfaceEnv ( 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)
105 -> ModuleEnv (ModuleName,IsBootInterface)
107 -> IO (a, Bag DsWarning)
109 initDs hsc_env mod type_env is_boot thing_inside
110 = do { warn_var <- newIORef emptyBag
111 ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env),
112 if_is_boot = is_boot }
113 ; gbl_env = DsGblEnv { ds_mod = mod,
115 ds_warns = warn_var }
116 ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
117 ds_loc = noSrcSpan } }
119 ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
121 ; warns <- readIORef warn_var
122 ; return (res, warns)
126 And all this mysterious stuff is so we can occasionally reach out and
127 grab one or more names. @newLocalDs@ isn't exported---exported
128 functions are defined with it. The difference in name-strings makes
129 it easier to read debugging output.
132 -- Make a new Id with the same print name, but different type, and new unique
133 newUniqueId :: Name -> Type -> DsM Id
135 = newUnique `thenDs` \ uniq ->
136 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
138 duplicateLocalDs :: Id -> DsM Id
139 duplicateLocalDs old_local
140 = newUnique `thenDs` \ uniq ->
141 returnDs (setIdUnique old_local uniq)
143 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
145 = newUnique `thenDs` \ uniq ->
146 returnDs (mkSysLocal FSLIT("ds") uniq ty)
148 newSysLocalsDs tys = mappM newSysLocalDs tys
151 = newUnique `thenDs` \ uniq ->
152 returnDs (mkSysLocal FSLIT("fail") uniq ty)
153 -- The UserLocal bit just helps make the code a little clearer
157 newTyVarsDs :: [TyVar] -> DsM [TyVar]
158 newTyVarsDs tyvar_tmpls
159 = newUniqueSupply `thenDs` \ uniqs ->
160 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
163 We can also reach out and either set/grab location information from
164 the @SrcSpan@ being carried around.
167 getDOptsDs :: DsM DynFlags
168 getDOptsDs = getDOpts
170 getModuleDs :: DsM Module
171 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
173 getSrcSpanDs :: DsM SrcSpan
174 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
176 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
177 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
179 dsWarn :: DsWarning -> DsM ()
180 dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
182 msg = ptext SLIT("Warning:") <+> warn
186 dsLookupGlobal :: Name -> DsM TyThing
187 -- Very like TcEnv.tcLookupGlobal
189 = do { env <- getGblEnv
190 ; setEnvs (ds_if_env env, ())
191 (tcIfaceGlobal name) }
193 dsLookupGlobalId :: Name -> DsM Id
194 dsLookupGlobalId name
195 = dsLookupGlobal name `thenDs` \ thing ->
196 returnDs (tyThingId thing)
198 dsLookupTyCon :: Name -> DsM TyCon
200 = dsLookupGlobal name `thenDs` \ thing ->
201 returnDs (tyThingTyCon thing)
203 dsLookupDataCon :: Name -> DsM DataCon
205 = dsLookupGlobal name `thenDs` \ thing ->
206 returnDs (tyThingDataCon thing)
210 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
211 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
213 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
214 dsExtendMetaEnv menv thing_inside
215 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
219 %************************************************************************
221 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
223 %************************************************************************
227 = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan