-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcMonad]{@TcMonad@: monad machinery for the typechecker}
-
\begin{code}
-#include "HsVersions.h"
-
-module TcMonad (
- TcM(..), TcResult{-abstract-},
- thenTc, thenTc_, returnTc, failTc, checkTc,
- listTc, mapTc, mapAndUnzipTc,
- fixTc, foldlTc, initTc,
- recoverTc, recoverQuietlyTc,
-
- NF_TcM(..),
- thenNF_Tc, thenLazilyNF_Tc, returnNF_Tc, listNF_Tc, mapNF_Tc,
- fixNF_Tc, noFailTc,
-
- Baby_TcM(..), Baby_TcResult{-abstract-},
- returnB_Tc, thenB_Tc, thenB_Tc_,
- failB_Tc, recoverIgnoreErrorsB_Tc,
- fixB_Tc, mapB_Tc,
- babyTcMtoTcM, babyTcMtoNF_TcM,
- getUniqueB_Tc, getUniquesB_Tc,
- addSrcLocB_Tc, getSrcLocB_Tc,
- getSwitchCheckerB_Tc, checkB_Tc,
- uniqSMtoBabyTcM,
-
- getSwitchCheckerTc,
- getDefaultingTys, setDefaultingTys,
- getUniquesTc, getUniqueTc,
- rn4MtoTcM,
-
- getTyVarUniquesTc, getTyVarUniqueTc,
-
- applyTcSubstToTy, applyTcSubstToTys,
---UNUSED: applyTcSubstToThetaTy,
- applyTcSubstToTyVar, applyTcSubstToTyVars,
- applyTcSubstToId,
- applyTcSubstToInst, applyTcSubstToInsts,
- extendSubstTc, pruneSubstTc,
-
- addSrcLocTc, getSrcLocTc,
- checkMaybeTc, checkMaybesTc,
- checkMaybeErrTc, -- UNUSED: checkMaybeErrsTc,
-
- lookupInst_Tc, lookupNoBindInst_Tc,
-
- -- and to make the interface self-sufficient ...
- UniqueSupply, SplitUniqSupply,
- Bag, Maybe, MaybeErr, Error(..), PprStyle, Pretty(..),
- PrettyRep, SrcLoc, Subst, TyVar, TyVarTemplate, TyCon,
- Class, UniType, TauType(..), ThetaType(..), SigmaType(..),
- UnifyErrContext, Unique, Expr,
- TypecheckedExpr(..), TypecheckedPat, Id, IdInfo, Inst,
- GlobalSwitch, SUniqSM(..), Rn4M(..), GlobalNameFuns(..),
- GlobalNameFun(..), Name, ProtoName
-
- IF_ATTACK_PRAGMAS(COMMA getSUnique COMMA getSUniques)
- IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA mkUniqueGrimily)
- IF_ATTACK_PRAGMAS(COMMA applySubstToId)
- IF_ATTACK_PRAGMAS(COMMA applySubstToInst)
- IF_ATTACK_PRAGMAS(COMMA applySubstToThetaTy)
- IF_ATTACK_PRAGMAS(COMMA applySubstToTy)
- IF_ATTACK_PRAGMAS(COMMA applySubstToTyVar)
- ) where
-
-import AbsSyn
-import AbsUniType ( TyVar, TyVarTemplate, TyCon, Class, UniType,
- TauType(..), ThetaType(..), SigmaType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Bag ( Bag, snocBag, emptyBag, isEmptyBag )
-import CmdLineOpts ( GlobalSwitch )
-import Errors ( noInstanceErr, unifyErr, pprBagOfErrors,
- Error(..), UnifyErrInfo(..), UnifyErrContext(..)
- )
-import FiniteMap ( emptyFM, FiniteMap )
-import Id ( applySubstToId )
-import Inst ( applySubstToInst )
-import InstEnv ( lookupInst, lookupNoBindInst, Inst )
-import Maybes ( Maybe(..), MaybeErr(..) )
-import Pretty
-import RenameMonad4 ( Rn4M(..), GlobalNameFuns(..), GlobalNameFun(..) )
-import SrcLoc ( mkUnknownSrcLoc )
-import Subst
-import Unify
-import SplitUniq
-import Unique
-import Util
-
-infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenLazilyNF_Tc`
-\end{code}
+module TcMonad(
+ TcM(..), NF_TcM(..), TcDown, TcEnv,
+ SST_R, FSST_R,
-%************************************************************************
-%* *
-\subsection[TcM-TcM]{Plain @TcM@ monadery}
-%* *
-%************************************************************************
+ initTc,
+ returnTc, thenTc, thenTc_, mapTc, listTc,
+ foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
+ mapBagTc, fixTc, tryTc,
-The following @TcM@ is of the garden variety which can fail, and does
-as soon as possible.
+ returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
+ listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
-\begin{code}
--- internal use only...
-type InTcM output
- = (GlobalSwitch -> Bool) -- so we can chk cmd-line switches
- -> [UniType] -- types used for defaulting; down only
- -> Subst -- substitution; threaded
- -> SplitUniqSupply -- threaded
- -> Bag Error -- threaded
- -> SrcLoc -- only passed downwards
- -> output
-
-data TcResult result
- = TcSucceeded result
- Subst
- (Bag Error)
- | TcFailed Subst
- (Bag Error)
-
-type TcM result
- = InTcM (TcResult result)
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenTc #-}
-{-# INLINE thenTc_ #-}
-{-# INLINE returnTc #-}
-#endif
-
-thenTc :: TcM a -> (a -> TcM b) -> TcM b
-thenTc_ :: TcM a -> TcM b -> TcM b
-
-thenTc expr cont sw_chkr dtys subst us errs src_loc
- = case splitUniqSupply us of { (s1, s2) ->
- case (expr sw_chkr dtys subst s1 errs src_loc) of
- TcFailed subst errs -> TcFailed subst errs
- TcSucceeded result subst2 errs2
- -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
- }
-
-thenTc_ expr cont sw_chkr dtys subst us errs src_loc
- = case splitUniqSupply us of { (s1, s2) ->
- case (expr sw_chkr dtys subst s1 errs src_loc) of
- TcFailed subst errs -> TcFailed subst errs
- TcSucceeded _ subst2 errs2
- -> cont sw_chkr dtys subst2 s2 errs2 src_loc
- }
-
-returnTc :: a -> TcM a
-returnTc result sw_chkr dtys subst us errs src_loc
- = TcSucceeded result subst errs
-
-failTc err sw_chkr dtys subst us errs src_loc
- = TcFailed subst (errs `snocBag` err)
-\end{code}
+ checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
+ failTc, warnTc, recoverTc, recoverNF_Tc,
-@recoverTc@ recovers from an error, by providing a value to use
-instead. It is also lazy, in that it always succeeds immediately; the
-thing inside is only even looked at when you pull on the errors, or on
-the value returned.
+ tcGetEnv, tcSetEnv,
+ tcGetDefaultTys, tcSetDefaultTys,
+ tcGetUnique, tcGetUniques,
-@recoverQuietlyTc@ doesn't even report the errors found---it is used
-when looking at pragmas.
+ tcAddSrcLoc, tcGetSrcLoc,
+ tcAddErrCtxtM, tcSetErrCtxtM,
+ tcAddErrCtxt, tcSetErrCtxt,
-\begin{code}
-recoverTc, recoverQuietlyTc :: a -> TcM a -> NF_TcM a
+ tcNewMutVar, tcReadMutVar, tcWriteMutVar,
-recoverTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
- = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
- TcSucceeded result subst_out errs_out ->
- (result, combineSubstUndos subst_out, errs_out)
+ rn4MtoTcM,
- TcFailed subst_out errs_out ->
- (use_this_if_err, undoSubstUndos subst_out, errs_out)
- -- Note that we return the *undone* substitution
- -- and the *incoming* UniqueSupply
+ -- For closure
+ MutableVar(..), _MutableArray
+ ) where
+
+
+import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env
+
+import Type ( Type(..), GenType )
+import TyVar ( TyVar(..), GenTyVar )
+import Usage ( Usage(..), GenUsage )
+import ErrUtils ( Error(..), Message(..), ErrCtxt(..),
+ TcWarning(..), TcError(..), mkTcErr )
+
+import SST
+import RnMonad4
+import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) )
+
+import Bag ( Bag, emptyBag, isEmptyBag,
+ foldBag, unitBag, unionBags, snocBag )
+import FiniteMap ( FiniteMap, emptyFM )
+import Pretty ( Pretty(..), PrettyRep )
+import PprStyle ( PprStyle )
+import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
+import Maybes ( MaybeErr(..) )
+import Name ( Name )
+import ProtoName ( ProtoName )
+import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
+import UniqFM ( UniqFM, emptyUFM )
+import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
+import Unique ( Unique )
+import Util
-recoverQuietlyTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
- = (r2, s2, e2)
- where
- (r2, s2, e2)
- = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
- TcSucceeded result subst_out errs_out ->
- (result, combineSubstUndos subst_out, errs_out)
-
- TcFailed subst_out errs_out ->
- (use_this_if_err, undoSubstUndos subst_out, errs_in)
- -- Note that we return the *undone* substitution,
- -- the *incoming* UniqueSupply, and the *incoming* errors
+infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
\end{code}
-The following @TcM@ checks a condition and fails with the given error
-message.
-\begin{code}
-checkTc :: Bool -> Error -> TcM ()
-
-checkTc True err = failTc err
-checkTc False err = returnTc ()
-
-listTc :: [TcM a] -> TcM [a]
-
-listTc [] = returnTc []
-listTc (x:xs)
- = x `thenTc` \ r ->
- listTc xs `thenTc` \ rs ->
- returnTc (r:rs)
-
-mapTc :: (a -> TcM b) -> [a] -> TcM [b]
-mapTc f [] = returnTc []
-mapTc f (x:xs)
- = f x `thenTc` \ r ->
- mapTc f xs `thenTc` \ rs ->
- returnTc (r:rs)
-
-mapAndUnzipTc :: (a -> TcM (b, c)) -> [a] -> TcM ([b], [c])
-
-mapAndUnzipTc f [] = returnTc ([], [])
-mapAndUnzipTc f (x:xs)
- = f x `thenTc` \ (r1, r2) ->
- mapAndUnzipTc f xs `thenTc` \ (rs1, rs2) ->
- returnTc (r1:rs1, r2:rs2)
-
-foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
-foldlTc f a [] = returnTc a
-foldlTc f a (b:bs) = f a b `thenTc` \ a2 ->
- foldlTc f a2 bs
-
-fixTc :: (x -> TcM x) -> TcM x
-fixTc m sw_chkr dtys subst us errs src_loc
- = lim
- where
- lim = m result sw_chkr dtys subst us errs src_loc
- result = case lim of
- TcSucceeded result _ _ -> result
-#ifdef DEBUG
- TcFailed _ errs -> pprPanic "Failed in fixTc:\n" (pprBagOfErrors PprDebug errs)
-#endif
-\end{code}
-
-And the machinery to start things up:
+\section{TcM, NF_TcM: the type checker monads}
+%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-aRRAY_SIZE :: Int
-aRRAY_SIZE = 511
-
-initTc :: (GlobalSwitch -> Bool)
- -> SplitUniqSupply
- -> TcM result
- -> MaybeErr result (Bag Error)
-
-initTc sw_chkr us tc
- = case (tc sw_chkr [{-no defaults-}] init_subst us emptyBag mkUnknownSrcLoc) of
- TcFailed _ errs -> Failed errs
- TcSucceeded result subst2 errs
- -> if isEmptyBag errs then
- Succeeded result
- else
- Failed errs
-
-init_subst = mkEmptySubst aRRAY_SIZE -- out here to avoid initTc CAF...sigh
+type NF_TcM s r = TcDown s -> TcEnv s -> SST s r
+type TcM s r = TcDown s -> TcEnv s -> FSST s r ()
\end{code}
-
-%************************************************************************
-%* *
-\subsection[TcM-NF_TcM]{No-fail @NF_TcM@ monadery}
-%* *
-%************************************************************************
-
-This is a no-fail version of a TcM.
-
\begin{code}
--- ToDo: re-order fields to match TcM?
-type NF_TcM result = InTcM (result, Subst, Bag Error)
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenNF_Tc #-}
-{-# INLINE thenLazilyNF_Tc #-}
-{-# INLINE returnNF_Tc #-}
-#endif
-
-thenNF_Tc, thenLazilyNF_Tc :: NF_TcM a -> (a -> InTcM b) -> InTcM b
--- ...Lazily... is purely a performance thing (WDP 95/09)
+-- With a builtin polymorphic type for _runSST the type for
+-- initTc should use TcM s r instead of TcM _RealWorld r
+
+initTc :: UniqSupply
+ -> TcM _RealWorld r
+ -> MaybeErr (r, Bag TcWarning)
+ (Bag TcError, Bag TcWarning)
+
+initTc us do_this
+ = _runSST (
+ newMutVarSST us `thenSST` \ us_var ->
+ newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
+ newMutVarSST emptyUFM `thenSST` \ tvs_var ->
+ let
+ init_down = TcDown [] us_var
+ mkUnknownSrcLoc
+ [] 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
+
+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
+
+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)
+
+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 -> TcM s b -> TcM s b
+thenTc_ m k down env
+ = m down env `thenFSST_` k down env
+
+returnTc :: a -> TcM s a
+returnTc val down env = returnFSST val
+
+mapTc :: (a -> TcM s b) -> [a] -> 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 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 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 f [] = returnTc ([],[])
+mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
+ mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
+ returnTc (r1:rs1, r2:rs2)
+
+mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d])
+mapAndUnzip3Tc f [] = returnTc ([],[],[])
+mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
+ 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 f bag
+ = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
+ b2 `thenTc` \ r2 ->
+ returnTc (unionBags r1 r2))
+ (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
+ (returnTc emptyBag)
+ bag
+
+fixTc :: (a -> TcM s a) -> TcM s a
+fixTc m env down = fixFSST (\ loop -> m loop env down)
\end{code}
-In particular, @thenNF_Tc@ has all of these types:
+@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!
+
\begin{pseudocode}
-thenNF_Tc :: NF_TcM a -> (a -> TcM b) -> TcM b
-thenNF_Tc :: NF_TcM a -> (a -> NF_TcM b) -> NF_TcM b
+forkNF_Tc :: NF_TcM s r -> NF_TcM s r
+forkNF_Tc m down env
+ = forkTcDown down `thenSST` \ down' ->
+ returnSST (_runSST (m down' (forkTcEnv env)))
\end{pseudocode}
-\begin{code}
-thenNF_Tc expr cont sw_chkr dtys subst us errs src_loc
- = case splitUniqSupply us of { (s1, s2) ->
- case (expr sw_chkr dtys subst s1 errs src_loc) of
- (result, subst2, errs2)
- -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
- }
-
-thenLazilyNF_Tc expr cont sw_chkr dtys subst us errs src_loc
- = let
- (s1, s2) = splitUniqSupply us
- in
- case (expr sw_chkr dtys subst s1 errs src_loc) of {
- (result, subst2, errs2)
- -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
- }
-
-returnNF_Tc :: a -> NF_TcM a
-returnNF_Tc result sw_chkr dtys subst us errs src_loc
- = (result, subst, errs)
-
-listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
-listNF_Tc [] = returnNF_Tc []
-listNF_Tc (x:xs)
- = x `thenNF_Tc` \ r ->
- listNF_Tc xs `thenNF_Tc` \ rs ->
- returnNF_Tc (r:rs)
-
-mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [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)
-
-fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
-fixNF_Tc m sw_chkr dtys subst us errs src_loc
- = lim
- where
- lim = m result sw_chkr dtys subst us errs src_loc
- (result, _, _) = lim
-\end{code}
-
-@noFailTc@ takes a \tr{TcM a} and returns a \tr{NF_TcM a}. You use it
-when you are darn sure that the TcM won't actually fail!
-
-\begin{code}
-noFailTc :: TcM a -> NF_TcM a
-
-noFailTc expr sw_chkr dtys subst us errs src_loc
- = case (expr sw_chkr dtys subst us errs src_loc) of
- TcFailed _ _ -> panic "Failure in noFailTc!"
- TcSucceeded result subst errs
- -> (result, subst, errs)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TcM-uniq-extract]{Extractings Uniques from the monad}
-%* *
-%************************************************************************
-
-These functions extract uniques from the monad. There are two unique
-supplies embedded in the monad.
-\begin{itemize}
-\item
-normal unique supply
-\item
-special unique supply for TyVars (these index the substitution)
-\end{itemize}
+Error handling
+~~~~~~~~~~~~~~
\begin{code}
-getUniquesTc :: Int -> NF_TcM [Unique]
-getUniquesTc n sw_chkr dtys subst us errs src_loc
- = case (getSUniques n us) of { uniques ->
- (uniques, subst, errs) }
-
--- This simpler version is often adequate:
-
-getUniqueTc :: NF_TcM Unique
-getUniqueTc sw_chkr dtys subst us errs src_loc
- = case (getSUnique us) of { unique ->
- (unique, subst, errs) }
-
-rn4MtoTcM :: GlobalNameFuns -> Rn4M a -> NF_TcM (a, Bag Error)
-
-rn4MtoTcM name_funs rn_action sw_chkr dtys subst us errs src_loc
- = let
- (rn_result, rn_errs)
- = rn_action sw_chkr name_funs emptyFM emptyBag us mkUnknownSrcLoc
- -- laziness may be good for you (see below)
+failTc :: Message -> TcM s a
+failTc err_msg down env
+ = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ foldr thenNF_Tc_ (returnNF_Tc []) ctxt down env `thenSST` \ ctxt_msgs ->
+ let
+ err = mkTcErr loc ctxt_msgs err_msg
in
- ((rn_result, rn_errs), subst, errs)
-
--- Special uniques for TyVars extracted from the substitution
-
-getTyVarUniquesTc :: Int -> NF_TcM [Unique]
-getTyVarUniquesTc n sw_chkr dtys subst us errs src_loc
- = returnNF_Tc uniques sw_chkr dtys subst2 us errs src_loc
+ writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
+ failFSST ()
where
- (subst2, uniques) = getSubstTyVarUniques n subst
-
-getTyVarUniqueTc :: NF_TcM Unique
-getTyVarUniqueTc sw_chkr dtys subst us errs src_loc
- = returnNF_Tc unique sw_chkr dtys subst2 us errs src_loc
+ errs_var = getTcErrs down
+ ctxt = getErrCtxt down
+ loc = getLoc down
+
+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
- (subst2, unique) = getSubstTyVarUnique subst
+ 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)
+
+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)
+
+-- (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
+
+checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true
+checkTc True err = returnTc ()
+checkTc False err = failTc err
+
+checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
+checkTcM True err = returnTc ()
+checkTcM False err = err
+
+checkMaybeTc :: Maybe val -> Message -> TcM s val
+checkMaybeTc (Just val) err = returnTc val
+checkMaybeTc Nothing err = failTc err
+
+checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
+checkMaybeTcM (Just val) err = returnTc val
+checkMaybeTcM Nothing err = err
\end{code}
-%************************************************************************
-%* *
-\subsection[TcM-extract]{Extractings other things from the monad}
-%* *
-%************************************************************************
-
-These are functions which extract things from the monad.
-
-Extending and applying the substitution.
-
-ToDo: Unify.lhs BackSubst.lhs Id.lhs Inst.lhs: The TcMonad is used in
-a number of places where only the sequenced substitution is required.
-A lighter weight sequence substitution monad would be more appropriate
-with TcMonad interface functions defined here.
-
+Mutable variables
+~~~~~~~~~~~~~~~~~
\begin{code}
-getTcSubst :: NF_TcM Subst
-applyTcSubstToTy :: TauType -> NF_TcM TauType
---UNUSED:applyTcSubstToThetaTy :: ThetaType -> NF_TcM ThetaType
-applyTcSubstToTyVar :: TyVar -> NF_TcM TauType
-applyTcSubstToId :: Id -> NF_TcM Id
-applyTcSubstToInst :: Inst -> NF_TcM Inst
-
-getTcSubst sw_chkr dtys subst us errs src_loc
- = returnNF_Tc subst sw_chkr dtys subst us errs src_loc
-
-applyTcSubstToTy ty sw_chkr dtys subst us errs src_loc
- = case (applySubstToTy subst ty) of { (subst2, new_tau_ty) ->
- returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
- }
-
-{- UNUSED:
-applyTcSubstToThetaTy theta_ty sw_chkr dtys subst us errs src_loc
- = case (applySubstToThetaTy subst theta_ty) of { (subst2, new_theta_ty) ->
- returnNF_Tc new_theta_ty sw_chkr dtys subst2 us errs src_loc
- }
--}
-
-applyTcSubstToTyVar tyvar sw_chkr dtys subst us errs src_loc
- = case (applySubstToTyVar subst tyvar) of { (subst2, new_tau_ty) ->
- returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
- }
-
-applyTcSubstToId tyvar sw_chkr dtys subst us errs src_loc
- = case (applySubstToId subst tyvar) of { (subst2, new_tau_ty) ->
- returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
- }
-
-applyTcSubstToInst inst sw_chkr dtys subst us errs src_loc
- = case (applySubstToInst subst inst) of { (subst2, new_inst) ->
- returnNF_Tc new_inst sw_chkr dtys subst2 us errs src_loc
- }
-
-applyTcSubstToTyVars :: [TyVar] -> NF_TcM [UniType]
-applyTcSubstToTys :: [TauType] -> NF_TcM [TauType]
-
-applyTcSubstToTyVars tyvars = mapNF_Tc applyTcSubstToTyVar tyvars
-applyTcSubstToTys tys = mapNF_Tc applyTcSubstToTy tys
-applyTcSubstToInsts insts = mapNF_Tc applyTcSubstToInst insts
-\end{code}
+tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
+tcNewMutVar val down env = newMutVarSST val
-\begin{code}
-extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> TcM ()
-
-extendSubstTc tyvar ty err_ctxt sw_chkr dtys subst us errs src_loc
- = case (extendSubst tyvar ty subst) of { (new_subst, extend_result) ->
- case extend_result of
- SubstOK ->
- TcSucceeded () new_subst errs
-
- OccursCheck tyvar ty ->
- TcFailed new_subst
- (errs `snocBag` (unifyErr (TypeRec tyvar ty) err_ctxt src_loc))
-
- AlreadyBound ty1 ->
- -- This should only happen in the case of a call to
- -- extendSubstTc from the unifier! The way things are now
- -- we can't check for the AlreadyBound case in other calls
- -- to extendSubstTc, but we're confident it never shows up.
- -- Ugh!
- unifyTauTy ty1 ty err_ctxt sw_chkr dtys new_subst us errs src_loc
- }
+tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
+tcWriteMutVar var val down env = writeMutVarSST var val
+
+tcReadMutVar :: MutableVar s a -> NF_TcM s a
+tcReadMutVar var down env = readMutVarSST var
\end{code}
-@pruneSubstTc@ does nothing with an array substitution implementation!!!
+Environment
+~~~~~~~~~~~
\begin{code}
-pruneSubstTc :: [TyVar] -- Type vars whose substitutions should be kept
- -> TcM a -- Type-check this
- -> TcM a -- Return same result but pruned subst
+tcGetEnv :: NF_TcM s (TcEnv s)
+tcGetEnv down env = returnSST env
-pruneSubstTc keep_tyvars m sw_chkr dtys subst uniqs errs src_loc
- = m sw_chkr dtys subst uniqs errs src_loc
+tcSetEnv :: TcEnv s -> TcM s a -> TcM s a
+tcSetEnv new_env m down old_env = m down new_env
\end{code}
-\begin{code}
-getSwitchCheckerTc :: NF_TcM (GlobalSwitch -> Bool)
-getSwitchCheckerTc sw_chkr = returnNF_Tc sw_chkr sw_chkr
-\end{code}
+Source location
+~~~~~~~~~~~~~~~
\begin{code}
-getDefaultingTys :: NF_TcM [UniType]
-getDefaultingTys sw_chkr dtys = returnNF_Tc dtys sw_chkr dtys
+tcGetDefaultTys :: NF_TcM s [Type]
+tcGetDefaultTys down env = returnSST (getDefaultTys down)
-setDefaultingTys :: [UniType] -> TcM a -> TcM a
-setDefaultingTys dtys action sw_chkr _ subst us errs src_loc
- = action sw_chkr dtys subst us errs src_loc
-\end{code}
-
-\begin{code}
-addSrcLocTc :: SrcLoc -> TcM a -> TcM a
-addSrcLocTc new_locn expr sw_chkr dtys subst us errs src_loc
- = expr sw_chkr dtys subst us errs new_locn
+tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r
+tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
-getSrcLocTc :: NF_TcM SrcLoc
-getSrcLocTc sw_chkr dtys subst us errs src_loc
- = (src_loc, subst, errs)
-\end{code}
+tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a
+tcAddSrcLoc loc m down env = m (setLoc down loc) env
-%************************************************************************
-%* *
-\subsection[TcM-check]{Error-detecting functions}
-%* *
-%************************************************************************
+tcGetSrcLoc :: NF_TcM s SrcLoc
+tcGetSrcLoc down env = returnSST (getLoc down)
-The following TcM checks a Maybe type and fails with the given
-error message.
+tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s 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
-\begin{code}
-checkMaybeTc :: Maybe val -> Error -> TcM val
-checkMaybeTc (Just result) err = returnTc result
-checkMaybeTc Nothing err = failTc err
-
-checkMaybesTc :: [Maybe val] -> Error -> TcM [val]
-checkMaybesTc [] err = returnTc []
-checkMaybesTc (Nothing:xs) err = failTc err
-checkMaybesTc ((Just v):xs) err
- = checkMaybesTc xs err `thenTc` \ xs2 ->
- returnTc (v:xs2)
-
-checkMaybeErrTc :: MaybeErr val err -> (err -> Error) -> TcM val
-checkMaybeErrTc (Succeeded result) errfun = returnTc result
-checkMaybeErrTc (Failed err) errfun = failTc (errfun err)
-
-{- UNUSED:
-checkMaybeErrsTc :: [MaybeErr val err] -> (err -> Error) -> TcM [val]
-
-checkMaybeErrsTc [] err_fun = returnTc []
-checkMaybeErrsTc ((Failed err) :xs) err_fun = failTc (err_fun err)
-checkMaybeErrsTc ((Succeeded v):xs) err_fun
- = checkMaybeErrsTc xs err_fun `thenTc` \ xs2 ->
- returnTc (v:xs2)
--}
+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
\end{code}
-%************************************************************************
-%* *
-\subsection[TcM-Insts]{Looking up instances}
-%* *
-%************************************************************************
+Unique supply
+~~~~~~~~~~~~~
\begin{code}
-lookupInst_Tc :: Inst -> TcM (TypecheckedExpr, [Inst])
-
-lookupInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
- = case (lookupInst uniqs inst) of
- Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
-
- Just (expr, insts) -> TcSucceeded (expr, insts) subst errs
-
-lookupNoBindInst_Tc :: Inst -> TcM [Inst]
-
-lookupNoBindInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
- = case (lookupNoBindInst uniqs inst) of
- Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
-
- Just insts -> TcSucceeded insts subst errs
+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
+ 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
+ where
+ u_var = getUniqSupplyVar down
\end{code}
-
-
-
-
-
-%************************************************************************
-%* *
-\subsection[Baby_TcM]{``Baby'' @TcM@ monadery---when we don't need the full bang}
-%* *
-%************************************************************************
-
-The "baby" Tc monad doesn't pass around the substitution.
-That means you can't use it to type-check bindings, but you can use
-if for everything else (interfaces, type decls, first pass of class and
-instance decls etc).
-
-Less importantly, it doesn't pass around the list of default decls either.
-
-
-Type declarations
-~~~~~~~~~~~~~~~~~
+\section{TcDown}
+%~~~~~~~~~~~~~~~
\begin{code}
-type Baby_TcM result
- = (GlobalSwitch -> Bool)
- -> SplitUniqSupply
- -> Bag Error -- threaded
- -> SrcLoc -- only passed downwards
- -> Baby_TcResult result
+data TcDown s
+ = TcDown
+ [Type] -- Types used for defaulting
-data Baby_TcResult result
- = BabyTcFailed (Bag Error)
+ (MutableVar s UniqSupply) -- Unique supply
- | BabyTcSucceeded result (Bag Error)
-\end{code}
+ SrcLoc -- Source location
+ (ErrCtxt s) -- Error context
+ (MutableVar s (Bag TcWarning,
+ Bag TcError))
+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
+\end{code}
-Standard plumbing
-~~~~~~~~~~~~~~~~~
+-- These selectors are *local* to TcMonad.lhs
\begin{code}
-thenB_Tc :: Baby_TcM a -> (a -> Baby_TcM b) -> Baby_TcM b
-returnB_Tc :: a -> Baby_TcM a
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenB_Tc #-}
-{-# INLINE returnB_Tc #-}
-#endif
-
-thenB_Tc a b sw us errs loc
- = case (splitUniqSupply us) of { (s1, s2) ->
- case (a sw s1 errs loc) of
- BabyTcFailed errs2 -> BabyTcFailed errs2
- BabyTcSucceeded a_res errs2 -> b a_res sw s2 errs2 loc
- }
-
-returnB_Tc result sw us errs loc = BabyTcSucceeded result errs
-failB_Tc err sw us errs loc = BabyTcFailed (errs `snocBag` err)
-
-recoverIgnoreErrorsB_Tc return_on_failure try_this sw us errs loc
- = BabyTcSucceeded result errs
- where
- result = case try_this sw us emptyBag loc of
- BabyTcSucceeded result errs_from_branch -> result
- BabyTcFailed errs_from_branch -> return_on_failure
+getTcErrs (TcDown def us loc ctxt errs) = errs
+setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
-fixB_Tc :: (a -> Baby_TcM a) -> Baby_TcM a
-fixB_Tc k sw us errs loc
- = result
- where
- result = k val sw us errs loc
- val = case result of
- BabyTcSucceeded val errs -> val
- BabyTcFailed errs -> panic "fixB_Tc failed"
-
-babyTcMtoTcM :: Baby_TcM a -> TcM a
-babyTcMtoTcM m sw_chkr dtys subst us errs src_loc
- = case m sw_chkr us errs src_loc of
- BabyTcSucceeded result errs2 -> TcSucceeded result subst errs2
- BabyTcFailed errs2 -> TcFailed subst errs2
-
-babyTcMtoNF_TcM :: Baby_TcM a -> NF_TcM a
-babyTcMtoNF_TcM m sw_chkr dtys subst us errs src_loc
- = case m sw_chkr us errs src_loc of
- BabyTcSucceeded result errs2 -> (result, subst, errs2)
- BabyTcFailed errs2 -> panic "babyTcMtoNF_TcM"
-\end{code}
+getDefaultTys (TcDown def us loc ctxt errs) = def
+setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
-\begin{code}
-uniqSMtoBabyTcM :: SUniqSM a -> Baby_TcM a
+getLoc (TcDown def us loc ctxt errs) = loc
+setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
-uniqSMtoBabyTcM u_action sw us errs loc
- = let
- u_result = u_action us
- -- at least one use *needs* this laziness
- in
- BabyTcSucceeded u_result errs
-\end{code}
+getUniqSupplyVar (TcDown def us loc ctxt errs) = us
-\begin{code}
-thenB_Tc_ m k = m `thenB_Tc` \ _ ->
- k
-
-mapB_Tc :: (a -> Baby_TcM b) -> [a] -> Baby_TcM [b]
-mapB_Tc f [] = returnB_Tc []
-mapB_Tc f (x:xs) = f x `thenB_Tc` \ fx ->
- mapB_Tc f xs `thenB_Tc` \ fxs ->
- returnB_Tc (fx:fxs)
+setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
+addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
+getErrCtxt (TcDown def us loc ctxt errs) = ctxt
\end{code}
-
-Primitives
-~~~~~~~~~~
+@forkTcDown@ makes a new "down" blob for a lazily-computed fork
+of the type checker.
\begin{code}
-getUniqueB_Tc :: Baby_TcM Unique
-getUniquesB_Tc :: Int -> Baby_TcM [Unique]
-
-getUniqueB_Tc sw us errs loc
- = case (getSUnique us) of { unique ->
- BabyTcSucceeded unique errs }
-
-getUniquesB_Tc n sw us errs loc
- = case (getSUniques n us) of { uniques ->
- BabyTcSucceeded uniques errs }
-
-addSrcLocB_Tc :: SrcLoc -> Baby_TcM a -> Baby_TcM a
-addSrcLocB_Tc new_locn m sw us errs loc
- = m sw us errs new_locn
+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_`
-getSrcLocB_Tc sw us errs loc = BabyTcSucceeded loc errs
+ -- Make fresh MutVars for the unique supply and errors
+ newMutVarSST us2 `thenSST` \ u_var' ->
+ newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' ->
-getSwitchCheckerB_Tc :: Baby_TcM (GlobalSwitch -> Bool)
-getSwitchCheckerB_Tc sw_chkr us errs loc = BabyTcSucceeded sw_chkr errs
+ -- Done
+ returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
\end{code}
-Useful functions
-~~~~~~~~~~~~~~~~
+\section{rn4MtoTcM}
+%~~~~~~~~~~~~~~~~~~
\begin{code}
-checkB_Tc :: Bool -> Error -> Baby_TcM ()
+rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error)
-checkB_Tc True err = failB_Tc err
-checkB_Tc False err = returnB_Tc ()
+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}
projects / ghc-hetmet.git / blobdiff