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 RdrName ( GlobalRdrEnv )
34 import HscTypes ( TyThing(..), TypeEnv, HscEnv,
35 tyThingId, tyThingTyCon, tyThingDataCon, unQualInScope )
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 )
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 )
51 import ErrUtils ( WarnMsg, mkWarnMsg )
54 import DATA_IOREF ( newIORef, readIORef )
59 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
60 a @UniqueSupply@ and some annotations, which
61 presumably include source-file location information:
63 type DsM result = TcRnIf DsGblEnv DsLclEnv result
65 -- Compatibility functions
71 mapAndUnzipDs = mapAndUnzipM
74 type DsWarning = (SrcSpan, SDoc)
75 -- Not quite the same as a WarnMsg, we have an SDoc here
76 -- and we'll do the print_unqual stuff later on to turn it
79 data DsGblEnv = DsGblEnv {
80 ds_mod :: Module, -- For SCC profiling
81 ds_warns :: IORef (Bag DsWarning), -- Warning messages
82 ds_if_env :: IfGblEnv -- Used for looking up global,
83 -- possibly-imported things
86 data DsLclEnv = DsLclEnv {
87 ds_meta :: DsMetaEnv, -- Template Haskell bindings
88 ds_loc :: SrcSpan -- to put in pattern-matching error msgs
91 -- Inside [| |] brackets, the desugarer looks
92 -- up variables in the DsMetaEnv
93 type DsMetaEnv = NameEnv DsMetaVal
96 = Bound Id -- Bound by a pattern inside the [| |].
97 -- Will be dynamically alpha renamed.
98 -- The Id has type THSyntax.Var
100 | Splice (HsExpr Id) -- These bindings are introduced by
101 -- the PendingSplices on a HsBracketOut
103 -- initDs returns the UniqSupply out the end (not just the result)
106 -> Module -> GlobalRdrEnv -> TypeEnv
108 -> IO (a, Bag WarnMsg)
110 initDs hsc_env mod rdr_env type_env thing_inside
111 = do { warn_var <- newIORef emptyBag
112 ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env) }
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, mapBag mk_warn warns)
125 print_unqual = unQualInScope rdr_env
127 mk_warn :: (SrcSpan,SDoc) -> WarnMsg
128 mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
131 And all this mysterious stuff is so we can occasionally reach out and
132 grab one or more names. @newLocalDs@ isn't exported---exported
133 functions are defined with it. The difference in name-strings makes
134 it easier to read debugging output.
137 -- Make a new Id with the same print name, but different type, and new unique
138 newUniqueId :: Name -> Type -> DsM Id
140 = newUnique `thenDs` \ uniq ->
141 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
143 duplicateLocalDs :: Id -> DsM Id
144 duplicateLocalDs old_local
145 = newUnique `thenDs` \ uniq ->
146 returnDs (setIdUnique old_local uniq)
148 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
150 = newUnique `thenDs` \ uniq ->
151 returnDs (mkSysLocal FSLIT("ds") uniq ty)
153 newSysLocalsDs tys = mappM newSysLocalDs tys
156 = newUnique `thenDs` \ uniq ->
157 returnDs (mkSysLocal FSLIT("fail") uniq ty)
158 -- The UserLocal bit just helps make the code a little clearer
162 newTyVarsDs :: [TyVar] -> DsM [TyVar]
163 newTyVarsDs tyvar_tmpls
164 = newUniqueSupply `thenDs` \ uniqs ->
165 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
168 We can also reach out and either set/grab location information from
169 the @SrcSpan@ being carried around.
172 getDOptsDs :: DsM DynFlags
173 getDOptsDs = getDOpts
175 getModuleDs :: DsM Module
176 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
178 getSrcSpanDs :: DsM SrcSpan
179 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
181 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
182 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
184 dsWarn :: DsWarning -> DsM ()
185 dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
187 msg = ptext SLIT("Warning:") <+> warn
191 dsLookupGlobal :: Name -> DsM TyThing
192 -- Very like TcEnv.tcLookupGlobal
194 = do { env <- getGblEnv
195 ; setEnvs (ds_if_env env, ())
196 (tcIfaceGlobal name) }
198 dsLookupGlobalId :: Name -> DsM Id
199 dsLookupGlobalId name
200 = dsLookupGlobal name `thenDs` \ thing ->
201 returnDs (tyThingId thing)
203 dsLookupTyCon :: Name -> DsM TyCon
205 = dsLookupGlobal name `thenDs` \ thing ->
206 returnDs (tyThingTyCon thing)
208 dsLookupDataCon :: Name -> DsM DataCon
210 = dsLookupGlobal name `thenDs` \ thing ->
211 returnDs (tyThingDataCon thing)
215 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
216 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
218 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
219 dsExtendMetaEnv menv thing_inside
220 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
224 %************************************************************************
226 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
228 %************************************************************************
232 = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan