X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=ff1979bc06444f1b0b377bcd8b188fa3ddbbae86;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=845bdd4e47a02851f20c3b72fd2eabd8a2dccb32;hpb=f7e8044f26652537e9b87c4481a45cdfb1bafb8a;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 845bdd4..ff1979b 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -10,6 +10,17 @@ module TcRnMonad( 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(..), @@ -20,13 +31,15 @@ import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), 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 ) @@ -34,7 +47,7 @@ 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 ) @@ -79,7 +92,6 @@ initTc hsc_env hsc_src mod do_this keep_var <- newIORef emptyNameSet ; th_var <- newIORef False ; dfun_n_var <- newIORef 1 ; - let { gbl_env = TcGblEnv { tcg_mod = mod, @@ -96,6 +108,8 @@ initTc hsc_env hsc_src mod do_this 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, @@ -114,17 +128,36 @@ initTc hsc_env hsc_src mod do_this 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 ; @@ -254,8 +287,8 @@ ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is tru 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} @@ -320,7 +353,7 @@ newUniqueSupply 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} @@ -350,7 +383,8 @@ traceOptTcRn :: DynFlag -> SDoc -> TcRn () 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 } @@ -452,7 +486,6 @@ addErrAt loc msg = addLongErrAt loc msg empty addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () addLongErrAt loc msg extra = 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 } ; @@ -646,12 +679,12 @@ getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } 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 }) -> @@ -683,7 +716,8 @@ addInstCtxt (InstLoc _ src_loc ctxt) thing_inside \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 @@ -717,7 +751,8 @@ checkTc False err = failWithTc err 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 () @@ -726,7 +761,32 @@ warnTc warn_if_true warn_msg | 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 @@ -744,7 +804,7 @@ ctxt_to_use ctxt | opt_PprStyle_Debug = 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 () @@ -979,16 +1039,4 @@ forkM doc thing_inside 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}