Now to present and get user input
This commit is contained in:
39
app/Main.hs
39
app/Main.hs
@@ -17,8 +17,9 @@ import Data.Yaml
|
|||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
import System.Environment.XDG.BaseDir
|
import System.Environment.XDG.BaseDir
|
||||||
import Data.HashMap.Lazy (HashMap, insert)
|
import Data.HashMap.Lazy (HashMap, insert, alter, toList)
|
||||||
import System.Environment.XDG.DesktopEntry
|
import System.Environment.XDG.DesktopEntry
|
||||||
|
import qualified Data.ByteString as BS
|
||||||
|
|
||||||
data Options = Options {
|
data Options = Options {
|
||||||
config :: Maybe FilePath,
|
config :: Maybe FilePath,
|
||||||
@@ -33,11 +34,16 @@ data Config a where
|
|||||||
|
|
||||||
type Cache = HashMap String Int
|
type Cache = HashMap String Int
|
||||||
|
|
||||||
data Item = Item { name :: String
|
data CacheItem = CacheItem { name :: String
|
||||||
, uses :: Int
|
, uses :: Int
|
||||||
}
|
}
|
||||||
deriving (Show, Generic, FromJSON, ToJSON)
|
deriving (Show, Generic, FromJSON, ToJSON)
|
||||||
|
|
||||||
|
data Item where
|
||||||
|
AppItem :: DesktopEntry -> Item
|
||||||
|
DMenuItem :: String -> Item
|
||||||
|
deriving Show
|
||||||
|
|
||||||
defaultCachePath :: IO FilePath
|
defaultCachePath :: IO FilePath
|
||||||
defaultCachePath = getUserCacheFile "mide" "cache.yaml"
|
defaultCachePath = getUserCacheFile "mide" "cache.yaml"
|
||||||
|
|
||||||
@@ -62,11 +68,28 @@ run :: Options -> IO ()
|
|||||||
run opts =
|
run opts =
|
||||||
maybe defaultConfigPath pure opts.config >>= \configPath ->
|
maybe defaultConfigPath pure opts.config >>= \configPath ->
|
||||||
decodeFileEither configPath >>= either (const $ Config . pure <$> defaultCachePath) pure >>= fixConfig >>= \config ->
|
decodeFileEither configPath >>= either (const $ Config . pure <$> defaultCachePath) pure >>= fixConfig >>= \config ->
|
||||||
(decodeFileEither config.cachePath <&> either mempty ((foldr (\p -> insert p.name p.uses) mempty) :: [Item] -> HashMap String Int)) >>= \cache ->
|
(decodeFileEither config.cachePath <&> either mempty ((foldr (\p -> insert p.name p.uses) mempty) :: [CacheItem] -> HashMap String Int)) >>= \cache ->
|
||||||
runReaderT (if opts.dmenu then dmenu else normal) (config,cache)
|
runReaderT ( updateCache =<< execItem =<< presentOptions =<< if opts.dmenu then dmenu else normal) (config,cache)
|
||||||
|
|
||||||
normal :: (MonadIO m, MonadReader State m) => m ()
|
normal :: (MonadIO m, MonadReader State m) => m [Item]
|
||||||
normal = liftIO getDirectoryEntriesDefault >>= mapM_ (liftIO . print)
|
normal = liftIO getDirectoryEntriesDefault <&> (AppItem <$>)
|
||||||
|
|
||||||
dmenu :: (MonadIO m, MonadReader State m) => m ()
|
dmenu :: (MonadIO m, MonadReader State m) => m [Item]
|
||||||
dmenu = undefined
|
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 (print $ 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 . encodeFile conf.cachePath . map (uncurry CacheItem) . toList $
|
||||||
|
alter (\case Nothing -> pure 1; Just x -> pure (x+1)) name hmap
|
||||||
|
|||||||
@@ -74,6 +74,7 @@ executable mide
|
|||||||
, yaml
|
, yaml
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, xdg-basedir
|
, xdg-basedir
|
||||||
|
, bytestring
|
||||||
|
|
||||||
-- Directories containing source files.
|
-- Directories containing source files.
|
||||||
hs-source-dirs: app
|
hs-source-dirs: app
|
||||||
|
|||||||
Reference in New Issue
Block a user