{-# LANGUAGE CPP #-}
-- boilerplate {{{
module Main where

import Control.Arrow ((&&&), second)
import Control.Concurrent (newEmptyMVar, takeMVar, putMVar, forkIO)
import Control.Monad (liftM, filterM, forM, when)
import Data.Char (toLower)
import Data.List (partition, sortBy)
import Data.Map (Map, insert, findWithDefault, fromList, intersection, 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, doesFileExist, getDirectoryContents, removeDirectory, removeFile)
import System.Environment (getArgs, getEnv)
import System.Environment.XDG.BaseDir (getAllDataFiles, getUserDataDir, getUserDataFile)
import System.Exit (ExitCode(ExitSuccess, ExitFailure), exitWith)
import System.FilePath ((</>))
import System.IO (hClose, hGetContents, hPutStr, stderr, stdout)
import System.Posix.Files (fileAccess, getFileStatus, isDirectory)
import System.Process (runInteractiveProcess, waitForProcess)
import Version (CurrentFormat, parseCurrentFormat, version)
import qualified System.IO.Strict as Strict (getContents, readFile)

#if MIN_VERSION_base(4,0,0)
import qualified Control.Exception
import Prelude hiding (catch)

catch :: IO a -> (Control.Exception.IOException -> IO a) -> IO a
catch = Control.Exception.catch
#endif
-- }}}
-- getopt {{{
options :: [OptDescr Flag]
options =   [Option "p" ["profile"]     (ReqArg Profile "PROFILE") "which popularity profile to use"
            ,Option "f" ["filter" ]     (NoArg Prune)              "prune a profile to contain exactly the lines of stdin"
            ,Option "x" ["executables"] (NoArg Executables)        "search $PATH for executables for the next run"
            ,Option "v" ["version"]     (NoArg Version)            "print the version number"
            ,Option "h" ["help"   ]     (NoArg Help)               "show usage information"
            ]

data Options = Options { dmenuOpts :: [String], profile :: String, prune :: Bool, executables :: Bool }
data Flag    = Profile String | Prune | Executables | Version | Help deriving Eq

compactFlags :: [Flag] -> (Flag, Bool, Bool)
compactFlags fs = (flag, not $ null prunes, not $ null execs) where
    (prunes, nonPrunes)     = partition (==Prune) fs
    (execs, nonExecs)       = partition (==Executables) nonPrunes
    flag                    = foldr1 compactFlags' . (Profile "default" :) $ nonExecs
    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 XDG data home for yeganesh."]

parseOptions :: [String] -> Either String Options
parseOptions 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
-- }}}
-- filesystem stuff {{{
type Commands = Map String Double

deprecatedDir :: IO FilePath
deprecatedDir = liftM (</> ".yeganesh") (getEnv "HOME")

inFileName :: String -> IO FilePath
inFileName arg = do
    depDir     <- deprecatedDir
    dataFiles  <- getAllDataFiles "yeganesh" arg
    validFiles <- filterM doesFileExist ((depDir </> arg) : dataFiles)
    case validFiles of
        []    -> getUserDataFile "yeganesh" arg
        (f:_) -> return f

outFileName :: String -> IO FilePath
outFileName arg = do
    dir <- getUserDataDir "yeganesh"
    createDirectoryIfMissing True dir
    return (dir </> arg)

deprecate :: String -> String -> IO ()
deprecate inFile arg = do
    depDir <- deprecatedDir
    when (inFile == depDir </> arg) $ do
        removeFile inFile
        filesLeft <- getDirectoryContents depDir
        when (null . filter (`notElem` [".", ".."]) $ filesLeft)
             (removeDirectory depDir)

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

-- an (almost certainly buggy) internal implementation of the shell's IFS
-- mechanism
xCons :: a -> [[a]] -> [[a]]
xCons x (p:ps) = ((x:p):ps)
xCons x []     = [[x]]

parsePath :: String -> [String]
parsePath ('\\':x:xs) = xCons x (parsePath xs)
parsePath (':':xs)    = [] : parsePath xs
parsePath (x:xs)      = xCons x (parsePath xs)
parsePath []          = []

addEntries :: [String] -> CurrentFormat -> CurrentFormat
addEntries es (t, m) = (t, union m (fromList [(e, 0) | e <- es]))
-- }}}
-- shell stuff {{{
dmenu :: [String] -> CurrentFormat -> IO (ExitCode, 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
    c <- waitForProcess p
    hPutStr stdout o
    hPutStr stderr e
    cv' <- updateState c o cv
    return (c, cv')

updateState :: ExitCode -> String -> CurrentFormat -> IO CurrentFormat
updateState (ExitFailure {})  _  (t, cmds) = return (t, cmds)
updateState  ExitSuccess     cmd (t, cmds) = do
    now <- getCurrentTime
    return (now, updatePriority cmd t now cmds)

lsx :: Bool -> IO (IO [String])
lsx False = return (return [])
lsx True  = do
    mvar <- newEmptyMVar
    _    <- forkIO $ do
        path  <- getEnv "PATH"
        execs <- forM (parsePath path) $ \s ->
            catch (getDirectoryContents s) (const . return $ []) >>=
            filterM (\file -> do
                status <- getFileStatus (s </> file)
                case isDirectory status of
                    True  -> return False
                    False -> fileAccess (s </> 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)

runWithOptions :: Options -> IO ()
runWithOptions opts = do
    future          <- lsx (executables opts)
    inFile          <- inFileName  (profile opts)
    outFile         <- outFileName (profile opts)
    cached          <- readPossiblyNonExistent inFile
    new             <- fmap parseInput Strict.getContents
    (code, updated) <- dmenu (dmenuOpts opts) (second (`combine` new) cached)
    execs           <- future
    writeFile outFile (show (addEntries execs updated))
    deprecate inFile (profile opts)
    exitWith code
    where
    combine = if prune opts
              then \old -> union old >>= intersection
              else union
-- }}}
main :: IO ()
main = getArgs >>= either putStrLn runWithOptions . parseOptions