2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
7 #include "HsVersions.h"
11 initDs, returnDs, thenDs, andDs, mapDs, listDs,
12 mapAndUnzipDs, zipWithDs,
14 newTyVarsDs, cloneTyVarsDs,
15 duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
17 getSrcLocDs, putSrcLocDs,
19 extendEnvDs, lookupEnvDs, lookupEnvWithDefaultDs,
24 DsMatchContext(..), DsMatchKind(..), pprDsWarnings
29 import Bag ( emptyBag, snocBag, bagToList )
30 import CmdLineOpts ( opt_SccGroup )
31 import CoreSyn ( CoreExpr(..) )
32 import CoreUtils ( substCoreExpr )
33 import HsSyn ( OutPat )
34 import Id ( mkSysLocal, lookupIdEnv, growIdEnvList, GenId, IdEnv(..) )
35 import PprType ( GenType, GenTyVar )
36 import PprStyle ( PprStyle(..) )
38 import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
39 import TcHsSyn ( TypecheckedPat(..) )
40 import TyVar ( nullTyVarEnv, GenTyVar )
41 import Unique ( Unique{-instances-} )
42 import UniqSupply ( splitUniqSupply, getUnique, getUniques,
43 mapUs, thenUs, returnUs, UniqSM(..) )
44 import Unique ( Unique )
45 import Util ( assoc, mapAccumL, zipWithEqual, panic )
49 cloneTyVar = panic "DsMonad.cloneTyVar"
50 cloneTyVarFromTemplate = panic "DsMonad.cloneTyVarFromTemplate"
51 mkIdWithNewUniq = panic "DsMonad.mkIdWithNewUniq"
54 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
55 a @UniqueSupply@ and some annotations, which
56 presumably include source-file location information:
60 -> SrcLoc -- to put in pattern-matching error msgs
61 -> (FAST_STRING, FAST_STRING) -- "module"+"group" : for SCC profiling
64 -> (result, DsWarnings)
66 type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are
67 -- completely shadowed
70 {-# INLINE returnDs #-}
72 -- initDs returns the UniqSupply out the end (not just the result)
76 -> FAST_STRING -- module name: for profiling; (group name: from switches)
80 initDs init_us env mod_name action
81 = action init_us mkUnknownSrcLoc module_and_group env emptyBag
83 module_and_group = (mod_name, grp_name)
84 grp_name = case opt_SccGroup of
86 Nothing -> mod_name -- default: module name
88 thenDs :: DsM a -> (a -> DsM b) -> DsM b
89 andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
91 thenDs m1 m2 us loc mod_and_grp env warns
92 = case splitUniqSupply us of { (s1, s2) ->
93 case (m1 s1 loc mod_and_grp env warns) of { (result, warns1) ->
94 m2 result s2 loc mod_and_grp env warns1}}
96 andDs combiner m1 m2 us loc mod_and_grp env warns
97 = case splitUniqSupply us of { (s1, s2) ->
98 case (m1 s1 loc mod_and_grp env warns) of { (result1, warns1) ->
99 case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
100 (combiner result1 result2, warns2) }}}
102 returnDs :: a -> DsM a
103 returnDs result us loc mod_and_grp env warns = (result, warns)
105 listDs :: [DsM a] -> DsM [a]
106 listDs [] = returnDs []
109 listDs xs `thenDs` \ rs ->
112 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
114 mapDs f [] = returnDs []
116 = f x `thenDs` \ r ->
117 mapDs f xs `thenDs` \ rs ->
120 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
122 mapAndUnzipDs f [] = returnDs ([], [])
123 mapAndUnzipDs f (x:xs)
124 = f x `thenDs` \ (r1, r2) ->
125 mapAndUnzipDs f xs `thenDs` \ (rs1, rs2) ->
126 returnDs (r1:rs1, r2:rs2)
128 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
130 zipWithDs f [] [] = returnDs []
131 zipWithDs f (x:xs) (y:ys)
132 = f x y `thenDs` \ r ->
133 zipWithDs f xs ys `thenDs` \ rs ->
135 -- Note: crashes if lists not equal length (like zipWithEqual)
138 And all this mysterious stuff is so we can occasionally reach out and
139 grab one or more names. @newLocalDs@ isn't exported---exported
140 functions are defined with it. The difference in name-strings makes
141 it easier to read debugging output.
143 newLocalDs :: FAST_STRING -> Type -> DsM Id
144 newLocalDs nm ty us loc mod_and_grp env warns
145 = case (getUnique us) of { assigned_uniq ->
146 (mkSysLocal nm assigned_uniq ty loc, warns) }
148 newSysLocalDs = newLocalDs SLIT("ds")
149 newSysLocalsDs tys = mapDs (newLocalDs SLIT("ds")) tys
150 newFailLocalDs = newLocalDs SLIT("fail")
152 duplicateLocalDs :: Id -> DsM Id
153 duplicateLocalDs old_local us loc mod_and_grp env warns
154 = case (getUnique us) of { assigned_uniq ->
155 (mkIdWithNewUniq old_local assigned_uniq, warns) }
157 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
158 cloneTyVarsDs tyvars us loc mod_and_grp env warns
159 = case (getUniques (length tyvars) us) of { uniqs ->
160 (zipWithEqual cloneTyVar tyvars uniqs, warns) }
164 newTyVarsDs :: [TyVar] -> DsM [TyVar]
166 newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
167 = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
168 (zipWithEqual cloneTyVarFromTemplate tyvar_tmpls uniqs, warns) }
171 We can also reach out and either set/grab location information from
172 the @SrcLoc@ being carried around.
174 uniqSMtoDsM :: UniqSM a -> DsM a
176 uniqSMtoDsM u_action us loc mod_and_grp env warns
177 = (u_action us, warns)
179 getSrcLocDs :: DsM (String, String)
180 getSrcLocDs us loc mod_and_grp env warns
181 = case (unpackSrcLoc loc) of { (x,y) ->
182 ((_UNPK_ x, _UNPK_ y), warns) }
184 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
185 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
186 = expr us new_loc mod_and_grp env warns
188 dsShadowError :: DsMatchContext -> DsM ()
189 dsShadowError cxt us loc mod_and_grp env warns
190 = ((), warns `snocBag` cxt)
194 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
195 getModuleAndGroupDs us loc mod_and_grp env warns
196 = (mod_and_grp, warns)
200 type DsIdEnv = IdEnv CoreExpr
202 extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
204 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
205 = case splitUniqSupply us of { (s1, s2) ->
207 revised_pairs = subst_all pairs s1
209 then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
212 subst_all pairs = mapUs subst pairs
215 = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr ->
216 returnUs (v, new_expr)
218 lookupEnvDs :: Id -> DsM (Maybe CoreExpr)
219 lookupEnvDs id us loc mod_and_grp env warns
220 = (lookupIdEnv env id, warns)
221 -- Note: we don't assert anything about the Id
222 -- being looked up. There's not really anything
223 -- much to say about it. (WDP 94/06)
225 lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
226 lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
227 = (case (lookupIdEnv env id) of
232 lookupId :: [(Id, a)] -> Id -> a
234 = assoc "lookupId" env id
237 %************************************************************************
239 %* type synonym EquationInfo and access functions for its pieces *
241 %************************************************************************
245 = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
254 pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty
255 pprDsWarnings sty warns
256 = ppAboves (map pp_cxt (bagToList warns))
258 pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what")
259 pp_cxt (DsMatchContext kind pats loc)
260 = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
261 4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:"))
262 4 (pp_match kind pats))
264 pp_match (FunMatch fun) pats
265 = ppHang (ppr sty fun)
266 4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")])
268 pp_match CaseMatch pats
269 = ppHang (ppPStr SLIT("in a case alternative:"))
270 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
272 pp_match PatBindMatch pats
273 = ppHang (ppPStr SLIT("in a pattern binding:"))
274 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
276 pp_match LambdaMatch pats
277 = ppHang (ppPStr SLIT("in a lambda abstraction:"))
278 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
280 pp_arrow_dotdotdot = ppPStr SLIT("-> ...")