More refactoring. Way nicer prompts

[xyz.git] / src / Prompts.hs

diff --git a/src/Prompts.hs b/src/Prompts.hs
index e70fcd7..240c1cf 100644 (file)
--- a/src/Prompts.hs
+++ b/src/Prompts.hs
@@ -1,36 +1,47 @@
-module Prompts (textPrompt, yornPrompt, dependantTextPrompt) where
+module Prompts (
+  textPrompt,
+  nonEmptyTextPrompt,
+  yornPrompt,
+  subPrompt,
+  entryPrompt,
+  initPrompt
+  ) where
 
-import Prelude hiding (getLine, null, putStrLn)
+import Util
+import Prelude hiding (getLine, null, putStrLn, putStr, unlines)
+import System.IO hiding (putStr, putStrLn, getLine)
 import Control.Monad (join)
-import Data.Text (Text, append, toLower, null, pack)
-import Data.Text.IO (getLine, putStrLn)
+import Data.Text (Text, unlines, append, toLower, null, pack, unpack)
+import Data.Text.IO (getLine, putStrLn, putStr, getLine)
+import Data.Maybe
+
+getOneText :: IO Text
+getOneText = getChar >>= return . pack . return
 
 cannotBeEmpty :: Text -> Either Text Text
 cannotBeEmpty xs = case null xs of
   True -> Left "Value cannot be empty"
   False -> Right xs
 
-prompt :: Text -> (Text -> Either Text a) -> IO a
-prompt xs validate = do
-  putStrLn xs
-  response <- getLine
+prompt :: Text -> IO a -> (a -> Either Text b) -> IO b
+prompt xs readerThing validate = do
+  hSetBuffering stdout $ BlockBuffering $ Just 1;
+  hSetBuffering stdin NoBuffering
+  putStr xs
+  response <- readerThing
   case validate response of
-    Left error -> putStrLn error >> prompt xs validate
+    Left error -> (putStrLn $ "\x1b[31m" +++ error +++ "\x1b[0m") >> prompt xs readerThing validate
     Right result -> return result
 
-subPrompt :: Text -> (Text -> Bool) -> IO a -> IO (Maybe (Text, a))
-subPrompt xs showNext p = do
-  let v x = case showNext x of
-        True -> Right $ p >>= return . Just . (x ,)
-        False -> Right $ return Nothing
-
-  join $ prompt xs v
+subPrompt :: IO a -> IO b -> (a -> Bool) -> IO (Maybe (a, b))
+subPrompt p1 p2 showNext = do
+  p1 >>= (\x -> if showNext x then p2 >>= (\y -> return $ Just (x,y)) else return Nothing)
 
 textPrompt :: Text -> IO Text
-textPrompt xs = prompt xs cannotBeEmpty
+textPrompt xs = prompt xs getLine  Right
 
-dependantTextPrompt :: Text -> Text -> IO (Maybe (Text, Text))
-dependantTextPrompt xs1 xs2 = subPrompt xs1 (not . null) $ prompt xs2 cannotBeEmpty
+nonEmptyTextPrompt :: Text -> IO Text
+nonEmptyTextPrompt xs = prompt xs getLine cannotBeEmpty
 
 yornPrompt :: Text -> IO Bool
 yornPrompt xs = do
@@ -38,4 +49,35 @@ yornPrompt xs = do
                    "y" -> Right True
                    "n" -> Right False
                    _ -> Left "Please answer with y or n"
-  prompt (xs `append` " (y/n):") v
+  prompt (xs +++ " (y/n):") getOneText v
+
+listPrompt :: Text -> [Text] -> IO Text
+listPrompt xs options = do
+  putStrLn $ xs +++ "\n\n" +++ cue
+  prompt ("Make your selection " +++ validRange +++ ": ") getOneText validator where
+    cue = unlines $ map (\x -> (pack . show $ fst x) +++ ") " +++ snd x) themeList
+    validator x = if choice > 0 && choice <= upper
+      then Right (fromJust (lookup choice themeList))
+      else Left $ "\nPick a valid number " +++ validRange where
+        choice = read . unpack $ x
+    themeList = (zip [1..] options)
+    validRange = "(1-" +++ (pack . show $ upper) +++ ")"
+    upper = length themeList
+
+dependantTextPrompt :: Text -> Text -> IO (Maybe (Text, Text))
+dependantTextPrompt xs1 xs2 = subPrompt (textPrompt xs1) (nonEmptyTextPrompt xs2) (not . null)
+
+dependantYornTextPrompt :: Text -> Text -> IO (Maybe (Bool, Text))
+dependantYornTextPrompt xs1 xs2 = subPrompt (yornPrompt xs1) (nonEmptyTextPrompt xs2) (id)
+
+entryPrompt = subPrompt entryNamePrompt videoPrompt (not . null) where
+  entryNamePrompt = nonEmptyTextPrompt "Name for this entry: "
+  videoPrompt = dependantTextPrompt "Video ID (leave blank to skip): " "Local video filename: "
+
+initPrompt :: [Text] -> IO [(String, Text)]
+initPrompt themes = fmap (zip ["projectName", "description", "theme"]) $ sequence prompts where
+  prompts = [
+    nonEmptyTextPrompt "Enter a name for your project: ",
+    nonEmptyTextPrompt "Enter a short description for your project: ",
+    listPrompt "Which theme would you like to use?" themes
+            ]