Initial-ish commit: quick-and-dirty code for parsing git logs and walking them

.gitignore

@@ -0,0 +1,5 @@
+*~
+.ghc.env*
+dist-newstyle
+dist
+.dante-dist

bunyan.cabal

@@ -0,0 +1,38 @@
+name:             bunyan
+version:          0.1.0.0
+-- synopsis:
+-- description:
+license:          BSD3
+license-file:     LICENSE
+author:           Getty Ritter <gdritter@galois.com>
+maintainer:       Getty Ritter <gdritter@galois.com>
+copyright:        ©2017 Getty Ritter
+-- category:
+build-type:       Simple
+cabal-version:    >= 1.14
+
+library
+  exposed-modules:     Bunyan
+  other-modules:       Bunyan.App
+                       Bunyan.Log
+                       Bunyan.Pretty
+  hs-source-dirs:      src
+  build-depends:       base >=4.7 && <5
+                     , brick
+                     , containers
+                     , process
+                     , text
+                     , vty
+  default-language:    Haskell2010
+  default-extensions:  ScopedTypeVariables
+
+executable bunyan
+  hs-source-dirs:      bunyan
+  main-is:             Main.hs
+  other-modules:       Options
+  default-extensions:  ScopedTypeVariables
+  ghc-options:         -Wall -threaded
+  build-depends:       base >=4.7 && <5
+                     , bunyan
+                     , directory
+  default-language:    Haskell2010

bunyan/Main.hs

@@ -0,0 +1,9 @@
+module Main where
+
+import qualified Bunyan
+import qualified Options
+
+main :: IO ()
+main = do
+  bunyan <- Options.getOpts
+  Bunyan.main bunyan

bunyan/Options.hs

@@ -0,0 +1,67 @@
+module Options (getOpts) where
+
+import           Control.Monad (when)
+import qualified System.Console.GetOpt as Opt
+import qualified System.Directory as Sys
+import qualified System.Environment as Sys
+import qualified System.Exit as Sys
+
+import qualified Bunyan
+
+data Options = Options
+  { optShowVersion :: Bool
+  , optShowHelp    :: Bool
+  , optEditorCmd   :: Maybe String
+  , optRepoPath    :: FilePath
+  } deriving (Eq, Show)
+
+options :: [Opt.OptDescr (Options -> Options)]
+options =
+  [ Opt.Option ['v'] ["version"]
+    (Opt.NoArg (\ o -> o { optShowVersion = True }))
+    "Show version number"
+  , Opt.Option ['h'] ["help"]
+    (Opt.NoArg (\ o -> o { optShowHelp = True }))
+    "Show this help screen"
+  , Opt.Option ['e'] ["editor"]
+    (Opt.ReqArg (\ e o -> o { optEditorCmd = Just e }) "CMD")
+    "desired editor command (defaults to $EDITOR)"
+  , Opt.Option ['r'] ["repository"]
+    (Opt.ReqArg (\ p o -> o { optRepoPath = p }) "PATH")
+    "git repository location (defaults to $CWD)"
+  ]
+
+usageInfo :: String
+usageInfo = Opt.usageInfo header options
+  where header = "Usage: bunyan [OPTIONS]..."
+
+getOpts :: IO Bunyan.Config
+getOpts = do
+  args <- Sys.getArgs
+  defaultEditor <- Sys.lookupEnv "EDITOR"
+  defaultPath   <- Sys.getCurrentDirectory
+  let defOpts = Options
+        { optShowVersion = False
+        , optShowHelp    = False
+        , optEditorCmd   = defaultEditor
+        , optRepoPath    = defaultPath
+        }
+  case Opt.getOpt Opt.Permute options args of
+    (o, [], [])  -> do
+      let opts = foldl (flip id) defOpts o
+      when (optShowVersion opts) $ do
+        putStrLn "bunyan, version 0.1.0.0"
+        Sys.exitSuccess
+      when (optShowHelp opts) $ do
+        putStrLn usageInfo
+        Sys.exitSuccess
+      editor <- case optEditorCmd opts of
+        Just e -> return e
+        Nothing ->
+          Sys.die "No $EDITOR set and no editor command supplied!"
+      return $ Bunyan.Config
+        { Bunyan.cfgEditorCommand = editor
+        , Bunyan.cfgGitRepo       = optRepoPath opts
+        }
+    (_, _, errs) -> do
+      Sys.die (concat errs ++ usageInfo)

