diff --git a/app/Git.hs b/app/Git.hs index afac856..e879f61 100644 --- a/app/Git.hs +++ b/app/Git.hs @@ -1,61 +1,65 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -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 - - -data Branch = BranchLocal String - | BranchCurrent String - | BranchRemote String String - deriving Eq - -instance (Show Branch) where - show (BranchLocal n ) = n - show (BranchCurrent n ) = n <> "*" +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 + +data Branch + = BranchLocal String + | BranchCurrent String + | BranchRemote String String + deriving (Eq) + +instance Show Branch where + show (BranchLocal n) = n + show (BranchCurrent n) = n <> "*" show (BranchRemote o n) = o <> "/" <> n fetch :: IO String 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 + where + validBranch b = not $ isHead b || isDetachedHead b || isNoBranch b toBranch :: String -> Branch toBranch line = mkBranch $ words $ dropWhile isSpace line where mkBranch ("*" : name : _) = BranchCurrent name - mkBranch (name : _) = case stripPrefix "remotes/" name of + mkBranch (name : _) = case 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) = span ('/' /=) str + name = drop 1 rest checkout :: Branch -> IO ExitCode checkout branch = spawnGit ["checkout", branchName branch] @@ -71,8 +75,8 @@ merge branch = do 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 @@ -82,33 +86,33 @@ readGit :: [String] -> IO String readGit args = readProcess "git" 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 (BranchCurrent n) = n +branchName (BranchLocal n) = n branchName (BranchRemote _ n) = n fullBranchName :: Branch -> String -fullBranchName (BranchCurrent n ) = n -fullBranchName (BranchLocal n ) = n +fullBranchName (BranchCurrent n) = n +fullBranchName (BranchLocal n) = n fullBranchName (BranchRemote r n) = r <> "/" <> n isHead :: String -> Bool diff --git a/app/GitBrunch.hs b/app/GitBrunch.hs index b5871ba..b3a7fe9 100644 --- a/app/GitBrunch.hs +++ b/app/GitBrunch.hs @@ -1,148 +1,155 @@ -{-# LANGUAGE LambdaCase #-} 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 Git ( Branch(..) ) -import qualified Git -import Theme - - -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 +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.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 Git qualified +import Theme + +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 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 String 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 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 - } - -appDraw :: State -> [Widget Name] -appDraw state = - drawDialog state - : [ C.vCenter $ padAll 1 $ maxWidth 200 $ vBox - [branchLists, filterEdit, padding, instructions] - ] +app = + M.App + { M.appDraw = drawApp + , M.appChooseCursor = M.showFirstCursor + , M.appHandleEvent = appHandleEvent + , M.appStartEvent = pure () + , M.appAttrMap = const $ themeToAttrMap theme + } + +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: " + 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 @@ -156,11 +163,11 @@ drawDialog state = case _dialog state of 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 @@ -168,193 +175,199 @@ drawListElement isListFocussed branch = 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 keys action = withAttr attrKey (str keys) <+> str " to " <+> withAttr attrBold (str 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 + & C.hCenter + +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 - -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 } - -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 - -appHandleEventMain :: State -> BrickEvent Name e -> EventM Name (Next State) -appHandleEventMain state (VtyEvent e) = +appHandleEventMain :: Event -> EventM Name State () +appHandleEventMain 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 + 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 + + confirmDelete :: Maybe Branch -> EventM Name State () + confirmDelete (Just (BranchCurrent _)) = pure () + confirmDelete (Just _) = dialogL ?= createDialog GitDeleteBranch + confirmDelete Nothing = pure () + + fetch = do + state <- get + M.suspendAndResume $ do + branches <- fetchBranches + pure $ updateBranches branches state + + 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 - -appHandleEventMain state _ = continue state - - -navigate :: State -> Event -> EventM Name (Next State) -navigate state event = - continue =<< handleEventLensed state focussedBranchesL update event - where update = L.handleListEventVi L.handleListEvent - -handleFilter :: State -> Event -> EventM Name (Next State) -handleFilter state event = - continue =<< handleEventLensed state filterL E.handleEditorEvent (VtyEvent event) - -focusBranches :: RemoteName -> State -> EventM Name (Next State) -focusBranches target state = if isAlreadySelected - then continue state - else do + 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 + + 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 + + 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 + +quit :: EventM n State () +quit = focussedBranchesL %= L.listClear >> halt + +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 +fetchBranches :: IO [Branch] +fetchBranches = do putStrLn "Fetching branches" output <- Git.fetch putStr output - branches <- Git.listBranches - return $ updateLists state { _branches = branches, _filter = emptyFilter } + 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 + lower = map toLower + filterString = lower $ unwords $ E.getEditContents $ _filter state isBranchInFilter = isInfixOf filterString . 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 @@ -363,22 +376,32 @@ rowHeight = 1 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 _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 index 780e58f..3b50888 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,29 +1,27 @@ -module Main where +module Main (main) where -import Data.Version ( showVersion ) -import Options.Applicative -import Paths_git_brunch ( version ) +import Data.Version (showVersion) +import Options.Applicative +import Paths_git_brunch (version) -import qualified GitBrunch - - -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 index c77a8a0..9dd22b4 100644 --- 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 index 02039e5..82cf3a4 100644 --- a/git-brunch.cabal +++ b/git-brunch.cabal @@ -38,13 +38,18 @@ executable git-brunch 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 , vector @@ -66,14 +71,19 @@ test-suite git-brunch-test 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 , vector diff --git a/package.yaml b/package.yaml index 90ade95..fe92974 100644 --- a/package.yaml +++ b/package.yaml @@ -17,7 +17,10 @@ description: Please see the README on GitHub at = 4.7 && < 5 - brick + - extra - microlens + - microlens-mtl + - mtl - process - vector - vty @@ -25,8 +28,10 @@ dependencies: - hspec # workaround for language servers default-extensions: - - StrictData + - ImportQualifiedPost + - LambdaCase - OverloadedStrings + - StrictData flags: static: diff --git a/stack.yaml b/stack.yaml index 5345dcd..3c46428 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: nightly-2022-08-02 +resolver: lts-20.4 # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/stack.yaml.lock b/stack.yaml.lock index 023d112..7d9790a 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 619227 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/8/2.yaml - sha256: ce4257dd36ba3b96eeee64cfb08884ddb46dd73f81f8b25a71658834edc607e2 - original: nightly-2022-08-02 + sha256: 3770dfd79f5aed67acdcc65c4e7730adddffe6dba79ea723cfb0918356fc0f94 + size: 648660 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/4.yaml + original: lts-20.4 diff --git a/test/Spec.hs b/test/Spec.hs index d68bf72..3899ed0 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,51 +1,48 @@ -import Git -import Test.Hspec +import Git +import Test.Hspec main :: IO () 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 =