\begin{code}
module TcMonad(
- TcType,
- TcTauType, TcPredType, TcThetaType, TcRhoType,
- TcTyVar, TcTyVarSet,
- TcKind,
-
TcM, NF_TcM, TcDown, TcEnv,
initTc,
tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
tcAddErrCtxtM, tcSetErrCtxtM,
- tcAddErrCtxt, tcSetErrCtxt,
+ tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
- tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
+ tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
InstOrigin(..), InstLoc, pprInstLoc,
import {-# SOURCE #-} TcEnv ( TcEnv )
-import HsSyn ( HsOverLit )
+import HsLit ( HsOverLit )
import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
-import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
- )
+import TcType ( Type, Kind, TyVarDetails )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
import Class ( Class )
import Name ( Name )
-import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
+import Var ( Id, TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
import VarEnv ( TidyEnv, emptyTidyEnv )
-import VarSet ( TyVarSet )
import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
splitUniqSupply, mkSplitUniqSupply,
UniqSM, initUs_ )
%************************************************************************
%* *
-\subsection{Types}
-%* *
-%************************************************************************
-
-\begin{code}
-type TcTyVar = TyVar -- Might be a mutable tyvar
-type TcTyVarSet = TyVarSet
-
-type TcType = Type -- A TcType can have mutable type variables
- -- 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 TcPredType = PredType
-type TcThetaType = ThetaType
-type TcRhoType = RhoType
-type TcTauType = TauType
-type TcKind = TcType
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{The main monads: TcM, NF_TcM}
%* *
%************************************************************************
fixTc :: (a -> TcM a) -> TcM a
fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
fixTc m env down = fixIO (\ loop -> m loop env down)
+{-# NOINLINE fixTc #-}
+-- aargh! Not inlining fixTc alleviates a space leak problem.
+-- Normally fixTc is used with a lazy tuple match: if the optimiser is
+-- shown the definition of fixTc, it occasionally transforms the code
+-- in such a way that the code generator doesn't spot the selector
+-- thunks. Sigh.
recoverTc :: TcM r -> TcM r -> TcM r
recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r
failTc down env = give_up
give_up :: IO a
-give_up = IOERROR (userError "Typecheck failed")
+give_up = ioError (userError "Typecheck failed")
failWithTc :: Message -> TcM a -- Add an error message and fail
failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
m_errs_var <- newIORef (emptyBag,emptyBag)
catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
where
+ errs_var = getTcErrs down
+
my_recover m_errs_var
= do warns_and_errs <- readIORef m_errs_var
recover warns_and_errs down env
-- errors along the way.
(m_warns, m_errs) <- readIORef m_errs_var
if isEmptyBag m_errs then
- return result
+ -- No errors, so return normally, but don't lose the warnings
+ if isEmptyBag m_warns then
+ return result
+ else
+ do (warns, errs) <- readIORef errs_var
+ writeIORef errs_var (warns `unionBags` m_warns, errs)
+ return result
else
give_up -- This triggers the catch
tcReadMutVar :: TcRef a -> NF_TcM a
tcReadMutVar var down env = readIORef var
-tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar
-tcNewMutTyVar name kind down env = newMutTyVar name kind
-
-tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar
-tcNewSigTyVar name kind down env = newSigTyVar name kind
+tcNewMutTyVar :: Name -> Kind -> TyVarDetails -> NF_TcM TyVar
+tcNewMutTyVar name kind details down env = newMutTyVar name kind details
tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
tcReadMutTyVar tyvar down env = readMutTyVar tyvar
-- 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
+
+tcPopErrCtxt :: Either_TcM r -> Either_TcM r
+tcPopErrCtxt m down env = m (popErrCtxt down) env
\end{code}
where
u_var = getUniqSupplyVar down
-tcGetUniques :: Int -> NF_TcM [Unique]
-tcGetUniques n down env
+tcGetUniques :: NF_TcM [Unique]
+tcGetUniques down env
= do uniq_supply <- readIORef u_var
let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniqs = uniqsFromSupply n uniq_s
+ uniqs = uniqsFromSupply uniq_s
writeIORef u_var new_uniq_supply
return uniqs
where
setErrCtxt down msg = down{tc_ctxt=[msg]}
addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
+popErrCtxt down = case tc_ctxt down of
+ [] -> down
+ m : ms -> down{tc_ctxt = ms}
+
doptsTc :: DynFlag -> TcM Bool
doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
= return (dopt dflag dflags)
type TcWarning = Message
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
+ | otherwise = take 3 ctxt
arityErr kind name n m
= hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
= hsep [ptext SLIT("use of implicit parameter"), quotes (char '?' <> ppr name)]
pp_orig (IPBind name)
= hsep [ptext SLIT("binding for implicit parameter"), quotes (char '?' <> ppr name)]
+ pp_orig RecordUpdOrigin
+ = ptext SLIT("a record update")
+ pp_orig DataDeclOrigin
+ = ptext SLIT("the data type declaration")
+ pp_orig InstanceDeclOrigin
+ = ptext SLIT("the instance declaration")
pp_orig (LiteralOrigin lit)
= hsep [ptext SLIT("the literal"), quotes (ppr lit)]
pp_orig (PatOrigin pat)
= hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
- pp_orig (InstanceDeclOrigin)
- = ptext SLIT("an instance declaration")
pp_orig (ArithSeqOrigin seq)
= hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
pp_orig (SignatureOrigin)