yeganesh 1.1 → 2.0
raw patch · 3 files changed
+108/−22 lines, 3 filesdep +time
Dependencies added: time
Files
- Version.hs +39/−0
- yeganesh.cabal +3/−2
- yeganesh.hs +66/−20
+ Version.hs view
@@ -0,0 +1,39 @@+-- boilerplate {{{+module Version (CurrentFormat, parseCurrentFormat) where+import Data.Map (Map, elems, empty)+import Data.Time (UTCTime, getCurrentTime)++type CurrentFormat = FormatV2++parseCurrentFormat :: String -> IO CurrentFormat+parseCurrentFormat = parseFormatV2+-- }}}+-- v2 {{{+type FormatV2 = (UTCTime, FormatV1)++parseFormatV2 :: String -> IO FormatV2+parseFormatV2 = parse parseFormatV1 upgradeFormatV1+-- }}}+-- v1 {{{+type FormatV1 = Map String Double++upgradeFormatV1 :: FormatV1 -> IO FormatV2+upgradeFormatV1 v1 = fmap (flip (,) popularities) getCurrentTime where+ maximal = case (elems v1, maximum (elems v1)) of+ ([], _) -> 1+ (_ , 0) -> 1+ (_ , m) -> m+ popularities = fmap (/maximal) v1++parseFormatV1 :: String -> IO FormatV1+parseFormatV1 = parse (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)++readMaybe :: Read a => String -> Maybe a+readMaybe s = case reads s of+ [(x, "")] -> Just x+ _ -> Nothing+-- }}}
yeganesh.cabal view
@@ -1,5 +1,5 @@ name: yeganesh-version: 1.1+version: 2.0 cabal-version: >=1.2 build-type: Simple license: BSD3@@ -20,5 +20,6 @@ directory >= 1.0, filepath >= 1.1, process >= 1.0,- strict >= 0.3+ strict >= 0.3,+ time >= 1.1 ghc-options: -Wall
yeganesh.hs view
@@ -1,31 +1,47 @@ -- boilerplate {{{ module Main where -import Control.Arrow ((&&&))+import Control.Arrow ((&&&), second) import Control.Monad (liftM) import Data.Char (toLower) import Data.List (sortBy)-import Data.Map (Map, insertWith, fromList, toList, union)+import Data.Map (Map, insert, findWithDefault, fromList, toList, union) import Data.Ord (comparing)+import Data.Time (UTCTime, diffUTCTime, getCurrentTime)+import System.Console.GetOpt (ArgDescr(ReqArg), ArgOrder(RequireOrder), OptDescr(Option), getOpt) import System.Directory (createDirectoryIfMissing)-import System.Environment (getEnv)+import System.Environment (getArgs, getEnv) import System.FilePath ((</>)) import System.IO (hClose, hGetContents, hPutStr, hPutStrLn, stderr, stdout) import System.Process (runInteractiveProcess, waitForProcess)+import Version (CurrentFormat, parseCurrentFormat) import qualified System.IO.Strict as Strict (getContents, readFile) -- }}}+-- getopt {{{+options :: [OptDescr String]+options = [Option "p" ["profile"] (ReqArg id "PROFILE") "which popularity profile to use"]++data Options = Options { dmenuOpts :: [String], profile :: String } deriving Show++parseOptions :: [String] -> Either String Options+parseOptions ss = fmap (Options dOpts) p where+ (opts, dOpts) = fmap (drop 1) . break (== "--") $ ss+ p = case getOpt RequireOrder options opts of+ (ps, [], []) -> Right . last $ "default" : ps+ (_ , ns, []) -> Left $ "Unknown options: " ++ unwords ns+ (_ , _ , es) -> Left . concat $ es+-- }}} -- filesystem stuff {{{ type Commands = Map String Double -fileName :: IO FilePath-fileName = do+fileName :: String -> IO FilePath+fileName arg = do home <- flip liftM (getEnv "HOME") (</> ".yeganesh") createDirectoryIfMissing True home- return (home </> "default")+ return $ home </> arg -readPossiblyNonExistent :: FilePath -> IO Commands-readPossiblyNonExistent file = fmap read $- catch (Strict.readFile file) (const . return $ "fromList []")+readPossiblyNonExistent :: FilePath -> IO CurrentFormat+readPossiblyNonExistent file = catch (Strict.readFile file) (const . return $ "") >>= parseCurrentFormat -- }}} -- pure {{{ sortOn :: Ord b => (a -> b) -> [a] -> [a]@@ -37,16 +53,39 @@ showPriority :: Commands -> String showPriority = unlines . map fst . sortOn descSnd . toList -updatePriority :: String -> Commands -> Commands-updatePriority cmd = if null cmd then id else insertWith (+) cmd 1+-- decay exponentially, with a one-month half-life+decay :: UTCTime -> UTCTime -> Commands -> Commands+decay old new = fmap (/factor) where+ seconds = fromRational . toRational $ diffUTCTime new old+ factor = exp (seconds * log 2 / 2592000) +-- give a boost, with things close to 0 getting a big boost, and things close+-- to 1 getting a small boost+-- Current method:+-- 1. clip ]-infty, infty[ to [0, 1]+-- 2. scale [0, 1] to [0.5, 1]+-- 3. take sqrt; this is the boost part+-- 4. scale [sqrt 0.5, 1] to [0.01, 1]+boost :: (Floating a, Ord a) => a -> a+boost = postscale . sqrt . prescale . clip where+ clip = min 1 . max 0+ prescale = (0.5 +) . (/ 2)+ postscale = ((0.01 - s2) / ms2 +) . ((0.99 / ms2) *)+ s2 = sqrt 0.5+ ms2 = 1 - s2++updatePriority :: String -> UTCTime -> UTCTime -> Commands -> Commands+updatePriority cmd old new cmds = insert cmd pri cmds' where+ cmds' = decay old new cmds+ pri = boost $ findWithDefault 0 cmd cmds'+ parseInput :: String -> Commands parseInput = fromList . flip zip (repeat 0) . filter (not . null) . lines -- }}} -- shell stuff {{{-dmenu :: Commands -> IO Commands-dmenu cmds = do- (hIn, hOut, hErr, p) <- runInteractiveProcess "dmenu" [] Nothing Nothing+dmenu :: [String] -> CurrentFormat -> IO CurrentFormat+dmenu opts cv@(_, cmds) = do+ (hIn, hOut, hErr, p) <- runInteractiveProcess "dmenu" opts Nothing Nothing hPutStrLn hIn (showPriority cmds) hClose hIn o <- hGetContents hOut@@ -54,13 +93,20 @@ waitForProcess p hPutStr stdout o hPutStr stderr e+ updateState o cv - return (updatePriority o cmds)--- }}}-main :: IO ()-main = do- file <- fileName+updateState :: String -> CurrentFormat -> IO CurrentFormat+updateState cmd cv@(t, cmds) = if null cmd then return cv else do+ now <- getCurrentTime+ return (now, updatePriority cmd t now cmds)++runWithOptions :: Options -> IO ()+runWithOptions opts = do+ file <- fileName (profile opts) cached <- readPossiblyNonExistent file new <- fmap parseInput Strict.getContents- updated <- dmenu (cached `union` new)+ updated <- dmenu (dmenuOpts opts) (second (`union` new) cached) writeFile file (show updated)+-- }}}+main :: IO ()+main = getArgs >>= either putStrLn runWithOptions . parseOptions