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 ( SYN_IE(CoreExpr) )
32 import CoreUtils ( substCoreExpr )
33 import HsSyn ( OutPat )
34 import Id ( mkSysLocal, mkIdWithNewUniq,
35 lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv)
37 import PprType ( GenType, GenTyVar )
38 import PprStyle ( PprStyle(..) )
40 import SrcLoc ( noSrcLoc, SrcLoc )
41 import TcHsSyn ( SYN_IE(TypecheckedPat) )
42 import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
43 import Unique ( Unique{-instances-} )
44 import UniqSupply ( splitUniqSupply, getUnique, getUniques,
45 mapUs, thenUs, returnUs, SYN_IE(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 noSrcLoc 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 SrcLoc
177 getSrcLocDs us loc mod_and_grp env warns
180 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
181 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
182 = expr us new_loc mod_and_grp env warns
184 dsShadowError :: DsMatchContext -> DsM ()
185 dsShadowError cxt us loc mod_and_grp env warns
186 = ((), warns `snocBag` cxt)
190 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
191 getModuleAndGroupDs us loc mod_and_grp env warns
192 = (mod_and_grp, warns)
196 type DsIdEnv = IdEnv CoreExpr
198 extendEnvDs :: [(Id, CoreExpr)] -> DsM a -> DsM a
200 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
201 = case splitUniqSupply us of { (s1, s2) ->
203 revised_pairs = subst_all pairs s1
205 then_do s2 loc mod_and_grp (growIdEnvList old_env revised_pairs) warns
208 subst_all pairs = mapUs subst pairs
211 = substCoreExpr old_env nullTyVarEnv expr `thenUs` \ new_expr ->
212 returnUs (v, new_expr)
214 lookupEnvDs :: Id -> DsM (Maybe CoreExpr)
215 lookupEnvDs id us loc mod_and_grp env warns
216 = (lookupIdEnv env id, warns)
217 -- Note: we don't assert anything about the Id
218 -- being looked up. There's not really anything
219 -- much to say about it. (WDP 94/06)
221 lookupEnvWithDefaultDs :: Id -> CoreExpr -> DsM CoreExpr
222 lookupEnvWithDefaultDs id deflt us loc mod_and_grp env warns
223 = (case (lookupIdEnv env id) of
228 lookupId :: [(Id, a)] -> Id -> a
230 = assoc "lookupId" env id
233 %************************************************************************
235 %* type synonym EquationInfo and access functions for its pieces *
237 %************************************************************************
241 = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
251 pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty
252 pprDsWarnings sty warns
253 = ppAboves (map pp_cxt (bagToList warns))
255 pp_cxt NoMatchContext = ppPStr SLIT("Some match is shadowed; I don't know what")
256 pp_cxt (DsMatchContext kind pats loc)
257 = ppHang (ppBesides [ppr PprForUser loc, ppPStr SLIT(": ")])
258 4 (ppHang (ppPStr SLIT("Pattern match(es) completely overlapped:"))
259 4 (pp_match kind pats))
261 pp_match (FunMatch fun) pats
262 = ppHang (ppr sty fun)
263 4 (ppSep [ppSep (map (ppr sty) pats), ppPStr SLIT("= ...")])
265 pp_match CaseMatch pats
266 = ppHang (ppPStr SLIT("in a case alternative:"))
267 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
269 pp_match PatBindMatch pats
270 = ppHang (ppPStr SLIT("in a pattern binding:"))
271 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
273 pp_match LambdaMatch pats
274 = ppHang (ppPStr SLIT("in a lambda abstraction:"))
275 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
277 pp_match DoBindMatch pats
278 = ppHang (ppPStr SLIT("in a `do' pattern binding:"))
279 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot])
281 pp_arrow_dotdotdot = ppPStr SLIT("-> ...")