diff --git a/Version.hs b/Version.hs new file mode 100644 --- /dev/null +++ b/Version.hs @@ -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 +-- }}} diff --git a/yeganesh.cabal b/yeganesh.cabal --- a/yeganesh.cabal +++ b/yeganesh.cabal @@ -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 diff --git a/yeganesh.hs b/yeganesh.hs --- a/yeganesh.hs +++ b/yeganesh.hs @@ -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