From d05745808f9d01e55dbf6a7370c73df3ae4a2a99 Mon Sep 17 00:00:00 2001 From: Malte Brandy Date: Wed, 13 Oct 2021 00:47:01 +0200 Subject: [PATCH] Add menu --- Dialog.hs | 142 +++++++++++++++++++++++++++++++++++++++ Main.hs | 155 +++++++++++-------------------------------- haskell-dialog.cabal | 9 ++- menu.json | 9 +++ 4 files changed, 195 insertions(+), 120 deletions(-) create mode 100644 Dialog.hs create mode 100644 menu.json diff --git a/Dialog.hs b/Dialog.hs new file mode 100644 index 00000000..e82b1fcd --- /dev/null +++ b/Dialog.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Dialog ( + runHaskeline, + runClearingHaskeline, + Menu (..), + MenuEntry (..), + menu, + confirm, + getLineWithDefaultAndSuggestions +) where + +import Control.Applicative (Alternative ((<|>))) +import Control.Monad (MonadPlus (mzero)) +import Control.Monad.IO.Class +import Data.Char ( + isLower, + isUpper, + toLower, + toUpper, + ) +import Data.List +import Data.Maybe +import Data.Text (Text) +import System.Console.ANSI +import System.Console.Haskeline +import System.Console.Wizard +import System.Console.Wizard.Haskeline +import System.Console.Wizard.Internal +import Witch + +newtype ClearingHaskeline a = ClearingHaskeline {runClearing :: InputT IO a} deriving newtype (Functor, Applicative, Monad) + +instance Run ClearingHaskeline Haskeline where + runAlgebra = + ClearingHaskeline . prependClearing . runAlgebra . fmap runClearing + where + prependClearing a = liftIO (clearScreen >> setCursorPosition 0 0) >> a + +data MenuEntry a = Option Text a | SubMenu (Menu a) deriving (Show) + +data Menu a = Menu Text [MenuEntry a] + deriving (Show) + +cancelCharacter :: Char +cancelCharacter = '.' + +menu :: + forall a m. + (Character :<: m, Show a) => + Maybe Text -> + Menu a -> + Wizard m a +menu = runMenu True + where + runMenu top prompt thisMenu@(Menu name options) = do + response <- + retry . validator (`elem` hotkeys) $ + character + (intercalate "\n" wholePrompt) + case lookup (toLower response) mappings of + Just (Option _ a) -> pure a + Just (SubMenu submenu) -> + runMenu False prompt submenu <|> runMenu True prompt thisMenu + Nothing -> mzero + where + hotkeys :: [Char] + mappings :: [(Char, MenuEntry a)] + (hotkeys, mappings) = foldr foldMappings ([cancelCharacter], []) options + + foldMappings :: + MenuEntry a -> + ([Char], [(Char, MenuEntry a)]) -> + ([Char], [(Char, MenuEntry a)]) + foldMappings option accu@(accuHotkeys, accuMappings) + | Just hotkey <- chooseHotkey accuHotkeys (getLabel option) = + (hotkey : accuHotkeys, accuMappings <> [(hotkey, option)]) + | otherwise = + accu + + chooseHotkey :: [Char] -> [Char] -> Maybe Char + chooseHotkey used label = + find (`notElem` used) $ + toLower + <$> filter isUpper label + <> filter isLower label + <> label + + getLabel :: MenuEntry a -> String + getLabel (Option label _) = into label + getLabel (SubMenu (Menu label _)) = into label + + wholePrompt :: [String] + wholePrompt = + maybe id (:) (into <$> prompt) $ + into name : + (if top then ".: Leave Menu" else ".: Back") : + ((promptLabel <$> mappings) <> ["> "]) + + promptLabel :: (Char, MenuEntry a) -> [Char] + promptLabel (c, option) = toUpper c : (": " <> getLabel option) + +confirm :: Character :<: m => Text -> Wizard m Bool +confirm prompt = + menu Nothing $ Menu prompt [Option "Yes" True, Option "No" False] + +-- From Hledger.Cli.Commands.Add +withCompletion :: + (WithSettings :<: m) => CompletionFunc IO -> Wizard m a -> Wizard m a +withCompletion c = withSettings (setComplete c defaultSettings) + +getLineWithDefaultAndSuggestions :: + (WithSettings :<: m, LinePrewritten :<: m) => + PromptString -> + Maybe String -> + [String] -> + Wizard m String +getLineWithDefaultAndSuggestions prompt startInput completions = + retry . withCompletion completeFunc $ + linePrewritten + (prompt <> "\n> ") + prewritten + "" + where + completeFunc (before, _) = pure ("", simpleCompletion <$> match completions) + where + match = filter (isInfixOf $ reverse before) + prewritten = fromMaybe "" startInput + +runHaskeline :: MonadIO m => Wizard Haskeline a -> m (Maybe a) +runHaskeline = liftIO . runInputT defaultSettings . run + +runClearingHaskeline :: MonadIO m => Wizard Haskeline a -> m (Maybe a) +runClearingHaskeline = liftIO . runInputT defaultSettings . runClearing . run diff --git a/Main.hs b/Main.hs index 22f30a32..35f52bd7 100644 --- a/Main.hs +++ b/Main.hs @@ -1,123 +1,42 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-orphans #-} -import Control.Monad.IO.Class -import System.Console.Wizard -import System.Console.Wizard.Internal -import System.Console.Haskeline -import System.Console.Wizard.Haskeline -import System.Console.ANSI -import Data.Maybe -import Data.List -import Control.Monad ( MonadPlus(mzero) ) -import Control.Applicative ( Alternative((<|>)) ) -import Data.Char ( isLower - , isUpper - , toUpper - , toLower - ) +import Data.Aeson ( + FromJSON (..), + eitherDecodeFileStrict', + withObject, + ) +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as Aeson +import Data.Aeson.Types (Value (String)) +import Dialog +import Relude +import System.Process (callCommand) +import Witch -newtype ClearingHaskeline a = ClearingHaskeline { runClearing :: InputT IO a } deriving newtype (Functor, Applicative, Monad) +type Command = Text -instance Run ClearingHaskeline Haskeline where - runAlgebra = - ClearingHaskeline . prependClearing . runAlgebra . fmap runClearing - where - prependClearing a = liftIO (clearScreen >> setCursorPosition 0 0) >> a +instance FromJSON (Menu Command) where + parseJSON = parseMenu "Hotkeys" + where + parseMenu name = withObject "mapping to menu entries" $ \object -> + fmap (Menu name) $ + forM (Aeson.toList object) $ \(Key.toText -> key, val) -> + case val of + String cmd -> pure $ Dialog.Option key cmd + innerObj -> Dialog.SubMenu <$> parseMenu key innerObj -data MenuEntry a = Option String a | SubMenu (Menu a) deriving Show +main :: IO () +main = do + menuCommand <- eitherDecodeFileStrict' "menu.json" + case menuCommand of + Left err -> putStrLn err + Right a -> do + cmd <- runClearingHaskeline $ menu Nothing a + maybe pass runCommand cmd -data Menu a = Menu String [MenuEntry a] - deriving Show - -cancelCharacter :: Char -cancelCharacter = '.' - -menu - :: forall a m - . (Character :<: m, Show a) - => Maybe String - -> Menu a - -> Wizard m a -menu = runMenu True - where - runMenu top prompt thisMenu@(Menu name options) = do - response <- retry . validator (`elem` hotkeys) $ character - (intercalate "\n" wholePrompt) - case lookup (toLower response) mappings of - Just (Option _ a) -> pure a - Just (SubMenu submenu) -> - runMenu False prompt submenu <|> runMenu True prompt thisMenu - Nothing -> mzero - where - hotkeys :: [Char] - mappings :: [(Char, MenuEntry a)] - (hotkeys, mappings) = foldr foldMappings ([cancelCharacter], []) options - - foldMappings - :: MenuEntry a - -> ([Char], [(Char, MenuEntry a)]) - -> ([Char], [(Char, MenuEntry a)]) - foldMappings option accu@(accuHotkeys, accuMappings) - | Just hotkey <- chooseHotkey accuHotkeys (getLabel option) - = (hotkey : accuHotkeys, accuMappings <> [(hotkey, option)]) - | otherwise - = accu - - chooseHotkey :: [Char] -> [Char] -> Maybe Char - chooseHotkey used label = - find (`notElem` used) - $ toLower - <$> filter isUpper label - <> filter isLower label - <> label - - getLabel :: MenuEntry a -> String - getLabel (Option label _ ) = label - getLabel (SubMenu (Menu label _)) = label - - wholePrompt :: [String] - wholePrompt = - maybe id (:) prompt - $ name - : (if top then ".: Leave Menu" else ".: Back") - : ((promptLabel <$> mappings) <> ["> "]) - - promptLabel :: (Char, MenuEntry a) -> [Char] - promptLabel (c, option) = toUpper c : (": " <> getLabel option) - -confirm :: Character :<: m => String -> Wizard m Bool -confirm prompt = - menu Nothing $ Menu prompt [Option "Yes" True, Option "No" False] - --- From Hledger.Cli.Commands.Add -withCompletion - :: (WithSettings :<: m) => CompletionFunc IO -> Wizard m a -> Wizard m a -withCompletion c = withSettings (setComplete c defaultSettings) - -getLineWithDefaultAndSuggestions - :: (WithSettings :<: m, LinePrewritten :<: m) - => PromptString - -> Maybe String - -> [String] - -> Wizard m String -getLineWithDefaultAndSuggestions prompt startInput completions = - retry . withCompletion completeFunc $ linePrewritten (prompt <> "\n> ") - prewritten - "" - where - completeFunc (before, _) = pure ("", simpleCompletion <$> match completions) - where match = filter (isInfixOf $ reverse before) - prewritten = fromMaybe "" startInput - -runHaskeline :: MonadIO m => Wizard Haskeline a -> m (Maybe a) -runHaskeline = liftIO . runInputT defaultSettings . run - -runClearingHaskeline :: MonadIO m => Wizard Haskeline a -> m (Maybe a) -runClearingHaskeline = liftIO . runInputT defaultSettings . runClearing . run +runCommand :: Command -> IO () +runCommand = callCommand . into diff --git a/haskell-dialog.cabal b/haskell-dialog.cabal index 484f0aac..cb1bd2c3 100644 --- a/haskell-dialog.cabal +++ b/haskell-dialog.cabal @@ -24,13 +24,18 @@ executable haskell-dialog main-is: Main.hs ghc-options: -Wall - -- other-modules: + other-modules: Dialog -- other-extensions: build-depends: - base >=4.13 && <4.14 + base >=4.13 && <4.15 + , aeson >= 2.0.1.0 , haskeline , wizards , ansi-terminal + , text + , witch + , relude + , process -- hs-source-dirs: default-language: Haskell2010 diff --git a/menu.json b/menu.json new file mode 100644 index 00000000..b8aaf957 --- /dev/null +++ b/menu.json @@ -0,0 +1,9 @@ +{ + "Firefox": "firefox", + "Htop": "htop", + "Discord": "discord", + "Headset": { + "connect": "bluetoothctl connect AC:12:2F:4F:EB:FA", + "disconnect": "bluetoothctl disconnect AC:12:2F:4F:EB:FA" + } +}