yeganesh 2.4 → 2.5
raw patch · 7 files changed
+415/−59 lines, 7 filesdep ~unix
Dependency ranges changed: unix
Files
- LICENSE +4/−2
- Lex.hs +265/−0
- Version.hs +80/−17
- Yeganesh.hs +23/−12
- main.hs +24/−16
- strip.hs +5/−6
- yeganesh.cabal +14/−6
LICENSE view
@@ -1,5 +1,7 @@-Copyright (c) 2008, Daniel Wagner-All rights reserved.+The code in yeganesh comes from two sources:++* Lex.hs comes from the GHC project which is (c) The University of Glasgow.+* All other source files (c) Daniel Wagner, 2008. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted, provided that the following conditions are met:
+ Lex.hs view
@@ -0,0 +1,265 @@+-- stolen from Text.Read.Lex in GHC's base library++module Lex (lexDecNumber, lexString, module Text.ParserCombinators.ReadP) where++import Control.Monad+import Data.Char+import Data.Maybe+import Data.Ratio+import Prelude hiding (exp)+import Text.ParserCombinators.ReadP++lexCharE :: ReadP (Char, Bool) -- "escaped or not"?+lexCharE =+ do c1 <- get+ if c1 == '\\'+ then do c2 <- lexEsc; return (c2, True)+ else do return (c1, False)+ where+ lexEsc =+ lexEscChar+ +++ lexNumeric+ +++ lexCntrlChar+ +++ lexAscii++ lexEscChar =+ do c <- get+ case c of+ 'a' -> return '\a'+ 'b' -> return '\b'+ 'f' -> return '\f'+ 'n' -> return '\n'+ 'r' -> return '\r'+ 't' -> return '\t'+ 'v' -> return '\v'+ '\\' -> return '\\'+ '\"' -> return '\"'+ '\'' -> return '\''+ _ -> pfail++ lexNumeric =+ do base <- lexBaseChar <++ return 10+ n <- lexInteger base+ guard (n <= toInteger (ord maxBound))+ return (chr (fromInteger n))++ lexCntrlChar =+ do _ <- char '^'+ c <- get+ case c of+ '@' -> return '\^@'+ 'A' -> return '\^A'+ 'B' -> return '\^B'+ 'C' -> return '\^C'+ 'D' -> return '\^D'+ 'E' -> return '\^E'+ 'F' -> return '\^F'+ 'G' -> return '\^G'+ 'H' -> return '\^H'+ 'I' -> return '\^I'+ 'J' -> return '\^J'+ 'K' -> return '\^K'+ 'L' -> return '\^L'+ 'M' -> return '\^M'+ 'N' -> return '\^N'+ 'O' -> return '\^O'+ 'P' -> return '\^P'+ 'Q' -> return '\^Q'+ 'R' -> return '\^R'+ 'S' -> return '\^S'+ 'T' -> return '\^T'+ 'U' -> return '\^U'+ 'V' -> return '\^V'+ 'W' -> return '\^W'+ 'X' -> return '\^X'+ 'Y' -> return '\^Y'+ 'Z' -> return '\^Z'+ '[' -> return '\^['+ '\\' -> return '\^\'+ ']' -> return '\^]'+ '^' -> return '\^^'+ '_' -> return '\^_'+ _ -> pfail++ lexAscii =+ do choice+ [ (string "SOH" >> return '\SOH') <+++ (string "SO" >> return '\SO')+ -- \SO and \SOH need maximal-munch treatment+ -- See the Haskell report Sect 2.6++ , string "NUL" >> return '\NUL'+ , string "STX" >> return '\STX'+ , string "ETX" >> return '\ETX'+ , string "EOT" >> return '\EOT'+ , string "ENQ" >> return '\ENQ'+ , string "ACK" >> return '\ACK'+ , string "BEL" >> return '\BEL'+ , string "BS" >> return '\BS'+ , string "HT" >> return '\HT'+ , string "LF" >> return '\LF'+ , string "VT" >> return '\VT'+ , string "FF" >> return '\FF'+ , string "CR" >> return '\CR'+ , string "SI" >> return '\SI'+ , string "DLE" >> return '\DLE'+ , string "DC1" >> return '\DC1'+ , string "DC2" >> return '\DC2'+ , string "DC3" >> return '\DC3'+ , string "DC4" >> return '\DC4'+ , string "NAK" >> return '\NAK'+ , string "SYN" >> return '\SYN'+ , string "ETB" >> return '\ETB'+ , string "CAN" >> return '\CAN'+ , string "EM" >> return '\EM'+ , string "SUB" >> return '\SUB'+ , string "ESC" >> return '\ESC'+ , string "FS" >> return '\FS'+ , string "GS" >> return '\GS'+ , string "RS" >> return '\RS'+ , string "US" >> return '\US'+ , string "SP" >> return '\SP'+ , string "DEL" >> return '\DEL'+ ]+++-- ---------------------------------------------------------------------------+-- string literal++lexString :: ReadP String+lexString =+ do _ <- char '"'+ body id+ where+ body f =+ do (c,esc) <- lexStrItem+ if c /= '"' || esc+ then body (f.(c:))+ else let s = f "" in+ return s++ lexStrItem = (lexEmpty >> lexStrItem)+ +++ lexCharE++ lexEmpty =+ do _ <- char '\\'+ c <- get+ case c of+ '&' -> do return ()+ _ | isSpace c -> do skipSpaces; _ <- char '\\'; return ()+ _ -> do pfail++lexBaseChar :: ReadP Int+-- Lex a single character indicating the base; fail if not there+lexBaseChar = do { c <- get;+ case c of+ 'o' -> return 8+ 'O' -> return 8+ 'x' -> return 16+ 'X' -> return 16+ _ -> pfail }++type Base = Int+type Digits = [Int]++lexDecNumber :: ReadP Rational+lexDecNumber =+ do xs <- lexDigits 10+ mFrac <- lexFrac <++ return Nothing+ mExp <- lexExp <++ return Nothing+ return (value xs mFrac mExp)+ where+ value xs mFrac mExp = valueFracExp (val 10 0 xs) mFrac mExp++ valueFracExp :: Integer -> Maybe Digits -> Maybe Integer+ -> Rational+ valueFracExp a Nothing Nothing+ = a % 1 -- 43+ valueFracExp a Nothing (Just exp)+ | exp >= 0 = a * (10 ^ exp) % 1 -- 43e7+ | otherwise = a % (10 ^ (-exp)) -- 43e-7+ valueFracExp a (Just fs) mExp -- 4.3[e2]+ = (fracExp (fromMaybe 0 mExp) a fs)+ -- Be a bit more efficient in calculating the Rational.+ -- Instead of calculating the fractional part alone, then+ -- adding the integral part and finally multiplying with+ -- 10 ^ exp if an exponent was given, do it all at once.++lexFrac :: ReadP (Maybe Digits)+-- Read the fractional part; fail if it doesn't+-- start ".d" where d is a digit+lexFrac = do _ <- char '.'+ fraction <- lexDigits 10+ return (Just fraction)++lexExp :: ReadP (Maybe Integer)+lexExp = do _ <- char 'e' +++ char 'E'+ exp <- signedExp +++ lexInteger 10+ return (Just exp)+ where+ signedExp+ = do c <- char '-' +++ char '+'+ n <- lexInteger 10+ return (if c == '-' then -n else n)++lexDigits :: Int -> ReadP Digits+-- Lex a non-empty sequence of digits in specified base+lexDigits base =+ do s <- look+ xs <- scan s id+ guard (not (null xs))+ return xs+ where+ scan (c:cs) f = case valDig base c of+ Just n -> do _ <- get; scan cs (f.(n:))+ Nothing -> do return (f [])+ scan [] f = do return (f [])++lexInteger :: Base -> ReadP Integer+lexInteger base =+ do xs <- lexDigits base+ return (val (fromIntegral base) 0 xs)++val :: Num a => a -> a -> Digits -> a+-- val base y [d1,..,dn] = y ++ [d1,..,dn], as it were+val _ y [] = y+val base y (x:xs) = y' `seq` val base y' xs+ where+ y' = y * base + fromIntegral x++-- Calculate a Rational from the exponent [of 10 to multiply with],+-- the integral part of the mantissa and the digits of the fractional+-- part. Leaving the calculation of the power of 10 until the end,+-- when we know the effective exponent, saves multiplications.+-- More importantly, this way we need at most one gcd instead of three.+--+-- frac was never used with anything but Integer and base 10, so+-- those are hardcoded now (trivial to change if necessary).+fracExp :: Integer -> Integer -> Digits -> Rational+fracExp exp mant []+ | exp < 0 = mant % (10 ^ (-exp))+ | otherwise = fromInteger (mant * 10 ^ exp)+fracExp exp mant (d:ds) = exp' `seq` mant' `seq` fracExp exp' mant' ds+ where+ exp' = exp - 1+ mant' = mant * 10 + fromIntegral d++valDig :: (Eq a, Num a) => a -> Char -> Maybe Int+valDig 8 c+ | '0' <= c && c <= '7' = Just (ord c - ord '0')+ | otherwise = Nothing++valDig 10 c = valDecDig c++valDig 16 c+ | '0' <= c && c <= '9' = Just (ord c - ord '0')+ | 'a' <= c && c <= 'f' = Just (ord c - ord 'a' + 10)+ | 'A' <= c && c <= 'F' = Just (ord c - ord 'A' + 10)+ | otherwise = Nothing++valDig _ _ = error "valDig: Bad base"++valDecDig :: Char -> Maybe Int+valDecDig c+ | '0' <= c && c <= '9' = Just (ord c - ord '0')+ | otherwise = Nothing
Version.hs view
@@ -1,25 +1,82 @@ -- boilerplate {{{-module Version (CurrentFormat, parseCurrentFormat, versionNumber, versionYeganesh, versionStrip) where+{-# LANGUAGE TupleSections #-}+module Version (CurrentFormat, parseCurrentFormat, pprintCurrentFormat, versionNumber, versionYeganesh, versionStrip) where+import Control.Monad (liftM2) import Data.Char (isSpace)-import Data.Map (Map, elems, empty)+import Data.Map (Map, assocs, elems, empty, fromList) import Data.Time (UTCTime, getCurrentTime)+import Data.Version (showVersion)+import Lex (ReadP, (+++), char, lexDecNumber, lexString, readP_to_S, readS_to_P, sepBy, string)+import Paths_yeganesh (version) -type CurrentFormat = FormatV2-versionNumber :: String-versionYeganesh :: String-versionStrip :: String-parseCurrentFormat :: String -> IO CurrentFormat+type CurrentFormat = FormatV4+versionNumber :: String+versionYeganesh :: String+versionStrip :: String+pprintCurrentFormat :: CurrentFormat -> String+parseCurrentFormat :: String -> IO CurrentFormat -versionNumber = "2.4"-versionYeganesh = "yeganesh version " ++ versionNumber-versionStrip = "yeganesh-strip version " ++ versionNumber-parseCurrentFormat = parseFormatV2+versionNumber = showVersion version+versionYeganesh = "yeganesh version " ++ versionNumber+versionStrip = "yeganesh-strip version " ++ versionNumber+pprintCurrentFormat = pprintFormatV4+parseCurrentFormat = parseFormatV4 -- }}}+-- v4 {{{+type FormatV4 = FormatV3++pprintFormatV4 :: FormatV4 -> String+pprintFormatV4 (now, cv) = unlines $+ show now :+ [show n ++ " " ++ line | (line,n) <- assocs cv]++parseFormatV4 :: String -> IO FormatV4+parseFormatV4 = parse v4 parseFormatV3 return++v4 :: String -> Maybe FormatV4+v4 = parseLines . lines where+ parseLines [] = Nothing+ parseLines (h:m) = liftM2 combine (parseHeader h) (mapM parseLine m)++ combine h m = (h, fromList [(b,a) | (a,b) <- m])+ parseHeader = readMaybe readp+ parseLine s = case break isSpace s of+ (n, ' ':line) -> fmap (,line) (readMaybe lexDouble n)+ _ -> Nothing+-- }}}+-- v3 {{{+type FormatV3 = FormatV2++-- be stricter about what you accept, but faster at parsing+parseFormatV3 :: String -> IO FormatV3+parseFormatV3 = parse (readMaybe v3) parseFormatV2 upgradeFormatV2++v3 :: ReadP FormatV3+v3 = lexTuple readp (lexMap lexString lexDouble) where+ lexTuple lexA lexB = do+ _ <- char '('+ a <- lexA+ _ <- char ','+ b <- lexB+ _ <- char ')'+ return (a,b)+ lexList lexElem = do+ _ <- char '['+ vs <- sepBy lexElem (char ',') +++ return []+ _ <- char ']'+ return vs+ lexMap lexKey lexValue = do+ _ <- string "fromList "+ fmap fromList (lexList (lexTuple lexKey lexValue))+-- }}} -- v2 {{{ type FormatV2 = (UTCTime, FormatV1) +upgradeFormatV2 :: FormatV2 -> IO FormatV3+upgradeFormatV2 = return+ parseFormatV2 :: String -> IO FormatV2-parseFormatV2 = parse parseFormatV1 upgradeFormatV1+parseFormatV2 = parse (readMaybe readp) parseFormatV1 upgradeFormatV1 -- }}} -- v1 {{{ type FormatV1 = Map String Double@@ -33,14 +90,20 @@ popularities = fmap (/maximal) v1 parseFormatV1 :: String -> IO FormatV1-parseFormatV1 = parse (const (return empty)) return+parseFormatV1 = parse (readMaybe readp) (const (return empty)) return -- }}} -- utilities {{{-parse :: Read new => (String -> IO old) -> (old -> IO new) -> (String -> IO new)-parse old upgrade s = maybe (old s >>= upgrade) return (readMaybe s)+lexDouble :: ReadP Double+lexDouble = fmap fromRational lexDecNumber -readMaybe :: Read a => String -> Maybe a-readMaybe s = case reads s of+parse :: (String -> Maybe new) -> (String -> IO old) -> (old -> IO new) -> (String -> IO new)+parse new old upgrade s = maybe (old s >>= upgrade) return (new s)++readMaybe :: ReadP a -> String -> Maybe a+readMaybe p s = case readP_to_S p s of [(x, unparsed)] | all isSpace unparsed -> Just x _ -> Nothing++readp :: Read a => ReadP a+readp = readS_to_P reads -- }}}
Yeganesh.hs view
@@ -16,8 +16,9 @@ import System.Environment (getEnv) import System.Environment.XDG.BaseDir (getAllDataFiles, getUserDataDir, getUserDataFile) import System.FilePath ((</>))-import Version (CurrentFormat, parseCurrentFormat)-import qualified System.IO.Strict as Strict (readFile)+import System.IO (IOMode(ReadMode, WriteMode), hClose, hPutStr, hSetEncoding, openFile, utf8)+import System.IO.Strict (hGetContents)+import Version (CurrentFormat, parseCurrentFormat, pprintCurrentFormat) -- }}} -- getopt {{{ options :: [OptDescr Flag]@@ -29,7 +30,7 @@ ] data Options = Options { dmenuOpts :: [String], profile :: String, prune :: Bool, executables :: Bool }-data Flag = Profile String | Prune | Executables | Version | Help deriving Eq+data Flag = Profile String | Prune | Executables | Version | Help deriving (Eq, Ord, Show, Read) compactFlags :: [Flag] -> (Flag, Bool, Bool) compactFlags fs = (flag, not $ null prunes, not $ null execs) where@@ -43,14 +44,12 @@ compactFlags' _ p = p parseOptions :: String -> String -> [String] -> Either String Options-parseOptions introText version ss = p where- (opts, dOpts) = fmap (drop 1) . break (== "--") $ ss- p = case onFirst compactFlags $ getOpt RequireOrder options opts of- ((Profile s, f, x), [], []) -> Right (Options dOpts s f x)- ((Version , _, _), [], []) -> Left version- ((Help , _, _), [], []) -> Left $ usageInfo introText options- (_ , ns, []) -> Left $ "Unknown options: " ++ unwords ns- (_ , _ , es) -> Left . concat $ es+parseOptions introText version ss =+ case onFirst compactFlags $ getOpt RequireOrder options ss of+ ((Profile s, f, x), dOpts, []) -> Right (Options dOpts s f x)+ ((Version , _, _), _ , []) -> Left (version ++ "\n")+ ((Help , _, _), _ , []) -> Left $ usageInfo introText options+ (_, _, es) -> Left . concat $ es -- }}} -- filesystem stuff {{{ type Commands = Map String Double@@ -83,7 +82,19 @@ (removeDirectory depDir) readPossiblyNonExistent :: FilePath -> IO CurrentFormat-readPossiblyNonExistent file = catch (Strict.readFile file) (const . return $ "") >>= parseCurrentFormat+readPossiblyNonExistent file = catch (readUTF8File file) (const . return $ "") >>= parseCurrentFormat where+ readUTF8File name = do+ h <- openFile name ReadMode+ hSetEncoding h utf8+ hGetContents h++writeProfile :: Options -> CurrentFormat -> IO ()+writeProfile opts cv = do+ outFile <- outFileName (profile opts)+ h <- openFile outFile WriteMode+ hSetEncoding h utf8+ hPutStr h (pprintCurrentFormat cv)+ hClose h -- }}} -- pure {{{ onFirst :: (a -> a') -> (a, b, c) -> (a', b, c)
main.hs view
@@ -1,4 +1,5 @@ -- boilerplate {{{+{-# LANGUAGE CPP #-} module Main where import Catch (catch)@@ -17,9 +18,9 @@ import System.Process (runInteractiveProcess, waitForProcess) import Version (CurrentFormat, versionYeganesh) import Yeganesh (Commands, Options, addEntries, deprecate, dmenuOpts,- executables, inFileName, outFileName, parseInput, parseOptions, parsePath,- profile, prune, readPossiblyNonExistent, showPriority, stripNewline,- updatePriority)+ executables, inFileName, parseInput, parseOptions, parsePath, profile,+ prune, readPossiblyNonExistent, showPriority, stripNewline, updatePriority,+ writeProfile) import qualified System.IO.Strict as Strict (getContents) -- }}} -- IO stuff {{{@@ -28,6 +29,12 @@ -- }}} -- shell stuff {{{ dmenu :: [String] -> CurrentFormat -> IO (ExitCode, CurrentFormat)++#ifdef profiling+-- when profiling, it's convenient to skip the call out to dmenu+dmenu opts cv = return (ExitSuccess, cv)+#endif+ dmenu opts cv@(_, cmds) = do (hIn, hOut, hErr, p) <- runInteractiveProcess "dmenu" opts Nothing Nothing hPutStr hIn (showPriority cmds)@@ -54,16 +61,18 @@ path <- catchList $ getEnv "PATH" execs <- catchList . forM (parsePath path) $ \s -> catchList (getDirectoryContents s) >>=- filterM (\file -> do- status <- getFileStatus (s </> file)- case isDirectory status of- True -> return False- False -> fileAccess (s </> file) True False True)+ filterM (executable . (s </>))+ putMVar mvar (concat execs)+ return (takeMVar mvar)+ where+ executable file = flip catch (\_ -> return False) $ do+ status <- getFileStatus file+ case isDirectory status of+ True -> return False+ False -> fileAccess file True False True -- TODO: do people prefer to see files which are executable by -- *someone*, even if not by the current user? ask brisbin on -- Freenode, who is to date the only person to request this feature- putMVar mvar (concat execs)- return (takeMVar mvar) parseStdin :: Bool -> IO Commands parseStdin False = fmap parseInput Strict.getContents@@ -72,13 +81,12 @@ runWithOptions :: Options -> IO () runWithOptions opts = do future <- lsx (executables opts)- inFile <- inFileName (profile opts)- outFile <- outFileName (profile opts)+ inFile <- inFileName (profile opts) cached <- readPossiblyNonExistent inFile- new <- parseStdin (executables opts)+ new <- parseStdin (executables opts) (code, updated) <- dmenu (dmenuOpts opts) (second (`combine` new) cached) execs <- future- writeFile outFile (show (addEntries execs updated))+ writeProfile opts (addEntries execs updated) deprecate inFile (profile opts) exitWith code where@@ -89,9 +97,9 @@ introText :: String introText = unlines $ [ versionYeganesh,- "Usage: yeganesh [OPTIONS] [-- DMENU_OPTIONS]",+ "Usage: yeganesh [OPTIONS] [[--] DMENU_OPTIONS]", "OPTIONS are described below, and DMENU_OPTIONS are passed on verbatim to dmenu.", "Profiles are stored in the XDG data home for yeganesh."] main :: IO ()-main = getArgs >>= either putStrLn runWithOptions . parseOptions introText versionYeganesh+main = getArgs >>= either putStr runWithOptions . parseOptions introText versionYeganesh
strip.hs view
@@ -3,15 +3,14 @@ import Data.Map (mapKeysWith) import System.Environment (getArgs) import Version (versionStrip)-import Yeganesh (Options, deprecate, inFileName, merge, profile, outFileName,- parseOptions, readPossiblyNonExistent, stripNewline)+import Yeganesh (Options, deprecate, inFileName, merge, profile, parseOptions,+ readPossiblyNonExistent, stripNewline, writeProfile) runWithOptions :: Options -> IO () runWithOptions opts = do- inFile <- inFileName (profile opts)- outFile <- outFileName (profile opts)+ inFile <- inFileName (profile opts) (t, cmd) <- readPossiblyNonExistent inFile- writeFile outFile (show (t, mapKeysWith merge stripNewline cmd))+ writeProfile opts (t, mapKeysWith merge stripNewline cmd) deprecate inFile (profile opts) introText :: String@@ -22,4 +21,4 @@ "Profiles are stored in the XDG data home for yeganesh."] main :: IO ()-main = getArgs >>= either putStrLn runWithOptions . parseOptions introText versionStrip+main = getArgs >>= either putStr runWithOptions . parseOptions introText versionStrip
yeganesh.cabal view
@@ -1,18 +1,17 @@ name: yeganesh-version: 2.4+version: 2.5 cabal-version: >=1.2 build-type: Simple license: BSD3 license-file: LICENSE author: Daniel Wagner maintainer: daniel@wagner-home.com-homepage: http://www.dmwit.com/yeganesh+homepage: http://dmwit.com/yeganesh synopsis: small dmenu wrapper description: I get so annoyed when I go to use dmenu, and the three programs I use every day aren't at the beginning of the list. Let's make it so, and automatically! category: Text-extra-source-files: Catch.hs, Version.hs, Yeganesh.hs cabal-version: >= 1.6 source-repository head type: darcs@@ -20,10 +19,15 @@ source-repository this type: darcs location: http://dmwit.com/yeganesh- tag: 2.4+ tag: 2.5 +flag profiling+ description: Build with profiling and -auto-all+ default: False+ Executable yeganesh main-is: main.hs+ other-modules: Catch, Lex, Paths_yeganesh, Version, Yeganesh build-depends: base >= 3 && < 5, containers >= 0.1, directory >= 1.0,@@ -31,13 +35,17 @@ process >= 1.0, strict >= 0.3, time >= 1.1,- unix >= 2.5,+ unix >= 2.4, xdg-basedir >= 0.2 ghc-options: -Wall extensions: CPP+ if flag(profiling)+ ghc-options: -auto-all+ cpp-options: -Dprofiling Executable yeganesh-strip main-is: strip.hs+ other-modules: Catch, Lex, Paths_yeganesh, Version, Yeganesh build-depends: base >= 3 && < 5, containers >= 0.1, directory >= 1.0,@@ -45,6 +53,6 @@ process >= 1.0, strict >= 0.3, time >= 1.1,- unix >= 2.5,+ unix >= 2.4, xdg-basedir >= 0.2 ghc-options: -Wall