#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, fixNF_Tc,
listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
- failTc, warnTc, recoverTc, recoverNF_Tc,
+ failTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
tcNewMutVar, tcReadMutVar, tcWriteMutVar,
- rnMtoTcM,
-
- 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
IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(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, TcTyVarSet )
+#endif
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), ErrCtxt(..),
- SYN_IE(Warning) )
+import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
+import CmdLineOpts ( opt_PprStyle_All, opt_PprUserLength )
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 ErrUtils ( SYN_IE(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}
\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
initTc :: UniqSupply
- -> TcM _RealWorld r
+ -> TcM REAL_WORLD r
-> MaybeErr (r, Bag Warning)
(Bag Error, Bag Warning)
newMutVarSST emptyUFM `thenSST` \ tvs_var ->
let
init_down = TcDown [] us_var
- mkUnknownSrcLoc
+ noSrcLoc
[] errs_var
init_env = initEnv tvs_var
in
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 ->
(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) ->
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_`
+ listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
+ let
+ full_warn = mkTcErr loc ctxt_msgs warn
+ in
+ writeMutVarSST errs_var (warns `snocBag` full_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
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_`
+ returnSST m_errs
+ in
+
+ recoverFSST (\ _ -> propagate_errs `thenSST_` failFSST ()) $
+
+ 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.
+ propagate_errs `thenSST` \ errs ->
+ if isEmptyBag errs then
+ returnFSST result
+ else
+ failFSST ()
+
-- (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.
= 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
else
recover down env
+-- Run the thing inside, but throw away all its error messages.
+discardErrsTc :: TcM s r -> TcM s r
+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
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}
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
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}
\end{code}
-\section{rn4MtoTcM}
-%~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-rnMtoTcM :: RnEnv -> RnM _RealWorld 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 pprPanic "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
-> 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}
projects / ghc-hetmet.git / blobdiff