\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,
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,
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}
\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 ->
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 ->
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}
\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
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 ()
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
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}
+
+
projects / ghc-hetmet.git / blobdiff