module System.Console.Terminfo.Base(
Terminal(),
setupTerm,
setupTermFromEnv,
SetupTermError,
Capability,
getCapability,
tiGetFlag,
tiGuardFlag,
tiGetNum,
tiGetStr,
TermOutput(),
runTermOutput,
hRunTermOutput,
termText,
tiGetOutput,
LinesAffected,
tiGetOutput1,
OutputCap,
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)
import System.IO
import Control.Exception.Extensible
import Data.Typeable
data 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 = bracket (peek cur_term) (poke cur_term) $ \_ ->
withCString term $ \c_term ->
with 0 $ \ret_ptr -> do
let stdOutput = 1
poke cur_term nullPtr
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 <- peek cur_term
fmap Terminal $ newForeignPtr del_curterm cterm
data SetupTermError = SetupTermError String
deriving Typeable
instance Show SetupTermError where
show (SetupTermError str) = "setupTerm: " ++ str
instance Exception SetupTermError where
setupTermFromEnv :: IO Terminal
setupTermFromEnv = do
env_term <- handle handleBadEnv $ getEnv "TERM"
let term = if null env_term then "dumb" else env_term
setupTerm term
where
handleBadEnv :: IOException -> IO String
handleBadEnv _ = return ""
withCurTerm :: Terminal -> IO a -> IO a
withCurTerm (Terminal term) f = withForeignPtr term $ \cterm -> do
old_term <- peek cur_term
if old_term /= cterm
then do
set_curterm cterm
x <- f
set_curterm old_term
return x
else f
newtype Capability a = Capability (IO (Maybe a))
getCapability :: Terminal -> Capability a -> Maybe a
getCapability term (Capability f) = unsafePerformIO $ withCurTerm term f
instance Functor Capability where
fmap f (Capability g) = Capability (fmap (fmap f) g)
instance Monad Capability where
return = Capability . return . Just
Capability f >>= g = Capability $ do
mx <- f
case mx of
Nothing -> return Nothing
Just x -> let Capability g' = g x in g'
instance MonadPlus Capability where
mzero = Capability (return Nothing)
Capability f `mplus` Capability g = Capability $ do
mx <- f
case mx of
Nothing -> g
_ -> return mx
foreign import ccall tigetnum :: CString -> IO CInt
tiGetNum :: String -> Capability Int
tiGetNum cap = Capability $ 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 $ fmap (Just . (>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 $ 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
tparm' _ = fail "tParm: List too short"
tiGetOutput :: String -> Capability ([Int] -> LinesAffected -> TermOutput)
tiGetOutput cap = flip fmap (tiGetStr cap) $
\str ps la -> TermOutput $ \_ putc -> do
outStr <- tParm str ps
tPuts outStr la putc
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 s n putc = withCString s $ \c_str -> tputs c_str (toEnum n) putc
newtype TermOutput = TermOutput (Handle -> FunPtr CharOutput -> IO ())
runTermOutput :: Terminal -> TermOutput -> IO ()
runTermOutput = hRunTermOutput stdout
hRunTermOutput :: Handle -> Terminal -> TermOutput -> IO ()
hRunTermOutput h term (TermOutput to) = do
putc_ptr <- mkCallback putc
withCurTerm term (to h putc_ptr)
freeHaskellFunPtr putc_ptr
where
putc c = let c' = toEnum $ fromEnum c
in hPutChar h c' >> hFlush h >> return c
termText :: String -> TermOutput
termText str = TermOutput $ \h _ -> hPutStr h str >> hFlush h
instance Monoid TermOutput where
mempty = TermOutput $ \_ _ -> return ()
TermOutput f `mappend` TermOutput g = TermOutput $ \h putc -> f h putc >> g h putc
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
infixl 2 <#>
(<#>) :: Monoid m => m -> m -> m
(<#>) = mappend