Merge ../haskell-dialog

apps/haskell-dialog/.gitignore

@@ -0,0 +1 @@
+/dist-newstyle

apps/haskell-dialog/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

apps/haskell-dialog/Main.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+import Relude
+import Witch
+
+import Data.Aeson (FromJSON (..), Value (Array, String), withObject)
+import qualified Data.Aeson.Key as Key
+import qualified Data.Aeson.KeyMap as Aeson
+import qualified Data.Foldable as Foldable
+import qualified Data.Text as Text
+import Data.Yaml (decodeFileEither)
+
+import System.Posix.Daemon (Redirection (DevNull), runDetached)
+import System.Process (callCommand)
+
+import Dialog (Menu (..), MenuEntry (Option, SubMenu), menu, runClearingHaskeline)
+
+data Command = Run Text | Fork Text deriving (Show)
+
+instance FromJSON (Menu Command) where
+   parseJSON = parseMenu "Hotkeys"
+     where
+      parseList name = (fmap (Menu name) .) $
+         mapM $ \(Key.toText -> key, val) ->
+            case val of
+               String cmd -> pure $ Dialog.Option key (text2cmd cmd)
+               innerObj -> Dialog.SubMenu <$> parseMenu key innerObj
+      unpackMenu (Array arr) = join <$> mapM unpackMenu (reverse $ Foldable.toList arr)
+      unpackMenu value = withObject "mapping to menu entries" (pure . reverse . Aeson.toList) value
+      parseMenu name = parseList name <=< unpackMenu
+      text2cmd t = if Text.isPrefixOf "fork " t then Fork (Text.drop 5 t) else Run t
+
+main :: IO ()
+main = do
+   [menuFileName] <- getArgs
+   menuCommand <- decodeFileEither menuFileName
+   case menuCommand of
+      Left err -> print err
+      Right a -> do
+         cmd <- runClearingHaskeline $ menu Nothing a
+         maybe pass runCommand cmd
+
+runCommand :: Command -> IO ()
+runCommand (Run cmd) = callCommand $ into cmd
+runCommand (Fork cmd) = runDetached Nothing DevNull (callCommand $ into cmd)

apps/haskell-dialog/haskell-dialog.cabal

@@ -0,0 +1,42 @@
+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:               haskell-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
+
+executable hotkeys
+  main-is:          Main.hs
+
+  ghc-options: -Wall
+  other-modules:    Dialog
+  -- other-extensions:
+  build-depends:
+      base       >=4.13
+    , aeson      >= 2.0.1.0
+    , haskeline
+    , daemons
+    , wizards
+    , ansi-terminal
+    , text
+    , witch
+    , relude
+    , process
+    , yaml
+
+  -- hs-source-dirs:
+  default-language: Haskell2010

apps/haskell-dialog/menu.yaml

@@ -0,0 +1,10 @@
+Htop: htop
+Web:
+   - Thunderbird: fork thunderbird
+     Banana: "echo lol"
+   - Firefox: fork firefox
+Test:
+   - B: "b"
+   - A: "a"
+   - D: "d"
+     C: "c"