git-brunch 1.5.1.0 → 1.6.0.0
raw patch · 7 files changed
+467/−424 lines, 7 filesdep +extradep +microlens-mtldep +mtl
Dependencies added: extra, microlens-mtl, mtl, text
Files
- LICENSE +1/−1
- app/Git.hs +83/−76
- app/GitBrunch.hs +275/−252
- app/Main.hs +13/−15
- app/Theme.hs +33/−29
- git-brunch.cabal +18/−6
- test/Spec.hs +44/−45
LICENSE view
@@ -1,4 +1,4 @@-Copyright andys8 (c) 2019+Copyright andys8 (c) 2023 All rights reserved.
app/Git.hs view
@@ -1,122 +1,129 @@-module Git- ( Branch(..)- , checkout- , deleteBranch- , fetch- , fullBranchName- , isCommonBranch- , isRemoteBranch- , listBranches- , rebaseInteractive- , merge- , toBranches- ) where--import Data.Char ( isSpace )-import Data.List-import System.Exit-import System.Process+module Git (+ Branch (..),+ checkout,+ deleteBranch,+ fetch,+ fullBranchName,+ isCommonBranch,+ isRemoteBranch,+ listBranches,+ rebaseInteractive,+ merge,+ toBranches,+) where +import Data.Char (isSpace)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import System.Exit+import System.Process -data Branch = BranchLocal String- | BranchCurrent String- | BranchRemote String String- deriving Eq+data Branch+ = BranchLocal Text+ | BranchCurrent Text+ | BranchRemote Text Text+ deriving (Eq) -instance (Show Branch) where- show (BranchLocal n ) = n- show (BranchCurrent n ) = n <> "*"- show (BranchRemote o n) = o <> "/" <> n+instance Show Branch where+ show (BranchLocal n) = T.unpack n+ show (BranchCurrent n) = T.unpack $ n <> "*"+ show (BranchRemote o n) = T.unpack $ o <> "/" <> n -fetch :: IO String+fetch :: IO Text fetch = readGit ["fetch", "--all", "--prune"] listBranches :: IO [Branch]-listBranches = toBranches <$> readGit- [ "branch"- , "--list"- , "--all"- , "--sort=-committerdate"- , "--no-column"- , "--no-color"- ]+listBranches =+ toBranches+ <$> readGit+ [ "branch"+ , "--list"+ , "--all"+ , "--sort=-committerdate"+ , "--no-column"+ , "--no-color"+ ] -toBranches :: String -> [Branch]-toBranches input = toBranch <$> filter validBranch (lines input)- where validBranch b = not $ isHead b || isDetachedHead b || isNoBranch b+toBranches :: Text -> [Branch]+toBranches input = toBranch <$> filter validBranch (T.lines input)+ where+ validBranch b = not $ isHead b || isDetachedHead b || isNoBranch b -toBranch :: String -> Branch-toBranch line = mkBranch $ words $ dropWhile isSpace line+toBranch :: Text -> Branch+toBranch line = mkBranch $ T.words $ T.dropWhile isSpace line where mkBranch ("*" : name : _) = BranchCurrent name- mkBranch (name : _) = case stripPrefix "remotes/" name of+ mkBranch (name : _) = case T.stripPrefix "remotes/" name of Just rest -> parseRemoteBranch rest- Nothing -> BranchLocal name+ Nothing -> BranchLocal name mkBranch [] = error "empty branch name" parseRemoteBranch str = BranchRemote remote name- where (remote, _ : name) = span ('/' /=) str+ where+ (remote, rest) = T.span ('/' /=) str+ name = T.drop 1 rest checkout :: Branch -> IO ExitCode checkout branch = spawnGit ["checkout", branchName branch] rebaseInteractive :: Branch -> IO ExitCode rebaseInteractive branch = do- putStrLn $ "Rebase onto " <> fullBranchName branch+ T.putStrLn $ "Rebase onto " <> fullBranchName branch spawnGit ["rebase", "--interactive", "--autostash", fullBranchName branch] merge :: Branch -> IO ExitCode merge branch = do- putStrLn $ "Merge branch " <> fullBranchName branch+ T.putStrLn $ "Merge branch " <> fullBranchName branch spawnGit ["merge", fullBranchName branch] deleteBranch :: Branch -> IO ExitCode-deleteBranch (BranchCurrent _ ) = error "Cannot delete current branch"-deleteBranch (BranchLocal n ) = spawnGit ["branch", "-D", n]+deleteBranch (BranchCurrent _) = error "Cannot delete current branch"+deleteBranch (BranchLocal n) = spawnGit ["branch", "-D", n] deleteBranch (BranchRemote o n) = spawnGit ["push", o, "--delete", n] -spawnGit :: [String] -> IO ExitCode-spawnGit args = waitForProcess =<< spawnProcess "git" args+spawnGit :: [Text] -> IO ExitCode+spawnGit args = waitForProcess =<< spawnProcess "git" (T.unpack <$> args) -readGit :: [String] -> IO String-readGit args = readProcess "git" args []+readGit :: [Text] -> IO Text+readGit args = T.pack <$> readProcess "git" (T.unpack <$> args) [] isCommonBranch :: Branch -> Bool-isCommonBranch b =- branchName b- `elem` [ "master"- , "main"- , "dev"- , "devel"- , "develop"- , "development"- , "staging"- , "trunk"- ]-+isCommonBranch b = branchName b `elem` commonBranchNames+ where+ commonBranchNames =+ [ "master"+ , "main"+ , "dev"+ , "devel"+ , "develop"+ , "development"+ , "staging"+ , "trunk"+ ] isRemoteBranch :: Branch -> Bool isRemoteBranch (BranchRemote _ _) = True-isRemoteBranch _ = False+isRemoteBranch _ = False --- Helper -branchName :: Branch -> String-branchName (BranchCurrent n ) = n-branchName (BranchLocal n ) = n+branchName :: Branch -> Text+branchName (BranchCurrent n) = n+branchName (BranchLocal n) = n branchName (BranchRemote _ n) = n -fullBranchName :: Branch -> String-fullBranchName (BranchCurrent n ) = n-fullBranchName (BranchLocal n ) = n+fullBranchName :: Branch -> Text+fullBranchName (BranchCurrent n) = n+fullBranchName (BranchLocal n) = n fullBranchName (BranchRemote r n) = r <> "/" <> n -isHead :: String -> Bool-isHead = isInfixOf "HEAD"+isHead :: Text -> Bool+isHead = T.isInfixOf "HEAD" -isDetachedHead :: String -> Bool-isDetachedHead = isInfixOf "HEAD detached"+isDetachedHead :: Text -> Bool+isDetachedHead = T.isInfixOf "HEAD detached" -- While rebasing git will show "no branch" -- e.g. "* (no branch, rebasing branch-name)"-isNoBranch :: String -> Bool-isNoBranch = isInfixOf "(no branch,"+isNoBranch :: Text -> Bool+isNoBranch = T.isInfixOf "(no branch,"
app/GitBrunch.hs view
@@ -1,150 +1,158 @@-{-# LANGUAGE LambdaCase #-}-module GitBrunch- ( main- ) where+module GitBrunch (main) where -import Brick.Main ( continue- , halt- , suspendAndResume- )-import qualified Brick.Main as M-import Brick.Themes ( themeToAttrMap )-import Brick.Types-import qualified Brick.Widgets.Border as B-import qualified Brick.Widgets.Border.Style as BS-import qualified Brick.Widgets.Center as C-import Brick.Widgets.Core-import qualified Brick.Widgets.Dialog as D-import qualified Brick.Widgets.Edit as E-import qualified Brick.Widgets.List as L-import Control.Exception ( SomeException- , catch- )-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe ( fromMaybe )-import qualified Data.Vector as Vec-import Graphics.Vty hiding ( update )-import Lens.Micro ( (%~)- , (&)- , (.~)- , Lens'- , (^.)- , lens- )-import System.Exit+import Brick.Main (halt)+import Brick.Main qualified as M+import Brick.Themes (themeToAttrMap)+import Brick.Types+import Brick.Widgets.Border qualified as B+import Brick.Widgets.Border.Style qualified as BS+import Brick.Widgets.Center qualified as C+import Brick.Widgets.Core+import Brick.Widgets.Dialog qualified as D+import Brick.Widgets.Edit qualified as E+import Brick.Widgets.List qualified as L+import Control.Exception (SomeException, catch)+import Control.Monad+import Control.Monad.Extra (ifM, unlessM)+import Data.Char+import Data.List+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Data.Vector qualified as Vec+import Graphics.Vty hiding (update)+import Lens.Micro (Lens', lens, (%~), (&), (.~), (^.), _Just)+import Lens.Micro.Mtl ((%=), (.=), (?=))+import System.Exit -import Git ( Branch(..) )-import qualified Git-import Theme+import Git (Branch (..))+import Git qualified+import Theme +data Name+ = Local+ | Remote+ | Filter+ deriving (Ord, Eq, Show) -data Name = Local | Remote | Filter deriving (Ord, Eq, Show)-data RemoteName = RLocal | RRemote deriving (Eq)-data GitCommand = GitRebase | GitMerge | GitCheckout | GitDeleteBranch deriving (Ord, Eq)-data DialogResult = SetDialog Dialog | EndDialog DialogOption-data DialogOption = Cancel | Confirm-type Dialog = D.Dialog DialogOption+data RemoteName+ = RLocal+ | RRemote+ deriving (Eq) +data GitCommand+ = GitRebase+ | GitMerge+ | GitCheckout+ | GitDeleteBranch+ deriving (Ord, Eq)++data DialogOption+ = Cancel+ | Confirm GitCommand+ data State = State- { _focus :: RemoteName- , _gitCommand :: GitCommand- , _branches :: [Branch]- , _localBranches :: L.List Name Branch- , _remoteBranches :: L.List Name Branch- , _dialog :: Maybe Dialog- , _filter :: E.Editor String Name+ { _focus :: RemoteName+ , _gitCommand :: GitCommand+ , _branches :: [Branch]+ , _localBranches :: L.List Name Branch+ , _remoteBranches :: L.List Name Branch+ , _dialog :: Maybe (D.Dialog DialogOption)+ , _filter :: E.Editor Text Name , _isEditingFilter :: Bool } - instance Show GitCommand where- show GitCheckout = "checkout"- show GitRebase = "rebase"- show GitMerge = "merge"+ show GitCheckout = "checkout"+ show GitRebase = "rebase"+ show GitMerge = "merge" show GitDeleteBranch = "delete" - main :: IO () main = do branches <- Git.listBranches `catch` gitFailed- state <- M.defaultMain app $ updateLists emptyState { _branches = branches }+ state <- M.defaultMain app $ syncBranchLists emptyState{_branches = branches} let execGit = gitFunction (_gitCommand state) exitCode <- maybe noBranchErr execGit (selectedBranch state)- when (exitCode /= ExitSuccess)- $ die ("Failed to " ++ show (_gitCommand state) ++ ".")+ when (exitCode /= ExitSuccess) $+ die ("Failed to " ++ show (_gitCommand state) ++ ".") where gitFailed :: SomeException -> IO a gitFailed _ = exitFailure noBranchErr = die "No branch selected." gitFunction = \case- GitCheckout -> Git.checkout- GitRebase -> Git.rebaseInteractive- GitMerge -> Git.merge+ GitCheckout -> Git.checkout+ GitRebase -> Git.rebaseInteractive+ GitMerge -> Git.merge GitDeleteBranch -> Git.deleteBranch emptyState :: State emptyState =- let mkList focus = L.list focus Vec.empty rowHeight- in State { _focus = RLocal- , _gitCommand = GitCheckout- , _branches = []- , _localBranches = mkList Local- , _remoteBranches = mkList Remote- , _dialog = Nothing- , _filter = emptyFilter- , _isEditingFilter = False- }+ State+ { _focus = RLocal+ , _gitCommand = GitCheckout+ , _branches = []+ , _localBranches = mkList Local+ , _remoteBranches = mkList Remote+ , _dialog = Nothing+ , _filter = emptyFilter+ , _isEditingFilter = False+ }+ where+ mkList focus = L.list focus Vec.empty rowHeight -emptyFilter :: E.Editor String Name+emptyFilter :: E.Editor Text Name emptyFilter = E.editor Filter Nothing "" app :: M.App State e Name-app = M.App { M.appDraw = appDraw- , M.appChooseCursor = M.showFirstCursor- , M.appHandleEvent = appHandleWithQuit- , M.appStartEvent = return- , M.appAttrMap = const $ themeToAttrMap theme- }+app =+ M.App+ { M.appDraw = drawApp+ , M.appChooseCursor = M.showFirstCursor+ , M.appHandleEvent = appHandleEvent+ , M.appStartEvent = pure ()+ , M.appAttrMap = const $ themeToAttrMap theme+ } -appDraw :: State -> [Widget Name]-appDraw state =- drawDialog state- : [ C.vCenter $ padAll 1 $ maxWidth 200 $ vBox- [branchLists, filterEdit, padding, instructions]- ]+drawApp :: State -> [Widget Name]+drawApp state =+ drawDialog state : [C.vCenter $ padAll 1 $ maxWidth 200 $ vBox content] where+ content = [branchLists, filterEdit, padding, instructions] padding = str " " maxWidth w = C.hCenter . hLimit w toBranchList r lens' = let isActive = state ^. focusL == r && not (_isEditingFilter state)- in state ^. lens' & drawBranchList isActive- filterEdit = if _isEditingFilter state then drawFilter state else emptyWidget- branchLists = hBox- [ C.hCenter $ toBranchList RLocal localBranchesL- , str " "- , C.hCenter $ toBranchList RRemote remoteBranchesL- ]- instructions = maxWidth 100 $ hBox- [ drawInstruction "Enter" "checkout"- , drawInstruction "/" "filter"- , drawInstruction "F" "fetch"- , drawInstruction "R" "rebase"- , drawInstruction "M" "merge"- , drawInstruction "D" "delete"- ]+ in state ^. lens' & drawBranchList isActive+ filterEdit = if _isEditingFilter state then drawFilter state else emptyWidget+ branchLists =+ hBox+ [ C.hCenter $ toBranchList RLocal localBranchesL+ , str " "+ , C.hCenter $ toBranchList RRemote remoteBranchesL+ ]+ instructions =+ maxWidth 100 $+ hBox+ [ drawInstruction "Enter" "checkout"+ , drawInstruction "/" "filter"+ , drawInstruction "F" "fetch"+ , drawInstruction "R" "rebase"+ , drawInstruction "M" "merge"+ , drawInstruction "D" "delete"+ ] drawFilter :: State -> Widget Name drawFilter state = withBorderStyle BS.unicodeBold $ B.border $ vLimit 1 $ label <+> editor where- editor = E.renderEditor (str . unlines) True (state ^. filterL)- label = str " Filter: "+ editor = E.renderEditor (txt . T.unlines) True (state ^. filterL)+ label = str " Filter: " drawDialog :: State -> Widget n drawDialog state = case _dialog state of- Nothing -> emptyWidget+ Nothing -> emptyWidget Just dialog -> D.renderDialog dialog $ C.hCenter $ padAll 1 content where branch = maybe "" show $ selectedBranch state@@ -158,11 +166,11 @@ drawBranchList :: Bool -> L.List Name Branch -> Widget Name drawBranchList hasFocus list =- withBorderStyle BS.unicodeBold- $ B.borderWithLabel (drawTitle list)- $ L.renderList drawListElement hasFocus list+ withBorderStyle BS.unicodeBold $+ B.borderWithLabel (drawTitle list) $+ L.renderList drawListElement hasFocus list where- attr = withAttr $ if hasFocus then attrTitleFocus else attrTitle+ attr = withAttr $ if hasFocus then attrTitleFocus else attrTitle drawTitle = attr . str . map toUpper . show . L.listName drawListElement :: Bool -> Branch -> Widget Name@@ -170,193 +178,198 @@ maxPadding $ highlight branch $ str $ " " <> show branch where maxPadding = if isListFocussed then padRight Max else id- highlight (BranchCurrent _) = withAttr attrBranchCurrent+ highlight (BranchCurrent _) = withAttr attrBranchCurrent highlight b | Git.isCommonBranch b = withAttr attrBranchCommon- highlight _ = id+ highlight _ = id -drawInstruction :: String -> String -> Widget n+drawInstruction :: Text -> Text -> Widget n drawInstruction keys action =- withAttr attrKey (str keys)- <+> str " to "- <+> withAttr attrBold (str action)- & C.hCenter+ withAttr attrKey (txt keys)+ <+> txt " to "+ <+> withAttr attrBold (txt action)+ & C.hCenter -appHandleWithQuit :: State -> BrickEvent Name e -> EventM Name (Next State)-appHandleWithQuit state e = if isQuitEvent e- then quit state- else appHandleEvent state e+appHandleEvent :: BrickEvent Name e -> EventM Name State ()+appHandleEvent (VtyEvent e)+ | isQuitEvent e = quit+ | otherwise = do+ dialog <- gets _dialog+ if isJust dialog+ then appHandleEventDialog e+ else appHandleEventMain e where- isQuitEvent (VtyEvent (EvKey (KChar 'c') [MCtrl])) = True- isQuitEvent (VtyEvent (EvKey (KChar 'd') [MCtrl])) = True+ isQuitEvent (EvKey (KChar 'c') [MCtrl]) = True+ isQuitEvent (EvKey (KChar 'd') [MCtrl]) = True isQuitEvent _ = False+appHandleEvent _ = pure () -quit :: State -> EventM Name (Next State)-quit state = halt $ focussedBranchesL %~ L.listClear $ state+appHandleEventMain :: Event -> EventM Name State ()+appHandleEventMain e =+ let+ event = lowerKey e+ endWithCheckout = gitCommandL .= GitCheckout >> halt+ endWithRebase = gitCommandL .= GitRebase >> halt+ endWithMerge = gitCommandL .= GitMerge >> halt+ resetFilter = filterL .~ emptyFilter+ showFilter = isEditingFilterL .~ True+ hideFilter = isEditingFilterL .~ False+ startEditingFilter = modify (showFilter . resetFilter)+ cancelEditingFilter = modify (hideFilter . resetFilter)+ stopEditingFilter = modify hideFilter -appHandleEvent :: State -> BrickEvent Name e -> EventM Name (Next State)-appHandleEvent state e = case _dialog state of- Nothing -> appHandleEventMain state e- Just d -> toState =<< appHandleEventDialog d e- where- toState (SetDialog dlg ) = continue $ state { _dialog = Just dlg }- toState (EndDialog Confirm) = halt $ state { _dialog = Nothing }- toState (EndDialog Cancel) =- continue $ state { _dialog = Nothing, _gitCommand = GitCheckout }+ confirmDelete :: Maybe Branch -> EventM Name State ()+ confirmDelete (Just (BranchCurrent _)) = pure ()+ confirmDelete (Just _) = dialogL ?= createDialog GitDeleteBranch+ confirmDelete Nothing = pure () -appHandleEventDialog :: Dialog -> BrickEvent Name e -> EventM Name DialogResult-appHandleEventDialog dialog (VtyEvent e) =- let closeDialog = pure $ EndDialog Cancel- dialogAction = pure $ case D.dialogSelection dialog of- Just Cancel -> EndDialog Cancel- Just confirm -> EndDialog confirm- Nothing -> SetDialog dialog- in case vimKey $ lowerKey e of- EvKey KEnter [] -> dialogAction- EvKey KEsc [] -> closeDialog- EvKey (KChar 'q') [] -> closeDialog- ev -> SetDialog <$> D.handleDialogEvent ev dialog-appHandleEventDialog dialog _ = pure $ SetDialog dialog+ fetch = do+ state <- get+ M.suspendAndResume $ do+ branches <- fetchBranches+ pure $ updateBranches branches state -appHandleEventMain :: State -> BrickEvent Name e -> EventM Name (Next State)-appHandleEventMain state (VtyEvent e) =- let- confirm c = state { _gitCommand = c, _dialog = Just $ createDialog c }- confirmDelete (Just (BranchCurrent _)) = continue state- confirmDelete (Just _ ) = continue $ confirm GitDeleteBranch- confirmDelete Nothing = continue state- endWithCheckout = halt $ state { _gitCommand = GitCheckout }- endWithRebase = halt $ state { _gitCommand = GitRebase }- endWithMerge = halt $ state { _gitCommand = GitMerge }- focusLocal = focusBranches RLocal state- focusRemote = focusBranches RRemote state- doFetch = suspendAndResume (fetchBranches state)- resetFilter = filterL .~ emptyFilter- showFilter = isEditingFilterL .~ True- hideFilter = isEditingFilterL .~ False- startEditingFilter =- continue $ updateLists $ resetFilter $ showFilter state- cancelEditingFilter = continue $ hideFilter $ resetFilter state- stopEditingFilter = continue $ hideFilter state- handle = if _isEditingFilter state- then fmap (updateLists <$>) . handleEditingFilter- else handleDefault- handleDefault = \case- EvKey KEsc [] -> quit state- EvKey (KChar 'q') [] -> quit state- EvKey (KChar '/') [] -> startEditingFilter+ handleDefault :: EventM Name State ()+ handleDefault = case event of+ EvKey KEsc [] -> quit+ EvKey (KChar 'q') [] -> quit+ EvKey (KChar '/') [] -> startEditingFilter EvKey (KChar 'f') [MCtrl] -> startEditingFilter- EvKey (KChar 'd') [] -> confirmDelete (selectedBranch state)- EvKey KEnter [] -> endWithCheckout- EvKey (KChar 'c') [] -> endWithCheckout- EvKey (KChar 'r') [] -> endWithRebase- EvKey (KChar 'm') [] -> endWithMerge- EvKey KLeft [] -> focusLocal- EvKey (KChar 'h') [] -> focusLocal- EvKey KRight [] -> focusRemote- EvKey (KChar 'l') [] -> focusRemote- EvKey (KChar 'f') [] -> doFetch- _ -> navigate state e- handleEditingFilter = \case- EvKey KEsc [] -> cancelEditingFilter- EvKey KEnter [] -> stopEditingFilter- EvKey KUp [] -> stopEditingFilter- EvKey KDown [] -> stopEditingFilter- _ -> handleFilter state e- in- handle $ lowerKey e+ EvKey (KChar 'd') [] -> confirmDelete =<< gets selectedBranch+ EvKey KEnter [] -> endWithCheckout+ EvKey (KChar 'c') [] -> endWithCheckout+ EvKey (KChar 'r') [] -> endWithRebase+ EvKey (KChar 'm') [] -> endWithMerge+ EvKey KLeft [] -> focusBranches RLocal+ EvKey (KChar 'h') [] -> focusBranches RLocal+ EvKey KRight [] -> focusBranches RRemote+ EvKey (KChar 'l') [] -> focusBranches RRemote+ EvKey (KChar 'f') [] -> fetch+ _ -> zoom focussedBranchesL $ L.handleListEventVi L.handleListEvent e -appHandleEventMain state _ = continue state+ handleEditingFilter :: EventM Name State ()+ handleEditingFilter = do+ case event of+ EvKey KEsc [] -> cancelEditingFilter+ EvKey KEnter [] -> stopEditingFilter+ EvKey KUp [] -> stopEditingFilter+ EvKey KDown [] -> stopEditingFilter+ _ -> zoom filterL $ E.handleEditorEvent (VtyEvent e)+ modify syncBranchLists+ in+ ifM+ (gets _isEditingFilter)+ handleEditingFilter+ handleDefault +appHandleEventDialog :: Event -> EventM Name State ()+appHandleEventDialog e =+ let+ cancelDialog = do+ dialogL .= Nothing+ gitCommandL .= GitCheckout -navigate :: State -> Event -> EventM Name (Next State)-navigate state event =- continue =<< handleEventLensed state focussedBranchesL update event- where update = L.handleListEventVi L.handleListEvent+ confirmDialog cmd = do+ dialogL .= Nothing+ gitCommandL .= cmd+ halt+ in+ case vimifiedKey e of+ EvKey KEnter [] -> do+ dialog <- gets _dialog+ case D.dialogSelection =<< dialog of+ Just (Confirm cmd) -> confirmDialog cmd+ Just Cancel -> cancelDialog+ Nothing -> pure ()+ EvKey KEsc [] -> cancelDialog+ EvKey (KChar 'q') [] -> cancelDialog+ ev -> zoom (dialogL . _Just) $ D.handleDialogEvent ev -handleFilter :: State -> Event -> EventM Name (Next State)-handleFilter state event =- continue =<< handleEventLensed state filterL E.handleEditorEvent event+quit :: EventM n State ()+quit = focussedBranchesL %= L.listClear >> halt -focusBranches :: RemoteName -> State -> EventM Name (Next State)-focusBranches target state = if isAlreadySelected- then continue state- else do+focusBranches :: RemoteName -> EventM Name State ()+focusBranches target = do+ let isAlreadyFocussed = (target ==) <$> gets _focus+ unlessM isAlreadyFocussed $ do offsetDiff <- listOffsetDiff target- continue $ state & changeList & syncPosition offsetDiff+ modify (changeList . syncPosition offsetDiff) where- isAlreadySelected = state ^. focusL == target- changeList = focusL .~ target- listIndex = fromMaybe 0 $ state ^. currentListL . L.listSelectedL- syncPosition diff = targetListL %~ L.listMoveTo (listIndex - diff)+ changeList = focusL .~ target+ listIndex state = fromMaybe 0 $ state ^. currentListL . L.listSelectedL+ syncPosition diff state = (targetListL %~ L.listMoveTo (listIndex state - diff)) state (currentListL, targetListL) = case target of- RLocal -> (remoteBranchesL, localBranchesL)+ RLocal -> (remoteBranchesL, localBranchesL) RRemote -> (localBranchesL, remoteBranchesL) -listOffsetDiff :: RemoteName -> EventM Name Int+listOffsetDiff :: RemoteName -> EventM Name State Int listOffsetDiff target = do- offLocal <- getOffset Local+ offLocal <- getOffset Local offRemote <- getOffset Remote- return- $ if target == RLocal then offRemote - offLocal else offLocal - offRemote- where getOffset name = maybe 0 (^. vpTop) <$> M.lookupViewport name+ pure $+ if target == RLocal+ then offRemote - offLocal+ else offLocal - offRemote+ where+ getOffset name = maybe 0 (^. vpTop) <$> M.lookupViewport name -fetchBranches :: State -> IO State-fetchBranches state = do- putStrLn "Fetching branches"+fetchBranches :: IO [Branch]+fetchBranches = do+ T.putStrLn "Fetching branches" output <- Git.fetch- putStr output- branches <- Git.listBranches- return $ updateLists state { _branches = branches, _filter = emptyFilter }+ T.putStr output+ Git.listBranches -updateLists :: State -> State-updateLists state =+updateBranches :: [Branch] -> State -> State+updateBranches branches =+ syncBranchLists+ . (branchesL .~ branches)+ . (filterL .~ emptyFilter)++syncBranchLists :: State -> State+syncBranchLists state = state- & localBranchesL- .~ mkList Local local- & remoteBranchesL- .~ mkList Remote remote- & focusL- %~ toggleFocus (local, remote)+ & localBranchesL .~ mkList Local local+ & remoteBranchesL .~ mkList Remote remote+ & focusL %~ toggleFocus (local, remote) where mkList name xs = L.list name (Vec.fromList xs) rowHeight- lower = map toLower- filterString = lower $ unwords $ E.getEditContents $ _filter state- isBranchInFilter = isInfixOf filterString . Git.fullBranchName+ filterText = T.toLower $ T.unwords $ E.getEditContents $ _filter state+ isBranchInFilter = T.isInfixOf filterText . Git.fullBranchName filteredBranches = filter isBranchInFilter (_branches state)- (remote, local) = partition Git.isRemoteBranch filteredBranches+ (remote, local) = partition Git.isRemoteBranch filteredBranches toggleFocus :: ([Branch], [Branch]) -> RemoteName -> RemoteName-toggleFocus ([] , _ : _) RLocal = RRemote-toggleFocus (_ : _, [] ) RRemote = RLocal-toggleFocus _ x = x+toggleFocus ([], _ : _) RLocal = RRemote+toggleFocus (_ : _, []) RRemote = RLocal+toggleFocus _ x = x selectedBranch :: State -> Maybe Branch selectedBranch state = snd <$> L.listSelectedElement (state ^. focussedBranchesL) -createDialog :: GitCommand -> Dialog+createDialog :: GitCommand -> D.Dialog DialogOption createDialog cmd = D.dialog (Just title) (Just (0, choices)) 80 where- choices = [(btnText $ show cmd, Confirm), ("Cancel", Cancel)]- title = map toUpper $ show cmd+ choices = [(btnText $ show cmd, Confirm cmd), ("Cancel", Cancel)]+ title = map toUpper $ show cmd btnText (x : xs) = toUpper x : xs- btnText x = x+ btnText x = x mapKey :: (Char -> Key) -> Event -> Event mapKey f (EvKey (KChar k) []) = EvKey (f k) []-mapKey _ e = e+mapKey _ e = e lowerKey :: Event -> Event lowerKey = mapKey (KChar . toLower) -vimKey :: Event -> Event-vimKey = mapKey vimify+vimifiedKey :: Event -> Event+vimifiedKey = mapKey vimify . lowerKey where vimify 'h' = KLeft vimify 'j' = KRight vimify 'k' = KLeft vimify 'l' = KRight- vimify k = KChar k+ vimify k = KChar k rowHeight :: Int rowHeight = 1@@ -365,22 +378,32 @@ focussedBranchesL :: Lens' State (L.List Name Branch) focussedBranchesL =- let branchLens s = case s ^. focusL of- RLocal -> localBranchesL- RRemote -> remoteBranchesL- in lens (\s -> s ^. branchLens s) (\s bs -> (branchLens s .~ bs) s)+ lens (\s -> s ^. branchLens s) (\s bs -> (branchLens s .~ bs) s)+ where+ branchLens s = case s ^. focusL of+ RLocal -> localBranchesL+ RRemote -> remoteBranchesL localBranchesL :: Lens' State (L.List Name Branch)-localBranchesL = lens _localBranches (\s bs -> s { _localBranches = bs })+localBranchesL = lens _localBranches (\s bs -> s{_localBranches = bs}) remoteBranchesL :: Lens' State (L.List Name Branch)-remoteBranchesL = lens _remoteBranches (\s bs -> s { _remoteBranches = bs })+remoteBranchesL = lens _remoteBranches (\s bs -> s{_remoteBranches = bs}) focusL :: Lens' State RemoteName-focusL = lens _focus (\s f -> s { _focus = f })+focusL = lens _focus (\s f -> s{_focus = f}) -filterL :: Lens' State (E.Editor String Name)-filterL = lens _filter (\s f -> s { _filter = f })+filterL :: Lens' State (E.Editor Text Name)+filterL = lens _filter (\s f -> s{_filter = f}) +branchesL :: Lens' State [Branch]+branchesL = lens _branches (\s f -> s{_branches = f})+ isEditingFilterL :: Lens' State Bool-isEditingFilterL = lens _isEditingFilter (\s f -> s { _isEditingFilter = f })+isEditingFilterL = lens _isEditingFilter (\s f -> s{_isEditingFilter = f})++dialogL :: Lens' State (Maybe (D.Dialog DialogOption))+dialogL = lens _dialog (\s v -> s{_dialog = v})++gitCommandL :: Lens' State GitCommand+gitCommandL = lens _gitCommand (\s v -> s{_gitCommand = v})
app/Main.hs view
@@ -1,29 +1,27 @@-module Main where--import Data.Version ( showVersion )-import Options.Applicative-import Paths_git_brunch ( version )--import qualified GitBrunch+module Main (main) where +import Data.Version (showVersion)+import Options.Applicative+import Paths_git_brunch (version) -data Mode = RunGitBrunch | ShowVersion+import GitBrunch qualified +data Mode+ = RunGitBrunch+ | ShowVersion main :: IO () main = run =<< execParser opts where- opts = info- (versionParser <|> pure RunGitBrunch <**> helper)- (header "git-brunch - A git command-line tool to work with branches")-+ opts =+ info+ (versionParser <|> pure RunGitBrunch <**> helper)+ (header "git-brunch - A git command-line tool to work with branches") run :: Mode -> IO ()-run ShowVersion = putStrLn $ showVersion version+run ShowVersion = putStrLn $ showVersion version run RunGitBrunch = GitBrunch.main - versionParser :: Parser Mode versionParser = flag' ShowVersion (long "version" <> short 'v' <> help "Show version")-
app/Theme.hs view
@@ -1,48 +1,52 @@ module Theme where -import Brick.AttrMap ( AttrName- , attrName- )-import Brick.Themes-import Brick.Util-import Brick.Widgets.Border as Border-import qualified Brick.Widgets.Dialog as Dialog-import qualified Brick.Widgets.Edit as Edit-import qualified Brick.Widgets.List as List-import Graphics.Vty+import Brick.AttrMap (AttrName, attrName)+import Brick.Themes+import Brick.Util+import Brick.Widgets.Border as Border+import Brick.Widgets.Dialog qualified as Dialog+import Brick.Widgets.Edit qualified as Edit+import Brick.Widgets.List qualified as List+import Graphics.Vty theme :: Theme-theme = newTheme- (white `on` brightBlack)- [ (List.listAttr , fg brightWhite)- , (List.listSelectedAttr , fg brightWhite)- , (List.listSelectedFocusedAttr, black `on` brightYellow)- , (Dialog.dialogAttr , fg brightWhite)- , (Dialog.buttonAttr , brightBlack `on` white)- , (Dialog.buttonSelectedAttr , black `on` brightMagenta)- , (Border.borderAttr , fg white)- , (Edit.editFocusedAttr , fg brightWhite)- , (attrKey , withStyle (fg brightMagenta) bold)- , (attrBold , withStyle (fg white) bold)- , (attrUnder , withStyle (fg brightWhite) underline)- , (attrTitle , withStyle (fg brightWhite) bold)- , (attrTitleFocus , withStyle (fg yellow) bold)- , (attrBranchCurrent , fg brightRed)- , (attrBranchCommon , fg brightBlue)- ]-+theme =+ newTheme+ (white `on` brightBlack)+ [ (List.listAttr, fg brightWhite)+ , (List.listSelectedAttr, fg brightWhite)+ , (List.listSelectedFocusedAttr, black `on` brightYellow)+ , (Dialog.dialogAttr, fg brightWhite)+ , (Dialog.buttonAttr, brightBlack `on` white)+ , (Dialog.buttonSelectedAttr, black `on` brightMagenta)+ , (Border.borderAttr, fg white)+ , (Edit.editFocusedAttr, fg brightWhite)+ , (attrKey, withStyle (fg brightMagenta) bold)+ , (attrBold, withStyle (fg white) bold)+ , (attrUnder, withStyle (fg brightWhite) underline)+ , (attrTitle, withStyle (fg brightWhite) bold)+ , (attrTitleFocus, withStyle (fg yellow) bold)+ , (attrBranchCurrent, fg brightRed)+ , (attrBranchCommon, fg brightBlue)+ ] attrKey :: AttrName attrKey = attrName "key"+ attrBold :: AttrName attrBold = attrName "bold"+ attrUnder :: AttrName attrUnder = attrName "under"+ attrTitle :: AttrName attrTitle = attrName "title"+ attrTitleFocus :: AttrName attrTitleFocus = attrName "title-focus"+ attrBranchCurrent :: AttrName attrBranchCurrent = attrName "current-branch"+ attrBranchCommon :: AttrName attrBranchCommon = attrName "common-branch"
git-brunch.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: git-brunch-version: 1.5.1.0+version: 1.6.0.0 synopsis: git checkout command-line tool description: Please see the README on GitHub at <https://github.com/andys8/git-brunch> category: Git@@ -13,7 +13,7 @@ bug-reports: https://github.com/andys8/git-brunch/issues author: andys8 maintainer: andys8@users.noreply.github.com-copyright: 2021 andys8+copyright: 2023 andys8 license: BSD3 license-file: LICENSE build-type: Simple@@ -38,24 +38,30 @@ hs-source-dirs: app default-extensions:- StrictData+ ImportQualifiedPost+ LambdaCase OverloadedStrings+ StrictData build-depends: base >=4.7 && <5 , brick+ , extra , hspec , microlens+ , microlens-mtl+ , mtl , optparse-applicative , process+ , text , vector , vty+ default-language: Haskell2010 if flag(static) ghc-options: -static -threaded -rtsopts -with-rtsopts=-N -Wall -O2 -optl-fuse-ld=bfd cc-options: -static ld-options: -static -pthread else ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -O2- default-language: Haskell2010 test-suite git-brunch-test type: exitcode-stdio-1.0@@ -66,16 +72,22 @@ test app default-extensions:- StrictData+ ImportQualifiedPost+ LambdaCase OverloadedStrings+ StrictData ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 , brick+ , extra , hspec , microlens+ , microlens-mtl+ , mtl , optparse-applicative , process+ , text , vector , vty default-language: Haskell2010
test/Spec.hs view
@@ -1,60 +1,59 @@-import Git-import Test.Hspec+import Data.Text (Text)+import Git+import Test.Hspec main :: IO ()-main = hspec $ describe "Git.toBranch" $ do+main = hspec $+ describe "Git.toBranch" $ do+ it "returns a remote branch is starts with remote" $ do+ toBranches "remotes/origin/master" `shouldBe` [BranchRemote "origin" "master"] - it "returns a remote branch is starts with remote"- $ toBranches "remotes/origin/master"- `shouldBe` [BranchRemote "origin" "master"]+ it "ignores leading spaces" $ do+ toBranches " master" `shouldBe` [BranchLocal "master"] - it "ignores leading spaces"- $ toBranches " master"- `shouldBe` [BranchLocal "master"]+ it "detects current branch by asterik" $ do+ toBranches "* master" `shouldBe` [BranchCurrent "master"] - it "detects current branch by asterik"- $ toBranches "* master"- `shouldBe` [BranchCurrent "master"]+ it "returns a local branch" $ do+ toBranches "master" `shouldBe` [BranchLocal "master"] - it "returns a local branch"- $ toBranches "master"- `shouldBe` [BranchLocal "master"]+ it "returns a branch with head in name" $ do+ toBranches "updateHead" `shouldBe` [BranchLocal "updateHead"] - it "returns a branch with head in name"- $ toBranches "updateHead"- `shouldBe` [BranchLocal "updateHead"]+ it "ignores HEAD" $ do+ toBranches "HEAD" `shouldBe` [] - it "ignores HEAD" $ toBranches "HEAD" `shouldBe` []+ it "ignores empty" $ do+ toBranches "" `shouldBe` [] - it "ignores origin/HEAD" $ toBranches "origin/HEAD" `shouldBe` []+ it "ignores origin/HEAD" $ do+ toBranches "origin/HEAD" `shouldBe` [] - it "ignores detatched HEAD"- $ toBranches "* (HEAD detached at f01a202)"- `shouldBe` []+ it "ignores detatched HEAD" $ do+ toBranches "* (HEAD detached at f01a202)" `shouldBe` [] - it "ignores 'no branch' during rebase"- $ toBranches "* (no branch, rebasing branch-name)"- `shouldBe` []+ it "ignores 'no branch' during rebase" $ do+ toBranches "* (no branch, rebasing branch-name)" `shouldBe` [] - it "parses sample output"- $ toBranches sampleOutput- `shouldBe` [ BranchLocal "experimental/failing-debug-log-demo"- , BranchLocal "gh-pages"- , BranchLocal "master"- , BranchLocal "wip/delete-as-action"- , BranchRemote "origin" "experimental/failing-debug-log-demo"- , BranchRemote "origin" "gh-pages"- , BranchRemote "origin" "master"- ]+ it "parses sample output" $ do+ toBranches sampleOutput+ `shouldBe` [ BranchLocal "experimental/failing-debug-log-demo"+ , BranchLocal "gh-pages"+ , BranchLocal "master"+ , BranchLocal "wip/delete-as-action"+ , BranchRemote "origin" "experimental/failing-debug-log-demo"+ , BranchRemote "origin" "gh-pages"+ , BranchRemote "origin" "master"+ ] -sampleOutput :: String+sampleOutput :: Text sampleOutput = "* (HEAD detached at f01a202)\n"- ++ " experimental/failing-debug-log-demo\n"- ++ " gh-pages\n"- ++ " master\n"- ++ " wip/delete-as-action\n"- ++ " remotes/origin/HEAD -> origin/master\n"- ++ " remotes/origin/experimental/failing-debug-log-demo\n"- ++ " remotes/origin/gh-pages\n"- ++ " remotes/origin/master"+ <> " experimental/failing-debug-log-demo\n"+ <> " gh-pages\n"+ <> " master\n"+ <> " wip/delete-as-action\n"+ <> " remotes/origin/HEAD -> origin/master\n"+ <> " remotes/origin/experimental/failing-debug-log-demo\n"+ <> " remotes/origin/gh-pages\n"+ <> " remotes/origin/master"