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 getSrcLocDs, putSrcLocDs,
17 UniqSupply, newUniqueSupply,
19 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
21 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
28 #include "HsVersions.h"
30 import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
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 ( noSrcLoc, SrcLoc )
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 = (SrcLoc, SDoc)
74 data DsGblEnv = DsGblEnv {
75 ds_mod :: Module, -- For SCC profiling
76 ds_warns :: IORef (Bag DsWarning), -- Warning messages
77 ds_if_env :: IfGblEnv -- Used for looking up global,
78 -- possibly-imported things
81 data DsLclEnv = DsLclEnv {
82 ds_meta :: DsMetaEnv, -- Template Haskell bindings
83 ds_loc :: SrcLoc -- to put in pattern-matching error msgs
86 -- Inside [| |] brackets, the desugarer looks
87 -- up variables in the DsMetaEnv
88 type DsMetaEnv = NameEnv DsMetaVal
91 = Bound Id -- Bound by a pattern inside the [| |].
92 -- Will be dynamically alpha renamed.
93 -- The Id has type THSyntax.Var
95 | Splice TypecheckedHsExpr -- These bindings are introduced by
96 -- the PendingSplices on a HsBracketOut
98 -- initDs returns the UniqSupply out the end (not just the result)
102 -> ModuleEnv (ModuleName,IsBootInterface)
104 -> IO (a, Bag DsWarning)
106 initDs hsc_env mod type_env is_boot thing_inside
107 = do { warn_var <- newIORef emptyBag
108 ; let { if_env = IfGblEnv { if_rec_types = Just (mod, return type_env),
109 if_is_boot = is_boot }
110 ; gbl_env = DsGblEnv { ds_mod = mod,
112 ds_warns = warn_var }
113 ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
114 ds_loc = noSrcLoc } }
116 ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
118 ; warns <- readIORef warn_var
119 ; return (res, warns)
123 And all this mysterious stuff is so we can occasionally reach out and
124 grab one or more names. @newLocalDs@ isn't exported---exported
125 functions are defined with it. The difference in name-strings makes
126 it easier to read debugging output.
129 -- Make a new Id with the same print name, but different type, and new unique
130 newUniqueId :: Name -> Type -> DsM Id
132 = newUnique `thenDs` \ uniq ->
133 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
135 duplicateLocalDs :: Id -> DsM Id
136 duplicateLocalDs old_local
137 = newUnique `thenDs` \ uniq ->
138 returnDs (setIdUnique old_local uniq)
140 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
142 = newUnique `thenDs` \ uniq ->
143 returnDs (mkSysLocal FSLIT("ds") uniq ty)
145 newSysLocalsDs tys = mappM newSysLocalDs tys
148 = newUnique `thenDs` \ uniq ->
149 returnDs (mkSysLocal FSLIT("fail") uniq ty)
150 -- The UserLocal bit just helps make the code a little clearer
154 newTyVarsDs :: [TyVar] -> DsM [TyVar]
155 newTyVarsDs tyvar_tmpls
156 = newUniqueSupply `thenDs` \ uniqs ->
157 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
160 We can also reach out and either set/grab location information from
161 the @SrcLoc@ being carried around.
164 getDOptsDs :: DsM DynFlags
165 getDOptsDs = getDOpts
167 getModuleDs :: DsM Module
168 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
170 getSrcLocDs :: DsM SrcLoc
171 getSrcLocDs = do { env <- getLclEnv; return (ds_loc env) }
173 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
174 putSrcLocDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
176 dsWarn :: DsWarning -> DsM ()
177 dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
179 msg = ptext SLIT("Warning:") <+> warn
183 dsLookupGlobal :: Name -> DsM TyThing
184 -- Very like TcEnv.tcLookupGlobal
186 = do { env <- getGblEnv
187 ; setEnvs (ds_if_env env, ())
188 (tcIfaceGlobal name) }
190 dsLookupGlobalId :: Name -> DsM Id
191 dsLookupGlobalId name
192 = dsLookupGlobal name `thenDs` \ thing ->
193 returnDs (tyThingId thing)
195 dsLookupTyCon :: Name -> DsM TyCon
197 = dsLookupGlobal name `thenDs` \ thing ->
198 returnDs (tyThingTyCon thing)
200 dsLookupDataCon :: Name -> DsM DataCon
202 = dsLookupGlobal name `thenDs` \ thing ->
203 returnDs (tyThingDataCon thing)
207 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
208 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
210 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
211 dsExtendMetaEnv menv thing_inside
212 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
216 %************************************************************************
218 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
220 %************************************************************************
224 = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc