import TcRnTypes -- Re-export all
import IOEnv -- Re-export all
+#if defined(GHCI) && defined(BREAKPOINT)
+import TypeRep ( Type(..), liftedTypeKind, TyThing(..) )
+import Var ( mkTyVar, mkGlobalId )
+import IdInfo ( GlobalIdDetails(..), vanillaIdInfo )
+import OccName ( mkOccName, tvName )
+import SrcLoc ( noSrcLoc )
+import TysWiredIn ( intTy, stringTy, mkListTy, unitTy )
+import PrelNames ( breakpointJumpName )
+import NameEnv ( mkNameEnv )
+#endif
+
import HsSyn ( emptyLHsBinds )
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
TyThing, TypeEnv, emptyTypeEnv, HscSource(..),
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,
mkLocMessage, mkLongErrMsg )
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 )
keep_var <- newIORef emptyNameSet ;
th_var <- newIORef False ;
dfun_n_var <- newIORef 1 ;
-
let {
gbl_env = TcGblEnv {
tcg_mod = mod,
tcg_imports = init_imports,
tcg_home_mods = home_mods,
tcg_dus = emptyDUs,
+ tcg_rn_imports = Nothing,
+ tcg_rn_exports = Nothing,
tcg_rn_decls = Nothing,
tcg_binds = emptyLHsBinds,
tcg_deprecs = NoDeprecs,
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
} ;
} ;
-- OK, here's the business end!
maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
- do { r <- tryM do_this
- ; case r of
- Right res -> return (Just res)
- Left _ -> return Nothing } ;
+ do {
+#if defined(GHCI) && defined(BREAKPOINT)
+ unique <- newUnique ;
+ let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc;
+ tyvar = mkTyVar var liftedTypeKind;
+ breakpointJumpType = mkGlobalId
+ (VanillaGlobal)
+ (breakpointJumpName)
+ (FunTy intTy
+ (FunTy (mkListTy unitTy)
+ (FunTy stringTy
+ (ForAllTy tyvar
+ (FunTy (TyVarTy tyvar)
+ (TyVarTy tyvar))))))
+ (vanillaIdInfo);
+ new_env = mkNameEnv [(breakpointJumpName,AGlobal (AnId breakpointJumpType))];
+ };
+ r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this)
+#else
+ r <- tryM do_this
+#endif
+ ; case r of
+ Right res -> return (Just res)
+ Left _ -> return Nothing } ;
-- Collect any error messages
msgs <- readIORef errs_var ;
ifOptM flag thing_inside = do { b <- doptM flag;
if b then thing_inside else return () }
-getGhciMode :: TcRnIf gbl lcl GhcMode
-getGhciMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
+getGhcMode :: TcRnIf gbl lcl GhcMode
+getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
\end{code}
\begin{code}
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 ;
-
- let style = mkErrStyle (unQualInScope rdr_env)
- doc = mkLocMessage loc (msg $$ extra)
- in traceTc (ptext SLIT("Adding error:") <+> doc) ;
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}
projects / ghc-hetmet.git / blobdiff