terminfo-hs (empty) → 0.1.0.0

raw patch · 8 files changed

+494/−0 lines, 8 filesdep +QuickCheckdep +attoparsecdep +basesetup-changed

Dependencies added: QuickCheck, attoparsec, base, bytestring, containers, directory, errors, filepath

Files

LICENSE +30/−0
Setup.hs +2/−0
System/Terminfo.hs +162/−0
System/Terminfo/DBParse.hs +126/−0
System/Terminfo/Internal.hs +66/−0
System/Terminfo/Types.hs +20/−0
terminfo-hs.cabal +46/−0
test.hs +42/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2013, Bryan Richter++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Bryan Richter nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT+OWNER OR 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.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ System/Terminfo.hs view

@@ -0,0 +1,162 @@+-- |+-- Module      :  System.Terminfo+-- Copyright   :  (c) Bryan Richter (2013)+-- License     :  BSD-style+-- Maintainer  :  bryan.richter@gmail.com+--+-- This is a pure-Haskell (no FFI) module for accessing terminfo databases,+-- which contain characteristics, or capabilities, for the various+-- terminals such as screen, vt100, or xterm. Among other things, the+-- capabilities include the idiosyncratic character sequences needed to+-- send commands to the terminal. These commands include things like cursor+-- movement.+--+-- For a deeper understanding of terminfo, consult the man pages for+-- term(5) and terminfo(5).+--+-- There are three parts to this module: acquiring a terminfo database,+-- querying the database, and defining the capabilities.+--+-- This module is dead simple, so a single example will hopefully suffice+-- to demonstrate its usage.+--+-- @+-- import System.Terminfo+-- import System.Terminfo.Caps as C+-- uglyExample :: IO (Maybe Int)+-- uglyExample = do+--     term \<- fromJust \<$> lookupEnv \"TERM\"+--     db \<- 'acquireDatabase' term+--     let maxColors (Right d) = 'queryNumTermCap' d C.'MaxColors'+--     return $ maxColors db+-- @+--+-- >>> uglyExample+-- Just 256+--++module System.Terminfo (+    -- * Acquiring a Database+      acquireDatabase+    -- * Querying Capabilities+    -- $queryFuncs+    , queryBoolTermCap+    , queryNumTermCap+    , queryStrTermCap+    -- * The Capabilities+    -- $capabilities++    -- * The Database Type+    , TIDatabase++    ) where++import Control.Applicative ((<$>), (<|>))+import Control.Error+import Control.Monad ((<=<), filterM)+import qualified Data.ByteString as B+import qualified Data.Map.Lazy as M+import System.Directory+import System.FilePath+import System.IO++import System.Terminfo.Types+import System.Terminfo.DBParse+import System.Terminfo.Internal (terminfoDBLocs)+import System.Terminfo.Caps++data DBType = BerkeleyDB | DirTreeDB+    deriving(Show)++-- Old MacDonald had a farm...+type EIO = EitherT String IO++acquireDatabase+    :: String -- ^ System name+    -> IO (Either String TIDatabase)+       -- ^ A database object for the terminal, if it exists.+acquireDatabase = runEitherT . (parseDBFile <=< findDBFile)++findDBFile :: String -> EIO (DBType, FilePath)+findDBFile term = case term of+    (c:_) -> dbFileM c term `orLeft` "No terminfo db found"+    _     -> hoistEither $ Left "User specified null terminal name"+  where+    orLeft = flip noteT+    dbFileM c t = dirTreeDB c t <|> berkeleyDB++-- | Not implemented+berkeleyDB :: MaybeT IO (DBType, FilePath)+berkeleyDB = nothing++dirTreeDB :: Char -> String -> MaybeT IO (DBType, FilePath)+dirTreeDB c term = MaybeT $ do+    path <- findFirst =<< map (</> [c] </> term) <$> terminfoDBLocs+    return $ (,) DirTreeDB <$> path++findFirst :: [FilePath] -> IO (Maybe FilePath)+findFirst = fmap headMay . filterM doesFileExist++parseDBFile :: (DBType, FilePath) -> EIO TIDatabase+parseDBFile (db, f) = case db of+    DirTreeDB -> extractDirTreeDB f+    BerkeleyDB -> hoistEither+        $ Left "BerkeleyDB support not yet implemented"++-- | Extract a 'TIDatabase' from the specified file. IO exceptions are+-- left to their own devices.+extractDirTreeDB :: FilePath+                 -> EIO TIDatabase+extractDirTreeDB =+    hoistEither . parseDB+    <=< rightT . B.hGetContents+    <=< rightT . flip openBinaryFile ReadMode+  where+    rightT = EitherT . fmap Right++queryBoolTermCap :: TIDatabase+                 -> BoolTermCap+                 -> Bool+queryBoolTermCap (TIDatabase (TCBMap vals) _ _) cap =+    fromMaybe False $ M.lookup cap vals++queryNumTermCap :: TIDatabase+                -> NumTermCap+                -> Maybe Int+queryNumTermCap (TIDatabase _ (TCNMap vals) _) cap = M.lookup cap vals++-- | As this is a dead simple module, no \'smart\' handling of the+-- returned string is implemented. In particular, placeholders for+-- buffer characters and command arguments are left as-is. This will be+-- rectified eventually, probably in a separate module.+queryStrTermCap :: TIDatabase+                -> StrTermCap+                -> Maybe String+queryStrTermCap (TIDatabase _ _ (TCSMap vals)) cap = M.lookup cap vals++--+-- DOCUMENTATION+--++++-- $queryFuncs+--+-- For each of these three actions, the first argument is the database to+-- query, and the second argument is the capability to look up.+--+-- I'm not super proud of this interface, but it's the best I can manage at+-- present without requiring lots of mostly-empty case expressions. Perhaps+-- someone will suggest a more interesting solution.++-- $capabilities+--+-- /see/ "System.Terminfo.Caps"+--+-- There are no less than 497 capabilities specified in term.h on my+-- Intel-based Ubuntu 12.04 notebook (slightly fewer in the terminfo(5) man+-- page). The naive way of making these available to the user is as data+-- constructors, and that is what I have done here.+--+-- The number of constructors absolutely crushes the namespace. I have+-- sequestered them into their own module to try to alleviate the pain.

