diff --git a/System/Console/Terminfo.hs b/System/Console/Terminfo.hs --- a/System/Console/Terminfo.hs +++ b/System/Console/Terminfo.hs @@ -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 diff --git a/System/Console/Terminfo/Base.hs b/System/Console/Terminfo/Base.hs --- a/System/Console/Terminfo/Base.hs +++ b/System/Console/Terminfo/Base.hs @@ -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 diff --git a/System/Console/Terminfo/Color.hs b/System/Console/Terminfo/Color.hs new file mode 100644 --- /dev/null +++ b/System/Console/Terminfo/Color.hs @@ -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" diff --git a/System/Console/Terminfo/Cursor.hs b/System/Console/Terminfo/Cursor.hs --- a/System/Console/Terminfo/Cursor.hs +++ b/System/Console/Terminfo/Cursor.hs @@ -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" diff --git a/System/Console/Terminfo/Edit.hs b/System/Console/Terminfo/Edit.hs --- a/System/Console/Terminfo/Edit.hs +++ b/System/Console/Terminfo/Edit.hs @@ -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. diff --git a/System/Console/Terminfo/Effects.hs b/System/Console/Terminfo/Effects.hs --- a/System/Console/Terminfo/Effects.hs +++ b/System/Console/Terminfo/Effects.hs @@ -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" diff --git a/System/Console/Terminfo/Keys.hs b/System/Console/Terminfo/Keys.hs --- a/System/Console/Terminfo/Keys.hs +++ b/System/Console/Terminfo/Keys.hs @@ -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" diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -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]) diff --git a/terminfo.cabal b/terminfo.cabal --- a/terminfo.cabal +++ b/terminfo.cabal @@ -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