2 #include "HsVersions.h"
5 SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv,
9 returnTc, thenTc, thenTc_, mapTc, listTc,
10 foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
11 mapBagTc, fixTc, tryTc, getErrsTc,
15 returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc,
17 listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
19 checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
20 failTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
23 tcGetDefaultTys, tcSetDefaultTys,
24 tcGetUnique, tcGetUniques,
26 tcAddSrcLoc, tcGetSrcLoc,
27 tcAddErrCtxtM, tcSetErrCtxtM,
28 tcAddErrCtxt, tcSetErrCtxt,
30 tcNewMutVar, tcReadMutVar, tcWriteMutVar,
32 SYN_IE(TcError), SYN_IE(TcWarning),
37 #if __GLASGOW_HASKELL__ == 201
39 #elif __GLASGOW_HASKELL__ == 201
48 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
49 IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
51 import {-# SOURCE #-} TcEnv ( TcEnv, initEnv )
52 import {-# SOURCE #-} TcType ( TcMaybe, TcTyVarSet )
55 import Type ( SYN_IE(Type), GenType )
56 import TyVar ( SYN_IE(TyVar), GenTyVar )
57 import Usage ( SYN_IE(Usage), GenUsage )
58 import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
59 import CmdLineOpts ( opt_PprStyle_All, opt_PprUserLength )
62 import Bag ( Bag, emptyBag, isEmptyBag,
63 foldBag, unitBag, unionBags, snocBag )
64 import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
65 import Maybes ( MaybeErr(..) )
66 import SrcLoc ( SrcLoc, noSrcLoc )
67 import UniqFM ( UniqFM, emptyUFM )
68 import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply,
69 SYN_IE(UniqSM), initUs )
70 import Unique ( Unique )
73 import Outputable ( PprStyle(..), Outputable(..) )
76 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
80 \section{TcM, NF_TcM: the type checker monads}
81 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
84 type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
85 type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
89 #if __GLASGOW_HASKELL__ >= 200
90 # define REAL_WORLD RealWorld
92 # define REAL_WORLD _RealWorld
95 -- With a builtin polymorphic type for runSST the type for
96 -- initTc should use TcM s r instead of TcM RealWorld r
100 -> MaybeErr (r, Bag Warning)
101 (Bag Error, Bag Warning)
105 newMutVarSST us `thenSST` \ us_var ->
106 newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
107 newMutVarSST emptyUFM `thenSST` \ tvs_var ->
109 init_down = TcDown [] us_var
112 init_env = initEnv tvs_var
115 (\_ -> returnSST Nothing)
116 (do_this init_down init_env `thenFSST` \ res ->
117 returnFSST (Just res))
118 `thenSST` \ maybe_res ->
119 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
120 case (maybe_res, isEmptyBag errs) of
121 (Just res, True) -> returnSST (Succeeded (res, warns))
122 _ -> returnSST (Failed (errs, warns))
125 thenNF_Tc :: NF_TcM s a
126 -> (a -> TcDown s -> TcEnv s -> State# s -> b)
127 -> TcDown s -> TcEnv s -> State# s -> b
128 -- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
129 -- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
131 thenNF_Tc m k down env
132 = m down env `thenSST` \ r ->
135 thenNF_Tc_ :: NF_TcM s a
136 -> (TcDown s -> TcEnv s -> State# s -> b)
137 -> TcDown s -> TcEnv s -> State# s -> b
138 -- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
139 -- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
141 thenNF_Tc_ m k down env
142 = m down env `thenSST_` k down env
144 returnNF_Tc :: a -> NF_TcM s a
145 returnNF_Tc v down env = returnSST v
147 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
148 fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
150 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
151 mapNF_Tc f [] = returnNF_Tc []
152 mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
153 mapNF_Tc f xs `thenNF_Tc` \ rs ->
156 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
157 listNF_Tc [] = returnNF_Tc []
158 listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
159 listNF_Tc xs `thenNF_Tc` \ rs ->
162 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
164 = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
165 b2 `thenNF_Tc` \ r2 ->
166 returnNF_Tc (unionBags r1 r2))
167 (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
168 (returnNF_Tc emptyBag)
171 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
172 mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
173 mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
174 mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
175 returnNF_Tc (r1:rs1, r2:rs2)
177 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
179 = m down env `thenFSST` \ r ->
182 thenTc_ :: TcM s a -> TcM s b -> TcM s b
184 = m down env `thenFSST_` k down env
186 returnTc :: a -> TcM s a
187 returnTc val down env = returnFSST val
189 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
190 mapTc f [] = returnTc []
191 mapTc f (x:xs) = f x `thenTc` \ r ->
192 mapTc f xs `thenTc` \ rs ->
195 listTc :: [TcM s a] -> TcM s [a]
196 listTc [] = returnTc []
197 listTc (x:xs) = x `thenTc` \ r ->
198 listTc xs `thenTc` \ rs ->
201 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
202 foldrTc k z [] = returnTc z
203 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
206 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
207 foldlTc k z [] = returnTc z
208 foldlTc k z (x:xs) = k z x `thenTc` \r ->
211 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
212 mapAndUnzipTc f [] = returnTc ([],[])
213 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
214 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
215 returnTc (r1:rs1, r2:rs2)
217 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
218 mapAndUnzip3Tc f [] = returnTc ([],[],[])
219 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
220 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
221 returnTc (r1:rs1, r2:rs2, r3:rs3)
223 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
225 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
227 returnTc (unionBags r1 r2))
228 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
232 fixTc :: (a -> TcM s a) -> TcM s a
233 fixTc m env down = fixFSST (\ loop -> m loop env down)
236 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
237 thread. Ideally, this elegantly ensures that it can't zap any type
238 variables that belong to the main thread. But alas, the environment
239 contains TyCon and Class environments that include (TcKind s) stuff,
240 which is a Royal Pain. By the time this fork stuff is used they'll
241 have been unified down so there won't be any kind variables, but we
242 can't express that in the current typechecker framework.
244 So we compromise and use unsafeInterleaveSST.
246 We throw away any error messages!
249 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
250 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
251 = -- Get a fresh unique supply
252 readMutVarSST u_var `thenSST` \ us ->
254 (us1, us2) = splitUniqSupply us
256 writeMutVarSST u_var us1 `thenSST_`
258 unsafeInterleaveSST (
259 newMutVarSST us2 `thenSST` \ us_var' ->
260 newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
261 newMutVarSST emptyUFM `thenSST` \ tv_var' ->
263 down' = TcDown deflts us_var' src_loc err_cxt err_var'
266 -- ToDo: optionally dump any error messages
274 getErrsTc :: NF_TcM s (Bag Error, Bag Warning)
276 = readMutVarSST errs_var
278 errs_var = getTcErrs down
280 failTc :: Message -> TcM s a
281 failTc err_msg down env
282 = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
283 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
285 err = mkTcErr loc ctxt_msgs err_msg
287 writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
290 errs_var = getTcErrs down
291 ctxt = getErrCtxt down
294 warnTc :: Bool -> Message -> NF_TcM s ()
295 warnTc warn_if_true warn down env
296 = if warn_if_true then
297 readMutVarSST errs_var `thenSST` \ (warns,errs) ->
298 listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
300 full_warn = mkTcErr loc ctxt_msgs warn
302 writeMutVarSST errs_var (warns `snocBag` full_warn, errs) `thenSST_`
307 errs_var = getTcErrs down
308 ctxt = getErrCtxt down
311 recoverTc :: TcM s r -> TcM s r -> TcM s r
312 recoverTc recover m down env
313 = recoverFSST (\ _ -> recover down env) (m down env)
315 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
316 recoverNF_Tc recover m down env
317 = recoverSST (\ _ -> recover down env) (m down env)
319 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
320 -- If m fails then (checkNoErrsTc m) fails.
321 -- If m succeeds, it checks whether m generated any errors messages
322 -- (it might have recovered internally)
323 -- If so, it fails too.
324 -- Regardless, any errors generated by m are propagated to the enclosing
327 checkNoErrsTc :: TcM s r -> TcM s r
328 checkNoErrsTc m down env
329 = newMutVarSST (emptyBag,emptyBag) `thenSST` \ m_errs_var ->
331 errs_var = getTcErrs down
333 = readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) ->
334 readMutVarSST errs_var `thenSST` \ (warns, errs) ->
335 writeMutVarSST errs_var (warns `unionBags` m_warns,
336 errs `unionBags` m_errs) `thenSST_`
340 recoverFSST (\ _ -> propagate_errs `thenSST_` failFSST ()) $
342 m (setTcErrs down m_errs_var) env `thenFSST` \ result ->
344 -- Check that m has no errors; if it has internal recovery
345 -- mechanisms it might "succeed" but having found a bunch of
346 -- errors along the way.
347 propagate_errs `thenSST` \ errs ->
348 if isEmptyBag errs then
353 -- (tryTc r m) tries m; if it succeeds it returns it,
354 -- otherwise it returns r. Any error messages added by m are discarded,
355 -- whether or not m succeeds.
356 tryTc :: TcM s r -> TcM s r -> TcM s r
357 tryTc recover m down env
358 = recoverFSST (\ _ -> recover down env) $
360 newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
361 m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
363 -- Check that m has no errors; if it has internal recovery
364 -- mechanisms it might "succeed" but having found a bunch of
365 -- errors along the way. If so we want tryTc to use
367 readMutVarSST new_errs_var `thenSST` \ (_,errs) ->
368 if isEmptyBag errs then
373 -- Run the thing inside, but throw away all its error messages.
374 discardErrsTc :: TcM s r -> TcM s r
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 = failTc 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 = failTc err
391 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
392 checkMaybeTcM (Just val) err = returnTc val
393 checkMaybeTcM Nothing err = err
399 tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
400 tcNewMutVar val down env = newMutVarSST val
402 tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
403 tcWriteMutVar var val down env = writeMutVarSST var val
405 tcReadMutVar :: MutableVar s a -> NF_TcM s a
406 tcReadMutVar var down env = readMutVarSST var
413 tcGetEnv :: NF_TcM s (TcEnv s)
414 tcGetEnv down env = returnSST env
417 -> (TcDown s -> TcEnv s -> State# s -> b)
418 -> TcDown s -> TcEnv s -> State# s -> b
419 -- tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
420 -- tcSetEnv :: TcEnv s -> NF_TcM s a -> NF_TcM s a
422 tcSetEnv new_env m down old_env = m down new_env
429 tcGetDefaultTys :: NF_TcM s [Type]
430 tcGetDefaultTys down env = returnSST (getDefaultTys down)
432 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
433 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
435 -- tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
436 -- tcAddSrcLoc :: SrcLoc -> NF_TcM s a -> NF_TcM s a
437 tcAddSrcLoc :: SrcLoc -> (TcDown s -> env -> result)
438 -> (TcDown s -> env -> result)
439 tcAddSrcLoc loc m down env = m (setLoc down loc) env
441 tcGetSrcLoc :: NF_TcM s SrcLoc
442 tcGetSrcLoc down env = returnSST (getLoc down)
444 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
445 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
446 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
448 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
449 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
450 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
457 tcGetUnique :: NF_TcM s Unique
459 = readMutVarSST u_var `thenSST` \ uniq_supply ->
461 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
462 uniq = getUnique uniq_s
464 writeMutVarSST u_var new_uniq_supply `thenSST_`
467 u_var = getUniqSupplyVar down
469 tcGetUniques :: Int -> NF_TcM s [Unique]
470 tcGetUniques n down env
471 = readMutVarSST u_var `thenSST` \ uniq_supply ->
473 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
474 uniqs = getUniques n uniq_s
476 writeMutVarSST u_var new_uniq_supply `thenSST_`
479 u_var = getUniqSupplyVar down
481 uniqSMToTcM :: UniqSM a -> NF_TcM s a
482 uniqSMToTcM m down env
483 = readMutVarSST u_var `thenSST` \ uniq_supply ->
485 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
487 writeMutVarSST u_var new_uniq_supply `thenSST_`
488 returnSST (initUs uniq_s m)
490 u_var = getUniqSupplyVar down
500 [Type] -- Types used for defaulting
502 (MutableVar s UniqSupply) -- Unique supply
504 SrcLoc -- Source location
505 (ErrCtxt s) -- Error context
506 (MutableVar s (Bag Warning,
509 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
510 -- to deal with bound type variables just before error
511 -- message construction
514 -- These selectors are *local* to TcMonad.lhs
517 getTcErrs (TcDown def us loc ctxt errs) = errs
518 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
520 getDefaultTys (TcDown def us loc ctxt errs) = def
521 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
523 getLoc (TcDown def us loc ctxt errs) = loc
524 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
526 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
528 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
529 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
530 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
540 type TcError = Message
541 type TcWarning = Message
543 mkTcErr :: SrcLoc -- Where
544 -> [Message] -- Context
545 -> Message -- What went wrong
546 -> TcError -- The complete error report
548 mkTcErr locn ctxt msg sty
549 = hang (hcat [ppr (PprForUser opt_PprUserLength) locn, ptext SLIT(": "), msg sty])
550 4 (vcat [msg sty | msg <- ctxt_to_use])
553 if opt_PprStyle_All then
558 takeAtMost :: Int -> [a] -> [a]
561 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
563 arityErr kind name n m sty
564 = hsep [ ppr sty name, ptext SLIT("should have"),
565 n_arguments <> comma, text "but has been given", int m, char '.']
567 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
568 quantity | m < n = "few"
570 n_arguments | n == 0 = ptext SLIT("no arguments")
571 | n == 1 = ptext SLIT("1 argument")
572 | True = hsep [int n, ptext SLIT("arguments")]