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