ansi-terminal 0.7 → 0.7.1
raw patch · 15 files changed
+991/−217 lines, 15 filesdep +containersPVP ok
version bump matches the API change (PVP)
Dependencies added: containers
API changes (from Hackage documentation)
+ System.Console.ANSI: cursorPosition :: ReadP (Int, Int)
+ System.Console.ANSI: getCursorPosition :: IO (Maybe (Int, Int))
+ System.Console.ANSI: getReportedCursorPosition :: IO String
+ System.Console.ANSI: hReportCursorPosition :: Handle -> IO ()
+ System.Console.ANSI: hRestoreCursor :: Handle -> IO ()
+ System.Console.ANSI: hSaveCursor :: Handle -> IO ()
+ System.Console.ANSI: reportCursorPosition :: IO ()
+ System.Console.ANSI: reportCursorPositionCode :: String
+ System.Console.ANSI: restoreCursor :: IO ()
+ System.Console.ANSI: restoreCursorCode :: String
+ System.Console.ANSI: saveCursor :: IO ()
+ System.Console.ANSI: saveCursorCode :: String
+ System.Console.ANSI.Codes: reportCursorPositionCode :: String
+ System.Console.ANSI.Codes: restoreCursorCode :: String
+ System.Console.ANSI.Codes: saveCursorCode :: String
Files
- CHANGELOG.md +6/−0
- System/Console/ANSI.hs +2/−2
- System/Console/ANSI/Codes.hs +8/−0
- System/Console/ANSI/Example.hs +73/−28
- System/Console/ANSI/Unix.hs +58/−1
- System/Console/ANSI/Windows.hs +101/−84
- System/Console/ANSI/Windows/Detect.hs +42/−9
- System/Console/ANSI/Windows/Emulator.hs +186/−45
- System/Console/ANSI/Windows/Emulator/Codes.hs +8/−0
- System/Console/ANSI/Windows/Foreign.hs +256/−2
- ansi-terminal.cabal +8/−3
- includes/Common-Include-Emulator.hs +65/−0
- includes/Common-Include-Enabled.hs +56/−0
- includes/Common-Include.hs +99/−42
- includes/Exports-Include.hs +23/−1
CHANGELOG.md view
@@ -1,6 +1,12 @@ Changes ======= +Version 0.7.1+-------------++* Allow saving, restoring, and querying the current cursor position+* Fix a couple of issues with the Reset emulation on Windows+ Version 0.7 -----------
System/Console/ANSI.hs view
@@ -25,8 +25,8 @@ -- to the supplied handle. Commands issued like this should also work as you expect on both Windows and Unix. -- -- * Strawberry: has a @String@ type and just consists of an escape code which can be added to any other bit of text--- before being output. This version of the API is often convenient to use,--- but will not work on Windows operating systems where the terminal in use+-- before being output. The use of these codes is generally discouraged+-- because they will not work on Windows operating systems where the terminal in use -- is not ANSI-enabled (such as those before Windows 10 Threshold 2). On -- versions of Windows where the terminal in use is not ANSI-enabled, these -- codes will always be the empty string, so it is possible to use them
System/Console/ANSI/Codes.hs view
@@ -25,6 +25,9 @@ -- * Directly changing cursor position , setCursorColumnCode, setCursorPositionCode + -- * Saving, restoring and reporting cursor position+ , saveCursorCode, restoreCursorCode, reportCursorPositionCode+ -- * Clearing parts of the screen , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode , clearScreenCode, clearFromCursorToLineEndCode@@ -133,6 +136,11 @@ -> Int -- ^ 0-based column to move to -> String setCursorPositionCode n m = csi [n + 1, m + 1] "H"++saveCursorCode, restoreCursorCode, reportCursorPositionCode :: String+saveCursorCode = "\ESC7"+restoreCursorCode = "\ESC8"+reportCursorPositionCode = csi [] "6n" clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String
System/Console/ANSI/Example.hs view
@@ -14,11 +14,13 @@ examples = [ cursorMovementExample , lineChangeExample , setCursorPositionExample+ , saveRestoreCursorExample , clearExample , scrollExample , sgrExample , cursorVisibilityExample , titleExample+ , getCursorPositionExample ] main :: IO ()@@ -46,25 +48,25 @@ pause -- Line One -- Line Two- + cursorUp 1 putStr " - Extras" pause -- Line One - Extras -- Line Two- + cursorBackward 2 putStr "zz" pause -- Line One - Extrzz -- Line Two- + cursorForward 2 putStr "- And More" pause -- Line One - Extrzz - And More -- Line Two- + cursorDown 1 putStr "Disconnected" pause@@ -78,13 +80,13 @@ pause -- Line One -- Line Two- + cursorUpLine 1 putStr "New Line One" pause -- New Line One -- Line Two- + cursorDownLine 1 putStr "New Line Two" pause@@ -98,25 +100,46 @@ pause -- Line One -- Line Two- + setCursorPosition 0 5 putStr "Foo" pause -- Line Foo -- Line Two- + setCursorPosition 1 5 putStr "Bar" pause -- Line Foo -- Line Bar- + setCursorColumn 1 putStr "oaf" pause -- Line Foo -- Loaf Bar +saveRestoreCursorExample :: IO ()+saveRestoreCursorExample = do+ putStr "Start sentence ..."+ pause+ -- Start sentence ...++ saveCursor+ setCursorPosition 2 3+ putStr "SPLASH!"+ pause+ -- Start sentence ...+ --+ -- SPLASH!++ restoreCursor+ putStr " end sentence, uninterrupted."+ pause+ -- Start sentence ... end sentence, uninterrupted+ --+ -- SPLASH!+ clearExample :: IO () clearExample = do putStrLn "Line One"@@ -124,50 +147,50 @@ pause -- Line One -- Line Two- + setCursorPosition 0 4 clearFromCursorToScreenEnd pause -- Line- - ++ resetScreen putStrLn "Line One" putStrLn "Line Two" pause -- Line One -- Line Two- + setCursorPosition 1 4 clearFromCursorToScreenBeginning pause -- -- Two- - ++ resetScreen putStrLn "Line One" putStrLn "Line Two" pause -- Line One -- Line Two- + setCursorPosition 0 4 clearFromCursorToLineEnd pause -- Line -- Line Two- + setCursorPosition 1 4 clearFromCursorToLineBeginning pause -- Line -- Two- + clearLine pause -- Line- + clearScreen pause --@@ -181,7 +204,7 @@ -- Line One -- Line Two -- Line Three- + scrollPageDown 2 pause --@@ -189,7 +212,7 @@ -- Line One -- Line Two -- Line Three- + scrollPageUp 3 pause -- Line Two@@ -207,7 +230,7 @@ putStrLn (show color) pause -- All the colors, 4 times in sequence- + let named_styles = [ (SetConsoleIntensity BoldIntensity, "Bold") , (SetConsoleIntensity FaintIntensity, "Faint") , (SetConsoleIntensity NormalIntensity, "Normal")@@ -228,16 +251,16 @@ putStrLn name pause -- Text describing a style displayed in that style in sequence- + setSGR [SetColor Foreground Vivid Red] setSGR [SetColor Background Vivid Blue]- + clearScreen >> setCursorPosition 0 0 setSGR [SetSwapForegroundBackground False] putStr "Red-On-Blue" pause -- Red-On-Blue- + clearScreen >> setCursorPosition 0 0 setSGR [SetSwapForegroundBackground True] putStr "Blue-On-Red"@@ -249,11 +272,11 @@ putStr "Cursor Demo" pause -- Cursor Demo|- + hideCursor pause -- Cursor Demo- + showCursor pause -- Cursor Demo|@@ -265,9 +288,31 @@ -- ~/foo/ - ansi-terminal-ex - 83x70 ------------------------------------ -- Title Demo- + setTitle "Yup, I'm a new title!" pause -- Yup, I'm a new title! - ansi-terminal-ex - 83x70 --------------------------------------------------- -- Title Demo++getCursorPositionExample :: IO ()+getCursorPositionExample = do+ putStrLn " 11111111112222222222"+ putStrLn "12345678901234567890123456789"+ putStr "Report cursor position here:"+ pause+ -- 11111111112222222222+ -- 12345678901234567890123456789+ -- Report cursor position here:|+ result <- getCursorPosition+ putStrLn " (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.\n"+ case result of+ Just (row, col) -> putStrLn $ "The cursor was at row number " +++ show row ++ " and column number " ++ show col ++ ".\n"+ Nothing -> putStrLn "Error: unable to get the cursor position\n"+ pause+ -- 11111111112222222222+ -- 12345678901234567890123456789+ -- Report cursor position here: (3rd row, 29th column) to stdin, as CSI 3 ; 29 R.+ --+ -- The cursor was at row number 3 and column number 29.
System/Console/ANSI/Unix.hs view
@@ -1,13 +1,29 @@ {-# OPTIONS_HADDOCK hide #-}+ module System.Console.ANSI.Unix (+-- This file contains code that is common to modules+-- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module+-- exports and the associated Haddock documentation. #include "Exports-Include.hs" ) where +import Control.Exception.Base (bracket) import System.Console.ANSI.Codes import System.Console.ANSI.Types-import System.IO (Handle, hIsTerminalDevice, hPutStr, stdout)+import System.IO (BufferMode (..), Handle, hFlush, hGetBuffering, hGetEcho,+ hIsTerminalDevice, hPutStr, hSetBuffering, hSetEcho, stdin, stdout)+import Text.ParserCombinators.ReadP (readP_to_S) +-- This file contains code that is common to modules System.Console.ANSI.Unix,+-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as+-- type signatures and the definition of functions specific to stdout in terms+-- of the corresponding more general functions, inclduding the related Haddock+-- documentation. #include "Common-Include.hs"+-- This file contains code that is common save that different code is required+-- in the case of the module System.Console.ANSI.Windows.Emulator (see the file+-- Common-Include-Emulator.hs in respect of the latter).+#include "Common-Include-Enabled.hs" hCursorUp h n = hPutStr h $ cursorUpCode n hCursorDown h n = hPutStr h $ cursorDownCode n@@ -20,6 +36,10 @@ hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m +hSaveCursor h = hPutStr h saveCursorCode+hRestoreCursor h = hPutStr h restoreCursorCode+hReportCursorPosition h = hPutStr h reportCursorPositionCode+ hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode hClearFromCursorToScreenBeginning h = hPutStr h clearFromCursorToScreenBeginningCode hClearScreen h = hPutStr h clearScreenCode@@ -37,3 +57,40 @@ hShowCursor h = hPutStr h showCursorCode hSetTitle h title = hPutStr h $ setTitleCode title++-- getReportedCursorPosition :: IO String+-- (See Common-Include.hs for Haddock documentation)+getReportedCursorPosition = bracket (hGetEcho stdin) (hSetEcho stdin) $ const get+ where+ get = do+ c <- getChar+ if c == '\ESC'+ then get' [c]+ else return [c] -- If the first character is not the expected+ -- \ESC then give up. This provides a modicom of+ -- protection against unexpected data in the+ -- input stream.+ get' s = do+ c <- getChar+ if c /= 'R'+ then get' (c:s) -- Continue building the list, until the expected 'R'+ -- character is obtained. Build the list in reverse+ -- order, in order to avoid O(n^2) complexity.+ else return $ reverse (c:s) -- Reverse the order of the built list.++-- getCursorPosition :: IO (Maybe (Int, Int))+-- (See Common-Include.hs for Haddock documentation)+getCursorPosition = do+ input <- bracket (hGetBuffering stdin) (hSetBuffering stdin) $ \_ -> do+ hSetBuffering stdin NoBuffering -- set no buffering (the contents of the+ -- buffer will be discarded, so this+ -- needs to be done before the cursor+ -- positon is emitted)+ reportCursorPosition+ hFlush stdout -- ensure the report cursor position code is sent to the+ -- operating system+ getReportedCursorPosition+ case readP_to_S cursorPosition input of+ [] -> return Nothing+ [((row, col),_)] -> return $ Just (row, col)+ (_:_) -> return Nothing
System/Console/ANSI/Windows.hs view
@@ -1,136 +1,146 @@ {-# OPTIONS_HADDOCK hide #-}+ module System.Console.ANSI.Windows (+-- This file contains code that is common to modules+-- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module+-- exports and the associated Haddock documentation. #include "Exports-Include.hs" ) where import System.Console.ANSI.Types import qualified System.Console.ANSI.Unix as U-import System.Console.ANSI.Windows.Detect (isANSIEnabled)+import System.Console.ANSI.Windows.Detect (ANSIEnabledStatus (..),+ ConsoleDefaultState (..), isANSIEnabled) import qualified System.Console.ANSI.Windows.Emulator as E import System.IO (Handle, hIsTerminalDevice, stdout) +-- This file contains code that is common to modules System.Console.ANSI.Unix,+-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as+-- type signatures and the definition of functions specific to stdout in terms+-- of the corresponding more general functions, inclduding the related Haddock+-- documentation. #include "Common-Include.hs"+-- This file contains code that is common save that different code is required+-- in the case of the module System.Console.ANSI.Windows.Emulator (see the file+-- Common-Include-Emulator.hs in respect of the latter).+#include "Common-Include-Enabled.hs" --- * Cursor movement by character-hCursorUp = if isANSIEnabled then U.hCursorUp else E.hCursorUp+-- | A helper function which returns the native or emulated version, depending+-- on `isANSIEnabled`.+nativeOrEmulated :: a -> a -> a+nativeOrEmulated native emulated = case isANSIEnabled of+ ANSIEnabled -> native+ NotANSIEnabled _ -> emulated -hCursorDown = if isANSIEnabled then U.hCursorDown else E.hCursorDown+-- | A helper function which returns the native or emulated version, depending+-- on `isANSIEnabled`, where the emulator uses the default console state.+nativeOrEmulatedWithDefault :: a -> (ConsoleDefaultState -> a) -> a+nativeOrEmulatedWithDefault native emulated = case isANSIEnabled of+ ANSIEnabled -> native+ NotANSIEnabled def -> emulated def -hCursorForward = if isANSIEnabled then U.hCursorForward else E.hCursorForward -hCursorBackward = if isANSIEnabled then U.hCursorBackward else E.hCursorBackward+-- * Cursor movement by character+hCursorUp = nativeOrEmulated U.hCursorUp E.hCursorUp+hCursorDown = nativeOrEmulated U.hCursorDown E.hCursorDown+hCursorForward = nativeOrEmulated U.hCursorForward E.hCursorForward+hCursorBackward = nativeOrEmulated U.hCursorBackward E.hCursorBackward cursorUpCode :: Int -> String-cursorUpCode = if isANSIEnabled then U.cursorUpCode else E.cursorUpCode+cursorUpCode = nativeOrEmulated U.cursorUpCode E.cursorUpCode cursorDownCode :: Int -> String-cursorDownCode = if isANSIEnabled then U.cursorDownCode else E.cursorDownCode+cursorDownCode = nativeOrEmulated U.cursorDownCode E.cursorDownCode cursorForwardCode :: Int -> String-cursorForwardCode = if isANSIEnabled- then U.cursorForwardCode- else E.cursorForwardCode+cursorForwardCode = nativeOrEmulated U.cursorForwardCode E.cursorForwardCode cursorBackwardCode :: Int -> String-cursorBackwardCode = if isANSIEnabled- then U.cursorBackwardCode- else E.cursorBackwardCode+cursorBackwardCode = nativeOrEmulated U.cursorBackwardCode E.cursorBackwardCode -- * Cursor movement by line-hCursorUpLine = if isANSIEnabled then U.hCursorUpLine else E.hCursorUpLine--hCursorDownLine = if isANSIEnabled then U.hCursorDownLine else E.hCursorDownLine+hCursorUpLine = nativeOrEmulated U.hCursorUpLine E.hCursorUpLine+hCursorDownLine = nativeOrEmulated U.hCursorDownLine E.hCursorDownLine cursorUpLineCode :: Int -> String-cursorUpLineCode = if isANSIEnabled- then U.cursorUpLineCode- else E.cursorUpLineCode+cursorUpLineCode = nativeOrEmulated U.cursorUpLineCode E.cursorUpLineCode cursorDownLineCode :: Int -> String-cursorDownLineCode = if isANSIEnabled- then U.cursorDownLineCode- else E.cursorDownLineCode+cursorDownLineCode = nativeOrEmulated U.cursorDownLineCode E.cursorDownLineCode -- * Directly changing cursor position-hSetCursorColumn = if isANSIEnabled- then U.hSetCursorColumn- else E.hSetCursorColumn+hSetCursorColumn = nativeOrEmulated U.hSetCursorColumn E.hSetCursorColumn setCursorColumnCode :: Int -> String-setCursorColumnCode = if isANSIEnabled- then U.setCursorColumnCode- else E.setCursorColumnCode+setCursorColumnCode = nativeOrEmulated+ U.setCursorColumnCode E.setCursorColumnCode -hSetCursorPosition = if isANSIEnabled- then U.hSetCursorPosition- else E.hSetCursorPosition+hSetCursorPosition = nativeOrEmulated U.hSetCursorPosition E.hSetCursorPosition setCursorPositionCode :: Int -> Int -> String-setCursorPositionCode = if isANSIEnabled- then U.setCursorPositionCode- else E.setCursorPositionCode+setCursorPositionCode = nativeOrEmulated+ U.setCursorPositionCode E.setCursorPositionCode --- * Clearing parts of the screen-hClearFromCursorToScreenEnd = if isANSIEnabled- then U.hClearFromCursorToScreenEnd- else E.hClearFromCursorToScreenEnd+-- * Saving, restoring and reporting cursor position+hSaveCursor = nativeOrEmulated U.hSaveCursor E.hSaveCursor+hRestoreCursor = nativeOrEmulated U.hRestoreCursor E.hRestoreCursor+hReportCursorPosition = nativeOrEmulated+ U.hReportCursorPosition E.hReportCursorPosition -hClearFromCursorToScreenBeginning = if isANSIEnabled- then U.hClearFromCursorToScreenBeginning- else E.hClearFromCursorToScreenBeginning+saveCursorCode :: String+saveCursorCode = nativeOrEmulated U.saveCursorCode E.saveCursorCode -hClearScreen = if isANSIEnabled then U.hClearScreen else E.hClearScreen+restoreCursorCode :: String+restoreCursorCode = nativeOrEmulated U.restoreCursorCode E.restoreCursorCode +reportCursorPositionCode :: String+reportCursorPositionCode = nativeOrEmulated+ U.reportCursorPositionCode E.reportCursorPositionCode++-- * Clearing parts of the screen+hClearFromCursorToScreenEnd = nativeOrEmulatedWithDefault+ U.hClearFromCursorToScreenEnd E.hClearFromCursorToScreenEnd+hClearFromCursorToScreenBeginning = nativeOrEmulatedWithDefault+ U.hClearFromCursorToScreenBeginning E.hClearFromCursorToScreenBeginning+hClearScreen = nativeOrEmulatedWithDefault U.hClearScreen E.hClearScreen+ clearFromCursorToScreenEndCode :: String-clearFromCursorToScreenEndCode = if isANSIEnabled- then U.clearFromCursorToScreenEndCode- else E.clearFromCursorToScreenEndCode+clearFromCursorToScreenEndCode = nativeOrEmulated+ U.clearFromCursorToScreenEndCode E.clearFromCursorToScreenEndCode clearFromCursorToScreenBeginningCode :: String-clearFromCursorToScreenBeginningCode =- if isANSIEnabled- then U.clearFromCursorToScreenBeginningCode- else E.clearFromCursorToScreenBeginningCode+clearFromCursorToScreenBeginningCode = nativeOrEmulated+ U.clearFromCursorToScreenBeginningCode E.clearFromCursorToScreenBeginningCode clearScreenCode :: String-clearScreenCode = if isANSIEnabled then U.clearScreenCode else E.clearScreenCode--hClearFromCursorToLineEnd = if isANSIEnabled- then U.hClearFromCursorToLineEnd- else E.hClearFromCursorToLineEnd--hClearFromCursorToLineBeginning = if isANSIEnabled- then U.hClearFromCursorToLineBeginning- else E.hClearFromCursorToLineBeginning+clearScreenCode = nativeOrEmulated U.clearScreenCode E.clearScreenCode -hClearLine = if isANSIEnabled then U.hClearLine else E.hClearLine+hClearFromCursorToLineEnd = nativeOrEmulatedWithDefault+ U.hClearFromCursorToLineEnd E.hClearFromCursorToLineEnd+hClearFromCursorToLineBeginning = nativeOrEmulatedWithDefault+ U.hClearFromCursorToLineBeginning E.hClearFromCursorToLineBeginning+hClearLine = nativeOrEmulatedWithDefault U.hClearLine E.hClearLine clearFromCursorToLineEndCode :: String-clearFromCursorToLineEndCode = if isANSIEnabled- then U.clearFromCursorToLineEndCode- else E.clearFromCursorToLineEndCode+clearFromCursorToLineEndCode = nativeOrEmulated+ U.clearFromCursorToLineEndCode E.clearFromCursorToLineEndCode clearFromCursorToLineBeginningCode :: String-clearFromCursorToLineBeginningCode = if isANSIEnabled- then U.clearFromCursorToLineBeginningCode- else E.clearFromCursorToLineBeginningCode+clearFromCursorToLineBeginningCode = nativeOrEmulated+ U.clearFromCursorToLineBeginningCode E.clearFromCursorToLineBeginningCode clearLineCode :: String-clearLineCode = if isANSIEnabled then U.clearLineCode else E.clearLineCode+clearLineCode = nativeOrEmulated U.clearLineCode E.clearLineCode -- * Scrolling the screen-hScrollPageUp = if isANSIEnabled then U.hScrollPageUp else E.hScrollPageUp-hScrollPageDown = if isANSIEnabled then U.hScrollPageDown else E.hScrollPageDown+hScrollPageUp = nativeOrEmulatedWithDefault U.hScrollPageUp E.hScrollPageUp+hScrollPageDown = nativeOrEmulatedWithDefault U.hScrollPageDown E.hScrollPageDown scrollPageUpCode :: Int -> String-scrollPageUpCode = if isANSIEnabled- then U.scrollPageUpCode- else E.scrollPageUpCode+scrollPageUpCode = nativeOrEmulated U.scrollPageUpCode E.scrollPageUpCode scrollPageDownCode :: Int -> String-scrollPageDownCode = if isANSIEnabled- then U.scrollPageDownCode- else E.scrollPageDownCode+scrollPageDownCode = nativeOrEmulated U.scrollPageDownCode E.scrollPageDownCode -- * Select Graphic Rendition mode: colors and other whizzy stuff --@@ -145,24 +155,31 @@ -- 25 SetBlinkSpeed NoBlink -- 28 SetVisible True -hSetSGR = if isANSIEnabled then U.hSetSGR else E.hSetSGR+hSetSGR = nativeOrEmulatedWithDefault U.hSetSGR E.hSetSGR setSGRCode :: [SGR] -> String-setSGRCode = if isANSIEnabled then U.setSGRCode else E.setSGRCode+setSGRCode = nativeOrEmulated U.setSGRCode E.setSGRCode -- * Cursor visibilty changes-hHideCursor = if isANSIEnabled then U.hHideCursor else E.hHideCursor--hShowCursor = if isANSIEnabled then U.hShowCursor else E.hShowCursor+hHideCursor = nativeOrEmulated U.hHideCursor E.hHideCursor+hShowCursor = nativeOrEmulated U.hShowCursor E.hShowCursor hideCursorCode :: String-hideCursorCode = if isANSIEnabled then U.hideCursorCode else E.hideCursorCode+hideCursorCode = nativeOrEmulated U.hideCursorCode E.hideCursorCode showCursorCode :: String-showCursorCode = if isANSIEnabled then U.showCursorCode else E.showCursorCode+showCursorCode = nativeOrEmulated U.showCursorCode E.showCursorCode -- * Changing the title-hSetTitle = if isANSIEnabled then U.hSetTitle else E.hSetTitle+hSetTitle = nativeOrEmulated U.hSetTitle E.hSetTitle setTitleCode :: String -> String-setTitleCode = if isANSIEnabled then U.setTitleCode else E.setTitleCode+setTitleCode = nativeOrEmulated U.setTitleCode E.setTitleCode++-- getReportedCursorPosition :: IO String+-- (See Common-Include.hs for Haddock documentation)+getReportedCursorPosition = E.getReportedCursorPosition++-- getCursorPosition :: IO (Maybe (Int, Int))+-- (See Common-Include.hs for Haddock documentation)+getCursorPosition = E.getCursorPosition
System/Console/ANSI/Windows/Detect.hs view
@@ -2,23 +2,56 @@ module System.Console.ANSI.Windows.Detect (- isANSIEnabled+ ANSIEnabledStatus (..)+, ConsoleDefaultState (..)+, isANSIEnabled ) where import Control.Exception (SomeException(..), throwIO, try)-import Data.Bits ((.|.))-import System.Console.ANSI.Windows.Foreign (ConsoleException(..), DWORD,- eNABLE_VIRTUAL_TERMINAL_PROCESSING, getConsoleMode, getStdHandle, HANDLE,- iNVALID_HANDLE_VALUE, nullHANDLE, setConsoleMode, sTD_OUTPUT_HANDLE)+import Data.Bits ((.&.), (.|.))+import System.Console.ANSI.Windows.Foreign (bACKGROUND_INTENSE_WHITE,+ ConsoleException(..), CONSOLE_SCREEN_BUFFER_INFO (..), DWORD,+ eNABLE_VIRTUAL_TERMINAL_PROCESSING, fOREGROUND_INTENSE_WHITE,+ getConsoleMode, getConsoleScreenBufferInfo, getStdHandle, HANDLE,+ iNVALID_HANDLE_VALUE, nullHANDLE, setConsoleMode, sTD_OUTPUT_HANDLE, WORD) -- 'lookupEnv' is not available until base-4.6.0.0 (GHC 7.6.1) import System.Environment.Compat (lookupEnv) import System.IO.Unsafe (unsafePerformIO) --- This function assumes that once it is first established whether or not the--- Windows console is ANSI-enabled, that will not change.+-- | The default state of the console+data ConsoleDefaultState = ConsoleDefaultState+ { defaultForegroundAttributes :: WORD -- ^ Foreground attributes+ , defaultBackgroundAttributes :: WORD -- ^ Background attributes+ } deriving (Eq, Show)++-- | The status of the console as regards it being ANSI-enabled or not+-- ANSI-enabled.+data ANSIEnabledStatus+ = ANSIEnabled -- ^ ANSI-enabled+ | NotANSIEnabled ConsoleDefaultState -- ^ Not ANSI-enabled (including the+ -- state of the console when that+ -- status was determined)+ deriving (Eq, Show)++-- | This function assumes that once it is first established whether or not the+-- Windows console is ANSI-enabled, that will not change. If the console is not+-- ANSI-enabled, the state of the console is considered to be its default state. {-# NOINLINE isANSIEnabled #-}-isANSIEnabled :: Bool-isANSIEnabled = unsafePerformIO safeIsANSIEnabled+isANSIEnabled :: ANSIEnabledStatus+isANSIEnabled = unsafePerformIO $ do+ e <- safeIsANSIEnabled+ if e+ then return ANSIEnabled+ else do+ hOut <- getValidStdHandle sTD_OUTPUT_HANDLE+ info <- getConsoleScreenBufferInfo hOut+ let attributes = csbi_attributes info+ fgAttributes = attributes .&. fOREGROUND_INTENSE_WHITE+ bgAttributes = attributes .&. bACKGROUND_INTENSE_WHITE+ consoleDefaultState = ConsoleDefaultState+ { defaultForegroundAttributes = fgAttributes+ , defaultBackgroundAttributes = bgAttributes }+ return $ NotANSIEnabled consoleDefaultState -- This function takes the following approach. If the environment variable TERM -- exists and is not set to 'dumb' or 'msys' (see below), it assumes the console
System/Console/ANSI/Windows/Emulator.hs view
@@ -1,25 +1,41 @@+{-# OPTIONS_HADDOCK hide #-}+ module System.Console.ANSI.Windows.Emulator ( #include "Exports-Include.hs" ) where import System.Console.ANSI.Types import qualified System.Console.ANSI.Unix as Unix+import System.Console.ANSI.Windows.Detect import System.Console.ANSI.Windows.Foreign import System.Console.ANSI.Windows.Emulator.Codes import System.IO+import System.IO.Unsafe (unsafePerformIO) -import Control.Exception (catchJust)+import Control.Exception (catch, catchJust, IOException)+import Control.Monad (forM_, unless) import Data.Colour (Colour) import Data.Colour.Names (black, blue, cyan, green, grey, lime, magenta, maroon, navy, olive, purple, red, silver, teal, white, yellow) import Data.Colour.SRGB (RGB (..), toSRGB) import Data.Bits+import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.List-+import Data.Maybe (mapMaybe)+import qualified Data.Map.Strict as Map+import Text.ParserCombinators.ReadP (readP_to_S) +-- This file contains code that is common to modules System.Console.ANSI.Unix,+-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as+-- type signatures and the definition of functions specific to stdout in terms+-- of the corresponding more general functions, inclduding the related Haddock+-- documentation. #include "Common-Include.hs"-+-- This file contains code that is required in the case of the module+-- System.Console.ANSI.Windows.Emulator and differs from the common code in+-- file Common-Include-Enabled.hs.+#include "Common-Include-Emulator.hs" withHandle :: Handle -> (HANDLE -> IO a) -> IO a withHandle handle action = do@@ -72,70 +88,105 @@ clearChar :: WCHAR clearChar = charToWCHAR ' ' -clearAttribute :: WORD-clearAttribute = 0+-- | The 'clear' attribute is equated with the default background attributes.+clearAttribute :: ConsoleDefaultState -> WORD+clearAttribute = defaultBackgroundAttributes -hClearScreenFraction :: HANDLE -> (SMALL_RECT -> COORD -> (DWORD, COORD)) -> IO ()-hClearScreenFraction handle fraction_finder = do+hClearScreenFraction+ :: ConsoleDefaultState+ -> HANDLE+ -> (SMALL_RECT -> COORD -> (SHORT, SHORT, SHORT, SHORT, SHORT, SHORT))+ -> IO ()+hClearScreenFraction cds handle fraction_finder = do screen_buffer_info <- getConsoleScreenBufferInfo handle let window = csbi_window screen_buffer_info cursor_pos = csbi_cursor_position screen_buffer_info- (fill_length, fill_cursor_pos) = fraction_finder window cursor_pos-- fillConsoleOutputCharacter handle clearChar fill_length fill_cursor_pos- fillConsoleOutputAttribute handle clearAttribute fill_length fill_cursor_pos- return ()+ (left, top, right, bottom, start_x, end_x)+ = fraction_finder window cursor_pos+ mapM_ (fill_line left top right bottom start_x end_x) [top .. bottom]+ where+ fill_line left top right bottom start_x end_x y = do+ let left' = if y == top then start_x else left+ right' = if y == bottom then end_x else right+ fill_cursor_pos = COORD left' y+ fill_length = fromIntegral $ right' - left' + 1+ fillConsoleOutputCharacter handle clearChar fill_length fill_cursor_pos+ fillConsoleOutputAttribute handle (clearAttribute cds) fill_length fill_cursor_pos -hClearFromCursorToScreenEnd h = emulatorFallback (Unix.hClearFromCursorToScreenEnd h) $ withHandle h $ \handle -> hClearScreenFraction handle go+hClearFromCursorToScreenEnd cds h+ = emulatorFallback (Unix.hClearFromCursorToScreenEnd h) $ withHandle h $+ \handle -> hClearScreenFraction cds handle go where- go window cursor_pos = (fromIntegral fill_length, cursor_pos)+ go window cursor_pos = (left, top, right, bottom, start_x, right) where- size_x = rect_width window- size_y = rect_bottom window - coord_y cursor_pos- line_remainder = size_x - coord_x cursor_pos- fill_length = size_x * size_y + line_remainder+ SMALL_RECT (COORD left _) (COORD right bottom) = window+ COORD start_x top = cursor_pos -hClearFromCursorToScreenBeginning h = emulatorFallback (Unix.hClearFromCursorToScreenBeginning h) $ withHandle h $ \handle -> hClearScreenFraction handle go+hClearFromCursorToScreenBeginning cds h+ = emulatorFallback (Unix.hClearFromCursorToScreenBeginning h) $ withHandle h $+ \handle -> hClearScreenFraction cds handle go where- go window cursor_pos = (fromIntegral fill_length, rect_top_left window)+ go window cursor_pos = (left, top, right, bottom, left, end_x) where- size_x = rect_width window- size_y = coord_y cursor_pos - rect_top window- line_remainder = coord_x cursor_pos- fill_length = size_x * size_y + line_remainder+ SMALL_RECT (COORD left top) (COORD right _) = window+ COORD end_x bottom = cursor_pos -hClearScreen h = emulatorFallback (Unix.hClearScreen h) $ withHandle h $ \handle -> hClearScreenFraction handle go+hClearScreen cds h+ = emulatorFallback (Unix.hClearScreen h) $ withHandle h $+ \handle -> hClearScreenFraction cds handle go where- go window _ = (fromIntegral fill_length, rect_top_left window)+ go window _ = (left, top, right, bottom, left, right) where- size_x = rect_width window- size_y = rect_height window- fill_length = size_x * size_y+ SMALL_RECT (COORD left top) (COORD right bottom) = window -hClearFromCursorToLineEnd h = emulatorFallback (Unix.hClearFromCursorToLineEnd h) $ withHandle h $ \handle -> hClearScreenFraction handle go+hClearFromCursorToLineEnd cds h+ = emulatorFallback (Unix.hClearFromCursorToLineEnd h) $ withHandle h $+ \handle -> hClearScreenFraction cds handle go where- go window cursor_pos = (fromIntegral (rect_right window - coord_x cursor_pos), cursor_pos)+ go window cursor_pos = (left, y, right, y, start_x, right)+ where+ SMALL_RECT (COORD left _) (COORD right _) = window+ COORD start_x y = cursor_pos -hClearFromCursorToLineBeginning h = emulatorFallback (Unix.hClearFromCursorToLineBeginning h) $ withHandle h $ \handle -> hClearScreenFraction handle go+hClearFromCursorToLineBeginning cds h+ = emulatorFallback (Unix.hClearFromCursorToLineBeginning h) $ withHandle h $+ \handle -> hClearScreenFraction cds handle go where- go window cursor_pos = (fromIntegral (coord_x cursor_pos), cursor_pos { coord_x = rect_left window })+ go window cursor_pos = (left, y, right, y, left, end_x)+ where+ SMALL_RECT (COORD left _) (COORD right _) = window+ COORD end_x y = cursor_pos -hClearLine h = emulatorFallback (Unix.hClearLine h) $ withHandle h $ \handle -> hClearScreenFraction handle go+hClearLine cds h+ = emulatorFallback (Unix.hClearLine h) $ withHandle h $+ \handle -> hClearScreenFraction cds handle go where- go window cursor_pos = (fromIntegral (rect_width window), cursor_pos { coord_x = rect_left window })+ go window cursor_pos = (left, y, right, y, left, right)+ where+ SMALL_RECT (COORD left _) (COORD right _) = window+ COORD _ y = cursor_pos -hScrollPage :: HANDLE -> Int -> IO ()-hScrollPage handle new_origin_y = do+hScrollPage+ :: ConsoleDefaultState -- ^ The default console state+ -> HANDLE+ -> Int+ -> IO ()+hScrollPage cds handle new_origin_y = do screen_buffer_info <- getConsoleScreenBufferInfo handle- let fill = CHAR_INFO clearChar clearAttribute+ let fill = CHAR_INFO clearChar (clearAttribute cds) window = csbi_window screen_buffer_info origin = COORD (rect_left window) (rect_top window + fromIntegral new_origin_y) scrollConsoleScreenBuffer handle window Nothing origin fill -hScrollPageUp h n = emulatorFallback (Unix.hScrollPageUp h n) $ withHandle h $ \handle -> hScrollPage handle (negate n)-hScrollPageDown h n = emulatorFallback (Unix.hScrollPageDown h n) $ withHandle h $ \handle -> hScrollPage handle n+hScrollPageUp cds h n+ = emulatorFallback (Unix.hScrollPageUp h n) $ withHandle h $+ \handle -> hScrollPage cds handle (negate n) +hScrollPageDown cds h n+ = emulatorFallback (Unix.hScrollPageDown h n) $ withHandle h $+ \handle -> hScrollPage cds handle n+ {-# INLINE applyANSIColorToAttribute #-} applyANSIColorToAttribute :: WORD -> WORD -> WORD -> Color -> WORD -> WORD applyANSIColorToAttribute rED gREEN bLUE color attribute = case color of@@ -164,9 +215,9 @@ foreground_attribute' = background_attribute `shiftR` 4 background_attribute' = foreground_attribute `shiftL` 4 -applyANSISGRToAttribute :: SGR -> WORD -> WORD-applyANSISGRToAttribute sgr attribute = case sgr of- Reset -> fOREGROUND_WHITE+applyANSISGRToAttribute :: WORD -> SGR -> WORD -> WORD+applyANSISGRToAttribute def sgr attribute = case sgr of+ Reset -> def SetConsoleIntensity intensity -> case intensity of BoldIntensity -> attribute .|. iNTENSITY FaintIntensity -> attribute .&. (complement iNTENSITY) -- Not supported@@ -206,10 +257,12 @@ where iNTENSITY = fOREGROUND_INTENSITY -hSetSGR h sgr = emulatorFallback (Unix.hSetSGR h sgr) $ withHandle h $ \handle -> do+hSetSGR cds h sgr = emulatorFallback (Unix.hSetSGR h sgr) $ withHandle h $ \handle -> do screen_buffer_info <- getConsoleScreenBufferInfo handle let attribute = csbi_attributes screen_buffer_info- attribute' = foldl' (flip applyANSISGRToAttribute) attribute+ def = defaultForegroundAttributes cds+ .|. defaultBackgroundAttributes cds+ attribute' = foldl' (flip $ applyANSISGRToAttribute def) attribute -- make [] equivalent to [Reset], as documented (if null sgr then [Reset] else sgr) setConsoleTextAttribute handle attribute'@@ -227,6 +280,44 @@ -- over e.g. a network link... but that's not really what I'm designing for. hSetTitle h title = emulatorFallback (Unix.hSetTitle h title) $ withTString title $ setConsoleTitle +cursorPositionRef :: IORef (Map.Map HANDLE COORD)+{-# NOINLINE cursorPositionRef #-}+cursorPositionRef = unsafePerformIO $ newIORef Map.empty++hSaveCursor h = emulatorFallback (Unix.hSaveCursor h) $ withHandle h $ \handle -> do+ screen_buffer_info <- getConsoleScreenBufferInfo handle+ m <- readIORef cursorPositionRef+ writeIORef cursorPositionRef+ (Map.insert handle (csbi_cursor_position screen_buffer_info) m)++hRestoreCursor h = emulatorFallback (Unix.hRestoreCursor h) $ withHandle h $ \handle -> do+ m <- readIORef cursorPositionRef+ let result = Map.lookup handle m+ forM_ result (setConsoleCursorPosition handle)++hReportCursorPosition h = emulatorFallback (Unix.hReportCursorPosition h) $ withHandle h $ \handle -> do+ result <- getConsoleScreenBufferInfo handle+ let (COORD cx cy) = csbi_cursor_position result+ window = csbi_window result+ x = cx - rect_left window + 1+ y = cy - rect_top window + 1+ hIn <- getStdHandle sTD_INPUT_HANDLE+ _ <- writeConsoleInput hIn $ keyPresses $+ "\ESC[" ++ show y ++ ";" ++ show x ++ "R"+ return ()++keyPress :: Char -> [INPUT_RECORD]+keyPress c = [keyDown, keyUp]+ where+ keyDown = key True+ keyUp = key False+ c' = UnicodeAsciiChar $ charToWCHAR c+ key isDown = INPUT_RECORD kEY_EVENT $+ InputKeyEvent (KEY_EVENT_RECORD isDown 1 0 0 c' 0)++keyPresses :: String -> [INPUT_RECORD]+keyPresses = concatMap keyPress+ aNSIColors :: [((ColorIntensity, Color), Colour Float)] aNSIColors = [ ((Dull, Black), black) , ((Dull, Blue), navy)@@ -255,3 +346,53 @@ dg = g' - g db = b' - b in dr * dr + dg * dg + db * db++-- getReportedCursorPosition :: IO String+-- (See Common-Include.hs for Haddock documentation)+getReportedCursorPosition = catch getReportedCursorPosition' getCPExceptionHandler+ where+ getReportedCursorPosition' = withHandleToHANDLE stdin action+ where+ action hdl = do+ n <- getNumberOfConsoleInputEvents hdl+ if n == 0+ then return ""+ else do+ es <- readConsoleInput hdl n+ return $ stringFromInputEvents es+ stringFromInputEvents = cWcharsToChars . wCharsFromInputEvents+ wCharsFromInputEvents = mapMaybe wCharFromInputEvent+ wCharFromInputEvent e = if isKeyDownEvent+ then Just (unicodeAsciiChar $ keyEventChar keyEventRecord)+ else Nothing+ where+ eventType = inputEventType e+ InputKeyEvent keyEventRecord = inputEvent e+ isKeyDown = keyEventKeyDown keyEventRecord+ isKeyDownEvent = eventType == 1 && isKeyDown++-- getCursorPosition :: IO (Maybe (Int, Int))+-- (See Common-Include.hs for Haddock documentation)+getCursorPosition = catch getCursorPosition' getCPExceptionHandler+ where+ getCursorPosition' = do+ withHandleToHANDLE stdin flush -- Flush the console input buffer+ reportCursorPosition+ hFlush stdout -- ensure the report cursor position code is sent to the+ -- operating system+ input <- getReportedCursorPosition+ case readP_to_S cursorPosition input of+ [] -> return Nothing+ [((row, col),_)] -> return $ Just (row, col)+ (_:_) -> return Nothing+ where+ flush hdl = do+ n <- getNumberOfConsoleInputEvents hdl+ unless (n == 0) (void $ readConsoleInput hdl n)++getCPExceptionHandler :: IOException -> IO a+getCPExceptionHandler e = error msg+ where+ msg = "Error: " ++ show e ++ "\nThis error may be avoided by using a " +++ "console based on the Win32 console of the Windows API, such as " +++ "Command Prompt or PowerShell."
System/Console/ANSI/Windows/Emulator/Codes.hs view
@@ -11,6 +11,9 @@ -- * Directly changing cursor position , setCursorColumnCode, setCursorPositionCode + -- * Saving, restoring and reporting cursor position+ , saveCursorCode, restoreCursorCode, reportCursorPositionCode+ -- * Clearing parts of the screen , clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode , clearScreenCode, clearFromCursorToLineEndCode@@ -51,6 +54,11 @@ -> Int -- ^ 0-based column to move to -> String setCursorPositionCode _ _ = ""++saveCursorCode, restoreCursorCode, reportCursorPositionCode :: String+saveCursorCode = ""+restoreCursorCode = ""+reportCursorPositionCode = "" clearFromCursorToScreenEndCode, clearFromCursorToScreenBeginningCode, clearScreenCode :: String clearFromCursorToLineEndCode, clearFromCursorToLineBeginningCode, clearLineCode :: String
System/Console/ANSI/Windows/Foreign.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_HADDOCK hide #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} -- | "System.Win32.Console" is really very impoverished, so I have had to do all the FFI myself.@@ -7,8 +8,13 @@ BOOL, WORD, DWORD, WCHAR, HANDLE, iNVALID_HANDLE_VALUE, nullHANDLE, SHORT, - charToWCHAR,+ -- 'Re-exports from System.Win32.Console.Extra'+ INPUT_RECORD(..), INPUT_RECORD_EVENT(..), kEY_EVENT,+ KEY_EVENT_RECORD(..), UNICODE_ASCII_CHAR (..), writeConsoleInput,+ getNumberOfConsoleInputEvents, readConsoleInput, + charToWCHAR, cWcharsToChars,+ COORD(..), SMALL_RECT(..), rect_top, rect_bottom, rect_left, rect_right, rect_width, rect_height, CONSOLE_CURSOR_INFO(..), CONSOLE_SCREEN_BUFFER_INFO(..), CHAR_INFO(..), @@ -38,7 +44,6 @@ withTString, withHandleToHANDLE, - -- ConsoleException(..) ) where @@ -118,6 +123,7 @@ coord_x :: SHORT, coord_y :: SHORT }+ deriving (Read, Eq) instance Show COORD where show (COORD x y) = "(" ++ show x ++ ", " ++ show y ++ ")"@@ -260,6 +266,13 @@ fOREGROUND_INTENSE_WHITE = fOREGROUND_WHITE .|. fOREGROUND_INTENSITY bACKGROUND_INTENSE_WHITE = bACKGROUND_WHITE .|. bACKGROUND_INTENSITY +kEY_EVENT, mOUSE_EVENT, wINDOW_BUFFER_SIZE_EVENT, mENU_EVENT, fOCUS_EVENT :: WORD+kEY_EVENT = 1+mOUSE_EVENT = 2+wINDOW_BUFFER_SIZE_EVENT = 4+mENU_EVENT = 8+fOCUS_EVENT = 16+ foreign import WINDOWS_CCONV unsafe "windows.h GetStdHandle" getStdHandle :: DWORD -> IO HANDLE foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleScreenBufferInfo" cGetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h GetConsoleCursorInfo" cGetConsoleCursorInfo :: HANDLE -> Ptr CONSOLE_CURSOR_INFO -> IO BOOL@@ -275,6 +288,10 @@ foreign import WINDOWS_CCONV unsafe "windows.h FillConsoleOutputCharacterW" cFillConsoleOutputCharacter :: HANDLE -> TCHAR -> DWORD -> UNPACKED_COORD -> Ptr DWORD -> IO BOOL foreign import WINDOWS_CCONV unsafe "windows.h ScrollConsoleScreenBufferW" cScrollConsoleScreenBuffer :: HANDLE -> Ptr SMALL_RECT -> Ptr SMALL_RECT -> UNPACKED_COORD -> Ptr CHAR_INFO -> IO BOOL +foreign import WINDOWS_CCONV unsafe "windows.h WriteConsoleInputW" cWriteConsoleInput :: HANDLE -> Ptr INPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL+foreign import WINDOWS_CCONV unsafe "windows.h GetNumberOfConsoleInputEvents" cGetNumberOfConsoleInputEvents :: HANDLE -> Ptr DWORD -> IO BOOL+foreign import WINDOWS_CCONV unsafe "windows.h ReadConsoleInputW" cReadConsoleInput :: HANDLE -> Ptr INPUT_RECORD -> DWORD -> LPDWORD -> IO BOOL+ data ConsoleException = ConsoleException !ErrCode deriving (Show, Eq, Typeable) instance Exception ConsoleException@@ -380,3 +397,240 @@ withStablePtr :: a -> (StablePtr a -> IO b) -> IO b withStablePtr value = bracket (newStablePtr value) freeStablePtr #endif++-- The following is based on module System.Win32.Console.Extra from package+-- Win32-console, cut down for the WCHAR version of writeConsoleInput.++writeConsoleInput :: HANDLE -> [INPUT_RECORD] -> IO DWORD+writeConsoleInput hdl evs =+ writeConsoleInputWith hdl $ \act -> withArrayLen evs $ \len ptr -> act (ptr, toEnum len)++writeConsoleInputWith :: HANDLE -> InputHandler (Ptr INPUT_RECORD, DWORD) -> IO DWORD+writeConsoleInputWith hdl withBuffer =+ returnWith_ $ \ptrN ->+ withBuffer $ \(ptrBuf, len) ->+ failIfFalse_ "WriteConsoleInputW" $ cWriteConsoleInput hdl ptrBuf len ptrN++returnWith_ :: Storable a => (Ptr a -> IO b) -> IO a+returnWith_ act = alloca $ \ptr -> act ptr >> peek ptr++type InputHandler i = forall a. (i -> IO a) -> IO a++{-+typedef union _UNICODE_ASCII_CHAR {+ WCHAR UnicodeChar;+ CHAR AsciiChar;+} UNICODE_ASCII_CHAR;+-}+newtype UNICODE_ASCII_CHAR = UnicodeAsciiChar { unicodeAsciiChar :: WCHAR }+ deriving (Show, Read, Eq)++instance Storable UNICODE_ASCII_CHAR where+ sizeOf _ = 2+ alignment _ = 2+ peek ptr = UnicodeAsciiChar <$> (`peekByteOff` 0) ptr+ poke ptr val = case val of+ UnicodeAsciiChar c -> (`pokeByteOff` 0) ptr c++{-+typedef struct _KEY_EVENT_RECORD {+ BOOL bKeyDown;+ WORD wRepeatCount;+ WORD wVirtualKeyCode;+ WORD wVirtualScanCode;+ union {+ WCHAR UnicodeChar;+ CHAR AsciiChar;+ } uChar;+ DWORD dwControlKeyState;+}+#ifdef __GNUC__+/* gcc's alignment is not what win32 expects */+ PACKED+#endif+KEY_EVENT_RECORD;+-}+data KEY_EVENT_RECORD = KEY_EVENT_RECORD {+ keyEventKeyDown :: BOOL,+ keyEventRepeatCount :: WORD,+ keyEventVirtualKeyCode :: WORD,+ keyEventVirtualScanCode :: WORD,+ keyEventChar :: UNICODE_ASCII_CHAR,+ keyEventControlKeystate :: DWORD+ } deriving (Show, Read, Eq)++instance Storable KEY_EVENT_RECORD where+ sizeOf _ = 16+ alignment _ = 4+ peek ptr = KEY_EVENT_RECORD <$> (`peekByteOff` 0) ptr+ <*> (`peekByteOff` 4) ptr+ <*> (`peekByteOff` 6) ptr+ <*> (`peekByteOff` 8) ptr+ <*> (`peekByteOff` 10) ptr+ <*> (`peekByteOff` 12) ptr+ poke ptr val = do+ (`pokeByteOff` 0) ptr $ keyEventKeyDown val+ (`pokeByteOff` 4) ptr $ keyEventRepeatCount val+ (`pokeByteOff` 6) ptr $ keyEventVirtualKeyCode val+ (`pokeByteOff` 8) ptr $ keyEventVirtualScanCode val+ (`pokeByteOff` 10) ptr $ keyEventChar val+ (`pokeByteOff` 12) ptr $ keyEventControlKeystate val++{-+typedef struct _MOUSE_EVENT_RECORD {+ COORD dwMousePosition;+ DWORD dwButtonState;+ DWORD dwControlKeyState;+ DWORD dwEventFlags;+} MOUSE_EVENT_RECORD;+-}+data MOUSE_EVENT_RECORD = MOUSE_EVENT_RECORD {+ mousePosition :: COORD,+ mouseButtonState :: DWORD,+ mouseControlKeyState :: DWORD,+ mouseEventFlags :: DWORD+ } deriving (Show, Read, Eq)++instance Storable MOUSE_EVENT_RECORD where+ sizeOf _ = 16+ alignment _ = 4+ peek ptr =+ MOUSE_EVENT_RECORD <$> (`peekByteOff` 0) ptr+ <*> (`peekByteOff` 4) ptr+ <*> (`peekByteOff` 8) ptr+ <*> (`peekByteOff` 12) ptr+ poke ptr val = do+ (`pokeByteOff` 0) ptr $ mousePosition val+ (`pokeByteOff` 4) ptr $ mouseButtonState val+ (`pokeByteOff` 8) ptr $ mouseControlKeyState val+ (`pokeByteOff` 12) ptr $ mouseEventFlags val++{-+typedef struct _WINDOW_BUFFER_SIZE_RECORD {+ COORD dwSize;+} WINDOW_BUFFER_SIZE_RECORD;+-}+data WINDOW_BUFFER_SIZE_RECORD = WINDOW_BUFFER_SIZE_RECORD {+ bufSizeNew :: COORD+ } deriving (Show, Read, Eq)++instance Storable WINDOW_BUFFER_SIZE_RECORD where+ sizeOf _ = 4+ alignment _ = 4+ peek ptr = WINDOW_BUFFER_SIZE_RECORD <$> (`peekByteOff` 0) ptr+ poke ptr val = (`pokeByteOff` 0) ptr $ bufSizeNew val++{-+typedef struct _MENU_EVENT_RECORD {+ UINT dwCommandId;+} MENU_EVENT_RECORD,*PMENU_EVENT_RECORD;+-}+data MENU_EVENT_RECORD = MENU_EVENT_RECORD {+ menuCommandId :: UINT+ } deriving (Show, Read, Eq)++instance Storable MENU_EVENT_RECORD where+ sizeOf _ = 4+ alignment _ = 4+ peek ptr = MENU_EVENT_RECORD <$> (`peekByteOff` 0) ptr+ poke ptr val = (`pokeByteOff` 0) ptr $ menuCommandId val++{-+typedef struct _FOCUS_EVENT_RECORD { BOOL bSetFocus; } FOCUS_EVENT_RECORD;+-}+data FOCUS_EVENT_RECORD = FOCUS_EVENT_RECORD {+ focusSetFocus :: BOOL+ } deriving (Show, Read, Eq)++instance Storable FOCUS_EVENT_RECORD where+ sizeOf _ = 4+ alignment _ = 4+ peek ptr = FOCUS_EVENT_RECORD <$> (`peekByteOff` 0) ptr+ poke ptr val = (`pokeByteOff` 0) ptr $ focusSetFocus val++data INPUT_RECORD_EVENT+ = InputKeyEvent KEY_EVENT_RECORD+ | InputMouseEvent MOUSE_EVENT_RECORD+ | InputWindowBufferSizeEvent WINDOW_BUFFER_SIZE_RECORD+ | InputMenuEvent MENU_EVENT_RECORD+ | InputFocusEvent FOCUS_EVENT_RECORD+ deriving (Show, Read, Eq)++{-+typedef struct _INPUT_RECORD {+ WORD EventType;+ union {+ KEY_EVENT_RECORD KeyEvent;+ MOUSE_EVENT_RECORD MouseEvent;+ WINDOW_BUFFER_SIZE_RECORD WindowBufferSizeEvent;+ MENU_EVENT_RECORD MenuEvent;+ FOCUS_EVENT_RECORD FocusEvent;+ } Event;+} INPUT_RECORD,*PINPUT_RECORD;+-}+data INPUT_RECORD = INPUT_RECORD {+ inputEventType :: WORD,+ inputEvent :: INPUT_RECORD_EVENT+ } deriving (Show, Read, Eq)++instance Storable INPUT_RECORD where+ sizeOf _ = 20+ alignment _ = 4+ peek ptr = do+ evType <- (`peekByteOff` 0) ptr+ event <- case evType of+ _ | evType == kEY_EVENT+ -> InputKeyEvent <$> (`peekByteOff` 4) ptr+ _ | evType == mOUSE_EVENT+ -> InputMouseEvent <$> (`peekByteOff` 4) ptr+ _ | evType == wINDOW_BUFFER_SIZE_EVENT+ -> InputWindowBufferSizeEvent <$> (`peekByteOff` 4) ptr+ _ | evType == mENU_EVENT+ -> InputMenuEvent <$> (`peekByteOff` 4) ptr+ _ | evType == fOCUS_EVENT+ -> InputFocusEvent <$> (`peekByteOff` 4) ptr+ _ -> error $ "peek (INPUT_RECORD): Unknown event type " ++ show evType+ return $ INPUT_RECORD evType event+ poke ptr val = do+ (`pokeByteOff` 0) ptr $ inputEventType val+ case inputEvent val of+ InputKeyEvent ev -> (`pokeByteOff` 4) ptr ev+ InputMouseEvent ev -> (`pokeByteOff` 4) ptr ev+ InputWindowBufferSizeEvent ev -> (`pokeByteOff` 4) ptr ev+ InputMenuEvent ev -> (`pokeByteOff` 4) ptr ev+ InputFocusEvent ev -> (`pokeByteOff` 4) ptr ev++-- The following is based on module System.Win32.Console.Extra from package+-- Win32-console.++getNumberOfConsoleInputEvents :: HANDLE -> IO DWORD+getNumberOfConsoleInputEvents hdl =+ returnWith_ $ \ptrN ->+ failIfFalse_ "GetNumberOfConsoleInputEvents" $ cGetNumberOfConsoleInputEvents hdl ptrN++-- The following is based on module System.Win32.Console.Extra from package+-- Win32-console, cut down for the WCHAR version of readConsoleInput.++readConsoleInput :: HANDLE -> DWORD -> IO [INPUT_RECORD]+readConsoleInput hdl len = readConsoleInputWith hdl len $ \(ptr, n) -> peekArray (fromEnum n) ptr++readConsoleInputWith :: HANDLE -> DWORD -> OutputHandler (Ptr INPUT_RECORD, DWORD)+readConsoleInputWith hdl len handler =+ allocaArray (fromEnum len) $ \ptrBuf ->+ alloca $ \ptrN -> do+ failIfFalse_ "ReadConsoleInputW" $ cReadConsoleInput hdl ptrBuf len ptrN+ n <- peek ptrN+ handler (ptrBuf, n)++type OutputHandler o = forall a. (o -> IO a) -> IO a++-- Replicated from module Foreign.C.String in package base because that module+-- does not export the function.+cWcharsToChars :: [CWchar] -> [Char]+cWcharsToChars = map chr . fromUTF16 . map fromIntegral+ where+ fromUTF16 (c1:c2:wcs)+ | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff =+ ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs+ fromUTF16 (c:wcs) = c : fromUTF16 wcs+ fromUTF16 [] = []
ansi-terminal.cabal view
@@ -1,10 +1,11 @@ Name: ansi-terminal-Version: 0.7+Version: 0.7.1 Cabal-Version: >= 1.6 Category: User Interfaces Synopsis: Simple ANSI terminal support, with Windows compatibility-Description: ANSI terminal support for Haskell: allows cursor movement, screen clearing, color output, showing or hiding the cursor, and- changing the title. Works on UNIX and Windows.+Description: ANSI terminal support for Haskell: allows cursor movement,+ screen clearing, color output, showing or hiding the+ cursor, and changing the title. Works on UNIX and Windows. License: BSD3 License-File: LICENSE Author: Max Bolingbroke@@ -13,6 +14,8 @@ Build-Type: Simple Extra-Source-Files: includes/Common-Include.hs+ includes/Common-Include-Emulator.hs+ includes/Common-Include-Enabled.hs includes/Exports-Include.hs CHANGELOG.md README.md@@ -36,6 +39,7 @@ , colour if os(windows) Build-Depends: base-compat >= 0.9.1+ , containers , Win32 >= 2.0 , process Cpp-Options: -DWINDOWS@@ -68,6 +72,7 @@ if os(windows) Build-Depends: base-compat >= 0.9.1+ , containers , Win32 >= 2.0 Cpp-Options: -DWINDOWS Other-Modules: System.Console.ANSI.Windows
+ includes/Common-Include-Emulator.hs view
@@ -0,0 +1,65 @@+-- This file contains code that is required in the case of the module+-- System.Console.ANSI.Windows.Emulator and differs from the common code in+-- file Common-Include-Enabled.hs.++-- | Set the Select Graphic Rendition mode+hSetSGR+ :: ConsoleDefaultState -- ^ The default console state+ -> Handle+ -> [SGR] -- ^ Commands: these will typically be applied on top of the+ -- current console SGR mode. An empty list of commands is+ -- equivalent to the list @[Reset]@. Commands are applied left to+ -- right.+ -> IO ()++-- | Set the Select Graphic Rendition mode+setSGR+ :: ConsoleDefaultState -- ^ The default console state+ -> [SGR] -- ^ Commands: these will typically be applied on top of the+ -- current console SGR mode. An empty list of commands is+ -- equivalent to the list @[Reset]@. Commands are applied left to+ -- right.+ -> IO ()+setSGR def = hSetSGR def stdout++hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen+ :: ConsoleDefaultState -- ^ The default console state+ -> Handle+ -> IO ()++clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen+ :: ConsoleDefaultState -- ^ The default console state+ -> IO ()+clearFromCursorToScreenEnd def = hClearFromCursorToScreenEnd def stdout+clearFromCursorToScreenBeginning def+ = hClearFromCursorToScreenBeginning def stdout+clearScreen def = hClearScreen def stdout++hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine+ :: ConsoleDefaultState -- ^ The default console state+ -> Handle+ -> IO ()++clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine+ :: ConsoleDefaultState -- ^ The default console state+ -> IO ()+clearFromCursorToLineEnd def = hClearFromCursorToLineEnd def stdout+clearFromCursorToLineBeginning def = hClearFromCursorToLineBeginning def stdout+clearLine def = hClearLine def stdout++-- | Scroll the displayed information up or down the terminal: not widely+-- supported+hScrollPageUp, hScrollPageDown+ :: ConsoleDefaultState -- ^ The default console state+ -> Handle+ -> Int -- ^ Number of lines to scroll by+ -> IO ()++-- | Scroll the displayed information up or down the terminal: not widely+-- supported+scrollPageUp, scrollPageDown+ :: ConsoleDefaultState -- ^ The default console state+ -> Int -- ^ Number of lines to scroll by+ -> IO ()+scrollPageUp def = hScrollPageUp def stdout+scrollPageDown def = hScrollPageDown def stdout
+ includes/Common-Include-Enabled.hs view
@@ -0,0 +1,56 @@+-- This file contains code that is common save that different code is required+-- in the case of the module System.Console.ANSI.Windows.Emulator (see the file+-- Common-Include-Emulator.hs in respect of the latter).++-- | Set the Select Graphic Rendition mode+hSetSGR+ :: Handle+ -> [SGR] -- ^ Commands: these will typically be applied on top of the+ -- current console SGR mode. An empty list of commands is+ -- equivalent to the list @[Reset]@. Commands are applied left to+ -- right.+ -> IO ()++-- | Set the Select Graphic Rendition mode+setSGR+ :: [SGR] -- ^ Commands: these will typically be applied on top of the+ -- current console SGR mode. An empty list of commands is+ -- equivalent to the list @[Reset]@. Commands are applied left to+ -- right.+ -> IO ()+setSGR = hSetSGR stdout++hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen+ :: Handle+ -> IO ()++clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen+ :: IO ()+clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout+clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout+clearScreen = hClearScreen stdout++hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine+ :: Handle+ -> IO ()++clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine+ :: IO ()+clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout+clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout+clearLine = hClearLine stdout++-- | Scroll the displayed information up or down the terminal: not widely+-- supported+hScrollPageUp, hScrollPageDown+ :: Handle+ -> Int -- ^ Number of lines to scroll by+ -> IO ()++-- | Scroll the displayed information up or down the terminal: not widely+-- supported+scrollPageUp, scrollPageDown+ :: Int -- ^ Number of lines to scroll by+ -> IO ()+scrollPageUp = hScrollPageUp stdout+scrollPageDown = hScrollPageDown stdout
includes/Common-Include.hs view
@@ -1,13 +1,25 @@+-- This file contains code that is common to modules System.Console.ANSI.Unix,+-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as+-- type signatures and the definition of functions specific to stdout in terms+-- of the corresponding more general functions, inclduding the related Haddock+-- documentation.+ import System.Environment #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif -hCursorUp, hCursorDown, hCursorForward, hCursorBackward :: Handle- -> Int -- ^ Number of lines or characters to move- -> IO ()-cursorUp, cursorDown, cursorForward, cursorBackward :: Int -- ^ Number of lines or characters to move- -> IO ()+import Control.Monad (void)+import Data.Char (isDigit)+import Text.ParserCombinators.ReadP (char, many1, ReadP, satisfy)++hCursorUp, hCursorDown, hCursorForward, hCursorBackward+ :: Handle+ -> Int -- ^ Number of lines or characters to move+ -> IO ()+cursorUp, cursorDown, cursorForward, cursorBackward+ :: Int -- ^ Number of lines or characters to move+ -> IO () cursorUp = hCursorUp stdout cursorDown = hCursorDown stdout cursorForward = hCursorForward stdout@@ -37,45 +49,33 @@ -> IO () setCursorPosition = hSetCursorPosition stdout -hClearFromCursorToScreenEnd, hClearFromCursorToScreenBeginning, hClearScreen :: Handle- -> IO ()-clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen :: IO ()-clearFromCursorToScreenEnd = hClearFromCursorToScreenEnd stdout-clearFromCursorToScreenBeginning = hClearFromCursorToScreenBeginning stdout-clearScreen = hClearScreen stdout--hClearFromCursorToLineEnd, hClearFromCursorToLineBeginning, hClearLine :: Handle- -> IO ()-clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine :: IO ()--clearFromCursorToLineEnd = hClearFromCursorToLineEnd stdout-clearFromCursorToLineBeginning = hClearFromCursorToLineBeginning stdout-clearLine = hClearLine stdout+hSaveCursor, hRestoreCursor, hReportCursorPosition :: Handle -> IO () --- | Scroll the displayed information up or down the terminal: not widely supported-hScrollPageUp, hScrollPageDown :: Handle- -> Int -- ^ Number of lines to scroll by- -> IO ()--- | Scroll the displayed information up or down the terminal: not widely supported-scrollPageUp, scrollPageDown :: Int -- ^ Number of lines to scroll by- -> IO ()--- | Scroll the displayed information up or down the terminal: not widely supported-scrollPageUp = hScrollPageUp stdout-scrollPageDown = hScrollPageDown stdout+-- | Save the cursor position in memory. The only way to access the saved value+-- is with the 'restoreCursor' command.+saveCursor :: IO ()+-- | Restore the cursor position from memory. There will be no value saved in+-- memory until the first use of the 'saveCursor' command.+restoreCursor :: IO ()+-- | Looking for a way to get the cursors position? See+-- 'getCursorPosition'.+--+-- Emit the cursor position into the console input stream, immediately after+-- being recognised on the output stream, as:+-- @ESC [ \<cursor row> ; \<cursor column> R@+--+-- In isolation of 'getReportedCursorPosition' or 'getCursorPosition', this+-- function may be of limited use on Windows operating systems because of+-- difficulties in obtaining the data emitted into the console input stream.+-- The function 'hGetBufNonBlocking' in module "System.IO" does not work on+-- Windows. This has been attributed to the lack of non-blocking primatives in+-- the operating system (see the GHC bug report #806 at+-- <https://ghc.haskell.org/trac/ghc/ticket/806>).+reportCursorPosition :: IO () --- | Set the Select Graphic Rendition mode-hSetSGR :: Handle- -> [SGR] -- ^ Commands: these will typically be applied on top of the current console SGR mode.- -- An empty list of commands is equivalent to the list @[Reset]@. Commands are applied- -- left to right.- -> IO ()--- | Set the Select Graphic Rendition mode-setSGR :: [SGR] -- ^ Commands: these will typically be applied on top of the current console SGR mode.- -- An empty list of commands is equivalent to the list @[Reset]@. Commands are applied- -- left to right.- -> IO ()--- | Set the Select Graphic Rendition mode-setSGR = hSetSGR stdout+saveCursor = hSaveCursor stdout+restoreCursor = hRestoreCursor stdout+reportCursorPosition = hReportCursorPosition stdout hHideCursor, hShowCursor :: Handle -> IO ()@@ -105,3 +105,60 @@ where -- cannot use lookupEnv since it only appeared in GHC 7.6 isDumb = maybe False (== "dumb") . lookup "TERM" <$> getEnvironment++-- | Parses the characters emitted by 'reportCursorPosition' into the console+-- input stream. Returns the cursor row and column as a tuple.+--+-- For example, if the characters emitted by 'reportCursorPosition' are in+-- 'String' @input@ then the parser could be applied like this:+--+-- > let result = readP_to_S cursorPosition input+-- > case result of+-- > [] -> putStrLn $ "Error: could not parse " ++ show input+-- > [((row, column), _)] -> putStrLn $ "The cursor was at row " ++ show row+-- > ++ " and column" ++ show column ++ "."+-- > (_:_) -> putStrLn $ "Error: parse not unique"+--+cursorPosition :: ReadP (Int, Int)+cursorPosition = do+ void $ char '\ESC'+ void $ char '['+ row <- decimal -- A non-negative whole decimal number+ void $ char ';'+ col <- decimal -- A non-negative whole decimal number+ void $ char 'R'+ return (read row, read col)+ where+ digit = satisfy isDigit+ decimal = many1 digit++-- | Attempts to get the reported cursor position data from the console input+-- stream. The function is intended to be called immediately after+-- 'reportCursorPosition' (or related functions) have caused characters to be+-- emitted into the stream.+--+-- For example, on a Unix-like operating system:+--+-- > hSetBuffering stdin NoBuffering -- set no buffering (the contents of the+-- > -- buffer will be discarded, so this needs+-- > -- to be done before the cursor positon is+-- > -- emitted)+-- > reportCursorPosition+-- > hFlush stdout -- ensure the report cursor position code is sent to the+-- > -- operating system+-- > input <- getReportedCursorPosition+--+-- On Windows operating systems, the function is not supported on consoles, such+-- as mintty, that are not based on the Win32 console of the Windows API.+-- (Command Prompt and PowerShell are based on the Win32 console.)+getReportedCursorPosition :: IO String++-- | Attempts to get the reported cursor position, combining the functions+-- 'reportCursorPosition', 'getReportedCursorPosition' and 'cursorPosition'.+-- Returns 'Nothing' if any data emitted by 'reportCursorPosition', obtained by+-- 'getReportedCursorPosition', cannot be parsed by 'cursorPosition'.+--+-- On Windows operating systems, the function is not supported on consoles, such+-- as mintty, that are not based on the Win32 console of the Windows API.+-- (Command Prompt and PowerShell are based on the Win32 console.)+getCursorPosition :: IO (Maybe (Int, Int))
includes/Exports-Include.hs view
@@ -1,3 +1,7 @@+-- This file contains code that is common to modules+-- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module+-- exports and the associated Haddock documentation.+ -- * Basic data types module System.Console.ANSI.Types, @@ -27,6 +31,19 @@ hSetCursorPosition, setCursorPositionCode, +-- * Saving, restoring and reporting cursor position+saveCursor,+hSaveCursor,+saveCursorCode,++restoreCursor,+hRestoreCursor,+restoreCursorCode,++reportCursorPosition,+hReportCursorPosition,+reportCursorPositionCode,+ -- * Clearing parts of the screen -- | Note that these functions only clear parts of the screen. They do not move the -- cursor.@@ -59,4 +76,9 @@ setTitleCode, -- * Checking if handle supports ANSI-hSupportsANSI+hSupportsANSI,++-- * Getting the cursor position+getCursorPosition,+getReportedCursorPosition,+cursorPosition