From c1dc0e692bb108bd384bfa6ccc385c76339797e3 Mon Sep 17 00:00:00 2001 From: Starkey Date: Fri, 2 Feb 2024 18:29:01 +0100 Subject: [PATCH] arguments --- flake.nix | 1 + git-activity-tracker.cabal | 6 ++ package.yaml | 2 + src/Lib.hs | 153 +++++++++++++++++++++++++++++++++---- 4 files changed, 148 insertions(+), 14 deletions(-) diff --git a/flake.nix b/flake.nix index 512392b..4ad460f 100644 --- a/flake.nix +++ b/flake.nix @@ -36,6 +36,7 @@ hPkgs.haskell-language-server hPkgs.ghc stack-wrapper + pkgs.glibcLocales ]; }; } diff --git a/git-activity-tracker.cabal b/git-activity-tracker.cabal index 52d36df..807ff5c 100644 --- a/git-activity-tracker.cabal +++ b/git-activity-tracker.cabal @@ -38,6 +38,8 @@ library , base >=4.7 && <5 , bytestring , chronos + , extra + , optparse-applicative , text , typed-process , wl-pprint-text @@ -57,7 +59,9 @@ executable git-activity-tracker-exe , base >=4.7 && <5 , bytestring , chronos + , extra , git-activity-tracker + , optparse-applicative , text , typed-process , wl-pprint-text @@ -78,7 +82,9 @@ test-suite git-activity-tracker-test , base >=4.7 && <5 , bytestring , chronos + , extra , git-activity-tracker + , optparse-applicative , text , typed-process , wl-pprint-text diff --git a/package.yaml b/package.yaml index fa3aa58..e164383 100644 --- a/package.yaml +++ b/package.yaml @@ -27,6 +27,8 @@ dependencies: - bytestring - aeson - wl-pprint-text +- optparse-applicative +- extra ghc-options: - -Wall diff --git a/src/Lib.hs b/src/Lib.hs index 4d077ec..c5bb00d 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} module Lib ( libMain ) where @@ -13,8 +14,14 @@ import GHC.Generics (Generic) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Char (toLower) -import Text.PrettyPrint.Leijen.Text +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) import qualified Data.Aeson.Types as A +import qualified Options.Applicative as O +import Data.Either.Extra +import Control.Monad +import qualified Data.Text.Encoding as T +import Data.Functor +import Data.Function updateHead :: (a -> a) -> [a] -> [a] updateHead fun (x:xs) = fun x : xs @@ -22,6 +29,111 @@ updateHead _ [] = [] data Commit = Commit{_cDate :: Datetime, _cHash :: Text, _cAuthor :: Text, _cMessage :: Text} deriving (Generic, Show) +data Arguments = Arguments + { _aStateDir :: Text + , _aVerbose :: Bool + , _aCommand :: Command + } + deriving Show + +data Command + = CommandAdd + { _caURL :: Text + } + | CommandRemove + { _crURL :: Text + } + | CommandCommits + { _ccFrom :: Maybe Datetime + , _ccTo :: Maybe Datetime + , _ccAuthors :: [Text] + } + | CommandGenGraph + { _cgFrom :: Maybe Datetime + , _cgTo :: Maybe Datetime + , _cgAuthors :: [Text] + } + deriving Show + +datetime :: O.ReadM Datetime +datetime = O.eitherReader $ \str -> + case decode_YmdHMS_lenient (T.pack str) of + Just date -> Right date + Nothing -> case decode_YmdHMS_lenient (T.pack str <> " 00:00:00") of + Just date -> Right date + Nothing -> Left "Invalid datetime" + +commandAdd :: O.Parser Command +commandAdd + = CommandAdd + <$> O.argument O.str (O.metavar "URL") + +commandRemove :: O.Parser Command +commandRemove + = CommandRemove + <$> O.argument O.str (O.metavar "URL") + +commandCommits :: O.Parser Command +commandCommits + = CommandCommits + <$> O.optional + ( O.option datetime + ( O.long "from" + <> O.metavar "DATE") + ) + <*> O.optional + ( O.option datetime + ( O.long "to" + <> O.metavar "DATE" + ) + ) + <*> O.many + ( O.strOption + ( O.long "author" + <> O.metavar "NAME" + ) + ) + +commandGenGraph :: O.Parser Command +commandGenGraph + = CommandGenGraph + <$> O.optional + ( O.option datetime + ( O.long "from" + <> O.metavar "DATE") + ) + <*> O.optional + ( O.option datetime + ( O.long "to" + <> O.metavar "DATE" + ) + ) + <*> O.many + ( O.strOption + ( O.long "author" + <> O.metavar "NAME" + ) + ) + +arguments :: O.Parser Arguments +arguments + = Arguments + <$> O.strOption + ( O.long "state-dir" + <> O.metavar "STATE_DIR" + ) + <*> O.switch + ( O.long "verbose" + <> O.short 'v' + ) + <*> O.subparser + ( O.command "add" (O.info (commandAdd O.<**> O.helper) ( O.progDesc "Add a remote for tracking" )) + <> O.command "remove" (O.info (commandRemove O.<**> O.helper) ( O.progDesc "Remove a remote from tracking")) + <> O.command "commits" (O.info (commandCommits O.<**> O.helper) ( O.progDesc "Print commits")) + <> O.command "gen-graph" (O.info (commandGenGraph O.<**> O.helper) ( O.progDesc "Generate graph")) + ) + + commitOptions :: A.Options commitOptions = (A.defaultOptions { A.fieldLabelModifier = updateHead toLower . drop 2}) @@ -38,31 +150,44 @@ prettyCommit (Commit {_cDate, _cHash, _cAuthor, _cMessage}) = textStrict (encode_YmdHMS (SubsecondPrecisionFixed 0) hyphen _cDate) <+> textStrict _cAuthor <+> textStrict _cHash - <+> textStrict ("\"" <> _cMessage <> "\"") + <+> textStrict ("\"" <> T.replace "\"" "\\\"" _cMessage <> "\"") libMain :: IO () -libMain = do - putStrLn "someFunc" - result <- getCommits "magic_rb/dotfiles/master/master" ["magic_rb"] (Just (Datetime (Date (Year 2024) (Month 0) (DayOfMonth 31)) (TimeOfDay 0 0 0)), Nothing) +libMain = O.execParser (O.info (arguments O.<**> O.helper) (O.progDesc "Git Activity Tracker")) >>= \(Arguments { _aVerbose, _aStateDir, _aCommand }) -> + case _aCommand of + CommandAdd { _caURL } -> pure () + CommandRemove { _crURL } -> pure () + CommandCommits { _ccFrom, _ccTo, _ccAuthors } -> do + result <- getCommits _aVerbose "magic_rb/dotfiles/master/master" _ccAuthors (_ccFrom, _ccTo) + case result of + Left err -> print err + Right ok -> mapM_ (print . prettyCommit) ok + CommandGenGraph { _cgFrom, _cgTo, _cgAuthors } -> pure () - case result of - Left err -> print err - Right ok -> mapM_ (print . prettyCommit) ok + -- do + --putStrLn "someFunc" + --result <- getCommits "magic_rb/dotfiles/master/master" ["magic_rb"] (Just (Datetime (Date (Year 2024) (Month 0) (DayOfMonth 31)) (TimeOfDay 0 0 0)), Nothing) -getCommits :: String -> [String] -> (Maybe Datetime, Maybe Datetime) -> IO (Either String [Commit]) -getCommits branch authors (from, to) = + --case result of + -- Left err -> print err + -- Right ok -> mapM_ (print . prettyCommit) ok + +getCommits :: Bool -> Text -> [Text] -> (Maybe Datetime, Maybe Datetime) -> IO (Either Text [Commit]) +getCommits verbose branch authors (from, to) = do + when verbose (putStrLn . unwords $ "git" : args) readProcessStdout pc >>= \(exitCode, stdout) -> case exitCode of ExitFailure _ -> pure $ Left "" - ExitSuccess -> pure $ mapM A.eitherDecode (BSL.lines stdout) + ExitSuccess -> pure a + where a = T.decodeUtf8' (BSL.toStrict stdout) <&> T.lines <&> map (T.replace "^@^" "\"" . T.replace "\"" "\\\"") & mapLeft show >>= mapM A.eitherDecode' . map (BSL.fromStrict . T.encodeUtf8) & mapLeft T.pack where pc = proc "git" args args = filter (/= "") $ [ "log" , "--date=format:%Y-%m-%d %H:%M:%S" - , "--format=format:{ \"date\": \"%ad\", \"hash\": \"%H\", \"author\": \"%an\", \"message\": \"%s\" }" + , "--format=format:{ ^@^date^@^: ^@^%ad^@^, ^@^hash^@^: ^@^%H^@^, ^@^author^@^: ^@^%an^@^, ^@^message^@^: ^@^%s^@^ }" , maybe "" (\from' -> "--since=" <> T.unpack (encodeIso8601 from')) from , maybe "" (\to' -> "--before=" <> T.unpack (encodeIso8601 to')) to - ] <> map ("--author=" <>) authors <> - [ branch + ] <> map (\author -> "--author=" <> T.unpack author) authors <> + [ T.unpack branch ]