\begin{code}
module TcMonad(
- TcType,
- TcTauType, TcPredType, TcThetaType, TcRhoType,
- TcTyVar, TcTyVarSet,
- TcKind,
-
TcM, NF_TcM, TcDown, TcEnv,
initTc,
listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
- failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+ failTc, failWithTc, addErrTc, addErrsTc, warnTc,
+ recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
addErrTcM, addInstErrTcM, failWithTcM,
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
- tcGetUnique, tcGetUniques, tcGetDFunUniq,
+ tcGetUnique, tcGetUniques,
+ doptsTc, getDOptsTc,
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 RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit )
-import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
- )
+import HsLit ( HsOverLit )
+import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
+import TcType ( Type, Kind, TyVarDetails )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, 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 ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
+import Var ( TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
import VarEnv ( TidyEnv, emptyTidyEnv )
-import VarSet ( TyVarSet )
-import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
+import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
+ splitUniqSupply, mkSplitUniqSupply,
UniqSM, initUs_ )
import SrcLoc ( SrcLoc, noSrcLoc )
-import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM )
-import UniqFM ( UniqFM, emptyUFM )
+import BasicTypes ( IPName )
+import UniqFM ( emptyUFM )
import Unique ( Unique )
-import BasicTypes ( Unused )
+import CmdLineOpts
import Outputable
-import FastString ( FastString )
import IOExts ( IORef, newIORef, readIORef, writeIORef,
unsafeInterleaveIO, fixIO
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
\begin{code}
type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError
type TcM r = TcDown -> TcEnv -> IO r -- Can raise UserError
- -- ToDo: nuke the 's' part
- -- The difference between the two is
- -- now for documentation purposes only
type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM
-- Used only in this file for type signatures which
\end{code}
\begin{code}
--- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
-initTc :: UniqSupply
- -> (TcRef (UniqFM a) -> TcEnv)
+initTc :: DynFlags
+ -> TcEnv
-> TcM r
- -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
+ -> IO (Maybe r, (Bag WarnMsg, Bag ErrMsg))
-initTc us initenv do_this
+initTc dflags tc_env do_this
= do {
+ us <- mkSplitUniqSupply 'a' ;
us_var <- newIORef us ;
- dfun_var <- newIORef emptyFM ;
errs_var <- newIORef (emptyBag,emptyBag) ;
tvs_var <- newIORef emptyUFM ;
let
- init_down = TcDown [] us_var dfun_var
- noSrcLoc
- [] errs_var
- init_env = initenv tvs_var
+ 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 init_env ;
+ 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)
+ return (maybe_res, (warns, errs))
}
-- Monadic operations
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
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.
+So we compromise and use unsafeInterleaveIO.
We throw away any error messages!
\begin{code}
forkNF_Tc :: NF_TcM r -> NF_TcM r
-forkNF_Tc m (TcDown deflts u_var df_var src_loc err_cxt err_var) env
+forkNF_Tc m down@(TcDown { tc_us = u_var }) env
= do
-- Get a fresh unique supply
us <- readIORef u_var
unsafeInterleaveIO (do {
us_var' <- newIORef us2 ;
err_var' <- newIORef (emptyBag,emptyBag) ;
- tv_var' <- newIORef emptyUFM ;
- let { down' = TcDown deflts us_var' df_var src_loc err_cxt err_var' } ;
+ let { down' = down { tc_us = us_var', tc_errs = err_var' } };
m down' env
-- ToDo: optionally dump any error messages
})
\begin{code}
traceTc :: SDoc -> NF_TcM ()
-traceTc doc down env = printErrs doc
+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
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)
addErrTc :: Message -> NF_TcM ()
addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+addErrsTc :: [Message] -> NF_TcM ()
+addErrsTc [] = returnNF_Tc ()
+addErrsTc err_msgs = listNF_Tc (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
+
-- The 'M' variants do the TidyEnv bit
failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
failWithTcM env_and_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
tcGetSrcLoc down env = return (getLoc down)
tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc
-tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down)
+tcGetInstLoc origin TcDown{tc_loc=loc, tc_ctxt=ctxt} env
+ = return (origin, loc, ctxt)
tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message))
-> TcM a -> TcM a
-- 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
\end{code}
-\begin{code}
-tcGetDFunUniq :: String -> NF_TcM 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}
-
%************************************************************************
%* *
\begin{code}
data TcDown
- = 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))
+ = 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
-
-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 ds loc ctxt errs) = errs
-setTcErrs (TcDown def us ds loc ctxt _ ) errs = TcDown def us ds loc ctxt errs
+getTcErrs (TcDown{tc_errs=errs}) = errs
+setTcErrs down errs = down{tc_errs=errs}
+
+getDefaultTys (TcDown{tc_def=def}) = def
+setDefaultTys down def = down{tc_def=def}
-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{tc_loc=loc}) = loc
+setLoc down loc = down{tc_loc=loc}
-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{tc_us=us}) = us
-getUniqSupplyVar (TcDown def us ds loc ctxt errs) = us
-getDFunSupplyVar (TcDown def us ds loc ctxt errs) = ds
+getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
+setErrCtxt down msg = down{tc_ctxt=[msg]}
+addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
-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
+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}
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"),
type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
data InstOrigin
- = OccurrenceOf Id -- Occurrence of an overloaded identifier
+ = OccurrenceOf Name -- Occurrence of an overloaded identifier
+
+ | IPOcc (IPName Name) -- Occurrence of an implicit parameter
+ | IPBind (IPName Name) -- Binding site of an implicit parameter
| RecordUpdOrigin
| InstanceDeclOrigin -- Typechecking an instance decl
- | LiteralOrigin RenamedHsOverLit -- Occurrence of a literal
+ | LiteralOrigin HsOverLit -- Occurrence of a literal
| PatOrigin RenamedPat
| 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
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 (OccurrenceOf name)
+ = hsep [ptext SLIT("use of"), quotes (ppr name)]
+ pp_orig (IPOcc name)
+ = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
+ pp_orig (IPBind name)
+ = hsep [ptext SLIT("binding for implicit parameter"), quotes (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 (PArrSeqOrigin seq)
+ = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
pp_orig (SignatureOrigin)
= ptext SLIT("a type signature")
pp_orig (Rank2Origin)
projects / ghc-hetmet.git / blobdiff