├── .dockerignore ├── .gitignore ├── .gitmodules ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── appveyor.yml ├── demo.gif ├── ghc7-10.dockerfile ├── ghc7-8.dockerfile ├── idemo.gif ├── src └── Main.hs ├── stack-run.cabal ├── stack.yaml └── unix └── System └── Console ├── Questioner.hs └── Questioner ├── Autocomplete.hs ├── ProgressIndicators.hs └── Util.hs /.dockerignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | # Created by https://www.gitignore.io/api/haskell 3 | 4 | ### Haskell ### 5 | dist 6 | cabal-dev 7 | *.o 8 | *.hi 9 | *.chi 10 | *.chs.h 11 | *.dyn_o 12 | *.dyn_hi 13 | .hpc 14 | .hsenv 15 | .cabal-sandbox/ 16 | cabal.sandbox.config 17 | *.prof 18 | *.aux 19 | *.hp 20 | .stack-work/ 21 | 22 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yamadapc/stack-run/76f18cc0800ef2ffa3d1c63306282f15e5a4daf0/.gitmodules -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This file has been generated -- see https://github.com/hvr/multi-ghc-travis 2 | language: c 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.cabsnap 8 | - $HOME/.cabal/packages 9 | 10 | before_cache: 11 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 12 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar 13 | 14 | matrix: 15 | include: 16 | - env: CABALVER=1.22 GHCVER=7.10.1 17 | compiler: ": #GHC 7.10.1" 18 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1], sources: [hvr-ghc]}} 19 | - env: CABALVER=1.22 GHCVER=7.10.2 20 | compiler: ": #GHC 7.10.2" 21 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}} 22 | - env: CABALVER=1.22 GHCVER=7.10.3 23 | compiler: ": #GHC 7.10.3" 24 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} 25 | - env: CABALVER=1.22 GHCVER=8.0.2 26 | compiler: ": #GHC 8.0.2" 27 | addons: {apt: {packages: [cabal-install-1.22,ghc-8.0.2], sources: [hvr-ghc]}} 28 | - env: CABALVER=head GHCVER=head 29 | compiler: ": #GHC head" 30 | addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} 31 | 32 | allow_failures: 33 | - env: CABALVER=1.22 GHCVER=8.0.2 34 | - env: CABALVER=head GHCVER=head 35 | 36 | before_install: 37 | - unset CC 38 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 39 | 40 | install: 41 | - cabal --version 42 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 43 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; 44 | then 45 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > 46 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; 47 | fi 48 | - travis_retry cabal update -v 49 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 50 | - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt 51 | - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt 52 | 53 | # check whether current requested install-plan matches cached package-db snapshot 54 | - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; 55 | then 56 | echo "cabal build-cache HIT"; 57 | rm -rfv .ghc; 58 | cp -a $HOME/.cabsnap/ghc $HOME/.ghc; 59 | cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; 60 | else 61 | echo "cabal build-cache MISS"; 62 | rm -rf $HOME/.cabsnap; 63 | mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; 64 | cabal install --only-dependencies --enable-tests --enable-benchmarks; 65 | fi 66 | 67 | # snapshot package-db on cache miss 68 | - if [ ! -d $HOME/.cabsnap ]; 69 | then 70 | echo "snapshotting package-db to build-cache"; 71 | mkdir $HOME/.cabsnap; 72 | cp -a $HOME/.ghc $HOME/.cabsnap/ghc; 73 | cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; 74 | fi 75 | 76 | # Here starts the actual work to be performed for the package under test; 77 | # any command which exits with a non-zero exit code causes the build to fail. 78 | script: 79 | - if [ -f configure.ac ]; then autoreconf -i; fi 80 | - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging 81 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 82 | - cabal test 83 | - cabal check 84 | - cabal sdist # tests that a source-distribution can be generated 85 | 86 | # Check that the resulting source distribution can be built & installed. 87 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler: 88 | # `cabal install --force-reinstalls dist/*-*.tar.gz` 89 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 90 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 91 | 92 | # EOF 93 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016 Pedro Tacla Yamada 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # stack-run 2 | [![Build Status](https://travis-ci.org/yamadapc/stack-run.svg?branch=master)](https://travis-ci.org/yamadapc/stack-run) 3 | [![Windows Build status](https://ci.appveyor.com/api/projects/status/y4fu37moed6m912m?svg=true)](https://ci.appveyor.com/project/yamadapc/stack-run) 4 | [![Hackage](https://img.shields.io/hackage/v/stack-run.svg)](http://hackage.haskell.org/package/stack-run) 5 | [![Hackage Deps](https://img.shields.io/hackage-deps/v/stack-run.svg)](http://packdeps.haskellers.com/feed?needle=stack-run) 6 | - - - 7 | **stack-run** is like `cabal run` but for `stack`. 8 | 9 | Only **UNIX** and **GHC** versions **>= 7.10** are currently supported. 10 | 11 | ## Installing 12 | ``` 13 | $ stack install stack-run 14 | ``` 15 | 16 | ## Usage 17 | ``` 18 | $ stack run 19 | ``` 20 | 21 | ## Interactive Usage 22 | ``` 23 | $ stack run -i 24 | ``` 25 | 26 | ## Help 27 | ``` 28 | $ stack run help 29 | ``` 30 | 31 | ## Demo 32 | ![](http://i.imgur.com/CxtaQIq.gif) 33 | 34 | ## Interactive Demo 35 | ![](http://i.imgur.com/Ph8LAXU.gif) 36 | 37 | ## License 38 | This code is published under the MIT license. 39 | 40 | ## Donations 41 | Would you like to buy me a beer? Send bitcoin to 3JjxJydvoJjTrhLL86LGMc8cNB16pTAF3y 42 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | # Disabled cache in hope of improving reliability of AppVeyor builds 2 | #cache: 3 | #- "c:\\sr" # stack root, short paths == fewer problems 4 | 5 | build: off 6 | 7 | before_test: 8 | - curl -sS -ostack.zip -L --insecure http://www.stackage.org/stack/windows-i386 9 | - 7z x stack.zip stack.exe 10 | 11 | clone_folder: "c:\\stack" 12 | environment: 13 | global: 14 | STACK_ROOT: "c:\\sr" 15 | 16 | test_script: 17 | - stack setup > nul 18 | # The ugly echo "" hack is to avoid complaints about 0 being an invalid file 19 | # descriptor 20 | - echo "" | stack --no-terminal test -------------------------------------------------------------------------------- /demo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yamadapc/stack-run/76f18cc0800ef2ffa3d1c63306282f15e5a4daf0/demo.gif -------------------------------------------------------------------------------- /ghc7-10.dockerfile: -------------------------------------------------------------------------------- 1 | FROM haskell:7.10 2 | RUN ["cabal", "update"] 3 | ADD . /app 4 | WORKDIR /app 5 | RUN ["cabal", "sandbox", "init"] 6 | RUN ["cabal", "install", "--only-dep", "-j4"] 7 | RUN ["cabal", "build"] 8 | -------------------------------------------------------------------------------- /ghc7-8.dockerfile: -------------------------------------------------------------------------------- 1 | FROM haskell:7.8 2 | RUN ["cabal", "update"] 3 | ADD . /app 4 | WORKDIR /app 5 | RUN ["cabal", "sandbox", "init"] 6 | RUN ["cabal", "install", "--only-dep", "-j4"] 7 | RUN ["cabal", "build"] 8 | -------------------------------------------------------------------------------- /idemo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/yamadapc/stack-run/76f18cc0800ef2ffa3d1c63306282f15e5a4daf0/idemo.gif -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Main 3 | where 4 | 5 | import Control.Applicative ((*>), (<$>)) 6 | import Control.Concurrent.Async 7 | import Control.Monad (unless) 8 | import qualified Data.ByteString.Char8 as ByteString 9 | import Data.Conduit 10 | import qualified Data.Conduit.Binary as Conduit.Binary 11 | import qualified Data.Conduit.List as Conduit.List 12 | import Data.Conduit.Process 13 | import Data.List 14 | import Data.List.Utils 15 | import Data.Maybe 16 | import Data.Time 17 | import Distribution.PackageDescription 18 | import Distribution.PackageDescription.Parse 19 | import System.Console.ANSI 20 | #ifndef OS_Win32 21 | import System.Console.Questioner 22 | #endif 23 | import System.Directory 24 | import System.Environment 25 | import System.Exit 26 | import System.FilePath 27 | import System.IO 28 | import System.IO.Error 29 | 30 | usage :: String 31 | usage = unlines [ "" 32 | , " Usage: stack run [args]" 33 | , "" 34 | , " Commands:" 35 | , "" 36 | , " stack run [name] [args] Compiles and runs the executable specified or the default" 37 | , " stack run -- [args] Like stack run, but will never match a sub-command" 38 | , " stack run -- -- [args] Pass-in arguments to the default executable" 39 | , "" 40 | , " stack run set-default Sets the default executable to run" 41 | , "" 42 | , " stack run --interactive Runs in interactive mode" 43 | , " stack run -i" 44 | , "" 45 | , " stack run help Print this help message" 46 | , " stack run --help" 47 | , " stack run -h" 48 | , "" 49 | ] 50 | 51 | setDefault :: String -> IO () 52 | setDefault name = do 53 | pr <- fromMaybe (error "No project root found") <$> 54 | getCabalProjectRootCurrent 55 | writeFile (pr ".stack-work" ".stack-run-default") name 56 | 57 | findDefault :: IO String 58 | findDefault = do 59 | pr <- fromMaybe (error "No project root found") <$> 60 | getCabalProjectRootCurrent 61 | e <- doesFileExist (pr ".stack-work" ".stack-run-default") 62 | if e then readFile (pr ".stack-work" ".stack-run-default") 63 | else findDefault' pr 64 | where 65 | findDefault' pr = do 66 | cfp <- fromMaybe (error "No cabal file found") <$> 67 | (find ((== ".cabal") . takeExtension) <$> getDirectoryContents pr) 68 | getPackageDescription (pr cfp) >>= getDefaultExecutable 69 | where 70 | getPackageDescription p = parsePackageDescription <$> readFile p 71 | getDefaultExecutable (ParseFailed _) = 72 | error "Failed to parse cabal file" 73 | getDefaultExecutable (ParseOk _ gpd) = case condExecutables gpd of 74 | [] -> error "No executable found" 75 | ((d, _):_) -> return d 76 | 77 | getExecutables :: IO [String] 78 | getExecutables = do 79 | pr <- fromMaybe (error "No project root found") <$> 80 | getCabalProjectRootCurrent 81 | cfp <- fromMaybe (error "No cabal file found") <$> 82 | (find ((== ".cabal") . takeExtension) <$> getDirectoryContents pr) 83 | pkgParseResult <- getPackageDescription (pr cfp) 84 | return $ getExecutables pkgParseResult 85 | where 86 | getPackageDescription p = parsePackageDescription <$> readFile p 87 | getExecutables (ParseFailed _) = 88 | error "Failed to parse cabal file" 89 | getExecutables (ParseOk _ gpd) = case condExecutables gpd of 90 | [] -> error "No executables found" 91 | ds -> map fst ds 92 | 93 | getCabalProjectRootCurrent :: IO (Maybe FilePath) 94 | getCabalProjectRootCurrent = flip catchIOError (const (return Nothing)) $ 95 | getCurrentDirectory >>= getCabalProjectRoot 96 | where 97 | getCabalProjectRoot :: FilePath -> IO (Maybe FilePath) 98 | getCabalProjectRoot path = do 99 | hasCabal <- any (isSuffixOf ".cabal") <$> getDirectoryContents path 100 | if hasCabal 101 | then return $ Just path 102 | else let parent = takeDirectory path in 103 | if parent /= path 104 | then getCabalProjectRoot parent 105 | else return Nothing 106 | 107 | stackRun :: String -> [String] -> IO b 108 | stackRun name as = do 109 | pr <- fromMaybe (error "No project root found") <$> getCabalProjectRootCurrent 110 | stackYmlExists <- doesFileExist (pr "stack.yaml") 111 | unless stackYmlExists $ do 112 | ec <- prettyRunCommand "stack init" 113 | case ec of 114 | ExitSuccess -> return () 115 | f -> exitWith f 116 | start <- getCurrentTime 117 | ec <- prettyRunCommand "stack build" 118 | hSetSGR stderr [SetColor Foreground Vivid Black] 119 | fdiff <- getDiffTime start 120 | hPutStrLn stderr ("stack build took " ++ show fdiff ++ "ms") 121 | hSetSGR stderr [Reset] 122 | case ec of 123 | ExitSuccess -> do 124 | let cmd = "stack exec " ++ name ++ " -- " ++ join " " as 125 | logCommand cmd 126 | hSetSGR stderr [Reset] 127 | hFlush stderr 128 | ph <- runCommand cmd 129 | ec' <- waitForProcess ph 130 | exitWith ec' 131 | f -> exitWith f 132 | where 133 | getDiffTime :: UTCTime -> IO Integer 134 | getDiffTime start = do 135 | now <- getCurrentTime 136 | let diff :: Double 137 | diff = fromRational (toRational (diffUTCTime now start)) 138 | fdiff = floor (diff * 1000) 139 | return fdiff 140 | 141 | 142 | prettyRunCommand :: String -> IO ExitCode 143 | prettyRunCommand cmd = do 144 | hSetBuffering stderr LineBuffering 145 | logCommand cmd 146 | (Inherited, out, err, cph) <- streamingProcess (shell cmd) 147 | runConcurrently $ 148 | Concurrently (out $$ (Conduit.Binary.lines =$ Conduit.List.mapM_ putLineGray)) *> 149 | Concurrently (err $$ (Conduit.Binary.lines =$ Conduit.List.mapM_ putLineRed)) *> 150 | Concurrently (waitForStreamingProcess cph) 151 | where 152 | putLineSGR sgr b = do 153 | hSetSGR stderr sgr 154 | hPutStr stderr " " 155 | ByteString.hPutStrLn stderr b 156 | hSetSGR stderr [Reset] 157 | putLineGray = putLineSGR [SetColor Foreground Dull White] 158 | putLineRed = putLineSGR [SetColor Foreground Vivid Black] 159 | 160 | logCommand :: String -> IO () 161 | logCommand cmd = do 162 | hSetSGR stderr [ SetColor Foreground Vivid White 163 | , SetConsoleIntensity BoldIntensity 164 | ] 165 | hPutStr stderr "$ " 166 | hSetSGR stderr [Reset] 167 | hSetSGR stderr [SetColor Foreground Vivid Cyan] 168 | hPutStrLn stderr cmd 169 | hSetSGR stderr [Reset] 170 | 171 | #ifndef OS_Win32 172 | runInteractive :: [String] -> IO () 173 | runInteractive as = do 174 | exs <- getExecutables 175 | ex <- prompt ("What executable should we run? ", exs) 176 | stackRun ex as 177 | #endif 178 | 179 | main :: IO () 180 | main = do 181 | args <- getArgs 182 | case args of 183 | ("set-default":name:_) -> setDefault name 184 | ("set-default":_) -> do 185 | hPutStrLn stderr "Missing required parameter: " 186 | exitFailure 187 | ("get-default":_) -> putStrLn =<< findDefault 188 | ("--help":_) -> exitUsage 189 | ("-h":_) -> exitUsage 190 | #ifndef OS_Win32 191 | ("-i":as) -> runInteractive as 192 | ("--interactive":as) -> runInteractive as 193 | #endif 194 | ("help":_) -> exitUsage 195 | ("--":"--":as) -> flip stackRun as =<< findDefault 196 | ("--":name:as) -> stackRun name as 197 | (name:as) -> stackRun name as 198 | [] -> flip stackRun [] =<< findDefault 199 | where 200 | exitUsage = do 201 | putStr usage 202 | exitSuccess 203 | -------------------------------------------------------------------------------- /stack-run.cabal: -------------------------------------------------------------------------------- 1 | name: stack-run 2 | version: 0.1.1.4 3 | synopsis: An equivalent to cabal run for stack. 4 | description: Finds the project root, compiles your code and runs the 5 | first or set default executable. It's a shorthand for 6 | @stack build && stack run executable@, much like 7 | @cabal run@. 8 | homepage: https://github.com/yamadapc/stack-run 9 | license: MIT 10 | license-file: LICENSE 11 | author: Pedro Tacla Yamada 12 | maintainer: tacla.yamada@gmail.com 13 | copyright: Copyright (c) 2016 Pedro Tacla Yamada 14 | category: Development 15 | build-type: Simple 16 | extra-source-files: README.md 17 | cabal-version: >=1.10 18 | 19 | tested-with: GHC >= 7.6 20 | 21 | executable stack-run 22 | main-is: Main.hs 23 | build-depends: Cabal 24 | , terminal-size 25 | , stm 26 | , MissingH 27 | , ansi-terminal >= 0.6 28 | , async 29 | , base >=4 && <5 30 | , bytestring >= 0.10 31 | , conduit > 1.1 && < 1.3 32 | , conduit-extra >= 1.1 && < 1.2 33 | , directory 34 | , filepath 35 | , time >= 1.5.0.1 36 | if os(windows) 37 | CPP-Options: -DOS_Win32 38 | hs-source-dirs: 39 | src 40 | if ! os(windows) 41 | other-modules: System.Console.Questioner 42 | , System.Console.Questioner.Autocomplete 43 | , System.Console.Questioner.ProgressIndicators 44 | , System.Console.Questioner.Util 45 | build-depends: vty 46 | hs-source-dirs: 47 | src 48 | unix 49 | default-language: Haskell2010 50 | ghc-options: -threaded 51 | 52 | source-repository head 53 | type: git 54 | location: git://github.com/yamadapc/stack-run.git 55 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.13 2 | packages: 3 | - '.' 4 | flags: {} 5 | extra-package-dbs: [] 6 | -------------------------------------------------------------------------------- /unix/System/Console/Questioner.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverlappingInstances #-} 5 | module System.Console.Questioner 6 | ( 7 | Question(..) 8 | 9 | , ChoiceEvent 10 | , charToChoiceEvent 11 | , listPrompt 12 | , checkboxPrompt 13 | 14 | , module System.Console.Questioner.ProgressIndicators 15 | ) 16 | where 17 | 18 | import Control.Applicative ((<$>)) 19 | import Control.Concurrent.STM 20 | import Control.Monad (forM_, (>=>)) 21 | import Data.List (delete) 22 | import Graphics.Vty (Event (..), 23 | Key (..), 24 | Modifier (..)) 25 | import qualified Graphics.Vty as Vty 26 | import System.Console.ANSI (Color (..), ColorIntensity (..), ConsoleIntensity (..), ConsoleLayer (..), 27 | SGR (..), 28 | clearLine, 29 | cursorUpLine, 30 | setSGR) 31 | import System.Console.Questioner.ProgressIndicators 32 | import System.Console.Questioner.Util 33 | import System.Exit 34 | import System.IO (hFlush, stdin, 35 | stdout) 36 | 37 | -- Base `Question` and `Question` instances 38 | ------------------------------------------------------------------------------- 39 | 40 | class Question q a where 41 | prompt :: q -> IO a 42 | 43 | instance {-# OVERLAPPABLE #-} Read a => Question String a where 44 | prompt = putStr . (++ " ") >=> const readLn 45 | 46 | instance {-# OVERLAPPING #-} Question String String where 47 | prompt = putStr . (++ " ") >=> const getLine 48 | 49 | instance {-# OVERLAPPING #-} Question String (Maybe String) where 50 | prompt = putStr . (++ " ") >=> const getLine >=> helper 51 | where 52 | helper [] = return Nothing 53 | helper s = return $ Just s 54 | 55 | instance {-# OVERLAPPING #-} Question (String, (String, String)) String where 56 | prompt (s, (o1, o2)) = do 57 | putStr s 58 | putStr $ " (" ++ o1 ++ "/" ++ o2 ++ ") " 59 | getLine 60 | 61 | instance {-# OVERLAPPING #-} Question (String, [String]) String where 62 | prompt = uncurry listPrompt 63 | 64 | instance {-# OVERLAPPING #-} Question (String, [String]) [String] where 65 | prompt = uncurry checkboxPrompt 66 | 67 | -- Multiple choice prompts 68 | ------------------------------------------------------------------------------- 69 | 70 | data ChoiceEvent = MoveUp | MoveDown | MakeChoice | ToggleSelection | Exit 71 | deriving(Eq, Ord, Show) 72 | 73 | charToChoiceEvent :: Char -> Maybe ChoiceEvent 74 | charToChoiceEvent 'j' = Just MoveDown 75 | charToChoiceEvent 'k' = Just MoveUp 76 | charToChoiceEvent '\n' = Just MakeChoice 77 | charToChoiceEvent ' ' = Just ToggleSelection 78 | charToChoiceEvent _ = Nothing 79 | 80 | -- simpleListPrompt options choices = setup $ do 81 | -- inp <- Vty.inputForConfig =<< Vty.standardIOConfig 82 | -- selection <- waitForSelection (Vty._eventChannel inp) 0 83 | -- setSGR [] 84 | -- clearScreen 85 | -- setCursorPosition 0 0 86 | -- Vty.shutdownInput inp 87 | -- return selection 88 | -- where 89 | -- setup = withNoBuffering stdin NoBuffering . withNoCursor . withNoEcho 90 | -- numChoices = length choices 91 | 92 | -- waitForSelection ichan currentIdx = do 93 | -- clearScreen 94 | -- renderListOptions options def choices currentIdx 95 | -- e <- atomically $ readTChan ichan 96 | -- case e of 97 | -- EvKey KEnter _ -> return $ Just (choices !! currentIdx) 98 | -- EvKey (KChar 'n') [MCtrl] -> onDown 99 | -- EvKey (KChar 'j') _ -> onDown 100 | -- EvKey KDown _ -> onDown 101 | -- EvKey (KChar 'p') [MCtrl] -> onUp 102 | -- EvKey (KChar 'k') _ -> onUp 103 | -- EvKey KUp _ -> onUp 104 | -- EvKey (KChar 'q') _ -> return Nothing 105 | -- EvKey KEsc _ -> return Nothing 106 | -- _ -> waitForSelection ichan currentIdx 107 | -- where 108 | -- onDown = waitForSelection ichan ((currentIdx + 1) `rem` numChoices) 109 | -- onUp = let currentIdx' = if currentIdx == 0 110 | -- then length choices - 1 111 | -- else currentIdx - 1 112 | -- in waitForSelection ichan currentIdx' 113 | 114 | 115 | listPrompt :: String -> [String] -> IO String 116 | listPrompt question options = setup $ do 117 | putStrLn question 118 | -- selection has structure: (selected item's index, indexed options) 119 | let selection = (0, zip options ([0..] :: [Int])) 120 | mi <- listenForSelection selection 121 | case mi of 122 | Just i -> return (options !! i) 123 | Nothing -> exitSuccess 124 | where 125 | setup = hWithNoBuffering stdin . withNoEcho 126 | 127 | listenForSelection selection = do 128 | inp <- Vty.inputForConfig =<< Vty.standardIOConfig 129 | go (Vty._eventChannel inp) selection 130 | where 131 | go c os = do 132 | render os 133 | hFlush stdout 134 | e <- atomically (readTChan c) 135 | case e of 136 | EvKey KEnter _ -> do 137 | -- makeChoice 138 | return (Just (fst os)) 139 | EvKey (KChar 'n') [MCtrl] -> do 140 | clearFromCursorTo $ length $ snd os 141 | go c (updateSelection MoveDown os) 142 | EvKey (KChar 'j') _ -> do 143 | clearFromCursorTo $ length $ snd os 144 | go c (updateSelection MoveDown os) 145 | EvKey KDown _ -> do 146 | clearFromCursorTo $ length $ snd os 147 | go c (updateSelection MoveDown os) 148 | EvKey (KChar 'p') [MCtrl] -> do 149 | clearFromCursorTo $ length $ snd os 150 | go c (updateSelection MoveUp os) 151 | EvKey (KChar 'k') _ -> do 152 | clearFromCursorTo $ length $ snd os 153 | go c (updateSelection MoveUp os) 154 | EvKey KUp _ -> do 155 | clearFromCursorTo $ length $ snd os 156 | go c (updateSelection MoveUp os) 157 | EvKey (KChar 'q') _ -> 158 | return Nothing 159 | EvKey (KChar 'c') [MCtrl] -> 160 | return Nothing 161 | EvKey KEsc _ -> 162 | return Nothing 163 | _ -> go c os 164 | 165 | makeChoice = forM_ (replicate (length (snd selection)) ()) 166 | (const (clearLine >> cursorUpLine 1)) 167 | 168 | updateSelection MoveUp (i, os) = ((i - 1) `mod` length os, os) 169 | updateSelection MoveDown (i, os) = ((i + 1) `mod` length os, os) 170 | updateSelection _ _ = error "Internal error, key not recognized" 171 | 172 | render (s, optionsI) = forM_ optionsI $ \(o, i) -> 173 | if i == s 174 | then do 175 | setSGR [ SetColor Foreground Vivid White 176 | , SetConsoleIntensity BoldIntensity 177 | ] 178 | putStr "> " 179 | setSGR [ SetColor Foreground Vivid Cyan 180 | , SetConsoleIntensity NormalIntensity 181 | ] 182 | putStrLn $ o 183 | setSGR [] 184 | else putStrLn $ " " ++ o 185 | 186 | checkboxPrompt :: String -> [String] -> IO [String] 187 | checkboxPrompt question options = setup $ do 188 | putStrLn question 189 | let selection = (0, [], zip options ([0..] :: [Int])) 190 | render selection 191 | is <- listenForSelection selection 192 | return $ map (options !!) is 193 | where 194 | setup = hWithNoBuffering stdin . withNoEcho 195 | 196 | listenForSelection :: (Int, [Int], [(String, Int)]) -> IO [Int] 197 | listenForSelection selection@(_, _, s3) = do 198 | inp <- Vty.inputForConfig =<< Vty.standardIOConfig 199 | go (Vty._eventChannel inp) selection 200 | where 201 | go :: TChan Event -> (Int, [Int], [(String, Int)]) -> IO [Int] 202 | go c os@(_, os2, os3) = do 203 | render os 204 | hFlush stdout 205 | e <- atomically (readTChan c) 206 | print e 207 | case e of 208 | EvKey KEnter _ -> do 209 | makeChoice 210 | return os2 211 | EvKey (KChar 'n') [MCtrl] -> do 212 | clearFromCursorTo $ length os3 213 | go c (updateSelection MoveDown os) 214 | EvKey (KChar 'j') _ -> do 215 | clearFromCursorTo $ length os3 216 | go c (updateSelection MoveDown os) 217 | EvKey KDown _ -> do 218 | clearFromCursorTo $ length os3 219 | go c (updateSelection MoveDown os) 220 | EvKey (KChar 'p') [MCtrl] -> do 221 | clearFromCursorTo $ length os3 222 | go c (updateSelection MoveUp os) 223 | EvKey (KChar 'k') _ -> do 224 | clearFromCursorTo $ length os3 225 | go c (updateSelection MoveUp os) 226 | EvKey KUp _ -> do 227 | clearFromCursorTo $ length os3 228 | go c (updateSelection MoveUp os) 229 | EvKey (KChar 'q') _ -> 230 | return [] 231 | EvKey (KChar 'c') [MCtrl] -> 232 | return [] 233 | EvKey KEsc _ -> 234 | return [] 235 | _ -> do 236 | clearFromCursorTo $ length os3 237 | go c os 238 | 239 | makeChoice = do 240 | let size = length (s3 :: [(String, Int)]) 241 | mlist = replicate size () 242 | forM_ mlist (const (clearLine >> cursorUpLine 1)) 243 | 244 | updateSelection MoveUp (i, is, os) = ((i - 1) `mod` length os, is, os) 245 | updateSelection MoveDown (i, is, os) = ((i + 1) `mod` length os, is, os) 246 | updateSelection ToggleSelection (i, is, os) = (i, is', os) 247 | where 248 | is' = if i `elem` is then delete i is else i:is 249 | updateSelection _ _ = error "Internal error, key not recognized" 250 | 251 | render (i, is, optionsI) = forM_ optionsI $ \(o, j) -> do 252 | let checkbox = if j `elem` is then "◉ " else "◯ " 253 | if i == j 254 | then do 255 | setSGR [ SetColor Foreground Vivid Cyan ] 256 | putStrLn $ ">" ++ checkbox ++ o 257 | setSGR [] 258 | else putStrLn $ " " ++ checkbox ++ o 259 | -------------------------------------------------------------------------------- /unix/System/Console/Questioner/Autocomplete.hs: -------------------------------------------------------------------------------- 1 | module System.Console.Questioner.Autocomplete 2 | where 3 | -------------------------------------------------------------------------------- /unix/System/Console/Questioner/ProgressIndicators.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : System.Console.Questioner.ProgressIndicators 3 | -- Description : Provides progress indicators and spinners 4 | -- Copyright : (c) Pedro Yamada 5 | -- License : MIT 6 | -- 7 | -- Maintainer : Pedro Yamada 8 | -- Stability : stable 9 | -- Portability : non-portable (not tested on multiple environments) 10 | -- 11 | -- Shamefully steals ideas from modules like `Inquirer.js` and `go-spin`. 12 | module System.Console.Questioner.ProgressIndicators 13 | where 14 | 15 | import Control.Applicative ((<$>)) 16 | import Control.Concurrent -- (MVar, ThreadId, forkIO, killThread, modifyMVar_, 17 | -- newMVar, tryTakeMVar, threadDelay) 18 | import Control.Monad (forever) 19 | import Data.Maybe (fromMaybe) 20 | import System.Console.ANSI (clearLine, setCursorColumn) 21 | import System.Console.Terminal.Size (size, Window(..)) 22 | import System.IO (BufferMode(NoBuffering), stdout) 23 | 24 | import System.Console.Questioner.Util 25 | 26 | -- ProgressIndicator type and utilities 27 | ------------------------------------------------------------------------------- 28 | 29 | data ProgressIndicator = BarIndicator ThreadId (MVar Double) 30 | | SpinnerIndicator ThreadId 31 | 32 | stopIndicator :: ProgressIndicator -> IO () 33 | stopIndicator i = case i of 34 | (BarIndicator tid _) -> stopProgressIndicator' tid 35 | (SpinnerIndicator tid) -> stopProgressIndicator' tid 36 | where 37 | stopProgressIndicator' tid = do 38 | killThread tid 39 | clearLine 40 | setCursorColumn 0 41 | 42 | updateIndicator :: ProgressIndicator -> Double -> IO () 43 | updateIndicator (BarIndicator _ c) i = putMVar c i 44 | updateIndicator _ _ = return () 45 | 46 | -- ProgressBars 47 | ------------------------------------------------------------------------------- 48 | 49 | newtype ProgressBarTheme = ProgressBarTheme (Double -> IO ()) 50 | 51 | progressBar :: ProgressBarTheme -> IO ProgressIndicator 52 | progressBar (ProgressBarTheme render) = do 53 | mi <- newEmptyMVar 54 | render 0 55 | tid <- forkIO $ hWithBufferMode stdout NoBuffering $ forever $ do 56 | i <- takeMVar mi 57 | clearLine 58 | setCursorColumn 0 59 | render i 60 | putMVar mi 0 61 | return $ BarIndicator tid mi 62 | 63 | -- Spinners 64 | ------------------------------------------------------------------------------- 65 | 66 | type SpinnerTheme = String 67 | 68 | spinner :: SpinnerTheme -> Int -> String -> IO ProgressIndicator 69 | spinner theme interval prompt = SpinnerIndicator <$> forkIO (setup $ loop 0) 70 | where 71 | setup = hWithBufferMode stdout NoBuffering 72 | 73 | loop i = do 74 | clearLine 75 | setCursorColumn 0 76 | putStr $ ' ' : spinnerState i : ' ' : prompt 77 | threadDelay interval 78 | loop $ i + 1 79 | 80 | -- TODO - parameterize 81 | themeLen = length theme 82 | spinnerState i = theme !! (i `mod` themeLen) 83 | 84 | -- Boilerplate for easier usage (TODO - generate this with TH) 85 | ------------------------------------------------------------------------------- 86 | 87 | simple1SpinnerTheme, simple2SpinnerTheme, simple3SpinnerTheme, 88 | simple4SpinnerTheme, simple5SpinnerTheme, simple6SpinnerTheme, 89 | simple7SpinnerTheme, simple8SpinnerTheme, simple9SpinnerTheme, 90 | dots1SpinnerTheme, dots2SpinnerTheme, dots3SpinnerTheme, dots4SpinnerTheme, 91 | dots5SpinnerTheme, dots6SpinnerTheme, dots7SpinnerTheme :: SpinnerTheme 92 | 93 | simple1Spinner, simple2Spinner, simple3Spinner, simple4Spinner, simple5Spinner, 94 | simple6Spinner, simple7Spinner, simple8Spinner, simple9Spinner, dots1Spinner, 95 | dots2Spinner, dots3Spinner, dots4Spinner, dots5Spinner, dots6Spinner, 96 | dots7Spinner :: Int -> String -> IO ProgressIndicator 97 | 98 | simple1SpinnerTheme = "|/-\\" 99 | simple2SpinnerTheme = "◴◷◶◵" 100 | simple3SpinnerTheme = "◰◳◲◱" 101 | simple4SpinnerTheme = "◐◓◑◒" 102 | simple5SpinnerTheme = "▉▊▋▌▍▎▏▎▍▌▋▊▉" 103 | simple6SpinnerTheme = "▌▄▐▀" 104 | simple7SpinnerTheme = "╫╪" 105 | simple8SpinnerTheme = "■□▪▫" 106 | simple9SpinnerTheme = "←↑→↓" 107 | simple1Spinner = spinner simple1SpinnerTheme 108 | simple2Spinner = spinner simple2SpinnerTheme 109 | simple3Spinner = spinner simple3SpinnerTheme 110 | simple4Spinner = spinner simple4SpinnerTheme 111 | simple5Spinner = spinner simple5SpinnerTheme 112 | simple6Spinner = spinner simple6SpinnerTheme 113 | simple7Spinner = spinner simple7SpinnerTheme 114 | simple8Spinner = spinner simple8SpinnerTheme 115 | simple9Spinner = spinner simple9SpinnerTheme 116 | 117 | dots1SpinnerTheme = "⠋⠙⠹⠸⠼⠴⠦⠧⠇⠏" 118 | dots2SpinnerTheme = "⠋⠙⠹⠸⠼⠴⠦⠧⠇⠏" 119 | dots3SpinnerTheme = "⠄⠆⠇⠋⠙⠸⠰⠠⠰⠸⠙⠋⠇⠆" 120 | dots4SpinnerTheme = "⠋⠙⠚⠒⠂⠂⠒⠲⠴⠦⠖⠒⠐⠐⠒⠓⠋" 121 | dots5SpinnerTheme = "⠁⠉⠙⠚⠒⠂⠂⠒⠲⠴⠤⠄⠄⠤⠴⠲⠒⠂⠂⠒⠚⠙⠉⠁" 122 | dots6SpinnerTheme = "⠈⠉⠋⠓⠒⠐⠐⠒⠖⠦⠤⠠⠠⠤⠦⠖⠒⠐⠐⠒⠓⠋⠉⠈" 123 | dots7SpinnerTheme = "⠁⠁⠉⠙⠚⠒⠂⠂⠒⠲⠴⠤⠄⠄⠤⠠⠠⠤⠦⠖⠒⠐⠐⠒⠓⠋⠉⠈⠈" 124 | dots1Spinner = spinner dots1SpinnerTheme 125 | dots2Spinner = spinner dots2SpinnerTheme 126 | dots3Spinner = spinner dots3SpinnerTheme 127 | dots4Spinner = spinner dots4SpinnerTheme 128 | dots5Spinner = spinner dots5SpinnerTheme 129 | dots6Spinner = spinner dots6SpinnerTheme 130 | dots7Spinner = spinner dots7SpinnerTheme 131 | 132 | simpleProgressBarTheme :: ProgressBarTheme 133 | simpleProgressBarTheme = ProgressBarTheme $ \i -> do 134 | w <- fromMaybe (45 :: Int) <$> (fmap width <$> size) 135 | let blocks = floor ((fromIntegral w :: Double) * i) - 3 136 | putStr (replicate blocks '▉') 137 | 138 | simpleProgressBar :: IO ProgressIndicator 139 | simpleProgressBar = progressBar simpleProgressBarTheme 140 | -------------------------------------------------------------------------------- /unix/System/Console/Questioner/Util.hs: -------------------------------------------------------------------------------- 1 | module System.Console.Questioner.Util 2 | where 3 | 4 | import Control.Exception (bracket_) 5 | import System.Console.ANSI (clearLine, cursorDownLine, cursorUpLine, 6 | hideCursor, showCursor) 7 | import System.IO (BufferMode(..), Handle, hGetBuffering, hSetBuffering, 8 | hSetEcho, stdin) 9 | 10 | -- | 11 | -- Performs an IO action with some buffer mode on a handle 12 | hWithBufferMode :: Handle -> BufferMode -> IO a -> IO a 13 | hWithBufferMode handle bufferMode action = do 14 | originalBuffering <- hGetBuffering handle 15 | bracket_ 16 | (hSetBuffering handle bufferMode) 17 | (hSetBuffering handle originalBuffering) 18 | action 19 | 20 | -- | 21 | -- Performs an IO action with NoBuffering on a handle 22 | hWithNoBuffering :: Handle -> IO a -> IO a 23 | hWithNoBuffering handle = hWithBufferMode handle NoBuffering 24 | 25 | -- | 26 | -- Performs an IO action with the console cursor hidden 27 | withNoCursor :: IO a -> IO a 28 | withNoCursor = bracket_ hideCursor showCursor 29 | 30 | -- | 31 | -- Performs an IO action with console "echoing" supressed 32 | withNoEcho :: IO a -> IO a 33 | withNoEcho = bracket_ (hSetEcho stdin False) (hSetEcho stdin True) 34 | 35 | -- | 36 | -- Clears the screen from the cursor's current position until `n` lines 37 | -- above it 38 | clearFromCursorTo :: Int -> IO () 39 | clearFromCursorTo nlines = do 40 | cursorUpLine nlines 41 | loop nlines 42 | cursorUpLine nlines 43 | where 44 | loop 0 = return () 45 | loop n = do 46 | clearLine 47 | cursorDownLine 1 48 | loop (n - 1) 49 | --------------------------------------------------------------------------------