From: Cameron Ball Date: Thu, 25 Jul 2019 06:19:58 +0000 (+0800) Subject: Refactor: X-Git-Url: http://cameron1729.xyz/?p=xyz.git;a=commitdiff_plain;h=5d5c9a6617396b9a19bad40d925b13e33f143f1a Refactor: - Use aeson for JSON stuff - Create a config module with a notion of local, global, and project configs - Start working git in to the command flow more --- diff --git a/app/Main.hs b/app/Main.hs index 597bb89..9469690 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,14 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields #-} + module Main where -import Data.List (intercalate) +import Data.List (intercalate, zipWith) import Data.String hiding (unlines) -import Data.Text hiding (map, init, length, splitAt) +import Data.Text hiding (map, init, length, splitAt, foldl, zipWith) import Data.Text.IO (putStrLn, putStr, writeFile) import Data.Text.Lazy (toStrict) import Data.Text.Template import Data.Time.Clock.POSIX import Lib -import Prelude hiding (putStrLn, putStr, init, unlines, writeFile) +import Prelude hiding (putStrLn, putStr, init, unlines, writeFile, zipWith) import Prompts import System.Directory import System.Directory (doesFileExist) @@ -16,10 +20,15 @@ import System.Environment import System.Exit import System.File.Tree hiding (map, mapM, mapM_) import System.Process -import Text.JSON -import Text.JSON.Generic +import Data.Aeson +import Data.Aeson.TH +import Data.Aeson.Text +import Data.Maybe import Util import Data.Bool (bool) +import Data.Tuple.Curry (uncurryN) +import qualified Data.ByteString.Lazy as BL +import Config main :: IO () main = getArgs >>= parse @@ -27,48 +36,80 @@ main = getArgs >>= parse getGlobalProjectDir :: IO FilePath getGlobalProjectDir = getHomeDirectory >>= return . (++ "/.xyz") -getGlobalProjectConfig :: IO FilePath -getGlobalProjectConfig = getGlobalProjectDir >>= return . (++ "/xyz.json") +getGlobalProjectConfigPath :: IO FilePath +getGlobalProjectConfigPath = getGlobalProjectDir >>= return . (++ "/xyz.json") + +getGlobalProjectConfig :: IO (Maybe GlobalConfig) +getGlobalProjectConfig = getGlobalProjectConfigPath >>= BL.readFile >>= return . decode + +getLocalProjectConfig :: IO (Maybe LocalConfig) +getLocalProjectConfig = BL.readFile "xyz.json" >>= return . decode + +resolveProjectConfig :: IO (Maybe ProjectConfig) +resolveProjectConfig = do + l <- getLocalProjectConfig + g <- getGlobalProjectConfig + + return $ case (l, g) of + (Just l, Just g) -> Just $ getProjectConfig g l + (_, _) -> Nothing continueIfValidProject :: IO () -> IO () -continueIfValidProject next = doesFileExist "xyz.json" >>= bool (putStrLn "This does not appear to be a valid project directory") next +continueIfValidProject next = doesFileExist "xyz.json" >>= bool (putStrLn "This does not appear to be a valid project directory") next + +continueIfInvalidProject :: IO () -> IO () +continueIfInvalidProject next = doesFileExist "xyz.json" >>= bool next (putStrLn "Project already initialised") initGlobalIfNeeded :: IO () -> IO () -initGlobalIfNeeded next = getGlobalProjectConfig >>= doesFileExist >>= bool globalInit (return ()) >> next +initGlobalIfNeeded next = getGlobalProjectConfigPath >>= doesFileExist >>= bool globalInit (return ()) >> next globalInit :: IO () globalInit = do home <- getHomeDirectory putStrLn "\nWelcome to xyz! Looks like this is your first time here. Let's configure a few things...\n" editor <- editorPrompt - writeFile (home ++ "/.xyz/xyz.json") (pack . encode . toJSObject $ [("editor", editor)]) + vcs <- vcsPrompt -- >>= (\x -> return $ if x then Just "git add . && git commit -m \"$title\"" else Nothing) + let pushCmdAndRemote = case vcs of + Just (True, x) -> [("pushCommand", "git add . && git commit -m \"$title\""), ("remote", x)] + Nothing -> [] + + getGlobalProjectConfigPath >>= flip writeFile (toStrict . encodeToLazyText $ GlobalConfig editor (lookup "pushCommand" pushCmdAndRemote) (lookup "remote" pushCmdAndRemote)) putStrLn "\nThanks! Now let's continue with initialising your project...\n" init :: IO () init = do - dirExists <- doesFileExist "xyz.json" - if dirExists - then putStrLn "Project already initialised" - else do home <- getHomeDirectory - themes <- allFilesIn $ home ++ "/.xyz/themes" - projectSpec <- initPrompt (map pack themes) - createDirectory "entries" - writeFile "xyz.json" . pack . encode . toJSObject $ projectSpec - putStrLn "\nInitialised empty project" + home <- getHomeDirectory + themes <- allFilesIn $ home ++ "/.xyz/themes" + projectSpec <- (initPrompt (map pack themes)) >>= return . fmap snd >>= (\[x,y,z] -> return (x, y, z, Nothing, Nothing, Nothing)) + let localConfig = uncurryN LocalConfig projectSpec + writeFile "xyz.json" (toStrict . encodeToLazyText $ localConfig) + config <- resolveProjectConfig + + case config of + Just projectConfig -> do + createDirectory "entries" + + case (commitCommand (projectConfig :: ProjectConfig), gitRemote (projectConfig :: ProjectConfig)) of + (Just cmd, Just remote) -> do + mapM_ (callCommand . unpack . ((+++) " > /dev/unll")) ["git init", "git remote add origin " +++ remote, "git add . && git commit -m \"Initial commit\""] + (_, _) -> return() + + putStrLn "\nInitialised empty project" + Nothing -> do + putStrLn "\nSomething went real wrong" build :: IO () build = do - fileExists <- doesFileExist "xyz.json" - if fileExists - then do - files <- allFilesIn "entries" - home <- getHomeDirectory - config <- readFile "xyz.json" - writeOutProject (decodeJSON config :: ProjectConfig) files >> putStrLn "Build successful" - else putStrLn "This does not appear to be a valid project directory" + files <- allFilesIn "entries" + config <- resolveProjectConfig + + case config of + Just c -> writeOutProject c files >> putStrLn "Build successful" + _ -> putStrLn "Busted" entry :: IO () entry = do + config <- resolveProjectConfig homeDir <- getHomeDirectory entrySpec <- entryPrompt entryNum <- fmap (show . (+1) . length) $ allFilesIn "entries" @@ -93,7 +134,23 @@ entry = do True -> do callCommand . unpack $ "git add . && git commit -m \"" +++ (fst rawEntry) +++ "\" && git push" False -> return () - putStrLn "Thanks for using xyz!" + putStrLn "\nThanks for using xyz!" + +config :: IO () +config = do + config <- resolveProjectConfig + case config of + Just (ProjectConfig { + name=n, + description=d, + theme=t, + editor=e, + commitCommand=cc + }) -> (putStrLn "\nProject details:\n") >> (putStr . unlines $ zipWith (+++) ["Name:\t\t", "Description:\t", "Theme:\t\t", "Editor:\t\t", "Commit command:\t"] [n, d, t, e, ccc]) where + ccc = case cc of + Just g -> g + Nothing -> "Not set" + Nothing -> putStrLn "broken" usage :: IO () usage = putStr . ununlines $ [ @@ -105,9 +162,10 @@ usage = putStr . ununlines $ [ ] ] -parse ["init"] = initGlobalIfNeeded init >> exitSuccess +parse ["init"] = initGlobalIfNeeded (continueIfInvalidProject init) >> exitSuccess parse ["build"] = continueIfValidProject build >> exitSuccess parse ["entry"] = continueIfValidProject entry >> exitSuccess +parse ["config"] = continueIfValidProject config >> exitSuccess parse [_] = usage >> exit parse [] = usage >> exit diff --git a/package.yaml b/package.yaml index 16347e0..bd718e3 100644 --- a/package.yaml +++ b/package.yaml @@ -28,6 +28,9 @@ dependencies: - json - filesystem-trees - process +- aeson +- bytestring +- tuple library: source-dirs: src diff --git a/src/Config.hs b/src/Config.hs new file mode 100644 index 0000000..8082c88 --- /dev/null +++ b/src/Config.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DeriveGeneric #-} + +module Config where + +import GHC.Generics +import Data.Aeson +import Data.Aeson.Types +import Data.Text hiding (map, init, length, splitAt, zip) +import Data.Text.Lazy (toStrict) +import Data.Aeson +import Data.Aeson.TH +import Data.Aeson.Text + +data GlobalConfig = GlobalConfig { + editor :: Text, + commitCommand :: Maybe Text, + gitRemote :: Maybe Text + } deriving (Show, Generic) + +data LocalConfig = LocalConfig { + name :: Text, + description :: Text, + theme :: Text, + editor :: Maybe Text, + commitCommand :: Maybe Text, + gitRemote :: Maybe Text + } deriving (Show, Generic) + +data ProjectConfig = ProjectConfig { + name :: Text, + description :: Text, + theme :: Text, + editor :: Text, + commitCommand :: Maybe Text, + gitRemote :: Maybe Text + } deriving (Show, Generic) + +instance ToJSON GlobalConfig where + toJSON = genericToJSON defaultOptions + { omitNothingFields = False } + +instance FromJSON GlobalConfig where + parseJSON = genericParseJSON defaultOptions + { omitNothingFields = False } + +instance ToJSON LocalConfig where + toJSON = genericToJSON defaultOptions + { omitNothingFields = True } + +instance FromJSON LocalConfig where + parseJSON = genericParseJSON defaultOptions + { omitNothingFields = True } + +maybeTrump :: LocalConfig -> GlobalConfig -> (LocalConfig -> Maybe a) -> (GlobalConfig -> Maybe a) -> Maybe a +maybeTrump l g lf gf = case lf l of + Just x -> Just x + Nothing -> gf g + +trump :: LocalConfig -> GlobalConfig -> (LocalConfig -> Maybe a) -> (GlobalConfig -> a) -> a +trump l g lf gf = case lf l of + Just x -> x + Nothing -> gf g + +getProjectConfig :: GlobalConfig -> LocalConfig -> ProjectConfig +getProjectConfig g l = ProjectConfig + (name (l :: LocalConfig)) + (description (l :: LocalConfig)) + (theme (l :: LocalConfig)) + (trumper editor editor) + (maybeTrumper commitCommand commitCommand) + (maybeTrumper gitRemote gitRemote) + where + trumper = trump l g + maybeTrumper = maybeTrump l g diff --git a/src/Lib.hs b/src/Lib.hs index 123e315..9798de0 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} @@ -21,17 +20,12 @@ import System.Directory import System.FilePath.Posix (takeBaseName, takeDirectory) import Data.Data import Data.Typeable +import Config data Theme = Theme { - name :: String, -- works better with getHomeDirectory - templates :: [(String, Template)] - } deriving (Show) - -data ProjectConfig = ProjectConfig { - name :: Text, - description :: Text, - theme :: String -- as above - } deriving (Show, Data, Typeable) + name :: Text, -- works better with getHomeDirectory + templates :: [(Text, Template)] + } deriving (Show) data Project = Project { name :: Text, @@ -132,13 +126,13 @@ writeOutProject projectConfig files = do entryList <- mapM (\raw -> return $ rawTextToEntry raw) rawEntries homeDir <- getHomeDirectory - let themeName = theme (projectConfig :: ProjectConfig) + let themeName = unpack $ theme (projectConfig :: ProjectConfig) themeTemplatePaths <- allFilesIn $ homeDir ++ "/.xyz/themes/" ++ themeName - themeTemplates <- mapM (\x -> (readFile $ homeDir ++ "/.xyz/themes/" ++ themeName ++ "/" ++ x) >>= (\y -> return (x, (template . fromString) y))) themeTemplatePaths + themeTemplates <- mapM (\x -> (readFile $ homeDir ++ "/.xyz/themes/" ++ themeName ++ "/" ++ x) >>= (\y -> return (pack x, (template . fromString) y))) themeTemplatePaths let projectName = name (projectConfig :: ProjectConfig) let projectDescription = description (projectConfig :: ProjectConfig) - let project = Project projectName projectDescription (Theme themeName themeTemplates) (stampsToEntryList entryList) + let project = Project projectName projectDescription (Theme (pack themeName) themeTemplates) (stampsToEntryList entryList) mapM_ (createDirectoryIfMissing True . takeDirectory . unpack . fst) $ getEntryPages project mapM_ (\x -> writeFile (unpack $ fst x) (unpack $ snd x)) $ getEntryPages project diff --git a/src/Prompts.hs b/src/Prompts.hs index 846d019..e2fccf1 100644 --- a/src/Prompts.hs +++ b/src/Prompts.hs @@ -1,4 +1,4 @@ -module Prompts (entryPrompt, initPrompt, pushPrompt, editorPrompt) where +module Prompts (entryPrompt, initPrompt, pushPrompt, editorPrompt, vcsPrompt) where import Util import Prelude hiding (getLine, null, putStrLn, putStr, unlines) @@ -88,4 +88,13 @@ editorPrompt = filterM (system . unpack . (+++ " > /dev/null") . ("which " +++) ExitSuccess -> True commonEditors = ["vi", "vim", "nano", "emacs"] +vcsPrompt :: IO (Maybe (Bool, Text)) +vcsPrompt = do + gitInstalled <- (system . unpack $ "which git > /dev/null") >>= return . codeToBool + if gitInstalled then dependantYornTextPrompt "I detected git on your system. Would you like to use it to version entries?" "Which remote should I use? " else return Nothing + where + codeToBool x = case x of + ExitFailure _ -> False + ExitSuccess -> True + pushPrompt = yornPrompt "Do you want to push this entry?"