Cleanup wizards-dialog
This commit is contained in:
parent
3499fb951f
commit
9b4c7e1d28
|
@ -1,2 +0,0 @@
|
||||||
# DO NOT HAND-EDIT THIS FILE
|
|
||||||
import (import ./thunk.nix)
|
|
|
@ -1,8 +0,0 @@
|
||||||
{
|
|
||||||
"owner": "obsidiansystems",
|
|
||||||
"repo": "obelisk",
|
|
||||||
"branch": "release/0.9.0.1",
|
|
||||||
"private": false,
|
|
||||||
"rev": "11beb6e8cd2419b2429925b76a98f24035e40985",
|
|
||||||
"sha256": "0b4m33b7yyzsbkvfz2kwg4v9hlnvbjlmjikbvwd7pg52vy84and0"
|
|
||||||
}
|
|
|
@ -1,9 +0,0 @@
|
||||||
# DO NOT HAND-EDIT THIS FILE
|
|
||||||
let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
|
|
||||||
if !fetchSubmodules && !private then builtins.fetchTarball {
|
|
||||||
url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
|
|
||||||
} else (import <nixpkgs> {}).fetchFromGitHub {
|
|
||||||
inherit owner repo rev sha256 fetchSubmodules private;
|
|
||||||
};
|
|
||||||
json = builtins.fromJSON (builtins.readFile ./github.json);
|
|
||||||
in fetch json
|
|
|
@ -1,142 +0,0 @@
|
||||||
{-# 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
|
|
|
@ -1,59 +0,0 @@
|
||||||
cabal-version: >=1.10
|
|
||||||
|
|
||||||
-- Initial package description 'haskell-dialog.cabal' generated by 'cabal
|
|
||||||
-- init'. For further documentation, see
|
|
||||||
-- http://haskell.org/cabal/users-guide/
|
|
||||||
|
|
||||||
name: wizards-dialog
|
|
||||||
version: 0.1.0.0
|
|
||||||
|
|
||||||
-- synopsis:
|
|
||||||
-- description:
|
|
||||||
-- bug-reports:
|
|
||||||
license: AGPL
|
|
||||||
author: Malte Brandy
|
|
||||||
maintainer: malte.brandy@maralorn.de
|
|
||||||
|
|
||||||
-- copyright:
|
|
||||||
-- category:
|
|
||||||
build-type: Simple
|
|
||||||
extra-source-files: CHANGELOG.md
|
|
||||||
|
|
||||||
library
|
|
||||||
ghc-options: -Wall
|
|
||||||
exposed-modules: Dialog
|
|
||||||
-- other-extensions:
|
|
||||||
build-depends:
|
|
||||||
base >=4.13
|
|
||||||
, haskeline
|
|
||||||
, wizards
|
|
||||||
, ansi-terminal
|
|
||||||
, text
|
|
||||||
, witch
|
|
||||||
, relude
|
|
||||||
, process
|
|
||||||
|
|
||||||
-- hs-source-dirs:
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
executable hotkeys
|
|
||||||
main-is: Main.hs
|
|
||||||
|
|
||||||
ghc-options: -Wall
|
|
||||||
-- other-extensions:
|
|
||||||
build-depends:
|
|
||||||
base >=4.13
|
|
||||||
, aeson >= 2.0.1.0
|
|
||||||
, haskeline
|
|
||||||
, daemons
|
|
||||||
, ansi-terminal
|
|
||||||
, text
|
|
||||||
, relude
|
|
||||||
, process
|
|
||||||
, witch
|
|
||||||
, wizards
|
|
||||||
, wizards-dialog
|
|
||||||
, yaml
|
|
||||||
|
|
||||||
-- hs-source-dirs:
|
|
||||||
default-language: Haskell2010
|
|
142
apps/wizards-dialog/Dialog.hs
Normal file
142
apps/wizards-dialog/Dialog.hs
Normal file
|
@ -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
|
|
@ -22,27 +22,27 @@ import Dialog (Menu (..), MenuEntry (Option, SubMenu), menu, runClearingHaskelin
|
||||||
data Command = Run Text | Fork Text deriving (Show)
|
data Command = Run Text | Fork Text deriving (Show)
|
||||||
|
|
||||||
instance FromJSON (Menu Command) where
|
instance FromJSON (Menu Command) where
|
||||||
parseJSON = parseMenu "Hotkeys"
|
parseJSON = parseMenu "Hotkeys"
|
||||||
where
|
where
|
||||||
parseList name = (fmap (Menu name) .) $
|
parseList name = (fmap (Menu name) .) $
|
||||||
mapM $ \(Key.toText -> key, val) ->
|
mapM $ \(Key.toText -> key, val) ->
|
||||||
case val of
|
case val of
|
||||||
String cmd -> pure $ Dialog.Option key (text2cmd cmd)
|
String cmd -> pure $ Dialog.Option key (text2cmd cmd)
|
||||||
innerObj -> Dialog.SubMenu <$> parseMenu key innerObj
|
innerObj -> Dialog.SubMenu <$> parseMenu key innerObj
|
||||||
unpackMenu (Array arr) = join <$> mapM unpackMenu (reverse $ Foldable.toList arr)
|
unpackMenu (Array arr) = join <$> mapM unpackMenu (reverse $ Foldable.toList arr)
|
||||||
unpackMenu value = withObject "mapping to menu entries" (pure . reverse . Aeson.toList) value
|
unpackMenu value = withObject "mapping to menu entries" (pure . reverse . Aeson.toList) value
|
||||||
parseMenu name = parseList name <=< unpackMenu
|
parseMenu name = parseList name <=< unpackMenu
|
||||||
text2cmd t = if Text.isPrefixOf "fork " t then Fork (Text.drop 5 t) else Run t
|
text2cmd t = if Text.isPrefixOf "fork " t then Fork (Text.drop 5 t) else Run t
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
[menuFileName] <- getArgs
|
[menuFileName] <- getArgs
|
||||||
menuCommand <- decodeFileEither menuFileName
|
menuCommand <- decodeFileEither menuFileName
|
||||||
case menuCommand of
|
case menuCommand of
|
||||||
Left err -> print err
|
Left err -> print err
|
||||||
Right a -> do
|
Right a -> do
|
||||||
cmd <- runClearingHaskeline $ menu Nothing a
|
cmd <- runClearingHaskeline $ menu Nothing a
|
||||||
maybe pass runCommand cmd
|
maybe pass runCommand cmd
|
||||||
|
|
||||||
runCommand :: Command -> IO ()
|
runCommand :: Command -> IO ()
|
||||||
runCommand (Run cmd) = callCommand $ into cmd
|
runCommand (Run cmd) = callCommand $ into cmd
|
Loading…
Reference in a new issue