2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
9 initDs, returnDs, thenDs, andDs, mapDs, listDs,
10 mapAndUnzipDs, zipWithDs, foldlDs,
12 newTyVarsDs, cloneTyVarsDs,
13 duplicateLocalDs, newSysLocalDs, newSysLocalsDs,
15 getSrcLocDs, putSrcLocDs,
23 DsMatchContext(..), DsMatchKind(..), pprDsWarnings
26 #include "HsVersions.h"
28 import Bag ( emptyBag, snocBag, bagToList, Bag )
29 import ErrUtils ( WarnMsg, pprBagOfErrors )
30 import HsSyn ( OutPat )
31 import Id ( mkUserLocal, mkSysLocal, setIdUnique, Id )
32 import Name ( Module, Name, maybeWiredInIdName )
33 import Var ( TyVar, setTyVarUnique )
36 import SrcLoc ( noSrcLoc, SrcLoc )
37 import TcHsSyn ( TypecheckedPat )
38 import TcEnv ( ValueEnv )
40 import UniqSupply ( initUs, splitUniqSupply, uniqFromSupply, uniqsFromSupply,
42 import Unique ( Unique )
43 import UniqFM ( lookupWithDefaultUFM )
44 import Util ( zipWithEqual )
49 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
50 a @UniqueSupply@ and some annotations, which
51 presumably include source-file location information:
56 -> SrcLoc -- to put in pattern-matching error msgs
57 -> (Module, Group) -- module + group name : for SCC profiling
59 -> (result, DsWarnings)
61 type DsWarnings = Bag WarnMsg -- The desugarer reports matches which are
62 -- completely shadowed or incomplete patterns
64 type Group = FAST_STRING
68 {-# INLINE returnDs #-}
70 -- initDs returns the UniqSupply out the end (not just the result)
74 -> (Module, Group) -- module name: for profiling; (group name: from switches)
78 initDs init_us genv module_and_group action
79 = action init_us genv noSrcLoc module_and_group emptyBag
81 thenDs :: DsM a -> (a -> DsM b) -> DsM b
82 andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a
84 thenDs m1 m2 us genv loc mod_and_grp warns
85 = case splitUniqSupply us of { (s1, s2) ->
86 case (m1 s1 genv loc mod_and_grp warns) of { (result, warns1) ->
87 m2 result s2 genv loc mod_and_grp warns1}}
89 andDs combiner m1 m2 us genv loc mod_and_grp warns
90 = case splitUniqSupply us of { (s1, s2) ->
91 case (m1 s1 genv loc mod_and_grp warns) of { (result1, warns1) ->
92 case (m2 s2 genv loc mod_and_grp warns1) of { (result2, warns2) ->
93 (combiner result1 result2, warns2) }}}
95 returnDs :: a -> DsM a
96 returnDs result us genv loc mod_and_grp warns = (result, warns)
98 listDs :: [DsM a] -> DsM [a]
99 listDs [] = returnDs []
102 listDs xs `thenDs` \ rs ->
105 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
107 mapDs f [] = returnDs []
109 = f x `thenDs` \ r ->
110 mapDs f xs `thenDs` \ rs ->
113 foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a
115 foldlDs k z [] = returnDs z
116 foldlDs k z (x:xs) = k z x `thenDs` \ r ->
119 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
121 mapAndUnzipDs f [] = returnDs ([], [])
122 mapAndUnzipDs f (x:xs)
123 = f x `thenDs` \ (r1, r2) ->
124 mapAndUnzipDs f xs `thenDs` \ (rs1, rs2) ->
125 returnDs (r1:rs1, r2:rs2)
127 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
129 zipWithDs f [] ys = returnDs []
130 zipWithDs f (x:xs) (y:ys)
131 = f x y `thenDs` \ r ->
132 zipWithDs f xs ys `thenDs` \ rs ->
136 And all this mysterious stuff is so we can occasionally reach out and
137 grab one or more names. @newLocalDs@ isn't exported---exported
138 functions are defined with it. The difference in name-strings makes
139 it easier to read debugging output.
142 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
143 newSysLocalDs ty us genv loc mod_and_grp warns
144 = case uniqFromSupply us of { assigned_uniq ->
145 (mkSysLocal SLIT("ds") assigned_uniq ty, warns) }
147 newSysLocalsDs tys = mapDs newSysLocalDs tys
149 newFailLocalDs ty us genv loc mod_and_grp warns
150 = case uniqFromSupply us of { assigned_uniq ->
151 (mkSysLocal SLIT("fail") assigned_uniq ty, warns) }
152 -- The UserLocal bit just helps make the code a little clearer
154 getUniqueDs :: DsM Unique
155 getUniqueDs us genv loc mod_and_grp warns
156 = case (uniqFromSupply us) of { assigned_uniq ->
157 (assigned_uniq, warns) }
159 duplicateLocalDs :: Id -> DsM Id
160 duplicateLocalDs old_local us genv loc mod_and_grp warns
161 = case uniqFromSupply us of { assigned_uniq ->
162 (setIdUnique old_local assigned_uniq, warns) }
164 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
165 cloneTyVarsDs tyvars us genv loc mod_and_grp warns
166 = case uniqsFromSupply (length tyvars) us of { uniqs ->
167 (zipWithEqual "cloneTyVarsDs" setTyVarUnique tyvars uniqs, warns) }
171 newTyVarsDs :: [TyVar] -> DsM [TyVar]
173 newTyVarsDs tyvar_tmpls us genv loc mod_and_grp warns
174 = case uniqsFromSupply (length tyvar_tmpls) us of { uniqs ->
175 (zipWithEqual "newTyVarsDs" setTyVarUnique tyvar_tmpls uniqs, warns) }
178 We can also reach out and either set/grab location information from
179 the @SrcLoc@ being carried around.
181 uniqSMtoDsM :: UniqSM a -> DsM a
183 uniqSMtoDsM u_action us genv loc mod_and_grp warns
184 = (initUs us u_action, warns)
186 getSrcLocDs :: DsM SrcLoc
187 getSrcLocDs us genv loc mod_and_grp warns
190 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
191 putSrcLocDs new_loc expr us genv old_loc mod_and_grp warns
192 = expr us genv new_loc mod_and_grp warns
194 dsWarn :: WarnMsg -> DsM ()
195 dsWarn warn us genv loc mod_and_grp warns = ((), warns `snocBag` warn)
200 getModuleAndGroupDs :: DsM (Module, Group)
201 getModuleAndGroupDs us genv loc mod_and_grp warns
202 = (mod_and_grp, warns)
206 dsLookupGlobalValue :: Name -> DsM Id
207 dsLookupGlobalValue name us genv loc mod_and_grp warns
208 = case maybeWiredInIdName name of
209 Just id -> (id, warns)
210 Nothing -> (lookupWithDefaultUFM genv def name, warns)
212 def = pprPanic "tcLookupGlobalValue:" (ppr name)
216 %************************************************************************
218 %* type synonym EquationInfo and access functions for its pieces *
220 %************************************************************************
224 = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc
238 pprDsWarnings :: DsWarnings -> SDoc
239 pprDsWarnings warns = pprBagOfErrors warns