X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=e595a839e4c1e5c3ef19f23d414737e7e7d149b6;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=59b9967710fed66f3730c4086deec9f8e23b08f1;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 59b9967..e595a83 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -1,6 +1,8 @@ \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, @@ -8,7 +10,7 @@ module TcMonad( foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc, mapBagTc, fixTc, tryTc, - returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, + returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc, checkTc, checkTcM, checkMaybeTc, checkMaybeTcM, @@ -24,39 +26,48 @@ module TcMonad( tcNewMutVar, tcReadMutVar, tcWriteMutVar, - rn4MtoTcM, + rnMtoTcM, + + SYN_IE(TcError), SYN_IE(TcWarning), + mkTcErr, arityErr, -- For closure - MutableVar(..), _MutableArray + SYN_IE(MutableVar), +#if __GLASGOW_HASKELL__ >= 200 + GHCbase.MutableArray +#else + _MutableArray +#endif ) where +IMP_Ubiq(){-uitous-} -import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env +IMPORT_DELOOPER(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 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 SST -import RnMonad4 -import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) +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 ) -import Pretty ( Pretty(..), PrettyRep ) -import PprStyle ( PprStyle ) -import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) +import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} ) +--import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) import Maybes ( MaybeErr(..) ) -import Name ( Name ) -import ProtoName ( ProtoName ) +--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(..) ) infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` \end{code} @@ -71,16 +82,22 @@ 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 - -> MaybeErr (r, Bag TcWarning) - (Bag TcError, Bag TcWarning) + -> 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 -> @@ -123,6 +140,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 -> @@ -214,10 +234,46 @@ 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} -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))) +forkNF_Tc :: NF_TcM s' r -> NF_TcM s r +forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env + = -- Get a fresh unique supply + readMutVarSST u_var `thenSST` \ us -> + let + (us1, us2) = splitUniqSupply us + in + writeMutVarSST u_var us1 `thenSST_` + returnSST ( runSST ( + newMutVarSST us2 `thenSST` \ u_var' -> + newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' -> + newMutVarSST emptyUFM `thenSST` \ tv_var' -> + let + down' = TcDown deflts us_var src_loc err_cxt err_var' + env' = forkEnv env tv_var' + in + m down' env' + + -- ToDo: optionally dump any error messages + )) +\end{pseudocode} + +@forkTcDown@ makes a new "down" blob for a lazily-computed fork +of the type checker. + +\begin{pseudocode} +forkTcDown (TcDown deflts u_var src_loc err_cxt err_var) + = -- Get a fresh unique supply + readMutVarSST u_var `thenSST` \ us -> + let + (us1, us2) = splitUniqSupply us + in + writeMutVarSST u_var us1 `thenSST_` + + -- Make fresh MutVars for the unique supply and errors + newMutVarSST us2 `thenSST` \ u_var' -> + newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' -> + + -- Done + returnSST (TcDown deflts u_var' src_loc err_cxt err_var') \end{pseudocode} @@ -226,8 +282,8 @@ Error handling \begin{code} 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 -> + = readMutVarSST errs_var `thenSST` \ (warns,errs) -> + listNF_Tc ctxt down env `thenSST` \ ctxt_msgs -> let err = mkTcErr loc ctxt_msgs err_msg in @@ -263,8 +319,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 () @@ -374,8 +442,8 @@ data TcDown s SrcLoc -- Source location (ErrCtxt s) -- Error context - (MutableVar s (Bag TcWarning, - Bag TcError)) + (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 @@ -401,44 +469,69 @@ 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} -@forkTcDown@ makes a new "down" blob for a lazily-computed fork -of the type checker. - -\begin{code} -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{code} - \section{rn4MtoTcM} %~~~~~~~~~~~~~~~~~~ \begin{code} -rn4MtoTcM :: GlobalNameMappers -> Rn4M a -> NF_TcM s (a, Bag Error) +rnMtoTcM :: RnEnv -> RnM REAL_WORLD a -> NF_TcM s (a, Bag Error) -rn4MtoTcM name_funs rn_action down env +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_action name_funs emptyFM emptyBag uniq_s mkUnknownSrcLoc + (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} + + +TypeChecking Errors +~~~~~~~~~~~~~~~~~~~ + +\begin{code} +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} + +