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
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Git
( module Git.CommitHash,
getCommitHashes,
getRootDir,
getChangedFilesOf,
Commit (..),
Author (..),
getCommitOf,
readTextFileOf,
)
where
import Control.Exception (throw, throwIO)
import Data.Binary (Binary, Put, get, put)
import Data.ByteString.Lazy qualified as LB
import Data.Fixed (Pico)
import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as N
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.Encoding qualified as LT
import Data.Text.Lazy.IO qualified as LT
import Data.Time.Calendar (Day (..), toModifiedJulianDay)
import Data.Time.Clock (DiffTime, UTCTime (..), getCurrentTime, picosecondsToDiffTime)
import Exception qualified as E
import GHC.Generics (Generic)
import Git.CommitHash
import Process (proc, sh)
import Prelude hiding (lines)
getCommitHashes :: IO (NonEmpty T.Text)
getCommitHashes = fromMaybe (throw E.NoCommits) . N.nonEmpty . reverse . T.lines . T.decodeUtf8 . LB.toStrict <$> sh "git log --format=%H"
getRootDir :: IO FilePath
getRootDir = T.unpack . stripTrailingNL . T.decodeUtf8 . LB.toStrict <$> sh (proc "git rev-parse --show-toplevel")
where
stripTrailingNL s = fromMaybe s $ T.stripSuffix "\n" s
getChangedFilesOf :: CommitHash -> IO [FilePath]
getChangedFilesOf WorkingTree = do
map T.unpack . T.lines . T.decodeUtf8 . LB.toStrict
<$> sh "git ls-files --modified"
getChangedFilesOf (Commit hash) = do
map T.unpack . T.lines . T.decodeUtf8 . LB.toStrict
<$> sh (proc "git show -p --name-only --format= %" hash)
data Commit = Commit'
{ commitHash :: CommitHash,
date :: UTCTime,
author :: Author
}
deriving (Show, Generic, Binary, Eq)
data Author = Author
{ name :: T.Text,
email :: T.Text
}
deriving (Show, Generic, Binary, Eq)
-- XXX These are taken from `Data.Binary.Orphans` [1]. I cannot get importing
-- the instance from the package to work.. so we use `-fno-warn-orphans` here.
--
-- [1] https://hackage.haskell.org/package/binary-orphans-0.1.5.1/docs/src/Data-Binary-Orphans.html#line-132
instance Binary UTCTime where
get = UTCTime <$> get <*> get
put (UTCTime d dt) = put d >> put dt
instance Binary Day where
get = fmap ModifiedJulianDay get
put = put . toModifiedJulianDay
instance Binary DiffTime where
get = fmap picosecondsToDiffTime get
put = (put :: Pico -> Put) . realToFrac
getCommitOf :: CommitHash -> IO Commit
getCommitOf commitHash@WorkingTree = do
date <- getCurrentTime
authorName <- T.decodeUtf8 . LB.toStrict <$> sh "git config user.name"
authorEmail <- T.decodeUtf8 . LB.toStrict <$> sh "git config user.email"
pure
Commit'
{ author = Author authorName authorEmail,
..
}
getCommitOf commitHash@(Commit hash) = do
( T.splitOn "\NUL" . head . T.lines . T.decodeUtf8 . LB.toStrict
<$> sh
( proc
"git show --quiet --format=%%ai%%x00%%ae%%x00%%an %"
hash
)
)
>>= \case
rawDate : authorEmail : authorName : _ ->
let date = read (T.unpack rawDate)
in pure
Commit'
{ author = Author authorName authorEmail,
..
}
_ -> throwIO E.NoCommits
-- TODO Fix `readTextFileOf`
--
-- Handle file does not exist in `WorkingTree` case.
readTextFileOf :: CommitHash -> FilePath -> IO LT.Text
readTextFileOf WorkingTree filePath = LT.readFile filePath
readTextFileOf (Commit hash) filePath =
LT.decodeUtf8 <$> sh (proc "git show %:%" hash filePath)
|
