[commit: haskeline] master: Fix ctrl-L on Windows with large console window sizes (GHC ticket #4415). (240ef63)

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