100 lines
3.3 KiB
Haskell
100 lines
3.3 KiB
Haskell
{-# LANGUAGE DeriveAnyClass,
|
|
DeriveGeneric,
|
|
DerivingVia,
|
|
DuplicateRecordFields,
|
|
LambdaCase,
|
|
GADTs,
|
|
NoFieldSelectors,
|
|
OverloadedRecordDot,
|
|
RecordWildCards,
|
|
OverloadedStrings #-}
|
|
module Main (main) where
|
|
|
|
import WithCli
|
|
import Control.Monad.Reader
|
|
import Data.Yaml
|
|
import Data.Functor
|
|
import Data.Maybe
|
|
import System.Environment.XDG.BaseDir
|
|
import Data.HashMap.Lazy (HashMap, insert, alter, toList)
|
|
import System.Environment.XDG.DesktopEntry
|
|
import System.Process
|
|
|
|
data Options = Options {
|
|
config :: Maybe FilePath,
|
|
cache :: Maybe FilePath,
|
|
dmenu :: Bool
|
|
}
|
|
deriving (Show, Generic, HasArguments)
|
|
|
|
defaultCachePath :: IO FilePath
|
|
defaultCachePath = getUserCacheFile "mide" "cache.yaml"
|
|
|
|
defaultConfigPath :: IO FilePath
|
|
defaultConfigPath = getUserConfigFile "mide" "config.yaml"
|
|
|
|
data TConfig where
|
|
Config :: { cachePath :: Maybe FilePath } -> TConfig
|
|
deriving (Show, Generic, FromJSON, ToJSON)
|
|
|
|
class Config a where
|
|
cachePath :: a -> IO FilePath
|
|
|
|
instance Config TConfig where
|
|
cachePath = (\case
|
|
Nothing -> defaultCachePath
|
|
Just f -> pure f) . (.cachePath)
|
|
|
|
type Cache = HashMap String Int
|
|
|
|
data CacheItem = CacheItem { name :: String
|
|
, uses :: Int
|
|
}
|
|
deriving (Show, Generic, FromJSON, ToJSON)
|
|
|
|
data Item where
|
|
AppItem :: DesktopEntry -> Item
|
|
DMenuItem :: String -> Item
|
|
deriving Show
|
|
|
|
type State = (TConfig, Cache)
|
|
|
|
main :: IO ()
|
|
main = withCliModified [ AddShortOption "config" 'c',
|
|
AddShortOption "dmenu" 'd',
|
|
AddOptionHelp "config" "Point to the file containing yaml for configuration",
|
|
AddOptionHelp "cache" "Point to the file containing yaml for cache",
|
|
AddOptionHelp "dmenu" "Run in dmenu version"
|
|
]
|
|
run
|
|
|
|
run :: Options -> IO ()
|
|
run opts =
|
|
maybe defaultConfigPath pure opts.config >>= \configPath ->
|
|
decodeFileEither configPath >>= either (const $ Config . pure <$> defaultCachePath) pure >>= \config ->
|
|
(cachePath config >>= decodeFileEither <&> either mempty ((foldr (\p -> insert p.name p.uses) mempty) :: [CacheItem] -> HashMap String Int)) >>= \cache ->
|
|
runReaderT ( updateCache =<< execItem =<< presentOptions =<< if opts.dmenu then dmenu else normal) (config,cache)
|
|
|
|
normal :: (MonadIO m, MonadReader State m) => m [Item]
|
|
normal = liftIO getDirectoryEntriesDefault <&> (AppItem <$>)
|
|
|
|
dmenu :: (MonadIO m, MonadReader State m) => m [Item]
|
|
dmenu = liftIO getContents <&> (DMenuItem <$>) . lines
|
|
|
|
presentOptions :: (MonadIO m, MonadReader State m) => [Item] -> m Item
|
|
presentOptions ls = mapM_ (liftIO . print) ls >> pure (head ls)
|
|
|
|
execItem :: (MonadIO m, MonadReader State m) => Item -> m Item
|
|
execItem i = (case i of
|
|
AppItem de -> liftIO (maybe undefined (void . spawnCommand) (deCommand de))
|
|
DMenuItem s -> liftIO (putStrLn s)) >> pure i
|
|
|
|
updateCache :: (MonadIO m, MonadReader State m) => Item -> m ()
|
|
updateCache i =
|
|
let name = case i of
|
|
AppItem d -> deName [] d
|
|
DMenuItem s -> s in
|
|
ask >>= \(conf, hmap) ->
|
|
liftIO (cachePath conf >>= \path -> encodeFile path . map (uncurry CacheItem) . toList $
|
|
alter (\case Nothing -> pure 1; Just x -> pure (x+1)) name hmap)
|