1module Git
2  ( Branch(..)
3  , checkout
4  , deleteBranch
5  , fetch
6  , fullBranchName
7  , isCommonBranch
8  , isRemoteBranch
9  , listBranches
10  , rebaseInteractive
11  , merge
12  , toBranches
13  ) where
14
15import           Data.Char                      ( isSpace )
16import           Data.List
17import           System.Exit
18import           System.Process
19
20
21data Branch = BranchLocal String
22            | BranchCurrent String
23            | BranchRemote String String
24            deriving Eq
25
26instance (Show Branch) where
27  show (BranchLocal   n ) = n
28  show (BranchCurrent n ) = n <> "*"
29  show (BranchRemote o n) = o <> "/" <> n
30
31fetch :: IO String
32fetch = readGit ["fetch", "--all", "--prune"]
33
34listBranches :: IO [Branch]
35listBranches = toBranches <$> readGit
36  [ "branch"
37  , "--list"
38  , "--all"
39  , "--sort=-committerdate"
40  , "--no-column"
41  , "--no-color"
42  ]
43
44toBranches :: String -> [Branch]
45toBranches input = toBranch <$> filter validBranch (lines input)
46  where validBranch b = not $ isHead b || isDetachedHead b || isNoBranch b
47
48toBranch :: String -> Branch
49toBranch line = mkBranch $ words $ dropWhile isSpace line
50 where
51  mkBranch ("*" : name : _) = BranchCurrent name
52  mkBranch (name       : _) = case stripPrefix "remotes/" name of
53    Just rest -> parseRemoteBranch rest
54    Nothing   -> BranchLocal name
55  mkBranch [] = error "empty branch name"
56  parseRemoteBranch str = BranchRemote remote name
57    where (remote, _ : name) = span ('/' /=) str
58
59checkout :: Branch -> IO ExitCode
60checkout branch = spawnGit ["checkout", branchName branch]
61
62rebaseInteractive :: Branch -> IO ExitCode
63rebaseInteractive branch = do
64  putStrLn $ "Rebase onto " <> fullBranchName branch
65  spawnGit ["rebase", "--interactive", "--autostash", fullBranchName branch]
66
67merge :: Branch -> IO ExitCode
68merge branch = do
69  putStrLn $ "Merge branch " <> fullBranchName branch
70  spawnGit ["merge", fullBranchName branch]
71
72deleteBranch :: Branch -> IO ExitCode
73deleteBranch (BranchCurrent _ ) = error "Cannot delete current branch"
74deleteBranch (BranchLocal   n ) = spawnGit ["branch", "-D", n]
75deleteBranch (BranchRemote o n) = spawnGit ["push", o, "--delete", n]
76
77spawnGit :: [String] -> IO ExitCode
78spawnGit args = waitForProcess =<< spawnProcess "git" args
79
80readGit :: [String] -> IO String
81readGit args = readProcess "git" args []
82
83isCommonBranch :: Branch -> Bool
84isCommonBranch b =
85  branchName b
86    `elem` [ "master"
87           , "main"
88           , "dev"
89           , "devel"
90           , "develop"
91           , "development"
92           , "staging"
93           , "trunk"
94           ]
95
96
97isRemoteBranch :: Branch -> Bool
98isRemoteBranch (BranchRemote _ _) = True
99isRemoteBranch _                  = False
100
101--- Helper
102
103branchName :: Branch -> String
104branchName (BranchCurrent n ) = n
105branchName (BranchLocal   n ) = n
106branchName (BranchRemote _ n) = n
107
108fullBranchName :: Branch -> String
109fullBranchName (BranchCurrent n ) = n
110fullBranchName (BranchLocal   n ) = n
111fullBranchName (BranchRemote r n) = r <> "/" <> n
112
113isHead :: String -> Bool
114isHead = isInfixOf "HEAD"
115
116isDetachedHead :: String -> Bool
117isDetachedHead = isInfixOf "HEAD detached"
118
119-- While rebasing git will show "no branch"
120-- e.g. "* (no branch, rebasing branch-name)"
121isNoBranch :: String -> Bool
122isNoBranch = isInfixOf "(no branch,"
123