\begin{code}
-#include "HsVersions.h"
-
module TcMonad(
- SYN_IE(TcM), SYN_IE(NF_TcM), TcDown, TcEnv,
+ TcType, TcMaybe(..), TcBox,
+ TcTauType, TcThetaType, TcRhoType,
+ TcTyVar, TcTyVarSet,
+ TcKind,
+
+ TcM, NF_TcM, TcDown, TcEnv,
SST_R, FSST_R,
initTc,
uniqSMToTcM,
- returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc,
+ returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc,
+ fixNF_Tc, forkNF_Tc, foldrNF_Tc, foldlNF_Tc,
listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
- failTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+ failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+ addErrTcM, failWithTcM,
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
tcAddErrCtxtM, tcSetErrCtxtM,
tcAddErrCtxt, tcSetErrCtxt,
- tcNewMutVar, tcReadMutVar, tcWriteMutVar,
+ tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
- SYN_IE(TcError), SYN_IE(TcWarning),
- mkTcErr, arityErr,
-
- -- For closure
- SYN_IE(MutableVar),
-#if __GLASGOW_HASKELL__ == 201
- GHCbase.MutableArray
-#elif __GLASGOW_HASKELL__ == 201
- GlaExts.MutableArray
-#else
- _MutableArray
-#endif
+ TcError, TcWarning, TidyTypeEnv, emptyTidyEnv,
+ arityErr
) where
-IMP_Ubiq(){-uitous-}
+#include "HsVersions.h"
-#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 {-# SOURCE #-} TcEnv ( TcEnv )
-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), SYN_IE(Warning) )
-import CmdLineOpts ( opt_PprStyle_All, opt_PprUserLength )
+import Type ( Type, GenType )
+import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
+import CmdLineOpts ( opt_PprStyle_Debug )
import SST
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
-import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
-import Maybes ( MaybeErr(..) )
+import Class ( Class )
+import Var ( GenTyVar )
+import VarEnv ( TyVarEnv, emptyVarEnv )
+import VarSet ( GenTyVarSet )
+import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply, splitUniqSupply,
+ UniqSM, initUs )
import SrcLoc ( SrcLoc, noSrcLoc )
+import FiniteMap ( FiniteMap, emptyFM )
import UniqFM ( UniqFM, emptyUFM )
-import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply,
- SYN_IE(UniqSM), initUs )
import Unique ( Unique )
import Util
-import Pretty
-import Outputable ( PprStyle(..), Outputable(..) )
+import Outputable
+
+import GlaExts ( State#, RealWorld )
infixr 9 `thenTc`, `thenTc_`, `thenNF_Tc`, `thenNF_Tc_`
\end{code}
+Types
+~~~~~
+\begin{code}
+type TcType s = GenType (TcBox s) -- Used during typechecker
+ -- 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 TcKind s = TcType s
+
+type TcThetaType s = [(Class, [TcType s])]
+type TcRhoType s = TcType s -- No ForAllTys
+type TcTauType s = TcType s -- No DictTys or ForAllTys
+
+type TcBox s = TcRef s (TcMaybe s)
+
+data TcMaybe s = UnBound
+ | BoundTo (TcType s)
+
+-- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
+-- because you get a synonym loop if you do!
+
+type TcTyVar s = GenTyVar (TcBox s)
+type TcTyVarSet s = GenTyVarSet (TcBox s)
+\end{code}
+
+
\section{TcM, NF_TcM: the type checker monads}
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\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
+-- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
+
initTc :: UniqSupply
- -> TcM REAL_WORLD r
- -> MaybeErr (r, Bag Warning)
- (Bag Error, Bag Warning)
+ -> (TcRef RealWorld (UniqFM a) -> TcEnv RealWorld)
+ -> TcM RealWorld r
+ -> (Maybe r, Bag WarnMsg, Bag ErrMsg)
-initTc us do_this
+initTc us initenv do_this
= runSST (
newMutVarSST us `thenSST` \ us_var ->
newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
init_down = TcDown [] us_var
noSrcLoc
[] errs_var
- init_env = initEnv tvs_var
+ init_env = initenv tvs_var
in
recoverSST
(\_ -> returnSST Nothing)
returnFSST (Just res))
`thenSST` \ maybe_res ->
readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- case (maybe_res, isEmptyBag errs) of
- (Just res, True) -> returnSST (Succeeded (res, warns))
- _ -> returnSST (Failed (errs, warns))
+ returnSST (maybe_res, warns, errs)
)
thenNF_Tc :: NF_TcM s a
mapNF_Tc f xs `thenNF_Tc` \ rs ->
returnNF_Tc (r:rs)
+foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b
+foldrNF_Tc k z [] = returnNF_Tc z
+foldrNF_Tc k z (x:xs) = foldrNF_Tc k z xs `thenNF_Tc` \r ->
+ k x r
+
+foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a
+foldlNF_Tc k z [] = returnNF_Tc z
+foldlNF_Tc k z (x:xs) = k z x `thenNF_Tc` \r ->
+ foldlNF_Tc k r xs
+
listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a]
listNF_Tc [] = returnNF_Tc []
listNF_Tc (x:xs) = x `thenNF_Tc` \ r ->
Error handling
~~~~~~~~~~~~~~
\begin{code}
-getErrsTc :: NF_TcM s (Bag Error, Bag Warning)
+getErrsTc :: NF_TcM s (Bag ErrMsg, Bag WarnMsg)
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) ->
- listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
+
+failTc :: TcM s a
+failTc down env
+ = failFSST ()
+
+failWithTc :: Message -> TcM s a -- Add an error message and fail
+failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
+
+addErrTc :: Message -> NF_TcM s ()
+addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+
+-- The 'M' variants do the TidyTypeEnv bit
+failWithTcM :: (TidyTypeEnv s, Message) -> TcM s a -- Add an error message and fail
+failWithTcM env_and_msg
+ = addErrTcM env_and_msg `thenNF_Tc_`
+ failTc
+
+addErrTcM :: (TidyTypeEnv s, Message) -> NF_TcM s () -- Add an error message but don't fail
+addErrTcM (tidy_env, err_msg) down env
+ = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ do_ctxt tidy_env ctxt down env `thenSST` \ ctxt_msgs ->
let
- err = mkTcErr loc ctxt_msgs err_msg
+ err = addShortErrLocLine loc $
+ vcat (err_msg : ctxt_to_use ctxt_msgs)
in
writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
- failFSST ()
+ returnSST ()
where
errs_var = getTcErrs down
ctxt = getErrCtxt down
loc = getLoc down
+do_ctxt tidy_env [] down env
+ = returnSST []
+do_ctxt tidy_env (c:cs) down env
+ = c tidy_env down env `thenSST` \ (tidy_env', m) ->
+ do_ctxt tidy_env' cs down env `thenSST` \ ms ->
+ returnSST (m:ms)
+
+-- warnings don't have an 'M' variant
warnTc :: Bool -> Message -> NF_TcM s ()
-warnTc warn_if_true warn down env
+warnTc warn_if_true warn_msg down env
= if warn_if_true then
- readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
+ readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ do_ctxt emptyTidyEnv ctxt down env `thenSST` \ ctxt_msgs ->
let
- full_warn = mkTcErr loc ctxt_msgs warn
+ warn = addShortWarnLocLine loc $
+ vcat (warn_msg : ctxt_to_use ctxt_msgs)
in
- writeMutVarSST errs_var (warns `snocBag` full_warn, errs) `thenSST_`
+ writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
returnSST ()
else
returnSST ()
= newMutVarSST (emptyBag,emptyBag) `thenSST` \ m_errs_var ->
let
errs_var = getTcErrs down
- propagate_errs
+ 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
+ failFSST()
in
- recoverFSST (\ _ -> propagate_errs `thenSST_` failFSST ()) $
+ recoverFSST propagate_errs $
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
+ readMutVarSST m_errs_var `thenSST` \ (m_warns, m_errs) ->
+ if isEmptyBag m_errs then
returnFSST result
else
- failFSST ()
+ failFSST () -- This triggers the recoverFSST
-- (tryTc r m) tries m; if it succeeds it returns it,
-- otherwise it returns r. Any error messages added by m are discarded,
recover down env
-- Run the thing inside, but throw away all its error messages.
-discardErrsTc :: TcM s r -> TcM s r
+-- discardErrsTc :: TcM s r -> TcM s r
+-- discardErrsTc :: NF_TcM s r -> NF_TcM s r
+discardErrsTc :: (TcDown s -> TcEnv s -> State# s -> a)
+ -> (TcDown s -> TcEnv s -> State# s -> a)
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
+checkTc False err = failWithTc err
checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true
checkTcM True err = returnTc ()
checkMaybeTc :: Maybe val -> Message -> TcM s val
checkMaybeTc (Just val) err = returnTc val
-checkMaybeTc Nothing err = failTc err
+checkMaybeTc Nothing err = failWithTc err
checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val
checkMaybeTcM (Just val) err = returnTc val
Mutable variables
~~~~~~~~~~~~~~~~~
\begin{code}
-tcNewMutVar :: a -> NF_TcM s (MutableVar s a)
+type TcRef s a = SSTRef s a
+
+tcNewMutVar :: a -> NF_TcM s (TcRef s a)
tcNewMutVar val down env = newMutVarSST val
-tcWriteMutVar :: MutableVar s a -> a -> NF_TcM s ()
+tcWriteMutVar :: TcRef s a -> a -> NF_TcM s ()
tcWriteMutVar var val down env = writeMutVarSST var val
-tcReadMutVar :: MutableVar s a -> NF_TcM s a
+tcReadMutVar :: TcRef s a -> NF_TcM s a
tcReadMutVar var down env = readMutVarSST var
\end{code}
tcSetEnv :: TcEnv s
-> (TcDown s -> TcEnv s -> State# s -> b)
- -> 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
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
tcGetSrcLoc down env = returnSST (getLoc down)
-tcSetErrCtxtM, tcAddErrCtxtM :: NF_TcM s Message -> TcM s a -> TcM s a
+tcSetErrCtxtM, tcAddErrCtxtM :: (TidyTypeEnv s -> NF_TcM s (TidyTypeEnv s, Message))
+ -> TcM s a -> TcM s a
tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env
tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env
-tcSetErrCtxt, tcAddErrCtxt :: Message -> TcM s a -> TcM s a
-tcSetErrCtxt msg m down env = m (setErrCtxt down (returnNF_Tc msg)) env
-tcAddErrCtxt msg m down env = m (addErrCtxt down (returnNF_Tc msg)) env
+tcSetErrCtxt, tcAddErrCtxt
+ :: Message
+ -> (TcDown s -> TcEnv s -> State# s -> b)
+ -> TcDown s -> TcEnv s -> State# s -> b
+-- 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
\end{code}
= readMutVarSST u_var `thenSST` \ uniq_supply ->
let
(new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniq = getUnique uniq_s
+ uniq = uniqFromSupply uniq_s
in
writeMutVarSST u_var new_uniq_supply `thenSST_`
returnSST uniq
= readMutVarSST u_var `thenSST` \ uniq_supply ->
let
(new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniqs = getUniques n uniq_s
+ uniqs = uniqsFromSupply n uniq_s
in
writeMutVarSST u_var new_uniq_supply `thenSST_`
returnSST uniqs
= TcDown
[Type] -- Types used for defaulting
- (MutableVar s UniqSupply) -- Unique supply
+ (TcRef s UniqSupply) -- Unique supply
SrcLoc -- Source location
(ErrCtxt s) -- Error context
- (MutableVar s (Bag Warning,
- Bag Error))
-
-type ErrCtxt s = [NF_TcM s Message] -- Innermost first. Monadic so that we have a chance
- -- to deal with bound type variables just before error
- -- message construction
+ (TcRef s (Bag WarnMsg,
+ Bag ErrMsg))
+
+-- The TidyTypeEnv gives us a chance to tidy up the type,
+-- so it prints nicely in error messages
+type TidyTypeEnv s = (FiniteMap FastString Int, -- Says what the 'next' unique to use
+ -- for this occname is
+ TyVarEnv (TcType s)) -- Current mapping
+
+emptyTidyEnv :: TidyTypeEnv s
+emptyTidyEnv = (emptyFM, emptyVarEnv)
+
+type ErrCtxt s = [TidyTypeEnv s -> NF_TcM s (TidyTypeEnv s, Message)]
+ -- Innermost first. Monadic so that we have a chance
+ -- to deal with bound type variables just before error
+ -- message construction
\end{code}
-- These selectors are *local* to TcMonad.lhs
type TcError = Message
type TcWarning = Message
-mkTcErr :: SrcLoc -- Where
- -> [Message] -- Context
- -> Message -- What went wrong
- -> TcError -- The complete error report
-
-mkTcErr locn ctxt msg sty
- = 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
- = hsep [ ppr sty name, ptext SLIT("should have"),
- n_arguments <> comma, text "but has been given", int m, char '.']
+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
+
+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
- errmsg = kind ++ " has too " ++ quantity ++ " arguments"
- quantity | m < n = "few"
- | otherwise = "many"
n_arguments | n == 0 = ptext SLIT("no arguments")
| n == 1 = ptext SLIT("1 argument")
| True = hsep [int n, ptext SLIT("arguments")]
projects / ghc-hetmet.git / blobdiff