3 TcM(..), NF_TcM(..), TcDown, TcEnv,
7 returnTc, thenTc, thenTc_, mapTc, listTc,
8 foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
9 mapBagTc, fixTc, tryTc,
11 returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
12 listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
14 checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
15 failTc, warnTc, recoverTc, recoverNF_Tc,
18 tcGetDefaultTys, tcSetDefaultTys,
19 tcGetUnique, tcGetUniques,
21 tcAddSrcLoc, tcGetSrcLoc,
22 tcAddErrCtxtM, tcSetErrCtxtM,
23 tcAddErrCtxt, tcSetErrCtxt,
25 tcNewMutVar, tcReadMutVar, tcWriteMutVar,
30 MutableVar(..), _MutableArray
34 import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
36 import Type ( Type(..), GenType )
37 import TyVar ( TyVar(..), GenTyVar )
38 import Usage ( Usage(..), GenUsage )
39 import ErrUtils ( Error(..), Message(..), ErrCtxt(..),
40 TcWarning(..), TcError(..), mkTcErr )
44 import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
46 import Bag ( Bag, emptyBag, isEmptyBag,
47 foldBag, unitBag, unionBags, snocBag )
48 import FiniteMap ( FiniteMap, emptyFM )
49 import Pretty ( Pretty(..), PrettyRep )
50 import PprStyle ( PprStyle )
51 import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
52 import Maybes ( MaybeErr(..) )
54 import ProtoName ( ProtoName )
55 import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
56 import UniqFM ( UniqFM, emptyUFM )
57 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
58 import Unique ( Unique )
61 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
65 \section{TcM, NF_TcM: the type checker monads}
66 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
69 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
70 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
74 -- With a builtin polymorphic type for _runSST the type for
75 -- initTc should use TcM s r instead of TcM _RealWorld r
79 -> MaybeErr (r, Bag TcWarning)
80 (Bag TcError, Bag TcWarning)
84 newMutVarSST us `thenSST` \ us_var ->
85 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
86 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
88 init_down = TcDown [] us_var
91 init_env = initEnv tvs_var
94 (\_ -> returnSST Nothing)
95 (do_this init_down init_env `thenFSST` \ res ->
96 returnFSST (Just res))
97 `thenSST` \ maybe_res ->
98 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
99 case (maybe_res, isEmptyBag errs) of
100 (Just res, True) -> returnSST (Succeeded (res, warns))
101 _ -> returnSST (Failed (errs, warns))
104 thenNF_Tc :: NF_TcM s a
105 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
106 -> TcDown s -> TcEnv s -> State# s -> b
107 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
108 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
110 thenNF_Tc m k down env
111 = m down env `thenSST` \ r ->
114 thenNF_Tc_ :: NF_TcM s a
115 -> (TcDown s -> TcEnv s -> State# s -> b)
116 -> TcDown s -> TcEnv s -> State# s -> b
117 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
118 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
120 thenNF_Tc_ m k down env
121 = m down env `thenSST_` k down env
123 returnNF_Tc :: a -> NF_TcM s a
124 returnNF_Tc v down env = returnSST v
126 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
127 mapNF_Tc f [] = returnNF_Tc []
128 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
129 mapNF_Tc f xs `thenNF_Tc` \ rs ->
132 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
133 listNF_Tc [] = returnNF_Tc []
134 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
135 listNF_Tc xs `thenNF_Tc` \ rs ->
138 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
140 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
141 b2 `thenNF_Tc` \ r2 ->
142 returnNF_Tc (unionBags r1 r2))
143 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
144 (returnNF_Tc emptyBag)
147 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
148 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
149 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
150 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
151 returnNF_Tc (r1:rs1, r2:rs2)
153 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
155 = m down env `thenFSST` \ r ->
158 thenTc_ :: TcM s a -> TcM s b -> TcM s b
160 = m down env `thenFSST_` k down env
162 returnTc :: a -> TcM s a
163 returnTc val down env = returnFSST val
165 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
166 mapTc f [] = returnTc []
167 mapTc f (x:xs) = f x `thenTc` \ r ->
168 mapTc f xs `thenTc` \ rs ->
171 listTc :: [TcM s a] -> TcM s [a]
172 listTc [] = returnTc []
173 listTc (x:xs) = x `thenTc` \ r ->
174 listTc xs `thenTc` \ rs ->
177 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
178 foldrTc k z [] = returnTc z
179 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
182 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
183 foldlTc k z [] = returnTc z
184 foldlTc k z (x:xs) = k z x `thenTc` \r ->
187 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
188 mapAndUnzipTc f [] = returnTc ([],[])
189 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
190 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
191 returnTc (r1:rs1, r2:rs2)
193 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
194 mapAndUnzip3Tc f [] = returnTc ([],[],[])
195 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
196 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
197 returnTc (r1:rs1, r2:rs2, r3:rs3)
199 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
201 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
203 returnTc (unionBags r1 r2))
204 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
208 fixTc :: (a -> TcM s a) -> TcM s a
209 fixTc m env down = fixFSST (\ loop -> m loop env down)
212 @forkNF_Tc@ runs a sub-typecheck action in a separate state thread.
213 This elegantly ensures that it can't zap any type variables that
214 belong to the main thread. We throw away any error messages!
217 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
219 = forkTcDown down `thenSST` \ down' ->
220 returnSST (_runSST (m down' (forkTcEnv env)))
227 failTc :: Message -> TcM s a
228 failTc err_msg down env
229 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
230 foldr thenNF_Tc_ (returnNF_Tc []) ctxt down env `thenSST` \ ctxt_msgs ->
232 err = mkTcErr loc ctxt_msgs err_msg
234 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
237 errs_var = getTcErrs down
238 ctxt = getErrCtxt down
241 warnTc :: Bool -> Message -> NF_TcM s ()
242 warnTc warn_if_true warn down env
243 = if warn_if_true then
244 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
245 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
250 errs_var = getTcErrs down
252 recoverTc :: TcM s r -> TcM s r -> TcM s r
253 recoverTc recover m down env
254 = recoverFSST (\ _ -> recover down env) (m down env)
256 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
257 recoverNF_Tc recover m down env
258 = recoverSST (\ _ -> recover down env) (m down env)
260 -- (tryTc r m) tries m; if it succeeds it returns it,
261 -- otherwise it returns r. Any error messages added by m are discarded,
262 -- whether or not m succeeds.
263 tryTc :: TcM s r -> TcM s r -> TcM s r
264 tryTc recover m down env
265 = recoverFSST (\ _ -> recover down env) $
266 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
267 m (setTcErrs down new_errs_var) env
269 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
270 checkTc True err = returnTc ()
271 checkTc False err = failTc err
273 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
274 checkTcM True err = returnTc ()
275 checkTcM False err = err
277 checkMaybeTc :: Maybe val -> Message -> TcM s val
278 checkMaybeTc (Just val) err = returnTc val
279 checkMaybeTc Nothing err = failTc err
281 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
282 checkMaybeTcM (Just val) err = returnTc val
283 checkMaybeTcM Nothing err = err
289 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
290 tcNewMutVar val down env = newMutVarSST val
292 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
293 tcWriteMutVar var val down env = writeMutVarSST var val
295 tcReadMutVar :: MutableVar s a -> NF_TcM s a
296 tcReadMutVar var down env = readMutVarSST var
303 tcGetEnv :: NF_TcM s (TcEnv s)
304 tcGetEnv down env = returnSST env
306 tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
307 tcSetEnv new_env m down old_env = m down new_env
314 tcGetDefaultTys :: NF_TcM s [Type]
315 tcGetDefaultTys down env = returnSST (getDefaultTys down)
317 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
318 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
320 tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
321 tcAddSrcLoc loc m down env = m (setLoc down loc) env
323 tcGetSrcLoc :: NF_TcM s SrcLoc
324 tcGetSrcLoc down env = returnSST (getLoc down)
326 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
327 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
328 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
330 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
331 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
332 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
339 tcGetUnique :: NF_TcM s Unique
341 = readMutVarSST u_var `thenSST` \ uniq_supply ->
343 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
344 uniq = getUnique uniq_s
346 writeMutVarSST u_var new_uniq_supply `thenSST_`
349 u_var = getUniqSupplyVar down
351 tcGetUniques :: Int -> NF_TcM s [Unique]
352 tcGetUniques n down env
353 = readMutVarSST u_var `thenSST` \ uniq_supply ->
355 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
356 uniqs = getUniques n uniq_s
358 writeMutVarSST u_var new_uniq_supply `thenSST_`
361 u_var = getUniqSupplyVar down
371 [Type] -- Types used for defaulting
373 (MutableVar s UniqSupply) -- Unique supply
375 SrcLoc -- Source location
376 (ErrCtxt s) -- Error context
377 (MutableVar s (Bag TcWarning,
380 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
381 -- to deal with bound type variables just before error
382 -- message construction
385 -- These selectors are *local* to TcMonad.lhs
388 getTcErrs (TcDown def us loc ctxt errs) = errs
389 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
391 getDefaultTys (TcDown def us loc ctxt errs) = def
392 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
394 getLoc (TcDown def us loc ctxt errs) = loc
395 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
397 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
399 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
400 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
401 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
404 @forkTcDown@ makes a new "down" blob for a lazily-computed fork
408 forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
409 = -- Get a fresh unique supply
410 readMutVarSST u_var `thenSST` \ us ->
412 (us1, us2) = splitUniqSupply us
414 writeMutVarSST u_var us1 `thenSST_`
416 -- Make fresh MutVars for the unique supply and errors
417 newMutVarSST us2 `thenSST` \ u_var' ->
418 newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' ->
421 returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
429 rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error)
431 rn4MtoTcM name_funs rn_action down env
432 = readMutVarSST u_var `thenSST` \ uniq_supply ->
434 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
436 writeMutVarSST u_var new_uniq_supply `thenSST_`
439 = rn_action name_funs emptyFM emptyBag uniq_s mkUnknownSrcLoc
441 returnSST (rn_result, rn_errs)
443 u_var = getUniqSupplyVar down