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
|
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"
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?)"
{-
- 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)
-}
hSplitToFile :: Config -> Handle -> FilePath -> IO ()
hSplitToFile cfg h path =
case cfgTokenizer cfg of
TokenizeCharCategory -> internal Toks.splitCategory
TokenizeCharCategorySimple -> internal Toks.splitSimple
TokenizeFilter fltr -> do
st <-
bracketFile path WriteMode $ \ho ->
withCreateProcess
(shell fltr) {std_in = UseHandle h, std_out = UseHandle ho} $ \_ _ _ ->
waitForProcess
unless (st == ExitSuccess) $ error "tokenize filter failed"
where
internal s = hGetContents h >>= writeFile path . Toks.toFile . s
|
