module Core.Select
    ( -- * Interacting with dmenu
      selectWith       -- :: [String] -> [ByteString] -> String -> IO (Either ProcessError ByteString)

      -- * Interacting with the history file
    , tryRead          -- :: FilePath -> IO Items
    , runUpdate        -- :: ByteString -> Config -> Items -> IO ()

      -- * Interacting with the system
    , getExecutables   -- :: IO [ByteString]
    , evalDirs         -- :: [ByteString] -> IO [ByteString]

      -- * Pretty printing
    , showItems        -- :: Items -> ByteString

      -- * Utility
    , makeNewEntries   -- :: [ByteString] -> Items
    , sortByValues     -- :: Items -> [ByteString]
    ) where

import Core.Parser (getHist)
import Core.Toml (Config (Config, decay, files, histPath, open, term, tty))
import Core.Util hiding ((</>))

import Data.ByteString.Char8 qualified as BS
import Data.Map.Strict       qualified as Map

import Data.Double.Conversion.ByteString (toShortest)
import System.Posix.Directory.Foreign (DirType, dtDir, dtUnknown)
import System.Posix.Directory.Traversals (allDirectoryContents', traverseDirectoryContents)
import System.Posix.Env.ByteString (getEnvDefault)
import System.Posix.FilePath (RawFilePath, (</>))
import System.Posix.Files.ByteString (fileExist, getFileStatus, isDirectory)
import System.Process.ByteString (readCreateProcessWithExitCode)


{- | When a spawned process fails, this type is used to represent the
exit code and @stderr@ output.

See <https://github.com/m0rphism/haskell-dmenu/blob/master/src/DMenu/Run.hs>.
-}
type ProcessError :: Type
type ProcessError = (Int, ByteString)

-- | Do the appropriate things with the user selection and update the
-- history file.
runUpdate
    :: ByteString  -- ^ What the user picked.
    -> Config      -- ^ User config containing things that interest us.
    -> Items       -- ^ Map prior to selection.
    -> IO ()
runUpdate :: ByteString -> Config -> Items -> IO ()
runUpdate ByteString
selection cfg :: Config
cfg@Config{ FilePath
histPath :: Config -> FilePath
histPath :: FilePath
histPath, Double
decay :: Config -> Double
decay :: Double
decay } Items
itemMap = do
    ByteString -> IO ()
spawn (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Config -> ByteString
decideSelection ByteString
selection Config
cfg     -- execute selected command
    FilePath
histPath FilePath -> ByteString -> IO ()
`BS.writeFile` Items -> ByteString
showItems Items
update  -- update map and write to file
  where
    -- Update the items based on the users selection.
    Items
update :: Items = (Double -> Double) -> ByteString -> Items -> Items
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
1) ByteString
selection ((Double -> Double) -> Items -> Items
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
decay) Items
itemMap)

{- | Run dmenu with the given command line options and a list of entries
from which the user should choose.

   Originally <https://github.com/m0rphism/haskell-dmenu/blob/master/src/DMenu/Run.hs select>.
-}
selectWith
    :: [String]     -- ^ List of options to give to dmenu.
    -> [ByteString] -- ^ List of executables from which the user should select.
    -> String       -- ^ The dmenu executable.
    -> IO (Either ProcessError ByteString)
    -- ^ The selection made by the user, or a 'ProcessError', if the user
    -- canceled.
selectWith :: [FilePath]
-> [ByteString] -> FilePath -> IO (Either ProcessError ByteString)
selectWith [FilePath]
opts [ByteString]
entries FilePath
dmenu = do
    -- Spawn the process with the available options and entries.
    (ExitCode
exitCode, ByteString
sOut, ByteString
sErr) <-
        CreateProcess
-> ByteString -> IO (ExitCode, ByteString, ByteString)
readCreateProcessWithExitCode (FilePath -> [FilePath] -> CreateProcess
proc FilePath
dmenu [FilePath]
opts) ([ByteString] -> ByteString
BS.unlines [ByteString]
entries)

    Either ProcessError ByteString
