diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright andys8 (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,17 @@ +# git-brunch [![Build Status](https://travis-ci.org/andys8/git-brunch.svg?branch=master)](https://travis-ci.org/andys8/git-brunch) + +A git checkout command-line tool + +![screenshot](./screenshot.png) + +## Install from source + +```sh +git clone https://github.com/andys8/git-brunch.git +cd git-brunch +stack install +``` + +## Usage + +Run `git-brunch` or `git brunch`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import qualified GitBrunch + +main :: IO () +main = GitBrunch.main + diff --git a/git-brunch.cabal b/git-brunch.cabal new file mode 100644 --- /dev/null +++ b/git-brunch.cabal @@ -0,0 +1,80 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: c070cc3b7c8222508470c4607d5321002780988a6453d0b2280b5d811e5fa578 + +name: git-brunch +version: 1.0.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/andys8/git-brunch#readme +bug-reports: https://github.com/andys8/git-brunch/issues +author: andys8 +maintainer: andys8@users.noreply.github.com +copyright: 2019 andys8 +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/andys8/git-brunch + +library + exposed-modules: + Git + GitBrunch + Theme + other-modules: + Paths_git_brunch + hs-source-dirs: + src + 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 + hs-source-dirs: + app + ghc-options: -threaded -static -rtsopts -with-rtsopts=-N + cc-options: -static + ld-options: -static -pthread + build-depends: + base >=4.7 && <5 + , brick + , git-brunch + , microlens + , process + , vector + , vty + default-language: Haskell2010 + +test-suite git-brunch-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_git_brunch + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , brick + , git-brunch + , microlens + , process + , vector + , vty + default-language: Haskell2010 diff --git a/src/Git.hs b/src/Git.hs new file mode 100644 --- /dev/null +++ b/src/Git.hs @@ -0,0 +1,73 @@ +module Git + ( listBranches + , checkout + , Branch(..) + ) +where + +import System.Process +import Data.List +import Data.Char ( isSpace ) +import Data.Either +import System.Exit + +data Branch = BranchLocal String + | BranchCurrent String + | BranchRemote String String + +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 = filter (not . isHead) $ toBranch <$> lines input + +toBranch :: String -> Branch +toBranch line = toBranch $ head $ words $ drop 2 line + where + isCurrent = "*" `isPrefixOf` line + toBranch name + | isCurrent = BranchCurrent name + | otherwise = case stripPrefix "remotes/" name of + Just rest -> parseRemoteBranch rest + Nothing -> BranchLocal name + + +checkout :: Branch -> IO (Either String String) +checkout branch = toEither <$> execGitCheckout (branchName branch) + where + execGitCheckout name = readProcessWithExitCode "git" ["checkout", name] [] + toEither (ExitSuccess , stdout, stderr) = Right $ dropWhile isSpace stdout + toEither (ExitFailure _, stdout, stderr) = Left $ dropWhile isSpace stderr + + +parseRemoteBranch :: String -> Branch +parseRemoteBranch str = BranchRemote remote branchName + where (remote, _ : branchName) = span ('/' /=) str + +--- Helper + +branchName :: Branch -> String +branchName (BranchCurrent n ) = n +branchName (BranchLocal n ) = n +branchName (BranchRemote _ n) = n + + +isHead :: Branch -> Bool +isHead = (== "HEAD") . branchName diff --git a/src/GitBrunch.hs b/src/GitBrunch.hs new file mode 100644 --- /dev/null +++ b/src/GitBrunch.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +module GitBrunch where + +import Control.Monad ( void ) +import Data.Maybe ( fromMaybe ) +import Data.Monoid +import Debug.Trace +import qualified Graphics.Vty as V +import Lens.Micro ( (^.) -- view + , (.~) -- set + , (%~) -- over + , (&) + , Lens' + , Lens + , lens + ) + +import qualified Brick.AttrMap as A +import qualified Brick.Main as M +import Brick.Types ( Widget ) +import Brick.Themes ( themeToAttrMap ) +import qualified Brick.Types as T +import Brick.Util ( fg + , on + ) +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 + , vLimit + , padLeft + , withAttr + , padRight + , withBorderStyle + , (<+>) + , padAll + ) +import qualified Brick.Widgets.List as L +import qualified Data.Vector as Vec +import Data.Maybe as Maybe +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) + print =<< checkout (selectedBranch finalState) + where + print (Left e ) = putStr e + print (Right msg) = putStr msg + checkout (Just b) = Git.checkout b + checkout 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 " " + , vBox + [ drawInstruction "HJKL/arrows" "navigate" + , drawInstruction "Enter" "checkout" + , drawInstruction "Esc/Q" "exit" + ] + ] + ] + where + toBranchList lens = state ^. lens & (\l -> drawBranchList (hasFocus l) l) + hasFocus = (_focus state ==) . L.listName + + +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 selected 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 = + C.hCenter + $ str "Press " + <+> withAttr "key" (str keys) + <+> str " to " + <+> withAttr "bold" (str action) + <+> str "." + + +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 = lens + (\s -> case (^. focusL) s of + Local -> (^. localBranchesL) s + Remote -> (^. remoteBranchesL) s + ) + (\s bs -> case (^. focusL) s of + Local -> (.~) localBranchesL bs s + Remote -> (.~) remoteBranchesL 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 }) diff --git a/src/Theme.hs b/src/Theme.hs new file mode 100644 --- /dev/null +++ b/src/Theme.hs @@ -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) + ] + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"