ConsoleAsk (empty) → 0.1.0.0
raw patch · 9 files changed
+827/−0 lines, 9 filesdep +basedep +lensdep +parsecsetup-changed
Dependencies added: base, lens, parsec, regex-tdfa, text
Files
- CHANGELOG.md +2/−0
- ConsoleAsk.cabal +44/−0
- LICENSE +21/−0
- README.md +245/−0
- Setup.hs +2/−0
- src/System/Console/Ask.hs +174/−0
- src/System/Console/Ask/Askable.hs +86/−0
- src/System/Console/Ask/Behaviour.hs +155/−0
- src/System/Console/Ask/Internal.hs +98/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+# 0.1.0.0 +Initial release.
+ ConsoleAsk.cabal view
@@ -0,0 +1,44 @@+cabal-version: 2.2 + +name: ConsoleAsk +version: 0.1.0.0 +description: Please see the README on GitHub at <https://github.com/t-sasaki915/ConsoleAsk#readme> +synopsis: Simple CLI user input library +homepage: https://github.com/t-sasaki915/ConsoleAsk#readme +bug-reports: https://github.com/t-sasaki915/ConsoleAsk/issues +author: Toma Sasaki +maintainer: netst915@gmail.com +copyright: 2025 Toma Sasaki +category: System, Console +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/t-sasaki915/ConsoleAsk + +library + exposed-modules: + System.Console.Ask.Askable + System.Console.Ask.Behaviour + System.Console.Ask.Internal + System.Console.Ask + other-modules: + Paths_ConsoleAsk + autogen-modules: + Paths_ConsoleAsk + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.7 && <5 + , text >=2 && <3 + , regex-tdfa >=1.3 && <1.4 + , parsec >=3.1 && <3.2 + , lens >=5 && <6 + default-language: Haskell2010 + default-extensions: OverloadedStrings, LambdaCase, QuasiQuotes
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License + +Copyright (c) 2025 Toma Sasaki + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE.
+ README.md view
@@ -0,0 +1,245 @@+# ConsoleAsk +Simple CLI user input library + +## Example +```haskell +import Data.Functor ((<&>)) +import Data.Text (Text) +import Text.Parsec (char, digit, many1) +import Text.Regex.TDFA ((=~)) + +import System.Console.Ask (Ask, ask, askOptional, askOrElse, runAsk, defaultBehaviour) +import System.Console.Ask.Askable (Askable (fromText), fromParsec) + +data UserInformation = UserInformation + { name :: Text + , age :: Maybe Int + , birthday :: Date + , notificationPreference :: NotificationPreference + } deriving Show + +data NotificationPreference = NotificationPreference + { needNotifications :: Bool + , emailAddress :: Maybe EmailAddress + } deriving Show + +askUserInformation :: Ask UserInformation +askUserInformation = + UserInformation + <$> ask "What is your name?" + <*> askOptional "How old are you?" + <*> ask "When is your birthday?" + <*> askNotificationPreference + +askNotificationPreference :: Ask NotificationPreference +askNotificationPreference = do + needNotifications' <- askOrElse "Do you need our update notifications?" False + + emailAddress' <- + if needNotifications' + then Just <$> ask "What is your email address?" + else pure Nothing + + pure NotificationPreference + { needNotifications = needNotifications' + , emailAddress = emailAddress' + } + +newtype EmailAddress = EmailAddress Text deriving Show + +instance Askable EmailAddress where + fromText text = + if text =~ ("[a-zA-Z0-9+._-]+@[a-zA-Z-]+\\.[a-z]+" :: Text) + then Just (EmailAddress text) + else Nothing + +data Date = Date Int Int deriving Show + +instance Askable Date where + fromText = fromParsec $ do + day <- many1 digit <&> read + _ <- char '/' + month <- many1 digit <&> read + + pure (Date day month) + +main :: IO () +main = do + userInfo <- runAsk defaultBehaviour askUserInformation + + print userInfo +``` +``` +What is your name? +> Toma Sasaki + +How old are you? +> + +When is your birthday? +> 15/9 + +Do you need our update notifications? (Default: False) +> aye + +What is your email address? +> me@t-sasaki.net + +UserInformation + { name = "Toma Sasaki" + , age = Nothing + , birthday = Date 15 9 + , notificationPreference = + NotificationPreference + { needNotifications = True + , emailAddress = Just (EmailAddress "me@t-sasaki.net") + } + } +``` + +## Features +- Automatically parses input values to `Askable` instances. (See also: [Askable.hs](https://github.com/t-sasaki915/ConsoleAsk/blob/main/src/System/Console/Ask/Askable.hs)) +```haskell +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO + +import System.Console.Ask (Ask, ask, askOptional, askOrElse, defaultBehaviour, runAsk) + +main :: IO () +main = runAsk defaultBehaviour $ do + name <- ask "What is your name?" :: Ask Text + age <- askOptional "How old are you?" :: Ask (Maybe Int) + needNotifications <- askOrElse "Do you need notifications?" False :: Ask Bool + + liftIO $ do + TextIO.putStrLn ("Name: " <> name) + TextIO.putStrLn ("Age: " <> Text.show age) + TextIO.putStrLn ("Need notifications: " <> Text.show needNotifications) +``` +``` +What is your name? +> Toma Sasaki + +How old are you? +> a +Invalid input. + +How old are you? +> 18 + +Do you need notifications? (Default: False) +> no + +Name: "Toma Sasaki" +Age: 18 +Need notifications: False +``` + +- `Askable` supports both `Text -> Maybe a` and parsec. +```haskell +import Data.Functor ((<&>)) +import Data.Text (Text) +import Text.Parsec (char, digit, many1) +import Text.Regex.TDFA ((=~)) + +import System.Console.Ask.Askable (Askable (fromText), fromParsec) + +newtype EmailAddress = EmailAddress Text deriving Show + +instance Askable EmailAddress where + fromText text = + if text =~ ("[a-zA-Z0-9+._-]+@[a-zA-Z-]+\\.[a-z]+" :: Text) + then Just (EmailAddress text) + else Nothing + +data Date = Date Int Int deriving Show + +instance Askable Date where + fromText = fromParsec $ do + day <- many1 digit <&> read + _ <- char '/' + month <- many1 digit <&> read + + pure (Date day month) +``` + +- Custom prompt +```haskell +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO + +import System.Console.Ask (Ask, ask', askOptional', askOrElse', defaultBehaviour, runAsk) + +main :: IO () +main = runAsk defaultBehaviour $ do + name <- ask' "What is your name?" "Text> " :: Ask Text + age <- askOptional' "How old are you?" "Int > " :: Ask (Maybe Int) + needNotifications <- askOrElse' "Do you need notifications?" False "Y/N > " :: Ask Bool + + liftIO $ do + TextIO.putStrLn ("Name: " <> name) + TextIO.putStrLn ("Age: " <> Text.show age) + TextIO.putStrLn ("Need notifications: " <> Text.show needNotifications) +``` +``` +What is your name? +Text> Toma Sasaki + +How old are you? +Int > 18 + +Do you need notifications? (Default: False) +Y/N > True + +Name: "Toma Sasaki" +Age: 18 +Need notifications: True +``` + +- Customisable behaviour (See also: [Behaviour.hs](https://github.com/t-sasaki915/ConsoleAsk/blob/main/src/System/Console/Ask/Behaviour.hs)) +```haskell +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO + +import System.Console.Ask (Ask, ask, askOptional, askOrElse, defaultBehaviour, runAsk, withBehaviour) +import System.Console.Ask.Behaviour (DefaultValueStyle (..), defaultValueStyle, invalidInputErrorMsg, set) + +main :: IO () +main = runAsk defaultBehaviour $ do + let customBehaviour1 = set invalidInputErrorMsg (Just "??????") defaultBehaviour + customBehaviour2 = set defaultValueStyle OnNewline defaultBehaviour + + name <- ask "What is your name?" :: Ask Text + age <- withBehaviour customBehaviour1 (askOptional "How old are you?") :: Ask (Maybe Int) + needNotifications <- withBehaviour customBehaviour2 (askOrElse "Do you need notifications?" False) :: Ask Bool + + liftIO $ do + TextIO.putStrLn ("Name: " <> name) + TextIO.putStrLn ("Age: " <> Text.show age) + TextIO.putStrLn ("Need notifications: " <> Text.show needNotifications) +``` +``` +What is your name? +> Toma Sasaki + +How old are you? +> a +?????? + +How old are you? +> 18 + +Do you need notifications? +Default: False +> True + +Name: "Toma Sasaki" +Age: 18 +Need notifications: True +```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ src/System/Console/Ask.hs view
@@ -0,0 +1,174 @@+{-| +Module : System.Console.Ask +Copyright : 2025 Toma Sasaki +Licence : MIT +Maintainer : netst915@gmail.com +Portability : Portable + +@System.Console.Ask@ is the main module of ConsoleAsk. +-} + +module System.Console.Ask + ( AskT (..) + , Ask + , runAskT + , runAsk + , ask + , askOrElse + , askOptional + , ask' + , askOrElse' + , askOptional' + , defaultBehaviour + , withBehaviour + ) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Maybe (fromJust) +import System.Console.Ask.Askable (Askable) +import System.Console.Ask.Behaviour (Behaviour, defaultBehaviour) +import System.Console.Ask.Internal (Prompt, Question, ask_) + +-- | 'AskT' is a kind of @MonadIO@ with 'Behaviour' inside. +-- +newtype AskT m a = AskT (Behaviour -> m a) + +-- | 'runAskT' unwraps an 'AskT' monad. +-- +-- @ +-- askQuestion :: MonadIO m => 'AskT' m Text +-- askQuestion = 'ask' \"Question1\" +-- +-- askQuestionMonadIO :: MonadIO m => m Text +-- askQuestionMonadIO = 'runAskT' 'defaultBehaviour' askQuestion +-- @ +-- +runAskT :: Behaviour -> AskT m a -> m a +runAskT behaviour (AskT run) = run behaviour + +-- | 'Ask' is the same as 'AskT', but @m@ is fixed to @IO@. +-- +type Ask = AskT IO + +-- | 'runAsk' is the same as 'runAskT', but @m@ is fixed to @IO@. +-- +runAsk :: Behaviour -> Ask a -> IO a +runAsk = runAskT + +instance Functor m => Functor (AskT m) where + fmap f (AskT run) = AskT (fmap f . run) + +instance Monad m => Applicative (AskT m) where + pure = AskT . const . pure + + (AskT runF) <*> (AskT runA) = AskT $ \behaviour -> do + f <- runF behaviour + a <- runA behaviour + pure (f a) + +instance Monad m => Monad (AskT m) where + (AskT runA) >>= f = AskT $ \behaviour -> do + a <- runA behaviour + runAskT behaviour (f a) + +instance MonadIO m => MonadIO (AskT m) where + liftIO = AskT . const . liftIO + +-- | 'ask'' is the same as 'ask', but you can specify the prompt. +-- +-- >>> ask' "What is your name?" "Text> " :: Ask Text +-- What is your name? +-- Text> +-- +ask' :: (MonadIO m, Askable a) => Question -> Prompt -> AskT m a +ask' question prompt = + fromJust <$> AskT (liftIO . ask_ True question prompt Nothing) + +-- | 'askOrElse'' is the same as 'askOrElse', but you can specify the prompt. +-- +-- >>> askOrElse' "Do you need notifications?" False "Y/N> " :: Ask Bool +-- Do you need notifications? (Default: False) +-- Y/N> +-- +askOrElse' :: (MonadIO m, Askable a) => Question -> a -> Prompt -> AskT m a +askOrElse' question defaultVal prompt = + fromJust <$> AskT (liftIO . ask_ True question prompt (Just defaultVal)) + +-- | 'askOptional'' is the same as 'askOptional', but you can specify the prompt. +-- +-- >>> askOptional' "How old are you?" "Int> " :: Ask (Maybe Int) +-- How old are you? +-- Int> +-- +askOptional' :: (MonadIO m, Askable a) => Question -> Prompt -> AskT m (Maybe a) +askOptional' question prompt = + AskT (liftIO . ask_ False question prompt Nothing) + +-- | 'ask' asks user a mandatory question. +-- +-- >>> ask "What is your name?" :: Ask Text +-- +-- @ +-- What is your name? +-- > +-- This question is mandatory. +-- +-- What is your name? +-- > +-- @ +-- +ask :: (MonadIO m, Askable a) => Question -> AskT m a +ask question = ask' question "> " + +-- | 'askOrElse' asks user a mandatory question with a default value. +-- +-- >>> askOrElse "Do you need notifications?" False :: Ask Bool +-- Do you need notifications? (Default: False) +-- > +-- +askOrElse :: (MonadIO m, Askable a) => Question -> a -> AskT m a +askOrElse question defaultVal = askOrElse' question defaultVal "> " + +-- | 'askOptional' asks user an optional question. +-- +-- >>> askOptional "How old are you?" :: Ask (Maybe Int) +-- How old are you? +-- > +-- +askOptional :: (MonadIO m, Askable a) => Question -> AskT m (Maybe a) +askOptional question = askOptional' question "> " + +-- | 'withBehaviour' attaches a behaviour to 'AskT'. +-- The behaviour specified to 'runAskT' will be ignored. +-- +-- @ +-- data Directories = Directories +-- { windowsRootDir :: FilePath +-- , installDir :: FilePath +-- } deriving Show +-- +-- askDirectories :: 'Ask' Directories +-- askDirectories = do +-- let customBehaviour = 'System.Console.Ask.Behaviour.set' 'System.Console.Ask.Behaviour.defaultValueStyle' 'System.Console.Ask.Behaviour.OnNewline' 'defaultBehaviour' +-- +-- Directories +-- \<$\> 'askOrElse' \"Windows root directory?\" \"C:\\\\Windows\\\\" +-- \<*\> 'withBehaviour' customBehaviour ('askOrElse' \"Install directory?\" \"C:\\\\Program Files\\\\net\\\\t_sasaki\\\\useful_tool\\\\\") +-- +-- main :: IO () +-- main = do +-- dirs <- 'runAsk' 'defaultBehaviour' askDirectories +-- print dirs +-- @ +-- +-- @ +-- Windows root directory? (Default: \"C:\\Windows\\") +-- > +-- +-- Install directory? +-- Default: \"C:\\Program Files\\net\\t_sasaki\\useful_tool\\\" +-- > +-- @ +-- +withBehaviour :: Behaviour -> AskT m a -> AskT m a +withBehaviour behaviour = AskT . const . runAskT behaviour
+ src/System/Console/Ask/Askable.hs view
@@ -0,0 +1,86 @@+{-| +Module : System.Console.Ask.Askable +Copyright : 2025 Toma Sasaki +Licence : MIT +Maintainer : netst915@gmail.com +Portability : Portable + +@System.Console.Ask.Askable@ provides 'Askable' and 'fromParsec'. +You should import this module if you want to do 'System.Console.Ask.ask' for your original data types. +-} + +{-# LANGUAGE FlexibleInstances #-} + +module System.Console.Ask.Askable + ( Askable (..) + , fromParsec + ) where + +import Data.Text (Text) +import qualified Data.Text as Text +import Text.Parsec (Parsec, anyChar, eof, parse) +import Text.Read (readMaybe) +import Text.Regex.TDFA ((=~)) + +-- | 'Askable' provides 'fromText'. +-- Instances of 'Askable' must derive @Show@. +-- This typeclass is used when 'System.Console.Ask.ask', 'System.Console.Ask.askOptional' and 'System.Console.Ask.askOrElse' try to parse user input. +-- Implementing 'fromText' is required. +-- +class Show a => Askable a where + -- | 'fromText' converts @Text@ into a certain type. + -- Returning @Nothing@ makes the conversion failed. + -- + -- @ + -- data EmailAddress = EmailAddress Text deriving Show + -- + -- instance 'Askable' EmailAddress where + -- 'fromText' text = + -- if text =~ ("[a-zA-Z0-9+._-]+@[a-zA-Z-]+\\.[a-z]+" :: Text) + -- then Just (EmailAddress text) + -- else Nothing + -- @ + -- + fromText :: Text -> Maybe a + +-- | 'fromParsec' converts @Parsec Text () a@ into @Text -> Maybe a@. +-- It is supposed to be used with 'fromText'. +-- +-- @ +-- instance 'Askable' 'Char' where +-- 'fromText' = 'fromParsec' (anyChar <* eof) +-- @ +-- +fromParsec :: Parsec Text () a -> Text -> Maybe a +fromParsec parser = either (const Nothing) Just . parse parser "" + +instance Askable Text where + fromText = Just + +instance Askable String where + fromText = Just . Text.unpack + +instance Askable Int where + fromText = readMaybe . Text.unpack + +instance Askable Integer where + fromText = readMaybe . Text.unpack + +instance Askable Float where + fromText = readMaybe . Text.unpack + +instance Askable Double where + fromText = readMaybe . Text.unpack + +instance Askable Char where + fromText = fromParsec (anyChar <* eof) + +instance Askable Bool where + fromText text = + let lower = Text.toLower text in + if lower =~ ("^(t(rue)?|y(es|eah)?|aye)$" :: Text) + then Just True + else + if lower =~ ("^(f(alse)?|n(o|ae)?)$" :: Text) + then Just False + else Nothing
+ src/System/Console/Ask/Behaviour.hs view
@@ -0,0 +1,155 @@+{-| +Module : System.Console.Ask.Behaviour +Copyright : 2025 Toma Sasaki +Licence : MIT +Maintainer : netst915@gmail.com +Portability : Portable + +@System.Console.Ask.Behaviour@ provides 'Behaviour', its fields and 'set'. +You should import this module if you want to customise the behaviour of ConsoleAsk. +-} + +{-# LANGUAGE TemplateHaskell #-} + +module System.Console.Ask.Behaviour + ( NewlineTiming (..) + , DefaultValueStyle (..) + , Behaviour (..) + , defaultBehaviour + , newlineTiming + , defaultValueStyle + , defaultValueViewer + , mandatoryQuestionErrorMsg + , invalidInputErrorMsg + , set + ) where + +import Control.Lens (makeLenses, set) +import Data.Text (Text) + +-- | 'NewlineTiming' is the timing of ConsoleAsk outputs newline between questions. +-- +-- 'AfterPrompt' +-- +-- @ +-- Question1? +-- > ABC +-- +-- Question2? +-- > DEF +-- +-- @ +-- +-- 'BeforePrompt' +-- +-- @ +-- +-- +-- Question1? +-- > ABC +-- +-- Question2? +-- > DEF +-- @ +-- +-- 'None' +-- +-- @ +-- Question1? +-- > ABC +-- Question2? +-- > DEF +-- @ +-- +data NewlineTiming = AfterPrompt | BeforePrompt | None deriving Eq + +-- | 'DefaultValueStyle' is the setting of where the default value is displayed. +-- +-- 'OnQuestionLine' +-- +-- @ +-- Question1? (Default: \"ABC\") +-- > +-- @ +-- +-- 'OnNewline' +-- +-- @ +-- Question1? +-- Default: \"ABC\" +-- > +-- @ +-- +data DefaultValueStyle = OnQuestionLine | OnNewline deriving Eq + +-- | 'Behaviour' specifies ConsoleAsk behaviours. +-- 'set' is useful for editing already existing 'Behaviour' definitions field-by-field. +-- +-- @ +-- let customBehaviour = 'set' 'System.Console.Ask.Behaviour.newlineTiming' 'BeforePrompt' 'System.Console.Ask.Behaviour.defaultBehaviour' +-- @ +-- +data Behaviour = Behaviour + { -- | Please see 'NewlineTiming'. + -- + _newlineTiming :: NewlineTiming + -- | Please see 'DefaultValueStyle'. + -- + , _defaultValueStyle :: DefaultValueStyle + -- | '_defaultValueViewer' is the message displayed if the question has a default value. + -- It is a function whose argument is the default value of the question. + -- + -- Assume @'_defaultValueViewer' = ("Default Value is: " <>)@, + -- + -- >>> askOrElse "Do you need notifications?" False :: Ask Bool + -- Do you need notifications? (Default Value is: False) + -- > + -- + , _defaultValueViewer :: Text -> Text + -- | '_mandatoryQuestionErrorMsg' is the message displayed if the user has not answered the question even though it is mandatory. + -- If @Nothing@, ConsoleAsk will not display the message. + -- + -- Assume @'_mandatoryQuestionErrorMsg' = Just "PLEASE ANSWER THIS QUESTION!!!"@, + -- + -- >>> ask "What is your name?" :: Ask Text + -- What is your name? + -- > + -- PLEASE ANSWER THIS QUESTION!!! + -- + , _mandatoryQuestionErrorMsg :: Maybe Text + -- | '_invalidInputErrorMsg' is the message displayed if the user enters an invalid value. + -- If @Nothing@, ConsoleAsk will not display the message. + -- + -- Assume @'_invalidInputErrorMsg' = Just "????????"@, + -- + -- >>> ask "How old are you?" :: Ask Int + -- How old are you? + -- > abc + -- ???????? + -- + , _invalidInputErrorMsg :: Maybe Text + } + +makeLenses ''Behaviour + +-- | 'defaultBehaviour' is the default definition of ConsoleAsk behaviour. +-- +-- @ +-- 'defaultBehaviour' = 'Behaviour' +-- { '_newlineTiming' = 'AfterPrompt' +-- , '_defaultValueStyle' = 'OnQuestionLine' +-- , '_defaultValueViewer' = (\"Default\" <>) +-- , '_mandatoryQuestionErrorMsg' = Just \"This question is mandatory.\" +-- , '_invalidInputErrorMsg' = Just \"Invalid input.\" +-- } +-- @ +-- +defaultBehaviour :: Behaviour +defaultBehaviour = + Behaviour + { _newlineTiming = AfterPrompt + , _defaultValueStyle = OnQuestionLine + , _defaultValueViewer = ("Default: " <>) + , _mandatoryQuestionErrorMsg = Just "This question is mandatory." + , _invalidInputErrorMsg = Just "Invalid input." + }
+ src/System/Console/Ask/Internal.hs view
@@ -0,0 +1,98 @@+{-| +Module : System.Console.Ask.Internal +Copyright : 2025 Toma Sasaki +Licence : MIT +Maintainer : netst915@gmail.com +Portability : Portable + +@System.Console.Ask.Internal@ is an internal module. +You should not import this module. +-} + +{-# LANGUAGE ScopedTypeVariables #-} + +module System.Console.Ask.Internal + ( Question + , Prompt + , readLineWithPrompt + , ask_ + ) where + +import Control.Exception (IOException, try) +import Control.Monad (when) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO +import System.Console.Ask.Askable (Askable (..)) +import System.Console.Ask.Behaviour +import System.IO (hFlush, stdout) + +readLineWithPrompt :: Text -> IO (Maybe Text) +readLineWithPrompt prompt = do + TextIO.putStr prompt + hFlush stdout + + result <- + try $ TextIO.getLine >>= \case + "" -> pure Nothing + x -> pure (Just x) + + case result of + Right result' -> pure result' + Left (_ :: IOException) -> pure Nothing + + +type Question = Text +type Prompt = Text + +ask_ :: Askable a => Bool -> Question -> Prompt -> Maybe a -> Behaviour -> IO (Maybe a) +ask_ isMandatory question prompt defaultVal behaviour = do + when (_newlineTiming behaviour == BeforePrompt) + putNewLine + + case defaultVal of + Nothing -> + TextIO.putStrLn question + + Just defaultVal' -> + let defaultValMessage = _defaultValueViewer behaviour (Text.show defaultVal') in + case _defaultValueStyle behaviour of + OnQuestionLine -> + TextIO.putStrLn (question <> " (" <> defaultValMessage <> ")") + + OnNewline -> + TextIO.putStrLn question >> + TextIO.putStrLn defaultValMessage + + result <- + readLineWithPrompt prompt >>= \case + Nothing -> + case defaultVal of + Just defaultVal' -> pure (Just (Just defaultVal')) + Nothing | not isMandatory -> pure (Just Nothing) + Nothing -> do + whenJust (_mandatoryQuestionErrorMsg behaviour) + TextIO.putStrLn + + pure Nothing + Just x -> + case fromText x of + Just x' -> pure (Just (Just x')) + Nothing -> do + whenJust (_invalidInputErrorMsg behaviour) + TextIO.putStrLn + + pure Nothing + + when (_newlineTiming behaviour == AfterPrompt) + putNewLine + + case result of + Just result' -> pure result' + Nothing -> ask_ isMandatory question prompt defaultVal behaviour + + where + whenJust Nothing _ = pure () + whenJust (Just x) f = f x + + putNewLine = TextIO.putStrLn ""