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