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,
22 dsShadowWarn, dsIncompleteWarn,
24 DsMatchContext(..), DsMatchKind(..), pprDsWarnings,
25 DsWarnFlavour -- Nuke with 1.4
31 import Bag ( emptyBag, snocBag, bagToList, Bag )
32 import CmdLineOpts ( opt_SccGroup, opt_PprUserLength )
33 import CoreSyn ( SYN_IE(CoreExpr) )
34 import CoreUtils ( substCoreExpr )
35 import HsSyn ( OutPat )
36 import Id ( mkSysLocal, mkIdWithNewUniq,
37 lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv),
40 import PprType ( GenType, GenTyVar )
41 import Outputable ( pprQuote, Outputable(..), PprStyle(..) )
43 import SrcLoc ( noSrcLoc, SrcLoc )
44 import TcHsSyn ( SYN_IE(TypecheckedPat) )
45 import Type ( SYN_IE(Type) )
46 import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-}, SYN_IE(TyVar) )
47 import Unique ( Unique{-instances-} )
48 import UniqSupply ( splitUniqSupply, getUnique, getUniques,
49 mapUs, thenUs, returnUs, SYN_IE(UniqSM),
51 import Util ( assoc, mapAccumL, zipWithEqual, panic )
56 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
57 a @UniqueSupply@ and some annotations, which
58 presumably include source-file location information:
62 -> SrcLoc -- to put in pattern-matching error msgs
63 -> (FAST_STRING, FAST_STRING) -- "module"+"group" : for SCC profiling
66 -> (result, DsWarnings)
68 type DsWarnings = Bag (DsWarnFlavour, DsMatchContext)
69 -- The desugarer reports matches which are
70 -- completely shadowed or incomplete patterns
73 {-# INLINE returnDs #-}
75 -- initDs returns the UniqSupply out the end (not just the result)
79 -> FAST_STRING -- module name: for profiling; (group name: from switches)
83 initDs init_us env mod_name action
84 = action init_us noSrcLoc module_and_group env emptyBag
86 module_and_group = (mod_name, grp_name)
87 grp_name = case opt_SccGroup of
89 Nothing -> mod_name -- default: module name
91 thenDs :: DsM a -> (a -> DsM b) -> DsM b
92 andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
94 thenDs m1 m2 us loc mod_and_grp env warns
95 = case splitUniqSupply us of { (s1, s2) ->
96 case (m1 s1 loc mod_and_grp env warns) of { (result, warns1) ->
97 m2 result s2 loc mod_and_grp env warns1}}
99 andDs combiner m1 m2 us loc mod_and_grp env warns
100 = case splitUniqSupply us of { (s1, s2) ->
101 case (m1 s1 loc mod_and_grp env warns) of { (result1, warns1) ->
102 case (m2 s2 loc mod_and_grp env warns1) of { (result2, warns2) ->
103 (combiner result1 result2, warns2) }}}
105 returnDs :: a -> DsM a
106 returnDs result us loc mod_and_grp env warns = (result, warns)
108 listDs :: [DsM a] -> DsM [a]
109 listDs [] = returnDs []
112 listDs xs `thenDs` \ rs ->
115 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
117 mapDs f [] = returnDs []
119 = f x `thenDs` \ r ->
120 mapDs f xs `thenDs` \ rs ->
123 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
125 mapAndUnzipDs f [] = returnDs ([], [])
126 mapAndUnzipDs f (x:xs)
127 = f x `thenDs` \ (r1, r2) ->
128 mapAndUnzipDs f xs `thenDs` \ (rs1, rs2) ->
129 returnDs (r1:rs1, r2:rs2)
131 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
133 zipWithDs f [] ys = returnDs []
134 zipWithDs f (x:xs) (y:ys)
135 = f x y `thenDs` \ r ->
136 zipWithDs f xs ys `thenDs` \ rs ->
140 And all this mysterious stuff is so we can occasionally reach out and
141 grab one or more names. @newLocalDs@ isn't exported---exported
142 functions are defined with it. The difference in name-strings makes
143 it easier to read debugging output.
146 newLocalDs :: FAST_STRING -> Type -> DsM Id
147 newLocalDs nm ty us loc mod_and_grp env warns
148 = case (getUnique us) of { assigned_uniq ->
149 (mkSysLocal nm assigned_uniq ty loc, warns) }
151 newSysLocalDs = newLocalDs SLIT("ds")
152 newSysLocalsDs tys = mapDs (newLocalDs SLIT("ds")) tys
153 newFailLocalDs = newLocalDs SLIT("fail")
155 duplicateLocalDs :: Id -> DsM Id
156 duplicateLocalDs old_local us loc mod_and_grp env warns
157 = case (getUnique us) of { assigned_uniq ->
158 (mkIdWithNewUniq old_local assigned_uniq, warns) }
160 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
161 cloneTyVarsDs tyvars us loc mod_and_grp env warns
162 = case (getUniques (length tyvars) us) of { uniqs ->
163 (zipWithEqual "cloneTyVarsDs" cloneTyVar tyvars uniqs, warns) }
167 newTyVarsDs :: [TyVar] -> DsM [TyVar]
169 newTyVarsDs tyvar_tmpls us loc mod_and_grp env warns
170 = case (getUniques (length tyvar_tmpls) us) of { uniqs ->
171 (zipWithEqual "newTyVarsDs" cloneTyVar tyvar_tmpls uniqs, warns) }
174 We can also reach out and either set/grab location information from
175 the @SrcLoc@ being carried around.
177 uniqSMtoDsM :: UniqSM a -> DsM a
179 uniqSMtoDsM u_action us loc mod_and_grp env warns
180 = (u_action us, warns)
182 getSrcLocDs :: DsM SrcLoc
183 getSrcLocDs us loc mod_and_grp env warns
186 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
187 putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
188 = expr us new_loc mod_and_grp env warns
190 dsShadowWarn :: DsMatchContext -> DsM ()
191 dsShadowWarn cxt us loc mod_and_grp env warns
192 = ((), warns `snocBag` (Shadowed, cxt))
194 dsIncompleteWarn :: DsMatchContext -> DsM ()
195 dsIncompleteWarn cxt us loc mod_and_grp env warns
196 = ((), warns `snocBag` (Incomplete, cxt))
200 getModuleAndGroupDs :: DsM (FAST_STRING, FAST_STRING)
201 getModuleAndGroupDs us loc mod_and_grp env warns
202 = (mod_and_grp, warns)
206 type DsIdEnv = IdEnv Id
208 extendEnvDs :: [(Id, Id)] -> DsM a -> DsM a
210 extendEnvDs pairs then_do us loc mod_and_grp old_env warns
211 = then_do us loc mod_and_grp (growIdEnvList old_env pairs) warns
213 lookupEnvDs :: Id -> DsM Id
214 lookupEnvDs id us loc mod_and_grp env warns
215 = (case (lookupIdEnv env id) of
221 %************************************************************************
223 %* type synonym EquationInfo and access functions for its pieces *
225 %************************************************************************
228 data DsWarnFlavour = Shadowed | Incomplete deriving ()
231 = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
243 pprDsWarnings :: PprStyle -> DsWarnings -> Doc
244 pprDsWarnings sty warns
245 = vcat (map pp_warn (bagToList warns))
247 pp_warn (flavour, NoMatchContext) = sep [ptext SLIT("Warning: Some match is"),
249 Shadowed -> ptext SLIT("shadowed")
250 Incomplete -> ptext SLIT("possibly incomplete")]
252 pp_warn (flavour, DsMatchContext kind pats loc)
253 = hang (hcat [ppr (PprForUser opt_PprUserLength) loc, ptext SLIT(": ")])
255 4 (pp_match kind pats))
257 msg = case flavour of
258 Shadowed -> ptext SLIT("Warning: Pattern match(es) completely overlapped")
259 Incomplete -> ptext SLIT("Warning: Possibly incomplete patterns")
261 pp_match (FunMatch fun) pats
262 = hsep [ptext SLIT("in the definition of function"), ppr sty fun]
264 pp_match CaseMatch pats
265 = hang (ptext SLIT("in a group of case alternatives beginning:"))
268 pp_match PatBindMatch pats
269 = hang (ptext SLIT("in a pattern binding:"))
272 pp_match LambdaMatch pats
273 = hang (ptext SLIT("in a lambda abstraction:"))
276 pp_match DoBindMatch pats
277 = hang (ptext SLIT("in a `do' pattern binding:"))
280 ppr_pats pats = pprQuote sty $ \ sty ->
281 sep [sep (map (ppr sty) pats), ptext SLIT("-> ...")]