\begin{code}
module TcMonad(
TcType,
- TcTauType, TcThetaType, TcRhoType,
+ TcTauType, TcPredType, TcThetaType, TcRhoType,
TcTyVar, TcTyVarSet,
TcKind,
TcM, NF_TcM, TcDown, TcEnv,
initTc,
- returnTc, thenTc, thenTc_, mapTc, listTc,
+ returnTc, thenTc, thenTc_, mapTc, mapTc_, listTc,
foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
mapBagTc, fixTc, tryTc, tryTc_, getErrsTc,
traceTc, ioToTc,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
- addErrTcM, failWithTcM,
+ addErrTcM, addInstErrTcM, failWithTcM,
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
- tcGetUnique, tcGetUniques,
+ tcGetUnique, tcGetUniques, tcGetDFunUniq,
- tcAddSrcLoc, tcGetSrcLoc,
+ tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
tcAddErrCtxtM, tcSetErrCtxtM,
tcAddErrCtxt, tcSetErrCtxt,
tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
+ InstOrigin(..), InstLoc, pprInstLoc,
+
TcError, TcWarning, TidyEnv, emptyTidyEnv,
arityErr
) where
import {-# SOURCE #-} TcEnv ( TcEnv )
-import Type ( Type, Kind, ThetaType, RhoType, TauType,
+import HsSyn ( HsLit )
+import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
+import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
)
-import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
+import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, pprBagOfErrors, ErrMsg, Message, WarnMsg )
import CmdLineOpts ( opt_PprStyle_Debug )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
import Class ( Class )
import Name ( Name )
-import Var ( TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
+import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
import VarEnv ( TyVarEnv, emptyVarEnv, TidyEnv, emptyTidyEnv )
import VarSet ( TyVarSet )
import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSM, initUs_ )
import SrcLoc ( SrcLoc, noSrcLoc )
-import FiniteMap ( FiniteMap, emptyFM )
+import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM )
import UniqFM ( UniqFM, emptyUFM )
import Unique ( Unique )
import BasicTypes ( Unused )
-import Util
import Outputable
import FastString ( FastString )
-- 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
initTc us initenv do_this
= do {
us_var <- newIORef us ;
+ dfun_var <- newIORef emptyFM ;
errs_var <- newIORef (emptyBag,emptyBag) ;
tvs_var <- newIORef emptyUFM ;
let
- init_down = TcDown [] us_var
+ init_down = TcDown [] us_var dfun_var
noSrcLoc
[] errs_var
init_env = initenv tvs_var
returnTc (r:rs)
mapTc :: (a -> TcM s b) -> [a] -> TcM s [b]
+mapTc_ :: (a -> TcM s b) -> [a] -> TcM s ()
mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b]
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 s b) -> b -> [a] -> TcM s b
foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
\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
+forkNF_Tc m (TcDown deflts u_var df_var src_loc err_cxt err_var) env
= do
-- Get a fresh unique supply
us <- readIORef u_var
us_var' <- newIORef us2 ;
err_var' <- newIORef (emptyBag,emptyBag) ;
tv_var' <- newIORef emptyUFM ;
- let { down' = TcDown deflts us_var' src_loc err_cxt err_var' } ;
+ let { down' = TcDown deflts us_var' df_var src_loc err_cxt err_var' } ;
m down' env
-- ToDo: optionally dump any error messages
})
addErrTcM :: (TidyEnv, Message) -> NF_TcM s () -- 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
+ ctxt = getErrCtxt down
+ loc = getLoc down
+
+addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM s () -- 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
writeIORef errs_var (warns, errs `snocBag` err)
where
errs_var = getTcErrs down
- ctxt = getErrCtxt down
- loc = getLoc down
do_ctxt tidy_env [] down env
= return []
tcGetSrcLoc :: NF_TcM s SrcLoc
tcGetSrcLoc down env = return (getLoc down)
+tcGetInstLoc :: InstOrigin -> NF_TcM s InstLoc
+tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
+
tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM s (TidyEnv, Message))
-> TcM s a -> TcM s a
tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
\end{code}
+\section{Dictionary function name supply
+%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+\begin{code}
+tcGetDFunUniq :: String -> NF_TcM s Int
+tcGetDFunUniq key down env
+ = do dfun_supply <- readIORef d_var
+ let uniq = case lookupFM dfun_supply key of
+ Just x -> x+1
+ Nothing -> 0
+ let dfun_supply' = addToFM dfun_supply key uniq
+ writeIORef d_var dfun_supply'
+ return uniq
+ where
+ d_var = getDFunSupplyVar down
+\end{code}
+
+
\section{TcDown}
%~~~~~~~~~~~~~~~
[Type] -- Types used for defaulting
(TcRef UniqSupply) -- Unique supply
+ (TcRef DFunNameSupply) -- Name supply for dictionary function names
SrcLoc -- Source location
ErrCtxt -- Error context
- (TcRef (Bag WarnMsg,
- Bag ErrMsg))
+ (TcRef (Bag WarnMsg, Bag ErrMsg))
type ErrCtxt = [TidyEnv -> NF_TcM Unused (TidyEnv, Message)]
-- Innermost first. Monadic so that we have a chance
-- to deal with bound type variables just before error
-- message construction
+
+type DFunNameSupply = FiniteMap String Int
+ -- This is used as a name supply for dictionary functions
+ -- From the inst decl we derive a string, usually by glomming together
+ -- the class and tycon name -- but it doesn't matter exactly how;
+ -- this map then gives a unique int for each inst decl with that
+ -- string. (In Haskell 98 there can only be one,
+ -- but not so in more extended versions; also class CC type T
+ -- and class C type TT might both give the string CCT
+ --
+ -- We could just use one Int for all the instance decls, but this
+ -- way the uniques change less when you add an instance decl,
+ -- hence less recompilation
\end{code}
-- These selectors are *local* to TcMonad.lhs
\begin{code}
-getTcErrs (TcDown def us loc ctxt errs) = errs
-setTcErrs (TcDown def us loc ctxt _ ) errs = TcDown def us loc ctxt errs
+getTcErrs (TcDown def us ds loc ctxt errs) = errs
+setTcErrs (TcDown def us ds loc ctxt _ ) errs = TcDown def us ds loc ctxt errs
-getDefaultTys (TcDown def us loc ctxt errs) = def
-setDefaultTys (TcDown _ us loc ctxt errs) def = TcDown def us loc ctxt errs
+getDefaultTys (TcDown def us ds loc ctxt errs) = def
+setDefaultTys (TcDown _ us ds loc ctxt errs) def = TcDown def us ds loc ctxt errs
-getLoc (TcDown def us loc ctxt errs) = loc
-setLoc (TcDown def us _ ctxt errs) loc = TcDown def us loc ctxt errs
+getLoc (TcDown def us ds loc ctxt errs) = loc
+setLoc (TcDown def us ds _ ctxt errs) loc = TcDown def us ds loc ctxt errs
-getUniqSupplyVar (TcDown def us loc ctxt errs) = us
+getUniqSupplyVar (TcDown def us ds loc ctxt errs) = us
+getDFunSupplyVar (TcDown def us ds loc ctxt errs) = ds
-setErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc [msg] errs
-addErrCtxt (TcDown def us loc ctxt errs) msg = TcDown def us loc (msg:ctxt) errs
-getErrCtxt (TcDown def us loc ctxt errs) = ctxt
+setErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc [msg] errs
+addErrCtxt (TcDown def us ds loc ctxt errs) msg = TcDown def us ds loc (msg:ctxt) errs
+getErrCtxt (TcDown def us ds loc ctxt errs) = ctxt
\end{code}
\end{code}
+
+%************************************************************************
+%* *
+\subsection[Inst-origin]{The @InstOrigin@ type}
+%* *
+%************************************************************************
+
+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...
+
+It appears in TcMonad because there are a couple of error-message-generation
+functions that deal with it.
+
+\begin{code}
+type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
+
+data InstOrigin
+ = OccurrenceOf Id -- Occurrence of an overloaded identifier
+
+ | RecordUpdOrigin
+
+ | DataDeclOrigin -- Typechecking a data declaration
+
+ | InstanceDeclOrigin -- Typechecking an instance decl
+
+ | LiteralOrigin HsLit -- Occurrence of a literal
+
+ | PatOrigin RenamedPat
+
+ | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc
+
+ | SignatureOrigin -- A dict created from a type signature
+ | Rank2Origin -- A dict created when typechecking the argument
+ -- of a rank-2 typed function
+
+ | DoOrigin -- The monad for a do expression
+
+ | ClassDeclOrigin -- Manufactured during a class decl
+
+ | InstanceSpecOrigin Class -- in a SPECIALIZE instance pragma
+ Type
+
+ -- 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].)
+
+ | ValSpecOrigin Name -- in a SPECIALIZE pragma for a value
+
+ -- 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.
+
+ | CCallOrigin String -- CCall label
+ (Maybe RenamedHsExpr) -- Nothing if it's the result
+ -- Just arg, for an argument
+
+ | LitLitOrigin String -- the litlit
+
+ | UnknownOrigin -- Help! I give up...
+\end{code}
+
+\begin{code}
+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 (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)
+ = 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