src/Prompts.hs

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