Commit 02a06a56 authored by simonpj's avatar simonpj
Browse files

[project @ 2005-05-20 11:42:57 by simonpj]

Improve the GHCi interaction

		Merge to STABLE?

This fix addresses Sourceforge #1156554 "GHCi: No instance for (Show (IO ()))",
and simultaneously improves the top-level interaction in two other ways:

- Only one error can show up (previously there could be two)

- If an I/O action gives a Showable result, the result is printed
  (provided it isn't ()).  So
	prompt> return 4
  prints 4, rather than nothing

- For command-line 'let' and 'x<-e' forms, if exactly one variable
  is bound, we print its value if it is Showable and not ()
	prompt> let x = 4
	4
	prompt> x <- return 5
	5
parent 40d3a06b
......@@ -221,12 +221,12 @@ nlHsFunTy a b = noLoc (HsFunTy a b)
%************************************************************************
\begin{code}
mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
mkVarBind :: SrcSpan -> name -> LHsExpr name -> LHsBind name
mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsBinds RdrName -> LHsExpr RdrName
-> LHsBind RdrName
mk_easy_FunBind :: SrcSpan -> name -> [LPat name]
-> LHsBinds name -> LHsExpr name
-> LHsBind name
mk_easy_FunBind loc fun pats binds expr
= L loc (FunBind (L loc fun) False{-not infix-}
......
......@@ -83,8 +83,8 @@ import Outputable
#ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
LStmt, LHsExpr, LHsType, mkMatchGroup,
collectLStmtsBinders, mkSimpleMatch, nlVarPat,
LStmt, LHsExpr, LHsType, mkVarBind,
collectLStmtsBinders, collectLStmtBinders, nlVarPat,
placeHolderType, noSyntaxExpr )
import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv )
......@@ -95,7 +95,7 @@ import TcMType ( zonkTcType, zonkQuantifiedTyVar )
import TcMatches ( tcStmts, tcDoStmt )
import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType )
isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy )
import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
import RnTypes ( rnLHsType )
import Inst ( tcGetInstEnvs )
......@@ -116,7 +116,6 @@ import DataCon ( dataConTyCon )
import TyCon ( tyConName )
import TysWiredIn ( mkListTy, unitTy )
import IdInfo ( GlobalIdDetails(..) )
import SrcLoc ( unLoc )
import Kind ( Kind )
import Var ( globaliseId )
import Name ( nameOccName, nameModule, isBuiltInSyntax, nameParent_maybe )
......@@ -129,7 +128,7 @@ import HscTypes ( InteractiveContext(..), HomeModInfo(..),
Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
import Panic ( ghcError, GhcException(..) )
import SrcLoc ( SrcLoc )
import SrcLoc ( SrcLoc, unLoc, noSrcSpan )
#endif
import FastString ( mkFastString )
......@@ -843,8 +842,14 @@ tcRnStmt hsc_env ictxt rdr_stmt
failIfErrsM ;
-- The real work is done here
(bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
(bound_ids, tc_expr) <- mkPlan rn_stmt ;
zonked_expr <- zonkTopLExpr tc_expr ;
zonked_ids <- zonkTopBndrs bound_ids ;
-- None of the Ids should be of unboxed type, because we
-- cast them all to HValues in the end!
mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
traceTc (text "tcs 1") ;
let { -- (a) Make all the bound ids "global" ids, now that
-- they're notionally top-level bindings. This is
......@@ -855,7 +860,7 @@ tcRnStmt hsc_env ictxt rdr_stmt
-- (b) Tidy their types; this is important, because :info may
-- ask to look at them, and :info expects the things it looks
-- up to have tidy types
global_ids = map globaliseAndTidy bound_ids ;
global_ids = map globaliseAndTidy zonked_ids ;
-- Update the interactive context
rn_env = ic_rn_local_env ictxt ;
......@@ -880,10 +885,13 @@ tcRnStmt hsc_env ictxt rdr_stmt
dumpOptTcRn Opt_D_dump_tc
(vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
text "Typechecked expr" <+> ppr tc_expr]) ;
text "Typechecked expr" <+> ppr zonked_expr]) ;
returnM (new_ic, bound_names, tc_expr)
returnM (new_ic, bound_names, zonked_expr)
}
where
bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
globaliseAndTidy :: Id -> Id
globaliseAndTidy id
......@@ -915,33 +923,65 @@ Here is the grand plan, implemented in tcUserStmt
\begin{code}
---------------------------
tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
tcUserStmt (L loc (ExprStmt expr _ _))
= newUnique `thenM` \ uniq ->
let
fresh_it = itName uniq
the_bind = noLoc $ FunBind (noLoc fresh_it) False
(mkMatchGroup [mkSimpleMatch [] expr])
in
tryTcLIE_ (do { -- Try this if the other fails
traceTc (text "tcs 1b") ;
tc_stmts (map (L loc) [
LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
(HsVar thenIOName) placeHolderType
]) })
(do { -- Try this first
traceTc (text "tcs 1a") ;
tc_stmts [L loc (BindStmt (nlVarPat fresh_it) expr
(HsVar bindIOName) noSyntaxExpr) ] })
tcUserStmt stmt = tc_stmts [stmt]
type PlanResult = ([Id], LHsExpr Id)
type Plan = TcM PlanResult
runPlans :: [Plan] -> TcM PlanResult
-- Try the plans in order. If one fails (by raising an exn), try the next.
-- If one succeeds, take it.
runPlans [] = panic "runPlans"
runPlans [p] = p
runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
--------------------
mkPlan :: LStmt Name -> TcM PlanResult
mkPlan (L loc (ExprStmt expr _ _))
= do { uniq <- newUnique
; let fresh_it = itName uniq
the_bind = mkVarBind noSrcSpan fresh_it expr
let_stmt = L loc $ LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive]
bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
(HsVar bindIOName) noSyntaxExpr
print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
(HsVar thenIOName) placeHolderType
-- The plans are:
-- [it <- e; print it] but not if it::()
-- [it <- e]
-- [let it = e; print it]
-- [let it = e]
; runPlans [do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
; it_ty <- zonkTcType (idType it_id)
; ifM (isUnitTy it_ty) failM
; return stuff },
tcGhciStmts [bind_stmt],
tcGhciStmts [let_stmt, print_it],
tcGhciStmts [let_stmt]
]}
mkPlan stmt@(L loc _)
| [L _ v] <- collectLStmtBinders stmt -- One binder
= do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
(HsVar thenIOName) placeHolderType
-- The plans are:
-- [stmt; print v] but not if v::()
-- [stmt]
; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
; v_ty <- zonkTcType (idType v_id)
; ifM (isUnitTy v_ty) failM
; return stuff },
tcGhciStmts [stmt]
]}
| otherwise
= tcGhciStmts [stmt]
---------------------------
tc_stmts :: [LStmt Name] -> TcM ([Id], LHsExpr Id)
tc_stmts stmts
tcGhciStmts :: [LStmt Name] -> TcM PlanResult
tcGhciStmts stmts
= do { ioTyCon <- tcLookupTyCon ioTyConName ;
ret_id <- tcLookupId returnIOName ; -- return @ IO
let {
io_ty = mkTyConApp ioTyCon [] ;
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
......@@ -958,51 +998,27 @@ tc_stmts stmts
-- then the type checker would instantiate x..z, and we wouldn't
-- get their *polymorphic* values. (And we'd get ambiguity errs
-- if they were overloaded, since they aren't applied to anything.)
mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
(noLoc $ ExplicitList unitTy (map mk_item ids)) ;
mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
(noLoc $ ExplicitList unitTy (map mk_item ids)) ;
mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
(nlHsVar id) ;
io_ty = mkTyConApp ioTyCon []
(nlHsVar id)
} ;
-- OK, we're ready to typecheck the stmts
traceTc (text "tcs 2") ;
((ids, tc_expr), lie) <- getLIE $ do {
(tc_stmts, ids) <- tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $
do {
-- Look up the names right in the middle,
-- where they will all be in scope
ids <- mappM tcLookupId names ;
return ids } ;
ret_id <- tcLookupId returnIOName ; -- return @ IO
return (ids, noLoc (HsDo DoExpr tc_stmts (mk_return ret_id ids) io_ret_ty))
} ;
-- Simplify the context right here, so that we fail
-- if there aren't enough instances. Notably, when we see
-- e
-- we use recoverTc_ to try it <- e
-- and then let it = e
-- It's the simplify step that rejects the first.
traceTc (text "tcs 3") ;
const_binds <- tcSimplifyInteractive lie ;
-- Build result expression and zonk it
let { expr = mkHsLet const_binds tc_expr } ;
zonked_expr <- zonkTopLExpr expr ;
zonked_ids <- zonkTopBndrs ids ;
-- None of the Ids should be of unboxed type, because we
-- cast them all to HValues in the end!
mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
return (zonked_ids, zonked_expr)
}
where
bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
((tc_stmts, ids), lie) <- getLIE $
tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $
mappM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
-- Simplify the context
const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
-- checkNoErrs ensures that the plan fails if context redn fails
return (ids, mkHsLet const_binds $
noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
}
\end{code}
......@@ -1165,8 +1181,8 @@ lookup_rdr_name rdr_name = do {
-- constructor and type class identifiers.
let { rdr_names = dataTcOccs rdr_name } ;
-- results :: [(Messages, Maybe Name)]
results <- mapM (tryTc . lookupOccRn) rdr_names ;
-- results :: [Either Messages Name]
results <- mapM (tryTcErrs . lookupOccRn) rdr_names ;
traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
-- The successful lookups will be (Just name)
......
......@@ -491,68 +491,88 @@ discardWarnings thing_inside
\begin{code}
try_m :: TcRn r -> TcRn (Either Exception r)
-- Does try_m, with a debug-trace on failure
try_m thing
= do { mb_r <- tryM thing ;
case mb_r of
Left exn -> do { traceTc (exn_msg exn); return mb_r }
Right r -> return mb_r }
where
exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)
-----------------------
recoverM :: TcRn r -- Recovery action; do this if the main one fails
-> TcRn r -- Main action: do this first
-> TcRn r
-- Errors in 'thing' are retained
recoverM recover thing
= do { mb_res <- try_m thing ;
case mb_res of
Left exn -> recover
Right res -> returnM res }
-----------------------
tryTc :: TcRn a -> TcRn (Messages, Maybe a)
-- (tryTc m) executes m, and returns
-- Just r, if m succeeds (returning r) and caused no errors
-- Nothing, if m fails, or caused errors
-- It also returns all the errors accumulated by m
-- (even in the Just case, there might be warnings)
--
-- It always succeeds (never raises an exception)
-- (tryTc m) executes m, and returns
-- Just r, if m succeeds (returning r)
-- Nothing, if m fails
-- It also returns all the errors and warnings accumulated by m
-- It always succeeds (never raises an exception)
tryTc m
= do { errs_var <- newMutVar emptyMessages ;
mb_r <- try_m (setErrsVar errs_var m) ;
new_errs <- readMutVar errs_var ;
dflags <- getDOpts ;
return (new_errs,
case mb_r of
Left exn -> Nothing
Right r | errorsFound dflags new_errs -> Nothing
| otherwise -> Just r)
res <- try_m (setErrsVar errs_var m) ;
msgs <- readMutVar errs_var ;
return (msgs, case res of
Left exn -> Nothing
Right val -> Just val)
-- The exception is always the IOEnv built-in
-- in exception; see IOEnv.failM
}
try_m :: TcRn r -> TcRn (Either Exception r)
-- Does try_m, with a debug-trace on failure
try_m thing
= do { mb_r <- tryM thing ;
case mb_r of
Left exn -> do { traceTc (exn_msg exn); return mb_r }
Right r -> return mb_r }
where
exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)
-----------------------
tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
-- Run the thing, returning
-- Just r, if m succceeds with no error messages
-- Nothing, if m fails, or if it succeeds but has error messages
-- Either way, the messages are returned; even in the Just case
-- there might be warnings
tryTcErrs thing
= do { (msgs, res) <- tryTc thing
; dflags <- getDOpts
; let errs_found = errorsFound dflags msgs
; return (msgs, case res of
Nothing -> Nothing
Just val | errs_found -> Nothing
| otherwise -> Just val)
}
-----------------------
tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
-- Just like tryTc, except that it ensures that the LIE
-- Just like tryTcErrs, except that it ensures that the LIE
-- for the thing is propagated only if there are no errors
-- Hence it's restricted to the type-check monad
tryTcLIE thing_inside
= do { ((errs, mb_r), lie) <- getLIE (tryTc thing_inside) ;
ifM (isJust mb_r) (extendLIEs lie) ;
return (errs, mb_r) }
= do { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ;
; case mb_res of
Nothing -> return (msgs, Nothing)
Just val -> do { extendLIEs lie; return (msgs, Just val) }
}
-----------------------
tryTcLIE_ :: TcM r -> TcM r -> TcM r
-- (tryTcLIE_ r m) tries m; if it succeeds it returns it,
-- otherwise it returns r. Any error messages added by m are discarded,
-- whether or not m succeeds.
-- (tryTcLIE_ r m) tries m;
-- if m succeeds with no error messages, it's the answer
-- otherwise tryTcLIE_ drops everything from m and tries r instead.
tryTcLIE_ recover main
= do { (_msgs, mb_res) <- tryTcLIE main ;
case mb_res of
Just res -> return res
Nothing -> recover }
= do { (msgs, mb_res) <- tryTcLIE main
; case mb_res of
Just val -> do { addMessages msgs -- There might be warnings
; return val }
Nothing -> recover -- Discard all msgs
}
-----------------------
checkNoErrs :: TcM r -> TcM r
-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
-- If m fails then (checkNoErrsTc m) fails.
......@@ -561,12 +581,12 @@ checkNoErrs :: TcM r -> TcM r
-- If so, it fails too.
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
= do { (msgs, mb_res) <- tryTcLIE main ;
addMessages msgs ;
case mb_res of
Just r -> return r
Nothing -> failM
}
= do { (msgs, mb_res) <- tryTcLIE main
; addMessages msgs
; case mb_res of
Nothing -> failM
Just val -> return val
}
ifErrsM :: TcRn r -> TcRn r -> TcRn r
-- ifErrsM bale_out main
......
......@@ -1240,9 +1240,9 @@ checkExpectedKind ty act_kind exp_kind
| act_kind `isSubKind` exp_kind -- Short cut for a very common case
= returnM ()
| otherwise
= tryTc (unifyKind exp_kind act_kind) `thenM` \ (errs, mb_r) ->
= tryTc (unifyKind exp_kind act_kind) `thenM` \ (_errs, mb_r) ->
case mb_r of {
Just _ -> returnM () ; -- Unification succeeded
Just r -> returnM () ; -- Unification succeeded
Nothing ->
-- So there's definitely an error
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment