diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,8 +3,10 @@ [![Hackage](https://img.shields.io/hackage/v/stack-run.svg)](http://hackage.haskell.org/package/stack-run) [![Hackage Deps](https://img.shields.io/hackage-deps/v/stack-run.svg)](http://packdeps.haskellers.com/feed?needle=stack-run) - - - -Like `cabal run` but for `stack`. +**stack-run** is like `cabal run` but for `stack`. +Only **GHC** versions **>= 7.8** are currently supported. + ## Installing ``` $ stack install stack-run @@ -15,6 +17,11 @@ $ stack run ``` +## Interactive Usage +``` +$ stack run -i +``` + ## Help ``` $ stack run help @@ -22,6 +29,9 @@ ## Demo ![](http://i.imgur.com/CxtaQIq.gif) + +## Interactive Demo +![](http://i.imgur.com/Ph8LAXU.gif) ## License This code is published under the MIT license. 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,258 @@ +{-# 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 diff --git a/stack-run.cabal b/stack-run.cabal --- a/stack-run.cabal +++ b/stack-run.cabal @@ -1,5 +1,5 @@ name: stack-run -version: 0.1.1.1 +version: 0.1.1.2 synopsis: An equivalent to cabal run for stack. description: Finds the project root, compiles your code and runs the first or set default executable. It's a shorthand for @@ -20,6 +20,7 @@ executable stack-run main-is: Main.hs + other-modules: System.Console.Questioner build-depends: Cabal , terminal-size , vty