1#include "Common-Safe-Haskell.hs" 2{-# OPTIONS_HADDOCK hide #-} 3 4module System.Console.ANSI.Unix 5 ( 6-- This file contains code that is common to modules 7-- System.Console.ANSI.Unix and System.Console.ANSI.Windows, namely the module 8-- exports and the associated Haddock documentation. 9#include "Exports-Include.hs" 10 ) where 11 12import Data.Maybe (fromMaybe) 13import Control.Exception.Base (bracket) 14import Control.Monad (when) 15import System.IO (BufferMode (..), Handle, hGetBuffering, hGetEcho, 16 hIsTerminalDevice, hIsWritable, hPutStr, hReady, hSetBuffering, hSetEcho, 17 stdin) 18import System.Timeout (timeout) 19import Text.ParserCombinators.ReadP (readP_to_S) 20 21import System.Console.ANSI.Codes 22import System.Console.ANSI.Types 23 24-- This file contains code that is common to modules System.Console.ANSI.Unix, 25-- System.Console.ANSI.Windows and System.Console.ANSI.Windows.Emulator, such as 26-- type signatures and the definition of functions specific to stdout in terms 27-- of the corresponding more general functions, inclduding the related Haddock 28-- documentation. 29#include "Common-Include.hs" 30-- This file contains code that is common save that different code is required 31-- in the case of the module System.Console.ANSI.Windows.Emulator (see the file 32-- Common-Include-Emulator.hs in respect of the latter). 33#include "Common-Include-Enabled.hs" 34 35hCursorUp h n = hPutStr h $ cursorUpCode n 36hCursorDown h n = hPutStr h $ cursorDownCode n 37hCursorForward h n = hPutStr h $ cursorForwardCode n 38hCursorBackward h n = hPutStr h $ cursorBackwardCode n 39 40hCursorDownLine h n = hPutStr h $ cursorDownLineCode n 41hCursorUpLine h n = hPutStr h $ cursorUpLineCode n 42 43hSetCursorColumn h n = hPutStr h $ setCursorColumnCode n 44hSetCursorPosition h n m = hPutStr h $ setCursorPositionCode n m 45 46hSaveCursor h = hPutStr h saveCursorCode 47hRestoreCursor h = hPutStr h restoreCursorCode 48hReportCursorPosition h = hPutStr h reportCursorPositionCode 49 50hClearFromCursorToScreenEnd h = hPutStr h clearFromCursorToScreenEndCode 51hClearFromCursorToScreenBeginning h 52 = hPutStr h clearFromCursorToScreenBeginningCode 53hClearScreen h = hPutStr h clearScreenCode 54 55hClearFromCursorToLineEnd h = hPutStr h clearFromCursorToLineEndCode 56hClearFromCursorToLineBeginning h = hPutStr h clearFromCursorToLineBeginningCode 57hClearLine h = hPutStr h clearLineCode 58 59hScrollPageUp h n = hPutStr h $ scrollPageUpCode n 60hScrollPageDown h n = hPutStr h $ scrollPageDownCode n 61 62hSetSGR h sgrs = hPutStr h $ setSGRCode sgrs 63 64hHideCursor h = hPutStr h hideCursorCode 65hShowCursor h = hPutStr h showCursorCode 66 67hSetTitle h title = hPutStr h $ setTitleCode title 68 69-- hSupportsANSI :: Handle -> IO Bool 70-- (See Common-Include.hs for Haddock documentation) 71-- 72-- Borrowed from an HSpec patch by Simon Hengel 73-- (https://github.com/hspec/hspec/commit/d932f03317e0e2bd08c85b23903fb8616ae642bd) 74hSupportsANSI h = (&&) <$> hIsTerminalDevice h <*> isNotDumb 75 where 76 -- cannot use lookupEnv since it only appeared in GHC 7.6 77 isNotDumb = (/= Just "dumb") . lookup "TERM" <$> getEnvironment 78 79-- hSupportsANSIWithoutEmulation :: Handle -> IO (Maybe Bool) 80-- (See Common-Include.hs for Haddock documentation) 81hSupportsANSIWithoutEmulation h = 82 Just <$> ((&&) <$> hIsWritable h <*> hSupportsANSI h) 83 84-- getReportedCursorPosition :: IO String 85-- (See Common-Include.hs for Haddock documentation) 86getReportedCursorPosition = do 87 -- If, unexpectedly, no data is available on the console input stream then 88 -- the timeout will prevent the getChar blocking. For consistency with the 89 -- Windows equivalent, returns "" if the expected information is unavailable. 90 fromMaybe "" <$> timeout 500000 get -- 500 milliseconds 91 where 92 get = do 93 c <- getChar 94 if c == '\ESC' 95 then get' [c] 96 else return [c] -- If the first character is not the expected \ESC then 97 -- give up. This provides a modicom of protection against 98 -- unexpected data in the input stream. 99 get' s = do 100 c <- getChar 101 if c /= 'R' 102 then get' (c:s) -- Continue building the list, until the expected 'R' 103 -- character is obtained. Build the list in reverse order, 104 -- in order to avoid O(n^2) complexity. 105 else return $ reverse (c:s) -- Reverse the order of the built list. 106 107-- hGetCursorPosition :: Handle -> IO (Maybe (Int, Int)) 108-- (See Common-Include.hs for Haddock documentation) 109hGetCursorPosition h = fmap to0base <$> getCursorPosition' 110 where 111 to0base (row, col) = (row - 1, col - 1) 112 getCursorPosition' = do 113 input <- bracket (hGetBuffering stdin) (hSetBuffering stdin) $ \_ -> do 114 -- set no buffering (if 'no buffering' is not already set, the contents of 115 -- the buffer will be discarded, so this needs to be done before the 116 -- cursor positon is emitted) 117 hSetBuffering stdin NoBuffering 118 -- ensure that echoing is off 119 bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do 120 hSetEcho stdin False 121 clearStdin 122 hReportCursorPosition h 123 hFlush h -- ensure the report cursor position code is sent to the 124 -- operating system 125 getReportedCursorPosition 126 case readP_to_S cursorPosition input of 127 [] -> return Nothing 128 [((row, col),_)] -> return $ Just (row, col) 129 (_:_) -> return Nothing 130 clearStdin = do 131 isReady <- hReady stdin 132 when isReady $ do 133 _ <-getChar 134 clearStdin 135