    {-# 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

    -- | 'Terminal' objects are automatically freed by the garbage collector.
    --   Hence, there is no equivalent of @del_curterm@ here.
    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 :: [Char] -> IO Terminal
    setupTerm [Char]
    term =
        [Char] -> (Ptr CChar -> IO Terminal) -> IO Terminal
    forall a. [Char] -> (Ptr CChar -> IO a) -> IO a
    withCString [Char]
    term ((Ptr CChar -> IO Terminal) -> IO Terminal)
    -> (Ptr CChar -> IO Terminal) -> IO Terminal
    forall a b. (a -> b) -> a -> b
    $ \Ptr CChar
    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.
            old_term <- Ptr TERMINAL -> IO (Ptr TERMINAL)
    set_curterm Ptr TERMINAL
    forall a. Ptr a
    nullPtr
            -- Call setupterm and check the return value.
            setupterm c_term stdOutput ret_ptr
            ret <- peek ret_ptr
            if (ret /=1)
                then throwIO $ SetupTermError
                    $ "Couldn't look up terminfo entry " ++ show term
                else do
                    cterm <- set_curterm old_term
                    fmap Terminal $ newForeignPtr del_curterm cterm

    data SetupTermError = SetupTermError String
                            deriving Typeable

    instance Show SetupTermError where
        show :: SetupTermError -> [Char]
    show (SetupTermError [Char]
    str) = [Char]
    "setupTerm: " [Char] -> [Char] -> [Char]
    forall a. [a] -> [a] -> [a]
    ++ [Char]
    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
        env_term <- (IOException -> IO [Char]) -> IO [Char] -> IO [Char]
    forall e a. Exception e => (e -> IO a) -> IO a -> IO a
    handle IOException -> IO [Char]
    handleBadEnv (IO [Char] -> IO [Char]) -> IO [Char] -> IO [Char]
    forall a b. (a -> b) -> a -> b
    $ [Char] -> IO [Char]
    getEnv [Char]
    "TERM"
        let term = if [Char] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Char]
    env_term then [Char]
    "dumb" else [Char]
    env_term
        setupTerm term
      where
        handleBadEnv :: IOException -> IO String
        handleBadEnv :: IOException -> IO [Char]
    handleBadEnv IOException
    _ = [Char] -> IO [Char]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Char]
    ""

    -- 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
            old_term <- Ptr TERMINAL -> IO (Ptr TERMINAL)
    set_curterm Ptr TERMINAL
    cterm
            x <- f
            _ <- set_curterm old_term
            return x

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

    -- Note I'm relying on this working even for strings with unset parameters.
    strHasPadding :: String -> Bool
    strHasPadding :: [Char] -> Bool
    strHasPadding [] = Bool
    False
    strHasPadding (Char
    '$':Char
    '<':[Char]
    _) = Bool
    True
    strHasPadding (Char
    _:[Char]
    cs) = [Char] -> Bool
    strHasPadding [Char]
    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 :: [Char] -> TermOutput
    termText [Char]
    str = ([TermOutputType] -> [TermOutputType]) -> TermOutput
    TermOutput ([Char] -> TermOutputType
    TOStr [Char]
    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
        putc_ptr <- CharOutput -> IO (FunPtr CharOutput)
    mkCallback CharOutput
    forall {b}. Enum b => b -> IO b
    putc
        withCurTerm term $ mapM_ (writeToTerm putc_ptr h) (to [])
        freeHaskellFunPtr putc_ptr
        hFlush 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 a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Handle -> IO ()
    hFlush Handle
    h IO () -> IO b -> IO b
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> b -> IO b
    forall a. a -> IO a
    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 [Char]
    s)
        | [Char] -> Bool
    strHasPadding [Char]
    s = [Char] -> Int -> FunPtr CharOutput -> IO ()
    tPuts [Char]
    s Int
    numLines FunPtr CharOutput
    putc
        | Bool
    otherwise = Handle -> [Char] -> IO ()
    hPutStr Handle
    h [Char]
    s
    writeToTerm FunPtr CharOutput
    _ Handle
    h (TOStr [Char]
    s) = Handle -> [Char] -> IO ()
    hPutStr Handle
    h [Char]
    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 a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((a -> b) -> Maybe a -> Maybe b
    forall a b. (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 a. a -> IO 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 a. 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
            mx <- Terminal -> IO (Maybe a)
    f Terminal
    t
            case mx of
                Maybe a
    Nothing -> Maybe b -> IO (Maybe b)
    forall a. a -> IO a
    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 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 a. 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 a. a -> IO 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
            mx <- Terminal -> IO (Maybe a)
    f Terminal
    t
            case mx of
                Maybe a
    Nothing -> Terminal -> IO (Maybe a)
    g Terminal
    t
                Maybe a
    _ -> Maybe a -> IO (Maybe a)
    forall a. a -> IO 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 :: [Char] -> Capability Int
    tiGetNum [Char]
    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
                    n <- (CInt -> Int) -> IO CInt -> IO Int
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap CInt -> Int
    forall a. Enum a => a -> Int
    fromEnum ([Char] -> (Ptr CChar -> IO CInt) -> IO CInt
    forall a. [Char] -> (Ptr CChar -> IO a) -> IO a
    withCString [Char]
    cap Ptr CChar -> IO CInt
    tigetnum)
                    if n >= 0
                        then return (Just n)
                        else return 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 :: [Char] -> Capability Bool
    tiGetFlag [Char]
    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 a b. (a -> b) -> IO a -> IO b
    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
    $
                            [Char] -> (Ptr CChar -> IO CInt) -> IO CInt
    forall a. [Char] -> (Ptr CChar -> IO a) -> IO a
    withCString [Char]
    cap Ptr CChar -> IO CInt
    tigetflag

    -- | Look up a boolean capability in the terminfo database, and fail if
    -- it\'s not defined.
    tiGuardFlag :: String -> Capability ()
    tiGuardFlag :: [Char] -> Capability ()
    tiGuardFlag [Char]
    cap = [Char] -> Capability Bool
    tiGetFlag [Char]
    cap Capability Bool -> (Bool -> Capability ()) -> Capability ()
    forall a b. Capability a -> (a -> Capability b) -> Capability b
    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 :: [Char] -> Capability [Char]
    tiGetStr [Char]
    cap = (Terminal -> IO (Maybe [Char])) -> Capability [Char]
    forall a. (Terminal -> IO (Maybe a)) -> Capability a
    Capability ((Terminal -> IO (Maybe [Char])) -> Capability [Char])
    -> (Terminal -> IO (Maybe [Char])) -> Capability [Char]
    forall a b. (a -> b) -> a -> b
    $ IO (Maybe [Char]) -> Terminal -> IO (Maybe [Char])
    forall a b. a -> b -> a
    const (IO (Maybe [Char]) -> Terminal -> IO (Maybe [Char]))
    -> IO (Maybe [Char]) -> Terminal -> IO (Maybe [Char])
    forall a b. (a -> b) -> a -> b
    $ do
                    result <- [Char] -> (Ptr CChar -> IO (Ptr CChar)) -> IO (Ptr CChar)
    forall a. [Char] -> (Ptr CChar -> IO a) -> IO a
    withCString [Char]
    cap Ptr CChar -> IO (Ptr CChar)
    tigetstr
                    if result == nullPtr || result == neg1Ptr
                        then return Nothing
                        else fmap Just (peekCString result)
        where
            -- hack; tigetstr sometimes returns (-1)
            neg1Ptr :: Ptr b
    neg1Ptr = Ptr (ZonkAny 0)
    forall a. Ptr a
    nullPtr Ptr (ZonkAny 0) -> 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 :: [Char] -> Capability ([Int] -> [Char])
    tParm [Char]
    cap = (Terminal -> IO (Maybe ([Int] -> [Char])))
    -> Capability ([Int] -> [Char])
    forall a. (Terminal -> IO (Maybe a)) -> Capability a
    Capability ((Terminal -> IO (Maybe ([Int] -> [Char])))
     -> Capability ([Int] -> [Char]))
    -> (Terminal -> IO (Maybe ([Int] -> [Char])))
    -> Capability ([Int] -> [Char])
    forall a b. (a -> b) -> a -> b
    $ \Terminal
    t -> Maybe ([Int] -> [Char]) -> IO (Maybe ([Int] -> [Char]))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Maybe ([Int] -> [Char]) -> IO (Maybe ([Int] -> [Char])))
    -> Maybe ([Int] -> [Char]) -> IO (Maybe ([Int] -> [Char]))
    forall a b. (a -> b) -> a -> b
    $ ([Int] -> [Char]) -> Maybe ([Int] -> [Char])
    forall a. a -> Maybe a
    Just
            (([Int] -> [Char]) -> Maybe ([Int] -> [Char]))
    -> ([Int] -> [Char]) -> Maybe ([Int] -> [Char])
    forall a b. (a -> b) -> a -> b
    $ \[Int]
    ps -> IO [Char] -> [Char]
    forall a. IO a -> a
    unsafePerformIO (IO [Char] -> [Char]) -> IO [Char] -> [Char]
    forall a b. (a -> b) -> a -> b
    $ Terminal -> IO [Char] -> IO [Char]
    forall a. Terminal -> IO a -> IO a
    withCurTerm Terminal
    t (IO [Char] -> IO [Char]) -> IO [Char] -> IO [Char]
    forall a b. (a -> b) -> a -> b
    $
                        [CLong] -> IO [Char]
    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 [Char]
    tparm' (CLong
    p1:CLong
    p2:CLong
    p3:CLong
    p4:CLong
    p5:CLong
    p6:CLong
    p7:CLong
    p8:CLong
    p9:[CLong]
    _)
                = [Char] -> (Ptr CChar -> IO [Char]) -> IO [Char]
    forall a. [Char] -> (Ptr CChar -> IO a) -> IO a
    withCString [Char]
    cap ((Ptr CChar -> IO [Char]) -> IO [Char])
    -> (Ptr CChar -> IO [Char]) -> IO [Char]
    forall a b. (a -> b) -> a -> b
    $ \Ptr CChar
    c_cap -> do
                    result <- Ptr CChar
    -> CLong
    -> CLong
    -> CLong
    -> CLong
    -> CLong
    -> CLong
    -> CLong
    -> CLong
    -> CLong
    -> IO (Ptr CChar)
    tparm Ptr CChar
    c_cap CLong
    p1 CLong
    p2 CLong
    p3 CLong
    p4 CLong
    p5 CLong
    p6 CLong
    p7 CLong
    p8 CLong
    p9
                    if result == nullPtr
                        then return ""
                        else peekCString result
              tparm' [CLong]
    _ = [Char] -> IO [Char]
    forall a. HasCallStack => [Char] -> IO a
    forall (m :: * -> *) a.
    (MonadFail m, HasCallStack) =>
    [Char] -> m a
    fail [Char]
    "tParm: List too short"

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

    fromStr :: LinesAffected -> String -> TermOutput
    fromStr :: Int -> [Char] -> TermOutput
    fromStr Int
    la [Char]
    s = ([TermOutputType] -> [TermOutputType]) -> TermOutput
    TermOutput (Int -> [Char] -> TermOutputType
    TOCmd Int
    la [Char]
    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.  Applies padding information to the string if
    -- necessary.
    tPuts :: String -> LinesAffected -> FunPtr CharOutput -> IO ()
    tPuts :: [Char] -> Int -> FunPtr CharOutput -> IO ()
    tPuts [Char]
    s Int
    n FunPtr CharOutput
    putc = [Char] -> (Ptr CChar -> IO ()) -> IO ()
    forall a. [Char] -> (Ptr CChar -> IO a) -> IO a
    withCString [Char]
    s ((Ptr CChar -> IO ()) -> IO ()) -> (Ptr CChar -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \Ptr CChar
    c_str -> Ptr CChar -> CInt -> FunPtr CharOutput -> IO ()
    tputs Ptr CChar
    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 => [Char] -> Capability f
    tiGetOutput1 [Char]
    str = do
        cap <- [Char] -> Capability [Char]
    tiGetStr [Char]
    str
        guard (hasOkPadding (undefined :: f) cap)
        f <- tParm cap
        return $ outputCap 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 :: [Char] -> [Char] -> Bool
    hasOkPadding [Char]
    _ = Bool -> Bool
    not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Char] -> Bool
    strHasPadding
        outputCap :: ([Int] -> [Char]) -> [Int] -> [Char]
    outputCap [Int] -> [Char]
    f [Int]
    xs = [Int] -> [Char]
    f ([Int] -> [Int]
    forall a. [a] -> [a]
    reverse [Int]
    xs)

    instance OutputCap TermOutput where
        hasOkPadding :: TermOutput -> [Char] -> Bool
    hasOkPadding TermOutput
    _ = Bool -> [Char] -> Bool
    forall a b. a -> b -> a
    const Bool
    True
        outputCap :: ([Int] -> [Char]) -> [Int] -> TermOutput
    outputCap [Int] -> [Char]
    f [Int]
    xs = Int -> [Char] -> TermOutput
    fromStr Int
    1 ([Char] -> TermOutput) -> [Char] -> TermOutput
    forall a b. (a -> b) -> a -> b
    $ [Int] -> [Char]
    f ([Int] -> [Char]) -> [Int] -> [Char]
    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] -> [Char]) -> [Int] -> p -> f
    outputCap [Int] -> [Char]
    f [Int]
    xs = \p
    x -> ([Int] -> [Char]) -> [Int] -> f
    forall f. OutputCap f => ([Int] -> [Char]) -> [Int] -> f
    outputCap [Int] -> [Char]
    f (p -> Int
    forall a. Enum a => a -> Int
    fromEnum p
    xInt -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    :[Int]
    xs)
        hasOkPadding :: (p -> f) -> [Char] -> Bool
    hasOkPadding p -> f
    _ = f -> [Char] -> Bool
    forall f. OutputCap f => f -> [Char] -> 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