X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=e0fddacb6d298f47164ff9a02ce8a96c32a5aeac;hb=046feb1ea3b3dafb21c43fda88778198c1c709d6;hp=4a49352767ddb8e46415baab7d2f8b9bb0975174;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 4a49352..e0fddac 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -6,11 +6,11 @@ -- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -w #-} +{-# OPTIONS -w #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix -- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where @@ -26,12 +26,12 @@ import qualified GHC import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), Type, Module, ModuleName, TyThing(..), Phase, BreakIndex, SrcSpan, Resume, SingleStep ) +import PprTyThing import DynFlags import Packages import PackageConfig import UniqFM import HscTypes ( implicitTyThings ) -import PprTyThing import Outputable hiding (printForUser) import Module -- for ModuleEnv import Name @@ -76,6 +76,7 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO import System.IO.Error as IO +import System.IO.Unsafe import Data.Char import Data.Dynamic import Data.Array @@ -609,12 +610,13 @@ afterRunStmt step_here run_result = do let namesSorted = sortBy compareNames names tythings <- catMaybes `liftM` io (mapM (GHC.lookupName session) namesSorted) - docs_ty <- mapM showTyThing tythings - terms <- mapM (io . GHC.obtainTermB session 10 False) - [ id | (AnId id, Just _) <- zip tythings docs_ty] + let ids = [id | AnId id <- tythings] + terms <- mapM (io . GHC.obtainTermB session 10 False) ids docs_terms <- mapM (io . showTerm session) terms - printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts) - (catMaybes docs_ty) + dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts) + (map (pprTyThing pefas . AnId) ids) docs_terms runBreakCmd :: GHC.BreakInfo -> GHCi () @@ -990,8 +992,10 @@ typeOfExpr str maybe_ty <- io (GHC.exprType cms str) case maybe_ty of Nothing -> return () - Just ty -> do ty' <- cleanType ty - printForUser $ text str <> text " :: " <> ppr ty' + Just ty -> do dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser $ text str <+> dcolon + <+> pprTypeForUser pefas ty kindOfType :: String -> GHCi () kindOfType str @@ -999,7 +1003,7 @@ kindOfType str maybe_ty <- io (GHC.typeKind cms str) case maybe_ty of Nothing -> return () - Just ty -> printForUser $ text str <> text " :: " <> ppr ty + Just ty -> printForUser $ text str <+> dcolon <+> ppr ty quit :: String -> GHCi Bool quit _ = return True @@ -1298,26 +1302,10 @@ showBindings = do compareTyThings :: TyThing -> TyThing -> Ordering t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2 -showTyThing :: TyThing -> GHCi (Maybe SDoc) -showTyThing (AnId id) = do - ty' <- cleanType (GHC.idType id) - return $ Just $ ppr id <> text " :: " <> ppr ty' -showTyThing _ = return Nothing - printTyThing :: TyThing -> GHCi () -printTyThing tyth = do - mb_x <- showTyThing tyth - case mb_x of - Just x -> printForUser x - Nothing -> return () - --- if -fglasgow-exts is on we show the foralls, otherwise we don't. -cleanType :: Type -> GHCi Type -cleanType ty = do - dflags <- getDynFlags - if dopt Opt_PrintExplicitForalls dflags - then return ty - else return $! GHC.dropForAlls ty +printTyThing tyth = do dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + printForUser (pprTyThing pefas tyth) showBkptTable :: GHCi () showBkptTable = do @@ -1345,10 +1333,11 @@ completeNone w = return [] completeWord :: String -> Int -> Int -> IO (Maybe (String, [String])) completeWord w start end = do line <- Readline.getLineBuffer - case w of + let line_words = words (dropWhile isSpace line) + case w of ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w _other - | Just c <- is_cmd line -> do + | ((':':c) : _) <- line_words -> do maybe_cmd <- lookupCommand c let (n,w') = selectWord (words' 0 line) case maybe_cmd of @@ -1357,6 +1346,8 @@ completeWord w start end = do Just (_,_,True,complete) -> let complete' w = do rets <- complete w return (map (drop n) rets) in wrapCompleter complete' w' + | ("import" : _) <- line_words -> + wrapCompleter completeModule w | otherwise -> do --printf "complete %s, start = %d, end = %d\n" w start end wrapCompleter completeIdentifier w @@ -1372,9 +1363,6 @@ completeWord w start end = do | offset+length x >= start = (start-offset,take (end-offset) x) | otherwise = selectWord xs -is_cmd line - | ((':':w) : _) <- words (dropWhile isSpace line) = Just w - | otherwise = Nothing completeCmd w = do cmds <- readIORef commands @@ -1817,18 +1805,18 @@ findBreakByCoord mb_file (line, col) arr GHC.srcSpanStartLine span == line, GHC.srcSpanStartCol span >= col ] --- for now, use ANSI bold on Unixy systems. On Windows, we add a line --- of carets under the active expression instead. The Windows console --- doesn't support ANSI escape sequences, and most Unix terminals --- (including xterm) do, so this is a reasonable guess until we have a --- proper termcap/terminfo library. -#if !defined(mingw32_TARGET_OS) -do_bold = True -#else -do_bold = False -#endif +-- For now, use ANSI bold on terminals that we know support it. +-- Otherwise, we add a line of carets under the active expression instead. +-- In particular, on Windows and when running the testsuite (which sets +-- TERM to vt100 for other reasons) we get carets. +-- We really ought to use a proper termcap/terminfo library. +do_bold :: Bool +do_bold = unsafePerformIO (System.Environment.getEnv "TERM") `elem` + ["xterm", "linux"] +start_bold :: String start_bold = "\ESC[1m" +end_bold :: String end_bold = "\ESC[0m" listCmd :: String -> GHCi () @@ -1895,10 +1883,10 @@ listAround span do_highlight = do line_nos = [ fst_line .. ] highlighted | do_highlight = zipWith highlight line_nos these_lines - | otherwise = these_lines + | otherwise = [\p -> BS.concat[p,l] | l <- these_lines] bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ] - prefixed = zipWith BS.append bs_line_nos highlighted + prefixed = zipWith ($) highlighted bs_line_nos -- BS.putStrLn (BS.join (BS.pack "\n") prefixed) where @@ -1915,32 +1903,33 @@ listAround span do_highlight = do highlight | do_bold = highlight_bold | otherwise = highlight_carets - highlight_bold no line + highlight_bold no line prefix | no == line1 && no == line2 = let (a,r) = BS.splitAt col1 line (b,c) = BS.splitAt (col2-col1) r in - BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c] + BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c] | no == line1 = let (a,b) = BS.splitAt col1 line in - BS.concat [a, BS.pack start_bold, b] + BS.concat [prefix, a, BS.pack start_bold, b] | no == line2 = let (a,b) = BS.splitAt col2 line in - BS.concat [a, BS.pack end_bold, b] - | otherwise = line + BS.concat [prefix, a, BS.pack end_bold, b] + | otherwise = BS.concat [prefix, line] - highlight_carets no line + highlight_carets no line prefix | no == line1 && no == line2 - = BS.concat [line, nl, indent, BS.replicate col1 ' ', + = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ', BS.replicate (col2-col1) '^'] | no == line1 - = BS.concat [line, nl, indent, BS.replicate col1 ' ', - BS.replicate (BS.length line-col1) '^'] + = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, + prefix, line] | no == line2 - = BS.concat [line, nl, indent, BS.replicate col2 '^'] - | otherwise = line + = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ', + BS.pack "^^"] + | otherwise = BS.concat [prefix, line] where - indent = BS.pack " " + indent = BS.pack (" " ++ replicate (length (show no)) ' ') nl = BS.singleton '\n' -- --------------------------------------------------------------------------