From: simonpj Date: Fri, 20 May 2005 11:42:57 +0000 (+0000) Subject: [project @ 2005-05-20 11:42:57 by simonpj] X-Git-Tag: Initial_conversion_from_CVS_complete~504 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=02a06a56c6511b19ef411fd3884089ea996cc26b;hp=40d3a06b353392a322d8425fb5dd9f103f4421f3;p=ghc-hetmet.git [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 --- diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index 6134d50..d2e757e 100644 --- a/ghc/compiler/hsSyn/HsUtils.lhs +++ b/ghc/compiler/hsSyn/HsUtils.lhs @@ -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-} diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index c0e3f5f..925b838 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -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) diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 306a71b..1023f56 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index dea7766..c11ae24 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -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