src/Prompts.hs

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