1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
|
module Main where
import Control.Monad
import Data.List
import Data.Maybe
import System.Environment
import System.Exit
import System.FilePath
import System.IO
import System.Process
import Text.Read
import Opts
{-
- program & directory work
-}
gitProg :: IO String
gitProg = fromMaybe "git" <$> lookupEnv "DELI_GIT"
gitCmd :: [String] -> IO ()
gitCmd args = do
git <- gitProg
st <- rawSystem git args
unless (st == ExitSuccess) . fail $ "git command failed: " ++ show args
gitCmdOutput :: [String] -> IO String
gitCmdOutput args = do
git <- gitProg
(out, st) <-
withCreateProcess (proc git args) {std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
(,) <$> hGetContents' oh <*> waitForProcess p
unless (st == ExitSuccess) . fail
$ "git output command failed on: " ++ show args
pure out
gitCmdFilter :: [String] -> String -> IO String
gitCmdFilter args input = do
git <- gitProg
(out, st) <-
withCreateProcess
(proc git args) {std_in = CreatePipe, std_out = CreatePipe} $ \(Just ih) (Just oh) _ p ->
(,)
<$> (hPutStr ih input >> hClose ih >> hGetContents' oh)
<*> waitForProcess p
unless (st == ExitSuccess) . fail
$ "git filter command failed on: " ++ show args
pure out
singleLine what = singleObj what . lines
singleObj :: MonadFail m => String -> [a] -> m a
singleObj _ [x] = pure x
singleObj what _ = fail $ "didn't get a single " ++ what
split :: (Char -> Bool) -> String -> [String]
split p [] = []
split p xs = uncurry (:) $ fmap (split p . drop 1) $ break p xs
uniq (x:xs@(y:_))
| x == y = uniq xs
| otherwise = x : uniq xs
uniq [x] = [x]
uniq [] = []
data SourceItem
= SourceFile FilePath
| SourceRange FilePath Int Int
deriving (Show)
itemPath (SourceFile p) = p
itemPath (SourceRange p _ _) = p
sourceItems = start . map words
where
start (("diff":"--git":(a':'/':path):_):ls) = go (SourceFile path) ls
start (_:ls) = start ls
start [] = []
go f (("diff":"--git":(a':'/':path):_):ls)
| SourceFile _ <- f = f : go (SourceFile path) ls
| otherwise = go (SourceFile path) ls
go f (("@@":('-':inrange):('+':_):"@@":_):ls)
| [Just a, Just b] <- map readMaybe $ split (== ',') inrange
, a /= 0
, b /= 0
, r <- SourceRange (itemPath f) a b = r : go r ls
go f (_:ls) = go f ls
go (SourceFile fp) [] = [SourceFile fp]
go _ [] = []
blameItem :: FilePath -> SourceItem -> IO [String]
blameItem base (SourceFile path) =
lines
<$> gitCmdOutput
["log", "-1", "--full-history", "--format=%H", base, "--", path]
blameItem base (SourceRange path r0 r1) =
concatMap (take 1 . words) . lines
<$> gitCmdOutput
[ "annotate"
, "-l"
, "-L"
, show r0 ++ "," ++ show (r0 + r1 - 1)
, base
, "--"
, path
]
indepCommits :: [String] -> IO [String]
indepCommits = go []
where
batch = 32
go acc [] = pure acc
go acc xs =
gitCmdOutput (["merge-base", "--independent"] ++ acc ++ take batch xs)
>>= (`go` drop batch xs) . lines
diffToSources :: String -> String -> String -> IO [String]
diffToSources base commit bottom = do
-- TODO: looks quite like this sometimes selects the head, which is ofc an issue
out <- lines <$> gitCmdOutput ["diff", "-p", "--no-renames", base, commit]
bis <-
fmap (uniq . sort . uniq . concat) . traverse (blameItem base)
$ sourceItems out
indepCommits (bottom : bis)
makeEmptyTree :: IO String
makeEmptyTree =
gitCmdOutput ["hash-object", "-w", "-t", "tree", "--stdin"]
>>= singleLine "hash-object tree output"
makeEmptyCommit :: IO String
makeEmptyCommit = do
et <- makeEmptyTree
let commitObj =
unlines
[ "tree " ++ et
, "author git-deli <git-deli@localhost> 1777294464 +0000"
, "committer git-deli <git-deli@localhost> 1777294464 +0000"
, ""
, "git-deli head commit"
]
ec <-
gitCmdFilter ["hash-object", "-w", "-t", "commit", "--stdin"] commitObj
>>= singleLine "empty commit hash"
pure ec
mergedCommitsTree [] = makeEmptyTree
mergedCommitsTree (c:cs) = go c c cs
where
go _ t [] = pure t
go b t (c1:cs) = do
b' <- gitCmdOutput ["merge-base", b, c1] >>= singleLine "merge base"
t' <-
gitCmdOutput
[ "merge-tree"
, "--write-tree"
, "-Xno-renames"
, "--merge-base=" ++ b'
, t
, c1
]
>>= singleLine "merged tree hash"
go b' t' cs
delinearize :: String -> String -> String -> IO String
delinearize head commit bottom = do
parents <- diffToSources head commit bottom
t <- mergedCommitsTree parents
git <- gitProg
-- create a new tree which is essentially commit-head+mergedtree
t' <-
gitCmdOutput
[ "merge-tree"
, "--write-tree"
, "-Xno-renames"
, "--merge-base=" ++ head
, t
, commit
]
>>= singleLine "transplanted tree hash"
-- now let's get all the data from the original commit and change parents
commitMsg' <- gitCmdOutput ["cat-file", "commit", commit]
let (msgHead, msgBody) = break null $ lines commitMsg'
commitMsg =
unlines
$ concat
[ ["tree " ++ t']
, map ("parent " ++) parents
, filter
(not . flip elem [["parent"], ["tree"]] . take 1 . words)
msgHead
, msgBody
]
-- label the stuff with a proper commit
commit' <-
gitCmdFilter ["hash-object", "-w", "-t", "commit", "--stdin"] commitMsg
>>= singleLine "transplanted commit hash-object"
-- take the old head
headMsg' <- gitCmdOutput ["cat-file", "commit", head]
-- make a new one
let (hHead, hBody) = break null $ lines headMsg'
getP ["parent", x] = [x]
getP _ = []
hParents <- indepCommits . (commit' :) $ concatMap (getP . words) hHead
let headMsg =
unlines
$ concat
[ filter ((== ["tree"]) . take 1 . words) msgHead
, map ("parent " ++) hParents
, filter
(not . flip elem [["parent"], ["tree"]] . take 1 . words)
hHead
, hBody
]
-- write the new head
hcommit' <-
gitCmdFilter ["hash-object", "-w", "-t", "commit", "--stdin"] headMsg
>>= singleLine "new head hash-object"
pure hcommit'
setGitRef :: String -> String -> IO ()
setGitRef refname tgt = gitCmd ["update-ref", refname, tgt]
main = do
opts <- parseOpts
print opts
|
