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