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