\begin{code}
-#include "HsVersions.h"
-
module TcMonad(
- SYN_IE(TcM), SYN_IE(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, getErrsTc,
+ mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
+ traceTc, ioToTc,
- returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc,
+ 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,
-
- SYN_IE(TcError), SYN_IE(TcWarning),
- mkTcErr, arityErr,
+ tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
+ tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
- -- For closure
- SYN_IE(MutableVar),
-#if __GLASGOW_HASKELL__ >= 200
- GHCbase.MutableArray
-#else
- _MutableArray
-#endif
+ TcError, TcWarning, TidyEnv, emptyTidyEnv,
+ arityErr
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
-IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
+import {-# SOURCE #-} TcEnv ( TcEnv )
-import Type ( SYN_IE(Type), GenType )
-import TyVar ( SYN_IE(TyVar), GenTyVar )
-import Usage ( SYN_IE(Usage), GenUsage )
-import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
+import Type ( Type, Kind, ThetaType, RhoType, TauType,
+ )
+import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
+import CmdLineOpts ( opt_PprStyle_Debug )
-import SST
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
-import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
-import Maybes ( MaybeErr(..) )
+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 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}
-#if __GLASGOW_HASKELL__ >= 200
-# define REAL_WORLD RealWorld
-#else
-# define REAL_WORLD _RealWorld
-#endif
-
--- 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 REAL_WORLD 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
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
+ init_env = initenv tvs_var
+ ;
-returnNF_Tc :: a -> NF_TcM s a
-returnNF_Tc v down env = returnSST v
+ 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)
+ }
-fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a
-fixNF_Tc m env down = fixSST (\ loop -> m loop env down)
-
-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)
-
-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)
-
-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
+-- Monadic operations
-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 *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 s) stuff,
+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.
\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_`
+ = do
+ -- Get a fresh unique supply
+ us <- readIORef u_var
+ let (us1, us2) = splitUniqSupply us
+ writeIORef u_var us1
- unsafeInterleaveSST (
- newMutVarSST us2 `thenSST` \ us_var' ->
- newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
- newMutVarSST emptyUFM `thenSST` \ tv_var' ->
- let
- down' = TcDown deflts us_var' src_loc err_cxt err_var'
- in
- m down' env
- -- ToDo: optionally dump any error messages
- )
+ 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}
-
-Error handling
-~~~~~~~~~~~~~~
\begin{code}
-getErrsTc :: NF_TcM s (Bag Error, Bag Warning)
-getErrsTc down env
- = readMutVarSST errs_var
- where
- errs_var = getTcErrs down
+traceTc :: SDoc -> NF_TcM s ()
+traceTc doc down env = printErrs doc
-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
+ioToTc :: IO a -> NF_TcM s a
+ioToTc io down env = io
+\end{code}
-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
-recoverTc :: TcM s r -> TcM s r -> TcM s r
-recoverTc recover m down env
- = recoverFSST (\ _ -> recover down env) (m down env)
+%************************************************************************
+%* *
+\subsection{Error handling}
+%* *
+%************************************************************************
-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)
+\begin{code}
+getErrsTc :: NF_TcM s (Bag WarnMsg, Bag ErrMsg)
+getErrsTc down env
+ = readIORef (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 m down env
- = recoverFSST (\ _ -> recover down env) $
+failTc :: TcM s a
+failTc down env = give_up
+
+give_up :: IO a
+give_up = IOERROR (userError "Typecheck failed")
- newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var ->
+failWithTc :: Message -> TcM s a -- Add an error message and fail
+failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
- m (setTcErrs down new_errs_var) env `thenFSST` \ result ->
+addErrTc :: Message -> NF_TcM s ()
+addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
- -- 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. If so we want tryTc to use
- -- "recover" instead
- readMutVarSST new_errs_var `thenSST` \ (_,errs) ->
- if isEmptyBag errs then
- returnFSST result
- else
- recover down env
+-- 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
-tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
-tcWriteMutVar var val down env = writeMutVarSST var val
+tcNewMutTyVar :: Name -> Kind -> NF_TcM s TyVar
+tcNewMutTyVar name kind down env = newMutTyVar name kind
-tcReadMutVar :: MutableVar s a -> NF_TcM s a
-tcReadMutVar var down env = readMutVarSST var
+tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type)
+tcReadMutTyVar tyvar down env = readMutTyVar tyvar
+
+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
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