+ System/Terminfo/DBParse.hs view

@@ -0,0 +1,126 @@+{-# LANGUAGE RecordWildCards #-}++-- |+-- Module      :  System.Terminfo.DBParse+-- Copyright   :  (c) Bryan Richter (2013)+-- License     :  BSD-style+-- +-- Maintainer  :  bryan.richter@gmail.com+--+-- An internal module encapsulating methods for parsing a terminfo file as+-- generated by tic(1). The primary reference is the term(5) manpage.+--++module System.Terminfo.DBParse+    ( parseDB+    ) where++import Control.Applicative ((<$>), (<*>))+import Control.Arrow ((***))+import qualified Control.Arrow as Arr+import Control.Monad ((<=<), when, void)+import Data.Attoparsec as A+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.Char (chr)+import qualified Data.Map.Lazy as M+import Data.Word (Word16)++import System.Terminfo.Types++-- | term(5) defines a short integer as two 8-bit bytes, so:+type ShortInt = Word16++-- | short ints are stored little-endian.+shortInt :: Integral a => ShortInt -> Parser a+shortInt i = word8 first >> word8 second >> return (fromIntegral i)+  where+    (second, first) = (fromIntegral *** fromIntegral) $ i `divMod` 256++-- | short ints are stored little-endian.+--+-- (-1) is represented by the two bytes 0o377 0o377.+--+-- Return type is Int so I can include (-1) in the possible outputs. I+-- wonder if I will regret this.+anyShortInt :: Parser Int+anyShortInt = do+    first <- fromIntegral <$> anyWord8+    second <- fromIntegral <$> anyWord8+    return $ if first == 0o377 && second == 0o377+       then (-1)+       else 256*second + first++parseDB :: ByteString -> Either String TIDatabase+parseDB = parseOnly tiDatabase++tiDatabase :: Parser TIDatabase+tiDatabase = do+    Header{..} <- header+    -- Ignore names+    _ <- A.take namesSize+    bools <- boolCaps boolSize+    -- Align on an even byte+    when (odd boolSize) (void $ A.take 1)+    nums <- numCaps numIntegers+    strs <- stringCaps numOffsets stringSize+    -- TODO: extended info+    return $ TIDatabase bools nums strs++boolCaps :: Int -- ^ Number of caps+         -> Parser TCBMap+boolCaps =+    return . TCBMap . M.fromList . zip keys . map (== 1) . B.unpack+        <=< A.take+  where+    {-keys :: [BoolTermCap]-}+    keys = [minBound ..]++-- Negative values indicate missing capability.+numCaps :: Int -- ^ Number of caps+        -> Parser TCNMap+numCaps = return . TCNMap . M.fromList . filter notNeg . zip keys+    <=< flip A.count anyShortInt+  where+    notNeg = ((/= -1) . snd)+    {-keys :: [BoolTermCap]-}+    keys = [minBound ..]++stringCaps :: Int -- ^ Number of caps+           -> Int -- ^ Size of table+           -> Parser TCSMap+stringCaps numOffsets stringSize = do+    offs <- A.count numOffsets anyShortInt+    stringTable <- A.take stringSize+    return+        $ TCSMap $ M.fromList $ map (parseValue stringTable)+        $ filter notNeg $ zip keys offs+  where+    notNeg = ((/= -1) . snd)+    keys = [minBound ..]+    parseValue tbl = Arr.second $ parseString tbl+    parseString table offset =+        asString+        $ B.takeWhile (/= 0)  -- null-terminated+        $ B.drop offset table -- starts at offset+    asString = map (chr . fromIntegral) . B.unpack++-- | the magic number for term files+magic :: Parser Int+magic = shortInt 0o432 <?> "Not a terminfo file (bad magic)"++data Header = Header+     { namesSize :: Int+     , boolSize :: Int+     , numIntegers :: Int+     , numOffsets :: Int+     , stringSize :: Int+     }+     deriving (Show)++header :: Parser Header+header = magic >> Header <$> anyShortInt+                         <*> anyShortInt+                         <*> anyShortInt+                         <*> anyShortInt+                         <*> anyShortInt

+ System/Terminfo/Internal.hs view

@@ -0,0 +1,66 @@+module System.Terminfo.Internal+    ( terminfoDBLocs+    , locationsPure+    ) where++import Control.Applicative ((<$>), (<*>), pure)+import Control.Error+import System.Environment (lookupEnv)+import System.FilePath++terminfoDBLocs :: IO [FilePath]+terminfoDBLocs = locationsPure+    <$> lookupEnv "TERMINFO"+    <*> (lookupEnv "HOME" <$$/> ".terminfo")+    <*> lookupEnv "TERMINFO_DIRS"+    <*> pure ["/lib/terminfo", "/usr/share/terminfo"]+++(<$/>) :: Functor f => f FilePath -> FilePath -> f FilePath+fa <$/> b = (</> b) <$> fa+infixr 4 <$/>++(<$$/>) :: (Functor f, Functor g)+        => f (g FilePath)+        -> FilePath+        -> f (g FilePath)+ffa <$$/> b = fmap (<$/> b) ffa+infixr 4 <$$/>++-- | I hate this name. There is undoubtedly a better way of structuring all+-- of this, starting way up at 'dirTreeDB'.+locationsPure :: Maybe FilePath -- ^ Override directory+              -> Maybe FilePath -- ^ $HOME+              -> Maybe String   -- ^ $TERMINFO_DIRS+              -> [FilePath]     -- ^ Defaults+              -> [FilePath]+locationsPure ovr usr termdirs defs = case ovr of+    Just override -> [override]+    Nothing       -> catMaybes [usr] ++ system++  where+    system = case termdirs of+        Just list -> parseTDVar defs list+        Nothing   -> defs++parseTDVar :: [String] -> String -> [String]+parseTDVar defs = replace "" defs . split ':'++-- | Replace an element with multiple replacements+replace :: Eq a => a -> [a] -> [a] -> [a]+replace old news = foldr (\x acc -> if x == old+                                       then news ++ acc+                                       else x : acc)+                         []++-- | split, as seen in ByteString and Text, but for Strings.+split :: Char -> String -> [String]+split s = foldr go [[]]+  where+    go c acc = if c /= s+                  then unshift c acc+                  else "" : acc++    -- | /perldoc -f unshift/+    unshift c (xs:xss) = (c:xs) : xss+    unshift c []       = [[c]]

+ System/Terminfo/Types.hs view

@@ -0,0 +1,20 @@+module System.Terminfo.Types+    ( TIDatabase(..)+    , TCBMap(..)+    , TCNMap(..)+    , TCSMap(..)+    ) where++import Data.Map.Lazy (Map)++import System.Terminfo.Caps++data TCBMap = TCBMap (Map BoolTermCap Bool)+    deriving (Show)+data TCNMap = TCNMap (Map NumTermCap Int)+    deriving (Show)+data TCSMap = TCSMap (Map StrTermCap String)+    deriving (Show)++data TIDatabase = TIDatabase TCBMap TCNMap TCSMap+    deriving (Show)

+ terminfo-hs.cabal view

@@ -0,0 +1,46 @@+name:                terminfo-hs+version:             0.1.0.0+synopsis:            A pure-Haskell (no FFI) module for accessing terminfo databases+description:         This module can acquire terminfo databases and query+                     them for terminal capabilities. For details of+                     terminfo, consult the man pages for term(5) and+                     terminfo(5).++                     This package is dead simple, and doesn't do anything+                     fancy with the capabilities themselves. It merely+                     provides a means for accessing them.++license:             BSD3+license-file:        LICENSE+author:              Bryan Richter+maintainer:          bryan.richter@gmail.com+copyright:           Bryan Richter, 2013+category:            System, Terminal+build-type:          Simple+cabal-version:       >=1.8++source-repository head+  type: git+  location: https://github.com/chreekat/terminfo-hs++source-repository this+  type: git+  tag: 0.1.0.0+  location: https://github.com/chreekat/terminfo-hs/tree/0.1.0.0++library+  ghc-options:         -Wall+  exposed-modules:     System.Terminfo+  other-modules:       System.Terminfo.DBParse,+                       System.Terminfo.Types+                       System.Terminfo.Internal+  build-depends:       base ==4.*, errors ==1.*,+                       bytestring ==0.*, directory ==1.*,+                       filepath ==1.*, attoparsec ==0.*,+                       containers ==0.5.*++test-suite System.Terminfo.Internal+  type:                exitcode-stdio-1.0+  main-is:             test.hs+  build-depends:       base ==4.*, filepath ==1.*, directory ==1.*,+                       errors ==1.*, QuickCheck

+ test.hs view

@@ -0,0 +1,42 @@+{-# LANGUAGE TemplateHaskell #-}++import Test.QuickCheck+import Test.QuickCheck.All+import System.Terminfo.Internal++import Data.Maybe++prop_useOverride ovr =+    forAll notLikely $ \usr ->+    forAll notLikely $ \tds ->+    forAll oftenNull $ \defs ->+    classify (isNothing usr && isNothing tds && null defs)+        "Nothing else specified"$+    classify (isJust usr && isJust tds && not (null defs))+        "Everything else specified"$+    locationsPure (Just ovr) usr tds defs == [ovr]++notLikely = frequency [(2, return Nothing), (1, fmap Just arbitrary)]+oftenNull = frequency [(2, return []), (1, arbitrary)]++prop_includeHome usr =+    forAll notLikely $ \tds ->+    forAll oftenNull $ \defs ->+    let+        withUsr    = locationsPure Nothing (Just usr) tds defs+        withoutUsr = locationsPure Nothing Nothing    tds defs+    in+    classify (isJust tds || not (null defs))+        "Something besides HOME specified"$+    withUsr == usr : withoutUsr++prop_terminfoDirsOverridesDefaults tds =+    forAll (oneof [return [], listOf1 arbitrary]) $ \defs ->+    classify (not $ null defs) "Defaults specified"$+    locationsPure Nothing Nothing (Just tds) defs+        == parseTDVar defs tds++prop_useDefaults defs =+    locationsPure Nothing Nothing Nothing defs == defs++main = $quickCheckAll