From: Cameron Ball Date: Thu, 20 Jun 2019 06:54:52 +0000 (+0800) Subject: More refactoring. Way nicer prompts X-Git-Url: http://cameron1729.xyz/?p=xyz.git;a=commitdiff_plain;h=7cda95f607f4281541acb4e5bd1daa40919236aa More refactoring. Way nicer prompts --- diff --git a/app/Main.hs b/app/Main.hs index 3838536..4ddb724 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,29 +1,29 @@ -{-# LANGUAGE OverloadedStrings #-} - module Main where +import Data.List (intercalate) +import Data.String hiding (unlines) +import Data.Text hiding (map, init, length, splitAt) +import Data.Text.IO (putStrLn, putStr) +import Data.Text.Lazy (toStrict) +import Data.Text.Template +import Data.Time.Clock.POSIX import Lib +import Prelude hiding (putStrLn, putStr, init, unlines) import Prompts +import System.Directory +import System.Directory (doesFileExist) import System.Environment import System.Exit -import System.Directory -import Prelude hiding (init) -import Data.List (intercalate) +import System.File.Tree hiding (map, mapM, mapM_) +import System.Process import Text.JSON import Text.JSON.Generic -import Data.Text hiding (intercalate, unlines, init, length, splitAt) -import Data.Time.Clock.POSIX -import System.File.Tree hiding (mapM, mapM_) -import System.Directory (doesFileExist) -import System.Process -import Data.Text.Template -import Data.String -import Data.Text.Lazy (toStrict) +import Util main :: IO () main = getArgs >>= parse -continueIfValidProject :: IO() -> IO () +continueIfValidProject :: IO () -> IO () continueIfValidProject nextfn = do jsonExists <- doesFileExist "xyz.json" if jsonExists @@ -35,17 +35,12 @@ init = do dirExists <- doesFileExist "xyz.json" if dirExists then putStrLn "Project already initialised" - else do createDirectory "entries" - home <- getHomeDirectory - templates <- allFilesIn $ home ++ "/.xyz/themes" - putStrLn "Enter a name for your project:" - projectName <- getLine - putStrLn "Enter short description for your project:" - projectDescription <- getLine - putStrLn $ "Which theme would you like to use?\n\n" ++ (ununlines templates) - theme <- getLine - writeFile "xyz.json" . encode . toJSObject $ [("name", projectName), ("description", projectDescription), ("theme", theme)] - putStrLn "Initialised empty project" + else do home <- getHomeDirectory + themes <- allFilesIn $ home ++ "/.xyz/themes" + projectSpec <- initPrompt (map pack themes) + createDirectory "entries" + writeFile "xyz.json" . encode . toJSObject $ projectSpec + putStrLn "\n\nInitialised empty project" build :: IO () build = do @@ -55,43 +50,48 @@ build = do files <- allFilesIn "entries" home <- getHomeDirectory config <- readFile "xyz.json" - someFunc (decodeJSON config :: ProjectConfig) files >> putStrLn "Build successful" + writeOutProject (decodeJSON config :: ProjectConfig) files >> putStrLn "Build successful" else putStrLn "This does not appear to be a valid project directory" -ununlines :: [String] -> String -ununlines = intercalate "\n\n" - entry :: IO () entry = do homeDir <- getHomeDirectory - entryName <- textPrompt "Name for this entry:" - video <- (fmap . fmap) (\(a,b) -> (a, b ++ ".webm"::String)) $ dependantPrompt "Video ID (leave blank to skip):" "Local video filename:" - entryNum <- fmap ((+1) . length) $ allFilesIn "entries" - stamp <- fmap round getPOSIXTime + entrySpec <- entryPrompt + entryNum <- fmap (show . (+1) . length) $ allFilesIn "entries" + stamp <- fmap (show . round) getPOSIXTime videoTemplate <- readFile (homeDir ++ "/.xyz/entry-video.txt") >>= return . template . fromString normalTemplate <- readFile (homeDir ++ "/.xyz/entry.txt") >>= return . template . fromString - let filename = "entries/" ++ (show entryNum) ++ "-" ++ (unpack . (toLower. replace " " "-") $ pack entryName) ++ ".txt" + --let filename = "entries/" ++ (show entryNum) ++ "-" ++ (unpack . (toLower. replace " " "-") $ pack entryName) ++ ".txt" + + case entrySpec of + Just (title, videoSpec) -> do + let filename = "entries/" ++ entryNum ++ "-" ++ (unpack . slugify $ title) ++ ".txt" + case videoSpec of + Just (videoId, videoFilename) -> putStrLn "oh jimmy" + Nothing -> putStrLn "oh bimmy" + - case video of - Just (videoId, videoFilename) -> do - let tmplContext = context $ [("timestamp", fromString . show $ (stamp::Integer)), ("title", pack entryName), ("videofilename", pack $ videoFilename), ("videoid", pack videoId)] - let rawEntry = unpack . toStrict $ render videoTemplate tmplContext - writeFile filename rawEntry - callCommand $ "youtube-dl -f 'webm[height<1080]+bestaudio' \"https://www.youtube.com/watch?v=" ++ videoId ++ "\" -o 'build/videos/" ++ videoFilename ++ "'" - Nothing -> do - let tmplContext = context $ [("timestamp", fromString . show $ (stamp::Integer)), ("title", pack entryName)] - let rawEntry = unpack . toStrict $ render normalTemplate tmplContext - writeFile filename rawEntry + putStrLn "lel" + -- case video of + -- Just (videoId, videoFilename) -> do + -- let tmplContext = context $ [("timestamp", fromString . show $ (stamp::Integer)), ("title", pack entryName), ("videofilename", pack $ videoFilename), ("videoid", pack videoId)] + -- let rawEntry = unpack . toStrict $ render videoTemplate tmplContext + -- writeFile filename rawEntry + -- callCommand $ "youtube-dl -f 'webm[height<1080]+bestaudio' \"https://www.youtube.com/watch?v=" ++ videoId ++ "\" -o 'build/videos/" ++ videoFilename ++ "'" + -- Nothing -> do + -- let tmplContext = context $ [("timestamp", fromString . show $ (stamp::Integer)), ("title", pack entryName)] + -- let rawEntry = unpack . toStrict $ render normalTemplate tmplContext + -- writeFile filename rawEntry - (putStrLn $ ("Created " ++ filename)) >> build + -- (putStrLn $ ("Created " ++ filename)) >> build - push <- yornPrompt "Do you want to push this entry?" + -- push <- yornPrompt "Do you want to push this entry?" - case push of - True -> do callCommand $ "git add . && git commit -m \"" ++ entryName ++ "\" && git push" - False -> return () + -- case push of + -- True -> do callCommand $ "git add . && git commit -m \"" ++ entryName ++ "\" && git push" + -- False -> return () - putStrLn "Thanks for using xyz!" + -- putStrLn "Thanks for using xyz!" usage :: IO () usage = putStr . ununlines $ [ diff --git a/src/Lib.hs b/src/Lib.hs index 9cad63d..b48ddf8 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -2,10 +2,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} -module Lib - ( someFunc, EntryList, allFilesIn, ProjectConfig, context - ) where +module Lib where +import Util import Data.Function (on) import Data.List (sort, sortBy, groupBy) import Data.Ord (comparing) @@ -100,9 +99,6 @@ entryListToIndex el = unorderedList Nothing $ map (\(year, monthList) -> unorder i2t :: Integer -> Text i2t = (fromString . show) -slugify = toLower. replace " " "-" -urlify = slugify . replace "?" "" - timeStampToDateString = fromString . formatTime defaultTimeLocale "%d %B %Y" . utcToLocalTime (hoursToTimeZone 8) entryToMarkup entry template = toStrict $ render template tmplContext @@ -130,9 +126,7 @@ rawTextToEntry rawEntry = BlogEntry (posixSecondsToUTCTime (fromInteger (read (u meta = splitOn "::" (fileLines !! 0) fileLines = lines rawEntry -allFilesIn dir = filter (/= "..")<$>(filter(/= "."))<$>(getDirectoryContents dir) - -someFunc projectConfig files = do +writeOutProject projectConfig files = do files <- fmap (reverse . sort) $ allFilesIn "entries" rawEntries <- mapM (\x -> (readFile ("entries/" ++ x)) >>= (\y -> (return . fromString) y)) files entryList <- mapM (\raw -> return $ rawTextToEntry raw) rawEntries diff --git a/src/Prompts.hs b/src/Prompts.hs index e70fcd7..240c1cf 100644 --- 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 + ] diff --git a/src/Util.hs b/src/Util.hs index 5071998..d1c5834 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -1,6 +1,14 @@ module Util where -import Data.Text +import Data.Text hiding (filter) +import System.Directory ununlines :: [Text] -> Text ununlines = intercalate "\n\n" + +slugify = toLower. replace " " "-" +urlify = slugify . replace "?" "" + +allFilesIn dir = filter (/= "..")<$>(filter(/= "."))<$>(getDirectoryContents dir) + +(+++) = append