File u_haskeline_update.patch of Package ghc
diff --git a/ghc-7.10.3.orig/libraries/haskeline/Changelog b/ghc-7.10.3/libraries/haskeline/Changelog
index 5cb7cc5..7b1f5e2 100644
--- a/ghc-7.10.3.orig/libraries/haskeline/Changelog
+++ b/ghc-7.10.3/libraries/haskeline/Changelog
@@ -1,3 +1,15 @@
+Changed in version 0.7.2.3:
+ * Fix hsc2hs-related warning on ghc-8
+ * Fix the behavior of ctrl-W in the emacs bindings
+ * Point to github instead of trac
+
+Changed in version 0.7.2.2:
+ * Fix Linux to Windows cross-compile
+ * Canonicalize AMP instances to make the code more future proof
+ * Generalize constraints for InputT instances
+ * Bump upper bounds on base and transformers
+ * Make Haskeline `-Wtabs` clean
+
Changed in version 0.7.2.1:
* Fix build on Windows.
diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Backend/Win32.hsc b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Backend/Win32.hsc
index 61c9ab2..d9c0934 100644
--- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Backend/Win32.hsc
+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Backend/Win32.hsc
@@ -1,546 +1,548 @@
-module System.Console.Haskeline.Backend.Win32(
- win32Term,
- win32TermStdin,
- fileRunTerm
- )where
-
-
-import System.IO
-import Foreign
-import Foreign.C
-import System.Win32 hiding (multiByteToWideChar)
-import Graphics.Win32.Misc(getStdHandle, sTD_OUTPUT_HANDLE)
-import Data.List(intercalate)
-import Control.Concurrent hiding (throwTo)
-import Data.Char(isPrint)
-import Data.Maybe(mapMaybe)
-import Control.Applicative
-import Control.Monad
-
-import System.Console.Haskeline.Key
-import System.Console.Haskeline.Monads hiding (Handler)
-import System.Console.Haskeline.LineState
-import System.Console.Haskeline.Term
-import System.Console.Haskeline.Backend.WCWidth
-
-import Data.ByteString.Internal (createAndTrim)
-import qualified Data.ByteString as B
-
-##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
-
-#include "win_console.h"
-
-foreign import WINDOWS_CCONV "windows.h ReadConsoleInputW" c_ReadConsoleInput
- :: HANDLE -> Ptr () -> DWORD -> Ptr DWORD -> IO Bool
-
-foreign import WINDOWS_CCONV "windows.h WaitForSingleObject" c_WaitForSingleObject
- :: HANDLE -> DWORD -> IO DWORD
-
-foreign import WINDOWS_CCONV "windows.h GetNumberOfConsoleInputEvents"
- 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
-
-getEvent :: HANDLE -> Chan Event -> IO Event
-getEvent h = keyEventLoop (eventReader h)
-
-eventReader :: HANDLE -> IO [Event]
-eventReader h = do
- 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)
- then eventReader h
- else do
- es <- readEvents h
- return $ mapMaybe processEvent es
-
-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)
- (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing
- oPEN_EXISTING 0 Nothing
-
-
-processEvent :: InputEvent -> Maybe Event
-processEvent KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc,
- controlKeyState = cstate}
- = fmap (\e -> KeyInput [Key modifier' e]) $ keyFromCode vc `mplus` simpleKeyChar
- where
- simpleKeyChar = guard (c /= '\NUL') >> return (KeyChar c)
- testMod ck = (cstate .&. ck) /= 0
- modifier' = if hasMeta modifier && hasControl modifier
- then noModifier {hasShift = hasShift modifier}
- else modifier
- 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)
- && not (isPrint c)
- }
-
-processEvent WindowEvent = Just WindowResize
-processEvent _ = Nothing
-
-keyFromCode :: WORD -> Maybe BaseKey
-keyFromCode (#const VK_BACK) = Just Backspace
-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
-keyFromCode (#const VK_HOME) = Just Home
-keyFromCode (#const VK_END) = Just End
-keyFromCode (#const VK_PRIOR) = Just PageUp
-keyFromCode (#const VK_NEXT) = Just PageDown
--- The Windows console will return '\r' when return is pressed.
-keyFromCode (#const VK_RETURN) = Just (KeyChar '\n')
--- TODO: KillLine?
--- TODO: function keys.
-keyFromCode _ = Nothing
-
-data InputEvent = KeyEvent {keyDown :: BOOL,
- repeatCount :: WORD,
- virtualKeyCode :: WORD,
- virtualScanCode :: WORD,
- unicodeChar :: Char,
- controlKeyState :: DWORD}
- -- TODO: WINDOW_BUFFER_SIZE_RECORD
- -- I cant figure out how the user generates them.
- | WindowEvent
- | OtherEvent
- deriving Show
-
-peekEvent :: Ptr () -> IO InputEvent
-peekEvent pRecord = do
- eventType :: WORD <- (#peek INPUT_RECORD, EventType) pRecord
- let eventPtr = (#ptr INPUT_RECORD, Event) pRecord
- case eventType of
- (#const KEY_EVENT) -> getKeyEvent eventPtr
- (#const WINDOW_BUFFER_SIZE_EVENT) -> return WindowEvent
- _ -> return OtherEvent
-
-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)
-
-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
- char :: CWchar <- (#peek KEY_EVENT_RECORD, uChar) p
- state <- (#peek KEY_EVENT_RECORD, dwControlKeyState) p
- return KeyEvent {keyDown = kDown',
- repeatCount = repeat',
- virtualKeyCode = keyCode,
- virtualScanCode = scanCode,
- unicodeChar = toEnum (fromEnum char),
- controlKeyState = state}
-
-data Coord = Coord {coordX, coordY :: Int}
- deriving Show
-
-#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
-instance Storable Coord where
- sizeOf _ = (#size COORD)
- alignment _ = (#alignment COORD)
- peek p = do
- x :: CShort <- (#peek COORD, X) p
- y :: CShort <- (#peek COORD, Y) p
- return Coord {coordX = fromEnum x, coordY = fromEnum y}
- poke p c = do
- (#poke COORD, X) p (toEnum (coordX c) :: CShort)
- (#poke COORD, Y) p (toEnum (coordY c) :: CShort)
-
-
-foreign import ccall "haskeline_SetPosition"
- c_SetPosition :: HANDLE -> Ptr Coord -> IO Bool
-
-setPosition :: HANDLE -> Coord -> IO ()
-setPosition h c = with c $ failIfFalse_ "SetConsoleCursorPosition"
- . c_SetPosition h
-
-foreign import WINDOWS_CCONV "windows.h GetConsoleScreenBufferInfo"
- 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
-
-getBufferSize :: HANDLE -> IO Layout
-getBufferSize = withScreenBufferInfo $ \p -> do
- c <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) p
- return Layout {width = coordX c, height = coordY c}
-
-foreign import WINDOWS_CCONV "windows.h WriteConsoleW" c_WriteConsoleW
- :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool
-
-writeConsole :: HANDLE -> String -> IO ()
--- For some reason, Wine returns False when WriteConsoleW is called on an empty
--- string. Easiest fix: just don't call that function.
-writeConsole _ "" = return ()
-writeConsole h str = writeConsole' >> writeConsole h ys
- where
- (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
-
-foreign import WINDOWS_CCONV "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool
-
-messageBeep :: IO ()
-messageBeep = c_messageBeep (-1) >> return ()-- intentionally ignore failures.
-
-
-----------
--- Console mode
-foreign import WINDOWS_CCONV "windows.h GetConsoleMode" c_GetConsoleMode
- :: HANDLE -> Ptr DWORD -> IO Bool
-
-foreign import WINDOWS_CCONV "windows.h SetConsoleMode" c_SetConsoleMode
- :: HANDLE -> DWORD -> IO Bool
-
-withWindowMode :: MonadException m => Handles -> m a -> m a
-withWindowMode hs f = do
- let h = hIn hs
- 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
-
-----------------------------
--- Drawing
-
-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}
- deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadReader Handles)
-
-type DrawM a = forall m . (MonadIO m, MonadReader Layout m) => Draw m a
-
-instance MonadTrans Draw where
- lift = Draw . lift
-
-getPos :: MonadIO m => Draw m Coord
-getPos = asks hOut >>= liftIO . getPosition
-
-setPos :: Coord -> DrawM ()
-setPos c = do
- h <- asks hOut
- -- 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 }
-
-printText :: MonadIO m => String -> Draw m ()
-printText txt = do
- h <- asks hOut
- liftIO (writeConsole h txt)
-
-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
-
-drawLineDiffWin :: LineChars -> LineChars -> DrawM ()
-drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of
- ([],[]) | ys1 == ys2 -> return ()
- (xs1',[]) | xs1' ++ ys1 == ys2 -> movePosLeft xs1'
- ([],xs2') | ys1 == xs2' ++ ys2 -> movePosRight xs2'
- (xs1',xs2') -> do
- movePosLeft xs1'
- let m = gsWidth xs1' + gsWidth ys1 - (gsWidth xs2' + gsWidth ys2)
- let deadText = stringToGraphemes $ replicate m ' '
- printText (graphemesToString xs2')
- printAfter (ys2 ++ deadText)
-
-movePosRight, movePosLeft :: [Grapheme] -> DrawM ()
-movePosRight str = do
- p <- getPos
- w <- asks width
- setPos $ moveCoord w p str
- where
- moveCoord _ p [] = p
- moveCoord w p cs = case splitAtWidth (w - coordX p) cs of
- (_,[],len) | len < w - coordX p -- stayed on same line
- -> Coord { coordY = coordY p,
- 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
- }
- (_,_:cs',_) -- moved to previous line
- -> moveCoord w Coord {
- coordY = coordY p - 1,
- coordX = w-1
- } cs'
-
-crlf :: String
-crlf = "\r\n"
-
-instance (MonadException m, MonadReader Layout m) => Term (Draw m) where
- drawLineDiff (xs1,ys1) (xs2,ys2) = let
- fixEsc = filter ((/= '\ESC') . baseChar)
- in drawLineDiffWin (fixEsc xs1, fixEsc ys1) (fixEsc xs2, fixEsc ys2)
- -- 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 ()
-
- printLines [] = return ()
- printLines ls = printText $ intercalate crlf ls ++ crlf
-
- clearLayout = clearScreen
-
- moveToNextLine s = do
- movePosRight (snd s)
- printText "\r\n" -- make the console take care of creating a new line
-
- ringBell True = liftIO messageBeep
- ringBell False = return () -- TODO
-
-win32TermStdin :: MaybeT IO RunTerm
-win32TermStdin = do
- liftIO (hIsTerminalDevice stdin) >>= guard
- win32Term
-
-win32Term :: MaybeT IO RunTerm
-win32Term = do
- hs <- consoleHandles
- ch <- liftIO newChan
- fileRT <- liftIO $ fileRunTerm stdin
- return fileRT {
- termOps = Left TermOps {
- getLayout = getBufferSize (hOut hs)
- , withGetEvent = withWindowMode hs
- . win32WithEvent hs ch
- , saveUnusedKeys = saveKeys ch
- , evalTerm = EvalTerm (runReaderT' hs . runDraw)
- (Draw . lift)
- },
- closeTerm = closeHandles hs
- }
-
-win32WithEvent :: MonadException m => Handles -> Chan Event
- -> (m Event -> m a) -> m a
-win32WithEvent h eventChan f = f $ liftIO $ getEvent (hIn h) eventChan
-
--- stdin is not a terminal, but we still need to check the right way to output unicode to stdout.
-fileRunTerm :: Handle -> IO RunTerm
-fileRunTerm h_in = do
- putter <- putOut
- cp <- getCodePage
- return RunTerm {
- closeTerm = return (),
- putStrOut = putter,
- wrapInterrupt = withCtrlCHandler,
- termOps = Right FileOps
- { inputHandle = h_in
- , wrapFileInput = hWithBinaryMode h_in
- , getLocaleChar = getMultiByteChar cp h_in
- , maybeReadNewline = hMaybeReadNewline h_in
- , getLocaleLine = hGetLocaleLine h_in
- >>= liftIO . codePageToUnicode cp
- }
-
- }
-
--- 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)
- else do
- cp <- getCodePage
- return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout
-
-
-type Handler = DWORD -> IO BOOL
-
-foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler)
-
-foreign import WINDOWS_CCONV "windows.h SetConsoleCtrlHandler" c_SetConsoleCtrlHandler
- :: 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
-
-
-
-------------------------
--- Multi-byte conversion
-
-foreign import WINDOWS_CCONV "WideCharToMultiByte" wideCharToMultiByte
- :: 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
-
-foreign import WINDOWS_CCONV "MultiByteToWideChar" multiByteToWideChar
- :: 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
-
-foreign import WINDOWS_CCONV "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx
- :: CodePage -> BYTE -> BOOL
-
-getMultiByteChar :: CodePage -> Handle -> MaybeT IO Char
-getMultiByteChar cp h = do
- b1 <- hGetByte h
- bs <- if c_IsDBCSLeadByteEx cp b1
- then hGetByte h >>= \b2 -> return [b1,b2]
- else return [b1]
- cs <- liftIO $ codePageToUnicode cp (B.pack bs)
- case cs of
- [] -> getMultiByteChar cp h
- (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
-
+module System.Console.Haskeline.Backend.Win32(
+ win32Term,
+ win32TermStdin,
+ fileRunTerm
+ )where
+
+
+import System.IO
+import Foreign
+import Foreign.C
+import System.Win32 hiding (multiByteToWideChar)
+import Graphics.Win32.Misc(getStdHandle, sTD_OUTPUT_HANDLE)
+import Data.List(intercalate)
+import Control.Concurrent hiding (throwTo)
+import Data.Char(isPrint)
+import Data.Maybe(mapMaybe)
+import Control.Applicative
+import Control.Monad
+
+import System.Console.Haskeline.Key
+import System.Console.Haskeline.Monads hiding (Handler)
+import System.Console.Haskeline.LineState
+import System.Console.Haskeline.Term
+import System.Console.Haskeline.Backend.WCWidth
+
+import Data.ByteString.Internal (createAndTrim)
+import qualified Data.ByteString as B
+
+##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
+
+#include "win_console.h"
+
+foreign import WINDOWS_CCONV "windows.h ReadConsoleInputW" c_ReadConsoleInput
+ :: HANDLE -> Ptr () -> DWORD -> Ptr DWORD -> IO Bool
+
+foreign import WINDOWS_CCONV "windows.h WaitForSingleObject" c_WaitForSingleObject
+ :: HANDLE -> DWORD -> IO DWORD
+
+foreign import WINDOWS_CCONV "windows.h GetNumberOfConsoleInputEvents"
+ 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
+
+getEvent :: HANDLE -> Chan Event -> IO Event
+getEvent h = keyEventLoop (eventReader h)
+
+eventReader :: HANDLE -> IO [Event]
+eventReader h = do
+ 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)
+ then eventReader h
+ else do
+ es <- readEvents h
+ return $ mapMaybe processEvent es
+
+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)
+ (fILE_SHARE_READ .|. fILE_SHARE_WRITE) Nothing
+ oPEN_EXISTING 0 Nothing
+
+
+processEvent :: InputEvent -> Maybe Event
+processEvent KeyEvent {keyDown = True, unicodeChar = c, virtualKeyCode = vc,
+ controlKeyState = cstate}
+ = fmap (\e -> KeyInput [Key modifier' e]) $ keyFromCode vc `mplus` simpleKeyChar
+ where
+ simpleKeyChar = guard (c /= '\NUL') >> return (KeyChar c)
+ testMod ck = (cstate .&. ck) /= 0
+ modifier' = if hasMeta modifier && hasControl modifier
+ then noModifier {hasShift = hasShift modifier}
+ else modifier
+ 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)
+ && not (isPrint c)
+ }
+
+processEvent WindowEvent = Just WindowResize
+processEvent _ = Nothing
+
+keyFromCode :: WORD -> Maybe BaseKey
+keyFromCode (#const VK_BACK) = Just Backspace
+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
+keyFromCode (#const VK_HOME) = Just Home
+keyFromCode (#const VK_END) = Just End
+keyFromCode (#const VK_PRIOR) = Just PageUp
+keyFromCode (#const VK_NEXT) = Just PageDown
+-- The Windows console will return '\r' when return is pressed.
+keyFromCode (#const VK_RETURN) = Just (KeyChar '\n')
+-- TODO: KillLine?
+-- TODO: function keys.
+keyFromCode _ = Nothing
+
+data InputEvent = KeyEvent {keyDown :: BOOL,
+ repeatCount :: WORD,
+ virtualKeyCode :: WORD,
+ virtualScanCode :: WORD,
+ unicodeChar :: Char,
+ controlKeyState :: DWORD}
+ -- TODO: WINDOW_BUFFER_SIZE_RECORD
+ -- I cant figure out how the user generates them.
+ | WindowEvent
+ | OtherEvent
+ deriving Show
+
+peekEvent :: Ptr () -> IO InputEvent
+peekEvent pRecord = do
+ eventType :: WORD <- (#peek INPUT_RECORD, EventType) pRecord
+ let eventPtr = (#ptr INPUT_RECORD, Event) pRecord
+ case eventType of
+ (#const KEY_EVENT) -> getKeyEvent eventPtr
+ (#const WINDOW_BUFFER_SIZE_EVENT) -> return WindowEvent
+ _ -> return OtherEvent
+
+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)
+
+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
+ char :: CWchar <- (#peek KEY_EVENT_RECORD, uChar) p
+ state <- (#peek KEY_EVENT_RECORD, dwControlKeyState) p
+ return KeyEvent {keyDown = kDown',
+ repeatCount = repeat',
+ virtualKeyCode = keyCode,
+ virtualScanCode = scanCode,
+ unicodeChar = toEnum (fromEnum char),
+ controlKeyState = state}
+
+data Coord = Coord {coordX, coordY :: Int}
+ deriving Show
+
+#if __GLASGOW_HASKELL__ < 711
+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
+#endif
+instance Storable Coord where
+ sizeOf _ = (#size COORD)
+ alignment _ = (#alignment COORD)
+ peek p = do
+ x :: CShort <- (#peek COORD, X) p
+ y :: CShort <- (#peek COORD, Y) p
+ return Coord {coordX = fromEnum x, coordY = fromEnum y}
+ poke p c = do
+ (#poke COORD, X) p (toEnum (coordX c) :: CShort)
+ (#poke COORD, Y) p (toEnum (coordY c) :: CShort)
+
+
+foreign import ccall "haskeline_SetPosition"
+ c_SetPosition :: HANDLE -> Ptr Coord -> IO Bool
+
+setPosition :: HANDLE -> Coord -> IO ()
+setPosition h c = with c $ failIfFalse_ "SetConsoleCursorPosition"
+ . c_SetPosition h
+
+foreign import WINDOWS_CCONV "windows.h GetConsoleScreenBufferInfo"
+ 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
+
+getBufferSize :: HANDLE -> IO Layout
+getBufferSize = withScreenBufferInfo $ \p -> do
+ c <- (#peek CONSOLE_SCREEN_BUFFER_INFO, dwSize) p
+ return Layout {width = coordX c, height = coordY c}
+
+foreign import WINDOWS_CCONV "windows.h WriteConsoleW" c_WriteConsoleW
+ :: HANDLE -> Ptr TCHAR -> DWORD -> Ptr DWORD -> Ptr () -> IO Bool
+
+writeConsole :: HANDLE -> String -> IO ()
+-- For some reason, Wine returns False when WriteConsoleW is called on an empty
+-- string. Easiest fix: just don't call that function.
+writeConsole _ "" = return ()
+writeConsole h str = writeConsole' >> writeConsole h ys
+ where
+ (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
+
+foreign import WINDOWS_CCONV "windows.h MessageBeep" c_messageBeep :: UINT -> IO Bool
+
+messageBeep :: IO ()
+messageBeep = c_messageBeep (-1) >> return ()-- intentionally ignore failures.
+
+
+----------
+-- Console mode
+foreign import WINDOWS_CCONV "windows.h GetConsoleMode" c_GetConsoleMode
+ :: HANDLE -> Ptr DWORD -> IO Bool
+
+foreign import WINDOWS_CCONV "windows.h SetConsoleMode" c_SetConsoleMode
+ :: HANDLE -> DWORD -> IO Bool
+
+withWindowMode :: MonadException m => Handles -> m a -> m a
+withWindowMode hs f = do
+ let h = hIn hs
+ 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
+
+----------------------------
+-- Drawing
+
+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}
+ deriving (Functor, Applicative, Monad, MonadIO, MonadException, MonadReader Handles)
+
+type DrawM a = forall m . (MonadIO m, MonadReader Layout m) => Draw m a
+
+instance MonadTrans Draw where
+ lift = Draw . lift
+
+getPos :: MonadIO m => Draw m Coord
+getPos = asks hOut >>= liftIO . getPosition
+
+setPos :: Coord -> DrawM ()
+setPos c = do
+ h <- asks hOut
+ -- 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 }
+
+printText :: MonadIO m => String -> Draw m ()
+printText txt = do
+ h <- asks hOut
+ liftIO (writeConsole h txt)
+
+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
+
+drawLineDiffWin :: LineChars -> LineChars -> DrawM ()
+drawLineDiffWin (xs1,ys1) (xs2,ys2) = case matchInit xs1 xs2 of
+ ([],[]) | ys1 == ys2 -> return ()
+ (xs1',[]) | xs1' ++ ys1 == ys2 -> movePosLeft xs1'
+ ([],xs2') | ys1 == xs2' ++ ys2 -> movePosRight xs2'
+ (xs1',xs2') -> do
+ movePosLeft xs1'
+ let m = gsWidth xs1' + gsWidth ys1 - (gsWidth xs2' + gsWidth ys2)
+ let deadText = stringToGraphemes $ replicate m ' '
+ printText (graphemesToString xs2')
+ printAfter (ys2 ++ deadText)
+
+movePosRight, movePosLeft :: [Grapheme] -> DrawM ()
+movePosRight str = do
+ p <- getPos
+ w <- asks width
+ setPos $ moveCoord w p str
+ where
+ moveCoord _ p [] = p
+ moveCoord w p cs = case splitAtWidth (w - coordX p) cs of
+ (_,[],len) | len < w - coordX p -- stayed on same line
+ -> Coord { coordY = coordY p,
+ 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
+ }
+ (_,_:cs',_) -- moved to previous line
+ -> moveCoord w Coord {
+ coordY = coordY p - 1,
+ coordX = w-1
+ } cs'
+
+crlf :: String
+crlf = "\r\n"
+
+instance (MonadException m, MonadReader Layout m) => Term (Draw m) where
+ drawLineDiff (xs1,ys1) (xs2,ys2) = let
+ fixEsc = filter ((/= '\ESC') . baseChar)
+ in drawLineDiffWin (fixEsc xs1, fixEsc ys1) (fixEsc xs2, fixEsc ys2)
+ -- 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 ()
+
+ printLines [] = return ()
+ printLines ls = printText $ intercalate crlf ls ++ crlf
+
+ clearLayout = clearScreen
+
+ moveToNextLine s = do
+ movePosRight (snd s)
+ printText "\r\n" -- make the console take care of creating a new line
+
+ ringBell True = liftIO messageBeep
+ ringBell False = return () -- TODO
+
+win32TermStdin :: MaybeT IO RunTerm
+win32TermStdin = do
+ liftIO (hIsTerminalDevice stdin) >>= guard
+ win32Term
+
+win32Term :: MaybeT IO RunTerm
+win32Term = do
+ hs <- consoleHandles
+ ch <- liftIO newChan
+ fileRT <- liftIO $ fileRunTerm stdin
+ return fileRT {
+ termOps = Left TermOps {
+ getLayout = getBufferSize (hOut hs)
+ , withGetEvent = withWindowMode hs
+ . win32WithEvent hs ch
+ , saveUnusedKeys = saveKeys ch
+ , evalTerm = EvalTerm (runReaderT' hs . runDraw)
+ (Draw . lift)
+ },
+ closeTerm = closeHandles hs
+ }
+
+win32WithEvent :: MonadException m => Handles -> Chan Event
+ -> (m Event -> m a) -> m a
+win32WithEvent h eventChan f = f $ liftIO $ getEvent (hIn h) eventChan
+
+-- stdin is not a terminal, but we still need to check the right way to output unicode to stdout.
+fileRunTerm :: Handle -> IO RunTerm
+fileRunTerm h_in = do
+ putter <- putOut
+ cp <- getCodePage
+ return RunTerm {
+ closeTerm = return (),
+ putStrOut = putter,
+ wrapInterrupt = withCtrlCHandler,
+ termOps = Right FileOps
+ { inputHandle = h_in
+ , wrapFileInput = hWithBinaryMode h_in
+ , getLocaleChar = getMultiByteChar cp h_in
+ , maybeReadNewline = hMaybeReadNewline h_in
+ , getLocaleLine = hGetLocaleLine h_in
+ >>= liftIO . codePageToUnicode cp
+ }
+
+ }
+
+-- 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)
+ else do
+ cp <- getCodePage
+ return $ \str -> unicodeToCodePage cp str >>= B.putStr >> hFlush stdout
+
+
+type Handler = DWORD -> IO BOOL
+
+foreign import ccall "wrapper" wrapHandler :: Handler -> IO (FunPtr Handler)
+
+foreign import WINDOWS_CCONV "windows.h SetConsoleCtrlHandler" c_SetConsoleCtrlHandler
+ :: 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
+
+
+
+------------------------
+-- Multi-byte conversion
+
+foreign import WINDOWS_CCONV "WideCharToMultiByte" wideCharToMultiByte
+ :: 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
+
+foreign import WINDOWS_CCONV "MultiByteToWideChar" multiByteToWideChar
+ :: 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
+
+foreign import WINDOWS_CCONV "IsDBCSLeadByteEx" c_IsDBCSLeadByteEx
+ :: CodePage -> BYTE -> BOOL
+
+getMultiByteChar :: CodePage -> Handle -> MaybeT IO Char
+getMultiByteChar cp h = do
+ b1 <- hGetByte h
+ bs <- if c_IsDBCSLeadByteEx cp b1
+ then hGetByte h >>= \b2 -> return [b1,b2]
+ else return [b1]
+ cs <- liftIO $ codePageToUnicode cp (B.pack bs)
+ case cs of
+ [] -> getMultiByteChar cp h
+ (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/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Command/Completion.hs b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Command/Completion.hs
index 97a887b..71a0f12 100644
--- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Command/Completion.hs
+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Command/Completion.hs
@@ -21,7 +21,7 @@ useCompletion im c = insertString r im
where r | isFinished c = replacement c ++ " "
| otherwise = replacement c
-askIMCompletions :: CommandMonad m =>
+askIMCompletions :: CommandMonad m =>
Command m InsertMode (InsertMode, [Completion])
askIMCompletions (IMode xs ys) = do
(rest, completions) <- lift $ runCompletion (withRev graphemesToString xs,
@@ -72,7 +72,7 @@ pagingCompletion :: MonadReader Layout m => Key -> Prefs
pagingCompletion k prefs completions = \im -> do
ls <- asks $ makeLines (map display completions)
let pageAction = do
- askFirst prefs (length completions) $
+ askFirst prefs (length completions) $
if completionPaging prefs
then printPage ls
else effect (PrintLines ls)
@@ -134,7 +134,7 @@ padWords :: Int -> [String] -> String
padWords _ [x] = x
padWords _ [] = ""
padWords len (x:xs) = x ++ replicate (len - glength x) ' '
- ++ padWords len xs
+ ++ padWords len xs
where
-- kludge: compute the length in graphemes, not chars.
-- but don't use graphemes for the max length, since I'm not convinced
@@ -159,5 +159,3 @@ splitIntoGroups n xs = transpose $ unfoldr f xs
ceilDiv :: Integral a => a -> a -> a
ceilDiv m n | m `rem` n == 0 = m `div` n
| otherwise = m `div` n + 1
-
-
diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Command.hs b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Command.hs
index 986fd42..1a0d915 100644
--- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Command.hs
+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Command.hs
@@ -66,11 +66,11 @@ instance Monad m => Functor (CmdM m) where
fmap = liftM
instance Monad m => Applicative (CmdM m) where
- pure = return
+ pure = Result
(<*>) = ap
instance Monad m => Monad (CmdM m) where
- return = Result
+ return = pure
GetKey km >>= g = GetKey $ fmap (>>= g) km
DoEffect e f >>= g = DoEffect e (f >>= g)
diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Directory.hsc b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Directory.hsc
index b2deb22..9eb0952 100644
--- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Directory.hsc
+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Directory.hsc
@@ -19,7 +19,7 @@ import qualified System.Directory
#endif
#include <windows.h>
-#include <Shlobj.h>
+#include <shlobj.h>
##if defined(i386_HOST_ARCH)
## define WINDOWS_CCONV stdcall
diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Emacs.hs b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Emacs.hs
index d5e0622..66d3297 100644
--- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Emacs.hs
+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Emacs.hs
@@ -89,7 +89,7 @@ rotatePaste im = get >>= loop
wordRight, wordLeft, bigWordLeft :: InsertMode -> InsertMode
wordRight = goRightUntil (atStart (not . isAlphaNum))
wordLeft = goLeftUntil (atStart isAlphaNum)
-bigWordLeft = goLeftUntil (atStart isSpace)
+bigWordLeft = goLeftUntil (atStart (not . isSpace))
modifyWord :: ([Grapheme] -> [Grapheme]) -> InsertMode -> InsertMode
modifyWord f im = IMode (reverse (f ys1) ++ xs) ys2
diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/InputT.hs b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/InputT.hs
index 383cf5f..c1ee55e 100644
--- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/InputT.hs
+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/InputT.hs
@@ -47,19 +47,12 @@ newtype InputT m a = InputT {unInputT ::
(ReaderT (IORef KillRing)
(ReaderT Prefs
(ReaderT (Settings m) m)))) a}
- deriving (Monad, MonadIO, MonadException)
+ deriving (Functor, Applicative, Monad, MonadIO, MonadException)
-- NOTE: we're explicitly *not* making InputT an instance of our
-- internal MonadState/MonadReader classes. Otherwise haddock
-- displays those instances to the user, and it makes it seem like
-- we implement the mtl versions of those classes.
-instance Monad m => Functor (InputT m) where
- fmap = liftM
-
-instance Monad m => Applicative (InputT m) where
- pure = return
- (<*>) = ap
-
instance MonadTrans InputT where
lift = InputT . lift . lift . lift . lift . lift
diff --git a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Monads.hs b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Monads.hs
index 6668e96..d5fc1bb 100644
--- a/ghc-7.10.3.orig/libraries/haskeline/System/Console/Haskeline/Monads.hs
+++ b/ghc-7.10.3/libraries/haskeline/System/Console/Haskeline/Monads.hs
@@ -77,11 +77,11 @@ instance Monad m => Functor (StateT s m) where
fmap = liftM
instance Monad m => Applicative (StateT s m) where
- pure = return
+ pure x = StateT $ \s -> return $ \f -> f x s
(<*>) = ap
instance Monad m => Monad (StateT s m) where
- return x = StateT $ \s -> return $ \f -> f x s
+ return = pure
StateT f >>= g = StateT $ \s -> do
useX <- f s
useX $ \x s' -> getStateTFunc (g x) s'
diff --git a/ghc-7.10.3.orig/libraries/haskeline/haskeline.cabal b/ghc-7.10.3/libraries/haskeline/haskeline.cabal
index b709ee3..35ecb26 100644
--- a/ghc-7.10.3.orig/libraries/haskeline/haskeline.cabal
+++ b/ghc-7.10.3/libraries/haskeline/haskeline.cabal
@@ -1,6 +1,6 @@
Name: haskeline
Cabal-Version: >=1.10
-Version: 0.7.2.1
+Version: 0.7.2.3
Category: User Interfaces
License: BSD3
License-File: LICENSE
@@ -16,7 +16,8 @@ Description:
Haskell programs.
.
Haskeline runs both on POSIX-compatible systems and on Windows.
-Homepage: http://trac.haskell.org/haskeline
+Homepage: https://github.com/judah/haskeline
+Bug-Reports: https://github.com/judah/haskeline/issues
Stability: Experimental
Build-Type: Custom
extra-source-files: examples/Test.hs Changelog
@@ -50,9 +51,9 @@ flag legacy-encoding
Default: False
Library
- Build-depends: base >=4.3 && < 4.9, containers>=0.4 && < 0.6,
+ Build-depends: base >=4.3 && < 4.10, containers>=0.4 && < 0.6,
directory>=1.1 && < 1.3, bytestring>=0.9 && < 0.11,
- filepath >= 1.2 && < 1.5, transformers >= 0.2 && < 0.5
+ filepath >= 1.2 && < 1.5, transformers >= 0.2 && < 0.6
Default-Language: Haskell98
Default-Extensions:
ForeignFunctionInterface, Rank2Types, FlexibleInstances,
