src/Prompts.hs

   1 module Prompts (
   2   textPrompt,
   3   nonEmptyTextPrompt,
   4   yornPrompt,
   5   subPrompt,
   6   entryPrompt,
   7   initPrompt
   8   ) where
   9
  10 import Util
  11 import Prelude hiding (getLine, null, putStrLn, putStr, unlines)
  12 import System.IO hiding (putStr, putStrLn, getLine)
  13 import Control.Monad (join)
  14 import Data.Text (Text, unlines, append, toLower, null, pack, unpack)
  15 import Data.Text.IO (getLine, putStrLn, putStr, getLine)
  16 import Data.Maybe
  17
  18 getOneText :: IO Text
  19 getOneText = getChar >>= return . pack . return
  20
  21 cannotBeEmpty :: Text -> Either Text Text
  22 cannotBeEmpty xs = case null xs of
  23   True -> Left "Value cannot be empty"
  24   False -> Right xs
  25
  26 prompt :: Text -> IO a -> (a -> Either Text b) -> IO b
  27 prompt xs readerThing validate = do
  28   hSetBuffering stdout $ BlockBuffering $ Just 1;
  29   hSetBuffering stdin NoBuffering
  30   putStr xs
  31   response <- readerThing
  32   case validate response of
  33     Left error -> (putStrLn $ "\x1b[31m" +++ error +++ "\x1b[0m") >> prompt xs readerThing validate
  34     Right result -> return result
  35
  36 subPrompt :: IO a -> IO b -> (a -> Bool) -> IO (Maybe (a, b))
  37 subPrompt p1 p2 showNext = do
  38   p1 >>= (\x -> if showNext x then p2 >>= (\y -> return $ Just (x,y)) else return Nothing)
  39
  40 textPrompt :: Text -> IO Text
  41 textPrompt xs = prompt xs getLine  Right
  42
  43 nonEmptyTextPrompt :: Text -> IO Text
  44 nonEmptyTextPrompt xs = prompt xs getLine cannotBeEmpty
  45
  46 yornPrompt :: Text -> IO Bool
  47 yornPrompt xs = do
  48   let v x = case (toLower x) of
  49                    "y" -> Right True
  50                    "n" -> Right False
  51                    _ -> Left "Please answer with y or n"
  52   prompt (xs +++ " (y/n):") getOneText v
  53
  54 listPrompt :: Text -> [Text] -> IO Text
  55 listPrompt xs options = do
  56   putStrLn $ xs +++ "\n\n" +++ cue
  57   prompt ("Make your selection " +++ validRange +++ ": ") getOneText validator where
  58     cue = unlines $ map (\x -> (pack . show $ fst x) +++ ") " +++ snd x) themeList
  59     validator x = if choice > 0 && choice <= upper
  60       then Right (fromJust (lookup choice themeList))
  61       else Left $ "\nPick a valid number " +++ validRange where
  62         choice = read . unpack $ x
  63     themeList = (zip [1..] options)
  64     validRange = "(1-" +++ (pack . show $ upper) +++ ")"
  65     upper = length themeList
  66
  67 dependantTextPrompt :: Text -> Text -> IO (Maybe (Text, Text))
  68 dependantTextPrompt xs1 xs2 = subPrompt (textPrompt xs1) (nonEmptyTextPrompt xs2) (not . null)
  69
  70 dependantYornTextPrompt :: Text -> Text -> IO (Maybe (Bool, Text))
  71 dependantYornTextPrompt xs1 xs2 = subPrompt (yornPrompt xs1) (nonEmptyTextPrompt xs2) (id)
  72
  73 entryPrompt = subPrompt entryNamePrompt videoPrompt (not . null) where
  74   entryNamePrompt = nonEmptyTextPrompt "Name for this entry: "
  75   videoPrompt = dependantTextPrompt "Video ID (leave blank to skip): " "Local video filename: "
  76
  77 initPrompt :: [Text] -> IO [(String, Text)]
  78 initPrompt themes = fmap (zip ["projectName", "description", "theme"]) $ sequence prompts where
  79   prompts = [
  80     nonEmptyTextPrompt "Enter a name for your project: ",
  81     nonEmptyTextPrompt "Enter a short description for your project: ",
  82     listPrompt "Which theme would you like to use?" themes
  83             ]