diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Pedro Tacla Yamada + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/CheckboxPrompt.hs b/examples/CheckboxPrompt.hs new file mode 100644 --- /dev/null +++ b/examples/CheckboxPrompt.hs @@ -0,0 +1,8 @@ +import System.Console.Questioner + +main :: IO () +main = do + fs <- prompt ( "What features would you like included?" + , [ "Testing" , "Makefile", "guard support" ] ) + putStrLn "Your choices:" + mapM_ putStrLn fs diff --git a/examples/ListPrompt.hs b/examples/ListPrompt.hs new file mode 100644 --- /dev/null +++ b/examples/ListPrompt.hs @@ -0,0 +1,8 @@ +import System.Console.Questioner + +main :: IO () +main = do + e <- prompt ("What's your editor?", ["Vim", "Emacs", "Sublime Text"]) + putStrLn $ + e ++ "?! " ++ + if e == "vim" then "That's very cool!" else "That's not so cool!" diff --git a/examples/ProgressBar.hs b/examples/ProgressBar.hs new file mode 100644 --- /dev/null +++ b/examples/ProgressBar.hs @@ -0,0 +1,14 @@ +import Control.Concurrent +import System.Console.Questioner + +main :: IO () +main = do + p <- simpleProgressBar + loop p 0 + where + loop p i = do + threadDelay (1000 * 100) -- 0.1s + let i' = i + 0.1 + if i >= 1 + then stopIndicator p >> putStrLn "Done!" + else updateIndicator p i' >> loop p i' diff --git a/examples/Spinner.hs b/examples/Spinner.hs new file mode 100644 --- /dev/null +++ b/examples/Spinner.hs @@ -0,0 +1,9 @@ +import Control.Concurrent +import System.Console.Questioner + +main :: IO () +main = do + s <- dots1Spinner (1000 * 200) "Loading..." + threadDelay (1000 * 10000) -- 10s + stopIndicator s + putStrLn "Done!" diff --git a/questioner.cabal b/questioner.cabal new file mode 100644 --- /dev/null +++ b/questioner.cabal @@ -0,0 +1,72 @@ +name: questioner +version: 0.1.0.0 +synopsis: A package for prompting values from the command-line. +description: This is still being developed +homepage: https://github.com/yamadapc/haskell-questioner.git +license: MIT +license-file: LICENSE +author: Pedro Tacla Yamada +maintainer: tacla.yamada@gmail.com +copyright: (c) 2014 Pedro Tacla Yamada +category: System +build-type: Simple +cabal-version: >=1.10 + +flag examples + description: Build UI examples + default: False + +library + exposed-modules: System.Console.Questioner + , System.Console.Questioner.ProgressIndicators + , System.Console.Questioner.Util + build-depends: base >=4 && <5 + , ansi-terminal >=0.6 && <0.7 + , terminal-size >=0.2 && <1 + , readline >=1 && <1.1 + hs-source-dirs: src + default-language: Haskell2010 + +executable questioner-list-prompt + main-is: ListPrompt.hs + hs-source-dirs: examples + build-depends: base + , questioner + default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False + +executable questioner-checkbox-prompt + main-is: CheckboxPrompt.hs + hs-source-dirs: examples + build-depends: base + , questioner + default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False + +executable questioner-spinner + main-is: Spinner.hs + hs-source-dirs: examples + build-depends: base + , questioner + default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False + +executable questioner-progressbar + main-is: ProgressBar.hs + hs-source-dirs: examples + build-depends: base + , questioner + default-language: Haskell2010 + if flag(examples) + buildable: True + else + buildable: False diff --git a/src/System/Console/Questioner.hs b/src/System/Console/Questioner.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Questioner.hs @@ -0,0 +1,136 @@ +{-# 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.Monad ((>=>), forM_) +import Data.List (delete) +import System.Console.ANSI (clearLine, cursorUpLine) +import System.IO (stdin) + +import System.Console.Questioner.ProgressIndicators +import System.Console.Questioner.Util + +-- Base `Question` and `Question` instances +------------------------------------------------------------------------------- + +class Question q a where + prompt :: q -> IO a + +instance Read a => Question String a where + prompt = putStr . (++ " ") >=> const readLn + +instance Question String String where + prompt = putStr . (++ " ") >=> const getLine + +instance Question (String, (String, String)) String where + prompt (s, (o1, o2)) = do + putStr s + putStr $ " (" ++ o1 ++ "/" ++ o2 ++ ") " + getLine + +instance Question (String, [String]) String where + prompt = uncurry listPrompt + +instance Question (String, [String]) [String] where + prompt = uncurry checkboxPrompt + +-- Multiple choice prompts +------------------------------------------------------------------------------- + +data ChoiceEvent = MoveUp | MoveDown | MakeChoice | ToggleSelection + 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 + +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])) + render selection + i <- listenForSelection selection + return $ options !! i + where + setup = hWithNoBuffering stdin . withNoEcho + + listenForSelection os = charToChoiceEvent <$> getChar >>= \case + Nothing -> listenForSelection os + Just ToggleSelection -> listenForSelection os + + Just MakeChoice -> do + forM_ (replicate (length (snd os) + 1) ()) + (const (clearLine >> cursorUpLine 1)) + clearLine + return $ fst os + + Just d -> do + let os' = updateSelection d os + clearFromCursorTo $ length $ snd os + render os' + listenForSelection os' + + 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) -> + putStrLn $ (if i == s then "> " else " ") ++ 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 o = charToChoiceEvent <$> getChar >>= \case + Just MakeChoice -> do + let (_, _, optionsI) = o in + forM_ (replicate (length optionsI + 1) ()) + (const (clearLine >> cursorUpLine 1)) + + clearLine + let (_, is, _) = o in + return is + + Just d -> do + let (_, _, optionsI) = o in + clearFromCursorTo $ length optionsI + let o' = updateSelection d o in + render o' >> listenForSelection o' + Nothing -> listenForSelection o + + 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) -> + putStrLn $ (if i == j then ">" else " ") ++ + (if j `elem` is then "◉ " else "◯ ") ++ + o diff --git a/src/System/Console/Questioner/ProgressIndicators.hs b/src/System/Console/Questioner/ProgressIndicators.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Questioner/ProgressIndicators.hs @@ -0,0 +1,139 @@ +-- | +-- Module : System.Console.Questioner.ProgressIndicators +-- Description : Provides progress indicators and spinners +-- Copyright : (c) Pedro Yamada +-- License : MIT +-- +-- Maintainer : Pedro Yamada +-- Stability : stable +-- Portability : non-portable (not tested on multiple environments) +-- +-- Shamefully steals ideas from modules like `Inquirer.js` and `go-spin`. +module System.Console.Questioner.ProgressIndicators + where + +import Control.Applicative ((<$>)) +import Control.Concurrent -- (MVar, ThreadId, forkIO, killThread, modifyMVar_, + -- newMVar, tryTakeMVar, threadDelay) +import Control.Monad (forever) +import Data.Maybe (fromMaybe) +import System.Console.ANSI (clearLine, setCursorColumn) +import System.Console.Terminal.Size (size, Window(..)) +import System.IO (BufferMode(NoBuffering), stdout) + +import System.Console.Questioner.Util + +-- ProgressIndicator type and utilities +------------------------------------------------------------------------------- + +data ProgressIndicator = BarIndicator ThreadId (MVar Double) + | SpinnerIndicator ThreadId + +stopIndicator :: ProgressIndicator -> IO () +stopIndicator i = case i of + (BarIndicator tid _) -> stopProgressIndicator' tid + (SpinnerIndicator tid) -> stopProgressIndicator' tid + where + stopProgressIndicator' tid = do + killThread tid + clearLine + setCursorColumn 0 + +updateIndicator :: ProgressIndicator -> Double -> IO () +updateIndicator (BarIndicator _ c) i = putMVar c i +updateIndicator _ _ = return () + +-- ProgressBars +------------------------------------------------------------------------------- + +newtype ProgressBarTheme = ProgressBarTheme (Double -> IO ()) + +progressBar :: ProgressBarTheme -> IO ProgressIndicator +progressBar (ProgressBarTheme render) = do + mi <- newEmptyMVar + render 0 + tid <- forkIO $ hWithBufferMode stdout NoBuffering $ forever $ do + i <- takeMVar mi + clearLine + setCursorColumn 0 + render i + putMVar mi 0 + return $ BarIndicator tid mi + +-- Spinners +------------------------------------------------------------------------------- + +type SpinnerTheme = String + +spinner :: SpinnerTheme -> Int -> String -> IO ProgressIndicator +spinner theme interval prompt = SpinnerIndicator <$> forkIO (setup $ loop 0) + where + setup = hWithBufferMode stdout NoBuffering + + loop i = do + clearLine + setCursorColumn 0 + putStr $ ' ' : spinnerState i : ' ' : prompt + threadDelay interval + loop $ i + 1 + + -- TODO - parameterize + themeLen = length theme + spinnerState i = theme !! (i `mod` themeLen) + +-- Boilerplate for easier usage (TODO - generate this with TH) +------------------------------------------------------------------------------- + +simple1SpinnerTheme, simple2SpinnerTheme, simple3SpinnerTheme, + simple4SpinnerTheme, simple5SpinnerTheme, simple6SpinnerTheme, + simple7SpinnerTheme, simple8SpinnerTheme, simple9SpinnerTheme, + dots1SpinnerTheme, dots2SpinnerTheme, dots3SpinnerTheme, dots4SpinnerTheme, + dots5SpinnerTheme, dots6SpinnerTheme, dots7SpinnerTheme :: SpinnerTheme + +simple1Spinner, simple2Spinner, simple3Spinner, simple4Spinner, simple5Spinner, + simple6Spinner, simple7Spinner, simple8Spinner, simple9Spinner, dots1Spinner, + dots2Spinner, dots3Spinner, dots4Spinner, dots5Spinner, dots6Spinner, + dots7Spinner :: Int -> String -> IO ProgressIndicator + +simple1SpinnerTheme = "|/-\\" +simple2SpinnerTheme = "◴◷◶◵" +simple3SpinnerTheme = "◰◳◲◱" +simple4SpinnerTheme = "◐◓◑◒" +simple5SpinnerTheme = "▉▊▋▌▍▎▏▎▍▌▋▊▉" +simple6SpinnerTheme = "▌▄▐▀" +simple7SpinnerTheme = "╫╪" +simple8SpinnerTheme = "■□▪▫" +simple9SpinnerTheme = "←↑→↓" +simple1Spinner = spinner simple1SpinnerTheme +simple2Spinner = spinner simple2SpinnerTheme +simple3Spinner = spinner simple3SpinnerTheme +simple4Spinner = spinner simple4SpinnerTheme +simple5Spinner = spinner simple5SpinnerTheme +simple6Spinner = spinner simple6SpinnerTheme +simple7Spinner = spinner simple7SpinnerTheme +simple8Spinner = spinner simple8SpinnerTheme +simple9Spinner = spinner simple9SpinnerTheme + +dots1SpinnerTheme = "⠋⠙⠹⠸⠼⠴⠦⠧⠇⠏" +dots2SpinnerTheme = "⠋⠙⠹⠸⠼⠴⠦⠧⠇⠏" +dots3SpinnerTheme = "⠄⠆⠇⠋⠙⠸⠰⠠⠰⠸⠙⠋⠇⠆" +dots4SpinnerTheme = "⠋⠙⠚⠒⠂⠂⠒⠲⠴⠦⠖⠒⠐⠐⠒⠓⠋" +dots5SpinnerTheme = "⠁⠉⠙⠚⠒⠂⠂⠒⠲⠴⠤⠄⠄⠤⠴⠲⠒⠂⠂⠒⠚⠙⠉⠁" +dots6SpinnerTheme = "⠈⠉⠋⠓⠒⠐⠐⠒⠖⠦⠤⠠⠠⠤⠦⠖⠒⠐⠐⠒⠓⠋⠉⠈" +dots7SpinnerTheme = "⠁⠁⠉⠙⠚⠒⠂⠂⠒⠲⠴⠤⠄⠄⠤⠠⠠⠤⠦⠖⠒⠐⠐⠒⠓⠋⠉⠈⠈" +dots1Spinner = spinner dots1SpinnerTheme +dots2Spinner = spinner dots2SpinnerTheme +dots3Spinner = spinner dots3SpinnerTheme +dots4Spinner = spinner dots4SpinnerTheme +dots5Spinner = spinner dots5SpinnerTheme +dots6Spinner = spinner dots6SpinnerTheme +dots7Spinner = spinner dots7SpinnerTheme + +simpleProgressBarTheme :: ProgressBarTheme +simpleProgressBarTheme = ProgressBarTheme $ \i -> do + w <- fromMaybe (45 :: Int) <$> (fmap width <$> size) + let blocks = floor ((fromIntegral w :: Double) * i) - 3 + putStr (replicate blocks '▉') + +simpleProgressBar :: IO ProgressIndicator +simpleProgressBar = progressBar simpleProgressBarTheme diff --git a/src/System/Console/Questioner/Util.hs b/src/System/Console/Questioner/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/Questioner/Util.hs @@ -0,0 +1,42 @@ +module System.Console.Questioner.Util + where + +import Control.Exception (bracket_) +import System.Console.ANSI (clearLine, cursorDownLine, cursorUpLine, + hideCursor, showCursor) +import System.IO (BufferMode(..), Handle, hGetBuffering, hSetBuffering, + hSetEcho, stdin) + +-- | +-- Performs an IO action with some buffer mode on a handle +hWithBufferMode :: Handle -> BufferMode -> IO a -> IO a +hWithBufferMode handle bufferMode action = do + originalBuffering <- hGetBuffering handle + bracket_ + (hSetBuffering handle bufferMode) + (hSetBuffering handle originalBuffering) + action + +-- | +-- Performs an IO action with NoBuffering on a handle +hWithNoBuffering :: Handle -> IO a -> IO a +hWithNoBuffering handle = hWithBufferMode handle NoBuffering + +-- | +-- Performs an IO action with the console cursor hidden +withNoCursor :: IO a -> IO a +withNoCursor = bracket_ hideCursor showCursor + +-- | +-- Performs an IO action with console "echoing" supressed +withNoEcho :: IO a -> IO a +withNoEcho = bracket_ (hSetEcho stdin False) (hSetEcho stdin True) + +-- | +-- Clears the screen from the cursor's current position until `n` lines +-- above it +clearFromCursorTo :: Int -> IO () +clearFromCursorTo nlines = loop nlines >> cursorDownLine (nlines - 2) + where + loop (-1) = return () + loop n = clearLine >> cursorUpLine 1 >> loop (n - 1)