yeganesh-2.1: yeganesh.hs

-- boilerplate {{{
module Main where

import Control.Arrow ((&&&), second)
import Control.Monad (liftM)
import Data.Char (toLower)
import Data.List (sortBy)
import Data.Map (Map, insert, findWithDefault, fromList, toList, union)
import Data.Ord (comparing)
import Data.Time (UTCTime, diffUTCTime, getCurrentTime)
import System.Console.GetOpt (ArgDescr(NoArg, ReqArg), ArgOrder(RequireOrder), OptDescr(Option), getOpt, usageInfo)
import System.Directory (createDirectoryIfMissing)
import System.Environment (getArgs, getEnv)
import System.FilePath ((</>))
import System.IO (hClose, hGetContents, hPutStr, stderr, stdout)
import System.Process (runInteractiveProcess, waitForProcess)
import Version (CurrentFormat, parseCurrentFormat, version)
import qualified System.IO.Strict as Strict (getContents, readFile)
-- }}}
-- getopt {{{
options :: [OptDescr Flag]
options =   [Option "p" ["profile"] (ReqArg Profile "PROFILE") "which popularity profile to use"
            ,Option "v" ["version"] (NoArg Version)            "print the version number"
            ,Option "h" ["help"   ] (NoArg Help)               "show usage information"
            ]

data Options = Options { dmenuOpts :: [String], profile :: String }
data Flag    = Profile String | Version | Help

compactFlags :: [Flag] -> Flag
compactFlags = foldr1 compactFlags' . (Profile "default" :) where
    compactFlags' Help    _ = Help
    compactFlags' _    Help = Help
    compactFlags' Version _ = Version
    compactFlags' _ Version = Version
    compactFlags' _ p       = p

introText :: String
introText = unlines $ [
    version,
    "Usage: yeganesh [OPTIONS] -- [DMENU_OPTIONS]",
    "OPTIONS are described below, and DMENU_OPTIONS are passed on verbatim to dmenu.",
    "Profiles are stored in the $HOME/.yeganesh directory."]

parseOptions :: [String] -> Either String Options
parseOptions ss = fmap (Options dOpts) p where
    (opts, dOpts) = fmap (drop 1) . break (== "--") $ ss
    p = case onFirst compactFlags $ getOpt RequireOrder options opts of
        (Profile f, [], []) -> Right f
        (Version  , [], []) -> Left version
        (Help     , [], []) -> Left $ usageInfo introText options
        (_ , ns, []) -> Left $ "Unknown options: " ++ unwords ns
        (_ , _ , es) -> Left  . concat $ es
-- }}}
-- filesystem stuff {{{
type Commands = Map String Double

fileName :: String -> IO FilePath
fileName arg = do
    home <- flip liftM (getEnv "HOME") (</> ".yeganesh")
    createDirectoryIfMissing True home
    return $ home </> arg

readPossiblyNonExistent :: FilePath -> IO CurrentFormat
readPossiblyNonExistent file = catch (Strict.readFile file) (const . return $ "") >>= parseCurrentFormat
-- }}}
-- pure {{{
onFirst :: (a -> a') -> (a, b, c) -> (a', b, c)
onFirst f (a, b, c) = (f a, b, c)

sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f = map snd . sortBy (comparing fst) . map (f &&& id)

descSnd :: Num b => (String, b) -> (b, String)
descSnd = (negate . snd) &&& (map toLower . fst)

showPriority :: Commands -> String
showPriority = unlines . map fst . sortOn descSnd . toList

-- decay exponentially, with a one-month half-life
-- The key for decay is that it be monotonic, so that commands will appear in
-- the same order before and after a decay operation; this means we can delay
-- the decay until *after* the user has selected an option.
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 :: [String] -> CurrentFormat -> IO CurrentFormat
dmenu opts cv@(_, cmds) = do
    (hIn, hOut, hErr, p) <- runInteractiveProcess "dmenu" opts Nothing Nothing
    hPutStr hIn (showPriority cmds)
    hClose hIn
    o <- hGetContents hOut
    e <- hGetContents hErr
    waitForProcess p
    hPutStr stdout o
    hPutStr stderr e
    updateState o cv

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 (dmenuOpts opts) (second (`union` new) cached)
    writeFile file (show updated)
-- }}}
main :: IO ()
main = getArgs >>= either putStrLn runWithOptions . parseOptions