src/Bunyan.hs

@@ -0,0 +1,27 @@
+module Bunyan where
+
+import           Data.Monoid ((<>))
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import qualified System.Process as Sys
+
+import           Bunyan.Log
+import           Bunyan.App
+import           Bunyan.Pretty
+
+data Config = Config
+  { cfgEditorCommand :: String
+  , cfgGitRepo       :: FilePath
+  } deriving (Eq, Show)
+
+
+main :: Config -> IO ()
+main cfg = do
+  let pr = (Sys.proc "git" ["log"]) { Sys.cwd = Just (cfgGitRepo cfg)
+                                    , Sys.std_out = Sys.CreatePipe
+                                    }
+  rs <- Sys.withCreateProcess pr $ \ _ (Just stdin) _ ph -> do
+    T.hGetContents stdin
+  let entries = parseLogEntry rs
+  cats <- runApp entries
+  T.putStrLn (pretty cats)

src/Bunyan/App.hs

@@ -0,0 +1,138 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bunyan.App (runApp) where
+
+import qualified Brick
+import qualified Data.Map as M
+import           Data.Monoid ((<>))
+import qualified Data.Sequence as S
+import qualified Data.Text as T
+import qualified Graphics.Vty as Vty
+import qualified Graphics.Vty.Input.Events as Vty
+
+import qualified Bunyan.Log as Log
+
+
+data Modal
+  = AddSectionModal ()
+  | ConfirmQuitModal
+  deriving (Eq, Show)
+
+data Annot
+  = Annot T.Text Log.Entry
+  | Skip Log.Entry
+  deriving (Eq, Show)
+
+data State = State
+  { stateSections :: M.Map T.Text (S.Seq (S.Seq T.Text))
+  , stateCommits  :: S.Seq Log.Entry
+  , stateFinished :: S.Seq Annot
+  , stateKeys     :: M.Map Char T.Text
+  , stateModal    :: Maybe Modal
+  , stateStatus   :: T.Text
+  } deriving (Eq, Show)
+
+
+defaultSections :: [(Char, T.Text)]
+defaultSections =
+  [ ('f', "New features")
+  , ('b', "Bug fixes")
+  , ('p', "Package changes")
+  , ('d', "Documentation changes")
+  , ('i', "Performance improvements")
+  ]
+
+newState :: S.Seq Log.Entry -> State
+newState commits = State
+  { stateSections = M.fromList
+    [ (name, mempty) | (_, name) <- defaultSections ]
+  , stateKeys = M.fromList defaultSections
+  , stateCommits = commits
+  , stateFinished = S.empty
+  , stateModal = Nothing
+  , stateStatus = ""
+  }
+
+
+
+runApp :: S.Seq Log.Entry -> IO (M.Map T.Text (S.Seq (S.Seq T.Text)))
+runApp entries = do
+  let state = newState entries
+      vty = Vty.mkVty Vty.defaultConfig
+  final <- Brick.customMain vty Nothing app state
+  return (stateSections final)
+
+
+app :: Brick.App State () ()
+app = Brick.App
+  { Brick.appDraw         = draw
+  , Brick.appChooseCursor = Brick.showFirstCursor
+  , Brick.appHandleEvent  = event
+  , Brick.appStartEvent   = return
+  , Brick.appAttrMap      = \ _ -> Brick.forceAttrMap mempty
+  }
+
+
+draw :: State -> [Brick.Widget ()]
+draw st
+  | Just ConfirmQuitModal <- stateModal st =
+      [ Brick.txt "Are you sure you want to quit? (y/n)" ]
+  | otherwise =
+      [ Brick.vBox
+        [ Brick.str (show (stateModal st))
+        , Brick.txt (stateStatus st)
+        ]
+      ]
+
+
+type EventHandler =
+  State -> Vty.Key -> [Vty.Modifier] -> Brick.EventM () (Brick.Next State)
+
+event :: State -> Brick.BrickEvent () () -> Brick.EventM () (Brick.Next State)
+event st (Brick.VtyEvent (Vty.EvKey key mod)) =
+  case stateModal st of
+    Nothing -> mainEvent st key mod
+    Just ConfirmQuitModal -> confirmQuitEvent st key mod
+    Just (AddSectionModal ()) -> addSectionEvent st key mod
+event st _ = Brick.continue st
+
+
+mainEvent :: EventHandler
+mainEvent st (Vty.KChar ' ') [] = do
+  let car S.:< cdr = S.viewl (stateCommits st)
+  Brick.continue st
+    { stateFinished = Skip car S.<| stateFinished st
+    , stateCommits = cdr
+    , stateStatus = "skipped"
+    }
+
+mainEvent st (Vty.KChar 'q') [] =
+  Brick.continue st { stateModal = Just ConfirmQuitModal }
+
+mainEvent st (Vty.KChar 'a') [] =
+  Brick.continue st { stateModal = Just (AddSectionModal ()) }
+
+mainEvent st (Vty.KChar c) []
+  | Just annot <- M.lookup c (stateKeys st) = do
+      let car S.:< cdr = S.viewl (stateCommits st)
+      Brick.continue st
+        { stateFinished = Annot annot car S.<| stateFinished st
+        , stateCommits  = cdr
+        , stateSections =
+          M.adjust ((Log.logMessage car) S.<|) annot (stateSections st)
+        , stateStatus =
+          "Added " <> Log.logCommit car <> " to section " <> annot
+        }
+  | otherwise =
+    Brick.continue st { stateStatus = "Unknown keybindings: " <> T.pack (show c) }
+
+mainEvent st _ _ = Brick.continue st
+
+
+confirmQuitEvent :: EventHandler
+confirmQuitEvent st (Vty.KChar 'y') _ = Brick.halt st
+confirmQuitEvent st _ _  = Brick.continue st { stateModal = Nothing }
+
+
+addSectionEvent :: EventHandler
+addSectionEvent st _ _ = Brick.continue st { stateModal = Nothing }

