diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright andys8 (c) 2019 +Copyright andys8 (c) 2023 All rights reserved. diff --git a/app/Git.hs b/app/Git.hs --- a/app/Git.hs +++ b/app/Git.hs @@ -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," diff --git a/app/GitBrunch.hs b/app/GitBrunch.hs --- a/app/GitBrunch.hs +++ b/app/GitBrunch.hs @@ -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}) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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") - diff --git a/app/Theme.hs b/app/Theme.hs --- a/app/Theme.hs +++ b/app/Theme.hs @@ -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" diff --git a/git-brunch.cabal b/git-brunch.cabal --- a/git-brunch.cabal +++ b/git-brunch.cabal @@ -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 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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"