packages feed

terminfo (empty) → 0.1

raw patch · 9 files changed

+535/−0 lines, 9 filesdep +basebuild-type:Customsetup-changed

Dependencies added: base

Files

+ LICENSE view
@@ -0,0 +1,23 @@+Copyright 2007, Judah Jacobson.+All Rights Reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistribution of source code must retain the above copyright notice,+this list of conditions and the following disclamer.++- Redistribution in binary form must reproduce the above copyright notice,+this list of conditions and the following disclamer in the documentation+and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/local/bin/runhaskell++\begin{code}+import Distribution.Simple+main = defaultMain+\end{code}
+ System/Console/Terminfo.hs view
@@ -0,0 +1,18 @@+{- |+Maintainer  : judah.jacobson@gmail.com+Stability   : experimental+Portability : portable (FFI)+-}+module System.Console.Terminfo(+    module System.Console.Terminfo.Base,+    module System.Console.Terminfo.Keys,+    module System.Console.Terminfo.Cursor,+    module System.Console.Terminfo.Effects,+    module System.Console.Terminfo.Edit+    ) where++import System.Console.Terminfo.Base+import System.Console.Terminfo.Keys+import System.Console.Terminfo.Cursor+import System.Console.Terminfo.Edit+import System.Console.Terminfo.Effects
+ System/Console/Terminfo/Base.hs view
@@ -0,0 +1,226 @@+-- |+-- Maintainer  : judah.jacobson@gmail.com+-- Stability   : experimental+-- Portability : portable (FFI)+--+-- This module provides a low-level interface to the C functions of the +-- terminfo library. +-- +-- NOTE: Since this library is built on top of the curses interface, it is not thread-safe.++module System.Console.Terminfo.Base(+                            Terminal(),+                            setupTerm,+                            setupTermFromEnv,+                            Capability,+                            getCapability,+                            tiGetFlag,+                            tiGuardFlag,+                            tiGetNum,+                            tiGetStr,+                            TermOutput(),+                            runTermOutput,+                            termText,+                            tiGetOutput,+                            LinesAffected,+                            tiGetOutput1,+                            OutputCap,+                            module Data.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)+++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 ()++-- | Initialize the terminfo library to the given terminal entry.+--+setupTerm :: String -> IO Terminal+setupTerm term = withCString term $ \c_term -> +    {-- If the terminal name is the same as for the previous call to +    setupterm, ncurses will return cur_term instead of a new struct.+    This leads to problems when calling del_curterm on a struct shared by+    more than one Terminal.  To avoid this behavior, we temporarily set the+    cur_term value to nullPtr.+    --}+                    with 0 $ \ret_ptr -> do+                        let stdOutput = 1+                        -- set cur_term to null, temporarily+                        old_term <- peek cur_term+                        poke cur_term nullPtr+                        -- call setupterm and check the return value.+                        setupterm c_term stdOutput ret_ptr+                        ret <- peek ret_ptr+                        when (ret /= 1) $ error ("Couldn't lookup terminfo entry " ++ show term)+                        -- set cur_term to its previous value+                        cterm <- peek cur_term+                        poke cur_term old_term +                        -- create the Terminal and return it.+                        fmap Terminal $ newForeignPtr del_curterm cterm+                            +-- | Initialize the terminfo library, using the @TERM@ environmental variable.+-- If @TERM@ is not set, we use the generic, minimal entry @dumb@.+setupTermFromEnv :: IO Terminal+setupTermFromEnv = do+    env_term <- getEnv "TERM" +    let term = if null env_term then "dumb" else env_term+    setupTerm term++withCurTerm :: Terminal -> IO a -> IO a+withCurTerm (Terminal term) f = withForeignPtr term set_curterm >> f++-- | A feature or operation which a 'Terminal' may define.+newtype Capability a = Capability (Terminal -> Maybe a)++getCapability :: Terminal -> Capability a -> Maybe a+getCapability term (Capability f) = 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 f . g) ++instance Monad Capability where+    return x = Capability (\_ -> Just x)+    Capability f >>= g = Capability $ \t -> f t >>= getCapability t . g+    Capability f >> Capability g = Capability $ \t -> f t >> g t++instance MonadPlus Capability where+    mzero = Capability (\_ -> Nothing)+    Capability f `mplus` Capability g = Capability (\t -> f t `mplus` g t)++foreign import ccall tigetnum :: CString -> IO CInt++-- | Look up a numeric capability in the terminfo database.+tiGetNum :: String -> Capability Int +tiGetNum cap = Capability $ \term -> unsafePerformIO $ withCurTerm term $ do+                n <- fmap fromEnum (withCString cap tigetnum)+                if n >= 0+                    then return (Just n)+                    else return Nothing++foreign import ccall tigetflag :: CString -> IO CInt+-- | Look up a boolean capability in the terminfo database.  +-- +-- Unlike 'tiGuardFlag', this capability never fails; it returns 'False' if the+-- capability is absent or set to false, and returns 'True' otherwise.  +-- +tiGetFlag :: String -> Capability Bool+tiGetFlag cap = Capability $ \term -> +                    Just $ unsafePerformIO $ withCurTerm term $ +                        fmap (>0) (withCString cap tigetflag)+                +-- | Look up a boolean capability in the terminfo database, and fail if+-- it\'s not defined.+tiGuardFlag :: String -> Capability ()+tiGuardFlag cap = tiGetFlag cap >>= guard+                +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.+tiGetStr :: String -> Capability String+tiGetStr cap = Capability $ \term -> unsafePerformIO $ withCurTerm term $ do+                result <- withCString cap tigetstr +                if result == nullPtr || result == neg1Ptr+                    then return Nothing+                    else fmap Just (peekCString result)+    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)+    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++-- | 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 $ do+        outStr <- tParm str ps+        tPuts outStr la++type CharOutput = CInt -> IO CInt+foreign import ccall "wrapper" mkCallback :: CharOutput -> IO (FunPtr CharOutput)+c_putChar = unsafePerformIO $ mkCallback putc+    where+        putc c = let c' = toEnum $ fromEnum c+                 in putChar c' >> return c++foreign import ccall tputs :: CString -> CInt -> FunPtr CharOutput -> IO ()++-- | A parameter to specify the number of lines affected.  Some capabilities+-- (e.g., @clear@ and @dch1@) use+-- this parameter on some terminals to compute variable-length padding.+type LinesAffected = Int++-- | Output a string capability.  Applys padding information to the string if+-- necessary.+tPuts :: String -> LinesAffected -> IO ()+tPuts s n = withCString s $ \c_str -> tputs c_str (toEnum n) c_putChar++-- | 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 (IO ())++runTermOutput :: Terminal -> TermOutput -> IO ()+runTermOutput term (TermOutput to) = withCurTerm term to++-- | Output plain text containing no control characters or escape sequences.+termText :: String -> TermOutput+termText = TermOutput . putStr++instance Monoid TermOutput where +    mempty = TermOutput $ return ()+    TermOutput f `mappend` TermOutput g = TermOutput (f >> g) ++-- | A type class to encapsulate capabilities which take in zero or more +-- parameters.+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)++-- | 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
+ System/Console/Terminfo/Cursor.hs view
@@ -0,0 +1,136 @@+-- |+-- Maintainer  : judah.jacobson@gmail.com+-- Stability   : experimental+-- Portability : portable (FFI)+--+-- | This module provides capabilities for moving the cursor on the terminal. -}+module System.Console.Terminfo.Cursor(+                        -- * Terminal dimensions+                        -- | Get the default size of the terminal.  For+                        -- resizeable terminals (e.g., @xterm@), these may not+                        -- correspond to the actual dimensions.+                        termLines, termColumns,+                        -- * Scrolling+                        carriageReturn,+                        newline,+                        scrollForward,+                        scrollReverse,+                        -- * Relative cursor movements+                        -- | The following functions for cursor movement will+                        -- combine the more primitive capabilities.  For example,+                        -- 'moveDown' may use either 'cursorDown' or+                        -- 'cursorDown1' depending on the parameter and which of+                        -- @cud@ and @cud1@ are defined.+                        moveDown, moveLeft, moveRight, moveUp,+                        +                        -- ** Primitive movement capabilities+                        -- | These capabilities correspond directly to @cub@, @cud@,+                        -- @cub1@, @cud1@, etc.+                        cursorDown1, +                        cursorLeft1,+                        cursorRight1,+                        cursorUp1, +                        cursorDown, +                        cursorLeft,+                        cursorRight,+                        cursorUp, +                        -- * Absolute cursor movements+                        cursorAddress,+                        Point(..),+                        rowAddress,+                        columnAddress+                        ) where++import System.Console.Terminfo.Base+import Control.Monad++termLines, termColumns :: Capability Int+termLines = tiGetNum "lines"+termColumns = tiGetNum "columns"++{--+On many terminals, the @cud1@ ('cursorDown1') capability is the line feed +character '\n'.  However, @stty@ settings may cause that character to have+other effects than intended; e.g. ONLCR turns LF into CRLF, and as a result +@cud1@ will always move the cursor to the first column of the next line.  ++Looking at the source code of curses (lib_mvcur.c) and other similar programs, +they use @cud@ instead of @cud1@ if it's '\n' and ONLCR is turned on.  ++Since there's no easy way to check for ONLCR at this point, I've just made+cursorDown1 always use @cud@.++Note the same problems apply to @ind@, but I think there's less of an+expectation that scrolling down will keep the same column.  +Suggestions are welcome.+--}+cursorDown1, cursorLeft1,cursorRight1,cursorUp1 :: Capability TermOutput+cursorDown1 = fmap ($1) cursorDown+cursorLeft1 = tiGetOutput1 "cub1"+cursorRight1 = tiGetOutput1 "cuf1"+cursorUp1 = tiGetOutput1 "cuu1"++cursorDown, cursorLeft, cursorRight, cursorUp :: Capability (Int -> TermOutput)+cursorDown = tiGetOutput1 "cud"+cursorLeft = tiGetOutput1 "cub"+cursorRight = tiGetOutput1 "cuf"+cursorUp = tiGetOutput1 "cuu"++cursorHome, cursorToLL :: Capability TermOutput+cursorHome = tiGetOutput1 "home"+cursorToLL = tiGetOutput1 "ll"+++-- Movements are built out of parametrized and unparam'd movement+-- capabilities.+-- todo: more complicated logic like ncurses does.+move single param = let+        tryBoth = do+                    s <- single+                    p <- param+                    return $ \n -> case n of+                        0 -> mempty+                        1 -> s+                        n -> p n+        manySingle = do+                        s <- single+                        return $ \n -> mconcat $ replicate n s+        in tryBoth `mplus` param `mplus` manySingle++moveLeft, moveRight, moveUp, moveDown :: Capability (Int -> TermOutput)+moveLeft = move cursorLeft1 cursorLeft+moveRight = move cursorRight1 cursorRight+moveUp = move cursorUp1 cursorUp+moveDown = cursorDown -- see notes on @cud1@ above++-- | The @cr@ capability, which moves the cursor to the first column of the+-- current line.+carriageReturn :: Capability TermOutput+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 = 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, scrollReverse :: Capability TermOutput+scrollForward = tiGetOutput1 "ind"+scrollReverse = tiGetOutput1 "ri"+++data Point = Point {row, col :: Int}++cursorAddress :: Capability (Point -> TermOutput)+cursorAddress = fmap (\g p -> g (row p) (col p)) $ tiGetOutput1 "cup"++columnAddress, rowAddress :: Capability (Int -> TermOutput)+columnAddress = tiGetOutput1 "hpa"+rowAddress = tiGetOutput1 "vpa"++
+ System/Console/Terminfo/Edit.hs view
@@ -0,0 +1,24 @@+-- |+-- Maintainer  : judah.jacobson@gmail.com+-- Stability   : experimental+-- Portability : portable (FFI)+module System.Console.Terminfo.Edit where++import System.Console.Terminfo.Base++-- | Clear the screen, and move the cursor to the upper left.+clearScreen :: Capability (LinesAffected -> TermOutput)+clearScreen = fmap ($ []) $ tiGetOutput "clear" ++-- | Clear from beginning of line to cursor.+clearBOL :: Capability TermOutput+clearBOL = tiGetOutput1 "el1"++-- | Clear from cursor to end of line.+clearEOL :: Capability TermOutput+clearEOL = tiGetOutput1 "el"++-- | Clear display after cursor.+clearEOS :: Capability (LinesAffected -> TermOutput)+clearEOS = fmap ($ []) $ tiGetOutput "ed"+
+ System/Console/Terminfo/Effects.hs view
@@ -0,0 +1,29 @@+-- |+-- Maintainer  : judah.jacobson@gmail.com+-- Stability   : experimental+-- Portability : portable (FFI)+module System.Console.Terminfo.Effects where++import System.Console.Terminfo.Base++wrapWith :: Capability TermOutput -> Capability TermOutput +                -> Capability (TermOutput -> TermOutput)+wrapWith start end = do+    s <- start+    e <- end+    return (\t -> s `mappend` t `mappend` e)++withStandout, withUnderline :: Capability (TermOutput -> TermOutput)+withStandout = wrapWith enterStandoutMode exitStandoutMode+withUnderline = wrapWith enterUnderlineMode exitUnderlineMode++enterStandoutMode, exitStandoutMode :: Capability TermOutput+enterStandoutMode = tiGetOutput1 "smso"+exitStandoutMode = tiGetOutput1 "rmso"++enterUnderlineMode, exitUnderlineMode :: Capability TermOutput+enterUnderlineMode = tiGetOutput1 "smul"+exitUnderlineMode = tiGetOutput1 "rmul"+++
+ System/Console/Terminfo/Keys.hs view
@@ -0,0 +1,47 @@+-- |+-- Maintainer  : judah.jacobson@gmail.com+-- Stability   : experimental+-- Portability : portable (FFI)+--+-- The string capabilities in this module are the character sequences+-- corresponding to user input such as arrow keys and function keys.+module System.Console.Terminfo.Keys(+                    -- * The keypad+                    -- | The following commands+                    -- turn the keypad on\/off (@smkx@ and @rmkx@).  +                    -- They have no effect if those capabilities are not defined.  +                    -- For portability between terminals, the keypad should be+                    -- explicitly turned on before accepting user key input.+                    keypadOn,+                    keypadOff,+                    -- * Arrow keys+                    keyUp,+                    keyDown,+                    keyLeft,+                    keyRight,+                    -- * Miscellaneous+                    functionKey,+                    keyBackspace,+                    keyDeleteChar+                    ) where++import System.Console.Terminfo.Base++keypadOn, keypadOff :: Capability TermOutput+keypadOn = tiGetOutput1 "smkx"+keypadOff = tiGetOutput1 "rmkx"++keyUp, keyDown, keyLeft, keyRight :: Capability String+keyUp = tiGetStr "kcuu1"+keyDown = tiGetStr "kcud1"+keyLeft = tiGetStr "kcub1"+keyRight = tiGetStr "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)++keyBackspace, keyDeleteChar :: Capability String+keyBackspace = tiGetStr "kbs"+keyDeleteChar = tiGetStr "kdch1"
+ terminfo.cabal view
@@ -0,0 +1,26 @@+Name:           terminfo+Cabal-Version:  >=1.1.4+Version:        0.1+Category:       User Interfaces+License:        BSD3+License-File:   LICENSE+Copyright:      (c) Judah Jacobson+Author:         Judah Jacobson+Maintainer:     Judah Jacobson <judah.jacobson@gmail.com>+Category:       User Interfaces+Synopsis:       Haskell bindings to the terminfo library.+Description:    This library provides an interface to the terminfo database (via bindings to the+                curses library).  Terminfo allows programs to interact with a variety of terminals +                using a standard set of capabilities.  +Homepage:       http://code.haskell.org/terminfo+Stability:      Experimental+Build-depends:  base>=1.0+extra-libraries:curses+Extensions:     ForeignFunctionInterface+Exposed-Modules:+                System.Console.Terminfo+                System.Console.Terminfo.Base+                System.Console.Terminfo.Cursor+                System.Console.Terminfo.Edit+                System.Console.Terminfo.Effects+                System.Console.Terminfo.Keys