src/Bunyan/Log.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bunyan.Log where
+
+import           Data.Monoid ((<>))
+import qualified Data.Text as T
+import qualified Data.Sequence as S
+
+
+data Entry = Entry
+  { logCommit      :: T.Text
+  , logAuthor      :: T.Text
+  , logDate        :: T.Text
+  , logMessage     :: S.Seq T.Text
+  } deriving (Eq, Show)
+
+
+emptyLogEntry :: T.Text -> Entry
+emptyLogEntry commit = Entry
+  { logCommit      = commit
+  , logAuthor      = ""
+  , logDate        = ""
+  , logMessage     = mempty
+  }
+
+
+parseLogEntry :: T.Text -> S.Seq Entry
+parseLogEntry = getNextCommit . T.lines
+  where getNextCommit [] = S.empty
+        getNextCommit (x:xs)
+          | Just cmt <- T.stripPrefix "commit " x =
+            parseCommit (emptyLogEntry cmt) xs
+          | otherwise = getNextCommit xs
+
+        parseCommit entry [] = S.singleton entry
+        parseCommit entry (x:xs)
+          | Just cmt <- T.stripPrefix "commit " x =
+              entry S.<| parseCommit (emptyLogEntry cmt) xs
+          | Just author <- T.stripPrefix "Author:" x =
+              parseCommit (entry { logAuthor = T.strip author }) xs
+          | Just date <- T.stripPrefix "Date:" x =
+              parseCommit (entry { logDate = T.strip date }) xs
+          | Just line   <- T.stripPrefix "    " x =
+              parseCommit (entry { logMessage = logMessage entry <> S.singleton line }) xs
+          | otherwise =
+            parseCommit entry xs

src/Bunyan/Pretty.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Bunyan.Pretty (pretty) where
+
+import qualified Data.Foldable as F
+import qualified Data.Map as M
+import           Data.Monoid ((<>))
+import qualified Data.Sequence as S
+import qualified Data.Text as T
+
+pretty :: M.Map T.Text (S.Seq (S.Seq T.Text)) -> T.Text
+pretty messages = T.unlines $ concat
+  [ section annot fields
+  | (annot, fields) <- M.toList messages
+  , not (S.null fields)
+  ]
+
+section :: T.Text -> S.Seq (S.Seq T.Text) -> [T.Text]
+section annot fields =
+  let bullet [] = []
+      bullet (x:xs) = ("* " <> x) : map ("  " <>) xs
+  in "" : (annot <> ":") : F.foldMap bullet (fmap F.toList fields)