stack-run 0.1.1.3 → 0.1.1.4
raw patch · 11 files changed
+489/−461 lines, 11 filesdep −projectroot
Dependencies removed: projectroot
Files
- README.md +2/−1
- src/Main.hs +26/−5
- src/System/Console/Questioner.hs +0/−258
- src/System/Console/Questioner/Autocomplete.hs +0/−2
- src/System/Console/Questioner/ProgressIndicators.hs +0/−139
- src/System/Console/Questioner/Util.hs +0/−48
- stack-run.cabal +14/−8
- unix/System/Console/Questioner.hs +258/−0
- unix/System/Console/Questioner/Autocomplete.hs +2/−0
- unix/System/Console/Questioner/ProgressIndicators.hs +139/−0
- unix/System/Console/Questioner/Util.hs +48/−0
README.md view
@@ -1,11 +1,12 @@ # stack-run [](https://travis-ci.org/yamadapc/stack-run)+[](https://ci.appveyor.com/project/yamadapc/stack-run) [](http://hackage.haskell.org/package/stack-run) [](http://packdeps.haskellers.com/feed?needle=stack-run) - - - **stack-run** is like `cabal run` but for `stack`. -Only **GHC** versions **>= 7.8** are currently supported.+Only **UNIX** and **GHC** versions **>= 7.10** are currently supported. ## Installing ```
src/Main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Main where @@ -16,13 +17,15 @@ import Distribution.PackageDescription import Distribution.PackageDescription.Parse import System.Console.ANSI+#ifndef OS_Win32 import System.Console.Questioner+#endif import System.Directory-import System.Directory.ProjectRoot import System.Environment import System.Exit import System.FilePath import System.IO+import System.IO.Error usage :: String usage = unlines [ ""@@ -48,13 +51,13 @@ setDefault :: String -> IO () setDefault name = do pr <- fromMaybe (error "No project root found") <$>- getProjectRootCurrent+ getCabalProjectRootCurrent writeFile (pr </> ".stack-work" </> ".stack-run-default") name findDefault :: IO String findDefault = do pr <- fromMaybe (error "No project root found") <$>- getProjectRootCurrent+ getCabalProjectRootCurrent e <- doesFileExist (pr </> ".stack-work" </> ".stack-run-default") if e then readFile (pr </> ".stack-work" </> ".stack-run-default") else findDefault' pr@@ -74,7 +77,7 @@ getExecutables :: IO [String] getExecutables = do pr <- fromMaybe (error "No project root found") <$>- getProjectRootCurrent+ getCabalProjectRootCurrent cfp <- fromMaybe (error "No cabal file found") <$> (find ((== ".cabal") . takeExtension) <$> getDirectoryContents pr) pkgParseResult <- getPackageDescription (pr </> cfp)@@ -87,9 +90,23 @@ [] -> error "No executables found" ds -> map fst ds +getCabalProjectRootCurrent :: IO (Maybe FilePath)+getCabalProjectRootCurrent = flip catchIOError (const (return Nothing)) $+ getCurrentDirectory >>= getCabalProjectRoot+ where+ getCabalProjectRoot :: FilePath -> IO (Maybe FilePath)+ getCabalProjectRoot path = do+ hasCabal <- any (isSuffixOf ".cabal") <$> getDirectoryContents path+ if hasCabal+ then return $ Just path+ else let parent = takeDirectory path in+ if parent /= path+ then getCabalProjectRoot parent+ else return Nothing+ stackRun :: String -> [String] -> IO b stackRun name as = do- pr <- fromMaybe (error "No project root found") <$> getProjectRootCurrent+ pr <- fromMaybe (error "No project root found") <$> getCabalProjectRootCurrent stackYmlExists <- doesFileExist (pr </> "stack.yaml") unless stackYmlExists $ do ec <- prettyRunCommand "stack init"@@ -151,11 +168,13 @@ hPutStrLn stderr cmd hSetSGR stderr [Reset] +#ifndef OS_Win32 runInteractive :: [String] -> IO () runInteractive as = do exs <- getExecutables ex <- prompt ("What executable should we run? ", exs) stackRun ex as+#endif main :: IO () main = do@@ -168,8 +187,10 @@ ("get-default":_) -> putStrLn =<< findDefault ("--help":_) -> exitUsage ("-h":_) -> exitUsage+#ifndef OS_Win32 ("-i":as) -> runInteractive as ("--interactive":as) -> runInteractive as+#endif ("help":_) -> exitUsage ("--":"--":as) -> flip stackRun as =<< findDefault ("--":name:as) -> stackRun name as
− src/System/Console/Questioner.hs
@@ -1,258 +0,0 @@-{-# 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
− src/System/Console/Questioner/Autocomplete.hs
@@ -1,2 +0,0 @@-module System.Console.Questioner.Autocomplete- where
− src/System/Console/Questioner/ProgressIndicators.hs
@@ -1,139 +0,0 @@--- |--- Module : System.Console.Questioner.ProgressIndicators--- Description : Provides progress indicators and spinners--- Copyright : (c) Pedro Yamada--- License : MIT------ Maintainer : Pedro Yamada <tacla.yamada@gmail.com>--- 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
− src/System/Console/Questioner/Util.hs
@@ -1,48 +0,0 @@-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 = do- cursorUpLine nlines- loop nlines- cursorUpLine nlines- where- loop 0 = return ()- loop n = do- clearLine- cursorDownLine 1- loop (n - 1)
stack-run.cabal view
@@ -1,5 +1,5 @@ name: stack-run-version: 0.1.1.3+version: 0.1.1.4 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,13 +20,8 @@ executable stack-run main-is: Main.hs- other-modules: System.Console.Questioner- , System.Console.Questioner.Autocomplete- , System.Console.Questioner.ProgressIndicators- , System.Console.Questioner.Util build-depends: Cabal , terminal-size- , vty , stm , MissingH , ansi-terminal >= 0.6@@ -37,9 +32,20 @@ , conduit-extra >= 1.1 && < 1.2 , directory , filepath- , projectroot >= 0.2 , time >= 1.5.0.1- hs-source-dirs: src+ if os(windows)+ CPP-Options: -DOS_Win32+ hs-source-dirs:+ src+ if ! os(windows)+ other-modules: System.Console.Questioner+ , System.Console.Questioner.Autocomplete+ , System.Console.Questioner.ProgressIndicators+ , System.Console.Questioner.Util+ build-depends: vty+ hs-source-dirs:+ src+ unix default-language: Haskell2010 ghc-options: -threaded
+ unix/System/Console/Questioner.hs view
@@ -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
+ unix/System/Console/Questioner/Autocomplete.hs view
@@ -0,0 +1,2 @@+module System.Console.Questioner.Autocomplete+ where
+ unix/System/Console/Questioner/ProgressIndicators.hs view
@@ -0,0 +1,139 @@+-- |+-- Module : System.Console.Questioner.ProgressIndicators+-- Description : Provides progress indicators and spinners+-- Copyright : (c) Pedro Yamada+-- License : MIT+--+-- Maintainer : Pedro Yamada <tacla.yamada@gmail.com>+-- 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
+ unix/System/Console/Questioner/Util.hs view
@@ -0,0 +1,48 @@+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 = do+ cursorUpLine nlines+ loop nlines+ cursorUpLine nlines+ where+ loop 0 = return ()+ loop n = do+ clearLine+ cursorDownLine 1+ loop (n - 1)