{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
module System.Console.Terminfo.Base(
Terminal(),
setupTerm,
setupTermFromEnv,
SetupTermError,
Capability,
getCapability,
tiGetFlag,
tiGuardFlag,
tiGetNum,
tiGetStr,
tiGetOutput1,
OutputCap,
TermStr,
TermOutput(),
runTermOutput,
hRunTermOutput,
termText,
tiGetOutput,
LinesAffected,
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)
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 ()
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
let stdOutput :: CInt
stdOutput = CInt
1
Ptr TERMINAL
old_term <- Ptr TERMINAL -> IO (Ptr TERMINAL)
set_curterm Ptr TERMINAL
forall a. Ptr a
nullPtr
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 a b. (a -> b) -> IO a -> IO b
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
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 a. [a] -> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
strHasPadding :: String -> Bool
strHasPadding :: String -> Bool
strHasPadding [] = Bool
False
strHasPadding (Char
'$':Char
'<':String
_) = Bool
True
strHasPadding (Char
_:String
cs) = String -> Bool
strHasPadding String
cs
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]
:)
runTermOutput :: Terminal -> TermOutput -> IO ()
runTermOutput :: Terminal -> TermOutput -> IO ()
runTermOutput = Handle -> Terminal -> TermOutput -> IO ()
hRunTermOutput Handle
stdout
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 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
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 <#>
(<#>) :: Monoid m => m -> m -> m
<#> :: forall m. Monoid m => m -> m -> m
(<#>) = m -> m -> m
forall m. Monoid m => m -> m -> m
mappend
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)
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
Maybe a
mx <- Terminal -> IO (Maybe a)
f Terminal
t
case Maybe a
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
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mx
foreign import ccall tigetnum :: CString -> IO CInt
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 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 (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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
foreign import ccall tigetflag :: CString -> IO CInt
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 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
$
String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
cap CString -> IO CInt
tigetflag
tiGuardFlag :: String -> Capability ()
tiGuardFlag :: String -> Capability ()
tiGuardFlag String
cap = String -> Capability Bool
tiGetFlag String
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." #-}
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 a. a -> IO a
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 a b. (a -> b) -> IO a -> IO b
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
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
-> IO CString
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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
else CString -> IO String
peekCString CString
result
tparm' [CLong]
_ = String -> IO String
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"tParm: List too short"
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 a. a -> Capability a
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 ()
type LinesAffected = Int
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
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 a. a -> Capability a
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 []
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)
class (Monoid s, OutputCap s) => TermStr s
instance TermStr [Char]
instance TermStr TermOutput