Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

WIP - ticket 3452, show something useful instead of failing with "no …

…show instance"
  • Loading branch information...
commit d542b418d913b4aba04e497fb63b70108b058f48 1 parent 3e598fe
@osa1 authored
View
8 compiler/main/HscMain.hs
@@ -1353,7 +1353,7 @@ IO monad as explained in Note [Interactively-bound Ids in GHCi] in TcRnDriver
--
-- We return Nothing to indicate an empty statement (or comment only), not a
-- parse error.
-hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], FixityEnv))
+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], IO [HValue], Bool, FixityEnv))
hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
-- | Compile a stmt all the way to an HValue, but don't run it
@@ -1364,7 +1364,7 @@ hscStmtWithLocation :: HscEnv
-> String -- ^ The statement
-> String -- ^ The source
-> Int -- ^ Starting line
- -> IO (Maybe ([Id], IO [HValue], FixityEnv))
+ -> IO (Maybe ([Id], IO [HValue], Bool, FixityEnv))
hscStmtWithLocation hsc_env0 stmt source linenumber =
runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
@@ -1381,7 +1381,7 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
-- Rename and typecheck it
-- Here we lift the stmt into the IO monad, see Note
-- [Interactively-bound Ids in GHCi] in TcRnDriver
- (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt
+ (ids, tc_expr, is_printed, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env icntxt parsed_stmt
-- Desugar it
ds_expr <- ioMsgMaybe $
@@ -1393,7 +1393,7 @@ hscStmtWithLocation hsc_env0 stmt source linenumber =
hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
let hval_io = unsafeCoerce# hval :: IO [HValue]
- return $ Just (ids, hval_io, fix_env)
+ return $ Just (ids, hval_io, is_printed, fix_env)
-- | Compile a decls
hscDecls :: HscEnv
View
21 compiler/main/InteractiveEval.hs
@@ -175,7 +175,7 @@ runStmtWithLocation source linenumber expr step =
-- empty statement / comment
Nothing -> return (RunOk [])
- Just (tyThings, hval, fix_env) -> do
+ Just (tyThings, hval, is_printed, fix_env) -> do
updateFixityEnv fix_env
status <-
@@ -188,13 +188,16 @@ runStmtWithLocation source linenumber expr step =
size = ghciHistSize idflags'
- case step of
- RunAndLogSteps ->
- traceRunStatus expr bindings tyThings
- breakMVar statusMVar status (emptyHistory size)
- _other ->
- handleRunStatus expr bindings tyThings
+ rl = if is_printed then id else resultNotShown
+
+ liftM rl $
+ case step of
+ RunAndLogSteps ->
+ traceRunStatus expr bindings tyThings
breakMVar statusMVar status (emptyHistory size)
+ _other ->
+ handleRunStatus expr bindings tyThings
+ breakMVar statusMVar status (emptyHistory size)
runDecls :: GhcMonad m => String -> m [Name]
runDecls = runDeclsWithLocation "<interactive>" 1
@@ -975,7 +978,7 @@ typeKind normalise str = withSession $ \hsc_env -> do
compileExpr :: GhcMonad m => String -> m HValue
compileExpr expr = withSession $ \hsc_env -> do
- Just (ids, hval, fix_env) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
+ Just (ids, hval, is_printed, fix_env) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr)
updateFixityEnv fix_env
hvals <- liftIO hval
case (ids,hvals) of
@@ -1000,7 +1003,7 @@ dynCompileExpr expr = do
}
setContext (IIDecl importDecl : iis)
let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")"
- Just (ids, hvals, fix_env) <- withSession $ \hsc_env ->
+ Just (ids, hvals, is_printed, fix_env) <- withSession $ \hsc_env ->
liftIO $ hscStmt hsc_env stmt
setContext iis
updateFixityEnv fix_env
View
6 compiler/main/InteractiveEvalTypes.hs
@@ -9,6 +9,7 @@
module InteractiveEvalTypes (
#ifdef GHCI
RunResult(..), Status(..), Resume(..), History(..),
+ resultNotShown,
#endif
) where
@@ -26,9 +27,14 @@ import Control.Concurrent
data RunResult
= RunOk [Name] -- ^ names bound by this evaluation
+ | RunOkNoShow [Name] -- ^ statement run fine but result isn't printed (no show instance)
| RunException SomeException -- ^ statement raised an exception
| RunBreak ThreadId [Name] (Maybe BreakInfo)
+resultNotShown :: RunResult -> RunResult
+resultNotShown (RunOk names) = RunOkNoShow names
+resultNotShown r = r
+
data Status
= Break Bool HValue BreakInfo ThreadId
-- ^ the computation hit a breakpoint (Bool <=> was an exception)
View
28 compiler/typecheck/TcRnDriver.lhs
@@ -1263,13 +1263,13 @@ setInteractiveContext hsc_env icxt thing_inside
-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
-- values, coerced to ().
tcRnStmt :: HscEnv -> InteractiveContext -> GhciLStmt RdrName
- -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv))
+ -> IO (Messages, Maybe ([Id], LHsExpr Id, Bool, FixityEnv))
tcRnStmt hsc_env ictxt rdr_stmt
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do {
-- The real work is done here
- ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;
+ ((bound_ids, tc_expr, is_printed), fix_env) <- tcUserStmt rdr_stmt ;
zonked_expr <- zonkTopLExpr tc_expr ;
zonked_ids <- zonkTopBndrs bound_ids ;
@@ -1304,7 +1304,7 @@ tcRnStmt hsc_env ictxt rdr_stmt
(vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
text "Typechecked expr" <+> ppr zonked_expr]) ;
- return (global_ids, zonked_expr, fix_env)
+ return (global_ids, zonked_expr, is_printed, fix_env)
}
where
bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
@@ -1355,7 +1355,8 @@ Here is the grand plan, implemented in tcUserStmt
\begin{code}
-- | A plan is an attempt to lift some code into the IO monad.
-type PlanResult = ([Id], LHsExpr Id)
+type PlanResult = ([Id], LHsExpr Id, Bool)
+
type Plan = TcM PlanResult
-- | Try the plans in order. If one fails (by raising an exn), try the next.
@@ -1407,6 +1408,7 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
-- A. [it <- e; print it] but not if it::()
-- B. [it <- e]
-- C. [let it = e; print it]
+ -- D. [let it = e]
--
-- Ensure that type errors don't get deferred when type checking the
-- naked expression. Deferring type errors here is unhelpful because the
@@ -1414,13 +1416,14 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
-- emit two redundant type-error warnings, one from each plan.
; plan <- unsetGOptM Opt_DeferTypeErrors $ runPlans [
-- Plan A
- do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
+ do { ([it_id], e, _) <- tcGhciStmts [bind_stmt, print_it]
; it_ty <- zonkTcType (idType it_id)
; when (isUnitTy $ it_ty) failM
- ; return stuff },
+ ; return ([it_id], e, True) },
-- Plan B; a naked bind statment
- tcGhciStmts [bind_stmt],
+ do { (ids, e, _) <- tcGhciStmts [bind_stmt]
+ ; return (ids, e, False) },
-- Plan C; check that the let-binding is typeable all by itself.
-- If not, fail; if so, try to print it.
@@ -1429,7 +1432,12 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
-- This two-step story is very clunky, alas
do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
--- checkNoErrs defeats the error recovery of let-bindings
- ; tcGhciStmts [let_stmt, print_it] } ]
+ ; (ids, e, _) <- tcGhciStmts [let_stmt, print_it]
+ ; return (ids, e, True) },
+
+ -- Plan D
+ do { (ids, e, _) <- tcGhciStmts [let_stmt]
+ ; return (ids, e, False) } ]
; fix_env <- getFixityEnv
; return (plan, fix_env) }
@@ -1463,7 +1471,7 @@ tcUserStmt rdr_stmt@(L loc _)
; return (plan, fix_env) }
where
mk_print_result_plan stmt v
- = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
+ = do { stuff@([v_id], _, is_printed) <- tcGhciStmts [stmt, print_v]
; v_ty <- zonkTcType (idType v_id)
; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
; return stuff }
@@ -1516,7 +1524,7 @@ tcGhciStmts stmts
stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
} ;
return (ids, mkHsDictLet (EvBinds const_binds) $
- noLoc (HsDo GhciStmtCtxt stmts io_ret_ty))
+ noLoc (HsDo GhciStmtCtxt stmts io_ret_ty), False)
}
-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
View
7 ghc/InteractiveUI.hs
@@ -853,6 +853,11 @@ afterRunStmt step_here run_result = do
GHC.RunOk names -> do
show_types <- isOptionSet ShowType
when show_types $ printTypeOfNames names
+ GHC.RunOkNoShow names -> do
+ -- at this point we know return value isn't printed
+ -- becuase it doesn't have Show instance implemented,
+ -- so print type of return value
+ printTypeOfNames names
GHC.RunBreak _ names mb_info
| isNothing mb_info ||
step_here (GHC.resumeSpan $ head resumes) -> do
@@ -874,7 +879,7 @@ afterRunStmt step_here run_result = do
b <- isOptionSet RevertCAFs
when b revertCAFs
- return (case run_result of GHC.RunOk _ -> True; _ -> False)
+ return (case run_result of GHC.RunOk _ -> True; GHC.RunOkNoShow _ -> True; _ -> False)
toBreakIdAndLocation ::
Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
Please sign in to comment.
Something went wrong with that request. Please try again.