stack-run-0.1.1.2: src/System/Console/Questioner.hs
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverlappingInstances #-}
module System.Console.Questioner
(
Question(..)
, ChoiceEvent
, charToChoiceEvent
, listPrompt
, checkboxPrompt
, module System.Console.Questioner.ProgressIndicators
)
where
import Control.Applicative ((<$>))
import Control.Concurrent.STM
import Control.Monad (forM_, (>=>))
import Data.List (delete)
import Graphics.Vty (Event (..),
Key (..),
Modifier (..))
import qualified Graphics.Vty as Vty
import System.Console.ANSI (Color (..), ColorIntensity (..), ConsoleIntensity (..), ConsoleLayer (..),
SGR (..),
clearLine,
cursorUpLine,
setSGR)
import System.Console.Questioner.ProgressIndicators
import System.Console.Questioner.Util
import System.Exit
import System.IO (hFlush, stdin,
stdout)
-- Base `Question` and `Question` instances
-------------------------------------------------------------------------------
class Question q a where
prompt :: q -> IO a
instance {-# OVERLAPPABLE #-} Read a => Question String a where
prompt = putStr . (++ " ") >=> const readLn
instance {-# OVERLAPPING #-} Question String String where
prompt = putStr . (++ " ") >=> const getLine
instance {-# OVERLAPPING #-} Question String (Maybe String) where
prompt = putStr . (++ " ") >=> const getLine >=> helper
where
helper [] = return Nothing
helper s = return $ Just s
instance {-# OVERLAPPING #-} Question (String, (String, String)) String where
prompt (s, (o1, o2)) = do
putStr s
putStr $ " (" ++ o1 ++ "/" ++ o2 ++ ") "
getLine
instance {-# OVERLAPPING #-} Question (String, [String]) String where
prompt = uncurry listPrompt
instance {-# OVERLAPPING #-} Question (String, [String]) [String] where
prompt = uncurry checkboxPrompt
-- Multiple choice prompts
-------------------------------------------------------------------------------
data ChoiceEvent = MoveUp | MoveDown | MakeChoice | ToggleSelection | Exit
deriving(Eq, Ord, Show)
charToChoiceEvent :: Char -> Maybe ChoiceEvent
charToChoiceEvent 'j' = Just MoveDown
charToChoiceEvent 'k' = Just MoveUp
charToChoiceEvent '\n' = Just MakeChoice
charToChoiceEvent ' ' = Just ToggleSelection
charToChoiceEvent _ = Nothing
-- simpleListPrompt options choices = setup $ do
-- inp <- Vty.inputForConfig =<< Vty.standardIOConfig
-- selection <- waitForSelection (Vty._eventChannel inp) 0
-- setSGR []
-- clearScreen
-- setCursorPosition 0 0
-- Vty.shutdownInput inp
-- return selection
-- where
-- setup = withNoBuffering stdin NoBuffering . withNoCursor . withNoEcho
-- numChoices = length choices
-- waitForSelection ichan currentIdx = do
-- clearScreen
-- renderListOptions options def choices currentIdx
-- e <- atomically $ readTChan ichan
-- case e of
-- EvKey KEnter _ -> return $ Just (choices !! currentIdx)
-- EvKey (KChar 'n') [MCtrl] -> onDown
-- EvKey (KChar 'j') _ -> onDown
-- EvKey KDown _ -> onDown
-- EvKey (KChar 'p') [MCtrl] -> onUp
-- EvKey (KChar 'k') _ -> onUp
-- EvKey KUp _ -> onUp
-- EvKey (KChar 'q') _ -> return Nothing
-- EvKey KEsc _ -> return Nothing
-- _ -> waitForSelection ichan currentIdx
-- where
-- onDown = waitForSelection ichan ((currentIdx + 1) `rem` numChoices)
-- onUp = let currentIdx' = if currentIdx == 0
-- then length choices - 1
-- else currentIdx - 1
-- in waitForSelection ichan currentIdx'
listPrompt :: String -> [String] -> IO String
listPrompt question options = setup $ do
putStrLn question
-- selection has structure: (selected item's index, indexed options)
let selection = (0, zip options ([0..] :: [Int]))
mi <- listenForSelection selection
case mi of
Just i -> return (options !! i)
Nothing -> exitSuccess
where
setup = hWithNoBuffering stdin . withNoEcho
listenForSelection selection = do
inp <- Vty.inputForConfig =<< Vty.standardIOConfig
go (Vty._eventChannel inp) selection
where
go c os = do
render os
hFlush stdout
e <- atomically (readTChan c)
case e of
EvKey KEnter _ -> do
-- makeChoice
return (Just (fst os))
EvKey (KChar 'n') [MCtrl] -> do
clearFromCursorTo $ length $ snd os
go c (updateSelection MoveDown os)
EvKey (KChar 'j') _ -> do
clearFromCursorTo $ length $ snd os
go c (updateSelection MoveDown os)
EvKey KDown _ -> do
clearFromCursorTo $ length $ snd os
go c (updateSelection MoveDown os)
EvKey (KChar 'p') [MCtrl] -> do
clearFromCursorTo $ length $ snd os
go c (updateSelection MoveUp os)
EvKey (KChar 'k') _ -> do
clearFromCursorTo $ length $ snd os
go c (updateSelection MoveUp os)
EvKey KUp _ -> do
clearFromCursorTo $ length $ snd os
go c (updateSelection MoveUp os)
EvKey (KChar 'q') _ ->
return Nothing
EvKey (KChar 'c') [MCtrl] ->
return Nothing
EvKey KEsc _ ->
return Nothing
_ -> go c os
makeChoice = forM_ (replicate (length (snd selection)) ())
(const (clearLine >> cursorUpLine 1))
updateSelection MoveUp (i, os) = ((i - 1) `mod` length os, os)
updateSelection MoveDown (i, os) = ((i + 1) `mod` length os, os)
updateSelection _ _ = error "Internal error, key not recognized"
render (s, optionsI) = forM_ optionsI $ \(o, i) ->
if i == s
then do
setSGR [ SetColor Foreground Vivid White
, SetConsoleIntensity BoldIntensity
]
putStr "> "
setSGR [ SetColor Foreground Vivid Cyan
, SetConsoleIntensity NormalIntensity
]
putStrLn $ o
setSGR []
else putStrLn $ " " ++ o
checkboxPrompt :: String -> [String] -> IO [String]
checkboxPrompt question options = setup $ do
putStrLn question
let selection = (0, [], zip options ([0..] :: [Int]))
render selection
is <- listenForSelection selection
return $ map (options !!) is
where
setup = hWithNoBuffering stdin . withNoEcho
listenForSelection :: (Int, [Int], [(String, Int)]) -> IO [Int]
listenForSelection selection@(_, _, s3) = do
inp <- Vty.inputForConfig =<< Vty.standardIOConfig
go (Vty._eventChannel inp) selection
where
go :: TChan Event -> (Int, [Int], [(String, Int)]) -> IO [Int]
go c os@(_, os2, os3) = do
render os
hFlush stdout
e <- atomically (readTChan c)
print e
case e of
EvKey KEnter _ -> do
makeChoice
return os2
EvKey (KChar 'n') [MCtrl] -> do
clearFromCursorTo $ length os3
go c (updateSelection MoveDown os)
EvKey (KChar 'j') _ -> do
clearFromCursorTo $ length os3
go c (updateSelection MoveDown os)
EvKey KDown _ -> do
clearFromCursorTo $ length os3
go c (updateSelection MoveDown os)
EvKey (KChar 'p') [MCtrl] -> do
clearFromCursorTo $ length os3
go c (updateSelection MoveUp os)
EvKey (KChar 'k') _ -> do
clearFromCursorTo $ length os3
go c (updateSelection MoveUp os)
EvKey KUp _ -> do
clearFromCursorTo $ length os3
go c (updateSelection MoveUp os)
EvKey (KChar 'q') _ ->
return []
EvKey (KChar 'c') [MCtrl] ->
return []
EvKey KEsc _ ->
return []
_ -> do
clearFromCursorTo $ length os3
go c os
makeChoice = do
let size = length (s3 :: [(String, Int)])
mlist = replicate size ()
forM_ mlist (const (clearLine >> cursorUpLine 1))
updateSelection MoveUp (i, is, os) = ((i - 1) `mod` length os, is, os)
updateSelection MoveDown (i, is, os) = ((i + 1) `mod` length os, is, os)
updateSelection ToggleSelection (i, is, os) = (i, is', os)
where
is' = if i `elem` is then delete i is else i:is
updateSelection _ _ = error "Internal error, key not recognized"
render (i, is, optionsI) = forM_ optionsI $ \(o, j) -> do
let checkbox = if j `elem` is then "◉ " else "◯ "
if i == j
then do
setSGR [ SetColor Foreground Vivid Cyan ]
putStrLn $ ">" ++ checkbox ++ o
setSGR []
else putStrLn $ " " ++ checkbox ++ o