143 lines
4.3 KiB
Haskell
143 lines
4.3 KiB
Haskell
{-# 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
|