git-brunch (empty) → 1.0.0.0
raw patch · 9 files changed
+440/−0 lines, 9 filesdep +basedep +brickdep +git-brunchsetup-changed
Dependencies added: base, brick, git-brunch, microlens, process, vector, vty
Files
- LICENSE +30/−0
- README.md +17/−0
- Setup.hs +2/−0
- app/Main.hs +7/−0
- git-brunch.cabal +80/−0
- src/Git.hs +73/−0
- src/GitBrunch.hs +204/−0
- src/Theme.hs +25/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,17 @@+# git-brunch [](https://travis-ci.org/andys8/git-brunch)++A git checkout command-line tool++++## 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`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import qualified GitBrunch++main :: IO ()+main = GitBrunch.main+
+ git-brunch.cabal view
@@ -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 <https://github.com/andys8/git-brunch#readme>+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
+ src/Git.hs view
@@ -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
+ src/GitBrunch.hs view
@@ -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 })
+ src/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)+ ]+
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"