src/Prompts.hs

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