X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=1ff8b37c2aa2e59985bb3ef295ce342524f818a9;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=71c7dd1ae20905b2ee409b57ee1268273aa45d85;hpb=fa44695e06cf83d8bcef2c826cb6b39d6ffc49c0;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 71c7dd1..1ff8b37 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -1,8 +1,11 @@ \begin{code} -#include "HsVersions.h" - module TcMonad( - SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv, + TcType, TcMaybe(..), TcBox, + TcTauType, TcThetaType, TcRhoType, + TcTyVar, TcTyVarSet, + TcKind, + + TcM, NF_TcM, TcDown, TcEnv, SST_R, FSST_R, initTc, @@ -12,12 +15,14 @@ module TcMonad( uniqSMToTcM, - returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc, + 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, @@ -27,47 +32,71 @@ module TcMonad( tcAddErrCtxtM, tcSetErrCtxtM, tcAddErrCtxt, tcSetErrCtxt, - tcNewMutVar, tcReadMutVar, tcWriteMutVar, + tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef, - SYN_IE(TcError), SYN_IE(TcWarning), - mkTcErr, arityErr, - - -- For closure - SYN_IE(MutableVar), -#if __GLASGOW_HASKELL__ >= 200 - GHCbase.MutableArray -#else - _MutableArray -#endif + TcError, TcWarning, TidyTypeEnv, 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, GenType ) +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 Var ( GenTyVar ) +import VarEnv ( TyVarEnv, emptyVarEnv ) +import VarSet ( GenTyVarSet ) +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, - SYN_IE(UniqSM), initUs ) import Unique ( Unique ) import Util -import Pretty -import PprStyle ( PprStyle(..) ) +import Outputable + +import GlaExts ( State#, RealWorld ) + infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_` \end{code} +Types +~~~~~ +\begin{code} +type TcType s = GenType (TcBox s) -- Used during typechecker + -- 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 TcKind s = TcType s + +type TcThetaType s = [(Class, [TcType s])] +type TcRhoType s = TcType s -- No ForAllTys +type TcTauType s = TcType s -- No DictTys or ForAllTys + +type TcBox s = TcRef s (TcMaybe s) + +data TcMaybe s = UnBound + | BoundTo (TcType s) + +-- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s), +-- because you get a synonym loop if you do! + +type TcTyVar s = GenTyVar (TcBox s) +type TcTyVarSet s = GenTyVarSet (TcBox s) +\end{code} + + \section{TcM, NF_TcM: the type checker monads} %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -77,21 +106,17 @@ type TcM s r = TcDown s -> TcEnv s -> FSST s r () \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) + -> (TcRef RealWorld (UniqFM a) -> TcEnv RealWorld) + -> TcM RealWorld r + -> (Maybe r, Bag WarnMsg, Bag ErrMsg) -initTc us do_this +initTc us initenv do_this = runSST ( newMutVarSST us `thenSST` \ us_var -> newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> @@ -100,7 +125,7 @@ initTc us do_this init_down = TcDown [] us_var noSrcLoc [] errs_var - init_env = initEnv tvs_var + init_env = initenv tvs_var in recoverSST (\_ -> returnSST Nothing) @@ -108,9 +133,7 @@ initTc us do_this 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)) + returnSST (maybe_res, warns, errs) ) thenNF_Tc :: NF_TcM s a @@ -144,6 +167,16 @@ mapNF_Tc f (x:xs) = f x `thenNF_Tc` \ r -> mapNF_Tc f xs `thenNF_Tc` \ rs -> returnNF_Tc (r:rs) +foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b +foldrNF_Tc k z [] = returnNF_Tc z +foldrNF_Tc k z (x:xs) = foldrNF_Tc k z xs `thenNF_Tc` \r -> + k x r + +foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a +foldlNF_Tc k z [] = returnNF_Tc z +foldlNF_Tc k z (x:xs) = k z x `thenNF_Tc` \r -> + foldlNF_Tc k r xs + listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a] listNF_Tc [] = returnNF_Tc [] listNF_Tc (x:xs) = x `thenNF_Tc` \ r -> @@ -262,36 +295,69 @@ forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env Error handling ~~~~~~~~~~~~~~ \begin{code} -getErrsTc :: NF_TcM s (Bag Error, Bag Warning) +getErrsTc :: NF_TcM s (Bag ErrMsg, Bag WarnMsg) 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) -> - listNF_Tc ctxt down env `thenSST` \ ctxt_msgs -> + +failTc :: TcM s a +failTc down env + = failFSST () + +failWithTc :: Message -> TcM s a -- Add an error message and fail +failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg) + +addErrTc :: Message -> NF_TcM s () +addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg) + +-- The 'M' variants do the TidyTypeEnv bit +failWithTcM :: (TidyTypeEnv s, Message) -> TcM s a -- Add an error message and fail +failWithTcM env_and_msg + = addErrTcM env_and_msg `thenNF_Tc_` + failTc + +addErrTcM :: (TidyTypeEnv s, Message) -> NF_TcM s () -- Add an error message but don't fail +addErrTcM (tidy_env, err_msg) down env + = readMutVarSST errs_var `thenSST` \ (warns,errs) -> + do_ctxt tidy_env ctxt down env `thenSST` \ ctxt_msgs -> let - err = mkTcErr loc ctxt_msgs err_msg + err = addShortErrLocLine loc $ + vcat (err_msg : ctxt_to_use ctxt_msgs) in writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_` - failFSST () + returnSST () where errs_var = getTcErrs down ctxt = getErrCtxt down loc = getLoc down +do_ctxt tidy_env [] down env + = returnSST [] +do_ctxt tidy_env (c:cs) down env + = c tidy_env down env `thenSST` \ (tidy_env', m) -> + do_ctxt tidy_env' cs down env `thenSST` \ ms -> + returnSST (m:ms) + +-- warnings don't have an 'M' variant warnTc :: Bool -> Message -> NF_TcM s () -warnTc warn_if_true warn down env +warnTc warn_if_true warn_msg down env = if warn_if_true then - readMutVarSST errs_var `thenSST` \ (warns,errs) -> + readMutVarSST errs_var `thenSST` \ (warns,errs) -> + do_ctxt emptyTidyEnv ctxt down env `thenSST` \ ctxt_msgs -> + let + warn = addShortWarnLocLine loc $ + vcat (warn_msg : ctxt_to_use ctxt_msgs) + in writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_` returnSST () else returnSST () where errs_var = getTcErrs down + ctxt = getErrCtxt down + loc = getLoc down recoverTc :: TcM s r -> TcM s r -> TcM s r recoverTc recover m down env @@ -301,6 +367,40 @@ 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) +-- (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 m down env + = newMutVarSST (emptyBag,emptyBag) `thenSST` \ m_errs_var -> + let + errs_var = getTcErrs down + propagate_errs _ + = readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) -> + readMutVarSST errs_var `thenSST` \ (warns, errs) -> + writeMutVarSST errs_var (warns `unionBags` m_warns, + errs `unionBags` m_errs) `thenSST_` + failFSST() + in + + recoverFSST propagate_errs $ + + m (setTcErrs down m_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. + readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) -> + if isEmptyBag m_errs then + returnFSST result + else + failFSST () -- This triggers the recoverFSST + -- (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. @@ -309,7 +409,6 @@ 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 @@ -322,9 +421,18 @@ tryTc recover m down env else recover down env +-- Run the thing inside, but throw away all its error messages. +-- discardErrsTc :: TcM s r -> TcM s r +-- discardErrsTc :: NF_TcM s r -> NF_TcM s r +discardErrsTc :: (TcDown s -> TcEnv s -> State# s -> a) + -> (TcDown s -> TcEnv s -> State# s -> a) +discardErrsTc m 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 +checkTc False err = failWithTc err checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true checkTcM True err = returnTc () @@ -332,7 +440,7 @@ checkTcM False err = err 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 @@ -342,13 +450,15 @@ checkMaybeTcM Nothing err = err Mutable variables ~~~~~~~~~~~~~~~~~ \begin{code} -tcNewMutVar :: a -> NF_TcM s (MutableVar s a) +type TcRef s a = SSTRef s a + +tcNewMutVar :: a -> NF_TcM s (TcRef s a) tcNewMutVar val down env = newMutVarSST val -tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s () +tcWriteMutVar :: TcRef s a -> a -> NF_TcM s () tcWriteMutVar var val down env = writeMutVarSST var val -tcReadMutVar :: MutableVar s a -> NF_TcM s a +tcReadMutVar :: TcRef s a -> NF_TcM s a tcReadMutVar var down env = readMutVarSST var \end{code} @@ -359,7 +469,12 @@ Environment tcGetEnv :: NF_TcM s (TcEnv s) tcGetEnv down env = returnSST env -tcSetEnv :: TcEnv s -> TcM s a -> TcM s a +tcSetEnv :: TcEnv s + -> (TcDown s -> TcEnv s -> State# s -> b) + -> TcDown s -> TcEnv s -> State# s -> b +-- tcSetEnv :: TcEnv s -> TcM s a -> TcM s a +-- tcSetEnv :: TcEnv s -> NF_TcM s a -> NF_TcM s a + tcSetEnv new_env m down old_env = m down new_env \end{code} @@ -373,19 +488,27 @@ tcGetDefaultTys down env = returnSST (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 -> TcM s a -> TcM s a +-- tcAddSrcLoc :: SrcLoc -> NF_TcM s a -> NF_TcM s a +tcAddSrcLoc :: SrcLoc -> (TcDown s -> env -> result) + -> (TcDown s -> env -> result) tcAddSrcLoc loc m down env = m (setLoc down loc) env tcGetSrcLoc :: NF_TcM s SrcLoc tcGetSrcLoc down env = returnSST (getLoc down) -tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a +tcSetErrCtxtM, tcAddErrCtxtM :: (TidyTypeEnv s -> NF_TcM s (TidyTypeEnv 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 -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 + -> (TcDown s -> TcEnv s -> State# s -> b) + -> TcDown s -> TcEnv s -> State# s -> b +-- 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} @@ -397,7 +520,7 @@ tcGetUnique down env = readMutVarSST u_var `thenSST` \ uniq_supply -> let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply - uniq = getUnique uniq_s + uniq = uniqFromSupply uniq_s in writeMutVarSST u_var new_uniq_supply `thenSST_` returnSST uniq @@ -409,7 +532,7 @@ tcGetUniques n down env = readMutVarSST u_var `thenSST` \ uniq_supply -> let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply - uniqs = getUniques n uniq_s + uniqs = uniqsFromSupply n uniq_s in writeMutVarSST u_var new_uniq_supply `thenSST_` returnSST uniqs @@ -437,16 +560,26 @@ data TcDown s = TcDown [Type] -- Types used for defaulting - (MutableVar s UniqSupply) -- Unique supply + (TcRef s UniqSupply) -- Unique supply 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 + (TcRef s (Bag WarnMsg, + Bag ErrMsg)) + +-- The TidyTypeEnv gives us a chance to tidy up the type, +-- so it prints nicely in error messages +type TidyTypeEnv s = (FiniteMap FastString Int, -- Says what the 'next' unique to use + -- for this occname is + TyVarEnv (TcType s)) -- Current mapping + +emptyTidyEnv :: TidyTypeEnv s +emptyTidyEnv = (emptyFM, emptyVarEnv) + +type ErrCtxt s = [TidyTypeEnv s -> NF_TcM s (TidyTypeEnv s, 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 @@ -478,26 +611,21 @@ TypeChecking Errors 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}