1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE Trustworthy #-}
5-- |
6-- Maintainer  : judah.jacobson@gmail.com
7-- Stability   : experimental
8-- Portability : portable (FFI)
9--
10-- This module provides a low-level interface to the C functions of the
11-- terminfo library.
12--
13-- NOTE: Since this library is built on top of the curses interface, it is not thread-safe.
14
15module System.Console.Terminfo.Base(
16                            -- *  Initialization
17                            Terminal(),
18                            setupTerm,
19                            setupTermFromEnv,
20                            SetupTermError,
21                            -- * Capabilities
22                            Capability,
23                            getCapability,
24                            tiGetFlag,
25                            tiGuardFlag,
26                            tiGetNum,
27                            tiGetStr,
28                            -- * Output
29                            -- $outputdoc
30                            tiGetOutput1,
31                            OutputCap,
32                            TermStr,
33                            -- ** TermOutput
34                            TermOutput(),
35                            runTermOutput,
36                            hRunTermOutput,
37                            termText,
38                            tiGetOutput,
39                            LinesAffected,
40                            -- ** Monoid functions
41                            Monoid(..),
42                            (<#>),
43                            ) where
44
45
46import Control.Applicative
47import Control.Monad
48import Data.Semigroup as Sem (Semigroup(..))
49import Foreign.C
50import Foreign.ForeignPtr
51import Foreign.Ptr
52import Foreign.Marshal
53import Foreign.Storable (peek)
54import System.Environment (getEnv)
55import System.IO.Unsafe (unsafePerformIO)
56import System.IO
57import Control.Exception
58import Data.Typeable
59
60
61data TERMINAL
62newtype Terminal = Terminal (ForeignPtr TERMINAL)
63
64-- Use "unsafe" to make set_curterm faster since it's called quite a bit.
65foreign import ccall unsafe set_curterm :: Ptr TERMINAL -> IO (Ptr TERMINAL)
66foreign import ccall "&" del_curterm :: FunPtr (Ptr TERMINAL -> IO ())
67
68foreign import ccall setupterm :: CString -> CInt -> Ptr CInt -> IO ()
69
70-- | Initialize the terminfo library to the given terminal entry.
71--
72-- Throws a 'SetupTermError' if the terminfo database could not be read.
73setupTerm :: String -> IO Terminal
74setupTerm term =
75    withCString term $ \c_term ->
76    with 0 $ \ret_ptr -> do
77        -- NOTE: I believe that for the way we use terminfo
78        -- (i.e. custom output function)
79        -- this parameter does not affect anything.
80        let stdOutput = 1
81        -- Save the previous terminal to be restored after calling setupterm.
82        old_term <- set_curterm nullPtr
83        -- Call setupterm and check the return value.
84        setupterm c_term stdOutput ret_ptr
85        ret <- peek ret_ptr
86        if (ret /=1)
87            then throwIO $ SetupTermError
88                $ "Couldn't look up terminfo entry " ++ show term
89            else do
90                cterm <- set_curterm old_term
91                fmap Terminal $ newForeignPtr del_curterm cterm
92
93data SetupTermError = SetupTermError String
94                        deriving Typeable
95
96instance Show SetupTermError where
97    show (SetupTermError str) = "setupTerm: " ++ str
98
99instance Exception SetupTermError where
100
101-- | Initialize the terminfo library, using the @TERM@ environmental variable.
102-- If @TERM@ is not set, we use the generic, minimal entry @dumb@.
103--
104-- Throws a 'SetupTermError' if the terminfo database could not be read.
105setupTermFromEnv :: IO Terminal
106setupTermFromEnv = do
107    env_term <- handle handleBadEnv $ getEnv "TERM"
108    let term = if null env_term then "dumb" else env_term
109    setupTerm term
110  where
111    handleBadEnv :: IOException -> IO String
112    handleBadEnv _ = return ""
113
114-- TODO: this isn't really thread-safe...
115withCurTerm :: Terminal -> IO a -> IO a
116withCurTerm (Terminal term) f = withForeignPtr term $ \cterm -> do
117        old_term <- set_curterm cterm
118        x <- f
119        _ <- set_curterm old_term
120        return x
121
122
123----------------------
124
125-- Note I'm relying on this working even for strings with unset parameters.
126strHasPadding :: String -> Bool
127strHasPadding [] = False
128strHasPadding ('$':'<':_) = True
129strHasPadding (_:cs) = strHasPadding cs
130
131-- | An action which sends output to the terminal.  That output may mix plain text with control
132-- characters and escape sequences, along with delays (called \"padding\") required by some older
133-- terminals.
134
135-- We structure this similarly to ShowS, so that appends don't cause space leaks.
136newtype TermOutput = TermOutput ([TermOutputType] -> [TermOutputType])
137
138data TermOutputType = TOCmd LinesAffected String
139                    | TOStr String
140
141instance Sem.Semigroup TermOutput where
142    TermOutput xs <> TermOutput ys = TermOutput (xs . ys)
143
144instance Monoid TermOutput where
145    mempty  = TermOutput id
146    mappend = (<>)
147
148termText :: String -> TermOutput
149termText str = TermOutput (TOStr str :)
150
151-- | Write the terminal output to the standard output device.
152runTermOutput :: Terminal -> TermOutput -> IO ()
153runTermOutput = hRunTermOutput stdout
154
155-- | Write the terminal output to the terminal or file managed by the given
156-- 'Handle'.
157hRunTermOutput :: Handle -> Terminal -> TermOutput -> IO ()
158hRunTermOutput h term (TermOutput to) = do
159    putc_ptr <- mkCallback putc
160    withCurTerm term $ mapM_ (writeToTerm putc_ptr h) (to [])
161    freeHaskellFunPtr putc_ptr
162    hFlush h
163  where
164    putc c = let c' = toEnum $ fromEnum c
165             in hPutChar h c' >> hFlush h >> return c
166
167-- NOTE: Currently, the output is checked every time tparm is called.
168-- It might be faster to check for padding once in tiGetOutput1.
169writeToTerm :: FunPtr CharOutput -> Handle -> TermOutputType -> IO ()
170writeToTerm putc h (TOCmd numLines s)
171    | strHasPadding s = tPuts s numLines putc
172    | otherwise = hPutStr h s
173writeToTerm _ h (TOStr s) = hPutStr h s
174
175infixl 2 <#>
176
177-- | An operator version of 'mappend'.
178(<#>) :: Monoid m => m -> m -> m
179(<#>) = mappend
180---------------------------------
181
182-- | A feature or operation which a 'Terminal' may define.
183newtype Capability a = Capability (Terminal -> IO (Maybe a))
184
185getCapability :: Terminal -> Capability a -> Maybe a
186getCapability term (Capability f) = unsafePerformIO $ withCurTerm term (f term)
187
188-- Note that the instances for Capability of Functor, Monad and MonadPlus
189-- use the corresponding instances for Maybe.
190instance Functor Capability where
191    fmap f (Capability g) = Capability $ \t -> fmap (fmap f) (g t)
192
193instance Applicative Capability where
194    pure = Capability . const . pure . Just
195    (<*>) = ap
196
197instance Monad Capability where
198    return = pure
199    Capability f >>= g = Capability $ \t -> do
200        mx <- f t
201        case mx of
202            Nothing -> return Nothing
203            Just x -> let Capability g' = g x in g' t
204
205instance Alternative Capability where
206    (<|>) = mplus
207    empty = mzero
208
209instance MonadPlus Capability where
210    mzero = Capability (const $ return Nothing)
211    Capability f `mplus` Capability g = Capability $ \t -> do
212        mx <- f t
213        case mx of
214            Nothing -> g t
215            _ -> return mx
216
217foreign import ccall tigetnum :: CString -> IO CInt
218
219-- | Look up a numeric capability in the terminfo database.
220tiGetNum :: String -> Capability Int
221tiGetNum cap = Capability $ const $ do
222                n <- fmap fromEnum (withCString cap tigetnum)
223                if n >= 0
224                    then return (Just n)
225                    else return Nothing
226
227foreign import ccall tigetflag :: CString -> IO CInt
228-- | Look up a boolean capability in the terminfo database.
229--
230-- Unlike 'tiGuardFlag', this capability never fails; it returns 'False' if the
231-- capability is absent or set to false, and returns 'True' otherwise.
232--
233tiGetFlag :: String -> Capability Bool
234tiGetFlag cap = Capability $ const $ fmap (Just . (>0)) $
235                        withCString cap tigetflag
236
237-- | Look up a boolean capability in the terminfo database, and fail if
238-- it\'s not defined.
239tiGuardFlag :: String -> Capability ()
240tiGuardFlag cap = tiGetFlag cap >>= guard
241
242foreign import ccall tigetstr :: CString -> IO CString
243
244{-# DEPRECATED tiGetStr "use tiGetOutput instead." #-}
245-- | Look up a string capability in the terminfo database.  NOTE: This function is deprecated; use
246-- 'tiGetOutput1' instead.
247tiGetStr :: String -> Capability String
248tiGetStr cap = Capability $ const $ do
249                result <- withCString cap tigetstr
250                if result == nullPtr || result == neg1Ptr
251                    then return Nothing
252                    else fmap Just (peekCString result)
253    where
254        -- hack; tigetstr sometimes returns (-1)
255        neg1Ptr = nullPtr `plusPtr` (-1)
256
257
258---------------
259
260
261
262foreign import ccall tparm ::
263    CString -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong
264    -> CLong -> CLong -> CLong -- p1,...,p9
265    -> IO CString
266
267-- Note: I may want to cut out the middleman and pipe tGoto/tGetStr together
268-- with tput without a String marshall in the middle.
269-- directly without
270
271tParm :: String -> Capability ([Int] -> String)
272tParm cap = Capability $ \t -> return $ Just
273        $ \ps -> unsafePerformIO $ withCurTerm t $
274                    tparm' (map toEnum ps ++ repeat 0)
275    where tparm' (p1:p2:p3:p4:p5:p6:p7:p8:p9:_)
276            = withCString cap $ \c_cap -> do
277                result <- tparm c_cap p1 p2 p3 p4 p5 p6 p7 p8 p9
278                if result == nullPtr
279                    then return ""
280                    else peekCString result
281          tparm' _ = fail "tParm: List too short"
282
283-- | Look up an output capability in the terminfo database.
284tiGetOutput :: String -> Capability ([Int] -> LinesAffected -> TermOutput)
285tiGetOutput cap = do
286    str <- tiGetStr cap
287    f <- tParm str
288    return $ \ps la -> fromStr la $ f ps
289
290fromStr :: LinesAffected -> String -> TermOutput
291fromStr la s = TermOutput (TOCmd la s :)
292
293type CharOutput = CInt -> IO CInt
294
295foreign import ccall "wrapper" mkCallback :: CharOutput -> IO (FunPtr CharOutput)
296
297foreign import ccall tputs :: CString -> CInt -> FunPtr CharOutput -> IO ()
298
299-- | A parameter to specify the number of lines affected.  Some capabilities
300-- (e.g., @clear@ and @dch1@) use
301-- this parameter on some terminals to compute variable-length padding.
302type LinesAffected = Int
303
304-- | Output a string capability.  Applys padding information to the string if
305-- necessary.
306tPuts :: String -> LinesAffected -> FunPtr CharOutput -> IO ()
307tPuts s n putc = withCString s $ \c_str -> tputs c_str (toEnum n) putc
308
309
310-- | Look up an output capability which takes a fixed number of parameters
311-- (for example, @Int -> Int -> TermOutput@).
312--
313-- For capabilities which may contain variable-length
314-- padding, use 'tiGetOutput' instead.
315tiGetOutput1 :: forall f . OutputCap f => String -> Capability f
316tiGetOutput1 str = do
317    cap <- tiGetStr str
318    guard (hasOkPadding (undefined :: f) cap)
319    f <- tParm cap
320    return $ outputCap f []
321
322
323-- OK, this is the structure that I want:
324class OutputCap f where
325    hasOkPadding :: f -> String -> Bool
326    outputCap :: ([Int] -> String) -> [Int] -> f
327
328instance OutputCap [Char] where
329    hasOkPadding _ = not . strHasPadding
330    outputCap f xs = f (reverse xs)
331
332instance OutputCap TermOutput where
333    hasOkPadding _ = const True
334    outputCap f xs = fromStr 1 $ f $ reverse xs
335
336instance (Enum p, OutputCap f) => OutputCap (p -> f) where
337    outputCap f xs = \x -> outputCap f (fromEnum x:xs)
338    hasOkPadding _ = hasOkPadding (undefined :: f)
339
340
341{- $outputdoc
342Terminfo contains many string capabilities for special effects.
343For example, the @cuu1@ capability moves the cursor up one line; on ANSI terminals
344this is accomplished by printing the control sequence @\"\\ESC[A\"@.
345However, some older terminals also require \"padding\", or short pauses, after certain commands.
346For example, when @TERM=vt100@ the @cuu1@ capability is @\"\\ESC[A$\<2\>\"@, which instructs terminfo
347to pause for two milliseconds after outputting the control sequence.
348
349The 'TermOutput' monoid abstracts away all padding and control
350sequence output.  Unfortunately, that datatype is difficult to integrate into existing 'String'-based APIs
351such as pretty-printers.  Thus, as a workaround, 'tiGetOutput1' also lets us access the control sequences as 'String's.  The one caveat is that it will not allow you to access padded control sequences as Strings.  For example:
352
353   > > t <- setupTerm "vt100"
354   > > isJust (getCapability t (tiGetOutput1 "cuu1") :: Maybe String)
355   > False
356   > > isJust (getCapability t (tiGetOutput1 "cuu1") :: Maybe TermOutput)
357   > True
358
359'String' capabilities will work with software-based terminal types such as @xterm@ and @linux@.
360However, you should use 'TermOutput' if compatibility with older terminals is important.
361Additionally, the @visualBell@ capability which flashes the screen usually produces its effect with a padding directive, so it will only work with 'TermOutput'.
362
363-}
364
365
366class (Monoid s, OutputCap s) => TermStr s
367
368instance TermStr [Char]
369instance TermStr TermOutput
370