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
|
module Progs where
import Control.Exception
import Control.Monad
import Data.List
import Data.Maybe
import System.Environment
import System.Exit
import System.IO
import System.Process
import Opts
import qualified Toks
bracketFile :: FilePath -> IOMode -> (Handle -> IO c) -> IO c
bracketFile path mode = bracket (openFile path mode) hClose
{-
- interface to gnu diff
-}
diffProg :: IO String
diffProg = fromMaybe "diff" <$> lookupEnv "WERGE_DIFF"
patchProg :: IO String
patchProg = fromMaybe "patch" <$> lookupEnv "WERGE_PATCH"
runDiff :: FilePath -> FilePath -> FilePath -> IO ()
runDiff f1 f2 out = do
diff <- diffProg
st <-
bracketFile out WriteMode $ \oh ->
withCreateProcess
(proc
diff
[ "--text"
, "--new-line-format=+%L"
, "--old-line-format=-%L"
, "--unchanged-line-format= %L"
, f1
, f2
])
{std_in = NoStream, std_out = UseHandle oh} $ \_ _ _ -> waitForProcess
when (st == ExitFailure 2) $ error "diff failed"
unless (st `elem` [ExitSuccess, ExitFailure 1])
$ error "diff failed for unknown reason (is GNU diffutils installed?)"
runDiffRaw :: Int -> FilePath -> FilePath -> FilePath -> IO Bool
runDiffRaw u f1 f2 out = do
diff <- diffProg
st <-
bracketFile out WriteMode $ \oh ->
withCreateProcess
(proc diff ["--text", "--unified=" ++ show u, f1, f2])
{std_in = NoStream, std_out = UseHandle oh} $ \_ _ _ -> waitForProcess
unless (st `elem` [ExitSuccess, ExitFailure 1]) $ error "diff failed"
pure (st /= ExitSuccess) -- report if diff thinks that the files differed
runPatch :: FilePath -> Handle -> IO Bool
runPatch f hi = do
patch <- patchProg
st <-
withCreateProcess
(proc patch ["--silent", "--batch", "--merge=diff3", f])
{std_in = UseHandle hi} $ \_ _ _ -> waitForProcess
unless (st `elem` [ExitSuccess, ExitFailure 1]) $ error "patch failed"
pure (st /= ExitSuccess) -- report if patch thinks that stuff has failed
{-
- interface to git
-}
gitProg :: IO String
gitProg = fromMaybe "git" <$> lookupEnv "WERGE_GIT"
gitRepoRelRoot :: IO FilePath
gitRepoRelRoot = do
git <- gitProg
(path, st) <-
withCreateProcess
(proc git ["rev-parse", "--show-cdup"])
{std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
(,) <$> hGetContents' oh <*> waitForProcess p
unless (st == ExitSuccess) $ error "git failed"
case lines path of
[p] -> pure p
_ -> fail "bad git-rev-parse output"
gitUnmerged :: IO [FilePath]
gitUnmerged = do
git <- gitProg
(paths, st) <-
withCreateProcess
(proc git ["status", "--porcelain=v1"])
{std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
(,)
<$> (map (drop 3) . filter ("UU " `isPrefixOf`) . lines
<$> hGetContents' oh)
<*> waitForProcess p
unless (st == ExitSuccess) $ error "git failed"
pure paths
gitCheckoutMOY ::
Config -> FilePath -> FilePath -> FilePath -> FilePath -> IO ()
gitCheckoutMOY cfg u my old your = do
git <- gitProg
(paths, st) <-
withCreateProcess
(proc git ["ls-files", "--unmerged", "--", u])
{std_in = NoStream, std_out = CreatePipe} $ \_ (Just oh) _ p ->
(,)
<$> (sortOn snd
. map ((\[a, b] -> (a, b)) . take 2 . drop 1 . words)
. lines
<$> hGetContents' oh)
<*> waitForProcess p
unless (st == ExitSuccess) $ error "git failed"
let co (hash, _) path = do
st' <-
withCreateProcess
(proc "git" ["cat-file", "blob", hash])
{std_in = NoStream, std_out = CreatePipe} $ \_ (Just ho) _ p -> do
hSplitToFile cfg ho path
waitForProcess p
unless (st' == ExitSuccess) . error
$ "failed checking out " ++ u ++ " from blob " ++ hash
case paths of
[(_, "1"), (_, "2"), (_, "3")] ->
zipWithM co paths [old, my, your] >> pure ()
_ -> error $ "bad data from ls-files for unmerged " ++ u
gitAdd :: FilePath -> IO ()
gitAdd path = do
git <- gitProg
st <- rawSystem git ["add", "--", path]
unless (st == ExitSuccess) $ error "git-add failed"
{-
- interface to external tokenizers
-
- TODO this might probably enforce joinSpaces?
- or have joinSpaces as configurable? (probably best, default true)
-}
hSplit :: Config -> Handle -> Handle -> IO ()
hSplit cfg hi ho =
case cfgTokenizer cfg of
TokenizeCharCategory -> internal Toks.splitCategory
TokenizeCharCategorySimple -> internal Toks.splitSimple
TokenizeFilter fltr -> do
st <-
withCreateProcess
(shell fltr) {std_in = UseHandle ho, std_out = UseHandle ho} $ \_ _ _ ->
waitForProcess
unless (st == ExitSuccess) $ error "tokenize filter failed"
where
internal s = hGetContents hi >>= hPutStr ho . Toks.toFile . s
hSplitToFile :: Config -> Handle -> FilePath -> IO ()
hSplitToFile cfg hi path = bracketFile path WriteMode $ hSplit cfg hi
|
