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
  31   putStr xs
  32   response <- readerThing
  33   case validate response of
  34     Left error -> (putStrLn $ "\x1b[31m" +++ error +++ "\x1b[0m") >> prompt xs readerThing validate
  35     Right result -> return result
  36
  37 subPrompt :: IO a -> IO b -> (a -> Bool) -> IO (Maybe (a, b))
  38 subPrompt p1 p2 showNext = do
  39   p1 >>= (\x -> if showNext x then p2 >>= (return . Just . (x, )) else return Nothing)
  40
  41 textPrompt :: Text -> IO Text
  42 textPrompt xs = prompt xs getLine  Right
  43
  44 nonEmptyTextPrompt :: Text -> IO Text
  45 nonEmptyTextPrompt xs = prompt xs getLine cannotBeEmpty
  46
  47 yornPrompt :: Text -> IO Bool
  48 yornPrompt xs = do
  49   let v x = case (toLower x) of
  50                    "y" -> Right True
  51                    "n" -> Right False
  52                    _ -> Left "Please answer with y or n"
  53   prompt (xs +++ " (y/n):") getOneText v
  54
  55 listPrompt :: Text -> [Text] -> IO Text
  56 listPrompt xs options = do
  57   putStrLn $ xs +++ "\n\n" +++ cue
  58   prompt ("Make your selection " +++ validRange +++ ": ") getOneText validator where
  59     cue = unlines $ map (\x -> (pack . show $ fst x) +++ ") " +++ snd x) themeList
  60     validator x = if choice > 0 && choice <= upper
  61       then Right (fromJust (lookup choice themeList))
  62       else Left $ "\nPick a valid number " +++ validRange where
  63         choice = read . unpack $ x
  64     themeList = (zip [1..] options)
  65     validRange = "(1-" +++ (pack . show $ upper) +++ ")"
  66     upper = length themeList
  67
  68 dependantTextPrompt :: Text -> Text -> IO (Maybe (Text, Text))
  69 dependantTextPrompt xs1 xs2 = subPrompt (textPrompt xs1) (nonEmptyTextPrompt xs2) (not . null)
  70
  71 dependantYornTextPrompt :: Text -> Text -> IO (Maybe (Bool, Text))
  72 dependantYornTextPrompt xs1 xs2 = subPrompt (yornPrompt xs1) (nonEmptyTextPrompt xs2) (id)
  73
  74 entryPrompt = subPrompt entryNamePrompt videoPrompt (not . null) where
  75   entryNamePrompt = nonEmptyTextPrompt "Name for this entry: "
  76   videoPrompt = dependantTextPrompt "Video ID (leave blank to skip): " "Local video filename: "
  77
  78 initPrompt :: [Text] -> IO [(String, Text)]
  79 initPrompt themes = fmap (zip ["projectName", "description", "theme"]) $ sequence prompts where
  80   prompts = [
  81     nonEmptyTextPrompt "Enter a name for your project: ",
  82     nonEmptyTextPrompt "Enter a short description for your project: ",
  83     listPrompt "Which theme would you like to use?" themes
  84             ]