src/Prompts.hs

   1 module Prompts (textPrompt, yornPrompt, dependantTextPrompt) where
   2
   3 import Prelude hiding (getLine, null, putStrLn)
   4 import Control.Monad (join)
   5 import Data.Text (Text, append, toLower, null, pack)
   6 import Data.Text.IO (getLine, putStrLn)
   7
   8 cannotBeEmpty :: Text -> Either Text Text
   9 cannotBeEmpty xs = case null xs of
  10   True -> Left "Value cannot be empty"
  11   False -> Right xs
  12
  13 prompt :: Text -> (Text -> Either Text a) -> IO a
  14 prompt xs validate = do
  15   putStrLn xs
  16   response <- getLine
  17   case validate response of
  18     Left error -> putStrLn error >> prompt xs validate
  19     Right result -> return result
  20
  21 subPrompt :: Text -> (Text -> Bool) -> IO a -> IO (Maybe (Text, a))
  22 subPrompt xs showNext p = do
  23   let v x = case showNext x of
  24         True -> Right $ p >>= return . Just . (x ,)
  25         False -> Right $ return Nothing
  26
  27   join $ prompt xs v
  28
  29 textPrompt :: Text -> IO Text
  30 textPrompt xs = prompt xs cannotBeEmpty
  31
  32 dependantTextPrompt :: Text -> Text -> IO (Maybe (Text, Text))
  33 dependantTextPrompt xs1 xs2 = subPrompt xs1 (not . null) $ prompt xs2 cannotBeEmpty
  34
  35 yornPrompt :: Text -> IO Bool
  36 yornPrompt xs = do
  37   let v x = case (toLower x) of
  38                    "y" -> Right True
  39                    "n" -> Right False
  40                    _ -> Left "Please answer with y or n"
  41   prompt (xs `append` " (y/n):") v