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 = 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
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