4 TcTauType, TcThetaType, TcRhoType,
8 TcM, NF_TcM, TcDown, TcEnv,
11 returnTc, thenTc, thenTc_, mapTc, listTc,
12 foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
13 mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
18 returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
19 fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
21 listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
23 checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
24 failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
25 addErrTcM, failWithTcM,
28 tcGetDefaultTys, tcSetDefaultTys,
29 tcGetUnique, tcGetUniques,
31 tcAddSrcLoc, tcGetSrcLoc,
32 tcAddErrCtxtM, tcSetErrCtxtM,
33 tcAddErrCtxt, tcSetErrCtxt,
35 tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
36 tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
38 TcError, TcWarning, TidyEnv, emptyTidyEnv,
42 #include "HsVersions.h"
44 import {-# SOURCE #-} TcEnv ( TcEnv )
46 import Type ( Type, Kind, ThetaType, RhoType, TauType,
48 import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
49 import CmdLineOpts ( opt_PprStyle_Debug )
51 import Bag ( Bag, emptyBag, isEmptyBag,
52 foldBag, unitBag, unionBags, snocBag )
53 import Class ( Class )
55 import Var ( TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
56 import VarEnv ( TyVarEnv, emptyVarEnv, TidyEnv, emptyTidyEnv )
57 import VarSet ( TyVarSet )
58 import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
60 import SrcLoc ( SrcLoc, noSrcLoc )
61 import FiniteMap ( FiniteMap, emptyFM )
62 import UniqFM ( UniqFM, emptyUFM )
63 import Unique ( Unique )
64 import BasicTypes ( Unused )
67 import FastString ( FastString )
69 import IOExts ( IORef, newIORef, readIORef, writeIORef,
70 unsafeInterleaveIO, fixIO
74 infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
81 type TcTyVar = TyVar -- Might be a mutable tyvar
82 type TcTyVarSet = TyVarSet
84 type TcType = Type -- A TcType can have mutable type variables
85 -- Invariant on ForAllTy in TcTypes:
87 -- a cannot occur inside a MutTyVar in T; that is,
88 -- T is "flattened" before quantifying over a
90 type TcThetaType = ThetaType
91 type TcRhoType = RhoType
92 type TcTauType = TauType
97 \section{TcM, NF_TcM: the type checker monads}
98 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
101 type NF_TcM s r = TcDown -> TcEnv -> IO r -- Can't raise UserError
102 type TcM s r = TcDown -> TcEnv -> IO r -- Can raise UserError
103 -- ToDo: nuke the 's' part
104 -- The difference between the two is
105 -- now for documentation purposes only
107 type Either_TcM s r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
108 -- Used only in this file for type signatures which
109 -- have a part that's polymorphic in whether it's NF_TcM or TcM
112 type TcRef a = IORef a
116 -- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
119 -> (TcRef (UniqFM a) -> TcEnv)
121 -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
123 initTc us initenv do_this
125 us_var <- newIORef us ;
126 errs_var <- newIORef (emptyBag,emptyBag) ;
127 tvs_var <- newIORef emptyUFM ;
130 init_down = TcDown [] us_var
133 init_env = initenv tvs_var
136 maybe_res <- catch (do { res <- do_this init_down init_env ;
138 (\_ -> return Nothing) ;
140 (warns,errs) <- readIORef errs_var ;
141 return (maybe_res, warns, errs)
144 -- Monadic operations
146 returnNF_Tc :: a -> NF_TcM s a
147 returnTc :: a -> TcM s a
148 returnTc v down env = return v
150 thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
151 thenNF_Tc :: NF_TcM s a -> (a -> Either_TcM s b) -> Either_TcM s b
152 thenTc m k down env = do { r <- m down env; k r down env }
154 thenTc_ :: TcM s a -> TcM s b -> TcM s b
155 thenNF_Tc_ :: NF_TcM s a -> Either_TcM s b -> Either_TcM s b
156 thenTc_ m k down env = do { m down env; k down env }
158 listTc :: [TcM s a] -> TcM s [a]
159 listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
160 listTc [] = returnTc []
161 listTc (x:xs) = x `thenTc` \ r ->
162 listTc xs `thenTc` \ rs ->
165 mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
166 mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
167 mapTc f [] = returnTc []
168 mapTc f (x:xs) = f x `thenTc` \ r ->
169 mapTc f xs `thenTc` \ rs ->
172 foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
173 foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
174 foldrTc k z [] = returnTc z
175 foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
178 foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
179 foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
180 foldlTc k z [] = returnTc z
181 foldlTc k z (x:xs) = k z x `thenTc` \r ->
184 mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
185 mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
186 mapAndUnzipTc f [] = returnTc ([],[])
187 mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
188 mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
189 returnTc (r1:rs1, r2:rs2)
191 mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
192 mapAndUnzip3Tc f [] = returnTc ([],[],[])
193 mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
194 mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
195 returnTc (r1:rs1, r2:rs2, r3:rs3)
197 mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
198 mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
200 = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
202 returnTc (unionBags r1 r2))
203 (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
207 fixTc :: (a -> TcM s a) -> TcM s a
208 fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
209 fixTc m env down = fixIO (\ loop -> m loop env down)
211 recoverTc :: TcM s r -> TcM s r -> TcM s r
212 recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
213 recoverTc recover m down env
214 = catch (m down env) (\ _ -> recover down env)
216 returnNF_Tc = returnTc
220 recoverNF_Tc = recoverTc
225 mapAndUnzipNF_Tc = mapAndUnzipTc
226 mapBagNF_Tc = mapBagTc
229 @forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
230 thread. Ideally, this elegantly ensures that it can't zap any type
231 variables that belong to the main thread. But alas, the environment
232 contains TyCon and Class environments that include TcKind stuff,
233 which is a Royal Pain. By the time this fork stuff is used they'll
234 have been unified down so there won't be any kind variables, but we
235 can't express that in the current typechecker framework.
237 So we compromise and use unsafeInterleaveSST.
239 We throw away any error messages!
242 forkNF_Tc :: NF_TcM s r -> NF_TcM s r
243 forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
245 -- Get a fresh unique supply
246 us <- readIORef u_var
247 let (us1, us2) = splitUniqSupply us
250 unsafeInterleaveIO (do {
251 us_var' <- newIORef us2 ;
252 err_var' <- newIORef (emptyBag,emptyBag) ;
253 tv_var' <- newIORef emptyUFM ;
254 let { down' = TcDown deflts us_var' src_loc err_cxt err_var' } ;
256 -- ToDo: optionally dump any error messages
261 traceTc :: SDoc -> NF_TcM s ()
262 traceTc doc down env = printErrs doc
264 ioToTc :: IO a -> NF_TcM s a
265 ioToTc io down env = io
269 %************************************************************************
271 \subsection{Error handling}
273 %************************************************************************
276 getErrsTc :: NF_TcM s (Bag WarnMsg, Bag ErrMsg)
278 = readIORef (getTcErrs down)
281 failTc down env = give_up
284 give_up = IOERROR (userError "Typecheck failed")
286 failWithTc :: Message -> TcM s a -- Add an error message and fail
287 failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
289 addErrTc :: Message -> NF_TcM s ()
290 addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
292 -- The 'M' variants do the TidyEnv bit
293 failWithTcM :: (TidyEnv, Message) -> TcM s a -- Add an error message and fail
294 failWithTcM env_and_msg
295 = addErrTcM env_and_msg `thenNF_Tc_`
298 checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
299 checkTc True err = returnTc ()
300 checkTc False err = failWithTc err
302 checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
303 checkTcM True err = returnTc ()
304 checkTcM False err = err
306 checkMaybeTc :: Maybe val -> Message -> TcM s val
307 checkMaybeTc (Just val) err = returnTc val
308 checkMaybeTc Nothing err = failWithTc err
310 checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
311 checkMaybeTcM (Just val) err = returnTc val
312 checkMaybeTcM Nothing err = err
314 addErrTcM :: (TidyEnv, Message) -> NF_TcM s () -- Add an error message but don't fail
315 addErrTcM (tidy_env, err_msg) down env
317 (warns, errs) <- readIORef errs_var
318 ctxt_msgs <- do_ctxt tidy_env ctxt down env
319 let err = addShortErrLocLine loc $
320 vcat (err_msg : ctxt_to_use ctxt_msgs)
321 writeIORef errs_var (warns, errs `snocBag` err)
323 errs_var = getTcErrs down
324 ctxt = getErrCtxt down
327 do_ctxt tidy_env [] down env
329 do_ctxt tidy_env (c:cs) down env
331 (tidy_env', m) <- c tidy_env down env
332 ms <- do_ctxt tidy_env' cs down env
335 -- warnings don't have an 'M' variant
336 warnTc :: Bool -> Message -> NF_TcM s ()
337 warnTc warn_if_true warn_msg down env
340 (warns,errs) <- readIORef errs_var
341 ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
342 let warn = addShortWarnLocLine loc $
343 vcat (warn_msg : ctxt_to_use ctxt_msgs)
344 writeIORef errs_var (warns `snocBag` warn, errs)
348 errs_var = getTcErrs down
349 ctxt = getErrCtxt down
352 -- (tryTc r m) succeeds if m succeeds and generates no errors
353 -- If m fails then r is invoked, passing the warnings and errors from m
354 -- If m succeeds, (tryTc r m) checks whether m generated any errors messages
355 -- (it might have recovered internally)
356 -- If so, then r is invoked, passing the warnings and errors from m
358 tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM s r) -- Recovery action
359 -> TcM s r -- Thing to try
361 tryTc recover main down env
363 m_errs_var <- newIORef (emptyBag,emptyBag)
364 catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
366 my_recover m_errs_var
367 = do warns_and_errs <- readIORef m_errs_var
368 recover warns_and_errs down env
371 = do result <- main (setTcErrs down m_errs_var) env
373 -- Check that m has no errors; if it has internal recovery
374 -- mechanisms it might "succeed" but having found a bunch of
375 -- errors along the way.
376 (m_warns, m_errs) <- readIORef m_errs_var
377 if isEmptyBag m_errs then
380 give_up -- This triggers the catch
383 -- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
384 -- If m fails then (checkNoErrsTc m) fails.
385 -- If m succeeds, it checks whether m generated any errors messages
386 -- (it might have recovered internally)
387 -- If so, it fails too.
388 -- Regardless, any errors generated by m are propagated to the enclosing context.
389 checkNoErrsTc :: TcM s r -> TcM s r
391 = tryTc my_recover main
393 my_recover (m_warns, m_errs) down env
394 = do (warns, errs) <- readIORef errs_var
395 writeIORef errs_var (warns `unionBags` m_warns,
396 errs `unionBags` m_errs)
399 errs_var = getTcErrs down
402 -- (tryTc_ r m) tries m; if it succeeds it returns it,
403 -- otherwise it returns r. Any error messages added by m are discarded,
404 -- whether or not m succeeds.
405 tryTc_ :: TcM s r -> TcM s r -> TcM s r
407 = tryTc my_recover main
409 my_recover warns_and_errs = recover
411 -- (discardErrsTc m) runs m, but throw away all its error messages.
412 discardErrsTc :: Either_TcM s r -> Either_TcM s r
413 discardErrsTc main down env
414 = do new_errs_var <- newIORef (emptyBag,emptyBag)
415 main (setTcErrs down new_errs_var) env
421 tcNewMutVar :: a -> NF_TcM s (TcRef a)
422 tcNewMutVar val down env = newIORef val
424 tcWriteMutVar :: TcRef a -> a -> NF_TcM s ()
425 tcWriteMutVar var val down env = writeIORef var val
427 tcReadMutVar :: TcRef a -> NF_TcM s a
428 tcReadMutVar var down env = readIORef var
430 tcNewMutTyVar :: Name -> Kind -> NF_TcM s TyVar
431 tcNewMutTyVar name kind down env = newMutTyVar name kind
433 tcNewSigTyVar :: Name -> Kind -> NF_TcM s TyVar
434 tcNewSigTyVar name kind down env = newSigTyVar name kind
436 tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type)
437 tcReadMutTyVar tyvar down env = readMutTyVar tyvar
439 tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM s ()
440 tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
447 tcGetEnv :: NF_TcM s TcEnv
448 tcGetEnv down env = return env
450 tcSetEnv :: TcEnv -> Either_TcM s a -> Either_TcM s a
451 tcSetEnv new_env m down old_env = m down new_env
458 tcGetDefaultTys :: NF_TcM s [Type]
459 tcGetDefaultTys down env = return (getDefaultTys down)
461 tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
462 tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
464 tcAddSrcLoc :: SrcLoc -> Either_TcM s a -> Either_TcM s a
465 tcAddSrcLoc loc m down env = m (setLoc down loc) env
467 tcGetSrcLoc :: NF_TcM s SrcLoc
468 tcGetSrcLoc down env = return (getLoc down)
470 tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM s (TidyEnv, Message))
471 -> TcM s a -> TcM s a
472 tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
473 tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
475 tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM s r -> Either_TcM s r
477 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
478 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
485 tcGetUnique :: NF_TcM s Unique
487 = do uniq_supply <- readIORef u_var
488 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
489 uniq = uniqFromSupply uniq_s
490 writeIORef u_var new_uniq_supply
493 u_var = getUniqSupplyVar down
495 tcGetUniques :: Int -> NF_TcM s [Unique]
496 tcGetUniques n down env
497 = do uniq_supply <- readIORef u_var
498 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
499 uniqs = uniqsFromSupply n uniq_s
500 writeIORef u_var new_uniq_supply
503 u_var = getUniqSupplyVar down
505 uniqSMToTcM :: UniqSM a -> NF_TcM s a
506 uniqSMToTcM m down env
507 = do uniq_supply <- readIORef u_var
508 let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
509 writeIORef u_var new_uniq_supply
510 return (initUs_ uniq_s m)
512 u_var = getUniqSupplyVar down
522 [Type] -- Types used for defaulting
524 (TcRef UniqSupply) -- Unique supply
526 SrcLoc -- Source location
527 ErrCtxt -- Error context
531 type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]
532 -- Innermost first. Monadic so that we have a chance
533 -- to deal with bound type variables just before error
534 -- message construction
537 -- These selectors are *local* to TcMonad.lhs
540 getTcErrs (TcDown def us loc ctxt errs) = errs
541 setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
543 getDefaultTys (TcDown def us loc ctxt errs) = def
544 setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
546 getLoc (TcDown def us loc ctxt errs) = loc
547 setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
549 getUniqSupplyVar (TcDown def us loc ctxt errs) = us
551 setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
552 addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
553 getErrCtxt (TcDown def us loc ctxt errs) = ctxt
563 type TcError = Message
564 type TcWarning = Message
566 ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
567 | otherwise = takeAtMost 3 ctxt
569 takeAtMost :: Int -> [a] -> [a]
572 takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
574 arityErr kind name n m
575 = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
576 n_arguments <> comma, text "but has been given", int m]
578 n_arguments | n == 0 = ptext SLIT("no arguments")
579 | n == 1 = ptext SLIT("1 argument")
580 | True = hsep [int n, ptext SLIT("arguments")]