-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[TcMonad]{@TcMonad@: monad machinery for the typechecker}
-
\begin{code}
-#include "HsVersions.h"
+module TcMonad(
+ TcM, NF_TcM, TcDown, TcEnv,
-module TcMonad (
- TcM(..), TcResult{-abstract-},
- thenTc, thenTc_, returnTc, failTc, checkTc,
- listTc, mapTc, mapAndUnzipTc,
- fixTc, foldlTc, initTc,
- recoverTc, recoverQuietlyTc,
-
- NF_TcM(..),
- thenNF_Tc, thenLazilyNF_Tc, returnNF_Tc, listNF_Tc, mapNF_Tc,
- fixNF_Tc, noFailTc,
-
- Baby_TcM(..), Baby_TcResult{-abstract-},
- returnB_Tc, thenB_Tc, thenB_Tc_,
- failB_Tc, recoverIgnoreErrorsB_Tc,
- fixB_Tc, mapB_Tc,
- babyTcMtoTcM, babyTcMtoNF_TcM,
- getUniqueB_Tc, getUniquesB_Tc,
- addSrcLocB_Tc, getSrcLocB_Tc,
- getSwitchCheckerB_Tc, checkB_Tc,
- uniqSMtoBabyTcM,
-
- getSwitchCheckerTc,
- getDefaultingTys, setDefaultingTys,
- getUniquesTc, getUniqueTc,
- rn4MtoTcM,
-
- getTyVarUniquesTc, getTyVarUniqueTc,
-
- applyTcSubstToTy, applyTcSubstToTys,
---UNUSED: applyTcSubstToThetaTy,
- applyTcSubstToTyVar, applyTcSubstToTyVars,
- applyTcSubstToId,
- applyTcSubstToInst, applyTcSubstToInsts,
- extendSubstTc, pruneSubstTc,
-
- addSrcLocTc, getSrcLocTc,
- checkMaybeTc, checkMaybesTc,
- checkMaybeErrTc, -- UNUSED: checkMaybeErrsTc,
-
- lookupInst_Tc, lookupNoBindInst_Tc,
-
- -- and to make the interface self-sufficient ...
- UniqueSupply, SplitUniqSupply,
- Bag, Maybe, MaybeErr, Error(..), PprStyle, Pretty(..),
- PrettyRep, SrcLoc, Subst, TyVar, TyVarTemplate, TyCon,
- Class, UniType, TauType(..), ThetaType(..), SigmaType(..),
- UnifyErrContext, Unique, Expr,
- TypecheckedExpr(..), TypecheckedPat, Id, IdInfo, Inst,
- GlobalSwitch, SUniqSM(..), Rn4M(..), GlobalNameFuns(..),
- GlobalNameFun(..), Name, ProtoName
-
- IF_ATTACK_PRAGMAS(COMMA getSUnique COMMA getSUniques)
- IF_ATTACK_PRAGMAS(COMMA splitUniqSupply COMMA mkUniqueGrimily)
- IF_ATTACK_PRAGMAS(COMMA applySubstToId)
- IF_ATTACK_PRAGMAS(COMMA applySubstToInst)
- IF_ATTACK_PRAGMAS(COMMA applySubstToThetaTy)
- IF_ATTACK_PRAGMAS(COMMA applySubstToTy)
- IF_ATTACK_PRAGMAS(COMMA applySubstToTyVar)
- ) where
-
-import AbsSyn
-import AbsUniType ( TyVar, TyVarTemplate, TyCon, Class, UniType,
- TauType(..), ThetaType(..), SigmaType(..)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import Bag ( Bag, snocBag, emptyBag, isEmptyBag )
-import CmdLineOpts ( GlobalSwitch )
-import Errors ( noInstanceErr, unifyErr, pprBagOfErrors,
- Error(..), UnifyErrInfo(..), UnifyErrContext(..)
- )
-import FiniteMap ( emptyFM, FiniteMap )
-import Id ( applySubstToId )
-import Inst ( applySubstToInst )
-import InstEnv ( lookupInst, lookupNoBindInst, Inst )
-import Maybes ( Maybe(..), MaybeErr(..) )
-import Pretty
-import RenameMonad4 ( Rn4M(..), GlobalNameFuns(..), GlobalNameFun(..) )
-import SrcLoc ( mkUnknownSrcLoc )
-import Subst
-import Unify
-import SplitUniq
-import Unique
-import Util
-
-infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenLazilyNF_Tc`
-\end{code}
+ initTc,
+ returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
+ foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
+ mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
+ traceTc, ioToTc,
-%************************************************************************
-%* *
-\subsection[TcM-TcM]{Plain @TcM@ monadery}
-%* *
-%************************************************************************
+ uniqSMToTcM,
-The following @TcM@ is of the garden variety which can fail, and does
-as soon as possible.
+ returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
+ fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
-\begin{code}
--- internal use only...
-type InTcM output
- = (GlobalSwitch -> Bool) -- so we can chk cmd-line switches
- -> [UniType] -- types used for defaulting; down only
- -> Subst -- substitution; threaded
- -> SplitUniqSupply -- threaded
- -> Bag Error -- threaded
- -> SrcLoc -- only passed downwards
- -> output
-
-data TcResult result
- = TcSucceeded result
- Subst
- (Bag Error)
- | TcFailed Subst
- (Bag Error)
-
-type TcM result
- = InTcM (TcResult result)
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenTc #-}
-{-# INLINE thenTc_ #-}
-{-# INLINE returnTc #-}
-#endif
-
-thenTc :: TcM a -> (a -> TcM b) -> TcM b
-thenTc_ :: TcM a -> TcM b -> TcM b
-
-thenTc expr cont sw_chkr dtys subst us errs src_loc
- = case splitUniqSupply us of { (s1, s2) ->
- case (expr sw_chkr dtys subst s1 errs src_loc) of
- TcFailed subst errs -> TcFailed subst errs
- TcSucceeded result subst2 errs2
- -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
- }
+ listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
-thenTc_ expr cont sw_chkr dtys subst us errs src_loc
- = case splitUniqSupply us of { (s1, s2) ->
- case (expr sw_chkr dtys subst s1 errs src_loc) of
- TcFailed subst errs -> TcFailed subst errs
- TcSucceeded _ subst2 errs2
- -> cont sw_chkr dtys subst2 s2 errs2 src_loc
- }
+ checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
+ failTc, failWithTc, addErrTc, addErrsTc, warnTc,
+ recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+ addErrTcM, addInstErrTcM, failWithTcM,
-returnTc :: a -> TcM a
-returnTc result sw_chkr dtys subst us errs src_loc
- = TcSucceeded result subst errs
+ tcGetEnv, tcSetEnv,
+ tcGetDefaultTys, tcSetDefaultTys,
+ tcGetUnique, tcGetUniques,
+ doptsTc, getDOptsTc,
-failTc err sw_chkr dtys subst us errs src_loc
- = TcFailed subst (errs `snocBag` err)
-\end{code}
-
-@recoverTc@ recovers from an error, by providing a value to use
-instead. It is also lazy, in that it always succeeds immediately; the
-thing inside is only even looked at when you pull on the errors, or on
-the value returned.
+ tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
+ tcAddErrCtxtM, tcSetErrCtxtM,
+ tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
-@recoverQuietlyTc@ doesn't even report the errors found---it is used
-when looking at pragmas.
+ tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
+ tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
-\begin{code}
-recoverTc, recoverQuietlyTc :: a -> TcM a -> NF_TcM a
+ InstOrigin(..), InstLoc, pprInstLoc,
-recoverTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
- = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
- TcSucceeded result subst_out errs_out ->
- (result, combineSubstUndos subst_out, errs_out)
+ TcError, TcWarning, TidyEnv, emptyTidyEnv,
+ arityErr
+ ) where
- TcFailed subst_out errs_out ->
- (use_this_if_err, undoSubstUndos subst_out, errs_out)
- -- Note that we return the *undone* substitution
- -- and the *incoming* UniqueSupply
-
-recoverQuietlyTc use_this_if_err expr sw_chkr dtys subst uniqs_in errs_in src_loc
- = (r2, s2, e2)
- where
- (r2, s2, e2)
- = case (expr sw_chkr dtys (pushSubstUndos subst) uniqs_in errs_in src_loc) of
- TcSucceeded result subst_out errs_out ->
- (result, combineSubstUndos subst_out, errs_out)
-
- TcFailed subst_out errs_out ->
- (use_this_if_err, undoSubstUndos subst_out, errs_in)
- -- Note that we return the *undone* substitution,
- -- the *incoming* UniqueSupply, and the *incoming* errors
-\end{code}
-
-The following @TcM@ checks a condition and fails with the given error
-message.
+#include "HsVersions.h"
-\begin{code}
-checkTc :: Bool -> Error -> TcM ()
-
-checkTc True err = failTc err
-checkTc False err = returnTc ()
-
-listTc :: [TcM a] -> TcM [a]
-
-listTc [] = returnTc []
-listTc (x:xs)
- = x `thenTc` \ r ->
- listTc xs `thenTc` \ rs ->
- returnTc (r:rs)
-
-mapTc :: (a -> TcM b) -> [a] -> TcM [b]
-mapTc f [] = returnTc []
-mapTc f (x:xs)
- = f x `thenTc` \ r ->
- mapTc f xs `thenTc` \ rs ->
- returnTc (r:rs)
-
-mapAndUnzipTc :: (a -> TcM (b, c)) -> [a] -> TcM ([b], [c])
-
-mapAndUnzipTc f [] = returnTc ([], [])
-mapAndUnzipTc f (x:xs)
- = f x `thenTc` \ (r1, r2) ->
- mapAndUnzipTc f xs `thenTc` \ (rs1, rs2) ->
- returnTc (r1:rs1, r2:rs2)
-
-foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
-foldlTc f a [] = returnTc a
-foldlTc f a (b:bs) = f a b `thenTc` \ a2 ->
- foldlTc f a2 bs
-
-fixTc :: (x -> TcM x) -> TcM x
-fixTc m sw_chkr dtys subst us errs src_loc
- = lim
- where
- lim = m result sw_chkr dtys subst us errs src_loc
- result = case lim of
- TcSucceeded result _ _ -> result
-#ifdef DEBUG
- TcFailed _ errs -> pprPanic "Failed in fixTc:\n" (pprBagOfErrors PprDebug errs)
-#endif
-\end{code}
+import {-# SOURCE #-} TcEnv ( TcEnv )
+
+import HsLit ( HsOverLit )
+import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
+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, readMutTyVar, writeMutTyVar )
+import VarEnv ( TidyEnv, emptyTidyEnv )
+import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
+ splitUniqSupply, mkSplitUniqSupply,
+ UniqSM, initUs_ )
+import SrcLoc ( SrcLoc, noSrcLoc )
+import BasicTypes ( IPName )
+import UniqFM ( emptyUFM )
+import Unique ( Unique )
+import CmdLineOpts
+import Outputable
+
+import IOExts ( IORef, newIORef, readIORef, writeIORef,
+ unsafeInterleaveIO, fixIO
+ )
-And the machinery to start things up:
-\begin{code}
-aRRAY_SIZE :: Int
-aRRAY_SIZE = 511
-
-initTc :: (GlobalSwitch -> Bool)
- -> SplitUniqSupply
- -> TcM result
- -> MaybeErr result (Bag Error)
-
-initTc sw_chkr us tc
- = case (tc sw_chkr [{-no defaults-}] init_subst us emptyBag mkUnknownSrcLoc) of
- TcFailed _ errs -> Failed errs
- TcSucceeded result subst2 errs
- -> if isEmptyBag errs then
- Succeeded result
- else
- Failed errs
-
-init_subst = mkEmptySubst aRRAY_SIZE -- out here to avoid initTc CAF...sigh
+infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
\end{code}
%************************************************************************
%* *
-\subsection[TcM-NF_TcM]{No-fail @NF_TcM@ monadery}
+\subsection{The main monads: TcM, NF_TcM}
%* *
%************************************************************************
-This is a no-fail version of a TcM.
-
\begin{code}
--- ToDo: re-order fields to match TcM?
-type NF_TcM result = InTcM (result, Subst, Bag Error)
+type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
+type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenNF_Tc #-}
-{-# INLINE thenLazilyNF_Tc #-}
-{-# INLINE returnNF_Tc #-}
-#endif
+type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
+ -- Used only in this file for type signatures which
+ -- have a part that's polymorphic in whether it's NF_TcM or TcM
+ -- E.g. thenNF_Tc
-thenNF_Tc, thenLazilyNF_Tc :: NF_TcM a -> (a -> InTcM b) -> InTcM b
--- ...Lazily... is purely a performance thing (WDP 95/09)
+type TcRef a = IORef a
\end{code}
-In particular, @thenNF_Tc@ has all of these types:
-\begin{pseudocode}
-thenNF_Tc :: NF_TcM a -> (a -> TcM b) -> TcM b
-thenNF_Tc :: NF_TcM a -> (a -> NF_TcM b) -> NF_TcM b
-\end{pseudocode}
-
\begin{code}
-thenNF_Tc expr cont sw_chkr dtys subst us errs src_loc
- = case splitUniqSupply us of { (s1, s2) ->
- case (expr sw_chkr dtys subst s1 errs src_loc) of
- (result, subst2, errs2)
- -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
- }
-thenLazilyNF_Tc expr cont sw_chkr dtys subst us errs src_loc
- = let
- (s1, s2) = splitUniqSupply us
- in
- case (expr sw_chkr dtys subst s1 errs src_loc) of {
- (result, subst2, errs2)
- -> cont result sw_chkr dtys subst2 s2 errs2 src_loc
+initTc :: DynFlags
+ -> TcEnv
+ -> TcM r
+ -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
+
+initTc dflags tc_env do_this
+ = do {
+ us <- mkSplitUniqSupply 'a' ;
+ us_var <- newIORef us ;
+ errs_var <- newIORef (emptyBag,emptyBag) ;
+ tvs_var <- newIORef emptyUFM ;
+
+ let
+ init_down = TcDown { tc_dflags = dflags, tc_def = [],
+ tc_us = us_var, tc_loc = noSrcLoc,
+ tc_ctxt = [], tc_errs = errs_var }
+ ;
+
+ maybe_res <- catch (do { res <- do_this init_down tc_env ;
+ return (Just res)})
+ (\_ -> return Nothing) ;
+
+ (warns,errs) <- readIORef errs_var ;
+ return (maybe_res, (warns, errs))
}
+-- Monadic operations
+
returnNF_Tc :: a -> NF_TcM a
-returnNF_Tc result sw_chkr dtys subst us errs src_loc
- = (result, subst, errs)
+returnTc :: a -> TcM a
+returnTc v down env = return v
+thenTc :: TcM a -> (a -> TcM b) -> TcM b
+thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b
+thenTc m k down env = do { r <- m down env; k r down env }
+
+thenTc_ :: TcM a -> TcM b -> TcM b
+thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b
+thenTc_ m k down env = do { m down env; k down env }
+
+listTc :: [TcM a] -> TcM [a]
listNF_Tc :: [NF_TcM a] -> NF_TcM [a]
-listNF_Tc [] = returnNF_Tc []
-listNF_Tc (x:xs)
- = x `thenNF_Tc` \ r ->
- listNF_Tc xs `thenNF_Tc` \ rs ->
- returnNF_Tc (r:rs)
+listTc [] = returnTc []
+listTc (x:xs) = x `thenTc` \ r ->
+ listTc xs `thenTc` \ rs ->
+ returnTc (r:rs)
+mapTc :: (a -> TcM b) -> [a] -> TcM [b]
+mapTc_ :: (a -> TcM b) -> [a] -> TcM ()
mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b]
-mapNF_Tc f [] = returnNF_Tc []
-mapNF_Tc f (x:xs)
- = f x `thenNF_Tc` \ r ->
- mapNF_Tc f xs `thenNF_Tc` \ rs ->
- returnNF_Tc (r:rs)
-
+mapTc f [] = returnTc []
+mapTc f (x:xs) = f x `thenTc` \ r ->
+ mapTc f xs `thenTc` \ rs ->
+ returnTc (r:rs)
+mapTc_ f xs = mapTc f xs `thenTc_` returnTc ()
+
+
+foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b
+foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b
+foldrTc k z [] = returnTc z
+foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r ->
+ k x r
+
+foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a
+foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a
+foldlTc k z [] = returnTc z
+foldlTc k z (x:xs) = k z x `thenTc` \r ->
+ foldlTc k r xs
+
+mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c])
+mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c])
+mapAndUnzipTc f [] = returnTc ([],[])
+mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) ->
+ mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) ->
+ returnTc (r1:rs1, r2:rs2)
+
+mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d])
+mapAndUnzip3Tc f [] = returnTc ([],[],[])
+mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) ->
+ mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) ->
+ returnTc (r1:rs1, r2:rs2, r3:rs3)
+
+mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b)
+mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b)
+mapBagTc f bag
+ = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 ->
+ b2 `thenTc` \ r2 ->
+ returnTc (unionBags r1 r2))
+ (\ a -> f a `thenTc` \ r -> returnTc (unitBag r))
+ (returnTc emptyBag)
+ bag
+
+fixTc :: (a -> TcM a) -> TcM a
fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a
-fixNF_Tc m sw_chkr dtys subst us errs src_loc
- = lim
- where
- lim = m result sw_chkr dtys subst us errs src_loc
- (result, _, _) = lim
+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
+recoverTc recover m down env
+ = catch (m down env) (\ _ -> recover down env)
+
+returnNF_Tc = returnTc
+thenNF_Tc = thenTc
+thenNF_Tc_ = thenTc_
+fixNF_Tc = fixTc
+recoverNF_Tc = recoverTc
+mapNF_Tc = mapTc
+foldrNF_Tc = foldrTc
+foldlNF_Tc = foldlTc
+listNF_Tc = listTc
+mapAndUnzipNF_Tc = mapAndUnzipTc
+mapBagNF_Tc = mapBagTc
\end{code}
-@noFailTc@ takes a \tr{TcM a} and returns a \tr{NF_TcM a}. You use it
-when you are darn sure that the TcM won't actually fail!
+@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 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 unsafeInterleaveIO.
+
+We throw away any error messages!
\begin{code}
-noFailTc :: TcM a -> NF_TcM a
+forkNF_Tc :: NF_TcM r -> NF_TcM r
+forkNF_Tc m down@(TcDown { tc_us = u_var }) env
+ = do
+ -- Get a fresh unique supply
+ us <- readIORef u_var
+ let (us1, us2) = splitUniqSupply us
+ writeIORef u_var us1
+
+ unsafeInterleaveIO (do {
+ us_var' <- newIORef us2 ;
+ err_var' <- newIORef (emptyBag,emptyBag) ;
+ let { down' = down { tc_us = us_var', tc_errs = err_var' } };
+ m down' env
+ -- ToDo: optionally dump any error messages
+ })
+\end{code}
-noFailTc expr sw_chkr dtys subst us errs src_loc
- = case (expr sw_chkr dtys subst us errs src_loc) of
- TcFailed _ _ -> panic "Failure in noFailTc!"
- TcSucceeded result subst errs
- -> (result, subst, errs)
+\begin{code}
+traceTc :: SDoc -> NF_TcM ()
+traceTc doc (TcDown { tc_dflags=dflags }) env
+ | dopt Opt_D_dump_tc_trace dflags = printDump doc
+ | otherwise = return ()
+
+ioToTc :: IO a -> NF_TcM a
+ioToTc io down env = io
\end{code}
+
%************************************************************************
%* *
-\subsection[TcM-uniq-extract]{Extractings Uniques from the monad}
+\subsection{Error handling}
%* *
%************************************************************************
-These functions extract uniques from the monad. There are two unique
-supplies embedded in the monad.
-\begin{itemize}
-\item
-normal unique supply
-\item
-special unique supply for TyVars (these index the substitution)
-\end{itemize}
-
\begin{code}
-getUniquesTc :: Int -> NF_TcM [Unique]
-getUniquesTc n sw_chkr dtys subst us errs src_loc
- = case (getSUniques n us) of { uniques ->
- (uniques, subst, errs) }
+getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg)
+getErrsTc down env
+ = readIORef (getTcErrs down)
+
+failTc :: TcM a
+failTc down env = give_up
+
+give_up :: IO a
+give_up = ioError (userError "Typecheck failed")
+
+failWithTc :: Message -> TcM a -- Add an error message and fail
+failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
+
+addErrTc :: Message -> NF_TcM ()
+addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
--- This simpler version is often adequate:
+addErrsTc :: [Message] -> NF_TcM ()
+addErrsTc [] = returnNF_Tc ()
+addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
-getUniqueTc :: NF_TcM Unique
-getUniqueTc sw_chkr dtys subst us errs src_loc
- = case (getSUnique us) of { unique ->
- (unique, subst, errs) }
+-- The 'M' variants do the TidyEnv bit
+failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
+failWithTcM env_and_msg
+ = addErrTcM env_and_msg `thenNF_Tc_`
+ failTc
-rn4MtoTcM :: GlobalNameFuns -> Rn4M a -> NF_TcM (a, Bag Error)
+checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true
+checkTc True err = returnTc ()
+checkTc False err = failWithTc err
-rn4MtoTcM name_funs rn_action sw_chkr dtys subst us errs src_loc
- = let
- (rn_result, rn_errs)
- = rn_action sw_chkr name_funs emptyFM emptyBag us mkUnknownSrcLoc
- -- laziness may be good for you (see below)
- in
- ((rn_result, rn_errs), subst, errs)
+checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true
+checkTcM True err = returnTc ()
+checkTcM False err = err
--- Special uniques for TyVars extracted from the substitution
+checkMaybeTc :: Maybe val -> Message -> TcM val
+checkMaybeTc (Just val) err = returnTc val
+checkMaybeTc Nothing err = failWithTc err
-getTyVarUniquesTc :: Int -> NF_TcM [Unique]
-getTyVarUniquesTc n sw_chkr dtys subst us errs src_loc
- = returnNF_Tc uniques sw_chkr dtys subst2 us errs src_loc
+checkMaybeTcM :: Maybe val -> TcM val -> TcM val
+checkMaybeTcM (Just val) err = returnTc val
+checkMaybeTcM Nothing err = err
+
+addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
+addErrTcM (tidy_env, err_msg) down env
+ = add_err_tcm tidy_env err_msg ctxt loc down env
where
- (subst2, uniques) = getSubstTyVarUniques n subst
+ ctxt = getErrCtxt down
+ loc = getLoc down
-getTyVarUniqueTc :: NF_TcM Unique
-getTyVarUniqueTc sw_chkr dtys subst us errs src_loc
- = returnNF_Tc unique sw_chkr dtys subst2 us errs src_loc
+addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail
+addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env
+ = add_err_tcm tidy_env err_msg full_ctxt loc down env
+ where
+ full_ctxt = (\env -> returnNF_Tc (env, pprInstLoc inst_loc)) : ctxt
+
+add_err_tcm tidy_env err_msg ctxt loc down env
+ = do
+ (warns, errs) <- readIORef errs_var
+ ctxt_msgs <- do_ctxt tidy_env ctxt down env
+ let err = addShortErrLocLine loc $
+ vcat (err_msg : ctxt_to_use ctxt_msgs)
+ writeIORef errs_var (warns, errs `snocBag` err)
+ where
+ errs_var = getTcErrs down
+
+do_ctxt tidy_env [] down env
+ = return []
+do_ctxt tidy_env (c:cs) down env
+ = do
+ (tidy_env', m) <- c tidy_env down env
+ ms <- do_ctxt tidy_env' cs down env
+ return (m:ms)
+
+-- warnings don't have an 'M' variant
+warnTc :: Bool -> Message -> NF_TcM ()
+warnTc warn_if_true warn_msg down env
+ | warn_if_true
+ = do
+ (warns,errs) <- readIORef errs_var
+ ctxt_msgs <- do_ctxt emptyTidyEnv ctxt down env
+ let warn = addShortWarnLocLine loc $
+ vcat (warn_msg : ctxt_to_use ctxt_msgs)
+ writeIORef errs_var (warns `snocBag` warn, errs)
+ | otherwise
+ = return ()
+ where
+ errs_var = getTcErrs down
+ ctxt = getErrCtxt down
+ loc = getLoc down
+
+-- (tryTc r m) succeeds if m succeeds and generates no errors
+-- If m fails then r is invoked, passing the warnings and errors from m
+-- If m succeeds, (tryTc r m) checks whether m generated any errors messages
+-- (it might have recovered internally)
+-- If so, then r is invoked, passing the warnings and errors from m
+
+tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r) -- Recovery action
+ -> TcM r -- Thing to try
+ -> TcM r
+tryTc recover main down env
+ = do
+ m_errs_var <- newIORef (emptyBag,emptyBag)
+ catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
where
- (subst2, unique) = getSubstTyVarUnique subst
+ errs_var = getTcErrs down
+
+ my_recover m_errs_var
+ = do warns_and_errs <- readIORef m_errs_var
+ recover warns_and_errs down env
+
+ my_main m_errs_var
+ = do result <- main (setTcErrs down m_errs_var) env
+
+ -- 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.
+ (m_warns, m_errs) <- readIORef m_errs_var
+ if isEmptyBag m_errs then
+ -- 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
+
+
+-- (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 r -> TcM r
+checkNoErrsTc main
+ = tryTc my_recover main
+ where
+ my_recover (m_warns, m_errs) down env
+ = do (warns, errs) <- readIORef errs_var
+ writeIORef errs_var (warns `unionBags` m_warns,
+ errs `unionBags` m_errs)
+ give_up
+ where
+ errs_var = getTcErrs down
+
+
+-- (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.
+tryTc_ :: TcM r -> TcM r -> TcM r
+tryTc_ recover main
+ = tryTc my_recover main
+ where
+ my_recover warns_and_errs = recover
+
+-- (discardErrsTc m) runs m, but throw away all its error messages.
+discardErrsTc :: Either_TcM r -> Either_TcM r
+discardErrsTc main down env
+ = do new_errs_var <- newIORef (emptyBag,emptyBag)
+ main (setTcErrs down new_errs_var) env
\end{code}
+
+
%************************************************************************
%* *
-\subsection[TcM-extract]{Extractings other things from the monad}
+\subsection{Mutable variables}
%* *
%************************************************************************
-These are functions which extract things from the monad.
+\begin{code}
+tcNewMutVar :: a -> NF_TcM (TcRef a)
+tcNewMutVar val down env = newIORef val
-Extending and applying the substitution.
+tcWriteMutVar :: TcRef a -> a -> NF_TcM ()
+tcWriteMutVar var val down env = writeIORef var val
-ToDo: Unify.lhs BackSubst.lhs Id.lhs Inst.lhs: The TcMonad is used in
-a number of places where only the sequenced substitution is required.
-A lighter weight sequence substitution monad would be more appropriate
-with TcMonad interface functions defined here.
+tcReadMutVar :: TcRef a -> NF_TcM a
+tcReadMutVar var down env = readIORef var
-\begin{code}
-getTcSubst :: NF_TcM Subst
-applyTcSubstToTy :: TauType -> NF_TcM TauType
---UNUSED:applyTcSubstToThetaTy :: ThetaType -> NF_TcM ThetaType
-applyTcSubstToTyVar :: TyVar -> NF_TcM TauType
-applyTcSubstToId :: Id -> NF_TcM Id
-applyTcSubstToInst :: Inst -> NF_TcM Inst
-
-getTcSubst sw_chkr dtys subst us errs src_loc
- = returnNF_Tc subst sw_chkr dtys subst us errs src_loc
-
-applyTcSubstToTy ty sw_chkr dtys subst us errs src_loc
- = case (applySubstToTy subst ty) of { (subst2, new_tau_ty) ->
- returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
- }
+tcNewMutTyVar :: Name -> Kind -> TyVarDetails -> NF_TcM TyVar
+tcNewMutTyVar name kind details down env = newMutTyVar name kind details
-{- UNUSED:
-applyTcSubstToThetaTy theta_ty sw_chkr dtys subst us errs src_loc
- = case (applySubstToThetaTy subst theta_ty) of { (subst2, new_theta_ty) ->
- returnNF_Tc new_theta_ty sw_chkr dtys subst2 us errs src_loc
- }
--}
+tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type)
+tcReadMutTyVar tyvar down env = readMutTyVar tyvar
-applyTcSubstToTyVar tyvar sw_chkr dtys subst us errs src_loc
- = case (applySubstToTyVar subst tyvar) of { (subst2, new_tau_ty) ->
- returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
- }
+tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM ()
+tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val
+\end{code}
-applyTcSubstToId tyvar sw_chkr dtys subst us errs src_loc
- = case (applySubstToId subst tyvar) of { (subst2, new_tau_ty) ->
- returnNF_Tc new_tau_ty sw_chkr dtys subst2 us errs src_loc
- }
-applyTcSubstToInst inst sw_chkr dtys subst us errs src_loc
- = case (applySubstToInst subst inst) of { (subst2, new_inst) ->
- returnNF_Tc new_inst sw_chkr dtys subst2 us errs src_loc
- }
+%************************************************************************
+%* *
+\subsection{The environment}
+%* *
+%************************************************************************
-applyTcSubstToTyVars :: [TyVar] -> NF_TcM [UniType]
-applyTcSubstToTys :: [TauType] -> NF_TcM [TauType]
+\begin{code}
+tcGetEnv :: NF_TcM TcEnv
+tcGetEnv down env = return env
-applyTcSubstToTyVars tyvars = mapNF_Tc applyTcSubstToTyVar tyvars
-applyTcSubstToTys tys = mapNF_Tc applyTcSubstToTy tys
-applyTcSubstToInsts insts = mapNF_Tc applyTcSubstToInst insts
+tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a
+tcSetEnv new_env m down old_env = m down new_env
\end{code}
-\begin{code}
-extendSubstTc :: TyVar -> UniType -> UnifyErrContext -> TcM ()
-
-extendSubstTc tyvar ty err_ctxt sw_chkr dtys subst us errs src_loc
- = case (extendSubst tyvar ty subst) of { (new_subst, extend_result) ->
- case extend_result of
- SubstOK ->
- TcSucceeded () new_subst errs
-
- OccursCheck tyvar ty ->
- TcFailed new_subst
- (errs `snocBag` (unifyErr (TypeRec tyvar ty) err_ctxt src_loc))
-
- AlreadyBound ty1 ->
- -- This should only happen in the case of a call to
- -- extendSubstTc from the unifier! The way things are now
- -- we can't check for the AlreadyBound case in other calls
- -- to extendSubstTc, but we're confident it never shows up.
- -- Ugh!
- unifyTauTy ty1 ty err_ctxt sw_chkr dtys new_subst us errs src_loc
- }
-\end{code}
+%************************************************************************
+%* *
+\subsection{Source location}
+%* *
+%************************************************************************
-@pruneSubstTc@ does nothing with an array substitution implementation!!!
\begin{code}
-pruneSubstTc :: [TyVar] -- Type vars whose substitutions should be kept
- -> TcM a -- Type-check this
- -> TcM a -- Return same result but pruned subst
+tcGetDefaultTys :: NF_TcM [Type]
+tcGetDefaultTys down env = return (getDefaultTys down)
-pruneSubstTc keep_tyvars m sw_chkr dtys subst uniqs errs src_loc
- = m sw_chkr dtys subst uniqs errs src_loc
-\end{code}
+tcSetDefaultTys :: [Type] -> TcM r -> TcM r
+tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env
-\begin{code}
-getSwitchCheckerTc :: NF_TcM (GlobalSwitch -> Bool)
-getSwitchCheckerTc sw_chkr = returnNF_Tc sw_chkr sw_chkr
-\end{code}
+tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a
+tcAddSrcLoc loc m down env = m (setLoc down loc) env
-\begin{code}
-getDefaultingTys :: NF_TcM [UniType]
-getDefaultingTys sw_chkr dtys = returnNF_Tc dtys sw_chkr dtys
+tcGetSrcLoc :: NF_TcM SrcLoc
+tcGetSrcLoc down env = return (getLoc down)
-setDefaultingTys :: [UniType] -> TcM a -> TcM a
-setDefaultingTys dtys action sw_chkr _ subst us errs src_loc
- = action sw_chkr dtys subst us errs src_loc
-\end{code}
+tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
+tcGetInstLoc origin TcDown{tc_loc=loc, tc_ctxt=ctxt} env
+ = return (origin, loc, ctxt)
-\begin{code}
-addSrcLocTc :: SrcLoc -> TcM a -> TcM a
-addSrcLocTc new_locn expr sw_chkr dtys subst us errs src_loc
- = expr sw_chkr dtys subst us errs new_locn
+tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
+ -> TcM a -> TcM a
+tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
+tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
+
+tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
+-- 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
-getSrcLocTc :: NF_TcM SrcLoc
-getSrcLocTc sw_chkr dtys subst us errs src_loc
- = (src_loc, subst, errs)
+tcPopErrCtxt :: Either_TcM r -> Either_TcM r
+tcPopErrCtxt m down env = m (popErrCtxt down) env
\end{code}
+
%************************************************************************
%* *
-\subsection[TcM-check]{Error-detecting functions}
+\subsection{Unique supply}
%* *
%************************************************************************
-The following TcM checks a Maybe type and fails with the given
-error message.
-
\begin{code}
-checkMaybeTc :: Maybe val -> Error -> TcM val
-checkMaybeTc (Just result) err = returnTc result
-checkMaybeTc Nothing err = failTc err
-
-checkMaybesTc :: [Maybe val] -> Error -> TcM [val]
-checkMaybesTc [] err = returnTc []
-checkMaybesTc (Nothing:xs) err = failTc err
-checkMaybesTc ((Just v):xs) err
- = checkMaybesTc xs err `thenTc` \ xs2 ->
- returnTc (v:xs2)
-
-checkMaybeErrTc :: MaybeErr val err -> (err -> Error) -> TcM val
-checkMaybeErrTc (Succeeded result) errfun = returnTc result
-checkMaybeErrTc (Failed err) errfun = failTc (errfun err)
-
-{- UNUSED:
-checkMaybeErrsTc :: [MaybeErr val err] -> (err -> Error) -> TcM [val]
-
-checkMaybeErrsTc [] err_fun = returnTc []
-checkMaybeErrsTc ((Failed err) :xs) err_fun = failTc (err_fun err)
-checkMaybeErrsTc ((Succeeded v):xs) err_fun
- = checkMaybeErrsTc xs err_fun `thenTc` \ xs2 ->
- returnTc (v:xs2)
--}
+tcGetUnique :: NF_TcM Unique
+tcGetUnique down env
+ = do uniq_supply <- readIORef u_var
+ let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ uniq = uniqFromSupply uniq_s
+ writeIORef u_var new_uniq_supply
+ return uniq
+ where
+ u_var = getUniqSupplyVar down
+
+tcGetUniques :: NF_TcM [Unique]
+tcGetUniques down env
+ = do uniq_supply <- readIORef u_var
+ let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ uniqs = uniqsFromSupply uniq_s
+ writeIORef u_var new_uniq_supply
+ return uniqs
+ where
+ u_var = getUniqSupplyVar down
+
+uniqSMToTcM :: UniqSM a -> NF_TcM a
+uniqSMToTcM m down env
+ = do uniq_supply <- readIORef u_var
+ let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
+ writeIORef u_var new_uniq_supply
+ return (initUs_ uniq_s m)
+ where
+ u_var = getUniqSupplyVar down
\end{code}
+
+
%************************************************************************
%* *
-\subsection[TcM-Insts]{Looking up instances}
+\subsection{TcDown}
%* *
%************************************************************************
\begin{code}
-lookupInst_Tc :: Inst -> TcM (TypecheckedExpr, [Inst])
+data TcDown
+ = TcDown {
+ tc_dflags :: DynFlags,
+ tc_def :: [Type], -- Types used for defaulting
+ tc_us :: (TcRef UniqSupply), -- Unique supply
+ tc_loc :: SrcLoc, -- Source location
+ tc_ctxt :: ErrCtxt, -- Error context
+ tc_errs :: (TcRef (Bag WarnMsg, Bag ErrMsg))
+ }
+
+type ErrCtxt = [TidyEnv -> NF_TcM (TidyEnv, Message)]
+ -- Innermost first. Monadic so that we have a chance
+ -- to deal with bound type variables just before error
+ -- message construction
+\end{code}
-lookupInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
- = case (lookupInst uniqs inst) of
- Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
+-- These selectors are *local* to TcMonad.lhs
- Just (expr, insts) -> TcSucceeded (expr, insts) subst errs
+\begin{code}
+getTcErrs (TcDown{tc_errs=errs}) = errs
+setTcErrs down errs = down{tc_errs=errs}
-lookupNoBindInst_Tc :: Inst -> TcM [Inst]
+getDefaultTys (TcDown{tc_def=def}) = def
+setDefaultTys down def = down{tc_def=def}
-lookupNoBindInst_Tc inst sw_chkr dtys subst uniqs errs src_loc
- = case (lookupNoBindInst uniqs inst) of
- Nothing -> TcFailed subst (errs `snocBag` (noInstanceErr inst))
+getLoc (TcDown{tc_loc=loc}) = loc
+setLoc down loc = down{tc_loc=loc}
- Just insts -> TcSucceeded insts subst errs
-\end{code}
+getUniqSupplyVar (TcDown{tc_us=us}) = us
+getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
+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 -> NF_TcM Bool
+doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
+ = return (dopt dflag dflags)
+
+getDOptsTc :: NF_TcM DynFlags
+getDOptsTc (TcDown{tc_dflags=dflags}) env_down
+ = return dflags
+\end{code}
%************************************************************************
%* *
-\subsection[Baby_TcM]{``Baby'' @TcM@ monadery---when we don't need the full bang}
+\subsection{TypeChecking Errors}
%* *
%************************************************************************
-The "baby" Tc monad doesn't pass around the substitution.
-That means you can't use it to type-check bindings, but you can use
-if for everything else (interfaces, type decls, first pass of class and
-instance decls etc).
+\begin{code}
+type TcError = Message
+type TcWarning = Message
+
+ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
+ | otherwise = take 3 ctxt
+
+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
+ n_arguments | n == 0 = ptext SLIT("no arguments")
+ | n == 1 = ptext SLIT("1 argument")
+ | True = hsep [int n, ptext SLIT("arguments")]
+\end{code}
-Less importantly, it doesn't pass around the list of default decls either.
-Type declarations
-~~~~~~~~~~~~~~~~~
+%************************************************************************
+%* *
+\subsection[Inst-origin]{The @InstOrigin@ type}
+%* *
+%************************************************************************
-\begin{code}
-type Baby_TcM result
- = (GlobalSwitch -> Bool)
- -> SplitUniqSupply
- -> Bag Error -- threaded
- -> SrcLoc -- only passed downwards
- -> Baby_TcResult result
+The @InstOrigin@ type gives information about where a dictionary came from.
+This is important for decent error message reporting because dictionaries
+don't appear in the original source code. Doubtless this type will evolve...
-data Baby_TcResult result
- = BabyTcFailed (Bag Error)
+It appears in TcMonad because there are a couple of error-message-generation
+functions that deal with it.
- | BabyTcSucceeded result (Bag Error)
-\end{code}
+\begin{code}
+type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
+data InstOrigin
+ = OccurrenceOf Id -- Occurrence of an overloaded identifier
-Standard plumbing
-~~~~~~~~~~~~~~~~~
+ | IPOcc (IPName Name) -- Occurrence of an implicit parameter
+ | IPBind (IPName Name) -- Binding site of an implicit parameter
-\begin{code}
-thenB_Tc :: Baby_TcM a -> (a -> Baby_TcM b) -> Baby_TcM b
-returnB_Tc :: a -> Baby_TcM a
-
-#ifdef __GLASGOW_HASKELL__
-{-# INLINE thenB_Tc #-}
-{-# INLINE returnB_Tc #-}
-#endif
-
-thenB_Tc a b sw us errs loc
- = case (splitUniqSupply us) of { (s1, s2) ->
- case (a sw s1 errs loc) of
- BabyTcFailed errs2 -> BabyTcFailed errs2
- BabyTcSucceeded a_res errs2 -> b a_res sw s2 errs2 loc
- }
+ | RecordUpdOrigin
-returnB_Tc result sw us errs loc = BabyTcSucceeded result errs
-failB_Tc err sw us errs loc = BabyTcFailed (errs `snocBag` err)
+ | DataDeclOrigin -- Typechecking a data declaration
-recoverIgnoreErrorsB_Tc return_on_failure try_this sw us errs loc
- = BabyTcSucceeded result errs
- where
- result = case try_this sw us emptyBag loc of
- BabyTcSucceeded result errs_from_branch -> result
- BabyTcFailed errs_from_branch -> return_on_failure
+ | InstanceDeclOrigin -- Typechecking an instance decl
-fixB_Tc :: (a -> Baby_TcM a) -> Baby_TcM a
-fixB_Tc k sw us errs loc
- = result
- where
- result = k val sw us errs loc
- val = case result of
- BabyTcSucceeded val errs -> val
- BabyTcFailed errs -> panic "fixB_Tc failed"
-
-babyTcMtoTcM :: Baby_TcM a -> TcM a
-babyTcMtoTcM m sw_chkr dtys subst us errs src_loc
- = case m sw_chkr us errs src_loc of
- BabyTcSucceeded result errs2 -> TcSucceeded result subst errs2
- BabyTcFailed errs2 -> TcFailed subst errs2
-
-babyTcMtoNF_TcM :: Baby_TcM a -> NF_TcM a
-babyTcMtoNF_TcM m sw_chkr dtys subst us errs src_loc
- = case m sw_chkr us errs src_loc of
- BabyTcSucceeded result errs2 -> (result, subst, errs2)
- BabyTcFailed errs2 -> panic "babyTcMtoNF_TcM"
-\end{code}
+ | LiteralOrigin HsOverLit -- Occurrence of a literal
-\begin{code}
-uniqSMtoBabyTcM :: SUniqSM a -> Baby_TcM a
-
-uniqSMtoBabyTcM u_action sw us errs loc
- = let
- u_result = u_action us
- -- at least one use *needs* this laziness
- in
- BabyTcSucceeded u_result errs
-\end{code}
+ | PatOrigin RenamedPat
-\begin{code}
-thenB_Tc_ m k = m `thenB_Tc` \ _ ->
- k
-
-mapB_Tc :: (a -> Baby_TcM b) -> [a] -> Baby_TcM [b]
-mapB_Tc f [] = returnB_Tc []
-mapB_Tc f (x:xs) = f x `thenB_Tc` \ fx ->
- mapB_Tc f xs `thenB_Tc` \ fxs ->
- returnB_Tc (fx:fxs)
-\end{code}
+ | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
+ | PArrSeqOrigin RenamedArithSeqInfo -- [:x..y:] and [:x,y..z:]
+ | SignatureOrigin -- A dict created from a type signature
+ | Rank2Origin -- A dict created when typechecking the argument
+ -- of a rank-2 typed function
-Primitives
-~~~~~~~~~~
+ | DoOrigin -- The monad for a do expression
-\begin{code}
-getUniqueB_Tc :: Baby_TcM Unique
-getUniquesB_Tc :: Int -> Baby_TcM [Unique]
+ | ClassDeclOrigin -- Manufactured during a class decl
-getUniqueB_Tc sw us errs loc
- = case (getSUnique us) of { unique ->
- BabyTcSucceeded unique errs }
+ | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
+ Type
-getUniquesB_Tc n sw us errs loc
- = case (getSUniques n us) of { uniques ->
- BabyTcSucceeded uniques errs }
+ -- When specialising instances the instance info attached to
+ -- each class is not yet ready, so we record it inside the
+ -- origin information. This is a bit of a hack, but it works
+ -- fine. (Patrick is to blame [WDP].)
-addSrcLocB_Tc :: SrcLoc -> Baby_TcM a -> Baby_TcM a
-addSrcLocB_Tc new_locn m sw us errs loc
- = m sw us errs new_locn
+ | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
-getSrcLocB_Tc sw us errs loc = BabyTcSucceeded loc errs
+ -- Argument or result of a ccall
+ -- Dictionaries with this origin aren't actually mentioned in the
+ -- translated term, and so need not be bound. Nor should they
+ -- be abstracted over.
-getSwitchCheckerB_Tc :: Baby_TcM (GlobalSwitch -> Bool)
-getSwitchCheckerB_Tc sw_chkr us errs loc = BabyTcSucceeded sw_chkr errs
-\end{code}
+ | CCallOrigin String -- CCall label
+ (Maybe RenamedHsExpr) -- Nothing if it's the result
+ -- Just arg, for an argument
+ | LitLitOrigin String -- the litlit
-Useful functions
-~~~~~~~~~~~~~~~~
+ | UnknownOrigin -- Help! I give up...
+\end{code}
\begin{code}
-checkB_Tc :: Bool -> Error -> Baby_TcM ()
-
-checkB_Tc True err = failB_Tc err
-checkB_Tc False err = returnB_Tc ()
+pprInstLoc :: InstLoc -> SDoc
+pprInstLoc (orig, locn, ctxt)
+ = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
+ where
+ pp_orig (OccurrenceOf id)
+ = hsep [ptext SLIT("use of"), quotes (ppr id)]
+ pp_orig (IPOcc name)
+ = 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 (ArithSeqOrigin seq)
+ = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
+ pp_orig (PArrSeqOrigin seq)
+ = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
+ pp_orig (SignatureOrigin)
+ = ptext SLIT("a type signature")
+ pp_orig (Rank2Origin)
+ = ptext SLIT("a function with an overloaded argument type")
+ pp_orig (DoOrigin)
+ = ptext SLIT("a do statement")
+ pp_orig (ClassDeclOrigin)
+ = ptext SLIT("a class declaration")
+ pp_orig (InstanceSpecOrigin clas ty)
+ = hsep [text "a SPECIALIZE instance pragma; class",
+ quotes (ppr clas), text "type:", ppr ty]
+ pp_orig (ValSpecOrigin name)
+ = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
+ pp_orig (CCallOrigin clabel Nothing{-ccall result-})
+ = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
+ pp_orig (CCallOrigin clabel (Just arg_expr))
+ = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
+ text "namely", quotes (ppr arg_expr)]
+ pp_orig (LitLitOrigin s)
+ = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
+ pp_orig (UnknownOrigin)
+ = ptext SLIT("...oops -- I don't know where the overloading came from!")
\end{code}
projects / ghc-hetmet.git / blobdiff