module System.Console.Terminfo.Base(
Terminal(),
setupTerm,
setupTermFromEnv,
Capability,
getCapability,
tiGetFlag,
tiGuardFlag,
tiGetNum,
tiGetStr,
TermOutput(),
runTermOutput,
termText,
tiGetOutput,
LinesAffected,
tiGetOutput1,
OutputCap,
module Data.Monoid
) where
import Control.Monad
import Data.Monoid
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Marshal
import Foreign.Storable (peek,poke)
import System.Environment (getEnv)
import System.IO.Unsafe (unsafePerformIO)
data TERMINAL = TERMINAL
newtype Terminal = Terminal (ForeignPtr TERMINAL)
foreign import ccall "&" cur_term :: Ptr (Ptr TERMINAL)
foreign import ccall 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 term = withCString term $ \c_term ->
with 0 $ \ret_ptr -> do
let stdOutput = 1
old_term <- peek cur_term
poke cur_term nullPtr
setupterm c_term stdOutput ret_ptr
ret <- peek ret_ptr
when (ret /= 1) $ error ("Couldn't lookup terminfo entry " ++ show term)
cterm <- peek cur_term
poke cur_term old_term
fmap Terminal $ newForeignPtr del_curterm cterm
setupTermFromEnv :: IO Terminal
setupTermFromEnv = do
env_term <- getEnv "TERM"
let term = if null env_term then "dumb" else env_term
setupTerm term
withCurTerm :: Terminal -> IO a -> IO a
withCurTerm (Terminal term) f = withForeignPtr term set_curterm >> f
newtype Capability a = Capability (Terminal -> Maybe a)
getCapability :: Terminal -> Capability a -> Maybe a
getCapability term (Capability f) = f term
instance Functor Capability where
fmap f (Capability g) = Capability (fmap f . g)
instance Monad Capability where
return x = Capability (\_ -> Just x)
Capability f >>= g = Capability $ \t -> f t >>= getCapability t . g
Capability f >> Capability g = Capability $ \t -> f t >> g t
instance MonadPlus Capability where
mzero = Capability (\_ -> Nothing)
Capability f `mplus` Capability g = Capability (\t -> f t `mplus` g t)
foreign import ccall tigetnum :: CString -> IO CInt
tiGetNum :: String -> Capability Int
tiGetNum cap = Capability $ \term -> unsafePerformIO $ withCurTerm term $ do
n <- fmap fromEnum (withCString cap tigetnum)
if n >= 0
then return (Just n)
else return Nothing
foreign import ccall tigetflag :: CString -> IO CInt
tiGetFlag :: String -> Capability Bool
tiGetFlag cap = Capability $ \term ->
Just $ unsafePerformIO $ withCurTerm term $
fmap (>0) (withCString cap tigetflag)
tiGuardFlag :: String -> Capability ()
tiGuardFlag cap = tiGetFlag cap >>= guard
foreign import ccall tigetstr :: CString -> IO CString
tiGetStr :: String -> Capability String
tiGetStr cap = Capability $ \term -> unsafePerformIO $ withCurTerm term $ do
result <- withCString cap tigetstr
if result == nullPtr || result == neg1Ptr
then return Nothing
else fmap Just (peekCString result)
where
neg1Ptr = nullPtr `plusPtr` (1)
foreign import ccall tparm ::
CString -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong
-> CLong -> CLong -> CLong
-> IO CString
tParm :: String -> [Int] -> IO String
tParm cap ps = tparm' (map toEnum ps ++ repeat 0)
where tparm' (p1:p2:p3:p4:p5:p6:p7:p8:p9:_)
= withCString cap $ \c_cap -> do
result <- tparm c_cap p1 p2 p3 p4 p5 p6 p7 p8 p9
peekCString result
tiGetOutput :: String -> Capability ([Int] -> LinesAffected -> TermOutput)
tiGetOutput cap = flip fmap (tiGetStr cap) $
\str ps la -> TermOutput $ do
outStr <- tParm str ps
tPuts outStr la
type CharOutput = CInt -> IO CInt
foreign import ccall "wrapper" mkCallback :: CharOutput -> IO (FunPtr CharOutput)
c_putChar = unsafePerformIO $ mkCallback putc
where
putc c = let c' = toEnum $ fromEnum c
in putChar c' >> return c
foreign import ccall tputs :: CString -> CInt -> FunPtr CharOutput -> IO ()
type LinesAffected = Int
tPuts :: String -> LinesAffected -> IO ()
tPuts s n = withCString s $ \c_str -> tputs c_str (toEnum n) c_putChar
newtype TermOutput = TermOutput (IO ())
runTermOutput :: Terminal -> TermOutput -> IO ()
runTermOutput term (TermOutput to) = withCurTerm term to
termText :: String -> TermOutput
termText = TermOutput . putStr
instance Monoid TermOutput where
mempty = TermOutput $ return ()
TermOutput f `mappend` TermOutput g = TermOutput (f >> g)
class OutputCap f where
outputCap :: ([Int] -> TermOutput) -> [Int] -> f
instance OutputCap TermOutput where
outputCap f xs = f (reverse xs)
instance (Enum a, OutputCap f) => OutputCap (a -> f) where
outputCap f xs = \x -> outputCap f (fromEnum x:xs)
tiGetOutput1 :: OutputCap f => String -> Capability f
tiGetOutput1 str = fmap (\f -> outputCap (flip f 1) []) $ tiGetOutput str