{-# 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 :: String -> IO Terminal
setupTerm String
term =
    forall a. String -> (CString -> IO a) -> IO a
withCString String
term forall a b. (a -> b) -> a -> b
$ \CString
c_term ->
    forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with CInt
0 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 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 <- forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
ret_ptr
        if (CInt
ret forall a. Eq a => a -> a -> Bool
/=CInt
1)
            then forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> SetupTermError
SetupTermError
                forall a b. (a -> b) -> a -> b
$ String
"Couldn't look up terminfo entry " forall a. [a] -> [a] -> [a]
++ 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
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignPtr TERMINAL -> Terminal
Terminal forall a b. (a -> b) -> a -> b
$ forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FunPtr (Ptr TERMINAL -> IO ())
del_curterm Ptr TERMINAL
cterm

data SetupTermError = SetupTermError String
                        deriving Typeable

instance Show SetupTermError where
    show :: SetupTermError -> String
show (SetupTermError String
str) = String
"setupTerm: " 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 <- forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOException -> IO String
handleBadEnv forall a b. (a -> b) -> a -> b
$ String -> IO String
getEnv String
"TERM" 
    let term :: String
term = if 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
_ = 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 = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr TERMINAL
term 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
        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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TermOutputType] -> [TermOutputType]
ys)

instance Monoid TermOutput where
    mempty :: TermOutput
mempty  = ([TermOutputType] -> [TermOutputType]) -> TermOutput
TermOutput forall a. a -> a
id
    mappend :: TermOutput -> TermOutput -> TermOutput
mappend = 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 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 forall {b}. Enum b => b -> IO b
putc
    forall a. Terminal -> IO a -> IO a
withCurTerm Terminal
term forall a b. (a -> b) -> a -> b
$ 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 [])
    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' = forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ forall a. Enum a => a -> Int
fromEnum b
c
             in Handle -> Char -> IO ()
hPutChar Handle
h Char
c' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
h forall (m :: * -> *) a b. Monad m => m a -> m b -> m 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
(<#>) = 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) = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ 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) = forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability forall a b. (a -> b) -> a -> b
$ \Terminal
t -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 = forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
    <*> :: forall a 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 = 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 = forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
(<|>) = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
    empty :: forall a. Capability a
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance MonadPlus Capability where
    mzero :: forall a. Capability a
mzero = forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability 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
_ -> 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 = forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
                Int
n <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Enum a => a -> Int
fromEnum (forall a. String -> (CString -> IO a) -> IO a
withCString String
cap CString -> IO CInt
tigetnum)
                if Int
n forall a. Ord a => a -> a -> Bool
>= Int
0
                    then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Int
n)
                    else forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ord a => a -> a -> Bool
>CInt
0)) forall a b. (a -> b) -> a -> b
$
                        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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
                CString
result <- forall a. String -> (CString -> IO a) -> IO a
withCString String
cap CString -> IO CString
tigetstr 
                if CString
result forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr Bool -> Bool -> Bool
|| CString
result forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
neg1Ptr
                    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                    else forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just (CString -> IO String
peekCString CString
result)
    where
        -- hack; tigetstr sometimes returns (-1)
        neg1Ptr :: Ptr b
neg1Ptr = forall a. Ptr a
nullPtr 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 = forall a. (Terminal -> IO (Maybe a)) -> Capability a
Capability forall a b. (a -> b) -> a -> b
$ \Terminal
t -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 
        forall a b. (a -> b) -> a -> b
$ \[Int]
ps -> forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. Terminal -> IO a -> IO a
withCurTerm Terminal
t forall a b. (a -> b) -> a -> b
$
                    [CLong] -> IO String
tparm' (forall a b. (a -> b) -> [a] -> [b]
map forall a. Enum a => Int -> a
toEnum [Int]
ps forall a. [a] -> [a] -> [a]
++ 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]
_)
            = forall a. String -> (CString -> IO a) -> IO a
withCString String
cap 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 forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr
                    then forall (m :: * -> *) a. Monad m => a -> m a
return String
""
                    else CString -> IO String
peekCString CString
result
          tparm' [CLong]
_ = 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \[Int]
ps Int
la -> Int -> String -> TermOutput
fromStr Int
la 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 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 :: String -> Int -> FunPtr CharOutput -> IO ()
tPuts String
s Int
n FunPtr CharOutput
putc = forall a. String -> (CString -> IO a) -> IO a
withCString String
s forall a b. (a -> b) -> a -> b
$ \CString
c_str -> CString -> CInt -> FunPtr CharOutput -> IO ()
tputs CString
c_str (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
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall f. OutputCap f => f -> String -> Bool
hasOkPadding (forall a. HasCallStack => a
undefined :: f) String
cap)
    [Int] -> String
f <- String -> Capability ([Int] -> String)
tParm String
cap
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 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 (forall a. [a] -> [a]
reverse [Int]
xs)

instance OutputCap TermOutput where
    hasOkPadding :: TermOutput -> String -> Bool
hasOkPadding TermOutput
_ = 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 forall a b. (a -> b) -> a -> b
$ [Int] -> String
f forall a b. (a -> b) -> a -> b
$ 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 -> forall f. OutputCap f => ([Int] -> String) -> [Int] -> f
outputCap [Int] -> String
f (forall a. Enum a => a -> Int
fromEnum p
xforall a. a -> [a] -> [a]
:[Int]
xs)
    hasOkPadding :: (p -> f) -> String -> Bool
hasOkPadding p -> f
_ = forall f. OutputCap f => f -> String -> Bool
hasOkPadding (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