-> IO (Either ProcessError ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure case ExitCode
exitCode of
        -- Take first (= selected) word or return the error message.
        ExitFailure Int
i -> ProcessError -> Either ProcessError ByteString
forall a b. a -> Either a b
Left (Int
i, ByteString
sErr)
        ExitCode
ExitSuccess   -> ByteString -> Either ProcessError ByteString
forall a b. b -> Either a b
Right (ByteString -> Either ProcessError ByteString)
-> ByteString -> Either ProcessError ByteString
forall a b. (a -> b) -> a -> b
$! (Char -> Bool) -> ByteString -> ByteString
BS.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') ByteString
sOut

-- | Try to read a file that contains a map.  Return an empty map if the
-- file doesn't exist.
tryRead :: FilePath -> IO Items
tryRead :: FilePath -> IO Items
tryRead FilePath
file = IO Bool -> IO Items -> IO Items -> IO Items
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (FilePath -> IO Bool
doesFileExist FilePath
file) (FilePath -> IO Items
getHist FilePath
file) (Items -> IO Items
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Items
forall a. Monoid a => a
mempty)

-- | Get all executables from all dirs in $PATH.
getExecutables :: IO [ByteString]
getExecutables :: IO [ByteString]
getExecutables = ([[ByteString]] -> [ByteString])
-> IO [[ByteString]] -> IO [ByteString]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
               (IO [[ByteString]] -> IO [ByteString])
-> (ByteString -> IO [[ByteString]])
-> ByteString
-> IO [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ByteString -> IO [ByteString])
-> [ByteString] -> IO [[ByteString]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ByteString -> IO [ByteString]
listExecutables
               ([ByteString] -> IO [[ByteString]])
-> (ByteString -> [ByteString]) -> ByteString -> IO [[ByteString]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> ByteString -> [ByteString]
BS.split Char
':'
             (ByteString -> IO [ByteString]) -> IO ByteString -> IO [ByteString]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> ByteString -> IO ByteString
getEnvDefault ByteString
"PATH" ByteString
""

-- | List all executables in the given directory. Only try listing the
-- directory if it actually exists; this is necessary, since people may
-- have non-existent things in their path.
listExecutables :: ByteString -> IO [ByteString]
listExecutables :: ByteString -> IO [ByteString]
listExecutables ByteString
dir = IO Bool -> IO [ByteString] -> IO [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (ByteString -> IO Bool
fileExist ByteString
dir) (ByteString -> IO [ByteString]
getDirContents ByteString
dir) ([ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
  where
    getDirContents :: ByteString -> IO [ByteString]
    getDirContents :: ByteString -> IO [ByteString]
getDirContents =
        ([ByteString] -> (DirType, ByteString) -> IO [ByteString])
-> [ByteString] -> ByteString -> IO [ByteString]
forall (m :: * -> *) s.
MonadUnliftIO m =>
(s -> (DirType, ByteString) -> m s) -> s -> ByteString -> m s
traverseDirectoryContents
            (\[ByteString]
xs (DirType
dt, ByteString
name) -> DirType -> ByteString -> IO Bool
isDirDT DirType
dt ByteString
name IO Bool -> (Bool -> [ByteString]) -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Bool
d -> if Bool
d then [ByteString]
xs else ByteString
name ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
xs)
            []

-- | Apply 'evalDir' to some list of file paths.
evalDirs :: [ByteString] -> IO [ByteString]
evalDirs :: [ByteString] -> IO [ByteString]
evalDirs = ([[ByteString]] -> [ByteString])
-> IO [[ByteString]] -> IO [ByteString]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[ByteString]] -> [ByteString]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[ByteString]] -> IO [ByteString])
-> ([ByteString] -> IO [[ByteString]])
-> [ByteString]
-> IO [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (ByteString -> IO [ByteString])
-> [ByteString] -> IO [[ByteString]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ByteString -> IO [ByteString]
evalDir

-- | How to eval a directory.
type EvalMode :: Type
data EvalMode = NoRecursion | Recurse

-- | If the given file path is a directory, try to list all of its
-- contents; otherwise just return the file path as is.
evalDir :: ByteString -> IO [ByteString]
evalDir :: ByteString -> IO [ByteString]
evalDir ByteString
dir = do
    (EvalMode
r, ByteString
pth) <- IO (EvalMode, ByteString)
shapePath
    Bool
isDir <- IO Bool -> (SomeException -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (FileStatus -> Bool
isDirectory (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO FileStatus
getFileStatus ByteString
pth)
                   (\(SomeException
_ :: SomeException) -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
    if Bool
isDir
    then case EvalMode
r of      -- list directory
            EvalMode
NoRecursion -> (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString
dir </>) ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO [ByteString]
listExecutables ByteString
pth
            EvalMode
Recurse     -> ByteString -> IO [ByteString]
allDirectoryContents' ByteString
pth
    else [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ByteString
dir]
  where
    shapePath :: IO (EvalMode, ByteString)
    shapePath :: IO (EvalMode, ByteString)
shapePath = do
        -- Try to make the path absolute.
        ByteString
absPath <- do
            ByteString
home <- ByteString -> ByteString -> IO ByteString
getEnvDefault ByteString
"HOME" ByteString
""
            ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ if ByteString
"~/" ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
dir then ByteString
home ByteString -> ByteString -> ByteString
</> Int -> ByteString -> ByteString
BS.drop Int
2 ByteString
dir else ByteString
dir
        let recurse :: (EvalMode, ByteString)
recurse | ByteString
"**" ByteString -> ByteString -> Bool
`BS.isSuffixOf` ByteString
absPath = (EvalMode
Recurse, Int -> ByteString -> ByteString
BS.dropEnd Int
2 ByteString
absPath)
                    | Bool
otherwise                    = (EvalMode
NoRecursion, ByteString
absPath)
        (EvalMode, ByteString) -> IO (EvalMode, ByteString)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvalMode, ByteString)
recurse

-- | Check if the given file path is a directory. The given directory
-- type @dt@ is assumed to be the actual one for @fp@.
isDirDT :: DirType -> RawFilePath -> IO Bool
isDirDT :: DirType -> ByteString -> IO Bool
isDirDT DirType
dt ByteString
fp
    | DirType
dt DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
dtDir     = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    | DirType
dt DirType -> DirType -> Bool
forall a. Eq a => a -> a -> Bool
== DirType
dtUnknown = FileStatus -> Bool
isDirectory (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO FileStatus
getFileStatus ByteString
fp
    | Bool
otherwise       = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

-- | Pretty print our items.
showItems :: Items -> ByteString
showItems :: Items -> ByteString
showItems = [ByteString] -> ByteString
BS.unlines ([ByteString] -> ByteString)
-> (Items -> [ByteString]) -> Items -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((ByteString, Double) -> ByteString)
-> [(ByteString, Double)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Double) -> ByteString
showItem ([(ByteString, Double)] -> [ByteString])
-> (Items -> [(ByteString, Double)]) -> Items -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Items -> [(ByteString, Double)]
Items -> [Item Items]
forall l. IsList l => l -> [Item l]
toList
  where
    -- Pretty print a single (application, score) tuple.
    showItem :: (ByteString, Double) -> ByteString
    showItem :: (ByteString, Double) -> ByteString
showItem (ByteString
k, Double
v) = ByteString
k ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Double -> ByteString
toShortest Double
v

-- | Decide what to actually do with the user selection from dmenu.
decideSelection :: ByteString -> Config -> ByteString
decideSelection :: ByteString -> Config -> ByteString
decideSelection ByteString
sel Config{ [ByteString]
files :: Config -> [ByteString]
files :: [ByteString]
files, [ByteString]
tty :: Config -> [ByteString]
tty :: [ByteString]
tty, ByteString -> ByteString
term :: Config -> ByteString -> ByteString
term :: ByteString -> ByteString
term, ByteString -> ByteString
open :: Config -> ByteString -> ByteString
open :: ByteString -> ByteString
open }
    | ByteString
sel ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
files = OpenIn -> ByteString -> ByteString
openWith ((ByteString -> ByteString) -> OpenIn
Open ByteString -> ByteString
open) ByteString
sel
    | ByteString
sel ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
tty   = OpenIn -> ByteString -> ByteString
openWith ((ByteString -> ByteString) -> OpenIn
Term ByteString -> ByteString
term) ByteString
sel
    | Bool
otherwise        = ByteString
sel

-- | Turn a list into 'Items' and set all starting values to 0.
makeNewEntries :: [ByteString] -> Items
makeNewEntries :: [ByteString] -> Items
makeNewEntries = (ByteString -> Double) -> Set ByteString -> Items
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Double -> ByteString -> Double
forall a b. a -> b -> a
const Double
0) (Set ByteString -> Items)
-> ([ByteString] -> Set ByteString) -> [ByteString] -> Items
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [Item (Set ByteString)] -> Set ByteString
[ByteString] -> Set ByteString
forall l. IsList l => [Item l] -> l
fromList

-- | Sort 'Items' by its values and return the list of keys.
-- This will make often used commands bubble up to the top.
sortByValues :: Items -> [ByteString]
sortByValues :: Items -> [ByteString]
sortByValues = ((ByteString, Double) -> ByteString)
-> [(ByteString, Double)] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString, Double) -> ByteString
forall a b. (a, b) -> a
fst ([(ByteString, Double)] -> [ByteString])
-> (Items -> [(ByteString, Double)]) -> Items -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((ByteString, Double) -> (ByteString, Double) -> Ordering)
-> [(ByteString, Double)] -> [(ByteString, Double)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Double -> Double -> Ordering) -> Double -> Double -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Double -> Double -> Ordering)
-> ((ByteString, Double) -> Double)
-> (ByteString, Double)
-> (ByteString, Double)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (ByteString, Double) -> Double
forall a b. (a, b) -> b
snd) ([(ByteString, Double)] -> [(ByteString, Double)])
-> (Items -> [(ByteString, Double)])
-> Items
-> [(ByteString, Double)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Items -> [(ByteString, Double)]
Items -> [Item Items]
forall l. IsList l => l -> [Item l]
toList