{-# 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 =
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
let stdOutput :: CInt
stdOutput = CInt
1
Ptr TERMINAL
old_term <- Ptr TERMINAL -> IO (Ptr TERMINAL)
set_curterm forall a. Ptr a
nullPtr
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
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
""
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
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 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]
:)
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 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
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
(<#>) = 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) = 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)
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
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
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
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." #-}
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
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
-> IO CString
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"
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 ()
type LinesAffected = Int
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
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 []
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)
class (Monoid s, OutputCap s) => TermStr s
instance TermStr [Char]
instance TermStr TermOutput