Win32.hsc 21.5 KB
Newer Older
1
module System.Console.Haskeline.Backend.Win32(
2
                win32Term,
3
                win32TermStdin,
4
                fileRunTerm
5
6
7
8
                )where


import System.IO
9
10
11
import Foreign
import Foreign.C
import System.Win32 hiding (multiByteToWideChar)
12
import Graphics.Win32.Misc(getStdHandle, sTD_OUTPUT_HANDLE)
judah's avatar
judah committed
13
import Data.List(intercalate)
14
import Control.Concurrent hiding (throwTo)
15
import Data.Char(isPrint)
16
import Data.Maybe(mapMaybe)
17
import Control.Applicative
18
import Control.Monad
judah's avatar
judah committed
19

20
import System.Console.Haskeline.Key
Edward Z. Yang's avatar
Edward Z. Yang committed
21
import System.Console.Haskeline.Monads hiding (Handler)
judah's avatar
judah committed
22
import System.Console.Haskeline.LineState
23
import System.Console.Haskeline.Term
judah's avatar
judah committed
24
import System.Console.Haskeline.Backend.WCWidth
25

26
27
28
import Data.ByteString.Internal (createAndTrim)
import qualified Data.ByteString as B

judah's avatar
judah committed
29
30
31
32
33
34
35
36
##if defined(i386_HOST_ARCH)
## define WINDOWS_CCONV stdcall
##elif defined(x86_64_HOST_ARCH)
## define WINDOWS_CCONV ccall
##else
## error Unknown mingw32 arch
##endif

37
38
#include "win_console.h"

39
foreign import WINDOWS_CCONV "windows.h ReadConsoleInputW" c_ReadConsoleInput
40
41
    :: HANDLE -> Ptr () -> DWORD -> Ptr DWORD -> IO Bool
    
42
foreign import WINDOWS_CCONV "windows.h WaitForSingleObject" c_WaitForSingleObject
judah's avatar
judah committed
43
44
    :: HANDLE -> DWORD -> IO DWORD

45
foreign import WINDOWS_CCONV "windows.h GetNumberOfConsoleInputEvents"
46
47
48
49
50
51
52
53
    c_GetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO Bool

getNumberOfEvents :: HANDLE -> IO Int
getNumberOfEvents h = alloca $ \numEventsPtr -> do
    failIfFalse_ "GetNumberOfConsoleInputEvents"
        $ c_GetNumberOfConsoleInputEvents h numEventsPtr
    fmap fromEnum $ peek numEventsPtr

judah's avatar
judah committed
54
55
getEvent :: HANDLE -> Chan Event -> IO Event
getEvent h = keyEventLoop (eventReader h)
56

