1{-# LANGUAGE DeriveDataTypeable #-} 2{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE ScopedTypeVariables #-} 4{-# LANGUAGE Trustworthy #-} 5-- | 6-- Maintainer : judah.jacobson@gmail.com 7-- Stability : experimental 8-- Portability : portable (FFI) 9-- 10-- This module provides a low-level interface to the C functions of the 11-- terminfo library. 12-- 13-- NOTE: Since this library is built on top of the curses interface, it is not thread-safe. 14 15module System.Console.Terminfo.Base( 16 -- * Initialization 17 Terminal(), 18 setupTerm, 19 setupTermFromEnv, 20 SetupTermError, 21 -- * Capabilities 22 Capability, 23 getCapability, 24 tiGetFlag, 25 tiGuardFlag, 26 tiGetNum, 27 tiGetStr, 28 -- * Output 29 -- $outputdoc 30 tiGetOutput1, 31 OutputCap, 32 TermStr, 33 -- ** TermOutput 34 TermOutput(), 35 runTermOutput, 36 hRunTermOutput, 37 termText, 38 tiGetOutput, 39 LinesAffected, 40 -- ** Monoid functions 41 Monoid(..), 42 (<#>), 43 ) where 44 45 46import Control.Applicative 47import Control.Monad 48import Data.Semigroup as Sem (Semigroup(..)) 49import Foreign.C 50import Foreign.ForeignPtr 51import Foreign.Ptr 52import Foreign.Marshal 53import Foreign.Storable (peek) 54import System.Environment (getEnv) 55import System.IO.Unsafe (unsafePerformIO) 56import System.IO 57import Control.Exception 58import Data.Typeable 59 60 61data TERMINAL 62newtype Terminal = Terminal (ForeignPtr TERMINAL) 63 64-- Use "unsafe" to make set_curterm faster since it's called quite a bit. 65foreign import ccall unsafe set_curterm :: Ptr TERMINAL -> IO (Ptr TERMINAL) 66foreign import ccall "&" del_curterm :: FunPtr (Ptr TERMINAL -> IO ()) 67 68foreign import ccall setupterm :: CString -> CInt -> Ptr CInt -> IO () 69 70-- | Initialize the terminfo library to the given terminal entry. 71-- 72-- Throws a 'SetupTermError' if the terminfo database could not be read. 73setupTerm :: String -> IO Terminal 74setupTerm term = 75 withCString term $ \c_term -> 76 with 0 $ \ret_ptr -> do 77 -- NOTE: I believe that for the way we use terminfo 78 -- (i.e. custom output function) 79 -- this parameter does not affect anything. 80 let stdOutput = 1 81 -- Save the previous terminal to be restored after calling setupterm. 82 old_term <- set_curterm nullPtr 83 -- Call setupterm and check the return value. 84 setupterm c_term stdOutput ret_ptr 85 ret <- peek ret_ptr 86 if (ret /=1) 87 then throwIO $ SetupTermError 88 $ "Couldn't look up terminfo entry " ++ show term 89 else do 90 cterm <- set_curterm old_term 91 fmap Terminal $ newForeignPtr del_curterm cterm 92 93data SetupTermError = SetupTermError String 94 deriving Typeable 95 96instance Show SetupTermError where 97 show (SetupTermError str) = "setupTerm: " ++ str 98 99instance Exception SetupTermError where 100 101-- | Initialize the terminfo library, using the @TERM@ environmental variable. 102-- If @TERM@ is not set, we use the generic, minimal entry @dumb@. 103-- 104-- Throws a 'SetupTermError' if the terminfo database could not be read. 105setupTermFromEnv :: IO Terminal 106setupTermFromEnv = do 107 env_term <- handle handleBadEnv $ getEnv "TERM" 108 let term = if null env_term then "dumb" else env_term 109 setupTerm term 110 where 111 handleBadEnv :: IOException -> IO String 112 handleBadEnv _ = return "" 113 114-- TODO: this isn't really thread-safe... 115withCurTerm :: Terminal -> IO a -> IO a 116withCurTerm (Terminal term) f = withForeignPtr term $ \cterm -> do 117 old_term <- set_curterm cterm 118 x <- f 119 _ <- set_curterm old_term 120 return x 121 122 123---------------------- 124 125-- Note I'm relying on this working even for strings with unset parameters. 126strHasPadding :: String -> Bool 127strHasPadding [] = False 128strHasPadding ('$':'<':_) = True 129strHasPadding (_:cs) = strHasPadding cs 130 131-- | An action which sends output to the terminal. That output may mix plain text with control 132-- characters and escape sequences, along with delays (called \"padding\") required by some older 133-- terminals. 134 135-- We structure this similarly to ShowS, so that appends don't cause space leaks. 136newtype TermOutput = TermOutput ([TermOutputType] -> [TermOutputType]) 137 138data TermOutputType = TOCmd LinesAffected String 139 | TOStr String 140 141instance Sem.Semigroup TermOutput where 142 TermOutput xs <> TermOutput ys = TermOutput (xs . ys) 143 144instance Monoid TermOutput where 145 mempty = TermOutput id 146 mappend = (<>) 147 148termText :: String -> TermOutput 149termText str = TermOutput (TOStr str :) 150 151-- | Write the terminal output to the standard output device. 152runTermOutput :: Terminal -> TermOutput -> IO () 153runTermOutput = hRunTermOutput stdout 154 155-- | Write the terminal output to the terminal or file managed by the given 156-- 'Handle'. 157hRunTermOutput :: Handle -> Terminal -> TermOutput -> IO () 158hRunTermOutput h term (TermOutput to) = do 159 putc_ptr <- mkCallback putc 160 withCurTerm term $ mapM_ (writeToTerm putc_ptr h) (to []) 161 freeHaskellFunPtr putc_ptr 162 hFlush h 163 where 164 putc c = let c' = toEnum $ fromEnum c 165 in hPutChar h c' >> hFlush h >> return c 166 167-- NOTE: Currently, the output is checked every time tparm is called. 168-- It might be faster to check for padding once in tiGetOutput1. 169writeToTerm :: FunPtr CharOutput -> Handle -> TermOutputType -> IO () 170writeToTerm putc h (TOCmd numLines s) 171 | strHasPadding s = tPuts s numLines putc 172 | otherwise = hPutStr h s 173writeToTerm _ h (TOStr s) = hPutStr h s 174 175infixl 2 <#> 176 177-- | An operator version of 'mappend'. 178(<#>) :: Monoid m => m -> m -> m 179(<#>) = mappend 180--------------------------------- 181 182-- | A feature or operation which a 'Terminal' may define. 183newtype Capability a = Capability (Terminal -> IO (Maybe a)) 184 185getCapability :: Terminal -> Capability a -> Maybe a 186getCapability term (Capability f) = unsafePerformIO $ withCurTerm term (f term) 187 188-- Note that the instances for Capability of Functor, Monad and MonadPlus 189-- use the corresponding instances for Maybe. 190instance Functor Capability where 191 fmap f (Capability g) = Capability $ \t -> fmap (fmap f) (g t) 192 193instance Applicative Capability where 194 pure = Capability . const . pure . Just 195 (<*>) = ap 196 197instance Monad Capability where 198 return = pure 199 Capability f >>= g = Capability $ \t -> do 200 mx <- f t 201 case mx of 202 Nothing -> return Nothing 203 Just x -> let Capability g' = g x in g' t 204 205instance Alternative Capability where 206 (<|>) = mplus 207 empty = mzero 208 209instance MonadPlus Capability where 210 mzero = Capability (const $ return Nothing) 211 Capability f `mplus` Capability g = Capability $ \t -> do 212 mx <- f t 213 case mx of 214 Nothing -> g t 215 _ -> return mx 216 217foreign import ccall tigetnum :: CString -> IO CInt 218 219-- | Look up a numeric capability in the terminfo database. 220tiGetNum :: String -> Capability Int 221tiGetNum cap = Capability $ const $ do 222 n <- fmap fromEnum (withCString cap tigetnum) 223 if n >= 0 224 then return (Just n) 225 else return Nothing 226 227foreign import ccall tigetflag :: CString -> IO CInt 228-- | Look up a boolean capability in the terminfo database. 229-- 230-- Unlike 'tiGuardFlag', this capability never fails; it returns 'False' if the 231-- capability is absent or set to false, and returns 'True' otherwise. 232-- 233tiGetFlag :: String -> Capability Bool 234tiGetFlag cap = Capability $ const $ fmap (Just . (>0)) $ 235 withCString cap tigetflag 236 237-- | Look up a boolean capability in the terminfo database, and fail if 238-- it\'s not defined. 239tiGuardFlag :: String -> Capability () 240tiGuardFlag cap = tiGetFlag cap >>= guard 241 242foreign import ccall tigetstr :: CString -> IO CString 243 244{-# DEPRECATED tiGetStr "use tiGetOutput instead." #-} 245-- | Look up a string capability in the terminfo database. NOTE: This function is deprecated; use 246-- 'tiGetOutput1' instead. 247tiGetStr :: String -> Capability String 248tiGetStr cap = Capability $ const $ do 249 result <- withCString cap tigetstr 250 if result == nullPtr || result == neg1Ptr 251 then return Nothing 252 else fmap Just (peekCString result) 253 where 254 -- hack; tigetstr sometimes returns (-1) 255 neg1Ptr = nullPtr `plusPtr` (-1) 256 257 258--------------- 259 260 261 262foreign import ccall tparm :: 263 CString -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong 264 -> CLong -> CLong -> CLong -- p1,...,p9 265 -> IO CString 266 267-- Note: I may want to cut out the middleman and pipe tGoto/tGetStr together 268-- with tput without a String marshall in the middle. 269-- directly without 270 271tParm :: String -> Capability ([Int] -> String) 272tParm cap = Capability $ \t -> return $ Just 273 $ \ps -> unsafePerformIO $ withCurTerm t $ 274 tparm' (map toEnum ps ++ repeat 0) 275 where tparm' (p1:p2:p3:p4:p5:p6:p7:p8:p9:_) 276 = withCString cap $ \c_cap -> do 277 result <- tparm c_cap p1 p2 p3 p4 p5 p6 p7 p8 p9 278 if result == nullPtr 279 then return "" 280 else peekCString result 281 tparm' _ = fail "tParm: List too short" 282 283-- | Look up an output capability in the terminfo database. 284tiGetOutput :: String -> Capability ([Int] -> LinesAffected -> TermOutput) 285tiGetOutput cap = do 286 str <- tiGetStr cap 287 f <- tParm str 288 return $ \ps la -> fromStr la $ f ps 289 290fromStr :: LinesAffected -> String -> TermOutput 291fromStr la s = TermOutput (TOCmd la s :) 292 293type CharOutput = CInt -> IO CInt 294 295foreign import ccall "wrapper" mkCallback :: CharOutput -> IO (FunPtr CharOutput) 296 297foreign import ccall tputs :: CString -> CInt -> FunPtr CharOutput -> IO () 298 299-- | A parameter to specify the number of lines affected. Some capabilities 300-- (e.g., @clear@ and @dch1@) use 301-- this parameter on some terminals to compute variable-length padding. 302type LinesAffected = Int 303 304-- | Output a string capability. Applys padding information to the string if 305-- necessary. 306tPuts :: String -> LinesAffected -> FunPtr CharOutput -> IO () 307tPuts s n putc = withCString s $ \c_str -> tputs c_str (toEnum n) putc 308 309 310-- | Look up an output capability which takes a fixed number of parameters 311-- (for example, @Int -> Int -> TermOutput@). 312-- 313-- For capabilities which may contain variable-length 314-- padding, use 'tiGetOutput' instead. 315tiGetOutput1 :: forall f . OutputCap f => String -> Capability f 316tiGetOutput1 str = do 317 cap <- tiGetStr str 318 guard (hasOkPadding (undefined :: f) cap) 319 f <- tParm cap 320 return $ outputCap f [] 321 322 323-- OK, this is the structure that I want: 324class OutputCap f where 325 hasOkPadding :: f -> String -> Bool 326 outputCap :: ([Int] -> String) -> [Int] -> f 327 328instance OutputCap [Char] where 329 hasOkPadding _ = not . strHasPadding 330 outputCap f xs = f (reverse xs) 331 332instance OutputCap TermOutput where 333 hasOkPadding _ = const True 334 outputCap f xs = fromStr 1 $ f $ reverse xs 335 336instance (Enum p, OutputCap f) => OutputCap (p -> f) where 337 outputCap f xs = \x -> outputCap f (fromEnum x:xs) 338 hasOkPadding _ = hasOkPadding (undefined :: f) 339 340 341{- $outputdoc 342Terminfo contains many string capabilities for special effects. 343For example, the @cuu1@ capability moves the cursor up one line; on ANSI terminals 344this is accomplished by printing the control sequence @\"\\ESC[A\"@. 345However, some older terminals also require \"padding\", or short pauses, after certain commands. 346For example, when @TERM=vt100@ the @cuu1@ capability is @\"\\ESC[A$\<2\>\"@, which instructs terminfo 347to pause for two milliseconds after outputting the control sequence. 348 349The 'TermOutput' monoid abstracts away all padding and control 350sequence output. Unfortunately, that datatype is difficult to integrate into existing 'String'-based APIs 351such as pretty-printers. Thus, as a workaround, 'tiGetOutput1' also lets us access the control sequences as 'String's. The one caveat is that it will not allow you to access padded control sequences as Strings. For example: 352 353 > > t <- setupTerm "vt100" 354 > > isJust (getCapability t (tiGetOutput1 "cuu1") :: Maybe String) 355 > False 356 > > isJust (getCapability t (tiGetOutput1 "cuu1") :: Maybe TermOutput) 357 > True 358 359'String' capabilities will work with software-based terminal types such as @xterm@ and @linux@. 360However, you should use 'TermOutput' if compatibility with older terminals is important. 361Additionally, the @visualBell@ capability which flashes the screen usually produces its effect with a padding directive, so it will only work with 'TermOutput'. 362 363-} 364 365 366class (Monoid s, OutputCap s) => TermStr s 367 368instance TermStr [Char] 369instance TermStr TermOutput 370