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 loc m down env = m (setLoc down loc) env
438 tcGetSrcLoc :: NF_TcM s SrcLoc
439 tcGetSrcLoc down env = returnSST (getLoc down)
441 tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
442 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
443 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
445 tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
446 tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
447 tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
454 tcGetUnique :: NF_TcM s Unique
456 = readMutVarSST u_var `thenSST` \ uniq_supply ->
458 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
459 uniq = getUnique uniq_s
461 writeMutVarSST u_var new_uniq_supply `thenSST_`
464 u_var = getUniqSupplyVar down
466 tcGetUniques :: Int -> NF_TcM s [Unique]
467 tcGetUniques n down env
468 = readMutVarSST u_var `thenSST` \ uniq_supply ->
470 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
471 uniqs = getUniques n uniq_s
473 writeMutVarSST u_var new_uniq_supply `thenSST_`
476 u_var = getUniqSupplyVar down
478 uniqSMToTcM :: UniqSM a -> NF_TcM s a
479 uniqSMToTcM m down env
480 = readMutVarSST u_var `thenSST` \ uniq_supply ->
482 (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
484 writeMutVarSST u_var new_uniq_supply `thenSST_`
485 returnSST (initUs uniq_s m)
487 u_var = getUniqSupplyVar down
497 [Type] -- Types used for defaulting
499 (MutableVar s UniqSupply) -- Unique supply
501 SrcLoc -- Source location
502 (ErrCtxt s) -- Error context
503 (MutableVar s (Bag Warning,
506 type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
507 -- to deal with bound type variables just before error
508 -- message construction
511 -- These selectors are *local* to TcMonad.lhs
514 getTcErrs (TcDown def us loc ctxt errs) = errs
515 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
517 getDefaultTys (TcDown def us loc ctxt errs) = def
518 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
520 getLoc (TcDown def us loc ctxt errs) = loc
521 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
523 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
525 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
526 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
527 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
537 type TcError = Message
538 type TcWarning = Message
540 mkTcErr :: SrcLoc -- Where
541 -> [Message] -- Context
542 -> Message -- What went wrong
543 -> TcError -- The complete error report
545 mkTcErr locn ctxt msg sty
546 = hang (hcat [ppr (PprForUser opt_PprUserLength) locn, ptext SLIT(": "), msg sty])
547 4 (vcat [msg sty | msg <- ctxt_to_use])
550 if opt_PprStyle_All then
555 takeAtMost :: Int -> [a] -> [a]
558 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
560 arityErr kind name n m sty
561 = hsep [ ppr sty name, ptext SLIT("should have"),
562 n_arguments <> comma, text "but has been given", int m, char '.']
564 errmsg = kind ++ " has too " ++ quantity ++ " arguments"
565 quantity | m < n = "few"
567 n_arguments | n == 0 = ptext SLIT("no arguments")
568 | n == 1 = ptext SLIT("1 argument")
569 | True = hsep [int n, ptext SLIT("arguments")]