git-brunch 1.0.6.0 → 1.1.0.0
raw patch · 8 files changed
+334/−327 lines, 8 filesdep −git-brunch
Dependencies removed: git-brunch
Files
- README.md +8/−2
- app/Git.hs +83/−0
- app/GitBrunch.hs +206/−0
- app/Theme.hs +25/−0
- git-brunch.cabal +12/−31
- src/Git.hs +0/−77
- src/GitBrunch.hs +0/−192
- src/Theme.hs +0/−25
README.md view
@@ -1,6 +1,6 @@ # git-brunch [](https://travis-ci.org/andys8/git-brunch) -A git checkout command-line tool+A git checkout and rebase command-line tool  @@ -28,7 +28,7 @@ #### Install ```sh-stack install git-brunch # --resolver=lts-14+stack install git-brunch # --resolver=lts-14.16 ``` #### Clone and install from source@@ -56,6 +56,12 @@ ``` ## Development++### Run application++```shell+./run.sh+``` ### Run tests
+ app/Git.hs view
@@ -0,0 +1,83 @@+module Git+ ( listBranches+ , checkout+ , rebaseInteractive+ , toBranches+ , Branch(..)+ )+where++import System.Process+import Data.List+import Data.Char ( isSpace )+import System.Exit++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+++listBranches :: IO [Branch]+listBranches = toBranches <$> execGitBranch+ where+ execGitBranch = readProcess+ "git"+ [ "branch"+ , "--list"+ , "--all"+ , "--sort=-committerdate"+ , "--no-column"+ , "--no-color"+ ]+ []+++toBranches :: String -> [Branch]+toBranches input = toBranch <$> filter (not . isHead) (lines input)+++toBranch :: String -> Branch+toBranch line = toBranch' $ words $ dropWhile isSpace line+ where+ toBranch' ("*" : name : _) = BranchCurrent name+ toBranch' (name : _) = case stripPrefix "remotes/" name of+ Just rest -> parseRemoteBranch rest+ Nothing -> BranchLocal name+ toBranch' [] = error "empty branch name"+++checkout :: Branch -> IO ExitCode+checkout branch = spawnGit ["checkout", branchName branch]+++rebaseInteractive :: Branch -> IO ExitCode+rebaseInteractive branch =+ spawnGit ["rebase", "--interactive", "--autostash", branchName branch]+++spawnGit :: [String] -> IO ExitCode+spawnGit args = waitForProcess =<< spawnProcess "git" args+++parseRemoteBranch :: String -> Branch+parseRemoteBranch str = BranchRemote remote name+ where (remote, _ : name) = span ('/' /=) str+++--- Helper++branchName :: Branch -> String+branchName (BranchCurrent n ) = n+branchName (BranchLocal n ) = n+branchName (BranchRemote _ n) = n+++isHead :: String -> Bool+isHead = isInfixOf "HEAD"
+ app/GitBrunch.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}+module GitBrunch+ ( main+ )+where++import Data.Maybe ( fromMaybe )+import qualified Graphics.Vty as V+import Lens.Micro ( (^.) -- view+ , (.~) -- set+ , (%~) -- over+ , (&)+ , Lens'+ , lens+ )++import qualified Brick.Main as M+import Brick.Types ( Widget )+import Brick.Themes ( themeToAttrMap )+import qualified Brick.Types as T+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 ( hLimit+ , str+ , vBox+ , hBox+ , padAll+ , padLeft+ , padRight+ , withAttr+ , withBorderStyle+ , (<+>)+ )+import qualified Brick.Widgets.List as L+import qualified Data.Vector as Vec+import Data.List+import Data.Char+import Control.Monad+import System.Exit++import Git+import Theme ( theme )+++data State = State { _focus :: Name, _gitCommand :: GitCommand, _localBranches :: L.List Name Branch, _remoteBranches :: L.List Name Branch }+data Name = Local | Remote deriving (Ord, Eq, Show)+data GitCommand = GitRebase | GitCheckout deriving (Ord, Eq)++instance (Show GitCommand) where+ show GitCheckout = "checkout"+ show GitRebase = "rebase"++main :: IO a+main = do+ branches <- Git.listBranches+ state <- M.defaultMain app $ initialState branches+ let gitCommand = _gitCommand state+ let branch = selectedBranch state+ let runGit = \case+ GitCheckout -> Git.checkout+ GitRebase -> Git.rebaseInteractive+ exitCode <- maybe (die "No branch selected.") (runGit gitCommand) branch+ when (exitCode /= ExitSuccess) $ die ("Failed to " ++ show gitCommand ++ ".")+ exitWith exitCode+++app :: M.App State e Name+app = M.App { M.appDraw = appDraw+ , M.appChooseCursor = M.showFirstCursor+ , M.appHandleEvent = appHandleEvent+ , M.appStartEvent = return+ , M.appAttrMap = const $ themeToAttrMap theme+ }+++appDraw :: State -> [Widget Name]+appDraw state =+ [ C.vCenter $ padAll 1 $ vBox+ [ hBox+ [ C.hCenter $ toBranchList localBranchesL+ , C.hCenter $ toBranchList remoteBranchesL+ ]+ , str " "+ , instructions+ ]+ ]+ where+ toBranchList lens' = state ^. lens' & (\l -> drawBranchList (hasFocus l) l)+ hasFocus = (_focus state ==) . L.listName+ instructions = C.hCenter $ hLimit 100 $ hBox+ [ drawInstruction "HJKL" "navigate"+ , drawInstruction "Enter" "checkout"+ , drawInstruction "R" "rebase"+ , drawInstruction "Esc/Q" "exit"+ ]+++drawBranchList :: Bool -> L.List Name Branch -> Widget Name+drawBranchList hasFocus list =+ withBorderStyle BS.unicodeBold+ $ B.borderWithLabel (drawTitle list)+ $ hLimit 80+ $ L.renderList drawListElement hasFocus list+ where+ title Local = map toUpper "local"+ title Remote = map toUpper "remote"+ drawTitle = withAttr "title" . str . title . L.listName+++drawListElement :: Bool -> Branch -> Widget Name+drawListElement _ branch =+ padLeft (T.Pad 1) $ padRight T.Max $ highlight branch $ str $ show branch+ where+ highlight (BranchCurrent _) = withAttr "current"+ highlight _ = id+++drawInstruction :: String -> String -> Widget n+drawInstruction keys action =+ withAttr "key" (str keys)+ <+> str " to "+ <+> withAttr "bold" (str action)+ & C.hCenter+++appHandleEvent :: State -> T.BrickEvent Name e -> T.EventM Name (T.Next State)+appHandleEvent state (T.VtyEvent e) =+ let endWithCheckout = M.halt $ state { _gitCommand = GitCheckout }+ endWithRebase = M.halt $ state { _gitCommand = GitRebase }+ focusLocal = M.continue $ focusBranches Local state+ focusRemote = M.continue $ focusBranches Remote state+ deleteSelection = focussedBranchesL %~ L.listClear+ quit = M.halt $ deleteSelection state+ in case e of+ V.EvKey V.KEsc [] -> quit+ V.EvKey (V.KChar 'q') [] -> quit+ V.EvKey V.KEnter [] -> endWithCheckout+ V.EvKey (V.KChar 'r') [] -> endWithRebase+ V.EvKey V.KLeft [] -> focusLocal+ V.EvKey (V.KChar 'h') [] -> focusLocal+ V.EvKey V.KRight [] -> focusRemote+ V.EvKey (V.KChar 'l') [] -> focusRemote+ event -> navigate state event++appHandleEvent state _ = M.continue state+++focusBranches :: Name -> State -> State+focusBranches target state = if state ^. focusL == target+ then state+ else state & toL %~ L.listMoveTo selectedIndex & focusL .~ target+ where+ selectedIndex = fromMaybe 0 $ L.listSelected (state ^. fromL)+ (fromL, toL) = case target of+ Local -> (remoteBranchesL, localBranchesL)+ Remote -> (localBranchesL, remoteBranchesL)+++navigate :: State -> V.Event -> T.EventM Name (T.Next State)+navigate state event = do+ let update = L.handleListEventVi L.handleListEvent+ newState <- T.handleEventLensed state focussedBranchesL update event+ M.continue newState+++initialState :: [Branch] -> State+initialState branches = State+ { _focus = Local+ , _gitCommand = GitCheckout+ , _localBranches = L.list Local (Vec.fromList local) 1+ , _remoteBranches = L.list Remote (Vec.fromList remote) 1+ }+ where+ (remote, local) = partition isRemote branches+ isRemote (BranchRemote _ _) = True+ isRemote _ = False+++selectedBranch :: State -> Maybe Branch+selectedBranch state =+ snd <$> L.listSelectedElement (state ^. focussedBranchesL)+++-- Lens++focussedBranchesL :: Lens' State (L.List Name Branch)+focussedBranchesL =+ let branchLens s = case s ^. focusL of+ Local -> localBranchesL+ Remote -> remoteBranchesL+ in lens (\s -> s ^. branchLens s) (\s bs -> (branchLens s .~ bs) s)+++localBranchesL :: Lens' State (L.List Name Branch)+localBranchesL = lens _localBranches (\s bs -> s { _localBranches = bs })+++remoteBranchesL :: Lens' State (L.List Name Branch)+remoteBranchesL = lens _remoteBranches (\s bs -> s { _remoteBranches = bs })+++focusL :: Lens' State Name+focusL = lens _focus (\s f -> s { _focus = f })
+ app/Theme.hs view
@@ -0,0 +1,25 @@+module Theme+ ( theme+ )+where++import Graphics.Vty+import qualified Brick.Widgets.List as List+import Brick.AttrMap ( attrName )+import Brick.Util+import Brick.Themes ( Theme+ , newTheme+ )++theme :: Theme+theme = newTheme+ (white `on` brightBlack)+ [ (List.listAttr , fg brightWhite)+ , (List.listSelectedAttr , fg brightWhite)+ , (List.listSelectedFocusedAttr, black `on` brightYellow)+ , (attrName "key" , withStyle (fg brightMagenta) bold)+ , (attrName "bold" , withStyle (fg white) bold)+ , (attrName "current" , fg brightRed)+ , (attrName "title" , withStyle (fg yellow) bold)+ ]+
git-brunch.cabal view
@@ -1,13 +1,13 @@-cabal-version: 2.0+cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.32.0. -- -- see: https://github.com/sol/hpack ----- hash: 444816bc5a9f874d6d5e86b15596505e88251387994393c341e0268092854eb6+-- hash: e39bbe53176fc36aa7200347481774d5d8bdab8efe1a1da737f3c03abbb2d806 name: git-brunch-version: 1.0.6.0+version: 1.1.0.0 synopsis: git checkout command-line tool description: Please see the README on GitHub at <https://github.com/andys8/git-brunch#readme> category: Git@@ -15,7 +15,7 @@ bug-reports: https://github.com/andys8/git-brunch/issues author: andys8 maintainer: andys8@users.noreply.github.com-copyright: 2019 andys8+copyright: 2020 andys8 license: BSD3 license-file: LICENSE build-type: Simple@@ -30,61 +30,42 @@ manual: True default: False -library git-brunch-lib- exposed-modules:- Git- GitBrunch- Theme- other-modules:- Paths_git_brunch- hs-source-dirs:- src- ghc-options: -Wall- build-depends:- base >=4.7 && <5- , brick- , microlens- , process- , vector- , vty- default-language: Haskell2010- executable git-brunch main-is: Main.hs other-modules:- Paths_git_brunch- autogen-modules:+ Git+ GitBrunch+ Theme Paths_git_brunch hs-source-dirs: app build-depends: base >=4.7 && <5 , brick- , git-brunch-lib , microlens , process , vector , vty if flag(static)- ghc-options: -static -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -static -threaded -rtsopts -with-rtsopts=-N -Wall cc-options: -static ld-options: -static -pthread else- ghc-options: -threaded -rtsopts -with-rtsopts=-N+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010 test-suite git-brunch-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules:- Paths_git_brunch+ Git hs-source-dirs: test+ app ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.7 && <5 , brick- , git-brunch-lib , hspec , microlens , process
− src/Git.hs
@@ -1,77 +0,0 @@-module Git- ( listBranches- , checkout- , toBranches- , Branch(..)- )-where--import System.Process-import Data.List-import Data.Char ( isSpace )-import System.Exit--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---listBranches :: IO [Branch]-listBranches = toBranches <$> execGitBranch- where- execGitBranch = readProcess- "git"- [ "branch"- , "--list"- , "--all"- , "--sort=-committerdate"- , "--no-column"- , "--no-color"- ]- []---toBranches :: String -> [Branch]-toBranches input = toBranch <$> filter (not . isHead) (lines input)---toBranch :: String -> Branch-toBranch line = toBranch' $ words $ dropWhile isSpace line- where- toBranch' ("*" : name : _) = BranchCurrent name- toBranch' (name : _) = case stripPrefix "remotes/" name of- Just rest -> parseRemoteBranch rest- Nothing -> BranchLocal name- toBranch' [] = error "empty branch name"---checkout :: Branch -> IO (Either String String)-checkout branch = toEither <$> execGitCheckout (branchName branch)- where- execGitCheckout name = readProcessWithExitCode "git" ["checkout", name] []- toEither (ExitSuccess , stdout, _ ) = Right $ dropWhile isSpace stdout- toEither (ExitFailure _, _ , stderr) = Left $ dropWhile isSpace stderr---parseRemoteBranch :: String -> Branch-parseRemoteBranch str = BranchRemote remote name- where (remote, _ : name) = span ('/' /=) str------ Helper--branchName :: Branch -> String-branchName (BranchCurrent n ) = n-branchName (BranchLocal n ) = n-branchName (BranchRemote _ n) = n---isHead :: String -> Bool-isHead = isInfixOf "HEAD"
− src/GitBrunch.hs
@@ -1,192 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-module GitBrunch- ( main- )-where--import Data.Maybe ( fromMaybe )-import qualified Graphics.Vty as V-import Lens.Micro ( (^.) -- view- , (.~) -- set- , (%~) -- over- , (&)- , Lens'- , lens- )--import qualified Brick.Main as M-import Brick.Types ( Widget )-import Brick.Themes ( themeToAttrMap )-import qualified Brick.Types as T-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 ( hLimit- , str- , vBox- , hBox- , padAll- , padLeft- , padRight- , withAttr- , withBorderStyle- , (<+>)- )-import qualified Brick.Widgets.List as L-import qualified Data.Vector as Vec-import Data.List-import Data.Char--import Git-import Theme ( theme )---data Name = Local | Remote deriving (Ord, Eq, Show)-data State = State { _focus :: Name, _localBranches :: L.List Name Branch, _remoteBranches :: L.List Name Branch }---main :: IO ()-main = do- branches <- Git.listBranches- finalState <- M.defaultMain app (initialState branches)- printResult =<< checkoutBranch (selectedBranch finalState)- where- printResult (Left err) = putStrLn err- printResult (Right msg) = putStr msg- checkoutBranch (Just b) = Git.checkout b- checkoutBranch Nothing = pure $ Left "No branch selected."---app :: M.App State e Name-app = M.App { M.appDraw = appDraw- , M.appChooseCursor = M.showFirstCursor- , M.appHandleEvent = appHandleEvent- , M.appStartEvent = return- , M.appAttrMap = const $ themeToAttrMap theme- }---appDraw :: State -> [Widget Name]-appDraw state =- [ C.vCenter $ padAll 1 $ vBox- [ hBox- [ C.hCenter $ toBranchList localBranchesL- , C.hCenter $ toBranchList remoteBranchesL- ]- , str " "- , instructions- ]- ]- where- toBranchList lens' = state ^. lens' & (\l -> drawBranchList (hasFocus l) l)- hasFocus = (_focus state ==) . L.listName- instructions = C.hCenter $ hLimit 100 $ hBox- [ drawInstruction "HJKL/arrows" "navigate"- , drawInstruction "Enter" "checkout"- , drawInstruction "Esc/Q" "exit"- ]---drawBranchList :: Bool -> L.List Name Branch -> Widget Name-drawBranchList hasFocus list =- withBorderStyle BS.unicodeBold- $ B.borderWithLabel (drawTitle list)- $ hLimit 80- $ L.renderList drawListElement hasFocus list- where- title Local = map toUpper "local"- title Remote = map toUpper "remote"- drawTitle = withAttr "title" . str . title . L.listName---drawListElement :: Bool -> Branch -> Widget Name-drawListElement _ branch =- padLeft (T.Pad 1) $ padRight T.Max $ highlight branch $ str $ show branch- where- highlight (BranchCurrent _) = withAttr "current"- highlight _ = id---drawInstruction :: String -> String -> Widget n-drawInstruction keys action =- withAttr "key" (str keys)- <+> str " to "- <+> withAttr "bold" (str action)- & C.hCenter---appHandleEvent :: State -> T.BrickEvent Name e -> T.EventM Name (T.Next State)-appHandleEvent state (T.VtyEvent e) =- let checkoutBranch = M.halt state- focusLocal = M.continue $ focusBranches Local state- focusRemote = M.continue $ focusBranches Remote state- deleteSelection = focussedBranchesL %~ L.listClear- quit = M.halt $ deleteSelection state- in case e of- V.EvKey V.KEsc [] -> quit- V.EvKey (V.KChar 'q') [] -> quit- V.EvKey V.KEnter [] -> checkoutBranch- V.EvKey V.KLeft [] -> focusLocal- V.EvKey (V.KChar 'h') [] -> focusLocal- V.EvKey V.KRight [] -> focusRemote- V.EvKey (V.KChar 'l') [] -> focusRemote- event -> navigate state event-appHandleEvent state _ = M.continue state---focusBranches :: Name -> State -> State-focusBranches target state = if state ^. focusL == target- then state- else state & toL %~ L.listMoveTo selectedIndex & focusL .~ target- where- selectedIndex = fromMaybe 0 $ L.listSelected (state ^. fromL)- (fromL, toL) = case target of- Local -> (remoteBranchesL, localBranchesL)- Remote -> (localBranchesL, remoteBranchesL)---navigate :: State -> V.Event -> T.EventM Name (T.Next State)-navigate state event = do- let update = L.handleListEventVi L.handleListEvent- newState <- T.handleEventLensed state focussedBranchesL update event- M.continue newState---initialState :: [Branch] -> State-initialState branches = State- { _focus = Local- , _localBranches = L.list Local (Vec.fromList local) 1- , _remoteBranches = L.list Remote (Vec.fromList remote) 1- }- where- (remote, local) = partition isRemote branches- isRemote (BranchRemote _ _) = True- isRemote _ = False---selectedBranch :: State -> Maybe Branch-selectedBranch state =- snd <$> L.listSelectedElement (state ^. focussedBranchesL)----- Lens--focussedBranchesL :: Lens' State (L.List Name Branch)-focussedBranchesL =- let branchLens s = case s ^. focusL of- Local -> localBranchesL- Remote -> remoteBranchesL- in lens (\s -> s ^. branchLens s) (\s bs -> (branchLens s .~ bs) s)---localBranchesL :: Lens' State (L.List Name Branch)-localBranchesL = lens _localBranches (\s bs -> s { _localBranches = bs })---remoteBranchesL :: Lens' State (L.List Name Branch)-remoteBranchesL = lens _remoteBranches (\s bs -> s { _remoteBranches = bs })---focusL :: Lens' State Name-focusL = lens _focus (\s f -> s { _focus = f })
− src/Theme.hs
@@ -1,25 +0,0 @@-module Theme- ( theme- )-where--import Graphics.Vty-import qualified Brick.Widgets.List as List-import Brick.AttrMap ( attrName )-import Brick.Util-import Brick.Themes ( Theme- , newTheme- )--theme :: Theme-theme = newTheme- (white `on` brightBlack)- [ (List.listAttr , fg brightWhite)- , (List.listSelectedAttr , fg brightWhite)- , (List.listSelectedFocusedAttr, black `on` brightYellow)- , (attrName "key" , withStyle (fg brightMagenta) bold)- , (attrName "bold" , withStyle (fg white) bold)- , (attrName "current" , fg brightRed)- , (attrName "title" , withStyle (fg yellow) bold)- ]-