\begin{code}
module TcMonad(
- TcM(..), NF_TcM(..), TcDown, TcEnv,
- SST_R, FSST_R,
+ TcType,
+ TcTauType, TcThetaType, TcRhoType,
+ TcTyVar, TcTyVarSet,
+ TcKind,
+
+ TcM, NF_TcM, TcDown, TcEnv,
initTc,
returnTc, thenTc, thenTc_, mapTc, listTc,
foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
- mapBagTc, fixTc, tryTc,
+ mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
+ traceTc, ioToTc,
+
+ uniqSMToTcM,
returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
+ fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
+
listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
- failTc, warnTc, recoverTc, recoverNF_Tc,
+ failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+ addErrTcM, failWithTcM,
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
tcAddErrCtxtM, tcSetErrCtxtM,
tcAddErrCtxt, tcSetErrCtxt,
- tcNewMutVar, tcReadMutVar, tcWriteMutVar,
+ tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
+ tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
- rn4MtoTcM,
-
- TcError(..), TcWarning(..),
- mkTcErr, arityErr,
-
- -- For closure
- MutableVar(..), _MutableArray
+ TcError, TcWarning, TidyEnv, emptyTidyEnv,
+ arityErr
) where
-import Ubiq{-uitous-}
-
-import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
+#include "HsVersions.h"
-import Type ( Type(..), GenType )
-import TyVar ( TyVar(..), GenTyVar )
-import Usage ( Usage(..), GenUsage )
-import ErrUtils ( Error(..), Message(..), ErrCtxt(..),
- Warning(..) )
+import {-# SOURCE #-} TcEnv ( TcEnv )
-import SST
---import RnMonad4
---LATER:import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
+import Type ( Type, Kind, ThetaType, RhoType, TauType,
+ )
+import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
+import CmdLineOpts ( opt_PprStyle_Debug )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
+import Class ( Class )
+import Name ( Name )
+import Var ( TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
+import VarEnv ( TyVarEnv, emptyVarEnv, TidyEnv, emptyTidyEnv )
+import VarSet ( TyVarSet )
+import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
+ UniqSM, initUs )
+import SrcLoc ( SrcLoc, noSrcLoc )
import FiniteMap ( FiniteMap, emptyFM )
-import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
-import ErrUtils ( Error(..) )
-import Maybes ( MaybeErr(..) )
---import Name ( Name )
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
import UniqFM ( UniqFM, emptyUFM )
-import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
import Unique ( Unique )
+import BasicTypes ( Unused )
import Util
-import Pretty
-import PprStyle ( PprStyle(..) )
+import Outputable
+import FastString ( FastString )
+
+import IOExts ( IORef, newIORef, readIORef, writeIORef,
+ unsafeInterleaveIO, fixIO
+ )
+
infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
\end{code}
+Types
+~~~~~
+\begin{code}
+type TcTyVar = TyVar -- Might be a mutable tyvar
+type TcTyVarSet = TyVarSet
+
+type TcType = Type -- A TcType can have mutable type variables
+ -- Invariant on ForAllTy in TcTypes:
+ -- forall a. T
+ -- a cannot occur inside a MutTyVar in T; that is,
+ -- T is "flattened" before quantifying over a
+
+type TcThetaType = ThetaType
+type TcRhoType = RhoType
+type TcTauType = TauType
+type TcKind = TcType
+\end{code}
+
+
\section{TcM, NF_TcM: the type checker monads}
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
-type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
+type NF_TcM s r = TcDown -> TcEnv -> IO r -- Can't raise UserError
+type TcM s r = TcDown -> TcEnv -> IO r -- Can raise UserError
+ -- ToDo: nuke the 's' part
+ -- The difference between the two is
+ -- now for documentation purposes only
+
+type Either_TcM s r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
+ -- Used only in this file for type signatures which
+ -- have a part that's polymorphic in whether it's NF_TcM or TcM
+ -- E.g. thenNF_Tc
+
+type TcRef a = IORef a
\end{code}
\begin{code}
--- With a builtin polymorphic type for _runSST the type for
--- initTc should use TcM s r instead of TcM _RealWorld r
+-- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
initTc :: UniqSupply
- -> TcM _RealWorld r
- -> MaybeErr (r, Bag Warning)
- (Bag Error, Bag Warning)
-
-initTc us do_this
- = _runSST (
- newMutVarSST us `thenSST` \ us_var ->
- newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
- newMutVarSST emptyUFM `thenSST` \ tvs_var ->
+ -> (TcRef (UniqFM a) -> TcEnv)
+ -> TcM s r
+ -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
+
+initTc us initenv do_this
+ = do {
+ us_var <- newIORef us ;
+ errs_var <- newIORef (emptyBag,emptyBag) ;
+ tvs_var <- newIORef emptyUFM ;
+
let
init_down = TcDown [] us_var
- mkUnknownSrcLoc
+ noSrcLoc
[] errs_var
- init_env = initEnv tvs_var
- in
- recoverSST
- (\_ -> returnSST Nothing)
- (do_this init_down init_env `thenFSST` \ res ->
- returnFSST (Just res))
- `thenSST` \ maybe_res ->
- readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- case (maybe_res, isEmptyBag errs) of
- (Just res, True) -> returnSST (Succeeded (res, warns))
- _ -> returnSST (Failed (errs, warns))
- )
-
-thenNF_Tc :: NF_TcM s a
- -> (a -> TcDown s -> TcEnv s -> State# s -> b)
- -> TcDown s -> TcEnv s -> State# s -> b
--- thenNF_Tc :: NF_TcM s a -> (a -> NF_TcM s b) -> NF_TcM s b
--- thenNF_Tc :: NF_TcM s a -> (a -> TcM s b) -> TcM s b
-
-thenNF_Tc m k down env
- = m down env `thenSST` \ r ->
- k r down env
-
-thenNF_Tc_ :: NF_TcM s a
- -> (TcDown s -> TcEnv s -> State# s -> b)
- -> TcDown s -> TcEnv s -> State# s -> b
--- thenNF_Tc :: NF_TcM s a -> NF_TcM s b -> NF_TcM s b
--- thenNF_Tc :: NF_TcM s a -> TcM s b -> TcM s b
-
-thenNF_Tc_ m k down env
- = m down env `thenSST_` k down env
-
-returnNF_Tc :: a -> NF_TcM s a
-returnNF_Tc v down env = returnSST v
+ init_env = initenv tvs_var
+ ;
-mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
-mapNF_Tc f [] = returnNF_Tc []
-mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r ->
- mapNF_Tc f xs `thenNF_Tc` \ rs ->
- returnNF_Tc (r:rs)
+ maybe_res <- catch (do { res <- do_this init_down init_env ;
+ return (Just res)})
+ (\_ -> return Nothing) ;
+
+ (warns,errs) <- readIORef errs_var ;
+ return (maybe_res, warns, errs)
+ }
-listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
-listNF_Tc [] = returnNF_Tc []
-listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
- listNF_Tc xs `thenNF_Tc` \ rs ->
- returnNF_Tc (r:rs)
+-- Monadic operations
-mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
-mapBagNF_Tc f bag
- = foldBag (\ b1 b2 -> b1 `thenNF_Tc` \ r1 ->
- b2 `thenNF_Tc` \ r2 ->
- returnNF_Tc (unionBags r1 r2))
- (\ a -> f a `thenNF_Tc` \ r -> returnNF_Tc (unitBag r))
- (returnNF_Tc emptyBag)
- bag
-
-mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
-mapAndUnzipNF_Tc f [] = returnNF_Tc ([],[])
-mapAndUnzipNF_Tc f (x:xs) = f x `thenNF_Tc` \ (r1,r2) ->
- mapAndUnzipNF_Tc f xs `thenNF_Tc` \ (rs1,rs2) ->
- returnNF_Tc (r1:rs1, r2:rs2)
+returnNF_Tc :: a -> NF_TcM s a
+returnTc :: a -> TcM s a
+returnTc v down env = return v
-thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
-thenTc m k down env
- = m down env `thenFSST` \ r ->
- k r down env
+thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b
+thenNF_Tc :: NF_TcM s a -> (a -> Either_TcM s b) -> Either_TcM s b
+thenTc m k down env = do { r <- m down env; k r down env }
-thenTc_ :: TcM s a -> TcM s b -> TcM s b
-thenTc_ m k down env
- = m down env `thenFSST_` k down env
+thenTc_ :: TcM s a -> TcM s b -> TcM s b
+thenNF_Tc_ :: NF_TcM s a -> Either_TcM s b -> Either_TcM s b
+thenTc_ m k down env = do { m down env; k down env }
-returnTc :: a -> TcM s a
-returnTc val down env = returnFSST val
+listTc :: [TcM s a] -> TcM s [a]
+listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
+listTc [] = returnTc []
+listTc (x:xs) = x `thenTc` \ r ->
+ listTc xs `thenTc` \ rs ->
+ returnTc (r:rs)
-mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
+mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
+mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
mapTc f [] = returnTc []
mapTc f (x:xs) = f x `thenTc` \ r ->
mapTc f xs `thenTc` \ rs ->
returnTc (r:rs)
-listTc :: [TcM s a] -> TcM s [a]
-listTc [] = returnTc []
-listTc (x:xs) = x `thenTc` \ r ->
- listTc xs `thenTc` \ rs ->
- returnTc (r:rs)
-
-foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
+foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b
+foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
foldrTc k z [] = returnTc z
foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
k x r
-foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
+foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a
+foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
foldlTc k z [] = returnTc z
foldlTc k z (x:xs) = k z x `thenTc` \r ->
foldlTc k r xs
-mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
+mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c])
+mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c])
mapAndUnzipTc f [] = returnTc ([],[])
mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
returnTc (r1:rs1, r2:rs2, r3:rs3)
-mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
+mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b)
+mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b)
mapBagTc f bag
= foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
b2 `thenTc` \ r2 ->
(returnTc emptyBag)
bag
-fixTc :: (a -> TcM s a) -> TcM s a
-fixTc m env down = fixFSST (\ loop -> m loop env down)
+fixTc :: (a -> TcM s a) -> TcM s a
+fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
+fixTc m env down = fixIO (\ loop -> m loop env down)
+
+recoverTc :: TcM s r -> TcM s r -> TcM s r
+recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
+recoverTc recover m down env
+ = catch (m down env) (\ _ -> recover down env)
+
+returnNF_Tc = returnTc
+thenNF_Tc = thenTc
+thenNF_Tc_ = thenTc_
+fixNF_Tc = fixTc
+recoverNF_Tc = recoverTc
+mapNF_Tc = mapTc
+foldrNF_Tc = foldrTc
+foldlNF_Tc = foldlTc
+listNF_Tc = listTc
+mapAndUnzipNF_Tc = mapAndUnzipTc
+mapBagNF_Tc = mapBagTc
\end{code}
-@forkNF_Tc@ runs a sub-typecheck action in a separate state thread.
-This elegantly ensures that it can't zap any type variables that
-belong to the main thread. We throw away any error messages!
+@forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
+thread. Ideally, this elegantly ensures that it can't zap any type
+variables that belong to the main thread. But alas, the environment
+contains TyCon and Class environments that include TcKind stuff,
+which is a Royal Pain. By the time this fork stuff is used they'll
+have been unified down so there won't be any kind variables, but we
+can't express that in the current typechecker framework.
+
+So we compromise and use unsafeInterleaveSST.
+
+We throw away any error messages!
-\begin{pseudocode}
-forkNF_Tc :: NF_TcM s' r -> NF_TcM s r
+\begin{code}
+forkNF_Tc :: NF_TcM s r -> NF_TcM s r
forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
- = -- Get a fresh unique supply
- readMutVarSST u_var `thenSST` \ us ->
- let
- (us1, us2) = splitUniqSupply us
- in
- writeMutVarSST u_var us1 `thenSST_`
- returnSST (_runSST (
- newMutVarSST us2 `thenSST` \ u_var' ->
- newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
- newMutVarSST emptyUFM `thenSST` \ tv_var' ->
- let
- down' = TcDown deflts us_var src_loc err_cxt err_var'
- env' = forkEnv env tv_var'
- in
- m down' env'
-
- -- ToDo: optionally dump any error messages
- ))
-\end{pseudocode}
-
-@forkTcDown@ makes a new "down" blob for a lazily-computed fork
-of the type checker.
-
-\begin{pseudocode}
-forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
- = -- Get a fresh unique supply
- readMutVarSST u_var `thenSST` \ us ->
- let
- (us1, us2) = splitUniqSupply us
- in
- writeMutVarSST u_var us1 `thenSST_`
-
- -- Make fresh MutVars for the unique supply and errors
- newMutVarSST us2 `thenSST` \ u_var' ->
- newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' ->
-
- -- Done
- returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
-\end{pseudocode}
-
-
-Error handling
-~~~~~~~~~~~~~~
+ = do
+ -- Get a fresh unique supply
+ us <- readIORef u_var
+ let (us1, us2) = splitUniqSupply us
+ writeIORef u_var us1
+
+ unsafeInterleaveIO (do {
+ us_var' <- newIORef us2 ;
+ err_var' <- newIORef (emptyBag,emptyBag) ;
+ tv_var' <- newIORef emptyUFM ;
+ let { down' = TcDown deflts us_var' src_loc err_cxt err_var' } ;
+ m down' env
+ -- ToDo: optionally dump any error messages
+ })
+\end{code}
+
\begin{code}
-failTc :: Message -> TcM s a
-failTc err_msg down env
- = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
- let
- err = mkTcErr loc ctxt_msgs err_msg
- in
- writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
- failFSST ()
- where
- errs_var = getTcErrs down
- ctxt = getErrCtxt down
- loc = getLoc down
+traceTc :: SDoc -> NF_TcM s ()
+traceTc doc down env = printErrs doc
-warnTc :: Bool -> Message -> NF_TcM s ()
-warnTc warn_if_true warn down env
- = if warn_if_true then
- readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
- returnSST ()
- else
- returnSST ()
- where
- errs_var = getTcErrs down
+ioToTc :: IO a -> NF_TcM s a
+ioToTc io down env = io
+\end{code}
-recoverTc :: TcM s r -> TcM s r -> TcM s r
-recoverTc recover m down env
- = recoverFSST (\ _ -> recover down env) (m down env)
-recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r
-recoverNF_Tc recover m down env
- = recoverSST (\ _ -> recover down env) (m down env)
+%************************************************************************
+%* *
+\subsection{Error handling}
+%* *
+%************************************************************************
--- (tryTc r m) tries m; if it succeeds it returns it,
--- otherwise it returns r. Any error messages added by m are discarded,
--- whether or not m succeeds.
-tryTc :: TcM s r -> TcM s r -> TcM s r
-tryTc recover m down env
- = recoverFSST (\ _ -> recover down env) $
- newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
- m (setTcErrs down new_errs_var) env
+\begin{code}
+getErrsTc :: NF_TcM s (Bag WarnMsg, Bag ErrMsg)
+getErrsTc down env
+ = readIORef (getTcErrs down)
+
+failTc :: TcM s a
+failTc down env = give_up
+
+give_up :: IO a
+give_up = IOERROR (userError "Typecheck failed")
+
+failWithTc :: Message -> TcM s a -- Add an error message and fail
+failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
+
+addErrTc :: Message -> NF_TcM s ()
+addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+
+-- The 'M' variants do the TidyEnv bit
+failWithTcM :: (TidyEnv, Message) -> TcM s a -- Add an error message and fail
+failWithTcM env_and_msg
+ = addErrTcM env_and_msg `thenNF_Tc_`
+ failTc
checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
checkTc True err = returnTc ()
-checkTc False err = failTc err
+checkTc False err = failWithTc err
checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
checkTcM True err = returnTc ()
checkMaybeTc :: Maybe val -> Message -> TcM s val
checkMaybeTc (Just val) err = returnTc val
-checkMaybeTc Nothing err = failTc err
+checkMaybeTc Nothing err = failWithTc err
checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
checkMaybeTcM (Just val) err = returnTc val
checkMaybeTcM Nothing err = err
+
+addErrTcM :: (TidyEnv, Message) -> NF_TcM s () -- Add an error message but don't fail
+addErrTcM (tidy_env, err_msg) down env
+ = do
+ (warns, errs) <- readIORef errs_var
+ ctxt_msgs <- do_ctxt tidy_env ctxt down env
+ let err = addShortErrLocLine loc $
+ vcat (err_msg : ctxt_to_use ctxt_msgs)
+ writeIORef errs_var (warns, errs `snocBag` err)
+ where
+ errs_var = getTcErrs down
+ ctxt = getErrCtxt down
+ loc = getLoc down
+
+do_ctxt tidy_env [] down env
+ = return []
+do_ctxt tidy_env (c:cs) down env
+ = do
+ (tidy_env', m) <- c tidy_env down env
+ ms <- do_ctxt tidy_env' cs down env
+ return (m:ms)
+
+-- warnings don't have an 'M' variant
+warnTc :: Bool -> Message -> NF_TcM s ()
+warnTc warn_if_true warn_msg down env
+ | warn_if_true
+ = do
+ (warns,errs) <- readIORef errs_var
+ ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
+ let warn = addShortWarnLocLine loc $
+ vcat (warn_msg : ctxt_to_use ctxt_msgs)
+ writeIORef errs_var (warns `snocBag` warn, errs)
+ | otherwise
+ = return ()
+ where
+ errs_var = getTcErrs down
+ ctxt = getErrCtxt down
+ loc = getLoc down
+
+-- (tryTc r m) succeeds if m succeeds and generates no errors
+-- If m fails then r is invoked, passing the warnings and errors from m
+-- If m succeeds, (tryTc r m) checks whether m generated any errors messages
+-- (it might have recovered internally)
+-- If so, then r is invoked, passing the warnings and errors from m
+
+tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM s r) -- Recovery action
+ -> TcM s r -- Thing to try
+ -> TcM s r
+tryTc recover main down env
+ = do
+ m_errs_var <- newIORef (emptyBag,emptyBag)
+ catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
+ where
+ my_recover m_errs_var
+ = do warns_and_errs <- readIORef m_errs_var
+ recover warns_and_errs down env
+
+ my_main m_errs_var
+ = do result <- main (setTcErrs down m_errs_var) env
+
+ -- Check that m has no errors; if it has internal recovery
+ -- mechanisms it might "succeed" but having found a bunch of
+ -- errors along the way.
+ (m_warns, m_errs) <- readIORef m_errs_var
+ if isEmptyBag m_errs then
+ return result
+ else
+ give_up -- This triggers the catch
+
+
+-- (checkNoErrsTc m) succeeds iff m succeeds and generates no errors
+-- If m fails then (checkNoErrsTc m) fails.
+-- If m succeeds, it checks whether m generated any errors messages
+-- (it might have recovered internally)
+-- If so, it fails too.
+-- Regardless, any errors generated by m are propagated to the enclosing context.
+checkNoErrsTc :: TcM s r -> TcM s r
+checkNoErrsTc main
+ = tryTc my_recover main
+ where
+ my_recover (m_warns, m_errs) down env
+ = do (warns, errs) <- readIORef errs_var
+ writeIORef errs_var (warns `unionBags` m_warns,
+ errs `unionBags` m_errs)
+ give_up
+ where
+ errs_var = getTcErrs down
+
+
+-- (tryTc_ r m) tries m; if it succeeds it returns it,
+-- otherwise it returns r. Any error messages added by m are discarded,
+-- whether or not m succeeds.
+tryTc_ :: TcM s r -> TcM s r -> TcM s r
+tryTc_ recover main
+ = tryTc my_recover main
+ where
+ my_recover warns_and_errs = recover
+
+-- (discardErrsTc m) runs m, but throw away all its error messages.
+discardErrsTc :: Either_TcM s r -> Either_TcM s r
+discardErrsTc main down env
+ = do new_errs_var <- newIORef (emptyBag,emptyBag)
+ main (setTcErrs down new_errs_var) env
\end{code}
Mutable variables
~~~~~~~~~~~~~~~~~
\begin{code}
-tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
-tcNewMutVar val down env = newMutVarSST val
+tcNewMutVar :: a -> NF_TcM s (TcRef a)
+tcNewMutVar val down env = newIORef val
+
+tcWriteMutVar :: TcRef a -> a -> NF_TcM s ()
+tcWriteMutVar var val down env = writeIORef var val
+
+tcReadMutVar :: TcRef a -> NF_TcM s a
+tcReadMutVar var down env = readIORef var
+
+tcNewMutTyVar :: Name -> Kind -> NF_TcM s TyVar
+tcNewMutTyVar name kind down env = newMutTyVar name kind
-tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
-tcWriteMutVar var val down env = writeMutVarSST var val
+tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type)
+tcReadMutTyVar tyvar down env = readMutTyVar tyvar
-tcReadMutVar :: MutableVar s a -> NF_TcM s a
-tcReadMutVar var down env = readMutVarSST var
+tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM s ()
+tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
\end{code}
Environment
~~~~~~~~~~~
\begin{code}
-tcGetEnv :: NF_TcM s (TcEnv s)
-tcGetEnv down env = returnSST env
+tcGetEnv :: NF_TcM s TcEnv
+tcGetEnv down env = return env
-tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
+tcSetEnv :: TcEnv -> Either_TcM s a -> Either_TcM s a
tcSetEnv new_env m down old_env = m down new_env
\end{code}
~~~~~~~~~~~~~~~
\begin{code}
tcGetDefaultTys :: NF_TcM s [Type]
-tcGetDefaultTys down env = returnSST (getDefaultTys down)
+tcGetDefaultTys down env = return (getDefaultTys down)
tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
-tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
+tcAddSrcLoc :: SrcLoc -> Either_TcM s a -> Either_TcM s a
tcAddSrcLoc loc m down env = m (setLoc down loc) env
tcGetSrcLoc :: NF_TcM s SrcLoc
-tcGetSrcLoc down env = returnSST (getLoc down)
+tcGetSrcLoc down env = return (getLoc down)
-tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
+tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM s (TidyEnv, Message))
+ -> TcM s a -> TcM s a
tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
-tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
-tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
-tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
+tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM s r -> Either_TcM s r
+-- Usual thing
+tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
+tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
\end{code}
\begin{code}
tcGetUnique :: NF_TcM s Unique
tcGetUnique down env
- = readMutVarSST u_var `thenSST` \ uniq_supply ->
- let
- (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniq = getUnique uniq_s
- in
- writeMutVarSST u_var new_uniq_supply `thenSST_`
- returnSST uniq
+ = do uniq_supply <- readIORef u_var
+ let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ uniq = uniqFromSupply uniq_s
+ writeIORef u_var new_uniq_supply
+ return uniq
where
u_var = getUniqSupplyVar down
tcGetUniques :: Int -> NF_TcM s [Unique]
tcGetUniques n down env
- = readMutVarSST u_var `thenSST` \ uniq_supply ->
- let
- (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniqs = getUniques n uniq_s
- in
- writeMutVarSST u_var new_uniq_supply `thenSST_`
- returnSST uniqs
+ = do uniq_supply <- readIORef u_var
+ let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ uniqs = uniqsFromSupply n uniq_s
+ writeIORef u_var new_uniq_supply
+ return uniqs
+ where
+ u_var = getUniqSupplyVar down
+
+uniqSMToTcM :: UniqSM a -> NF_TcM s a
+uniqSMToTcM m down env
+ = do uniq_supply <- readIORef u_var
+ let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ writeIORef u_var new_uniq_supply
+ return (initUs uniq_s m)
where
u_var = getUniqSupplyVar down
\end{code}
%~~~~~~~~~~~~~~~
\begin{code}
-data TcDown s
+data TcDown
= TcDown
- [Type] -- Types used for defaulting
+ [Type] -- Types used for defaulting
- (MutableVar s UniqSupply) -- Unique supply
+ (TcRef UniqSupply) -- Unique supply
- SrcLoc -- Source location
- (ErrCtxt s) -- Error context
- (MutableVar s (Bag Warning,
- Bag Error))
+ SrcLoc -- Source location
+ ErrCtxt -- Error context
+ (TcRef (Bag WarnMsg,
+ Bag ErrMsg))
-type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
- -- to deal with bound type variables just before error
- -- message construction
+type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]
+ -- Innermost first. Monadic so that we have a chance
+ -- to deal with bound type variables just before error
+ -- message construction
\end{code}
-- These selectors are *local* to TcMonad.lhs
\end{code}
-\section{rn4MtoTcM}
-%~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-rn4MtoTcM = panic "TcMonad.rn4MtoTcM (ToDo LATER)"
-{- LATER:
-rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error)
-
-rn4MtoTcM name_funs rn_action down env
- = readMutVarSST u_var `thenSST` \ uniq_supply ->
- let
- (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- in
- writeMutVarSST u_var new_uniq_supply `thenSST_`
- let
- (rn_result, rn_errs)
- = rn_action name_funs emptyFM emptyBag uniq_s mkUnknownSrcLoc
- in
- returnSST (rn_result, rn_errs)
- where
- u_var = getUniqSupplyVar down
--}
-\end{code}
TypeChecking Errors
type TcError = Message
type TcWarning = Message
-mkTcErr :: SrcLoc -- Where
- -> [Message] -- Context
- -> Message -- What went wrong
- -> TcError -- The complete error report
-
-mkTcErr locn ctxt msg sty
- = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty])
- 4 (ppAboves [msg sty | msg <- ctxt])
-
-
-arityErr kind name n m sty
- = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ",
- n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.']
+ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
+ | otherwise = takeAtMost 3 ctxt
+ where
+ takeAtMost :: Int -> [a] -> [a]
+ takeAtMost 0 ls = []
+ takeAtMost n [] = []
+ takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
+
+arityErr kind name n m
+ = hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
+ n_arguments <> comma, text "but has been given", int m]
where
- errmsg = kind ++ " has too " ++ quantity ++ " arguments"
- quantity | m < n = "few"
- | otherwise = "many"
- n_arguments | n == 0 = ppStr "no arguments"
- | n == 1 = ppStr "1 argument"
- | True = ppCat [ppInt n, ppStr "arguments"]
+ n_arguments | n == 0 = ptext SLIT("no arguments")
+ | n == 1 = ptext SLIT("1 argument")
+ | True = hsep [int n, ptext SLIT("arguments")]
\end{code}
projects / ghc-hetmet.git / blobdiff