diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,37 +6,139 @@ and this project adheres to [PVP Versioning][1]. The changelog is also available [on GitHub][2]. - ## [Unreleased] + + +## [0.1.0.0] — 2023-03-02 🎂 + +### Added + +- [#22](https://github.com/chshersh/iris/issues/22): + Implement full CLI Guidelines recommendations on colouring: + + * Detect colours of `stdout` and `stderr` automatically + * Always output colours when `--colour` (or `--color`) is specified + * Disable colours when: + * `--no-colour` (or `--no-color`) is specified + * Output handle doesn't support colouring + * `NO_COLOUR` (or `NO_COLOR`) env is set + * `MYAPP_NO_COLOUR` (or `MYAPP_NO_COLOR`) env is set + * `TERM=dumb` env variable is set + + (by [@marcellourbani], [@chshersh]) +- [#58](https://github.com/chshersh/iris/issues/58): + Detect non-interactive terminals automatically + (by [@marcellourbani]) +- [#89](https://github.com/chshersh/iris/issues/89) + Add `putStderrColoured` and `putStdoutColoured` functions for putting string + without outputting the line break + (by [@Dponya]) +- [#84](https://github.com/chshersh/iris/issues/84): + Add support for GHC 9.4 + (by [@blackheaven]) +- [#27](https://github.com/chshersh/iris/issues/27): + Add Haddock with usage examples to many modules + (by [@chshersh]) + +### Changed + +- [#90](https://github.com/chshersh/iris/issues/90): + Use `Text` instead of `ByteString` in `putStdoutColoured(Ln)` and + `putStderrColoured(Ln)` functions + (by [@lillycat332]) + - __Migration guide:__ Use functions from `Data.Text.Encoding` to convert + between `ByteString` and `Text` or change your types to `Text` +- [#67](https://github.com/chshersh/iris/issues/67): + Remove the `cliEnvSettingsRequiredTools` field from the `CliEnvSettings` type. + Also remove the `CliEnvException` type. Now, a new function `need` from + `Iris.Tool` should be used for each individual command instead. + (by [@german1608]) + - __Migration guide 1:__ Use the `need` function from the `Iris.Tool` module instead. + - __Migration guide 2:__ Don't catch `CliEnvException` from `mkCliEnv` anymore. +- [#33](https://github.com/chshersh/iris/issues/33): + Move errors from `ToolCheckResult` into a separate type + (by [@charrsky]) + - __Migration guide:__ Change pattern-matching on `ToolCheckResult` to + handle only one constructor with an error instead of previous two. + +### Non-UX changes + +- [#16](https://github.com/chshersh/iris/issues/16): + Write complete Iris tutorial with a usage example using Literate Haskell + (by [@Dponya], [@chshersh]) +- [#56](https://github.com/chshersh/iris/issues/56): + Implement tests for the `--help` parser + (by [@CThuleHansen]) +- [#57](https://github.com/chshersh/iris/issues/57): + Add tests for the `--version` and `--numeric-version` flags + (by [@CThuleHansen]) +- [#59](https://github.com/chshersh/iris/issues/59): + Write a test to check if global parsing conflicts with local parsing + (by [@zetkez]) +- [#70](https://github.com/chshersh/iris/issues/70): + Add HLint configuration and CI support + (by [@blackheaven]) +- [#64](https://github.com/chshersh/iris/issues/64): + Add Stan configuration and CI support + (by [@blackheaven]) +- [#69](https://github.com/chshersh/iris/issues/69): + Add pre-commit hooks config + (by [@aleeusgr]) +- [#74](https://github.com/chshersh/iris/issues/74): + Add pull request template + (by [@himanshumalviya15]) +- [#62](https://github.com/chshersh/iris/issues/62): + Use `fourmolu` for code formatting + (by [@chshersh]) + ## [0.0.0.0] — 2022-08-09 🌇 -Initial release prepared by [@chshersh](https://github.com/chshersh). +Initial release prepared by [@chshersh]. ### Added - [#34](https://github.com/chshersh/iris/issues/34): Add the `--no-input` CLI option for disabling interactivity - (by [@charrsky](https://github.com/charrsky)) + (by [@charrsky]) - [#36](https://github.com/chshersh/iris/issues/36): Support Windows and macOS - (by [@charrsky](https://github.com/charrsky)) + (by [@charrsky]) - [#37](https://github.com/chshersh/iris/issues/37): Support GHC 9.0.2 - (by [@charrsky](https://github.com/charrsky)) + (by [@charrsky]) - [#38](https://github.com/chshersh/iris/issues/38): Support GHC 9.2.3 and GHC 9.2.4 - (by [@charrsky](https://github.com/charrsky), [@chshersh](https://github.com/chshersh)) + (by [@charrsky], [@chshersh]) - [#42](https://github.com/chshersh/iris/issues/42), [#52](https://github.com/chshersh/iris/issues/52): Add `stack` support and instructions to build with `stack` - (by [@charrsky](https://github.com/charrsky), [@chshersh](https://github.com/chshersh)) + (by [@charrsky], [@chshersh]) - [#43](https://github.com/chshersh/iris/issues/43): Add `MonadUnliftIO` instance for the `CliApp` monad - (by [@charrsky](https://github.com/charrsky)) + (by [@charrsky]) + + +[@aleeusgr]: https://github.com/aleeusgr +[@blackheaven]: https://github.com/blackheaven +[@charrsky]: https://github.com/charrsky +[@chshersh]: https://github.com/chshersh +[@CThuleHansen]: https://github.com/CThuleHansen +[@Dponya]: https://github.com/Dponya +[@german1608]: https://github.com/german1608 +[@himanshumalviya15]: https://github.com/himanshumalviya15 +[@lillycat332]: https://github.com/lillycat332 +[@marcellourbani]: https://github.com/marcellourbani +[@zetkez]: https://github.com/zetkez + + + [1]: https://pvp.haskell.org [2]: https://github.com/chshersh/iris/releases -[Unreleased]: https://github.com/chshersh/iris/compare/v0.0.0.0...HEAD + + +[Unreleased]: https://github.com/chshersh/iris/compare/v0.1.0.0...HEAD +[0.1.0.0]: https://github.com/chshersh/iris/releases/tag/v0.1.0.0 [0.0.0.0]: https://github.com/chshersh/iris/releases/tag/v0.0.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -35,7 +35,7 @@ 1. **Support [Command Line Interface Guidelines](https://clig.dev/).** Features or changes that violate these guidelines are not accepted in the project. -2. **Beginner-friendliess.** Haskell beginners should be able to build +2. **Beginner-friendliness.** Haskell beginners should be able to build CLI applications with Iris. Hence, the implementation of Iris API that uses less fancy Haskell features are preferred. When the complexity is justified, the cost of introducing this extra @@ -50,6 +50,13 @@ > **NOTE:** Currently, Iris may lack documentation but there's an > ongoing effort to improve the situation. +5. **Single-line access.** Iris is designed for qualified imports, and you + should be able to get all the needed API by writing a single import line: + + ```haskell + import qualified Iris + ``` + 🧱 Iris focuses solely on CLI applications. If you're interested in building TUI app with Haskell, check out [brick](https://hackage.haskell.org/package/brick). @@ -66,10 +73,17 @@ * `--version` * `--numeric-version`: helpful for detecting required tools versions * `--no-input`: for disabling all interactive features + * `--colour=(auto|never|always)`: to set colour mode + * `--no-colour`: to disable terminal colouring * Utilities to open files in a browser -## How to use? +## Quick Start Guide +> 📚 Refer to [the complete Iris tutorial][simple-grep] for more details and +> examples of more Iris features. + +[simple-grep]: https://github.com/chshersh/iris/blob/main/examples/simple-grep/README.md + `iris` is compatible with the following GHC versions - [supported versions](https://matrix.hackage.haskell.org/#/package/iris) @@ -89,6 +103,7 @@ 2. To use this package, refer to the below example. ```haskell + {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Main (main) where @@ -171,9 +186,9 @@ tooling for some reason, type the following commands in the terminal: ```shell -ghcup install ghc 8.10.7 -ghcup set ghc 8.10.7 -ghcup install cabal 3.6.2.0 +ghcup install ghc 9.2.5 +ghcup set ghc 9.2.5 +ghcup install cabal 3.8.1.0 ``` > If you are using Linux or macOS, you may find `ghcup tui` command a diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Main (main) where - -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Reader (MonadReader) - -import qualified Colourista -import qualified Iris -import qualified Paths_iris as Autogen - - -newtype App a = App - { unApp :: Iris.CliApp () () a - } deriving newtype - ( Functor - , Applicative - , Monad - , MonadIO - , MonadReader (Iris.CliEnv () ()) - ) - -appSettings :: Iris.CliEnvSettings () () -appSettings = Iris.defaultCliEnvSettings - { Iris.cliEnvSettingsHeaderDesc = "Iris usage example" - , Iris.cliEnvSettingsProgDesc = "A simple grep utility" - , Iris.cliEnvSettingsVersionSettings = - Just (Iris.defaultVersionSettings Autogen.version) - { Iris.versionSettingsMkDesc = \v -> "Iris Example v" <> v - } - , Iris.cliEnvSettingsRequiredTools = ["curl", "ghc"] - } - -app :: App () -app = do - liftIO $ putStrLn "Hello from an Iris app!" - - Iris.putStdoutColouredLn - (Colourista.formatWith [Colourista.yellow, Colourista.bold]) - "I'm yellow" - - Iris.putStderrColouredLn - (Colourista.formatWith [Colourista.blueBg]) - "I'm white on blue" - -main :: IO () -main = Iris.runCliApp appSettings $ unApp app diff --git a/iris.cabal b/iris.cabal --- a/iris.cabal +++ b/iris.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: iris -version: 0.0.0.0 +version: 0.1.0.0 synopsis: Haskell CLI framework description: Haskell CLI framework. @@ -16,16 +16,18 @@ build-type: Simple extra-doc-files: README.md CHANGELOG.md -tested-with: GHC == 9.2.4 - GHC == 9.0.2 - GHC == 8.10.7 +tested-with: + GHC == 9.4.4 + GHC == 9.2.5 + GHC == 9.0.2 + GHC == 8.10.7 source-repository head type: git location: https://github.com/chshersh/iris.git common common-options - build-depends: base >= 4.14 && < 4.17 + build-depends: base >= 4.14 && < 4.18 ghc-options: -Wall -Wcompat @@ -50,6 +52,8 @@ if impl(ghc >= 9.2) ghc-options: -Wredundant-bang-patterns -Woperator-whitespace + if impl(ghc >= 9.4) + ghc-options: -Wredundant-strictness-flags default-language: Haskell2010 default-extensions: ConstraintKinds @@ -72,62 +76,59 @@ library import: common-options hs-source-dirs: src + exposed-modules: Iris Iris.App Iris.Browse Iris.Cli Iris.Cli.Browse + Iris.Cli.Colour + Iris.Cli.Internal Iris.Cli.Interactive + Iris.Cli.ParserInfo Iris.Cli.Version Iris.Colour Iris.Colour.Formatting Iris.Colour.Mode Iris.Env + Iris.Settings Iris.Tool build-depends: , ansi-terminal ^>= 0.11 , directory ^>= 1.3 - , bytestring >= 0.10 && < 0.12 , mtl >= 2.2 && < 2.4 , optparse-applicative ^>= 0.17 , process ^>= 1.6 , text >= 1.2 && < 2.1 , unliftio-core ^>= 0.2 -executable iris-example - import: common-options - hs-source-dirs: app - - main-is: Main.hs - autogen-modules: Paths_iris - other-modules: Paths_iris - - build-depends: - , iris - , colourista ^>= 0.1 - , mtl - - ghc-options: -threaded - -rtsopts - -with-rtsopts=-N - test-suite iris-test import: common-options type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + autogen-modules: + Paths_iris + other-modules: + Paths_iris Test.Iris + Test.Iris.Common + Test.Iris.Cli + Test.Iris.Colour + Test.Iris.Colour.Mode Test.Iris.Tool build-depends: , iris , hspec >= 2.9.7 && < 2.11 , text + , optparse-applicative - ghc-options: -threaded - -rtsopts - -with-rtsopts=-N + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N diff --git a/src/Iris.hs b/src/Iris.hs --- a/src/Iris.hs +++ b/src/Iris.hs @@ -27,29 +27,35 @@ That's all! Now, you can write your CLI app by having access to all capabilities provided by __Iris__ 🎉 +For a detailed introduction to __Iris__, refer to the following examples: + +* [Simple Grep Example](https://github.com/chshersh/iris/blob/main/examples/simple-grep/README.md) + @since 0.0.0.0 -} - -module Iris - ( -- $app - module Iris.App - -- $browse - , module Iris.Browse - -- $cli - , module Iris.Cli - -- $colour - , module Iris.Colour - -- $env - , module Iris.Env - -- $tool - , module Iris.Tool - ) where +module Iris ( + -- $app + module Iris.App, + -- $browse + module Iris.Browse, + -- $cli + module Iris.Cli, + -- $colour + module Iris.Colour, + -- $env + module Iris.Env, + -- $settings + module Iris.Settings, + -- $tool + module Iris.Tool, +) where import Iris.App import Iris.Browse import Iris.Cli import Iris.Colour import Iris.Env +import Iris.Settings import Iris.Tool {- $app @@ -70,6 +76,10 @@ {- $env Global environment for a CLI application and CLI app settings. +-} + +{- $settings +Settings for the environment. -} {- $tool diff --git a/src/Iris/App.hs b/src/Iris/App.hs --- a/src/Iris/App.hs +++ b/src/Iris/App.hs @@ -1,53 +1,89 @@ {-# LANGUAGE DerivingVia #-} {- | -Module : Iris.Env +Module : Iris.App Copyright : (c) 2022 Dmitrii Kovanikov SPDX-License-Identifier : MPL-2.0 Maintainer : Dmitrii Kovanikov Stability : Experimental Portability : Portable -Haskell CLI framework +The application monad — 'CliApp'. +Many functions in __Iris__ are polymorphic over any monad that has the 'MonadReader' constraint. + +Implement your own application monad as a __newtype__ wrapper around 'CliApp' in +the following way. + +@ +__newtype__ App a = App + { unApp :: Iris.'CliApp' MyOptions MyEnv a + } __deriving newtype__ + ( 'Functor' + , 'Applicative' + , 'Monad' + , 'MonadIO' + , 'MonadUnliftIO' + , 'MonadReader' (Iris.'CliEnv' MyOptions MyEnv) + ) +@ + @since 0.0.0.0 -} - -module Iris.App - ( CliApp (..) - , runCliApp - , runCliAppManually - ) where +module Iris.App ( + CliApp (..), + runCliApp, + runCliAppManually, +) where import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (MonadReader, ReaderT (..)) import Control.Monad.IO.Unlift (MonadUnliftIO) - -import Iris.Env (CliEnv, CliEnvSettings, mkCliEnv) +import Control.Monad.Reader (MonadReader, ReaderT (..)) +import Iris.Env (CliEnv, mkCliEnv) +import Iris.Settings (CliEnvSettings) {- | Main monad for your CLI application. +The type variables are: + +* @cmd@: the data type for your CLI arguments +* @appEnv@: custom environment for your application (can be just @()@ if you + don't need one) +* @a@: the value inside the monadic context + @since 0.0.0.0 -} newtype CliApp cmd appEnv a = CliApp { unCliApp :: CliEnv cmd appEnv -> IO a - } deriving + } + deriving ( Functor - -- ^ @since 0.0.0.0 + -- ^ @since 0.0.0.0 , Applicative - -- ^ @since 0.0.0.0 + -- ^ @since 0.0.0.0 , Monad - -- ^ @since 0.0.0.0 + -- ^ @since 0.0.0.0 , MonadIO - -- ^ @since 0.0.0.0 + -- ^ @since 0.0.0.0 , MonadReader (CliEnv cmd appEnv) - -- ^ @since 0.0.0.0 + -- ^ @since 0.0.0.0 , MonadUnliftIO - -- ^ @since 0.0.0.0 - ) via ReaderT (CliEnv cmd appEnv) IO + -- ^ @since 0.0.0.0 + ) + via ReaderT (CliEnv cmd appEnv) IO {- | Run application with settings. + +This function is supposed to be used in your @main@ function: + +@ +app :: App () +app = ... your main application ... + +main :: IO () +main = 'runCliApp' mySettings (unApp app) +@ @since 0.0.0.0 -} diff --git a/src/Iris/Browse.hs b/src/Iris/Browse.hs --- a/src/Iris/Browse.hs +++ b/src/Iris/Browse.hs @@ -1,7 +1,6 @@ {- | Module : Iris.Browse -Copyright : (c) 2020 Kowainik - (c) 2022 Dmitrii Kovanikov +Copyright : (c) 2022 Dmitrii Kovanikov SPDX-License-Identifier : MPL-2.0 Maintainer : Dmitrii Kovanikov Stability : Experimental @@ -11,11 +10,10 @@ @since 0.0.0.0 -} - -module Iris.Browse - ( openInBrowser - , BrowseException (..) - ) where +module Iris.Browse ( + openInBrowser, + BrowseException (..), +) where import Control.Exception (Exception, throwIO) import System.Directory (findExecutable) @@ -23,29 +21,28 @@ import System.Info (os) import System.Process (callCommand, showCommandForUser) - {- | Exception thrown by 'openInBrowser'. @since 0.0.0.0 -} newtype BrowseException - -- | Can't find a browser application. Stores the current OS inside. - -- - -- @since 0.0.0.0 - = BrowserNotFoundException String + = -- | Can't find a browser application. Stores the current OS inside. + -- + -- @since 0.0.0.0 + BrowserNotFoundException String deriving stock - ( Show -- ^ @since 0.0.0.0 + ( Show + -- ^ @since 0.0.0.0 ) - deriving newtype - ( Eq -- ^ @since 0.0.0.0 + ( Eq + -- ^ @since 0.0.0.0 ) - deriving anyclass - ( Exception -- ^ @since 0.0.0.0 + ( Exception + -- ^ @since 0.0.0.0 ) - {- | Open a given file in a browser. The function has the following algorithm: * Check the @BROWSER@ environment variable @@ -57,91 +54,26 @@ @since 0.0.0.0 -} openInBrowser :: FilePath -> IO () -openInBrowser file = lookupEnv "BROWSER" >>= \case - Just browser -> runCommand browser [file] - Nothing -> case os of - "darwin" -> runCommand "open" [file] - "mingw32" -> runCommand "cmd" ["/c", "start", file] - curOs -> do - browserExe <- findFirstExecutable - [ "xdg-open" - , "cygstart" - , "x-www-browser" - , "firefox" - , "opera" - , "mozilla" - , "netscape" - ] - case browserExe of - Just browser -> runCommand browser [file] - Nothing -> throwIO $ BrowserNotFoundException curOs - --- | Execute a command with arguments. -runCommand :: FilePath -> [String] -> IO () -runCommand cmd args = do - let cmdStr = showCommandForUser cmd args - putStrLn $ "⚙ " ++ cmdStr - callCommand cmdStr - -findFirstExecutable :: [FilePath] -> IO (Maybe FilePath) -findFirstExecutable = \case - [] -> pure Nothing - exe:exes -> findExecutable exe >>= \case - Nothing -> findFirstExecutable exes - Just path -> pure $ Just path - -{- ------------------------- --- Original source code: ------------------------- - -{- | -Copyright: (c) 2020 Kowainik -SPDX-License-Identifier: MPL-2.0 -Maintainer: Kowainik - -Contains implementation of a function that opens a given file in a -browser. --} - -module Stan.Browse - ( openBrowser - ) where - -import Colourista (errorMessage, infoMessage) -import System.Directory (findExecutable) -import System.Info (os) -import System.Process (callCommand, showCommandForUser) - - -{- | Open a given file in a browser. The function has the following algorithm: - -* Check the @BROWSER@ environment variable -* If it's not set, try to guess browser depending on OS -* If unsuccsessful, print a message --} -openBrowser :: FilePath -> IO () -openBrowser file = lookupEnv "BROWSER" >>= \case - Just browser -> runCommand browser [file] - Nothing -> case os of - "darwin" -> runCommand "open" [file] - "mingw32" -> runCommand "cmd" ["/c", "start", file] - curOs -> do - browserExe <- findFirstExecutable - [ "xdg-open" - , "cygstart" - , "x-www-browser" - , "firefox" - , "opera" - , "mozilla" - , "netscape" - ] - case browserExe of - Just browser -> runCommand browser [file] - Nothing -> do - errorMessage $ "Cannot guess browser for the OS: " <> toText curOs - infoMessage "Please set the $BROWSER environment variable to a web launcher" - exitFailure +openInBrowser file = + lookupEnv "BROWSER" >>= \case + Just browser -> runCommand browser [file] + Nothing -> case os of + "darwin" -> runCommand "open" [file] + "mingw32" -> runCommand "cmd" ["/c", "start", file] + curOs -> do + browserExe <- + findFirstExecutable + [ "xdg-open" + , "cygstart" + , "x-www-browser" + , "firefox" + , "opera" + , "mozilla" + , "netscape" + ] + case browserExe of + Just browser -> runCommand browser [file] + Nothing -> throwIO $ BrowserNotFoundException curOs -- | Execute a command with arguments. runCommand :: FilePath -> [String] -> IO () @@ -153,7 +85,7 @@ findFirstExecutable :: [FilePath] -> IO (Maybe FilePath) findFirstExecutable = \case [] -> pure Nothing - exe:exes -> findExecutable exe >>= \case - Nothing -> findFirstExecutable exes - Just path -> pure $ Just path --} + exe : exes -> + findExecutable exe >>= \case + Nothing -> findFirstExecutable exes + Just path -> pure $ Just path diff --git a/src/Iris/Cli.hs b/src/Iris/Cli.hs --- a/src/Iris/Cli.hs +++ b/src/Iris/Cli.hs @@ -10,19 +10,25 @@ @since 0.0.0.0 -} - -module Iris.Cli - ( -- $browse - module Iris.Cli.Browse - -- $version - , module Iris.Cli.Version - ) where +module Iris.Cli ( + -- $browse + module Iris.Cli.Browse, + -- $parserInfo + module Iris.Cli.ParserInfo, + -- $version + module Iris.Cli.Version, +) where import Iris.Cli.Browse +import Iris.Cli.ParserInfo import Iris.Cli.Version {- $browse CLI parsers for @--browse@ flags. +-} + +{- $parserInfo + Info needed to create a CLI parser. -} {- $version diff --git a/src/Iris/Cli/Browse.hs b/src/Iris/Cli/Browse.hs --- a/src/Iris/Cli/Browse.hs +++ b/src/Iris/Cli/Browse.hs @@ -6,15 +6,14 @@ Stability : Experimental Portability : Portable -CLI options parsing for @--browse@ and @--browse=@. +CLI options parsing for @--browse@ and @--browse=FILE_PATH@. @since 0.0.0.0 -} - -module Iris.Cli.Browse - ( browseP - , browseFileP - ) where +module Iris.Cli.Browse ( + browseP, + browseFileP, +) where import qualified Options.Applicative as Opt @@ -27,12 +26,15 @@ @since 0.0.0.0 -} browseP - :: String -- ^ Flag description + :: String + -- ^ Flag description -> Opt.Parser Bool -browseP description = Opt.switch $ mconcat - [ Opt.long "browse" - , Opt.help description - ] +browseP description = + Opt.switch $ + mconcat + [ Opt.long "browse" + , Opt.help description + ] {- | A CLI option parser for a 'FilePath' that needs to be open with a browser. @@ -41,10 +43,13 @@ @since 0.0.0.0 -} browseFileP - :: String -- ^ Flag description + :: String + -- ^ Flag description -> Opt.Parser FilePath -browseFileP description = Opt.option Opt.str $ mconcat - [ Opt.long "browse" - , Opt.metavar "FILE_PATH" - , Opt.help description - ] +browseFileP description = + Opt.option Opt.str $ + mconcat + [ Opt.long "browse" + , Opt.metavar "FILE_PATH" + , Opt.help description + ] diff --git a/src/Iris/Cli/Colour.hs b/src/Iris/Cli/Colour.hs new file mode 100644 --- /dev/null +++ b/src/Iris/Cli/Colour.hs @@ -0,0 +1,67 @@ +{- | +Module : Iris.Cli.Colour +Copyright : (c) 2023 Dmitrii Kovanikov +SPDX-License-Identifier : MPL-2.0 +Maintainer : Dmitrii Kovanikov +Stability : Experimental +Portability : Portable + +CLI parser for the @--colour@ and @--no-colour@ options. + +@since 0.1.0.0 +-} +module Iris.Cli.Colour ( + ColourOption (..), + colourOptionP, +) where + +import Control.Applicative ((<|>)) + +import qualified Options.Applicative as Opt + +{- | Data type that tells whether the user wants the colouring option enabled, +disabled or autodetected. + +See 'colourOptionP' for the parser of this option. + +@since 0.1.0.0 +-} +data ColourOption + = -- | @since 0.1.0.0 + Always + | -- | @since 0.1.0.0 + Never + | -- | @since 0.1.0.0 + Auto + deriving stock + ( Show + -- ^ @since 0.1.0.0 + , Eq + -- ^ @since 0.1.0.0 + , Ord + -- ^ @since 0.1.0.0 + , Enum + -- ^ @since 0.1.0.0 + , Bounded + -- ^ @since 0.1.0.0 + ) + +{- | A CLI option parser for the desired coloured output mode in the terminal. + +It parses @--colour@ and @--no-colour@ flags explicitly. Otherwise, it defaults +to 'Auto'. + +@since 0.1.0.0 +-} +colourOptionP :: Opt.Parser ColourOption +colourOptionP = alwaysP <|> neverP <|> pure Auto + where + alwaysP = + Opt.flag' Always (Opt.long "colour" <> Opt.help "Always output colours") + <|> Opt.flag' Always (Opt.long "color" <> Opt.internal) + + neverP = + Opt.flag' Never (Opt.long "no-colour" <> Opt.help "Never output colours") + <|> Opt.flag' Never (Opt.long "no-color" <> Opt.internal) + <|> Opt.flag' Never (Opt.long "disable-color" <> Opt.internal) + <|> Opt.flag' Never (Opt.long "disable-coulor" <> Opt.internal) diff --git a/src/Iris/Cli/Interactive.hs b/src/Iris/Cli/Interactive.hs --- a/src/Iris/Cli/Interactive.hs +++ b/src/Iris/Cli/Interactive.hs @@ -6,35 +6,39 @@ Stability : Experimental Portability : Portable -Interative mode datatype and CLI parser. +Interactive mode datatype and CLI parser. @since 0.0.0.0 -} - -module Iris.Cli.Interactive - ( InteractiveMode (..) - , interactiveModeP - ) where +module Iris.Cli.Interactive ( + InteractiveMode (..), + interactiveModeP, + handleInteractiveMode, +) where -import Options.Applicative ( (<|>) ) +import Options.Applicative ((<|>)) import qualified Options.Applicative as Opt +import System.Console.ANSI (hSupportsANSI) +import System.IO (stdin) -{- Datatype for specifying if the terminal is interactive. - +{- | Datatype for specifying if the terminal is interactive. + @since 0.0.0.0 -} data InteractiveMode - -- | @since 0.0.0.0 - = Interactive - -- | @since 0.0.0.0 - | NonInteractive - deriving stock - ( Show -- ^ @since 0.0.0.0 - , Eq -- ^ @since 0.0.0.0 + = -- | @since 0.0.0.0 + Interactive + | -- | @since 0.0.0.0 + NonInteractive + deriving stock + ( Show + -- ^ @since 0.0.0.0 + , Eq + -- ^ @since 0.0.0.0 ) - -{- | A CLI option parser for switching to non-interactive mode if the flag is passed. +{- | A CLI option parser for switching to non-interactive mode +if the @--no-input@ flag is passed. @since 0.0.0.0 -} @@ -42,7 +46,27 @@ interactiveModeP = nonInteractiveP <|> pure Interactive where nonInteractiveP :: Opt.Parser InteractiveMode - nonInteractiveP = Opt.flag' NonInteractive $ mconcat - [ Opt.long "no-input" - , Opt.help "Enter the terminal in non-interactive mode" - ] + nonInteractiveP = + Opt.flag' NonInteractive $ + mconcat + [ Opt.long "no-input" + , Opt.help "Enter the terminal in non-interactive mode" + ] + +{- | Forces non interactive mode when the terminal is not interactive + +Use this function to check whether you can get input from the terminal: + +@ +'handleInteractiveMode' requestedInteractiveMode +@ + +If the terminal is non interactive i.e. the program is run in a pipe, +interactive mode is set to false no matter what + +@since 0.1.0.0 +-} +handleInteractiveMode :: InteractiveMode -> IO InteractiveMode +handleInteractiveMode optionMode = do + supportsANSI <- hSupportsANSI stdin + pure $ if supportsANSI then optionMode else NonInteractive diff --git a/src/Iris/Cli/Internal.hs b/src/Iris/Cli/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Iris/Cli/Internal.hs @@ -0,0 +1,26 @@ +{- | +Module : Iris.Cli.Cmd +Copyright : (c) 2022 Dmitrii Kovanikov +SPDX-License-Identifier : MPL-2.0 +Maintainer : Dmitrii Kovanikov +Stability : Internal +Portability : Portable + +Wrapper around the user-defined command. + +__⚠️ This module is internal and doesn't follow PVP.__ +-} +module Iris.Cli.Internal ( + Cmd (..), +) where + +import Data.Kind (Type) +import Iris.Cli.Colour (ColourOption) +import Iris.Cli.Interactive (InteractiveMode) + +-- | Wrapper around @cmd@ with additional predefined fields +data Cmd (cmd :: Type) = Cmd + { cmdInteractiveMode :: InteractiveMode + , cmdColourOption :: ColourOption + , cmdCmd :: cmd + } diff --git a/src/Iris/Cli/ParserInfo.hs b/src/Iris/Cli/ParserInfo.hs new file mode 100644 --- /dev/null +++ b/src/Iris/Cli/ParserInfo.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE FlexibleContexts #-} + +{- | +Module : Iris.Cli.ParserInfo +Copyright : (c) 2022 Dmitrii Kovanikov +SPDX-License-Identifier : MPL-2.0 +Maintainer : Dmitrii Kovanikov +Stability : Experimental +Portability : Portable + +Parser information for the default CLI parser. + +@since 0.1.0.0 +-} +module Iris.Cli.ParserInfo (cmdParserInfo) where + +import Iris.Cli.Interactive (interactiveModeP) +import Iris.Cli.Internal (Cmd (..)) +import Iris.Cli.Version (mkVersionParser) +import Iris.Settings (CliEnvSettings (..)) + +import Iris.Cli.Colour (colourOptionP) +import qualified Options.Applicative as Opt + +{- | + +@since 0.1.0.0 +-} +cmdParserInfo :: forall cmd appEnv. CliEnvSettings cmd appEnv -> Opt.ParserInfo (Cmd cmd) +cmdParserInfo CliEnvSettings{..} = + Opt.info + ( Opt.helper + <*> mkVersionParser cliEnvSettingsVersionSettings + <*> cmdP + ) + $ mconcat + [ Opt.fullDesc + , Opt.header cliEnvSettingsHeaderDesc + , Opt.progDesc cliEnvSettingsProgDesc + ] + where + cmdP :: Opt.Parser (Cmd cmd) + cmdP = do + cmdInteractiveMode <- interactiveModeP + cmdCmd <- cliEnvSettingsCmdParser + cmdColourOption <- colourOptionP + + pure Cmd{..} diff --git a/src/Iris/Cli/Version.hs b/src/Iris/Cli/Version.hs --- a/src/Iris/Cli/Version.hs +++ b/src/Iris/Cli/Version.hs @@ -12,34 +12,31 @@ @since 0.0.0.0 -} - -module Iris.Cli.Version - ( -- * Settings - VersionSettings (..) - , defaultVersionSettings +module Iris.Cli.Version ( + -- * Settings + VersionSettings (..), + defaultVersionSettings, - -- * CLI parser - , fullVersionP + -- * CLI parser + fullVersionP, - -- * Internal helpers - , mkVersionParser - ) where + -- * Internal helpers + mkVersionParser, +) where import Data.Version (Version, showVersion) import qualified Options.Applicative as Opt - {- | @since 0.0.0.0 -} data VersionSettings = VersionSettings - { -- | @since 0.0.0.0 - versionSettingsVersion :: Version - - -- | @since 0.0.0.0 - , versionSettingsMkDesc :: String -> String + { versionSettingsVersion :: Version + -- ^ @since 0.0.0.0 + , versionSettingsMkDesc :: String -> String + -- ^ @since 0.0.0.0 } {- | @@ -47,10 +44,11 @@ @since 0.0.0.0 -} defaultVersionSettings :: Version -> VersionSettings -defaultVersionSettings version = VersionSettings - { versionSettingsVersion = version - , versionSettingsMkDesc = id - } +defaultVersionSettings version = + VersionSettings + { versionSettingsVersion = version + , versionSettingsMkDesc = id + } {- | @@ -70,13 +68,17 @@ versionStr = showVersion versionSettingsVersion versionP :: Opt.Parser (a -> a) - versionP = Opt.infoOption (versionSettingsMkDesc versionStr) $ mconcat - [ Opt.long "version" - , Opt.help "Show application version" - ] + versionP = + Opt.infoOption (versionSettingsMkDesc versionStr) $ + mconcat + [ Opt.long "version" + , Opt.help "Show application version" + ] numericVersionP :: Opt.Parser (a -> a) - numericVersionP = Opt.infoOption versionStr $ mconcat - [ Opt.long "numeric-version" - , Opt.help "Show only numeric application version" - ] + numericVersionP = + Opt.infoOption versionStr $ + mconcat + [ Opt.long "numeric-version" + , Opt.help "Show only numeric application version" + ] diff --git a/src/Iris/Colour.hs b/src/Iris/Colour.hs --- a/src/Iris/Colour.hs +++ b/src/Iris/Colour.hs @@ -10,13 +10,12 @@ @since 0.0.0.0 -} - -module Iris.Colour - ( -- $mode - module Iris.Colour.Mode - -- $formatting - , module Iris.Colour.Formatting - ) where +module Iris.Colour ( + -- $mode + module Iris.Colour.Mode, + -- $formatting + module Iris.Colour.Formatting, +) where import Iris.Colour.Formatting import Iris.Colour.Mode diff --git a/src/Iris/Colour/Formatting.hs b/src/Iris/Colour/Formatting.hs --- a/src/Iris/Colour/Formatting.hs +++ b/src/Iris/Colour/Formatting.hs @@ -12,24 +12,25 @@ @since 0.0.0.0 -} - -module Iris.Colour.Formatting - ( putStdoutColouredLn - , putStderrColouredLn - ) where +module Iris.Colour.Formatting ( + putStdoutColouredLn, + putStderrColouredLn, + putStdoutColoured, + putStderrColoured, +) where import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Reader (MonadReader) -import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Data.Text.IO as T import System.IO (stderr) import Iris.Colour.Mode (ColourMode (..)) import Iris.Env (CliEnv (..), asksCliEnv) -import qualified Data.ByteString.Char8 as BS8 - +import qualified Data.Text.IO as TIO -{- | Print 'ByteString' to 'System.IO.stdout' by providing a custom +{- | Print 'Text' to 'System.IO.stdout' by providing a custom formatting function. This works especially well with the @colourista@ package: @@ -46,16 +47,16 @@ :: ( MonadReader (CliEnv cmd appEnv) m , MonadIO m ) - => (ByteString -> ByteString) - -> ByteString + => (Text -> Text) + -> Text -> m () putStdoutColouredLn formatWithColour str = do colourMode <- asksCliEnv cliEnvStdoutColourMode - liftIO $ BS8.putStrLn $ case colourMode of + liftIO $ T.putStrLn $ case colourMode of DisableColour -> str - EnableColour -> formatWithColour str + EnableColour -> formatWithColour str -{- | Print 'ByteString' to 'System.IO.stderr' by providing a custom +{- | Print 'Text' to 'System.IO.stderr' by providing a custom formatting function. This works especially well with the @colourista@ package: @@ -72,11 +73,65 @@ :: ( MonadReader (CliEnv cmd appEnv) m , MonadIO m ) - => (ByteString -> ByteString) - -> ByteString + => (Text -> Text) + -> Text -> m () putStderrColouredLn formatWithColour str = do colourMode <- asksCliEnv cliEnvStderrColourMode - liftIO $ BS8.hPutStrLn stderr $ case colourMode of + liftIO $ T.hPutStrLn stderr $ case colourMode of DisableColour -> str - EnableColour -> formatWithColour str + EnableColour -> formatWithColour str + +{- | Print 'Text' to 'System.IO.stdout' by providing a custom +formatting function. Doesn't breaks output line that differs from +`putStdoutColouredLn` + +This works especially well with the @colourista@ package: + +@ +'putStdoutColoured' + (Colourista.formatWith [Colourista.bold, Colourista.green]) + "my message" +@ + +@since 0.1.0.0 +-} +putStdoutColoured + :: ( MonadReader (CliEnv cmd appEnv) m + , MonadIO m + ) + => (Text -> Text) + -> Text + -> m () +putStdoutColoured formatWithColour str = do + colourMode <- asksCliEnv cliEnvStdoutColourMode + liftIO $ TIO.putStr $ case colourMode of + DisableColour -> str + EnableColour -> formatWithColour str + +{- | Print 'Text' to 'System.IO.stderr' by providing a custom +formatting function. Doesn't breaks output line that differs from +`putStderrColouredLn` + +This works especially well with the @colourista@ package: + +@ +'putStderrColoured' + (Colourista.formatWith [Colourista.bold, Colourista.green]) + "my message" +@ + +@since 0.1.0.0 +-} +putStderrColoured + :: ( MonadReader (CliEnv cmd appEnv) m + , MonadIO m + ) + => (Text -> Text) + -> Text + -> m () +putStderrColoured formatWithColour str = do + colourMode <- asksCliEnv cliEnvStderrColourMode + liftIO $ TIO.hPutStr stderr $ case colourMode of + DisableColour -> str + EnableColour -> formatWithColour str diff --git a/src/Iris/Colour/Mode.hs b/src/Iris/Colour/Mode.hs --- a/src/Iris/Colour/Mode.hs +++ b/src/Iris/Colour/Mode.hs @@ -1,7 +1,6 @@ {- | Module : Iris.Colour.Mode -Copyright : (c) 2020 Kowainik - (c) 2022 Dmitrii Kovanikov +Copyright : 2022 Dmitrii Kovanikov SPDX-License-Identifier : MPL-2.0 Maintainer : Dmitrii Kovanikov Stability : Experimental @@ -12,15 +11,21 @@ @since 0.0.0.0 -} +module Iris.Colour.Mode ( + ColourMode (..), + detectColourMode, -module Iris.Colour.Mode - ( ColourMode (..) - , handleColourMode - ) where + -- * Internal + handleColourMode, +) where +import Data.Char (toLower, toUpper) +import Data.Maybe (isJust) import System.Console.ANSI (hSupportsANSIColor) +import System.Environment (lookupEnv) import System.IO (Handle) +import Iris.Cli.Colour (ColourOption (..)) {- | Data type that tells whether the colouring is enabled or disabled. Its value is detected automatically on application start and @@ -29,22 +34,26 @@ @since 0.0.0.0 -} data ColourMode - -- | @since 0.0.0.0 - = DisableColour - - -- | @since 0.0.0.0 - | EnableColour + = -- | @since 0.0.0.0 + DisableColour + | -- | @since 0.0.0.0 + EnableColour deriving stock - ( Show -- ^ @since 0.0.0.0 - , Eq -- ^ @since 0.0.0.0 - , Ord -- ^ @since 0.0.0.0 - , Enum -- ^ @since 0.0.0.0 - , Bounded -- ^ @since 0.0.0.0 + ( Show + -- ^ @since 0.0.0.0 + , Eq + -- ^ @since 0.0.0.0 + , Ord + -- ^ @since 0.0.0.0 + , Enum + -- ^ @since 0.0.0.0 + , Bounded + -- ^ @since 0.0.0.0 ) -{- | Returns 'ColourMode' of a 'Handle'. You can use this function on -output 'Handle's to find out whether they support colouring or -not. +{- | Returns 'ColourMode' of a 'Handle' ignoring environment and CLI options. +You can use this function on output 'Handle's to find out whether they support +colouring or not. Use a function like this to check whether you can print with colour to terminal: @@ -60,117 +69,90 @@ supportsANSI <- hSupportsANSIColor handle pure $ if supportsANSI then EnableColour else DisableColour -{- ------------------------- --- Original source code: ------------------------- - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -{- | -Copyright: (c) 2020 Kowainik -SPDX-License-Identifier: MPL-2.0 -Maintainer: Kowainik - -The 'ColourMode' data type that allows disabling and enabling of -colouring. Implemented using the [Implicit Parameters](https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#implicit-parameters) -GHC feature. - -By default, all formatting and printing functions in @colourista@ -print with colour. However, you control this behaviour by adding the -@HasColourMode@ constraint to your functions and setting the value of -the implicit @?colourMode@ variable. - -@since 0.2.0.0 --} - -module Colourista.Mode - ( ColourMode (..) - , HasColourMode - , withColourMode - , handleColourMode - ) where +{- | This function performs a full check of the 'Handle' colouring support, env +variables and user-specified settings to detect whether the given handle +supports colouring. -import System.IO (Handle) -import System.Console.ANSI (hSupportsANSIWithoutEmulation) -import Data.String (IsString) +Per CLI Guidelines, the algorithm for detecting the colouring support is the +following: -import GHC.Classes (IP (..)) +__Disable color if your program is not in a terminal or the user requested it. +These things should disable colors:__ +* @stdout@ or @stderr@ is not an interactive terminal (a TTY). It’s best to + individually check—if you’re piping stdout to another program, it’s still + useful to get colors on stderr. +* The @NO_COLOR@ environment variable is set. +* The @TERM@ environment variable has the value @dumb@. +* The user passes the option @--no-color@. +* You may also want to add a @MYAPP_NO_COLOR@ environment variable in case users + want to disable color specifically for your program. -{- | Data type that tells whether the colouring is enabled or -disabled. It's used with the @-XImplicitParams@ GHC extension. +ℹ️ Iris performs this check on the application start automatically so you don't +need to call this function manually. -@since 0.2.0.0 +@since 0.1.0.0 -} -data ColourMode - = DisableColour - | EnableColour - deriving stock (Show, Eq, Enum, Bounded) - -{- | Magic instance to set the value of the implicit variable -@?colourMode@ to 'EnableColour' by default. Equivalent to the -following code: - -@ -?colourMode = 'EnableColour' -@ +detectColourMode + :: Handle + -- ^ A terminal handle (e.g. 'System.IO.stderr') + -> ColourOption + -- ^ User settings + -> Maybe String + -- ^ Application name + -> IO ColourMode +detectColourMode handle colour maybeAppName = case colour of + Never -> pure DisableColour + Always -> pure EnableColour + Auto -> autoDetectColour + where + autoDetectColour :: IO ColourMode + autoDetectColour = disabledToMode <$> checkIfDisabled -However, you still can override @?colourMode@ with any possible value. + disabledToMode :: Bool -> ColourMode + disabledToMode isDisabled = + if isDisabled then DisableColour else EnableColour -@since 0.2.0.0 --} -instance IP "colourMode" ColourMode where - ip = EnableColour + checkIfDisabled :: IO Bool + checkIfDisabled = + orM + [ isHandleColouringDisabled + , hasNoColourEnvVars + , isTermDumb + ] -{- | Constraint that stores 'ColourMode' as an implicit parameter. + isHandleColouringDisabled :: IO Bool + isHandleColouringDisabled = (== DisableColour) <$> handleColourMode handle -@since 0.2.0.0 --} -type HasColourMode = (?colourMode :: ColourMode) + hasNoColourEnvVars :: IO Bool + hasNoColourEnvVars = orM $ map hasEnvVar allVarNames -{- | Helper function for writing custom formatter. The function takes -'ColourMode' from the implicit parameter context and either returns a -given string or an empty string. + isTermDumb :: IO Bool + isTermDumb = + lookupEnv "TERM" >>= \mVal -> pure $ case mVal of + Nothing -> False + Just val -> map toLower val == "dumb" -@since 0.2.0.0 --} -withColourMode :: (HasColourMode, IsString str) => str -> str -withColourMode str = case ?colourMode of - EnableColour -> str - DisableColour -> "" -{-# INLINE withColourMode #-} + hasEnvVar :: String -> IO Bool + hasEnvVar var = isJust <$> lookupEnv var -{- | Returns 'ColourMode' of a 'Handle'. You can use this function on -output 'Handle's to find out whether they support colouring or -now. Use this function like this to check whether you can print with -colour to terminal: + noColourVarNames :: [String] + noColourVarNames = ["NO_COLOR", "NO_COLOUR"] -@ -'handleColourMode' 'System.IO.stdout' -@ + prepend :: String -> String -> String + prepend appName envName = map toUpper appName <> "_" <> envName -Typical usage can look like this: + allVarNames :: [String] + allVarNames = case maybeAppName of + Nothing -> noColourVarNames + Just appName -> noColourVarNames <> map (prepend appName) noColourVarNames -@ -main :: IO () -main = do - colourMode <- 'handleColourMode' 'System.IO.stdout' - let ?colourMode = fromMaybe 'DisableColour' - 'Colourista.IO.successMessage' "Success!" -@ +(||^) :: Monad m => m Bool -> m Bool -> m Bool +mx ||^ my = do + x <- mx + if x + then pure True + else my -@since 0.2.0.0 --} -handleColourMode :: Handle -> IO (Maybe ColourMode) -handleColourMode handle = do - supportsANSI <- hSupportsANSIWithoutEmulation handle - pure $ fmap - (\supportsColour -> if supportsColour then EnableColour else DisableColour) - supportsANSI --} +orM :: Monad m => [m Bool] -> m Bool +orM = foldr (||^) (pure False) diff --git a/src/Iris/Env.hs b/src/Iris/Env.hs --- a/src/Iris/Env.hs +++ b/src/Iris/Env.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE FlexibleContexts #-} {- | Module : Iris.Env @@ -13,195 +13,76 @@ @since 0.0.0.0 -} - - -module Iris.Env - ( -- * Settings for the CLI app - CliEnvSettings (..) - , defaultCliEnvSettings +module Iris.Env ( + -- * CLI application environment - -- * CLI application environment - -- ** Constructing - , CliEnv (..) - , CliEnvException (..) - , CliEnvError (..) - , mkCliEnv + -- ** Constructing + CliEnv (..), + mkCliEnv, - -- ** Querying - , asksCliEnv - , asksAppEnv - ) where + -- ** Querying + asksCliEnv, + asksAppEnv, +) where -import Control.Exception (Exception, throwIO) import Control.Monad.Reader (MonadReader, asks) -import Data.Foldable (for_) import Data.Kind (Type) import System.IO (stderr, stdout) -import Iris.Cli.Version (VersionSettings, mkVersionParser) -import Iris.Cli.Interactive (InteractiveMode, interactiveModeP) -import Iris.Colour.Mode (ColourMode, handleColourMode) -import Iris.Tool (Tool, ToolCheckResult (..), checkTool) +import Iris.Cli.Interactive (InteractiveMode, handleInteractiveMode) +import Iris.Cli.Internal (Cmd (..)) +import Iris.Cli.ParserInfo (cmdParserInfo) +import Iris.Colour.Mode (ColourMode, detectColourMode) +import Iris.Settings (CliEnvSettings (..)) import qualified Options.Applicative as Opt - -{- | - -@since 0.0.0.0 --} -data CliEnvSettings (cmd :: Type) (appEnv :: Type) = CliEnvSettings - { -- | @since 0.0.0.0 - cliEnvSettingsCmdParser :: Opt.Parser cmd - - -- | @since 0.0.0.0 - , cliEnvSettingsAppEnv :: appEnv - - -- | @since 0.0.0.0 - , cliEnvSettingsHeaderDesc :: String - - -- | @since 0.0.0.0 - , cliEnvSettingsProgDesc :: String - - -- | @since 0.0.0.0 - , cliEnvSettingsVersionSettings :: Maybe VersionSettings - - -- | @since 0.0.0.0 - , cliEnvSettingsRequiredTools :: [Tool cmd] - } - - -{- | - -@since 0.0.0.0 --} -defaultCliEnvSettings :: CliEnvSettings () () -defaultCliEnvSettings = CliEnvSettings - { cliEnvSettingsCmdParser = pure () - , cliEnvSettingsAppEnv = () - , cliEnvSettingsHeaderDesc = "Simple CLI program" - , cliEnvSettingsProgDesc = "CLI tool build with iris - a Haskell CLI framework" - , cliEnvSettingsVersionSettings = Nothing - , cliEnvSettingsRequiredTools = [] - } - - {- | CLI application environment. It contains default settings for every CLI app and parameter Has the following type parameters: -* @cmd@ — application commands -* @appEnv@ — application-specific environment; use @()@ if you don't +* @cmd@: application commands +* @appEnv@: application-specific environment; use @()@ if you don't have custom app environment @since 0.0.0.0 -} data CliEnv (cmd :: Type) (appEnv :: Type) = CliEnv - { -- | @since 0.0.0.0 - cliEnvCmd :: cmd - - -- | @since 0.0.0.0 + { cliEnvCmd :: cmd + -- ^ @since 0.0.0.0 , cliEnvStdoutColourMode :: ColourMode - - -- | @since 0.0.0.0 + -- ^ @since 0.0.0.0 , cliEnvStderrColourMode :: ColourMode - - -- | @since 0.0.0.0 - , cliEnvAppEnv :: appEnv - - -- | @since 0.0.0.0 - , cliEnvInteractiveMode :: InteractiveMode + -- ^ @since 0.0.0.0 + , cliEnvAppEnv :: appEnv + -- ^ @since 0.0.0.0 + , cliEnvInteractiveMode :: InteractiveMode + -- ^ @since 0.0.0.0 } {- | @since 0.0.0.0 -} -newtype CliEnvError - -- | @since 0.0.0.0 - = CliEnvToolError ToolCheckResult - deriving stock - ( Show -- ^ @since 0.0.0.0 - ) - - deriving newtype - ( Eq -- ^ @since 0.0.0.0 - ) -{- | - -@since 0.0.0.0 --} -newtype CliEnvException = CliEnvException - { unCliEnvException :: CliEnvError - } - deriving stock - ( Show -- ^ @since 0.0.0.0 - ) - - deriving newtype - ( Eq -- ^ @since 0.0.0.0 - ) - - deriving anyclass - ( Exception -- ^ @since 0.0.0.0 - ) - -{- | - -Wrapper around @cmd@ with additional predefined fields --} - -data Cmd (cmd :: Type) = Cmd - { cmdInteractiveMode :: InteractiveMode - , cmdCmd :: cmd - } - -{- | - -__Throws:__ 'CliEnvException' - -@since 0.0.0.0 --} mkCliEnv :: forall cmd appEnv - . CliEnvSettings cmd appEnv + . CliEnvSettings cmd appEnv -> IO (CliEnv cmd appEnv) -mkCliEnv CliEnvSettings{..} = do - Cmd{..} <- Opt.execParser cmdParserInfo - stdoutColourMode <- handleColourMode stdout - stderrColourMode <- handleColourMode stderr - - for_ cliEnvSettingsRequiredTools $ \tool -> - checkTool cmdCmd tool >>= \case - ToolOk -> pure () - toolErr -> throwIO $ CliEnvException $ CliEnvToolError toolErr - - pure CliEnv - { cliEnvCmd = cmdCmd - , cliEnvStdoutColourMode = stdoutColourMode - , cliEnvStderrColourMode = stderrColourMode - , cliEnvAppEnv = cliEnvSettingsAppEnv - , cliEnvInteractiveMode = cmdInteractiveMode - } - where - cmdParserInfo :: Opt.ParserInfo (Cmd cmd) - cmdParserInfo = Opt.info - ( Opt.helper - <*> mkVersionParser cliEnvSettingsVersionSettings - <*> cmdP - ) - $ mconcat - [ Opt.fullDesc - , Opt.header cliEnvSettingsHeaderDesc - , Opt.progDesc cliEnvSettingsProgDesc - ] - cmdP :: Opt.Parser (Cmd cmd) - cmdP = do - cmdInteractiveMode <- interactiveModeP - cmdCmd <- cliEnvSettingsCmdParser +mkCliEnv cliEnvSettings@CliEnvSettings{..} = do + Cmd{..} <- Opt.execParser $ cmdParserInfo cliEnvSettings + stdoutColourMode <- detectColourMode stdout cmdColourOption cliEnvSettingsAppName + stderrColourMode <- detectColourMode stderr cmdColourOption cliEnvSettingsAppName + interactive <- handleInteractiveMode cmdInteractiveMode - pure Cmd{..} + pure + CliEnv + { cliEnvCmd = cmdCmd + , cliEnvStdoutColourMode = stdoutColourMode + , cliEnvStderrColourMode = stderrColourMode + , cliEnvAppEnv = cliEnvSettingsAppEnv + , cliEnvInteractiveMode = interactive + } {- | Get a field from the global environment 'CliEnv'. diff --git a/src/Iris/Settings.hs b/src/Iris/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Iris/Settings.hs @@ -0,0 +1,102 @@ +{- | +Module : Iris.Settings +Copyright : (c) 2022 Dmitrii Kovanikov +SPDX-License-Identifier : MPL-2.0 +Maintainer : Dmitrii Kovanikov +Stability : Experimental +Portability : Portable + +Settings of a CLI app environment. + +You're encouraged to create a separate module @MyApp.Settings@ and put settings +for your custom application there following the below pattern: + +@ +__module__ MyApp.Settings (appSettings) __where__ + +-- data data for your CLI arguments and CLI parser +__import__ MyApp.Cli (Options, optionsP) + +-- custom application environment +__import__ MyApp.Env (Env) + +__import qualified__ "Iris" +__import qualified__ Paths_myapp __as__ Autogen + + +appSettings :: Env -> Iris.'CliEnvSettings' Options Env +appSettings env = Iris.defaultCliEnvSettings + { -- CLI parser for Options + Iris.'cliEnvSettingsCmdParser' = optionsP + + -- Custom app environment + , Iris.'cliEnvSettingsAppEnv' = env + + -- Application name + , Iris.'cliEnvSettingsAppName' = + Just "myapp" + + -- Short app description + , Iris.'cliEnvSettingsHeaderDesc' = + "myapp - short description" + + -- Long app description to appear in --help + , Iris.'cliEnvSettingsProgDesc' = + "A tool for ..." + + -- How to print app version with the --version flag + , Iris.'cliEnvSettingsVersionSettings' = + Just (Iris.'Iris.Cli.Version.defaultVersionSettings' Autogen.version) + { Iris.'Iris.Cli.Version.versionSettingsMkDesc' = \v -> "MyApp v" <> v + } + } +@ + +@since 0.1.0.0 +-} +module Iris.Settings ( + -- * Settings for the CLI app + CliEnvSettings (..), + defaultCliEnvSettings, +) where + +import Data.Kind (Type) +import Iris.Cli.Version (VersionSettings) + +import qualified Options.Applicative as Opt + +{- | The Iris settings type. + +Use 'defaultCliEnvSettings' to specify only used fields. + +@since 0.0.0.0 +-} +data CliEnvSettings (cmd :: Type) (appEnv :: Type) = CliEnvSettings + { cliEnvSettingsCmdParser :: Opt.Parser cmd + -- ^ @since 0.0.0.0 + , cliEnvSettingsAppEnv :: appEnv + -- ^ @since 0.0.0.0 + , cliEnvSettingsHeaderDesc :: String + -- ^ @since 0.0.0.0 + , cliEnvSettingsProgDesc :: String + -- ^ @since 0.0.0.0 + , cliEnvSettingsVersionSettings :: Maybe VersionSettings + -- ^ @since 0.0.0.0 + , cliEnvSettingsAppName :: Maybe String + -- ^ @since 0.1.0.0 + } + +{- | Default Iris app settings. + +@since 0.0.0.0 +-} +defaultCliEnvSettings :: CliEnvSettings () () +defaultCliEnvSettings = + CliEnvSettings + { cliEnvSettingsCmdParser = pure () + , cliEnvSettingsAppEnv = () + , cliEnvSettingsHeaderDesc = "Simple CLI program" + , cliEnvSettingsProgDesc = "CLI tool build with iris - a Haskell CLI framework" + , cliEnvSettingsAppName = Nothing + , cliEnvSettingsVersionSettings = Nothing + } diff --git a/src/Iris/Tool.hs b/src/Iris/Tool.hs --- a/src/Iris/Tool.hs +++ b/src/Iris/Tool.hs @@ -8,20 +8,27 @@ Utilities to check required tools and their minimal version for a CLI app. +Sometimes, your CLI application + @since 0.0.0.0 -} - -module Iris.Tool - ( -- * Types describing executable requirements - Tool (..) - , ToolSelector (..) - , defaultToolSelector +module Iris.Tool ( + -- * Requiring an executable + need, + Tool (..), + ToolSelector (..), + defaultToolSelector, - -- * Tool requirements check - , ToolCheckResult (..) - , checkTool - ) where + -- * Tool requirements check + ToolCheckResult (..), + ToolCheckError (..), + ToolCheckException (..), + checkTool, +) where +import Control.Exception (Exception, throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Foldable (traverse_) import Data.String (IsString (..)) import Data.Text (Text) import System.Directory (findExecutable) @@ -29,94 +36,151 @@ import qualified Data.Text as Text - {- | @since 0.0.0.0 -} -data Tool cmd = Tool - { -- | @since 0.0.0.0 - toolName :: Text - - -- | @since 0.0.0.0 - , toolSelector :: Maybe (ToolSelector cmd) +data Tool = Tool + { toolName :: Text + -- ^ @since 0.0.0.0 + , toolSelector :: Maybe ToolSelector + -- ^ @since 0.0.0.0 } {- | @since 0.0.0.0 -} -instance IsString (Tool cmd) where - fromString :: String -> Tool cmd - fromString s = Tool - { toolName = fromString s - , toolSelector = Nothing - } +instance IsString Tool where + fromString :: String -> Tool + fromString s = + Tool + { toolName = fromString s + , toolSelector = Nothing + } {- | @since 0.0.0.0 -} -data ToolSelector cmd = ToolSelector - { -- | @since 0.0.0.0 - toolSelectorFunction :: cmd -> Text -> Bool - - -- | @since 0.0.0.0 +data ToolSelector = ToolSelector + { toolSelectorFunction :: Text -> Bool + -- ^ @since 0.0.0.0 , toolSelectorVersionArg :: Maybe Text + -- ^ @since 0.0.0.0 } {- | @since 0.0.0.0 -} -defaultToolSelector :: ToolSelector cmd -defaultToolSelector = ToolSelector - { toolSelectorFunction = \_cmd _version -> True - , toolSelectorVersionArg = Nothing - } +defaultToolSelector :: ToolSelector +defaultToolSelector = + ToolSelector + { toolSelectorFunction = const True + , toolSelectorVersionArg = Nothing + } {- | @since 0.0.0.0 -} data ToolCheckResult - {- | + = -- | + -- + -- @since 0.1.0.0 + ToolCheckError ToolCheckError + | -- | + -- + -- @since 0.0.0.0 + ToolOk + deriving stock + ( Show + -- ^ @since 0.0.0.0 + , Eq + -- ^ @since 0.0.0.0 + ) - @since 0.0.0.0 - -} - = ToolNotFound Text +{- | - {- | +@since 0.1.0.0 +-} +data ToolCheckError + = -- | + -- + -- @since 0.1.0.0 + ToolNotFound Text + | -- | + -- + -- @since 0.1.0.0 + ToolWrongVersion Text + deriving stock + ( Show + -- ^ @since 0.1.0.0 + , Eq + -- ^ @since 0.1.0.0 + ) - @since 0.0.0.0 - -} - | ToolWrongVersion Text +{- | - {- | +@since 0.0.0.0 +-} +checkTool :: Tool -> IO ToolCheckResult +checkTool Tool{..} = + findExecutable (Text.unpack toolName) >>= \case + Nothing -> pure $ ToolCheckError $ ToolNotFound toolName + Just exe -> case toolSelector of + Nothing -> pure ToolOk + Just ToolSelector{..} -> case toolSelectorVersionArg of + Nothing -> pure ToolOk + Just versionArg -> do + toolVersionOutput <- readProcess exe [Text.unpack versionArg] "" + let version = Text.strip $ Text.pack toolVersionOutput - @since 0.0.0.0 - -} - | ToolOk + if toolSelectorFunction version + then pure ToolOk + else pure $ ToolCheckError $ ToolWrongVersion version + +{- | An exception thrown by 'need' when there's an error requiring a tool. + +@since 0.1.0.0 +-} +newtype ToolCheckException = ToolCheckException ToolCheckError deriving stock - ( Show -- ^ @since 0.0.0.0 - , Eq -- ^ @since 0.0.0.0 + ( Show + -- ^ @since 0.1.0.0 ) + deriving newtype + ( Eq + -- ^ @since 0.1.0.0 + ) + deriving anyclass + ( Exception + -- ^ @since 0.1.0.0 + ) -{- | +{- | Use this function to require specific CLI tools for your CLI application. +The function can be used in the beginning of each command in the following way: + +@ +app :: App () +app = Iris.'Iris.Env.asksCliEnv' Iris.'Iris.Env.cliEnvCmd' >>= __\\case__ + Download url -> do + Iris.'need' ["curl"] + runDownload url + Evaluate hs -> do + Iris.'need' ["ghc", "cabal"] + runEvaluate hs +@ + +__Throws:__ 'ToolCheckException' if can't find a tool or if it has wrong version. + @since 0.0.0.0 -} -checkTool :: cmd -> Tool cmd -> IO ToolCheckResult -checkTool cmd Tool{..} = findExecutable (Text.unpack toolName) >>= \case - Nothing -> pure $ ToolNotFound toolName - Just exe -> case toolSelector of - Nothing -> pure ToolOk - Just ToolSelector{..} -> case toolSelectorVersionArg of - Nothing -> pure ToolOk - Just versionArg -> do - toolVersionOutput <- readProcess exe [Text.unpack versionArg] "" - let version = Text.strip $ Text.pack toolVersionOutput - - if toolSelectorFunction cmd version - then pure ToolOk - else pure $ ToolWrongVersion version +need :: MonadIO m => [Tool] -> m () +need = traverse_ $ \tool -> + liftIO $ + checkTool tool >>= \case + ToolOk -> pure () + ToolCheckError toolErr -> throwIO $ ToolCheckException toolErr diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,6 +4,5 @@ import Test.Iris (irisSpec) - main :: IO () main = hspec irisSpec diff --git a/test/Test/Iris.hs b/test/Test/Iris.hs --- a/test/Test/Iris.hs +++ b/test/Test/Iris.hs @@ -2,8 +2,13 @@ import Test.Hspec (Spec, describe) +import Test.Iris.Cli (cliSpec, cliSpecParserConflicts) +import Test.Iris.Colour (colourSpec) import Test.Iris.Tool (toolSpec) irisSpec :: Spec irisSpec = describe "Iris" $ do + cliSpec + cliSpecParserConflicts + colourSpec toolSpec diff --git a/test/Test/Iris/Cli.hs b/test/Test/Iris/Cli.hs new file mode 100644 --- /dev/null +++ b/test/Test/Iris/Cli.hs @@ -0,0 +1,194 @@ +module Test.Iris.Cli (cliSpec, cliSpecParserConflicts) where + +import Options.Applicative (getParseResult) +import Test.Hspec (Expectation, Spec, describe, expectationFailure, it, shouldBe, shouldReturn) + +import Iris (CliEnvSettings (..)) +import Iris.Cli (VersionSettings (versionSettingsMkDesc)) +import Iris.Cli.Colour (ColourOption (..)) +import Iris.Cli.Interactive (InteractiveMode (..), handleInteractiveMode) +import Iris.Cli.Internal +import Iris.Cli.ParserInfo (cmdParserInfo) +import Iris.Cli.Version (defaultVersionSettings) +import Iris.Settings (defaultCliEnvSettings) + +import Test.Iris.Common (checkCI) + +import qualified Options.Applicative as Opt +import qualified Paths_iris as Autogen + +expectedHelpText :: String +expectedHelpText = + "Simple CLI program\n\ + \\n\ + \Usage: [--no-input] [--colour | --no-colour]\n\ + \\n\ + \ CLI tool build with iris - a Haskell CLI framework\n\ + \\n\ + \Available options:\n\ + \ -h,--help Show this help text\n\ + \ --no-input Enter the terminal in non-interactive mode\n\ + \ --colour Always output colours\n\ + \ --no-colour Never output colours" + +expectedHelpTextWithVersion :: String +expectedHelpTextWithVersion = + "Simple CLI program\n\ + \\n\ + \Usage: [--version] [--numeric-version] [--no-input] \n\ + \ [--colour | --no-colour]\n\ + \\n\ + \ CLI tool build with iris - a Haskell CLI framework\n\ + \\n\ + \Available options:\n\ + \ -h,--help Show this help text\n\ + \ --version Show application version\n\ + \ --numeric-version Show only numeric application version\n\ + \ --no-input Enter the terminal in non-interactive mode\n\ + \ --colour Always output colours\n\ + \ --no-colour Never output colours" + +expectedNumericVersion :: String +expectedNumericVersion = "0.1.0.0" + +cliSpec :: Spec +cliSpec = describe "Cli Options" $ do + let parserPrefs = Opt.defaultPrefs + it "help without version environment" $ do + let parserInfo = cmdParserInfo defaultCliEnvSettings + let result = Opt.execParserPure parserPrefs parserInfo ["--help"] + parseResultHandlerFailure result expectedHelpText + it "help with version environment" $ do + let cliEnvSettings = defaultCliEnvSettings{cliEnvSettingsVersionSettings = Just (defaultVersionSettings Autogen.version)} + let parserInfo = cmdParserInfo cliEnvSettings + let result = Opt.execParserPure parserPrefs parserInfo ["--help"] + parseResultHandlerFailure result expectedHelpTextWithVersion + it "--numeric-version returns correct version" $ do + let cliEnvSettings = defaultCliEnvSettings{cliEnvSettingsVersionSettings = Just (defaultVersionSettings Autogen.version)} + let parserInfo = cmdParserInfo cliEnvSettings + let result = Opt.execParserPure parserPrefs parserInfo ["--numeric-version"] + parseResultHandlerFailure result expectedNumericVersion + it "CI interactivity check" $ do + handleInteractiveMode NonInteractive `shouldReturn` NonInteractive + isCi <- checkCI + if isCi + then handleInteractiveMode Interactive `shouldReturn` NonInteractive + else handleInteractiveMode Interactive `shouldReturn` Interactive + it "Handles colour mode" $ do + let parserInfo = cmdParserInfo defaultCliEnvSettings + let coloption args = getParseResult $ cmdColourOption <$> Opt.execParserPure parserPrefs parserInfo args + coloption ["--colour"] `shouldBe` pure Always + coloption ["--no-colour"] `shouldBe` pure Never + coloption [] `shouldBe` pure Auto + + it "--version returns correct version text" $ do + let expectedVersionMkDescription = ("Version " ++) + let cliEnvSettings = defaultCliEnvSettings{cliEnvSettingsVersionSettings = Just $ (defaultVersionSettings Autogen.version){versionSettingsMkDesc = expectedVersionMkDescription}} + let parserInfo = cmdParserInfo cliEnvSettings + let expectedVersion = expectedVersionMkDescription expectedNumericVersion + let result = Opt.execParserPure parserPrefs parserInfo ["--version"] + parseResultHandlerFailure result expectedVersion + +newtype UserDefinedParser a = UserDefinedParser {noInteractive :: a} + +userDefinedNoInputOption :: Opt.Parser (UserDefinedParser String) +userDefinedNoInputOption = + UserDefinedParser + <$> Opt.strOption (Opt.long "no-input") + +userDefinedNoInputSwitch :: Opt.Parser (UserDefinedParser Bool) +userDefinedNoInputSwitch = + UserDefinedParser + <$> Opt.switch (Opt.long "no-input") + +userDefinedNoInputOnCommand :: Opt.Parser (UserDefinedParser Bool) +userDefinedNoInputOnCommand = + Opt.subparser + ( Opt.command + "test-command" + (Opt.info userDefinedNoInputSwitch Opt.fullDesc) + ) + +customParserSettings :: Opt.Parser (UserDefinedParser a) -> CliEnvSettings (UserDefinedParser a) () +customParserSettings parser = + CliEnvSettings + { cliEnvSettingsCmdParser = parser + , cliEnvSettingsAppEnv = () + , cliEnvSettingsHeaderDesc = "Simple CLI program" + , cliEnvSettingsProgDesc = "CLI tool build with iris - a Haskell CLI framework" + , cliEnvSettingsVersionSettings = Nothing + , cliEnvSettingsAppName = Nothing + } + +argValue :: String +argValue = "someValue" + +expectedErrorTextUserDefinedNoInputArg :: String +expectedErrorTextUserDefinedNoInputArg = + "Invalid argument `" + <> argValue + <> "'\n\ + \\n\ + \Usage: [--no-input] --no-input ARG [--colour | --no-colour]\n\ + \\n\ + \ CLI tool build with iris - a Haskell CLI framework" + +expectedErrorTextUserDefinedNoInputNoArg :: String +expectedErrorTextUserDefinedNoInputNoArg = + "Missing: --no-input ARG\n\ + \\n\ + \Usage: [--no-input] --no-input ARG [--colour | --no-colour]\n\ + \\n\ + \ CLI tool build with iris - a Haskell CLI framework" + +cliSpecParserConflicts :: Spec +cliSpecParserConflicts = describe "Cli Parser Conflicts" $ do + let parserPrefs = Opt.defaultPrefs + it "--no-input=someValue defined by user - arg provided" $ do + let parserInfo = cmdParserInfo $ customParserSettings userDefinedNoInputOption + let result = Opt.execParserPure parserPrefs parserInfo ["--no-input", argValue] + parseResultHandlerFailure result expectedErrorTextUserDefinedNoInputArg + it "--no-input=someValue defined by user - no arg provided" $ do + let parserInfo = cmdParserInfo $ customParserSettings userDefinedNoInputOption + let result = Opt.execParserPure parserPrefs parserInfo ["--no-input"] + parseResultHandlerFailure result expectedErrorTextUserDefinedNoInputNoArg + it "--no-input=someValue defined by user - not provided at all" $ do + let parserInfo = cmdParserInfo $ customParserSettings userDefinedNoInputOption + let result = Opt.execParserPure parserPrefs parserInfo [] + parseResultHandlerFailure result expectedErrorTextUserDefinedNoInputNoArg + it "--no-input switch defined by user - provided" $ do + let parserInfo = cmdParserInfo $ customParserSettings userDefinedNoInputSwitch + let result = Opt.execParserPure parserPrefs parserInfo ["--no-input"] + parseResultHandlerSuccess result ["NonInteractive", "False"] + it "--no-input switch defined by user - not provided" $ do + let parserInfo = cmdParserInfo $ customParserSettings userDefinedNoInputSwitch + let result = Opt.execParserPure parserPrefs parserInfo [] + parseResultHandlerSuccess result ["Interactive", "False"] + it "--no-input switch with command defined by user - user provided" $ do + let parserInfo = cmdParserInfo $ customParserSettings userDefinedNoInputOnCommand + let result = Opt.execParserPure parserPrefs parserInfo ["test-command", "--no-input"] + parseResultHandlerSuccess result ["Interactive", "True"] + it "--no-input switch with command defined by user - internal provided" $ do + let parserInfo = cmdParserInfo $ customParserSettings userDefinedNoInputOnCommand + let result = Opt.execParserPure parserPrefs parserInfo ["--no-input", "test-command"] + parseResultHandlerSuccess result ["NonInteractive", "False"] + +parseResultHandlerSuccess :: Show b => Opt.ParserResult (Cmd (UserDefinedParser b)) -> [String] -> Expectation +parseResultHandlerSuccess parseResult expected = + case parseResult of + Opt.Failure _ -> expectationFailure "Expected 'Success' but got 'Failure' " + Opt.Success a -> do + let internalNoInput = show $ cmdInteractiveMode a + let userDefinedNoInput = show . noInteractive . cmdCmd $ a + shouldBe [internalNoInput, userDefinedNoInput] expected + Opt.CompletionInvoked completionResult -> expectationFailure $ "Expected 'Success' but got: " <> show completionResult + +parseResultHandlerFailure :: Opt.ParserResult a -> String -> Expectation +parseResultHandlerFailure parseResult expected = + case parseResult of + -- The help functionality is baked into optparse-applicative and presents itself as a ParserFailure. + Opt.Failure (Opt.ParserFailure getFailure) -> do + let (helpText, _exitCode, _int) = getFailure "" + show helpText `shouldBe` expected + Opt.Success _ -> expectationFailure "Expected 'Failure' but got 'Success' " + Opt.CompletionInvoked completionResult -> expectationFailure $ "Expected 'Failure' but got: " <> show completionResult diff --git a/test/Test/Iris/Colour.hs b/test/Test/Iris/Colour.hs new file mode 100644 --- /dev/null +++ b/test/Test/Iris/Colour.hs @@ -0,0 +1,9 @@ +module Test.Iris.Colour (colourSpec) where + +import Test.Hspec (Spec, describe) + +import Test.Iris.Colour.Mode (modeSpec) + +colourSpec :: Spec +colourSpec = describe "Colour" $ do + modeSpec diff --git a/test/Test/Iris/Colour/Mode.hs b/test/Test/Iris/Colour/Mode.hs new file mode 100644 --- /dev/null +++ b/test/Test/Iris/Colour/Mode.hs @@ -0,0 +1,84 @@ +module Test.Iris.Colour.Mode (modeSpec) where + +import Data.Foldable (for_) +import System.Environment (setEnv, unsetEnv) +import System.IO (stderr, stdout) +import Test.Hspec (Spec, before_, describe, it, shouldReturn) + +import Iris.Cli.Colour (ColourOption (..)) +import Iris.Colour.Mode (ColourMode (..), detectColourMode) + +import Test.Iris.Common (checkCI) + +modeSpec :: Spec +modeSpec = before_ clearAppEnv $ describe "Mode" $ do + let detectStdoutColour option = detectColourMode stdout option (Just "myapp") + let detectStderrColour option = detectColourMode stderr option (Just "myapp") + + it "DisableColour when --no-colour" $ do + detectStdoutColour Never `shouldReturn` DisableColour + detectStderrColour Never `shouldReturn` DisableColour + + it "EnableColour when --colour" $ do + detectStdoutColour Always `shouldReturn` EnableColour + detectStderrColour Always `shouldReturn` EnableColour + + it "EnableColour in clear environment" $ do + ciColour <- colourWithCI + detectStdoutColour Auto `shouldReturn` ciColour + detectStderrColour Auto `shouldReturn` ciColour + + it "DisableColour when NO_COLOR is set" $ do + setEnv "NO_COLOR" "1" + detectStdoutColour Auto `shouldReturn` DisableColour + detectStderrColour Auto `shouldReturn` DisableColour + + it "DisableColour when NO_COLOUR is set" $ do + setEnv "NO_COLOUR" "1" + detectStdoutColour Auto `shouldReturn` DisableColour + detectStderrColour Auto `shouldReturn` DisableColour + + it "DisableColour when MYAPP_NO_COLOR is set" $ do + setEnv "MYAPP_NO_COLOR" "1" + detectStdoutColour Auto `shouldReturn` DisableColour + detectStderrColour Auto `shouldReturn` DisableColour + + it "DisableColour when MYAPP_NO_COLOUR is set" $ do + setEnv "MYAPP_NO_COLOUR" "1" + detectStdoutColour Auto `shouldReturn` DisableColour + detectStderrColour Auto `shouldReturn` DisableColour + + it "DisableColour when TERM=dumb" $ do + setEnv "TERM" "dumb" + detectStdoutColour Auto `shouldReturn` DisableColour + detectStderrColour Auto `shouldReturn` DisableColour + + it "EnableColour when TERM=xterm-256color" $ do + setEnv "TERM" "xterm-256color" + ciColour <- colourWithCI + detectStdoutColour Auto `shouldReturn` ciColour + detectStderrColour Auto `shouldReturn` ciColour + + it "DisableColour when CI is set" $ do + ciColour <- colourWithCI + detectStdoutColour Auto `shouldReturn` ciColour + detectStderrColour Auto `shouldReturn` ciColour + +-- Helper functions + +testEnvVars :: [String] +testEnvVars = + [ "NO_COLOR" + , "NO_COLOUR" + , "MYAPP_NO_COLOR" + , "MYAPP_NO_COLOUR" + , "TERM" + ] + +clearAppEnv :: IO () +clearAppEnv = for_ testEnvVars unsetEnv + +colourWithCI :: IO ColourMode +colourWithCI = do + isCi <- checkCI + pure $ if isCi then DisableColour else EnableColour diff --git a/test/Test/Iris/Common.hs b/test/Test/Iris/Common.hs new file mode 100644 --- /dev/null +++ b/test/Test/Iris/Common.hs @@ -0,0 +1,9 @@ +module Test.Iris.Common ( + checkCI, +) where + +import Data.Maybe (isJust) +import System.Environment (lookupEnv) + +checkCI :: IO Bool +checkCI = isJust <$> lookupEnv "CI" diff --git a/test/Test/Iris/Tool.hs b/test/Test/Iris/Tool.hs --- a/test/Test/Iris/Tool.hs +++ b/test/Test/Iris/Tool.hs @@ -2,44 +2,70 @@ import Data.Text (Text) import Data.Version (Version, makeVersion, parseVersion) -import Test.Hspec (Spec, describe, it, shouldReturn, shouldSatisfy) +import Test.Hspec (Spec, describe, it, shouldReturn, shouldSatisfy, shouldThrow) import Text.ParserCombinators.ReadP (readP_to_S) -import Iris.Tool (Tool (..), ToolCheckResult (..), ToolSelector (..), checkTool, - defaultToolSelector) +import Iris.Tool ( + Tool (..), + ToolCheckError (..), + ToolCheckException (..), + ToolCheckResult (..), + ToolSelector (..), + checkTool, + defaultToolSelector, + need, + ) import qualified Data.Text as Text +ghc100 :: Tool +ghc100 = + "ghc" + { toolSelector = + Just + defaultToolSelector + { toolSelectorFunction = \version -> case getVersion version of + Nothing -> False + Just v -> v >= makeVersion [100] + , toolSelectorVersionArg = Just "--numeric-version" + } + } toolSpec :: Spec toolSpec = describe "Tool" $ do it "should find 'curl'" $ do - checkTool () "curl" `shouldReturn` ToolOk + checkTool "curl" `shouldReturn` ToolOk it "shouldn't find 'xxx_unknown_executable'" $ do - checkTool () "xxx_unknown_executable" - `shouldReturn` ToolNotFound "xxx_unknown_executable" + checkTool "xxx_unknown_executable" + `shouldReturn` ToolCheckError (ToolNotFound "xxx_unknown_executable") it "shouldn't find 'ghc' version 100" $ do - let tool :: Tool () - tool = "ghc" - { toolSelector = Just defaultToolSelector - { toolSelectorFunction = \_cmd version -> case getVersion version of - Nothing -> False - Just v -> v >= makeVersion [100] - , toolSelectorVersionArg = Just "--numeric-version" - } - } - let isToolWrongVersion :: ToolCheckResult -> Bool - isToolWrongVersion (ToolWrongVersion _) = True - isToolWrongVersion _other = False + isToolWrongVersion (ToolCheckError (ToolWrongVersion _)) = True + isToolWrongVersion _other = False - checkTool () tool >>= (`shouldSatisfy` isToolWrongVersion) + checkTool ghc100 >>= (`shouldSatisfy` isToolWrongVersion) + it "should not fail when 'need'ing 'curl'" (need ["curl"] :: IO ()) + + it "should fail when 'need'ing not found tools" $ do + let tool = "xxx_unknown_executable" + let expectedExceptionSel (err :: ToolCheckException) = case err of + ToolCheckException (ToolNotFound e) -> e == tool + _other -> False + + need [Tool tool Nothing] `shouldThrow` expectedExceptionSel + + it "should fail when 'need'ing tools with wrong version" $ do + let expectedExceptionSel (err :: ToolCheckException) = case err of + ToolCheckException (ToolWrongVersion _) -> True + _other -> False + need [ghc100] `shouldThrow` expectedExceptionSel + getVersion :: Text -> Maybe Version getVersion = extractVersion . readP_to_S parseVersion . Text.unpack where extractVersion :: [(Version, String)] -> Maybe Version extractVersion [(version, "")] = Just version - extractVersion _ = Nothing + extractVersion _ = Nothing