-{-# 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
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
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 $ [
{-# 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)
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
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
-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
"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
+ ]
projects / xyz.git / commitdiff
