import Module ( Module, unitModuleEnv )
import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv,
LocalRdrEnv, emptyLocalRdrEnv )
-import Name ( Name, isInternalName, mkInternalName, getOccName, getSrcLoc )
+import Name ( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
import Type ( Type )
-import NameEnv ( extendNameEnvList )
+import TcType ( tcIsTyVarTy, tcGetTyVar )
+import NameEnv ( extendNameEnvList, nameEnvElts )
import InstEnv ( emptyInstEnv )
+import Var ( setTyVarName )
import VarSet ( emptyVarSet )
-import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv )
+import VarEnv ( TidyEnv, emptyTidyEnv, extendVarEnv )
import ErrUtils ( Message, Messages, emptyMessages, errorsFound,
- mkWarnMsg, printErrorsAndWarnings, pprBagOfErrors,
+ mkWarnMsg, printErrorsAndWarnings,
mkLocMessage, mkLongErrMsg )
import Packages ( mkHomeModules )
import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
import NameEnv ( emptyNameEnv )
import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet )
-import OccName ( emptyOccEnv )
+import OccName ( emptyOccEnv, tidyOccName )
import Bag ( emptyBag )
import Outputable
import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
import Unique ( Unique )
import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
import StaticFlags ( opt_PprStyle_Debug )
-import Bag ( snocBag, unionBags, unitBag )
+import Bag ( snocBag, unionBags )
import Panic ( showException )
import IO ( stderr )
tcl_arrow_ctxt = NoArrowCtxt,
tcl_env = emptyNameEnv,
tcl_tyvars = tvs_var,
- tcl_lie = panic "initTc:LIE", -- LIE only valid inside a getLIE
- tcl_gadt = emptyVarEnv
+ tcl_lie = panic "initTc:LIE" -- LIE only valid inside a getLIE
} ;
} ;
-> IO (Maybe r)
initTcPrintErrors env mod todo = do
(msgs, res) <- initTc env HsSrcFile mod todo
- printErrorsAndWarnings msgs
+ printErrorsAndWarnings (hsc_dflags env) msgs
return res
-- mkImpTypeEnv makes the imported symbol table
newLocalName :: Name -> TcRnIf gbl lcl Name
newLocalName name -- Make a clone
= newUnique `thenM` \ uniq ->
- returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
+ returnM (mkInternalName uniq (nameOccName name) (getSrcLoc name))
\end{code}
traceOptTcRn flag doc = ifOptM flag $ do
{ ctxt <- getErrCtxt
; loc <- getSrcSpanM
- ; ctxt_msgs <- do_ctxt emptyTidyEnv ctxt
+ ; env0 <- tcInitTidyEnv
+ ; ctxt_msgs <- do_ctxt env0 ctxt
; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs))
; dumpTcRn real_doc }
getModule :: TcRn Module
getModule = do { env <- getGblEnv; return (tcg_mod env) }
+setModule :: Module -> TcRn a -> TcRn a
+setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside
+
tcIsHsBoot :: TcRn Bool
tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) }
addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
addLongErrAt loc msg extra
- = do { errs_var <- getErrsVar ;
+ = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;
+ errs_var <- getErrsVar ;
rdr_env <- getGlobalRdrEnv ;
let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
(warns, errs) <- readMutVar errs_var ;
- traceTc (ptext SLIT("Adding error:") <+> \ _ -> pprBagOfErrors (unitBag err)) ;
- -- Ugh! traceTc is too specific; unitBag is horrible
writeMutVar errs_var (warns, errs `snocBag` err) }
addErrs :: [(SrcSpan,Message)] -> TcRn ()
setErrCtxt :: ErrCtxt -> TcM a -> TcM a
setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
-addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
-addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
-
addErrCtxt :: Message -> TcM a -> TcM a
addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg))
+addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a
+addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs)
+
-- Helper function for the above
updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a
updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
\begin{code}
addErrTc :: Message -> TcM ()
-addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+addErrTc err_msg = do { env0 <- tcInitTidyEnv
+ ; addErrTcM (env0, err_msg) }
addErrsTc :: [Message] -> TcM ()
addErrsTc err_msgs = mappM_ addErrTc err_msgs
addWarnTc :: Message -> TcM ()
addWarnTc msg
= do { ctxt <- getErrCtxt ;
- ctxt_msgs <- do_ctxt emptyTidyEnv ctxt ;
+ env0 <- tcInitTidyEnv ;
+ ctxt_msgs <- do_ctxt env0 ctxt ;
addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) }
warnTc :: Bool -> Message -> TcM ()
| otherwise = return ()
\end{code}
- Helper functions
+-----------------------------------
+ Tidying
+
+We initialise the "tidy-env", used for tidying types before printing,
+by building a reverse map from the in-scope type variables to the
+OccName that the programmer originally used for them
+
+\begin{code}
+tcInitTidyEnv :: TcM TidyEnv
+tcInitTidyEnv
+ = do { lcl_env <- getLclEnv
+ ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
+ | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
+ , tcIsTyVarTy ty ]
+ ; return (foldl add emptyTidyEnv nm_tv_prs) }
+ where
+ add (env,subst) (name, tyvar)
+ = case tidyOccName env (nameOccName name) of
+ (env', occ') -> (env', extendVarEnv subst tyvar tyvar')
+ where
+ tyvar' = setTyVarName tyvar name'
+ name' = tidyNameOcc name occ'
+\end{code}
+
+-----------------------------------
+ Other helper functions
\begin{code}
add_err_tcm tidy_env err_msg loc ctxt
| otherwise = take 3 ctxt
\end{code}
-debugTc is useful for monadi debugging code
+debugTc is useful for monadic debugging code
\begin{code}
debugTc :: TcM () -> TcM ()
Just r -> r) }
\end{code}
-%************************************************************************
-%* *
- Stuff for GADTs
-%* *
-%************************************************************************
-
-\begin{code}
-getTypeRefinement :: TcM GadtRefinement
-getTypeRefinement = do { lcl_env <- getLclEnv; return (tcl_gadt lcl_env) }
-setTypeRefinement :: GadtRefinement -> TcM a -> TcM a
-setTypeRefinement gadt = updLclEnv (\env -> env { tcl_gadt = gadt })
-\end{code}