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, mkIdWithNewUniq,
35 lookupIdEnv, growIdEnvList, GenId, IdEnv(..)
37 import PprType ( GenType, GenTyVar )
38 import PprStyle ( PprStyle(..) )
40 import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
41 import TcHsSyn ( TypecheckedPat(..) )
42 import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
43 import Unique ( Unique{-instances-} )
44 import UniqSupply ( splitUniqSupply, getUnique, getUniques,
45 mapUs, thenUs, returnUs, UniqSM(..) )
46 import Util ( assoc, mapAccumL, zipWithEqual, panic )
51 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
52 a @UniqueSupply@ and some annotations, which
53 presumably include source-file location information:
57 -> SrcLoc -- to put in pattern-matching error msgs
58 -> (FAST_STRING, FAST_STRING) -- "module"+"group" : for SCC profiling
61 -> (result, DsWarnings)
63 type DsWarnings = Bag DsMatchContext -- The desugarer reports matches which are
64 -- completely shadowed
67 {-# INLINE returnDs #-}
69 -- initDs returns the UniqSupply out the end (not just the result)
73 -> FAST_STRING -- module name: for profiling; (group name: from switches)
77 initDs init_us env mod_name action
78 = action init_us mkUnknownSrcLoc module_and_group env emptyBag
80 module_and_group = (mod_name, grp_name)
81 grp_name = case opt_SccGroup of
83 Nothing -> mod_name -- default: module name
85 thenDs :: DsM a -> (a -> DsM b) -> DsM b
86 andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
88 thenDs m1 m2 us loc mod_and_grp env warns
89 = case splitUniqSupply us of { (s1, s2) ->
90 case (m1 s1 loc mod_and_grp env warns) of { (result, warns1) ->
91 m2 result s2 loc mod_and_grp env warns1}}
93 andDs combiner m1 m2 us loc mod_and_grp env warns
94 = case splitUniqSupply us of { (s1, s2) ->
95 case (m1 s1 loc mod_and_grp env warns) of { (result1, warns1) ->
96 case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
97 (combiner result1 result2, warns2) }}}
99 returnDs :: a -> DsM a
100 returnDs result us loc mod_and_grp env warns = (result, warns)
102 listDs :: [DsM a] -> DsM [a]
103 listDs [] = returnDs []
106 listDs xs `thenDs` \ rs ->
109 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
111 mapDs f [] = returnDs []
113 = f x `thenDs` \ r ->
114 mapDs f xs `thenDs` \ rs ->
117 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
119 mapAndUnzipDs f [] = returnDs ([], [])
120 mapAndUnzipDs f (x:xs)
121 = f x `thenDs` \ (r1, r2) ->
122 mapAndUnzipDs f xs `thenDs` \ (rs1, rs2) ->
123 returnDs (r1:rs1, r2:rs2)
125 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
127 zipWithDs f [] [] = returnDs []
128 zipWithDs f (x:xs) (y:ys)
129 = f x y `thenDs` \ r ->
130 zipWithDs f xs ys `thenDs` \ rs ->
132 -- Note: crashes if lists not equal length (like zipWithEqual)
135 And all this mysterious stuff is so we can occasionally reach out and
136 grab one or more names. @newLocalDs@ isn't exported---exported
137 functions are defined with it. The difference in name-strings makes
138 it easier to read debugging output.
140 newLocalDs :: FAST_STRING -> Type -> DsM Id
141 newLocalDs nm ty us loc mod_and_grp env warns
142 = case (getUnique us) of { assigned_uniq ->
143 (mkSysLocal nm assigned_uniq ty loc, warns) }
145 newSysLocalDs = newLocalDs SLIT("ds")
146 newSysLocalsDs tys = mapDs (newLocalDs SLIT("ds")) tys
147 newFailLocalDs = newLocalDs SLIT("fail")
149 duplicateLocalDs :: Id -> DsM Id
150 duplicateLocalDs old_local us loc mod_and_grp env warns
151 = case (getUnique us) of { assigned_uniq ->
152 (mkIdWithNewUniq old_local assigned_uniq, warns) }
154 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
155 cloneTyVarsDs tyvars us loc mod_and_grp env warns
156 = case (getUniques (length tyvars) us) of { uniqs ->
157 (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
161 newTyVarsDs :: [TyVar] -> DsM [TyVar]
163 newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
164 = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
165 (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
168 We can also reach out and either set/grab location information from
169 the @SrcLoc@ being carried around.
171 uniqSMtoDsM :: UniqSM a -> DsM a
173 uniqSMtoDsM u_action us loc mod_and_grp env warns
174 = (u_action us, warns)
176 getSrcLocDs :: DsM (String, String)
177 getSrcLocDs us loc mod_and_grp env warns
178 = case (unpackSrcLoc loc) of { (x,y) ->
179 ((_UNPK_ x, _UNPK_ y), warns) }
181 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
182 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
183 = expr us new_loc mod_and_grp env warns
185 dsShadowError :: DsMatchContext -> DsM ()
186 dsShadowError cxt us loc mod_and_grp env warns
187 = ((), warns `snocBag` cxt)
191 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
192 getModuleAndGroupDs us loc mod_and_grp env warns
193 = (mod_and_grp, warns)
197 type DsIdEnv = IdEnv CoreExpr
199 extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
201 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
202 = case splitUniqSupply us of { (s1, s2) ->
204 revised_pairs = subst_all pairs s1
206 then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
209 subst_all pairs = mapUs subst pairs
212 = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr ->
213 returnUs (v, new_expr)
215 lookupEnvDs :: Id -> DsM (Maybe CoreExpr)
216 lookupEnvDs id us loc mod_and_grp env warns
217 = (lookupIdEnv env id, warns)
218 -- Note: we don't assert anything about the Id
219 -- being looked up. There's not really anything
220 -- much to say about it. (WDP 94/06)
222 lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
223 lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
224 = (case (lookupIdEnv env id) of
229 lookupId :: [(Id, a)] -> Id -> a
231 = assoc "lookupId" env id
234 %************************************************************************
236 %* type synonym EquationInfo and access functions for its pieces *
238 %************************************************************************
242 = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
252 pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty
253 pprDsWarnings sty warns
254 = ppAboves (map pp_cxt (bagToList warns))
256 pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what")
257 pp_cxt (DsMatchContext kind pats loc)
258 = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
259 4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:"))
260 4 (pp_match kind pats))
262 pp_match (FunMatch fun) pats
263 = ppHang (ppr sty fun)
264 4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")])
266 pp_match CaseMatch pats
267 = ppHang (ppPStr SLIT("in a case alternative:"))
268 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
270 pp_match PatBindMatch pats
271 = ppHang (ppPStr SLIT("in a pattern binding:"))
272 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
274 pp_match LambdaMatch pats
275 = ppHang (ppPStr SLIT("in a lambda abstraction:"))
276 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
278 pp_match DoBindMatch pats
279 = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
280 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
282 pp_arrow_dotdotdot = ppPStr SLIT("-> ...")