3 TcM, NF_TcM, TcDown, TcEnv,
7 returnTc, thenTc, thenTc_, mapTc, listTc,
8 foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
9 mapBagTc, fixTc, tryTc, getErrsTc,
13 returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
14 fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
16 listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
18 checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
19 failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
22 tcGetDefaultTys, tcSetDefaultTys,
23 tcGetUnique, tcGetUniques,
25 tcAddSrcLoc, tcGetSrcLoc,
26 tcAddErrCtxtM, tcSetErrCtxtM,
27 tcAddErrCtxt, tcSetErrCtxt,
29 tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
35 #include "HsVersions.h"
37 import {-# SOURCE #-} TcEnv ( TcEnv )
39 import Type ( Type, GenType )
40 import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
41 import CmdLineOpts ( opt_PprStyle_All )
44 import Bag ( Bag, emptyBag, isEmptyBag,
45 foldBag, unitBag, unionBags, snocBag )
46 import SrcLoc ( SrcLoc, noSrcLoc )
47 import UniqFM ( UniqFM, emptyUFM )
48 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply,
50 import Unique ( Unique )
54 import GlaExts ( State#, RealWorld )
57 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
61 \section{TcM, NF_TcM: the type checker monads}
62 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
65 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
66 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
70 -- With a builtin polymorphic type for runSST the type for
71 -- initTc should use TcM s r instead of TcM RealWorld r
73 -- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
76 -> (TcRef RealWorld (UniqFM a) -> TcEnv RealWorld)
78 -> (Maybe r, Bag WarnMsg, Bag ErrMsg)
80 initTc us initenv do_this
82 newMutVarSST us `thenSST` \ us_var ->
83 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
84 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
86 init_down = TcDown [] us_var
89 init_env = initenv tvs_var
92 (\_ -> returnSST Nothing)
93 (do_this init_down init_env `thenFSST` \ res ->
94 returnFSST (Just res))
95 `thenSST` \ maybe_res ->
96 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
97 returnSST (maybe_res, warns, errs)
100 thenNF_Tc :: NF_TcM s a
101 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
102 -> TcDown s -> TcEnv s -> State# s -> b
103 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
104 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
106 thenNF_Tc m k down env
107 = m down env `thenSST` \ r ->
110 thenNF_Tc_ :: NF_TcM s a
111 -> (TcDown s -> TcEnv s -> State# s -> b)
112 -> TcDown s -> TcEnv s -> State# s -> b
113 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
114 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
116 thenNF_Tc_ m k down env
117 = m down env `thenSST_` k down env
119 returnNF_Tc :: a -> NF_TcM s a
120 returnNF_Tc v down env = returnSST v
122 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
123 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
125 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
126 mapNF_Tc f [] = returnNF_Tc []
127 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
128 mapNF_Tc f xs `thenNF_Tc` \ rs ->
131 foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
132 foldrNF_Tc k z [] = returnNF_Tc z
133 foldrNF_Tc k z (x:xs) = foldrNF_Tc k z xs `thenNF_Tc` \r ->
136 foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
137 foldlNF_Tc k z [] = returnNF_Tc z
138 foldlNF_Tc k z (x:xs) = k z x `thenNF_Tc` \r ->
141 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
142 listNF_Tc [] = returnNF_Tc []
143 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
144 listNF_Tc xs `thenNF_Tc` \ rs ->
147 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
149 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
150 b2 `thenNF_Tc` \ r2 ->
151 returnNF_Tc (unionBags r1 r2))
152 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
153 (returnNF_Tc emptyBag)
156 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
157 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
158 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
159 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
160 returnNF_Tc (r1:rs1, r2:rs2)
162 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
164 = m down env `thenFSST` \ r ->
167 thenTc_ :: TcM s a -> TcM s b -> TcM s b
169 = m down env `thenFSST_` k down env
171 returnTc :: a -> TcM s a
172 returnTc val down env = returnFSST val
174 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
175 mapTc f [] = returnTc []
176 mapTc f (x:xs) = f x `thenTc` \ r ->
177 mapTc f xs `thenTc` \ rs ->
180 listTc :: [TcM s a] -> TcM s [a]
181 listTc [] = returnTc []
182 listTc (x:xs) = x `thenTc` \ r ->
183 listTc xs `thenTc` \ rs ->
186 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
187 foldrTc k z [] = returnTc z
188 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
191 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
192 foldlTc k z [] = returnTc z
193 foldlTc k z (x:xs) = k z x `thenTc` \r ->
196 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
197 mapAndUnzipTc f [] = returnTc ([],[])
198 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
199 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
200 returnTc (r1:rs1, r2:rs2)
202 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
203 mapAndUnzip3Tc f [] = returnTc ([],[],[])
204 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
205 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
206 returnTc (r1:rs1, r2:rs2, r3:rs3)
208 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
210 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
212 returnTc (unionBags r1 r2))
213 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
217 fixTc :: (a -> TcM s a) -> TcM s a
218 fixTc m env down = fixFSST (\ loop -> m loop env down)
221 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
222 thread. Ideally, this elegantly ensures that it can't zap any type
223 variables that belong to the main thread. But alas, the environment
224 contains TyCon and Class environments that include (TcKind s) stuff,
225 which is a Royal Pain. By the time this fork stuff is used they'll
226 have been unified down so there won't be any kind variables, but we
227 can't express that in the current typechecker framework.
229 So we compromise and use unsafeInterleaveSST.
231 We throw away any error messages!
234 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
235 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
236 = -- Get a fresh unique supply
237 readMutVarSST u_var `thenSST` \ us ->
239 (us1, us2) = splitUniqSupply us
241 writeMutVarSST u_var us1 `thenSST_`
243 unsafeInterleaveSST (
244 newMutVarSST us2 `thenSST` \ us_var' ->
245 newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
246 newMutVarSST emptyUFM `thenSST` \ tv_var' ->
248 down' = TcDown deflts us_var' src_loc err_cxt err_var'
251 -- ToDo: optionally dump any error messages
259 getErrsTc :: NF_TcM s (Bag ErrMsg, Bag WarnMsg)
261 = readMutVarSST errs_var
263 errs_var = getTcErrs down
270 failWithTc :: Message -> TcM s a -- Add an error message and fail
272 = addErrTc err_msg `thenNF_Tc_`
275 addErrTc :: Message -> NF_TcM s () -- Add an error message but don't fail
276 addErrTc err_msg down env
277 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
278 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
280 err = addShortErrLocLine loc $
281 hang err_msg 4 (vcat (ctxt_to_use ctxt_msgs))
283 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
286 errs_var = getTcErrs down
287 ctxt = getErrCtxt down
290 warnTc :: Bool -> Message -> NF_TcM s ()
291 warnTc warn_if_true warn_msg down env
292 = if warn_if_true then
293 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
294 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
296 warn = addShortWarnLocLine loc $
297 hang warn_msg 4 (vcat (ctxt_to_use ctxt_msgs))
299 writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
304 errs_var = getTcErrs down
305 ctxt = getErrCtxt down
308 recoverTc :: TcM s r -> TcM s r -> TcM s r
309 recoverTc recover m down env
310 = recoverFSST (\ _ -> recover down env) (m down env)
312 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
313 recoverNF_Tc recover m down env
314 = recoverSST (\ _ -> recover down env) (m down env)
316 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
317 -- If m fails then (checkNoErrsTc m) fails.
318 -- If m succeeds, it checks whether m generated any errors messages
319 -- (it might have recovered internally)
320 -- If so, it fails too.
321 -- Regardless, any errors generated by m are propagated to the enclosing
324 checkNoErrsTc :: TcM s r -> TcM s r
325 checkNoErrsTc m down env
326 = newMutVarSST (emptyBag,emptyBag) `thenSST` \ m_errs_var ->
328 errs_var = getTcErrs down
330 = readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) ->
331 readMutVarSST errs_var `thenSST` \ (warns, errs) ->
332 writeMutVarSST errs_var (warns `unionBags` m_warns,
333 errs `unionBags` m_errs) `thenSST_`
337 recoverFSST propagate_errs $
339 m (setTcErrs down m_errs_var) env `thenFSST` \ result ->
341 -- Check that m has no errors; if it has internal recovery
342 -- mechanisms it might "succeed" but having found a bunch of
343 -- errors along the way.
344 readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) ->
345 if isEmptyBag m_errs then
348 failFSST () -- This triggers the recoverFSST
350 -- (tryTc r m) tries m; if it succeeds it returns it,
351 -- otherwise it returns r. Any error messages added by m are discarded,
352 -- whether or not m succeeds.
353 tryTc :: TcM s r -> TcM s r -> TcM s r
354 tryTc recover m down env
355 = recoverFSST (\ _ -> recover down env) $
357 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
358 m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
360 -- Check that m has no errors; if it has internal recovery
361 -- mechanisms it might "succeed" but having found a bunch of
362 -- errors along the way. If so we want tryTc to use
364 readMutVarSST new_errs_var `thenSST` \ (_,errs) ->
365 if isEmptyBag errs then
370 -- Run the thing inside, but throw away all its error messages.
371 -- discardErrsTc :: TcM s r -> TcM s r
372 -- discardErrsTc :: NF_TcM s r -> NF_TcM s r
373 discardErrsTc :: (TcDown s -> TcEnv s -> State# s -> a)
374 -> (TcDown s -> TcEnv s -> State# s -> a)
375 discardErrsTc m down env
376 = newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
377 m (setTcErrs down new_errs_var) env
379 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
380 checkTc True err = returnTc ()
381 checkTc False err = failWithTc err
383 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
384 checkTcM True err = returnTc ()
385 checkTcM False err = err
387 checkMaybeTc :: Maybe val -> Message -> TcM s val
388 checkMaybeTc (Just val) err = returnTc val
389 checkMaybeTc Nothing err = failWithTc err
391 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
392 checkMaybeTcM (Just val) err = returnTc val
393 checkMaybeTcM Nothing err = err
399 type TcRef s a = SSTRef s a
401 tcNewMutVar :: a -> NF_TcM s (TcRef s a)
402 tcNewMutVar val down env = newMutVarSST val
404 tcWriteMutVar :: TcRef s a -> a -> NF_TcM s ()
405 tcWriteMutVar var val down env = writeMutVarSST var val
407 tcReadMutVar :: TcRef s a -> NF_TcM s a
408 tcReadMutVar var down env = readMutVarSST var
415 tcGetEnv :: NF_TcM s (TcEnv s)
416 tcGetEnv down env = returnSST env
419 -> (TcDown s -> TcEnv s -> State# s -> b)
420 -> TcDown s -> TcEnv s -> State# s -> b
421 -- tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
422 -- tcSetEnv :: TcEnv s -> NF_TcM s a -> NF_TcM s a
424 tcSetEnv new_env m down old_env = m down new_env
431 tcGetDefaultTys :: NF_TcM s [Type]
432 tcGetDefaultTys down env = returnSST (getDefaultTys down)
434 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
435 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
437 -- tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
438 -- tcAddSrcLoc :: SrcLoc -> NF_TcM s a -> NF_TcM s a
439 tcAddSrcLoc :: SrcLoc -> (TcDown s -> env -> result)
440 -> (TcDown s -> env -> result)
441 tcAddSrcLoc loc m down env = m (setLoc down loc) env
443 tcGetSrcLoc :: NF_TcM s SrcLoc
444 tcGetSrcLoc down env = returnSST (getLoc down)
446 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
447 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
448 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
450 tcSetErrCtxt, tcAddErrCtxt
452 -> (TcDown s -> TcEnv s -> State# s -> b)
453 -> TcDown s -> TcEnv s -> State# s -> b
455 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
456 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
463 tcGetUnique :: NF_TcM s Unique
465 = readMutVarSST u_var `thenSST` \ uniq_supply ->
467 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
468 uniq = getUnique uniq_s
470 writeMutVarSST u_var new_uniq_supply `thenSST_`
473 u_var = getUniqSupplyVar down
475 tcGetUniques :: Int -> NF_TcM s [Unique]
476 tcGetUniques n down env
477 = readMutVarSST u_var `thenSST` \ uniq_supply ->
479 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
480 uniqs = getUniques n uniq_s
482 writeMutVarSST u_var new_uniq_supply `thenSST_`
485 u_var = getUniqSupplyVar down
487 uniqSMToTcM :: UniqSM a -> NF_TcM s a
488 uniqSMToTcM m down env
489 = readMutVarSST u_var `thenSST` \ uniq_supply ->
491 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
493 writeMutVarSST u_var new_uniq_supply `thenSST_`
494 returnSST (initUs uniq_s m)
496 u_var = getUniqSupplyVar down
506 [Type] -- Types used for defaulting
508 (TcRef s UniqSupply) -- Unique supply
510 SrcLoc -- Source location
511 (ErrCtxt s) -- Error context
512 (TcRef s (Bag WarnMsg,
515 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
516 -- to deal with bound type variables just before error
517 -- message construction
520 -- These selectors are *local* to TcMonad.lhs
523 getTcErrs (TcDown def us loc ctxt errs) = errs
524 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
526 getDefaultTys (TcDown def us loc ctxt errs) = def
527 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
529 getLoc (TcDown def us loc ctxt errs) = loc
530 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
532 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
534 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
535 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
536 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
546 type TcError = Message
547 type TcWarning = Message
549 ctxt_to_use ctxt | opt_PprStyle_All = ctxt
550 | otherwise = takeAtMost 3 ctxt
552 takeAtMost :: Int -> [a] -> [a]
555 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
557 arityErr kind name n m
558 = hsep [ ppr name, ptext SLIT("should have"),
559 n_arguments <> comma, text "but has been given", int m, char '.']
561 n_arguments | n == 0 = ptext SLIT("no arguments")
562 | n == 1 = ptext SLIT("1 argument")
563 | True = hsep [int n, ptext SLIT("arguments")]