yeganesh-2.0: 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(ReqArg), ArgOrder(RequireOrder), OptDescr(Option), getOpt)
import System.Directory (createDirectoryIfMissing)
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 :: 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 {{{
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
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
    hPutStrLn 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