{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
-- |
-- Maintainer  : judah.jacobson@gmail.com
-- Stability   : experimental
-- Portability : portable (FFI)
--
-- This module provides a low-level interface to the C functions of the 
-- terminfo library. 
-- 
-- NOTE: Since this library is built on top of the curses interface, it is not thread-safe.

module System.Console.Terminfo.Base(
                            -- *  Initialization
                            Terminal(),
                            setupTerm,
                            setupTermFromEnv,
                            SetupTermError,
                            -- * Capabilities
                            Capability,
                            getCapability,
                            tiGetFlag,
                            tiGuardFlag,
                            tiGetNum,
                            tiGetStr,
                            -- * Output
                            -- $outputdoc
                            tiGetOutput1,
                            OutputCap,
                            TermStr,
                            -- ** TermOutput
                            TermOutput(),
                            runTermOutput,
                            hRunTermOutput,
                            termText,
                            tiGetOutput,
                            LinesAffected,
                            -- ** Monoid functions
                            Monoid(..),
                            (<#>),
                            ) where


import Control.Applicative
import Control.Monad
import Data.Semigroup as Sem (Semigroup(..))
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Marshal
import Foreign.Storable (peek)
import System.Environment (getEnv)
import System.IO.Unsafe (unsafePerformIO)
import System.IO
import Control.Exception
import Data.Typeable


data TERMINAL
newtype Terminal = Terminal (ForeignPtr TERMINAL)

-- Use "unsafe" to make set_curterm faster since it's called quite a bit.
foreign import ccall unsafe set_curterm :: Ptr TERMINAL -> IO (Ptr TERMINAL)
foreign import ccall "&" del_curterm :: FunPtr (Ptr TERMINAL -> IO ())

foreign import ccall setupterm :: CString -> CInt -> Ptr CInt -> IO ()

-- | Initialize the terminfo library to the given terminal entry.
-- 
-- Throws a 'SetupTermError' if the terminfo database could not be read.
--
-- *Note:* @ncurses@ is not thread-safe; initializing or using multiple
-- 'Terminal's in different threads at the same time can result in memory
-- unsafety.
setupTerm :: String -> IO Terminal
setupTerm :: String -> IO Terminal
setupTerm String
term =
    String -> (CString -> IO Terminal) -> IO Terminal
forall a. String -> (CString -> IO a) -> IO a
withCString String
term ((CString -> IO Terminal) -> IO Terminal)
-> (CString -> IO Terminal) -> IO Terminal
forall a b. (a -> b) -> a -> b
$ \CString
c_term ->
    CInt -> (Ptr CInt -> IO Terminal) -> IO Terminal
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with CInt
0 ((Ptr CInt -> IO Terminal) -> IO Terminal)
-> (Ptr CInt -> IO Terminal) -> IO Terminal
forall a b. (a -> b) -> a -> b
$ \Ptr CInt
ret_ptr -> do
        -- NOTE: I believe that for the way we use terminfo
        -- (i.e. custom output function)
        -- this parameter does not affect anything.
        let stdOutput :: CInt
stdOutput = CInt
1
        -- Save the previous terminal to be restored after calling setupterm.
        Ptr TERMINAL
old_term <- Ptr TERMINAL -> IO (Ptr TERMINAL)
set_curterm Ptr TERMINAL
forall a. Ptr a
nullPtr
        -- Call setupterm and check the return value.
        CString -> CInt -> Ptr CInt -> IO ()
setupterm CString
c_term CInt
stdOutput Ptr CInt
ret_ptr
        CInt
ret <- Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
ret_ptr
        if (CInt
ret CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/=CInt
1)
            then SetupTermError -> IO Terminal
forall e a. Exception e => e -> IO a
throwIO (SetupTermError -> IO Terminal) -> SetupTermError -> IO Terminal
forall a b. (a -> b) -> a -> b
$ String -> SetupTermError
SetupTermError
                (String -> SetupTermError) -> String -> SetupTermError
forall a b. (a -> b) -> a -> b
$ String
"Couldn't look up terminfo entry " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
term
            else do
                Ptr TERMINAL
cterm <- Ptr TERMINAL -> IO (Ptr TERMINAL)
set_curterm Ptr TERMINAL
old_term
                (ForeignPtr TERMINAL -> Terminal)
-> IO (ForeignPtr TERMINAL) -> IO Terminal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr TERMINAL -> Terminal
Terminal (IO (ForeignPtr TERMINAL) -> IO Terminal)
-> IO (ForeignPtr TERMINAL) -> IO Terminal
forall a b. (a -> b) -> a -> b
$ FinalizerPtr TERMINAL -> Ptr TERMINAL -> IO (ForeignPtr TERMINAL)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr TERMINAL
del_curterm Ptr TERMINAL
cterm

data SetupTermError = SetupTermError String
                        deriving Typeable

instance Show SetupTermError where
    show :: SetupTermError -> String
show (SetupTermError String
str) = String
"setupTerm: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str

instance Exception SetupTermError where

-- | Initialize the terminfo library, using the @TERM@ environmental variable.
-- If @TERM@ is not set, we use the generic, minimal entry @dumb@.
-- 
-- Throws a 'SetupTermError' if the terminfo database could not be read.
setupTermFromEnv :: IO Terminal
setupTermFromEnv :: IO Terminal
setupTermFromEnv = do
    String
env_term <- (IOException -> IO String) -> IO String -> IO String
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOException -> IO String
handleBadEnv (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
getEnv String
"TERM" 
    let term :: String
term = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
env_term then String
"dumb" else String
env_term
    String -> IO Terminal
setupTerm String
term
  where
    handleBadEnv :: IOException -> IO String
    handleBadEnv :: IOException -> IO String
handleBadEnv IOException
_ = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""

-- TODO: this isn't really thread-safe...
withCurTerm :: Terminal -> IO a -> IO a
withCurTerm :: forall a. Terminal -> IO a -> IO a
withCurTerm (Terminal ForeignPtr TERMINAL
term) IO a
f = ForeignPtr TERMINAL -> (Ptr TERMINAL -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr TERMINAL
term ((Ptr TERMINAL -> IO a) -> IO a) -> (Ptr TERMINAL -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr TERMINAL
cterm -> do
        Ptr TERMINAL
old_term <- Ptr TERMINAL -> IO (Ptr TERMINAL)
set_curterm Ptr TERMINAL
cterm
        a
x <- IO a
f
        Ptr TERMINAL
_ <- Ptr TERMINAL -> IO (Ptr TERMINAL)
set_curterm Ptr TERMINAL
old_term
        a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x


----------------------

-- Note I'm relying on this working even for strings with unset parameters.
strHasPadding :: String -> Bool
strHasPadding :: String -> Bool
strHasPadding [] = Bool
False
strHasPadding (Char
'$':Char
'<':String
_) = Bool
True
strHasPadding (Char
_:String
cs) = String -> Bool
strHasPadding String
cs

-- | An action which sends output to the terminal.  That output may mix plain text with control
-- characters and escape sequences, along with delays (called \"padding\") required by some older
-- terminals.

-- We structure this similarly to ShowS, so that appends don't cause space leaks.
newtype TermOutput = TermOutput ([TermOutputType] -> [TermOutputType])

data TermOutputType = TOCmd LinesAffected String
                    | TOStr String

instance Sem.Semigroup TermOutput where
    TermOutput [TermOutputType] -> [TermOutputType]
xs <> :: TermOutput -> TermOutput -> TermOutput
<> TermOutput [TermOutputType] -> [TermOutputType]
ys = ([TermOutputType] -> [TermOutputType]) -> TermOutput
TermOutput ([TermOutputType] -> [TermOutputType]
xs ([TermOutputType] -> [TermOutputType])
-> ([TermOutputType] -> [TermOutputType])
-> [TermOutputType]
-> [TermOutputType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TermOutputType] -> [TermOutputType]
ys)

instance Monoid TermOutput where
    mempty :: TermOutput
mempty  = ([TermOutputType] -> [TermOutputType]) -> TermOutput
TermOutput [TermOutputType] -> [TermOutputType]
forall a. a -> a
id
    mappend :: TermOutput -> TermOutput -> TermOutput
mappend = TermOutput -> TermOutput -> TermOutput
forall a. Semigroup a => a -> a -> a
(<>)

termText :: String -> TermOutput 
termText :: String -> TermOutput
termText String
str = ([TermOutputType] -> [TermOutputType]) -> TermOutput
TermOutput (String -> TermOutputType
TOStr String
str TermOutputType -> [TermOutputType] -> [TermOutputType]
forall a. a -> [a] -> [a]
:)

-- | Write the terminal output to the standard output device.
runTermOutput :: Terminal -> TermOutput -> IO ()
runTermOutput :: Terminal -> TermOutput -> IO ()
runTermOutput = Handle -> Terminal -> TermOutput -> IO ()
hRunTermOutput Handle
stdout

-- | Write the terminal output to the terminal or file managed by the given
-- 'Handle'.
hRunTermOutput :: Handle -> Terminal -> TermOutput -> IO ()
hRunTermOutput :: Handle -> Terminal -> TermOutput -> IO ()
hRunTermOutput Handle
h Terminal
term (TermOutput [TermOutputType] -> [TermOutputType]
to) = do
    FunPtr CharOutput
putc_ptr <- CharOutput -> IO (FunPtr CharOutput)
mkCallback CharOutput
forall {b}. Enum b => b -> IO b
putc
    Terminal -> IO () -> IO ()
forall a. Terminal -> IO a -> IO a
withCurTerm Terminal
term (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (TermOutputType -> IO ()) -> [TermOutputType] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FunPtr CharOutput -> Handle -> TermOutputType -> IO ()
writeToTerm FunPtr CharOutput
putc_ptr Handle
h) ([TermOutputType] -> [TermOutputType]
to [])
    FunPtr CharOutput -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr CharOutput
putc_ptr
    Handle -> IO ()
hFlush Handle
h
  where
    putc :: b -> IO b
putc b
c = let c' :: Char
c' = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ b -> Int
forall a. Enum a => a -> Int
fromEnum b
c
             in Handle -> Char -> IO ()
hPutChar Handle
h Char
c' IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h IO () -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
c

-- NOTE: Currently, the output is checked every time tparm is called.
-- It might be faster to check for padding once in tiGetOutput1.
writeToTerm :: FunPtr CharOutput -> Handle -> TermOutputType -> IO ()
writeToTerm :: FunPtr CharOutput -> Handle -> TermOutputType -> IO ()
writeToTerm FunPtr CharOutput
putc Handle
h (TOCmd Int
numLines String
s)
    | String -> Bool
strHasPadding String
s = String -> Int -> FunPtr CharOutput -> IO ()
tPuts String
s Int
numLines FunPtr CharOutput
putc
    | Bool
otherwise = Handle -> String -> IO ()
hPutStr Handle
h String
s
writeToTerm FunPtr CharOutput
_ Handle
h (TOStr String
s) = Handle -> String -> IO ()
hPutStr Handle
h String
s

infixl 2 <#>

-- | An operator version of 'mappend'.
(<#>) :: Monoid m => m -> m -> m
<#> :: forall m. Monoid m => m -> m -> m
(<#>) = m -> m -> m
forall m. Monoid m => m -> m -> m
mappend
---------------------------------

-- | A feature or operation which a 'Terminal' may define.
newtype Capability a = Capability (Terminal -> IO (Maybe a))

getCapability :: Terminal -> Capability a -> Maybe a
getCapability :: forall a. Terminal -> Capability a -> Maybe a
getCapability Terminal
term (Capability Terminal -> IO (Maybe a)
f) = IO (Maybe a) -> Maybe a
forall a. IO a -> a
unsafePerformIO (IO (Maybe a) -> Maybe a) -> IO (Maybe a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ Terminal -> IO (Maybe a) -> IO (Maybe a)
forall a. Terminal -> IO a -> IO a
withCurTerm Terminal
term (Terminal -> IO (Maybe a)
f Terminal
term)

-- Note that the instances for Capability of Functor, Monad and MonadPlus 
-- use the corresponding instances for Maybe.
instance Functor Capability where
    fmap :: forall a b. (a -> b) -> Capability a -> Capability b
fmap a -> b
f (Capability Terminal -> IO (Maybe a)
g) = (Terminal -> IO (Maybe b)) -> Capability b
forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability ((Terminal -> IO (Maybe b)) -> Capability b)
-> (Terminal -> IO (Maybe b)) -> Capability b
forall a b. (a -> b) -> a -> b
$ \Terminal
t -> (Maybe a -> Maybe b) -> IO (Maybe a) -> IO (Maybe b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (Terminal -> IO (Maybe a)
g Terminal
t)

instance Applicative Capability where
    pure :: forall a. a -> Capability a
pure = (Terminal -> IO (Maybe a)) -> Capability a
forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability ((Terminal -> IO (Maybe a)) -> Capability a)
-> (a -> Terminal -> IO (Maybe a)) -> a -> Capability a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe a) -> Terminal -> IO (Maybe a)
forall a b. a -> b -> a
const (IO (Maybe a) -> Terminal -> IO (Maybe a))
-> (a -> IO (Maybe a)) -> a -> Terminal -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> IO (Maybe a)) -> (a -> Maybe a) -> a -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just
    <*> :: forall a b. Capability (a -> b) -> Capability a -> Capability b
(<*>) = Capability (a -> b) -> Capability a -> Capability b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Capability where
    return :: forall a. a -> Capability a
return = a -> Capability a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Capability Terminal -> IO (Maybe a)
f >>= :: forall a b. Capability a -> (a -> Capability b) -> Capability b
>>= a -> Capability b
g = (Terminal -> IO (Maybe b)) -> Capability b
forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability ((Terminal -> IO (Maybe b)) -> Capability b)
-> (Terminal -> IO (Maybe b)) -> Capability b
forall a b. (a -> b) -> a -> b
$ \Terminal
t -> do
        Maybe a
mx <- Terminal -> IO (Maybe a)
f Terminal
t
        case Maybe a
mx of
            Maybe a
Nothing -> Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
            Just a
x -> let Capability Terminal -> IO (Maybe b)
g' = a -> Capability b
g a
x in Terminal -> IO (Maybe b)
g' Terminal
t

instance Alternative Capability where
    <|> :: forall a. Capability a -> Capability a -> Capability a
(<|>) = Capability a -> Capability a -> Capability a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
    empty :: forall a. Capability a
empty = Capability a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance MonadPlus Capability where
    mzero :: forall a. Capability a
mzero = (Terminal -> IO (Maybe a)) -> Capability a
forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability (IO (Maybe a) -> Terminal -> IO (Maybe a)
forall a b. a -> b -> a
const (IO (Maybe a) -> Terminal -> IO (Maybe a))
-> IO (Maybe a) -> Terminal -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing)
    Capability Terminal -> IO (Maybe a)
f mplus :: forall a. Capability a -> Capability a -> Capability a
`mplus` Capability Terminal -> IO (Maybe a)
g = (Terminal -> IO (Maybe a)) -> Capability a
forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability ((Terminal -> IO (Maybe a)) -> Capability a)
-> (Terminal -> IO (Maybe a)) -> Capability a
forall a b. (a -> b) -> a -> b
$ \Terminal
t -> do
        Maybe a
mx <- Terminal -> IO (Maybe a)
f Terminal
t
        case Maybe a
mx of
            Maybe a
Nothing -> Terminal -> IO (Maybe a)
g Terminal
t
            Maybe a
_ -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mx

foreign import ccall tigetnum :: CString -> IO CInt

-- | Look up a numeric capability in the terminfo database.
tiGetNum :: String -> Capability Int 
tiGetNum :: String -> Capability Int
tiGetNum String
cap = (Terminal -> IO (Maybe Int)) -> Capability Int
forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability ((Terminal -> IO (Maybe Int)) -> Capability Int)
-> (Terminal -> IO (Maybe Int)) -> Capability Int
forall a b. (a -> b) -> a -> b
$ IO (Maybe Int) -> Terminal -> IO (Maybe Int)
forall a b. a -> b -> a
const (IO (Maybe Int) -> Terminal -> IO (Maybe Int))
-> IO (Maybe Int) -> Terminal -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ do
                Int
n <- (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a. Enum a => a -> Int
fromEnum (String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
cap CString -> IO CInt
tigetnum)
                if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
                    then Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n)
                    else Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing

foreign import ccall tigetflag :: CString -> IO CInt
-- | Look up a boolean capability in the terminfo database.  
-- 
-- Unlike 'tiGuardFlag', this capability never fails; it returns 'False' if the
-- capability is absent or set to false, and returns 'True' otherwise.  
-- 
tiGetFlag :: String -> Capability Bool
tiGetFlag :: String -> Capability Bool
tiGetFlag String
cap = (Terminal -> IO (Maybe Bool)) -> Capability Bool
forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability ((Terminal -> IO (Maybe Bool)) -> Capability Bool)
-> (Terminal -> IO (Maybe Bool)) -> Capability Bool
forall a b. (a -> b) -> a -> b
$ IO (Maybe Bool) -> Terminal -> IO (Maybe Bool)
forall a b. a -> b -> a
const (IO (Maybe Bool) -> Terminal -> IO (Maybe Bool))
-> IO (Maybe Bool) -> Terminal -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ (CInt -> Maybe Bool) -> IO CInt -> IO (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> (CInt -> Bool) -> CInt -> Maybe Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
>CInt
0)) (IO CInt -> IO (Maybe Bool)) -> IO CInt -> IO (Maybe Bool)
forall a b. (a -> b) -> a -> b
$
                        String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
cap CString -> IO CInt
tigetflag
                
-- | Look up a boolean capability in the terminfo database, and fail if
-- it\'s not defined.
tiGuardFlag :: String -> Capability ()
tiGuardFlag :: String -> Capability ()
tiGuardFlag String
cap = String -> Capability Bool
tiGetFlag String
cap Capability Bool -> (Bool -> Capability ()) -> Capability ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Capability ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
                
foreign import ccall tigetstr :: CString -> IO CString

{-# DEPRECATED tiGetStr "use tiGetOutput instead." #-} 
-- | Look up a string capability in the terminfo database.  NOTE: This function is deprecated; use
-- 'tiGetOutput1' instead.
tiGetStr :: String -> Capability String
tiGetStr :: String -> Capability String
tiGetStr String
cap = (Terminal -> IO (Maybe String)) -> Capability String
forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability ((Terminal -> IO (Maybe String)) -> Capability String)
-> (Terminal -> IO (Maybe String)) -> Capability String
forall a b. (a -> b) -> a -> b
$ IO (Maybe String) -> Terminal -> IO (Maybe String)
forall a b. a -> b -> a
const (IO (Maybe String) -> Terminal -> IO (Maybe String))
-> IO (Maybe String) -> Terminal -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
                CString
result <- String -> (CString -> IO CString) -> IO CString
forall a. String -> (CString -> IO a) -> IO a
withCString String
cap CString -> IO CString
tigetstr 
                if CString
result CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr Bool -> Bool -> Bool
|| CString
result CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
neg1Ptr
                    then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
                    else (String -> Maybe String) -> IO String -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Maybe String
forall a. a -> Maybe a
Just (CString -> IO String
peekCString CString
result)
    where
        -- hack; tigetstr sometimes returns (-1)
        neg1Ptr :: Ptr b
neg1Ptr = Ptr Any
forall a. Ptr a
nullPtr Ptr Any -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (-Int
1)


---------------


                    
foreign import capi "term.h tparm"
    tparm :: CString -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong
    -> CLong -> CLong -> CLong -- p1,...,p9
    -> IO CString

-- Note: I may want to cut out the middleman and pipe tGoto/tGetStr together
-- with tput without a String marshall in the middle.
-- directly without 

tParm :: String -> Capability ([Int] -> String)
tParm :: String -> Capability ([Int] -> String)
tParm String
cap = (Terminal -> IO (Maybe ([Int] -> String)))
-> Capability ([Int] -> String)
forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability ((Terminal -> IO (Maybe ([Int] -> String)))
 -> Capability ([Int] -> String))
-> (Terminal -> IO (Maybe ([Int] -> String)))
-> Capability ([Int] -> String)
forall a b. (a -> b) -> a -> b
$ \Terminal
t -> Maybe ([Int] -> String) -> IO (Maybe ([Int] -> String))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ([Int] -> String) -> IO (Maybe ([Int] -> String)))
-> Maybe ([Int] -> String) -> IO (Maybe ([Int] -> String))
forall a b. (a -> b) -> a -> b
$ ([Int] -> String) -> Maybe ([Int] -> String)
forall a. a -> Maybe a
Just 
        (([Int] -> String) -> Maybe ([Int] -> String))
-> ([Int] -> String) -> Maybe ([Int] -> String)
forall a b. (a -> b) -> a -> b
$ \[Int]
ps -> IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ Terminal -> IO String -> IO String
forall a. Terminal -> IO a -> IO a
withCurTerm Terminal
t (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$
                    [CLong] -> IO String
tparm' ((Int -> CLong) -> [Int] -> [CLong]
forall a b. (a -> b) -> [a] -> [b]
map Int -> CLong
forall a. Enum a => Int -> a
toEnum [Int]
ps [CLong] -> [CLong] -> [CLong]
forall a. [a] -> [a] -> [a]
++ CLong -> [CLong]
forall a. a -> [a]
repeat CLong
0)
    where tparm' :: [CLong] -> IO String
tparm' (CLong
p1:CLong
p2:CLong
p3:CLong
p4:CLong
p5:CLong
p6:CLong
p7:CLong
p8:CLong
p9:[CLong]
_)
            = String -> (CString -> IO String) -> IO String
forall a. String -> (CString -> IO a) -> IO a
withCString String
cap ((CString -> IO String) -> IO String)
-> (CString -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \CString
c_cap -> do
                CString
result <- CString
-> CLong
-> CLong
-> CLong
-> CLong
-> CLong
-> CLong
-> CLong
-> CLong
-> CLong
-> IO CString
tparm CString
c_cap CLong
p1 CLong
p2 CLong
p3 CLong
p4 CLong
p5 CLong
p6 CLong
p7 CLong
p8 CLong
p9
                if CString
result CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
                    then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
                    else CString -> IO String
peekCString CString
result
          tparm' [CLong]
_ = String -> IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"tParm: List too short"

-- | Look up an output capability in the terminfo database.  
tiGetOutput :: String -> Capability ([Int] -> LinesAffected -> TermOutput)
tiGetOutput :: String -> Capability ([Int] -> Int -> TermOutput)
tiGetOutput String
cap = do
    String
str <- String -> Capability String
tiGetStr String
cap
    [Int] -> String
f <- String -> Capability ([Int] -> String)
tParm String
str
    ([Int] -> Int -> TermOutput)
-> Capability ([Int] -> Int -> TermOutput)
forall (m :: * -> *) a. Monad m => a -> m a
return (([Int] -> Int -> TermOutput)
 -> Capability ([Int] -> Int -> TermOutput))
-> ([Int] -> Int -> TermOutput)
-> Capability ([Int] -> Int -> TermOutput)
forall a b. (a -> b) -> a -> b
$ \[Int]
ps Int
la -> Int -> String -> TermOutput
fromStr Int
la (String -> TermOutput) -> String -> TermOutput
forall a b. (a -> b) -> a -> b
$ [Int] -> String
f [Int]
ps

fromStr :: LinesAffected -> String -> TermOutput
fromStr :: Int -> String -> TermOutput
fromStr Int
la String
s = ([TermOutputType] -> [TermOutputType]) -> TermOutput
TermOutput (Int -> String -> TermOutputType
TOCmd Int
la String
s TermOutputType -> [TermOutputType] -> [TermOutputType]
forall a. a -> [a] -> [a]
:)

type CharOutput = CInt -> IO CInt

foreign import ccall "wrapper" mkCallback :: CharOutput -> IO (FunPtr CharOutput)

foreign import ccall tputs :: CString -> CInt -> FunPtr CharOutput -> IO ()

-- | A parameter to specify the number of lines affected.  Some capabilities
-- (e.g., @clear@ and @dch1@) use
-- this parameter on some terminals to compute variable-length padding.
type LinesAffected = Int

-- | Output a string capability.  Applys padding information to the string if
-- necessary.
tPuts :: String -> LinesAffected -> FunPtr CharOutput -> IO ()
tPuts :: String -> Int -> FunPtr CharOutput -> IO ()
tPuts String
s Int
n FunPtr CharOutput
putc = String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
s ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
c_str -> CString -> CInt -> FunPtr CharOutput -> IO ()
tputs CString
c_str (Int -> CInt
forall a. Enum a => Int -> a
toEnum Int
n) FunPtr CharOutput
putc


-- | Look up an output capability which takes a fixed number of parameters
-- (for example, @Int -> Int -> TermOutput@).
-- 
-- For capabilities which may contain variable-length
-- padding, use 'tiGetOutput' instead.
tiGetOutput1 :: forall f . OutputCap f => String -> Capability f
tiGetOutput1 :: forall f. OutputCap f => String -> Capability f
tiGetOutput1 String
str = do
    String
cap <- String -> Capability String
tiGetStr String
str
    Bool -> Capability ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (f -> String -> Bool
forall f. OutputCap f => f -> String -> Bool
hasOkPadding (f
forall a. HasCallStack => a
undefined :: f) String
cap)
    [Int] -> String
f <- String -> Capability ([Int] -> String)
tParm String
cap
    f -> Capability f
forall (m :: * -> *) a. Monad m => a -> m a
return (f -> Capability f) -> f -> Capability f
forall a b. (a -> b) -> a -> b
$ ([Int] -> String) -> [Int] -> f
forall f. OutputCap f => ([Int] -> String) -> [Int] -> f
outputCap [Int] -> String
f []


-- OK, this is the structure that I want:
class OutputCap f where
    hasOkPadding :: f -> String -> Bool
    outputCap :: ([Int] -> String) -> [Int] -> f

instance OutputCap [Char] where
    hasOkPadding :: String -> String -> Bool
hasOkPadding String
_ = Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
strHasPadding 
    outputCap :: ([Int] -> String) -> [Int] -> String
outputCap [Int] -> String
f [Int]
xs = [Int] -> String
f ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
xs)

instance OutputCap TermOutput where
    hasOkPadding :: TermOutput -> String -> Bool
hasOkPadding TermOutput
_ = Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
True
    outputCap :: ([Int] -> String) -> [Int] -> TermOutput
outputCap [Int] -> String
f [Int]
xs = Int -> String -> TermOutput
fromStr Int
1 (String -> TermOutput) -> String -> TermOutput
forall a b. (a -> b) -> a -> b
$ [Int] -> String
f ([Int] -> String) -> [Int] -> String
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
xs

instance (Enum p, OutputCap f) => OutputCap (p -> f) where
    outputCap :: ([Int] -> String) -> [Int] -> p -> f
outputCap [Int] -> String
f [Int]
xs = \p
x -> ([Int] -> String) -> [Int] -> f
forall f. OutputCap f => ([Int] -> String) -> [Int] -> f
outputCap [Int] -> String
f (p -> Int
forall a. Enum a => a -> Int
fromEnum p
xInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
xs)
    hasOkPadding :: (p -> f) -> String -> Bool
hasOkPadding p -> f
_ = f -> String -> Bool
forall f. OutputCap f => f -> String -> Bool
hasOkPadding (f
forall a. HasCallStack => a
undefined :: f)


{- $outputdoc
Terminfo contains many string capabilities for special effects.
For example, the @cuu1@ capability moves the cursor up one line; on ANSI terminals
this is accomplished by printing the control sequence @\"\\ESC[A\"@.
However, some older terminals also require \"padding\", or short pauses, after certain commands.
For example, when @TERM=vt100@ the @cuu1@ capability is @\"\\ESC[A$\<2\>\"@, which instructs terminfo
to pause for two milliseconds after outputting the control sequence.

The 'TermOutput' monoid abstracts away all padding and control
sequence output.  Unfortunately, that datatype is difficult to integrate into existing 'String'-based APIs
such 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:

   > > t <- setupTerm "vt100"
   > > isJust (getCapability t (tiGetOutput1 "cuu1") :: Maybe String)
   > False
   > > isJust (getCapability t (tiGetOutput1 "cuu1") :: Maybe TermOutput)
   > True

'String' capabilities will work with software-based terminal types such as @xterm@ and @linux@.
However, you should use 'TermOutput' if compatibility with older terminals is important.
Additionally, the @visualBell@ capability which flashes the screen usually produces its effect with a padding directive, so it will only work with 'TermOutput'.

-}


class (Monoid s, OutputCap s) => TermStr s

instance TermStr [Char]
instance TermStr TermOutput