\begin{code}
module TcMonad(
+ TcType, TcMaybe(..), TcBox,
+ TcTauType, TcThetaType, TcRhoType,
+ TcTyVar, TcTyVarSet,
+ TcKind,
+
TcM, NF_TcM, TcDown, TcEnv,
SST_R, FSST_R,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+ addErrTcM, failWithTcM,
tcGetEnv, tcSetEnv,
tcGetDefaultTys, tcSetDefaultTys,
tcNewMutVar, tcReadMutVar, tcWriteMutVar, TcRef,
- TcError, TcWarning,
+ TcError, TcWarning, TidyTypeEnv, emptyTidyEnv,
arityErr
) where
#include "HsVersions.h"
-import {-# SOURCE #-} TcEnv ( TcEnv, initEnv )
-import {-# SOURCE #-} TcType ( TcMaybe, TcTyVarSet )
+import {-# SOURCE #-} TcEnv ( TcEnv )
import Type ( Type, GenType )
-import TyVar ( TyVar, GenTyVar )
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
-import CmdLineOpts ( opt_PprStyle_All, opt_PprUserLength )
+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,
- UniqSM, initUs )
import Unique ( Unique )
import Util
import Outputable
\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}
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- 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
+ -> (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)
failTc down env
= failFSST ()
-failWithTc :: Message -> TcM s a -- Add an error message and fail
-failWithTc err_msg
- = addErrTc err_msg `thenNF_Tc_`
+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
-addErrTc :: Message -> NF_TcM s () -- Add an error message but don't fail
-addErrTc err_msg down env
- = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- listNF_Tc ctxt down env `thenSST` \ ctxt_msgs ->
+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 = addShortErrLocLine loc $
- hang err_msg 4 (vcat (ctxt_to_use ctxt_msgs))
+ vcat (err_msg : ctxt_to_use ctxt_msgs)
in
writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
returnSST ()
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_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
warn = addShortWarnLocLine loc $
- hang warn_msg 4 (vcat (ctxt_to_use ctxt_msgs))
+ vcat (warn_msg : ctxt_to_use ctxt_msgs)
in
writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
returnSST ()
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
-> (TcDown s -> TcEnv s -> State# s -> b)
-> TcDown s -> TcEnv s -> State# s -> b
-- Usual thing
-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 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
(TcRef s (Bag WarnMsg,
Bag ErrMsg))
-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
+-- 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
-ctxt_to_use ctxt | opt_PprStyle_All = ctxt
- | otherwise = takeAtMost 3 ctxt
+ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
+ | otherwise = takeAtMost 3 ctxt
where
takeAtMost :: Int -> [a] -> [a]
takeAtMost 0 ls = []
takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
arityErr kind name n m
- = hsep [ ppr name, ptext SLIT("should have"),
- n_arguments <> comma, text "but has been given", int m, char '.']
+ = 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