Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
124 changes: 64 additions & 60 deletions app/Git.hs
Original file line number Diff line number Diff line change
@@ -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]
Expand All @@ -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
Expand All @@ -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
Expand Down
Loading