X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=ff1979bc06444f1b0b377bcd8b188fa3ddbbae86;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=86b2fbeaa137cbe291e9ae02534d4d7a13ab3d08;hpb=0c53bd0e1b02dea0bde32cd7eb8ccb5ee2d3719e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 86b2fbe..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,28 +31,30 @@ import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), import Module ( Module, unitModuleEnv ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) -import Name ( Name, isInternalName ) +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 ) @@ -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 ; @@ -159,7 +192,7 @@ initTcPrintErrors -- Used from the interactive loop only -> 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 @@ -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} @@ -316,6 +349,11 @@ newUniqueSupply let { (us1, us2) = splitUniqSupply us } ; writeMutVar u_var us1 ; return us2 } + +newLocalName :: Name -> TcRnIf gbl lcl Name +newLocalName name -- Make a clone + = newUnique `thenM` \ uniq -> + returnM (mkInternalName uniq (nameOccName name) (getSrcLoc name)) \end{code} @@ -345,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 } @@ -368,6 +407,9 @@ dumpOptTcRn flag doc = ifOptM flag (dumpTcRn 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)) } @@ -443,12 +485,11 @@ addErrAt loc msg = addLongErrAt loc msg empty 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 () @@ -638,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 }) -> @@ -675,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 @@ -709,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 () @@ -718,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 @@ -736,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 () @@ -926,7 +994,7 @@ failIfM :: Message -> IfL a -- We use IfL here so that we can get context info out of the local env failIfM msg = do { env <- getLclEnv - ; let full_msg = if_loc env $$ nest 2 msg + ; let full_msg = (if_loc env <> colon) $$ nest 2 msg ; ioToIOEnv (printErrs (full_msg defaultErrStyle)) ; failM } @@ -966,20 +1034,9 @@ forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside = do { mb_res <- forkM_maybe doc thing_inside ; return (case mb_res of - Nothing -> pprPanic "forkM" doc + Nothing -> pgmError "Cannot continue after interface file error" + -- pprPanic "forkM" doc 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}