X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=e595a839e4c1e5c3ef19f23d414737e7e7d149b6;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=48cc7d90afc8591dca10fb8d48ecd029766789b9;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 48cc7d9..e595a83 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -1,718 +1,537 @@ -% -% (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, 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 +module TcMonad( + SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv, + SST_R, FSST_R, -infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc` -\end{code} + initTc, + returnTc, thenTc, thenTc_, mapTc, listTc, + foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc, + mapBagTc, fixTc, tryTc, -%************************************************************************ -%* * -\subsection[TcM-TcM]{Plain @TcM@ monadery} -%* * -%************************************************************************ + returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, + listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc, -The following @TcM@ is of the garden variety which can fail, and does -as soon as possible. + checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, + failTc, warnTc, recoverTc, recoverNF_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 + tcGetEnv, tcSetEnv, + tcGetDefaultTys, tcSetDefaultTys, + tcGetUnique, tcGetUniques, -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} + tcAddSrcLoc, tcGetSrcLoc, + tcAddErrCtxtM, tcSetErrCtxtM, + tcAddErrCtxt, tcSetErrCtxt, -@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. + tcNewMutVar, tcReadMutVar, tcWriteMutVar, -@recoverQuietlyTc@ doesn't even report the errors found---it is used -when looking at pragmas. + rnMtoTcM, -\begin{code} -recoverTc, recoverQuietlyTc :: a -> TcM a -> NF_TcM a + SYN_IE(TcError), SYN_IE(TcWarning), + mkTcErr, arityErr, -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) + -- For closure + SYN_IE(MutableVar), +#if __GLASGOW_HASKELL__ >= 200 + GHCbase.MutableArray +#else + _MutableArray +#endif + ) where - 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 +IMP_Ubiq(){-uitous-} -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 -\end{code} +IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env -The following @TcM@ checks a condition and fails with the given error -message. +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) ) -\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: +import SST +import RnMonad ( SYN_IE(RnM), RnDown, initRn, setExtraRn, + returnRn, thenRn, getImplicitUpRn + ) +import RnUtils ( SYN_IE(RnEnv) ) + +import Bag ( Bag, emptyBag, isEmptyBag, + foldBag, unitBag, unionBags, snocBag ) +import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} ) +--import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) +import Maybes ( MaybeErr(..) ) +--import Name ( Name ) +import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +import UniqFM ( UniqFM, emptyUFM ) +import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply ) +import Unique ( Unique ) +import Util +import Pretty +import PprStyle ( PprStyle(..) ) -\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 +infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` \end{code} -%************************************************************************ -%* * -\subsection[TcM-NF_TcM]{No-fail @NF_TcM@ monadery} -%* * -%************************************************************************ - -This is a no-fail version of a TcM. +\section{TcM, NF_TcM: the type checker monads} +%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} --- ToDo: re-order fields to match TcM? -type NF_TcM result = InTcM (result, Subst, Bag Error) +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} -#ifdef __GLASGOW_HASKELL__ -{-# INLINE thenNF_Tc #-} -{-# INLINE returnNF_Tc #-} +\begin{code} +#if __GLASGOW_HASKELL__ >= 200 +# define REAL_WORLD RealWorld +#else +# define REAL_WORLD _RealWorld #endif -thenNF_Tc :: NF_TcM a -> (a -> InTcM b) -> InTcM b +-- With a builtin polymorphic type for runSST the type for +-- initTc should use TcM s r instead of TcM RealWorld r + +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 -> + 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 + +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 + +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 (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} -\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 - } - -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} +@forkTcDown@ makes a new "down" blob for a lazily-computed fork +of the type checker. -@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{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_` -\begin{code} -noFailTc :: TcM a -> NF_TcM a + -- Make fresh MutVars for the unique supply and errors + newMutVarSST us2 `thenSST` \ u_var' -> + newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' -> -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} + -- Done + returnSST (TcDown deflts u_var' src_loc err_cxt err_var') +\end{pseudocode} -%************************************************************************ -%* * -\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) -> + listNF_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 `thenFSST` \ result -> + + -- 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 + +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} +tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r +tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env -\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 +tcAddSrcLoc :: SrcLoc -> TcM s a -> TcM s a +tcAddSrcLoc loc m down env = m (setLoc down loc) env -getSrcLocTc :: NF_TcM SrcLoc -getSrcLocTc sw_chkr dtys subst us errs src_loc - = (src_loc, subst, errs) -\end{code} - -%************************************************************************ -%* * -\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 Warning, + Bag Error)) +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 +getTcErrs (TcDown def us loc ctxt errs) = errs +setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs -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 - } +getDefaultTys (TcDown def us loc ctxt errs) = def +setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs -returnB_Tc result sw us errs loc = BabyTcSucceeded result errs -failB_Tc err sw us errs loc = BabyTcFailed (errs `snocBag` err) +getLoc (TcDown def us loc ctxt errs) = loc +setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs -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 +getUniqSupplyVar (TcDown def us loc ctxt errs) = us -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" +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} -\begin{code} -uniqSMtoBabyTcM :: SUniqSM a -> Baby_TcM a -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} +\section{rn4MtoTcM} +%~~~~~~~~~~~~~~~~~~ \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) +rnMtoTcM :: RnEnv -> RnM REAL_WORLD a -> NF_TcM s (a, Bag Error) + +rnMtoTcM rn_env 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_warns) + = initRn False{-*interface* mode! so we can see the builtins-} + (panic "rnMtoTcM:module") + rn_env uniq_s ( + rn_action `thenRn` \ result -> + + -- Though we are in "interface mode", we must + -- not have added anything to the ImplicitEnv! + getImplicitUpRn `thenRn` \ implicit_env@(v_env,tc_env) -> + if (isEmptyFM v_env && isEmptyFM tc_env) + then returnRn result + else panic "rnMtoTcM: non-empty ImplicitEnv!" +-- (ppAboves ([ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM v_env] +-- ++ [ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM tc_env])) + ) + in + returnSST (rn_result, rn_errs) + where + u_var = getUniqSupplyVar down \end{code} -Primitives -~~~~~~~~~~ +TypeChecking Errors +~~~~~~~~~~~~~~~~~~~ \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 - -getSrcLocB_Tc sw us errs loc = BabyTcSucceeded loc errs - -getSwitchCheckerB_Tc :: Baby_TcM (GlobalSwitch -> Bool) -getSwitchCheckerB_Tc sw_chkr us errs loc = BabyTcSucceeded sw_chkr errs +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 '.'] + 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"] \end{code} -Useful functions -~~~~~~~~~~~~~~~~ - -\begin{code} -checkB_Tc :: Bool -> Error -> Baby_TcM () - -checkB_Tc True err = failB_Tc err -checkB_Tc False err = returnB_Tc () -\end{code}