{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 703
{-# LANGUAGE Trustworthy #-}
#endif
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
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup
#elif !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
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 term =
withCString term $ \c_term ->
with 0 $ \ret_ptr -> do
let stdOutput = 1
old_term <- set_curterm 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 <- set_curterm old_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 <- set_curterm cterm
x <- f
_ <- set_curterm old_term
return x
strHasPadding :: String -> Bool
strHasPadding [] = False
strHasPadding ('$':'<':_) = True
strHasPadding (_:cs) = strHasPadding cs
newtype TermOutput = TermOutput ([TermOutputType] -> [TermOutputType])
data TermOutputType = TOCmd LinesAffected String
| TOStr String
#if MIN_VERSION_base(4,9,0)
instance Semigroup TermOutput where
TermOutput xs <> TermOutput ys = TermOutput (xs . ys)
instance Monoid TermOutput where
mempty = TermOutput id
mappend = (<>)
#else
instance Monoid TermOutput where
mempty = TermOutput id
TermOutput xs `mappend` TermOutput ys = TermOutput (xs . ys)
#endif
termText :: String -> TermOutput
termText str = TermOutput (TOStr str :)
runTermOutput :: Terminal -> TermOutput -> IO ()
runTermOutput = hRunTermOutput stdout
hRunTermOutput :: Handle -> Terminal -> TermOutput -> IO ()
hRunTermOutput h term (TermOutput to) = do
putc_ptr <- mkCallback putc
withCurTerm term $ mapM_ (writeToTerm putc_ptr h) (to [])
freeHaskellFunPtr putc_ptr
hFlush h
where
putc c = let c' = toEnum $ fromEnum c
in hPutChar h c' >> hFlush h >> return c
writeToTerm :: FunPtr CharOutput -> Handle -> TermOutputType -> IO ()
writeToTerm putc h (TOCmd numLines s)
| strHasPadding s = tPuts s numLines putc
| otherwise = hPutStr h s
writeToTerm _ h (TOStr s) = hPutStr h s
infixl 2 <#>
(<#>) :: Monoid m => m -> m -> m
(<#>) = mappend
newtype Capability a = Capability (Terminal -> IO (Maybe a))
getCapability :: Terminal -> Capability a -> Maybe a
getCapability term (Capability f) = unsafePerformIO $ withCurTerm term (f term)
instance Functor Capability where
fmap f (Capability g) = Capability $ \t -> fmap (fmap f) (g t)
instance Applicative Capability where
pure = Capability . const . pure . Just
(<*>) = ap
instance Monad Capability where
return = pure
Capability f >>= g = Capability $ \t -> do
mx <- f t
case mx of
Nothing -> return Nothing
Just x -> let Capability g' = g x in g' t
instance Alternative Capability where
(<|>) = mplus
empty = mzero
instance MonadPlus Capability where
mzero = Capability (const $ return Nothing)
Capability f `mplus` Capability g = Capability $ \t -> do
mx <- f t
case mx of
Nothing -> g t
_ -> return mx
foreign import ccall tigetnum :: CString -> IO CInt
tiGetNum :: String -> Capability Int
tiGetNum cap = Capability $ const $ 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 $ const $ fmap (Just . (>0)) $
withCString cap tigetflag
tiGuardFlag :: String -> Capability ()
tiGuardFlag cap = tiGetFlag cap >>= guard
foreign import ccall tigetstr :: CString -> IO CString
{-# DEPRECATED tiGetStr "use tiGetOutput instead." #-}
tiGetStr :: String -> Capability String
tiGetStr cap = Capability $ const $ 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 -> Capability ([Int] -> String)
tParm cap = Capability $ \t -> return $ Just
$ \ps -> unsafePerformIO $ withCurTerm t $
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
if result == nullPtr
then return ""
else peekCString result
tparm' _ = fail "tParm: List too short"
tiGetOutput :: String -> Capability ([Int] -> LinesAffected -> TermOutput)
tiGetOutput cap = do
str <- tiGetStr cap
f <- tParm str
return $ \ps la -> fromStr la $ f ps
fromStr :: LinesAffected -> String -> TermOutput
fromStr la s = TermOutput (TOCmd la s :)
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
tiGetOutput1 :: forall f . OutputCap f => String -> Capability f
tiGetOutput1 str = do
cap <- tiGetStr str
guard (hasOkPadding (undefined :: f) cap)
f <- tParm cap
return $ outputCap f []
class OutputCap f where
hasOkPadding :: f -> String -> Bool
outputCap :: ([Int] -> String) -> [Int] -> f
instance OutputCap [Char] where
hasOkPadding _ = not . strHasPadding
outputCap f xs = f (reverse xs)
instance OutputCap TermOutput where
hasOkPadding _ = const True
outputCap f xs = fromStr 1 $ f $ reverse xs
instance (Enum p, OutputCap f) => OutputCap (p -> f) where
outputCap f xs = \x -> outputCap f (fromEnum x:xs)
hasOkPadding _ = hasOkPadding (undefined :: f)
class (Monoid s, OutputCap s) => TermStr s
instance TermStr [Char]
instance TermStr TermOutput