terminfo 0.3.0.2 → 0.3.1
raw patch · 9 files changed
+437/−128 lines, 9 files
Files
- System/Console/Terminfo.hs +3/−1
- System/Console/Terminfo/Base.hs +145/−72
- System/Console/Terminfo/Color.hs +118/−0
- System/Console/Terminfo/Cursor.hs +28/−24
- System/Console/Terminfo/Edit.hs +2/−2
- System/Console/Terminfo/Effects.hs +120/−12
- System/Console/Terminfo/Keys.hs +11/−11
- configure.ac +3/−3
- terminfo.cabal +7/−3
System/Console/Terminfo.hs view
@@ -8,7 +8,8 @@ module System.Console.Terminfo.Keys, module System.Console.Terminfo.Cursor, module System.Console.Terminfo.Effects,- module System.Console.Terminfo.Edit+ module System.Console.Terminfo.Edit,+ module System.Console.Terminfo.Color ) where import System.Console.Terminfo.Base@@ -16,3 +17,4 @@ import System.Console.Terminfo.Cursor import System.Console.Terminfo.Edit import System.Console.Terminfo.Effects+import System.Console.Terminfo.Color
System/Console/Terminfo/Base.hs view
@@ -22,17 +22,20 @@ tiGetNum, tiGetStr, -- * Output+ -- $outputdoc+ tiGetOutput1,+ OutputCap,+ TermStr,+ -- ** TermOutput TermOutput(), runTermOutput, hRunTermOutput, termText, tiGetOutput, LinesAffected,- tiGetOutput1,- OutputCap, -- ** Monoid functions Monoid(..),- (<#>)+ (<#>), ) where @@ -50,7 +53,7 @@ import Data.Typeable -data TERMINAL = TERMINAL+data TERMINAL newtype Terminal = Terminal (ForeignPtr TERMINAL) foreign import ccall "&" cur_term :: Ptr (Ptr TERMINAL)@@ -107,49 +110,102 @@ handleBadEnv :: IOException -> IO String handleBadEnv _ = return "" +-- TODO: this isn't really thread-safe... 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+ _ <- set_curterm cterm x <- f- set_curterm old_term+ _ <- set_curterm old_term return x else f ++----------------------++-- Note I'm relying on this working even for strings with unset parameters.+strHasPadding :: String -> Bool+strHasPadding [] = False+strHasPadding ('$':'<':_) = True+strHasPadding (_:cs) = strHasPadding cs++-- | An action which sends output to the terminal. That output may mix plain text with control+-- characters and escape sequences, along with delays (called \"padding\") required by some older+-- terminals.++-- We structure this similarly to ShowS, so that appends don't cause space leaks.+newtype TermOutput = TermOutput ([TermOutputType] -> [TermOutputType])++data TermOutputType = TOCmd LinesAffected String+ | TOStr String++instance Monoid TermOutput where+ mempty = TermOutput id+ TermOutput xs `mappend` TermOutput ys = TermOutput (xs . ys)++termText :: String -> TermOutput +termText str = TermOutput (TOStr str :)++-- | Write the terminal output to the standard output device.+runTermOutput :: Terminal -> TermOutput -> IO ()+runTermOutput = hRunTermOutput stdout++-- | Write the terminal output to the terminal or file managed by the given+-- 'Handle'.+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+ where+ putc c = let c' = toEnum $ fromEnum c+ in hPutChar h c' >> hFlush h >> return c++writeToTerm :: FunPtr CharOutput -> Handle -> TermOutputType -> IO ()+writeToTerm putc _ (TOCmd numLines s) = tPuts s numLines putc+writeToTerm _ h (TOStr s) = hPutStr h s >> hFlush h++infixl 2 <#>++-- | An operator version of 'mappend'.+(<#>) :: Monoid m => m -> m -> m+(<#>) = mappend+---------------------------------+ -- | A feature or operation which a 'Terminal' may define.-newtype Capability a = Capability (IO (Maybe a))+newtype Capability a = Capability (Terminal -> IO (Maybe a)) getCapability :: Terminal -> Capability a -> Maybe a-getCapability term (Capability f) = unsafePerformIO $ withCurTerm term f+getCapability term (Capability f) = unsafePerformIO $ withCurTerm term (f term) -- Note that the instances for Capability of Functor, Monad and MonadPlus -- use the corresponding instances for Maybe. instance Functor Capability where- fmap f (Capability g) = Capability (fmap (fmap f) g) + fmap f (Capability g) = Capability $ \t -> fmap (fmap f) (g t) instance Monad Capability where- return = Capability . return . Just- Capability f >>= g = Capability $ do- mx <- f+ return = Capability . const . return . Just+ Capability f >>= g = Capability $ \t -> do+ mx <- f t case mx of Nothing -> return Nothing- Just x -> let Capability g' = g x in g'+ Just x -> let Capability g' = g x in g' t instance MonadPlus Capability where- mzero = Capability (return Nothing)- Capability f `mplus` Capability g = Capability $ do- mx <- f+ mzero = Capability (const $ return Nothing)+ Capability f `mplus` Capability g = Capability $ \t -> do+ mx <- f t case mx of- Nothing -> g+ Nothing -> g t _ -> return mx foreign import ccall tigetnum :: CString -> IO CInt -- | Look up a numeric capability in the terminfo database. tiGetNum :: String -> Capability Int -tiGetNum cap = Capability $ do+tiGetNum cap = Capability $ const $ do n <- fmap fromEnum (withCString cap tigetnum) if n >= 0 then return (Just n)@@ -162,7 +218,7 @@ -- capability is absent or set to false, and returns 'True' otherwise. -- tiGetFlag :: String -> Capability Bool-tiGetFlag cap = Capability $ fmap (Just . (>0)) $+tiGetFlag cap = Capability $ const $ fmap (Just . (>0)) $ withCString cap tigetflag -- | Look up a boolean capability in the terminfo database, and fail if@@ -172,12 +228,11 @@ foreign import ccall tigetstr :: CString -> IO CString --- | Look up a string capability in the terminfo database. ------ Note: Do not use this function for terminal output; use 'tiGetOutput'--- instead.+{-# DEPRECATED tiGetStr "use tiGetOutput instead." #-} +-- | Look up a string capability in the terminfo database. NOTE: This function is deprecated; use+-- 'tiGetOutput1' instead. tiGetStr :: String -> Capability String-tiGetStr cap = Capability $ do+tiGetStr cap = Capability $ const $ do result <- withCString cap tigetstr if result == nullPtr || result == neg1Ptr then return Nothing@@ -185,31 +240,41 @@ where -- hack; tigetstr sometimes returns (-1) neg1Ptr = nullPtr `plusPtr` (-1)+++---------------++ foreign import ccall tparm :: CString -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -> CLong -- p1,...,p9 -> IO CString - -- Note: I may want to cut out the middleman and pipe tGoto/tGetStr together -- with tput without a String marshall in the middle. -- directly without -tParm :: String -> [Int] -> IO String-tParm cap ps = tparm' (map toEnum ps ++ repeat 0)+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 peekCString result+ tparm' _ = fail "tParm: List too short" -- | Look up an output capability in the terminfo database. 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+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)@@ -226,56 +291,64 @@ tPuts :: String -> LinesAffected -> FunPtr CharOutput -> IO () tPuts s n putc = withCString s $ \c_str -> tputs c_str (toEnum n) putc --- | An action which sends output to the terminal. That output may mix plain text with control--- characters and escape sequences, along with delays (called \"padding\") required by some older--- terminals.-newtype TermOutput = TermOutput (Handle -> FunPtr CharOutput -> IO ()) --- | Write the terminal output to the standard output device.-runTermOutput :: Terminal -> TermOutput -> IO ()-runTermOutput = hRunTermOutput stdout+-- | Look up an output capability which takes a fixed number of parameters+-- (for example, @Int -> Int -> TermOutput@).+-- +-- For capabilities which may contain variable-length+-- padding, use 'tiGetOutput' instead.+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 [] --- | Write the terminal output to the terminal or file managed by the given--- 'Handle'.-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 --- | Output plain text containing no control characters or escape sequences.-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 ---- | A type class to encapsulate capabilities which take in zero or more --- parameters.+-- OK, this is the structure that I want: class OutputCap f where- outputCap :: ([Int] -> TermOutput) -> [Int] -> f+ hasOkPadding :: f -> String -> Bool+ outputCap :: ([Int] -> String) -> [Int] -> f -instance OutputCap TermOutput where+instance OutputCap [Char] where+ hasOkPadding _ = not . strHasPadding outputCap f xs = f (reverse xs) -instance (Enum a, OutputCap f) => OutputCap (a -> f) where+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) --- | Look up an output capability which takes a fixed number of parameters--- (for example, @Int -> Int -> TermOutput@).--- --- For capabilities which may contain variable-length--- padding, use 'tiGetOutput' instead.-tiGetOutput1 :: OutputCap f => String -> Capability f-tiGetOutput1 str = fmap (\f -> outputCap (flip f 1) []) $ tiGetOutput str -infixl 2 <#>+{- $outputdoc+Terminfo contains many string capabilities for special effects.+For example, the @cuu1@ capability moves the cursor up one line; on ANSI terminals+this is accomplished by printing the control sequence @\"\\ESC[A\"@.+However, some older terminals also require \"padding\", or short pauses, after certain commands.+For example, when @TERM=vt100@ the @cuu1@ capability is @\"\\ESC[A$\<2\>\"@, which instructs terminfo+to pause for two milliseconds after outputting the control sequence. --- | An operator version of 'mappend'.-(<#>) :: Monoid m => m -> m -> m-(<#>) = mappend+The 'TermOutput' monoid abstracts away all padding and control+sequence output. Unfortunately, that datatype is difficult to integrate into existing 'String'-based APIs+such 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: + > > t <- setupTerm "vt100"+ > > isJust (getCapability t (tiGetOutput1 "cuu1") :: Maybe String)+ > False+ > > isJust (getCapability t (tiGetOutput1 "cuu1") :: Maybe TermOutput)+ > True++'String' capabilities will work with software-based terminal types such as @xterm@ and @linux@.+However, you should use 'TermOutput' if compatibility with older terminals is important.+Additionally, the @visualBell@ capability which flashes the screen usually produces its effect with a padding directive, so it will only work with 'TermOutput'.++-}+++class (Monoid s, OutputCap s) => TermStr s++instance TermStr [Char]+instance TermStr TermOutput
+ System/Console/Terminfo/Color.hs view
@@ -0,0 +1,118 @@+-- |+-- Maintainer : judah.jacobson@gmail.com+-- Stability : experimental+-- Portability : portable (FFI)+module System.Console.Terminfo.Color(+ termColors,+ Color(..),+ -- ColorPair,+ withForegroundColor,+ withBackgroundColor,+ -- withColorPair,+ setForegroundColor,+ setBackgroundColor,+ -- setColorPair,+ restoreDefaultColors+ ) where++import System.Console.Terminfo.Base+import Control.Monad (mplus)++-- TODOs:+-- examples+-- try with xterm-256-colors (?)+-- Color pairs, and HP terminals.+-- TODO: this "white" looks more like a grey. (What does ncurses do?)++-- NB: for all the terminals in ncurses' terminfo.src, colors>=8 when it's+-- set. So we don't need to perform that check.++-- | The maximum number of of colors on the screen.+termColors :: Capability Int+termColors = tiGetNum "colors"++data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan+ | White | ColorNumber Int+++colorIntA, colorInt :: Color -> Int+colorIntA c = case c of+ Black -> 0+ Red -> 1+ Green -> 2+ Yellow -> 3+ Blue -> 4+ Magenta -> 5+ Cyan -> 6+ White -> 7+ ColorNumber n -> n+colorInt c = case c of+ Black -> 0+ Blue -> 1+ Green -> 2+ Cyan -> 3+ Red -> 4+ Magenta -> 5+ Yellow -> 6+ White -> 7+ ColorNumber n -> n+++-- NB these aren't available on HP systems.+-- also do we want to handle case when they're not available?++-- | This capability temporarily sets the+-- terminal's foreground color while outputting the given text, and+-- then restores the terminal to its default foreground and background+-- colors.+withForegroundColor :: TermStr s => Capability (Color -> s -> s)+withForegroundColor = withColorCmd setForegroundColor++-- | This capability temporarily sets the+-- terminal's background color while outputting the given text, and+-- then restores the terminal to its default foreground and background+-- colors.+withBackgroundColor :: TermStr s => Capability (Color -> s -> s)+withBackgroundColor = withColorCmd setBackgroundColor++withColorCmd :: TermStr s => Capability (a -> s)+ -> Capability (a -> s -> s)+withColorCmd getSet = do+ set <- getSet+ restore <- restoreDefaultColors+ return $ \c t -> set c <#> t <#> restore++-- | Sets the foreground color of all further text output, using+-- either the @setaf@ or @setf@ capability.+setForegroundColor :: TermStr s => Capability (Color -> s)+setForegroundColor = setaf `mplus` setf+ where+ setaf = fmap (. colorIntA) $ tiGetOutput1 "setaf"+ setf = fmap (. colorInt) $ tiGetOutput1 "setf"++-- | Sets the background color of all further text output, using+-- either the @setab@ or @setb@ capability.+setBackgroundColor :: TermStr s => Capability (Color -> s)+setBackgroundColor = setab `mplus` setb+ where+ setab = fmap (. colorIntA) $ tiGetOutput1 "setab"+ setb = fmap (. colorInt) $ tiGetOutput1 "setb"++{-+withColorPair :: TermStr s => Capability (ColorPair -> s -> s)+withColorPair = withColorCmd setColorPair++setColorPair :: TermStr s => Capability (ColorPair -> s)+setColorPair = do+ setf <- setForegroundColor+ setb <- setBackgroundColor+ return (\(f,b) -> setf f <#> setb b)++type ColorPair = (Color,Color)+-} +++-- | Restores foreground/background colors to their original+-- settings.+restoreDefaultColors :: TermStr s => Capability s +restoreDefaultColors = tiGetOutput1 "op"
System/Console/Terminfo/Cursor.hs view
@@ -38,6 +38,8 @@ cursorLeft, cursorRight, cursorUp, + cursorHome,+ cursorToLL, -- * Absolute cursor movements cursorAddress, Point(..),@@ -89,46 +91,48 @@ moveDown only use cud1 if it's not '\n'. Suggestions are welcome. --}-cursorDown1Fixed :: Capability TermOutput+cursorDown1Fixed :: TermStr s => Capability s cursorDown1Fixed = do- str <- tiGetStr "cud1"+ str <- tiGetOutput1 "cud1" guard (str /= "\n") tiGetOutput1 "cud1" -cursorDown1 :: Capability TermOutput+cursorDown1 :: TermStr s => Capability s cursorDown1 = tiGetOutput1 "cud1" -cursorLeft1 :: Capability TermOutput+cursorLeft1 :: TermStr s => Capability s cursorLeft1 = tiGetOutput1 "cub1" -cursorRight1 :: Capability TermOutput+cursorRight1 :: TermStr s => Capability s cursorRight1 = tiGetOutput1 "cuf1" -cursorUp1 :: Capability TermOutput+cursorUp1 :: TermStr s => Capability s cursorUp1 = tiGetOutput1 "cuu1" -cursorDown :: Capability (Int -> TermOutput)+cursorDown :: TermStr s => Capability (Int -> s) cursorDown = tiGetOutput1 "cud" -cursorLeft :: Capability (Int -> TermOutput)+cursorLeft :: TermStr s => Capability (Int -> s) cursorLeft = tiGetOutput1 "cub" -cursorRight :: Capability (Int -> TermOutput)+cursorRight :: TermStr s => Capability (Int -> s) cursorRight = tiGetOutput1 "cuf" -cursorUp :: Capability (Int -> TermOutput)+cursorUp :: TermStr s => Capability (Int -> s) cursorUp = tiGetOutput1 "cuu" -cursorHome :: Capability TermOutput+cursorHome :: TermStr s => Capability s cursorHome = tiGetOutput1 "home" -cursorToLL :: Capability TermOutput+cursorToLL :: TermStr s => Capability s cursorToLL = tiGetOutput1 "ll" -- Movements are built out of parametrized and unparam'd movement -- capabilities. -- todo: more complicated logic like ncurses does.+move :: TermStr s => Capability s -> Capability (Int -> s)+ -> Capability (Int -> s) move single param = let tryBoth = do s <- single@@ -136,56 +140,56 @@ return $ \n -> case n of 0 -> mempty 1 -> s- n -> p n+ _ -> p n manySingle = do s <- single return $ \n -> mconcat $ replicate n s in tryBoth `mplus` param `mplus` manySingle -moveLeft :: Capability (Int -> TermOutput)+moveLeft :: TermStr s => Capability (Int -> s) moveLeft = move cursorLeft1 cursorLeft -moveRight :: Capability (Int -> TermOutput)+moveRight :: TermStr s => Capability (Int -> s) moveRight = move cursorRight1 cursorRight -moveUp :: Capability (Int -> TermOutput)+moveUp :: TermStr s => Capability (Int -> s) moveUp = move cursorUp1 cursorUp -moveDown :: Capability (Int -> TermOutput)+moveDown :: TermStr s => Capability (Int -> s) moveDown = move cursorDown1Fixed cursorDown -- | The @cr@ capability, which moves the cursor to the first column of the -- current line.-carriageReturn :: Capability TermOutput+carriageReturn :: TermStr s => Capability s carriageReturn = tiGetOutput1 "cr" -- | The @nel@ capability, which moves the cursor to the first column of -- the next line. It behaves like a carriage return followed by a line feed. -- -- If @nel@ is not defined, this may be built out of other capabilities.-newline :: Capability TermOutput+newline :: TermStr s => Capability s newline = tiGetOutput1 "nel" `mplus` (liftM2 mappend carriageReturn (scrollForward `mplus` tiGetOutput1 "cud1")) -- Note it's OK to use cud1 here, despite the stty problem referenced -- above, because carriageReturn already puts us on the first column. -scrollForward :: Capability TermOutput+scrollForward :: TermStr s => Capability s scrollForward = tiGetOutput1 "ind" -scrollReverse :: Capability TermOutput+scrollReverse :: TermStr s => Capability s scrollReverse = tiGetOutput1 "ri" data Point = Point {row, col :: Int} -cursorAddress :: Capability (Point -> TermOutput)+cursorAddress :: TermStr s => Capability (Point -> s) cursorAddress = fmap (\g p -> g (row p) (col p)) $ tiGetOutput1 "cup" -columnAddress :: Capability (Int -> TermOutput)+columnAddress :: TermStr s => Capability (Int -> s) columnAddress = tiGetOutput1 "hpa" -rowAddress :: Capability (Int -> TermOutput)+rowAddress :: TermStr s => Capability (Int -> s) rowAddress = tiGetOutput1 "vpa"
System/Console/Terminfo/Edit.hs view
@@ -11,11 +11,11 @@ clearScreen = fmap ($ []) $ tiGetOutput "clear" -- | Clear from beginning of line to cursor.-clearBOL :: Capability TermOutput+clearBOL :: TermStr s => Capability s clearBOL = tiGetOutput1 "el1" -- | Clear from cursor to end of line.-clearEOL :: Capability TermOutput+clearEOL :: TermStr s => Capability s clearEOL = tiGetOutput1 "el" -- | Clear display after cursor.
System/Console/Terminfo/Effects.hs view
@@ -5,44 +5,152 @@ module System.Console.Terminfo.Effects( -- * Bell alerts bell,visualBell,- -- * text effects- withStandout,withUnderline,+ -- * Text attributes+ Attributes(..),+ defaultAttributes,+ withAttributes,+ setAttributes,+ allAttributesOff,+ -- ** Mode wrappers+ withStandout,+ withUnderline,+ withBold,+ -- ** Low-level capabilities enterStandoutMode, exitStandoutMode, enterUnderlineMode,- exitUnderlineMode+ exitUnderlineMode,+ reverseOn,+ blinkOn,+ boldOn,+ dimOn,+ invisibleOn,+ protectedOn ) where import System.Console.Terminfo.Base+import Control.Monad -wrapWith :: Capability TermOutput -> Capability TermOutput - -> Capability (TermOutput -> TermOutput)+wrapWith :: TermStr s => Capability s -> Capability s -> Capability (s -> s) wrapWith start end = do s <- start e <- end return (\t -> s <#> t <#> e) -withStandout :: Capability (TermOutput -> TermOutput)+-- | Turns on standout mode before outputting the given+-- text, and then turns it off.+withStandout :: TermStr s => Capability (s -> s) withStandout = wrapWith enterStandoutMode exitStandoutMode-withUnderline :: Capability (TermOutput -> TermOutput)++-- | Turns on underline mode before outputting the given+-- text, and then turns it off.+withUnderline :: TermStr s => Capability (s -> s) withUnderline = wrapWith enterUnderlineMode exitUnderlineMode -enterStandoutMode :: Capability TermOutput+-- | Turns on bold mode before outputting the given text, and then turns+-- all attributes off.+withBold :: TermStr s => Capability (s -> s)+withBold = wrapWith boldOn allAttributesOff++enterStandoutMode :: TermStr s => Capability s enterStandoutMode = tiGetOutput1 "smso" -exitStandoutMode :: Capability TermOutput+exitStandoutMode :: TermStr s => Capability s exitStandoutMode = tiGetOutput1 "rmso" -enterUnderlineMode :: Capability TermOutput+enterUnderlineMode :: TermStr s => Capability s enterUnderlineMode = tiGetOutput1 "smul" -exitUnderlineMode :: Capability TermOutput+exitUnderlineMode :: TermStr s => Capability s exitUnderlineMode = tiGetOutput1 "rmul" +reverseOn :: TermStr s => Capability s+reverseOn = tiGetOutput1 "rev" +blinkOn:: TermStr s => Capability s+blinkOn = tiGetOutput1 "blink" -bell :: Capability TermOutput+boldOn :: TermStr s => Capability s+boldOn = tiGetOutput1 "bold"++dimOn :: TermStr s => Capability s+dimOn = tiGetOutput1 "dim"++invisibleOn :: TermStr s => Capability s+invisibleOn = tiGetOutput1 "invis"++protectedOn :: TermStr s => Capability s+protectedOn = tiGetOutput1 "prot"++-- | Turns off all text attributes. This capability will always succeed, but it has+-- no effect in terminals which do not support text attributes.+allAttributesOff :: TermStr s => Capability s+allAttributesOff = tiGetOutput1 "sgr0" `mplus` return mempty++data Attributes = Attributes {+ standoutAttr,+ underlineAttr,+ reverseAttr,+ blinkAttr,+ dimAttr,+ boldAttr,+ invisibleAttr,+ protectedAttr :: Bool+ -- NB: I'm not including the "alternate character set." + }++-- | Sets the attributes on or off before outputting the given text,+-- and then turns them all off. This capability will always succeed; properties+-- which cannot be set in the current terminal will be ignored.+withAttributes :: TermStr s => Capability (Attributes -> s -> s)+withAttributes = do+ set <- setAttributes+ off <- allAttributesOff+ return $ \attrs to -> set attrs <#> to <#> off++-- | Sets the attributes on or off. This capability will always succeed;+-- properties which cannot be set in the current terminal will be ignored.+setAttributes :: TermStr s => Capability (Attributes -> s)+setAttributes = usingSGR0 `mplus` manualSets+ where+ usingSGR0 = do+ sgr <- tiGetOutput1 "sgr"+ return $ \a -> let mkAttr f = if f a then 1 else 0 :: Int+ in sgr (mkAttr standoutAttr)+ (mkAttr underlineAttr)+ (mkAttr reverseAttr)+ (mkAttr blinkAttr)+ (mkAttr dimAttr)+ (mkAttr boldAttr)+ (mkAttr invisibleAttr)+ (mkAttr protectedAttr)+ (0::Int) -- for alt. character sets+ attrCap :: TermStr s => (Attributes -> Bool) -> Capability s + -> Capability (Attributes -> s)+ attrCap f cap = do {to <- cap; return $ \a -> if f a then to else mempty}+ `mplus` return (const mempty)+ manualSets = do+ cs <- sequence [attrCap standoutAttr enterStandoutMode+ , attrCap underlineAttr enterUnderlineMode+ , attrCap reverseAttr reverseOn+ , attrCap blinkAttr blinkOn+ , attrCap boldAttr boldOn+ , attrCap dimAttr dimOn+ , attrCap invisibleAttr invisibleOn+ , attrCap protectedAttr protectedOn+ ]+ return $ \a -> mconcat $ map ($ a) cs++ ++-- | These attributes have all properties turned off.+defaultAttributes :: Attributes+defaultAttributes = Attributes False False False False False False False False++-- | Sound the audible bell.+bell :: TermStr s => Capability s bell = tiGetOutput1 "bel" +-- | Present a visual alert using the @flash@ capability. visualBell :: Capability TermOutput visualBell = tiGetOutput1 "flash"
System/Console/Terminfo/Keys.hs view
@@ -29,37 +29,37 @@ import System.Console.Terminfo.Base -keypadOn :: Capability TermOutput+keypadOn :: TermStr s => Capability s keypadOn = tiGetOutput1 "smkx" -keypadOff :: Capability TermOutput+keypadOff :: TermStr s => Capability s keypadOff = tiGetOutput1 "rmkx" keyUp :: Capability String-keyUp = tiGetStr "kcuu1"+keyUp = tiGetOutput1 "kcuu1" keyDown :: Capability String-keyDown = tiGetStr "kcud1"+keyDown = tiGetOutput1 "kcud1" keyLeft :: Capability String-keyLeft = tiGetStr "kcub1"+keyLeft = tiGetOutput1 "kcub1" keyRight :: Capability String-keyRight = tiGetStr "kcuf1"+keyRight = tiGetOutput1 "kcuf1" -- | Look up the control sequence for a given function sequence. For example, -- @functionKey 12@ retrieves the @kf12@ capability. functionKey :: Int -> Capability String-functionKey n = tiGetStr ("kf" ++ show n)+functionKey n = tiGetOutput1 ("kf" ++ show n) keyBackspace :: Capability String-keyBackspace = tiGetStr "kbs"+keyBackspace = tiGetOutput1 "kbs" keyDeleteChar :: Capability String-keyDeleteChar = tiGetStr "kdch1"+keyDeleteChar = tiGetOutput1 "kdch1" keyHome :: Capability String-keyHome = tiGetStr "khome"+keyHome = tiGetOutput1 "khome" keyEnd :: Capability String-keyEnd = tiGetStr "kend"+keyEnd = tiGetOutput1 "kend"
configure.ac view
@@ -40,9 +40,9 @@ fi AC_CHECK_LIB(ncursesw, setupterm, HaveLibCurses=YES; LibCurses=ncursesw,- AC_CHECK_LIB(ncurses, setupterm, HaveLibCurses=YES; LibCurses=ncurses,- AC_CHECK_LIB(curses, setupterm, HaveLibCurses=YES; LibCurses=curses,- HaveLibCurses=NO; LibCurses=not-installed)))+ [AC_CHECK_LIB(ncurses, setupterm, HaveLibCurses=YES; LibCurses=ncurses,+ [AC_CHECK_LIB(curses, setupterm, HaveLibCurses=YES; LibCurses=curses,+ HaveLibCurses=NO; LibCurses=not-installed)])]) if test "x$HaveLibCurses" = "xNO" ; then AC_MSG_FAILURE([curses library not found, so this package cannot be built])
terminfo.cabal view
@@ -1,6 +1,6 @@ Name: terminfo Cabal-Version: >=1.4-Version: 0.3.0.2+Version: 0.3.1 Category: User Interfaces License: BSD3 License-File: LICENSE@@ -15,14 +15,18 @@ Homepage: http://code.haskell.org/terminfo Stability: Experimental Build-type: Configure-Build-depends: base>=1.0, extensible-exceptions>=0.1.1.0 && < 0.2+Build-depends: base >= 1.0 && < 5,+ extensible-exceptions >= 0.1.1.0 && < 0.2 extra-source-files: configure.ac configure terminfo.buildinfo.in extra-tmp-files: config.log config.status autom4te.cache terminfo.buildinfo-Extensions: ForeignFunctionInterface, DeriveDataTypeable+Extensions: ForeignFunctionInterface, DeriveDataTypeable, EmptyDataDecls,+ ScopedTypeVariables, FlexibleInstances+ghc-options: -Wall Exposed-Modules: System.Console.Terminfo System.Console.Terminfo.Base System.Console.Terminfo.Cursor+ System.Console.Terminfo.Color System.Console.Terminfo.Edit System.Console.Terminfo.Effects System.Console.Terminfo.Keys