Repository : ssh://darcs.haskell.org//srv/darcs/packages/haskeline On branch : master
http://hackage.haskell.org/trac/ghc/changeset/240ef6385702edccc708c21113b7b101cb473335 >--------------------------------------------------------------- commit 240ef6385702edccc708c21113b7b101cb473335 Author: Judah Jacobson <[email protected]> Date: Wed Jul 18 20:59:56 2012 +0000 Fix ctrl-L on Windows with large console window sizes (GHC ticket #4415). Here "large" means an area of >2^15 cells, e.g., 200x200. Original patch by [email protected]. >--------------------------------------------------------------- System/Console/Haskeline/Backend/Win32.hsc | 46 +++++++++++++++++++++++++--- cbits/win_console.c | 8 +++++ includes/win_console.h | 2 + 3 files changed, 51 insertions(+), 5 deletions(-) diff --git a/System/Console/Haskeline/Backend/Win32.hsc b/System/Console/Haskeline/Backend/Win32.hsc index e11cbc0..2a34c84 100644 --- a/System/Console/Haskeline/Backend/Win32.hsc +++ b/System/Console/Haskeline/Backend/Win32.hsc @@ -350,11 +350,7 @@ instance (MonadException m, MonadReader Layout m) => Term (Draw m) where printLines [] = return () printLines ls = printText $ intercalate crlf ls ++ crlf - clearLayout = do - lay <- ask - setPos (Coord 0 0) - printText (replicate (width lay * height lay) ' ') - setPos (Coord 0 0) + clearLayout = clearScreen moveToNextLine s = do movePosRight (snd s) @@ -500,3 +496,43 @@ getMultiByteChar cp h = hWithBinaryMode h loop case cs of [] -> loop (c:_) -> return c + +---------------------------------- +-- Clearing screen +-- WriteConsole has a limit of ~20,000-30000 characters, which is +-- less than a 200x200 window, for example. +-- So we'll use other Win32 functions to clear the screen. + +getAttribute :: HANDLE -> IO WORD +getAttribute = withScreenBufferInfo $ + (#peek CONSOLE_SCREEN_BUFFER_INFO, wAttributes) + +fillConsoleChar :: HANDLE -> Char -> Int -> Coord -> IO () +fillConsoleChar h c n start = with start $ \startPtr -> alloca $ \numWritten -> do + failIfFalse_ "FillConsoleOutputCharacter" + $ c_FillConsoleCharacter h (toEnum $ fromEnum c) + (toEnum n) startPtr numWritten + +foreign import ccall "haskeline_FillConsoleCharacter" c_FillConsoleCharacter + :: HANDLE -> TCHAR -> DWORD -> Ptr Coord -> Ptr DWORD -> IO BOOL + +fillConsoleAttribute :: HANDLE -> WORD -> Int -> Coord -> IO () +fillConsoleAttribute h a n start = with start $ \startPtr -> alloca $ \numWritten -> do + failIfFalse_ "FillConsoleOutputAttribute" + $ c_FillConsoleAttribute h a + (toEnum n) startPtr numWritten + +foreign import ccall "haskeline_FillConsoleAttribute" c_FillConsoleAttribute + :: HANDLE -> WORD -> DWORD -> Ptr Coord -> Ptr DWORD -> IO BOOL + +clearScreen :: DrawM () +clearScreen = do + lay <- ask + h <- asks hOut + let windowSize = width lay * height lay + let origin = Coord 0 0 + attr <- liftIO $ getAttribute h + liftIO $ fillConsoleChar h ' ' windowSize origin + liftIO $ fillConsoleAttribute h attr windowSize origin + setPos origin + diff --git a/cbits/win_console.c b/cbits/win_console.c index c8ae01a..7d394ec 100644 --- a/cbits/win_console.c +++ b/cbits/win_console.c @@ -3,3 +3,11 @@ BOOL haskeline_SetPosition(HANDLE h, COORD* c) { return SetConsoleCursorPosition(h,*c); } + +BOOL haskeline_FillConsoleCharacter(HANDLE h, TCHAR c, DWORD l, COORD *p, LPDWORD n) { + return FillConsoleOutputCharacter(h,c,l,*p,n); +} + +BOOL haskeline_FillConsoleAttribute(HANDLE h, WORD a, DWORD l, COORD *p, LPDWORD n) { + return FillConsoleOutputAttribute(h,a,l,*p,n); +} diff --git a/includes/win_console.h b/includes/win_console.h index cfe24a2..b4525cd 100644 --- a/includes/win_console.h +++ b/includes/win_console.h @@ -3,5 +3,7 @@ #include <windows.h> BOOL haskeline_SetPosition(HANDLE h, COORD* c); +BOOL haskeline_FillConsoleCharacter(HANDLE h, TCHAR c, DWORD l, COORD *p, LPDWORD n); +BOOL haskeline_FillConsoleAttribute(HANDLE h, WORD c, DWORD l, COORD *p, LPDWORD n); #endif _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
