X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=d1b7a271726ab86c314516c887dcaf860c8f7b7b;hb=9a35cb417209de48cca57f1899f305cf76909bb3;hp=5614273ccf3a004c53f672d36d0d27e43328a3a2;hpb=f9120c200bcf613b58d742802172fb4c08171f0d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 5614273..d1b7a27 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -1,14 +1,19 @@ \begin{code} +#include "HsVersions.h" + module TcMonad( - TcM(..), NF_TcM(..), TcDown, TcEnv, + SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv, SST_R, FSST_R, initTc, returnTc, thenTc, thenTc_, mapTc, listTc, foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc, - mapBagTc, fixTc, tryTc, + mapBagTc, fixTc, tryTc, getErrsTc, + + uniqSMToTcM, + + returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc, - returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc, checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, @@ -24,43 +29,49 @@ module TcMonad( tcNewMutVar, tcReadMutVar, tcWriteMutVar, - rn4MtoTcM, - - TcError(..), TcWarning(..), + SYN_IE(TcError), SYN_IE(TcWarning), mkTcErr, arityErr, -- For closure - MutableVar(..), _MutableArray + SYN_IE(MutableVar), +#if __GLASGOW_HASKELL__ == 201 + GHCbase.MutableArray +#elif __GLASGOW_HASKELL__ == 201 + GlaExts.MutableArray +#else + _MutableArray +#endif ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 +IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env +#else +import {-# SOURCE #-} TcEnv ( TcEnv, initEnv ) +import {-# SOURCE #-} TcType ( TcMaybe ) +#endif -import Type ( Type(..), GenType ) -import TyVar ( TyVar(..), GenTyVar ) -import Usage ( Usage(..), GenUsage ) -import ErrUtils ( Error(..), Message(..), ErrCtxt(..), - Warning(..) ) +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 CmdLineOpts ( opt_PprStyle_All, opt_PprUserLength ) import SST ---import RnMonad4 ---LATER:import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) - import Bag ( Bag, emptyBag, isEmptyBag, foldBag, unitBag, unionBags, snocBag ) -import FiniteMap ( FiniteMap, emptyFM ) -import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) -import ErrUtils ( Error(..) ) +import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} ) import Maybes ( MaybeErr(..) ) ---import Name ( Name ) -import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc ) import UniqFM ( UniqFM, emptyUFM ) -import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply ) +import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply, + SYN_IE(UniqSM), initUs ) import Unique ( Unique ) import Util import Pretty -import PprStyle ( PprStyle(..) ) +import Outputable ( PprStyle(..), Outputable(..) ) + infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` \end{code} @@ -75,22 +86,28 @@ type TcM s r = TcDown s -> TcEnv s -> FSST s r () \end{code} \begin{code} --- With a builtin polymorphic type for _runSST the type for --- initTc should use TcM s r instead of TcM _RealWorld r +#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 initTc :: UniqSupply - -> TcM _RealWorld r + -> TcM REAL_WORLD r -> MaybeErr (r, Bag Warning) (Bag Error, Bag Warning) initTc us do_this - = _runSST ( + = runSST ( newMutVarSST us `thenSST` \ us_var -> newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> newMutVarSST emptyUFM `thenSST` \ tvs_var -> let init_down = TcDown [] us_var - mkUnknownSrcLoc + noSrcLoc [] errs_var init_env = initEnv tvs_var in @@ -127,6 +144,9 @@ thenNF_Tc_ m 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 -> @@ -213,12 +233,20 @@ fixTc :: (a -> TcM s a) -> TcM s a fixTc m env down = fixFSST (\ loop -> m loop env down) \end{code} -@forkNF_Tc@ runs a sub-typecheck action in a separate state thread. -This elegantly ensures that it can't zap any type variables that -belong to the main thread. We throw away any error messages! +@forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state +thread. Ideally, this elegantly ensures that it can't zap any type +variables that belong to the main thread. But alas, the environment +contains TyCon and Class environments that include (TcKind s) stuff, +which is a Royal Pain. By the time this fork stuff is used they'll +have been unified down so there won't be any kind variables, but we +can't express that in the current typechecker framework. + +So we compromise and use unsafeInterleaveSST. + +We throw away any error messages! -\begin{pseudocode} -forkNF_Tc :: NF_TcM s' r -> NF_TcM s r +\begin{code} +forkNF_Tc :: NF_TcM s r -> NF_TcM s r forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env = -- Get a fresh unique supply readMutVarSST u_var `thenSST` \ us -> @@ -226,44 +254,29 @@ forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env (us1, us2) = splitUniqSupply us in writeMutVarSST u_var us1 `thenSST_` - returnSST (_runSST ( - newMutVarSST us2 `thenSST` \ u_var' -> + + 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' - env' = forkEnv env tv_var' + down' = TcDown deflts us_var' src_loc err_cxt err_var' in - m down' env' - + m down' env -- ToDo: optionally dump any error messages - )) -\end{pseudocode} - -@forkTcDown@ makes a new "down" blob for a lazily-computed fork -of the type checker. - -\begin{pseudocode} -forkTcDown (TcDown deflts u_var src_loc err_cxt err_var) - = -- Get a fresh unique supply - readMutVarSST u_var `thenSST` \ us -> - let - (us1, us2) = splitUniqSupply us - in - writeMutVarSST u_var us1 `thenSST_` - - -- Make fresh MutVars for the unique supply and errors - newMutVarSST us2 `thenSST` \ u_var' -> - newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' -> - - -- Done - returnSST (TcDown deflts u_var' src_loc err_cxt err_var') -\end{pseudocode} + ) +\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 + failTc :: Message -> TcM s a failTc err_msg down env = readMutVarSST errs_var `thenSST` \ (warns,errs) -> @@ -303,8 +316,20 @@ recoverNF_Tc recover m down env 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 + + 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 () @@ -399,6 +424,17 @@ tcGetUniques n down env returnSST uniqs where u_var = getUniqSupplyVar down + +uniqSMToTcM :: UniqSM a -> NF_TcM s a +uniqSMToTcM m 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_` + returnSST (initUs uniq_s m) + where + u_var = getUniqSupplyVar down \end{code} @@ -442,29 +478,6 @@ getErrCtxt (TcDown def us loc ctxt errs) = ctxt \end{code} -\section{rn4MtoTcM} -%~~~~~~~~~~~~~~~~~~ - -\begin{code} -rn4MtoTcM = panic "TcMonad.rn4MtoTcM (ToDo LATER)" -{- LATER: -rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error) - -rn4MtoTcM name_funs rn_action down env - = readMutVarSST u_var `thenSST` \ uniq_supply -> - let - (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply - in - writeMutVarSST u_var new_uniq_supply `thenSST_` - let - (rn_result, rn_errs) - = rn_action name_funs emptyFM emptyBag uniq_s mkUnknownSrcLoc - in - returnSST (rn_result, rn_errs) - where - u_var = getUniqSupplyVar down --} -\end{code} TypeChecking Errors @@ -480,20 +493,30 @@ mkTcErr :: SrcLoc -- Where -> TcError -- The complete error report mkTcErr locn ctxt msg sty - = ppHang (ppBesides [ppr PprForUser locn, ppStr ": ", msg sty]) - 4 (ppAboves [msg sty | msg <- ctxt]) + = hang (hcat [ppr (PprForUser opt_PprUserLength) locn, ptext SLIT(": "), msg sty]) + 4 (vcat [msg sty | msg <- ctxt_to_use]) + where + ctxt_to_use = + if opt_PprStyle_All then + ctxt + else + takeAtMost 4 ctxt + takeAtMost :: Int -> [a] -> [a] + takeAtMost 0 ls = [] + takeAtMost n [] = [] + takeAtMost n (x:xs) = x:takeAtMost (n-1) xs arityErr kind name n m sty - = ppBesides [ ppStr "`", ppr sty name, ppStr "' should have ", - n_arguments, ppStr ", but has been given ", ppInt m, ppChar '.'] + = hsep [ ppr sty name, ptext SLIT("should have"), + n_arguments <> comma, text "but has been given", int m, char '.'] 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}