57
58
eventReader :: HANDLE -> IO [Event]
eventReader h = do
59
60
61
62
63
    let waitTime = 500 -- milliseconds
    ret <- c_WaitForSingleObject h waitTime
    yield -- otherwise, the above foreign call causes the loop to never 
          -- respond to the killThread
    if ret /= (#const WAIT_OBJECT_0)
64
        then eventReader h
65
        else do
66
            es <- readEvents h
67
            return $ mapMaybe processEvent es
68
69
70
71
72
73
74
75
76

consoleHandles :: MaybeT IO Handles
consoleHandles = do
    h_in <- open "CONIN$"
    h_out <- open "CONOUT$"
    return Handles { hIn = h_in, hOut = h_out }
  where
   open file = handle (\(_::IOException) -> mzero) $ liftIO
                $ createFile file (gENERIC_READ .|. gENERIC_WRITE)
77
                        (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing
78
                        oPEN_EXISTING 0 Nothing
79

80
                       
81
82
processEvent :: InputEvent -> Maybe Event
processEvent KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc,
83
                    controlKeyState = cstate}
84
    = fmap (\e -> KeyInput [Key modifier' e]) $ keyFromCode vc `mplus` simpleKeyChar
85
  where
86
87
    simpleKeyChar = guard (c /= '\NUL') >> return (KeyChar c)
    testMod ck = (cstate .&. ck) /= 0
judah's avatar
judah committed
88
89
90
    modifier' = if hasMeta modifier && hasControl modifier
                    then noModifier {hasShift = hasShift modifier}
                    else modifier
91
92
93
94
95
96
    modifier = Modifier {hasMeta = testMod ((#const RIGHT_ALT_PRESSED) 
                                        .|. (#const LEFT_ALT_PRESSED))
                        ,hasControl = testMod ((#const RIGHT_CTRL_PRESSED) 
                                        .|. (#const LEFT_CTRL_PRESSED))
                                    && not (c > '\NUL' && c <= '\031')
                        ,hasShift = testMod (#const SHIFT_PRESSED)
97
                                    && not (isPrint c)
98
                        }
99

100
101
processEvent WindowEvent = Just WindowResize
processEvent _ = Nothing
102

103
keyFromCode :: WORD -> Maybe BaseKey
104
keyFromCode (#const VK_BACK) = Just Backspace
105
106
107
108
109
keyFromCode (#const VK_LEFT) = Just LeftKey
keyFromCode (#const VK_RIGHT) = Just RightKey
keyFromCode (#const VK_UP) = Just UpKey
keyFromCode (#const VK_DOWN) = Just DownKey
keyFromCode (#const VK_DELETE) = Just Delete
110
111
keyFromCode (#const VK_HOME) = Just Home
keyFromCode (#const VK_END) = Just End
112
113
keyFromCode (#const VK_PRIOR) = Just PageUp
keyFromCode (#const VK_NEXT) = Just PageDown
114
115
116
117
-- The Windows console will return '\r' when return is pressed.
keyFromCode (#const VK_RETURN) = Just (KeyChar '\n')
-- TODO: KillLine?
-- TODO: function keys.
118
119
120
121
122
123
124
125
126
keyFromCode _ = Nothing
    
data InputEvent = KeyEvent {keyDown :: BOOL,
                          repeatCount :: WORD,
                          virtualKeyCode :: WORD,
                          virtualScanCode :: WORD,
                          unicodeChar :: Char,
                          controlKeyState :: DWORD}
            -- TODO: WINDOW_BUFFER_SIZE_RECORD
judah's avatar
judah committed
127
            -- I cant figure out how the user generates them.
128
           | WindowEvent
129
130
131
           | OtherEvent
                        deriving Show

132
133
peekEvent :: Ptr () -> IO InputEvent
peekEvent pRecord = do
134
135
136
137
    eventType :: WORD <- (#peek INPUT_RECORD, EventType) pRecord
    let eventPtr = (#ptr INPUT_RECORD, Event) pRecord
    case eventType of
        (#const KEY_EVENT) -> getKeyEvent eventPtr
138
        (#const WINDOW_BUFFER_SIZE_EVENT) -> return WindowEvent
139
        _ -> return OtherEvent
140
141
142
143
144
145
146
147
148
149
150
151

readEvents :: HANDLE -> IO [InputEvent]
readEvents h = do
    n <- getNumberOfEvents h
    alloca $ \numEventsPtr -> 
        allocaBytes (n * #size INPUT_RECORD) $ \pRecord -> do
            failIfFalse_ "ReadConsoleInput" 
                $ c_ReadConsoleInput h pRecord (toEnum n) numEventsPtr
            numRead <- fmap fromEnum $ peek numEventsPtr
            forM [0..toEnum numRead-1] $ \i -> peekEvent
                $ pRecord `plusPtr` (i * #size INPUT_RECORD)

152
153
154
155
156
157
getKeyEvent :: Ptr () -> IO InputEvent
getKeyEvent p = do
    kDown' <- (#peek KEY_EVENT_RECORD, bKeyDown) p
    repeat' <- (#peek KEY_EVENT_RECORD, wRepeatCount) p
    keyCode <- (#peek KEY_EVENT_RECORD, wVirtualKeyCode) p
    scanCode <- (#peek KEY_EVENT_RECORD, wVirtualScanCode) p
158
    char :: CWchar <- (#peek KEY_EVENT_RECORD, uChar) p
159
160
161
162
163
    state <- (#peek KEY_EVENT_RECORD, dwControlKeyState) p
    return KeyEvent {keyDown = kDown',
                            repeatCount = repeat',
                            virtualKeyCode = keyCode,
                            virtualScanCode = scanCode,
164
                            unicodeChar = toEnum (fromEnum char),
165
166
                            controlKeyState = state}

judah's avatar
judah committed
167
data Coord = Coord {coordX, coordY :: Int}
168
169
                deriving Show
                
170
#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
171
172
instance Storable Coord where
    sizeOf _ = (#size COORD)
173
    alignment _ = (#alignment COORD)
174
    peek p = do
judah's avatar
judah committed
175
176
177
        x :: CShort <- (#peek COORD, X) p
        y :: CShort <- (#peek COORD, Y) p
        return Coord {coordX = fromEnum x, coordY = fromEnum y}
178
    poke p c = do
judah's avatar
judah committed
179
180
        (#poke COORD, X) p (toEnum (coordX c) :: CShort)
        (#poke COORD, Y) p (toEnum (coordY c) :: CShort)
181
182
                
                            
judah's avatar
judah committed
183
foreign import ccall "haskeline_SetPosition"
184
185
186
187
188
189
    c_SetPosition :: HANDLE -> Ptr Coord -> IO Bool
    
setPosition :: HANDLE -> Coord -> IO ()
setPosition h c = with c $ failIfFalse_ "SetConsoleCursorPosition" 
                    . c_SetPosition h
                    
190
foreign import WINDOWS_CCONV "windows.h GetConsoleScreenBufferInfo"
191
192
193
194
195
196
197
198
199
200
201
202
    c_GetScreenBufferInfo :: HANDLE -> Ptr () -> IO Bool
    
getPosition :: HANDLE -> IO Coord
getPosition = withScreenBufferInfo $ 
    (#peek CONSOLE_SCREEN_BUFFER_INFO, dwCursorPosition)

withScreenBufferInfo :: (Ptr () -> IO a) -> HANDLE -> IO a
withScreenBufferInfo f h = allocaBytes (#size CONSOLE_SCREEN_BUFFER_INFO)
                                $ \infoPtr -> do
        failIfFalse_ "GetConsoleScreenBufferInfo"
            $ c_GetScreenBufferInfo h infoPtr
        f infoPtr
judah's avatar
judah committed
203

204
205
206
207
getBufferSize :: HANDLE -> IO Layout
getBufferSize = withScreenBufferInfo $ \p -> do
    c <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) p
    return Layout {width = coordX c, height = coordY c}
208

209
foreign import WINDOWS_CCONV "windows.h WriteConsoleW" c_WriteConsoleW
judah's avatar
judah committed
210
211
212
    :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool

writeConsole :: HANDLE -> String -> IO ()
213
214
215
-- For some reason, Wine returns False when WriteConsoleW is called on an empty
-- string.  Easiest fix: just don't call that function.
writeConsole _ "" = return ()
216
writeConsole h str = writeConsole' >> writeConsole h ys
judah's avatar
judah committed
217
  where
218
219
220
221
222
223
224
225
226
227
228
229
    (xs,ys) = splitAt limit str
    -- WriteConsoleW has a buffer limit which is documented as 32768 word8's,
    -- but bug reports from online suggest that the limit may be lower (~25000).
    -- To be safe, we pick a round number we know to be less than the limit.
    limit = 20000 -- known to be less than WriteConsoleW's buffer limit
    writeConsole'
        = withArray (map (toEnum . fromEnum) xs)
            $ \t_arr -> alloca $ \numWritten -> do
                    failIfFalse_ "WriteConsoleW"
                        $ c_WriteConsoleW h t_arr (toEnum $ length xs)
                                numWritten nullPtr
                        
230
foreign import WINDOWS_CCONV "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool
judah's avatar
judah committed
231
232
233
234

messageBeep :: IO ()
messageBeep = c_messageBeep (-1) >> return ()-- intentionally ignore failures.

235
236
237

----------
-- Console mode
238
foreign import WINDOWS_CCONV "windows.h GetConsoleMode" c_GetConsoleMode
239
240
    :: HANDLE -> Ptr DWORD -> IO Bool

241
foreign import WINDOWS_CCONV "windows.h SetConsoleMode" c_SetConsoleMode
242
243
    :: HANDLE -> DWORD -> IO Bool

244
245
246
withWindowMode :: MonadException m => Handles -> m a -> m a
withWindowMode hs f = do
    let h = hIn hs
247
248
249
250
251
252
253
254
    bracket (getConsoleMode h) (setConsoleMode h)
            $ \m -> setConsoleMode h (m .|. (#const ENABLE_WINDOW_INPUT)) >> f
  where
    getConsoleMode h = liftIO $ alloca $ \p -> do
            failIfFalse_ "GetConsoleMode" $ c_GetConsoleMode h p
            peek p
    setConsoleMode h m = liftIO $ failIfFalse_ "SetConsoleMode" $ c_SetConsoleMode h m

judah's avatar
judah committed
255
256
257
----------------------------
-- Drawing

258
259
260
261
262
263
data Handles = Handles { hIn, hOut :: HANDLE }

closeHandles :: Handles -> IO ()
closeHandles hs = closeHandle (hIn hs) >> closeHandle (hOut hs)

newtype Draw m a = Draw {runDraw :: ReaderT Handles m a}
264
    deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadReader Handles)
judah's avatar
judah committed
265

266
type DrawM a = forall m . (MonadIO m, MonadReader Layout m) => Draw m a
267

268
instance MonadTrans Draw where
269
    lift = Draw . lift
270

judah's avatar
judah committed
271
getPos :: MonadIO m => Draw m Coord
272
getPos = asks hOut >>= liftIO . getPosition
judah's avatar
judah committed
273
    
274
setPos :: Coord -> DrawM ()
275
setPos c = do
276
    h <- asks hOut
277
278
279
280
281
282
283
    -- SetPosition will fail if you give it something out of bounds of
    -- the window buffer (i.e., the input line doesn't fit in the window).
    -- So we do a simple guard against that uncommon case.
    -- However, we don't throw away the x coord since it produces sensible
    -- results for some cases.
    maxY <- liftM (subtract 1) $ asks height
    liftIO $ setPosition h c { coordY = max 0 $ min maxY $ coordY c }
judah's avatar
judah committed
284

285
printText :: MonadIO m => String -> Draw m ()
judah's avatar
judah committed
286
printText txt = do
287
    h <- asks hOut
judah's avatar
judah committed
288
    liftIO (writeConsole h txt)
judah's avatar
judah committed
289
    
judah's avatar
judah committed
290
291
292
293
294
295
296
297
298
printAfter :: [Grapheme] -> DrawM ()
printAfter gs = do
    -- NOTE: you may be tempted to write
    -- do {p <- getPos; printText (...); setPos p}
    -- Unfortunately, that would be WRONG, because if printText wraps
    -- a line at the bottom of the window, causing the window to scroll,
    -- then the old value of p will be incorrect.
    printText (graphemesToString gs)
    movePosLeft gs
judah's avatar
judah committed
299
    
300
drawLineDiffWin :: LineChars -> LineChars -> DrawM ()
301
302
drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of
    ([],[])     | ys1 == ys2            -> return ()
judah's avatar
judah committed
303
304
    (xs1',[])   | xs1' ++ ys1 == ys2    -> movePosLeft xs1'
    ([],xs2')   | ys1 == xs2' ++ ys2    -> movePosRight xs2'
305
    (xs1',xs2')                         -> do
judah's avatar
judah committed
306
307
        movePosLeft xs1'
        let m = gsWidth xs1' + gsWidth ys1 - (gsWidth xs2' + gsWidth ys2)
judah's avatar
judah committed
308
        let deadText = stringToGraphemes $ replicate m ' '
309
        printText (graphemesToString xs2')
judah's avatar
judah committed
310
        printAfter (ys2 ++ deadText)
judah's avatar
judah committed
311

judah's avatar
judah committed
312
313
314
movePosRight, movePosLeft :: [Grapheme] -> DrawM ()
movePosRight str = do
    p <- getPos
judah's avatar
judah committed
315
    w <- asks width
judah's avatar
judah committed
316
317
318
319
    setPos $ moveCoord w p str
  where
    moveCoord _ p [] = p
    moveCoord w p cs = case splitAtWidth (w - coordX p) cs of
320
321
                        (_,[],len) | len < w - coordX p -- stayed on same line
                            -> Coord { coordY = coordY p,
judah's avatar
judah committed
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
                                       coordX = coordX p + len
                                     }
                        (_,cs',_) -- moved to next line
                            -> moveCoord w Coord {
                                            coordY = coordY p + 1,
                                            coordX = 0
                                           } cs'

movePosLeft str = do
    p <- getPos
    w <- asks width
    setPos $ moveCoord w p str
  where
    moveCoord _ p [] = p
    moveCoord w p cs = case splitAtWidth (coordX p) cs of
                        (_,[],len) -- stayed on same line
                            -> Coord { coordY = coordY p,
                                       coordX = coordX p - len
                                     }
341
                        (_,_:cs',_) -- moved to previous line
judah's avatar
judah committed
342
343
344
345
                            -> moveCoord w Coord {
                                            coordY = coordY p - 1,
                                            coordX = w-1
                                           } cs'
judah's avatar
judah committed
346

347
crlf :: String
judah's avatar
judah committed
348
349
crlf = "\r\n"

350
instance (MonadException m, MonadReader Layout m) => Term (Draw m) where
351
352
353
    drawLineDiff (xs1,ys1) (xs2,ys2) = let
        fixEsc = filter ((/= '\ESC') . baseChar)
        in drawLineDiffWin (fixEsc xs1, fixEsc ys1) (fixEsc xs2, fixEsc ys2)
354
355
356
357
    -- TODO now that we capture resize events.
    -- first, looks like the cursor stays on the same line but jumps
    -- to the beginning if cut off.
    reposition _ _ = return ()
358

359
360
361
    printLines [] = return ()
    printLines ls = printText $ intercalate crlf ls ++ crlf
    
362
    clearLayout = clearScreen
363
364
    
    moveToNextLine s = do
judah's avatar
judah committed
365
        movePosRight (snd s)
366
        printText "\r\n" -- make the console take care of creating a new line
367
    
judah's avatar
judah committed
368
    ringBell True = liftIO messageBeep
369
    ringBell False = return () -- TODO
370

371
372
373
374
375
win32TermStdin :: MaybeT IO RunTerm
win32TermStdin = do
    liftIO (hIsTerminalDevice stdin) >>= guard
    win32Term

376
win32Term :: MaybeT IO RunTerm
377
win32Term = do
378
    hs <- consoleHandles
379
380
381
    ch <- liftIO newChan
    fileRT <- liftIO $ fileRunTerm stdin
    return fileRT {
judah's avatar
judah committed
382
                            termOps = Left TermOps {
383
384
385
                                getLayout = getBufferSize (hOut hs)
                                , withGetEvent = withWindowMode hs
                                                    . win32WithEvent hs ch
386
                                , saveUnusedKeys = saveKeys ch
387
388
                                , evalTerm = EvalTerm (runReaderT' hs . runDraw)
                                                    (Draw . lift)
389
                                },
390
                            closeTerm = closeHandles hs
judah's avatar
judah committed
391
                        }
392

393
394
395
win32WithEvent :: MonadException m => Handles -> Chan Event
                                        -> (m Event -> m a) -> m a
win32WithEvent h eventChan f = f $ liftIO $ getEvent (hIn h) eventChan
396
397

-- stdin is not a terminal, but we still need to check the right way to output unicode to stdout.
judah's avatar
judah committed
398
399
fileRunTerm :: Handle -> IO RunTerm
fileRunTerm h_in = do
400
    putter <- putOut
401
    cp <- getCodePage
judah's avatar
judah committed
402
    return RunTerm {
403
404
                    closeTerm = return (),
                    putStrOut = putter,
judah's avatar
judah committed
405
                    wrapInterrupt = withCtrlCHandler,
406
407
408
409
410
411
                    termOps = Right FileOps
                                { inputHandle = h_in
                                , wrapFileInput = hWithBinaryMode h_in
                                , getLocaleChar = getMultiByteChar cp h_in
                                , maybeReadNewline = hMaybeReadNewline h_in
                                , getLocaleLine = hGetLocaleLine h_in
412
                                            >>= liftIO . codePageToUnicode cp
413
                                }
judah's avatar
judah committed
414
415

                    }
416
417
418
419
420
421
422
423
424
425

-- On Windows, Unicode written to the console must be written with the WriteConsole API call.
-- And to make the API cross-platform consistent, Unicode to a file should be UTF-8.
putOut :: IO (String -> IO ())
putOut = do
    outIsTerm <- hIsTerminalDevice stdout
    if outIsTerm
        then do
            h <- getStdHandle sTD_OUTPUT_HANDLE
            return (writeConsole h)
426
427
428
        else do
            cp <- getCodePage
            return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout
judah's avatar
judah committed
429
430


judah's avatar
judah committed
431
432
433
434
type Handler = DWORD -> IO BOOL

foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler)

ian@well-typed.com's avatar
ian@well-typed.com committed
435
foreign import WINDOWS_CCONV "windows.h SetConsoleCtrlHandler" c_SetConsoleCtrlHandler
judah's avatar
judah committed
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
    :: FunPtr Handler -> BOOL -> IO BOOL

-- sets the tv to True when ctrl-c is pressed.
withCtrlCHandler :: MonadException m => m a -> m a
withCtrlCHandler f = bracket (liftIO $ do
                                    tid <- myThreadId
                                    fp <- wrapHandler (handler tid)
                                -- don't fail if we can't set the ctrl-c handler
                                -- for example, we might not be attached to a console?
                                    _ <- c_SetConsoleCtrlHandler fp True
                                    return fp)
                                (\fp -> liftIO $ c_SetConsoleCtrlHandler fp False)
                                (const f)
  where
    handler tid (#const CTRL_C_EVENT) = do
        throwTo tid Interrupt
        return True
    handler _ _ = return False


judah's avatar
judah committed
456

457
458
459
------------------------
-- Multi-byte conversion

460
foreign import WINDOWS_CCONV "WideCharToMultiByte" wideCharToMultiByte
461
462
463
464
465
466
467
468
469
470
471
472
473
        :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt
                -> LPCSTR -> LPBOOL -> IO CInt

unicodeToCodePage :: CodePage -> String -> IO B.ByteString
unicodeToCodePage cp wideStr = withCWStringLen wideStr $ \(wideBuff, wideLen) -> do
    -- first, ask for the length without filling the buffer.
    outSize <- wideCharToMultiByte cp 0 wideBuff (toEnum wideLen)
                    nullPtr 0 nullPtr nullPtr
    -- then, actually perform the encoding.
    createAndTrim (fromEnum outSize) $ \outBuff -> 
        fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen)
                    (castPtr outBuff) outSize nullPtr nullPtr

474
foreign import WINDOWS_CCONV "MultiByteToWideChar" multiByteToWideChar
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
        :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt

codePageToUnicode :: CodePage -> B.ByteString -> IO String
codePageToUnicode cp bs = B.useAsCStringLen bs $ \(inBuff, inLen) -> do
    -- first ask for the size without filling the buffer.
    outSize <- multiByteToWideChar cp 0 inBuff (toEnum inLen) nullPtr 0
    -- then, actually perform the decoding.
    allocaArray0 (fromEnum outSize) $ \outBuff -> do
    outSize' <- multiByteToWideChar cp 0 inBuff (toEnum inLen) outBuff outSize
    peekCWStringLen (outBuff, fromEnum outSize')
                

getCodePage :: IO CodePage
getCodePage = do
    conCP <- getConsoleCP
    if conCP > 0
        then return conCP
        else getACP
493

494
foreign import WINDOWS_CCONV "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx
495
496
        :: CodePage -> BYTE -> BOOL

497
getMultiByteChar :: CodePage -> Handle -> MaybeT IO Char
498
getMultiByteChar cp h = do
499
        b1 <- hGetByte h
judah's avatar
judah committed
500
        bs <- if c_IsDBCSLeadByteEx cp b1
501
                then hGetByte h >>= \b2 -> return [b1,b2]
judah's avatar
judah committed
502
                else return [b1]
503
        cs <- liftIO $ codePageToUnicode cp (B.pack bs)
judah's avatar
judah committed
504
        case cs of
505
            [] -> getMultiByteChar cp h
506
            (c:_) -> return c
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546

----------------------------------
-- 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