From 3c6e62b75293b6625509ade3c278fc2d4d147c30 Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Thu, 7 Dec 2023 03:55:45 +0100
Subject: chore: increase performance by caching everything
Initial cache generation is slower, as we are losing out on parallelism.
---
app/Debug.hs | 5 +-
app/History.hs | 267 +++++++++++++++++++++++++++++++++++++--
app/History/Cache.hs | 23 +++-
app/History/CommitHash.hs | 16 +--
app/History/CommitInfo.hs | 137 --------------------
app/History/IssueEvent.hs | 4 +-
app/History/PartialCommitInfo.hs | 138 --------------------
app/Issue.hs | 2 +-
app/Main.hs | 26 ++--
app/Patch.hs | 8 +-
app/Text/Diff/Extra.hs | 30 +++++
11 files changed, 336 insertions(+), 320 deletions(-)
delete mode 100644 app/History/CommitInfo.hs
delete mode 100644 app/History/PartialCommitInfo.hs
create mode 100644 app/Text/Diff/Extra.hs
(limited to 'app')
diff --git a/app/Debug.hs b/app/Debug.hs
index c6549a6..6ad9480 100644
--- a/app/Debug.hs
+++ b/app/Debug.hs
@@ -1,4 +1,7 @@
-module Debug where
+module Debug
+ ( debug,
+ )
+where
import Debug.Trace (trace)
import Text.Printf (printf)
diff --git a/app/History.hs b/app/History.hs
index 6a4ddbe..e1ea0ab 100644
--- a/app/History.hs
+++ b/app/History.hs
@@ -1,15 +1,44 @@
module History
- ( getHistory,
+ ( History (..),
+ getHistory,
)
where
-import History.CommitHash (CommitHash)
-import History.CommitInfo (CommitInfo (..), fromPartialCommitInfos, issueEvents)
+import CMark qualified as D
+import Control.Exception (catch, handle, try)
+import Data.Binary (Binary)
+import Data.ByteString.Lazy qualified as LB
+import Data.Function (on, (&))
+import Data.List (deleteFirstsBy, find)
+import Data.List.NonEmpty qualified as N
+import Data.Maybe (catMaybes, isJust)
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Data.Text.IO qualified as T
+import Data.Text.Lazy qualified as LT
+import Data.Text.Lazy.Encoding qualified as LT
+import Die (die)
+import Exception qualified as E
+import GHC.Generics (Generic)
+import Git qualified
+import History.Cache (cachedMaybe)
+import History.CommitHash (CommitHash (..))
+import History.CommitHash qualified as C
import History.IssueEvent (IssueEvent (..))
-import History.PartialCommitInfo (getPartialCommitInfos)
-import Issue (Issue)
+import Issue qualified as I
+import Issue.Parser qualified as I
+import Issue.Provenance qualified as I
+import Issue.Tag qualified as I
+import Issue.Text qualified as I
+import Patch qualified as A
+import Process (proc, sh)
+import Render qualified as P
+import System.Directory (getCurrentDirectory)
+import System.FilePath ((</>))
+import System.IO.Temp (withSystemTempDirectory)
+import System.Process.Typed (setWorkingDir)
+import TreeGrepper.Comment qualified as G
import Tuple ()
-import Prelude hiding (id, lines)
-- TODO Reduce cached data size
--
@@ -27,10 +56,222 @@ import Prelude hiding (id, lines)
-- @topic caching
-- @backlog
-getHistory :: IO [(CommitHash, [IssueEvent], [Issue])]
-getHistory = do
- commitInfos <- fromPartialCommitInfos <$> getPartialCommitInfos
- let commitHashes = map (.hash) commitInfos
- issueses = map (.issues) commitInfos
- issueEventses <- map (._2) <$> issueEvents commitInfos
- pure (zip3 commitHashes issueEventses issueses)
+data History = History
+ { commitHash :: CommitHash,
+ issues :: [I.Issue],
+ issueEvents :: [IssueEvent]
+ }
+ deriving (Show, Generic, Binary)
+
+getHistory :: IO History
+getHistory = getHistoryOf WorkingTree
+
+getHistoryOf :: CommitHash -> IO History
+getHistoryOf commitHash = cachedMaybe (C.toText commitHash) do
+ maybeParentCommitHash <- getParentCommitHashOf commitHash
+ case maybeParentCommitHash of
+ Just parentCommitHash -> do
+ parentHistory <- getHistoryOf parentCommitHash
+ scramble <- getScrambleOf commitHash
+ propagate commitHash parentHistory scramble
+ Nothing -> unsafeAssume commitHash =<< getScrambleOf commitHash
+
+getParentCommitHashOf :: CommitHash -> IO (Maybe CommitHash)
+getParentCommitHashOf commitHash =
+ either
+ (\_ -> Nothing)
+ (Just . Commit . T.strip . T.decodeUtf8 . LB.toStrict)
+ <$> try @E.ProcessException
+ ( case commitHash of
+ WorkingTree -> sh "git show -s --format=%H HEAD"
+ Commit hash -> sh (proc "git show -s --format=%%H %^" hash)
+ )
+
+-- | `Scramble` records the complete issues ONLY in files that have
+-- been changed in the commit.
+data Scramble = Scramble
+ { commitHash :: CommitHash,
+ filesChanged :: [FilePath],
+ issues :: [I.Issue]
+ }
+ deriving (Show, Binary, Generic)
+
+getScrambleOf :: CommitHash -> IO Scramble
+getScrambleOf commitHash@WorkingTree = do
+ (issues, filesChanged) <- getIssuesAndFilesWorkingTreeChanged []
+ pure $ Scramble {..}
+getScrambleOf commitHash@(Commit hash) = do
+ (issues, filesChanged) <- getIssuesAndFilesCommitChanged hash
+ pure $ Scramble {..}
+
+-- | Given the hash of a commit, get all issues in the files which have
+-- been changed by this commit, as well as all changed files.
+getIssuesAndFilesCommitChanged :: T.Text -> IO ([I.Issue], [FilePath])
+getIssuesAndFilesCommitChanged hash = do
+ withSystemTempDirectory "history" $ \tmp -> do
+ let cwd = tmp </> T.unpack hash
+ Git.withWorkingTree cwd hash do
+ files <- gitShowChanged cwd
+ issues <- concat <$> catch (mapM (getIssues cwd) files) dieOfInvalidTreeGrepperResult
+ pure (issues, files)
+
+-- | Get all issues in the given directory and file.
+getIssues :: FilePath -> FilePath -> IO [I.Issue]
+getIssues cwd filename =
+ handle (\(_ :: E.UnknownFileExtension) -> pure []) $
+ fmap catMaybes . mapM (fromComment cwd)
+ =<< G.getComments cwd filename
+
+-- | Note that `provenance` is trivial and needs to be fixed up later.
+fromComment :: FilePath -> G.Comment -> IO (Maybe I.Issue)
+fromComment cwd comment = do
+ commit <- I.commitFromHEAD cwd
+ let provenance = I.Provenance commit commit
+
+ pure $
+ ( \parseResult ->
+ let (markers, title) =
+ I.stripIssueMarkers (T.pack (show (P.render parseResult.heading)))
+ in I.Issue
+ { title = title,
+ description = N.nonEmpty parseResult.paragraphs,
+ file = comment.file,
+ provenance = provenance,
+ start = comment.start,
+ end = comment.end,
+ tags = I.extractTags parseResult.tags,
+ markers = markers,
+ rawText = rawText,
+ commentStyle = commentStyle,
+ comments = N.nonEmpty parseResult.comments,
+ closed = False
+ }
+ )
+ <$> I.parse I.issueMarkers (D.commonmarkToNode [] rawText)
+ where
+ (commentStyle, rawText) = G.uncomment comment.file_type comment.text
+
+dieOfInvalidTreeGrepperResult :: E.InvalidTreeGrepperResult -> IO a
+dieOfInvalidTreeGrepperResult (E.InvalidTreeGrepperResult e) =
+ die e
+
+-- | Gets issues in all files which have been changed in your current
+-- [working
+-- - tree](https://git-scm.com/docs/gitglossary#Documentation/gitglossary.txt-aiddefworkingtreeaworkingtree)
+getIssuesAndFilesWorkingTreeChanged :: [FilePath] -> IO ([I.Issue], [FilePath])
+getIssuesAndFilesWorkingTreeChanged paths = do
+ cwd <- getCurrentDirectory
+ files <- gitLsFilesModifiedIn cwd paths
+ issues <- concat <$> catch (mapM (getIssues cwd) files) dieOfInvalidTreeGrepperResult
+ pure (issues, files)
+
+gitShowChanged :: FilePath -> IO [FilePath]
+gitShowChanged cwd =
+ map T.unpack . T.lines . T.decodeUtf8 . LB.toStrict
+ <$> sh ("git show -p --name-only --format=''" & setWorkingDir cwd)
+
+gitLsFilesModifiedIn :: FilePath -> [FilePath] -> IO [FilePath]
+gitLsFilesModifiedIn cwd paths =
+ map T.unpack . T.lines . T.decodeUtf8 . LB.toStrict
+ <$> sh
+ ( proc "git ls-files --modified %" ("--" : paths)
+ & setWorkingDir cwd
+ )
+
+propagate :: CommitHash -> History -> Scramble -> IO History
+propagate commitHash oldHistory scramble = do
+ let issues = propagateIssues oldHistory.issues scramble
+ issueEvents <- propagateIssueEvents oldHistory.issueEvents oldHistory.issues commitHash issues
+ pure $ History {..}
+
+propagateIssues :: [I.Issue] -> Scramble -> [I.Issue]
+propagateIssues oldIssues partialCommitInfo =
+ mergeListsBy
+ eq
+ ( \old new ->
+ new
+ { I.provenance =
+ I.Provenance
+ { first = old.provenance.first,
+ last =
+ if ((/=) `on` (.rawText)) old new
+ then new.provenance.last
+ else old.provenance.last
+ },
+ I.closed = False
+ }
+ )
+ ( \old ->
+ if elemBy eq old partialCommitInfo.issues
+ || not (old.file `elem` partialCommitInfo.filesChanged)
+ then old
+ else old {I.closed = True}
+ )
+ id
+ oldIssues
+ partialCommitInfo.issues
+
+propagateIssueEvents :: [IssueEvent] -> [I.Issue] -> CommitHash -> [I.Issue] -> IO [IssueEvent]
+propagateIssueEvents oldIssueEvents oldIssues commitHash issues =
+ fmap (oldIssueEvents ++) $ newIssueEvents oldIssues commitHash issues
+
+newIssueEvents :: [I.Issue] -> CommitHash -> [I.Issue] -> IO [IssueEvent]
+newIssueEvents oldIssues' commitHash issues' =
+ sequence $
+ concat
+ [ [IssueCreated commitHash issue <$> patchCreated issue | issue <- deleteFirstsBy eq issues oldIssues],
+ [ IssueChanged commitHash oldIssue newIssue <$> patchChanged oldIssue newIssue
+ | (newIssue : oldIssue : _) <- intersectBy' eq issues oldIssues,
+ neq newIssue oldIssue
+ ],
+ [IssueDeleted commitHash issue <$> patchDeleted issue | issue <- deleteFirstsBy eq oldIssues issues]
+ ]
+ where
+ issues = filter (not . (.closed)) issues'
+ oldIssues = filter (not . (.closed)) oldIssues'
+
+ patchCreated new = diff "" new.rawText
+ patchChanged old new = diff old.rawText new.rawText
+ patchDeleted old = diff old.rawText ""
+
+ diff old new = withSystemTempDirectory "diff" $ \tmp -> do
+ let cwd = tmp
+ T.writeFile (tmp </> "old") old
+ T.writeFile (tmp </> "new") new
+ A.parse . LT.toStrict . LT.decodeUtf8 <$> sh ("git diff --no-index -- old new || :" & setWorkingDir cwd)
+
+unsafeAssume :: CommitHash -> Scramble -> IO History
+unsafeAssume commitHash scramble = do
+ let issues = scramble.issues
+ issueEvents <- propagateIssueEvents [] [] commitHash issues
+ pure $ History {..}
+
+eq :: I.Issue -> I.Issue -> Bool
+eq = (==) `on` (.id)
+
+neq :: I.Issue -> I.Issue -> Bool
+neq = (/=) `on` (.rawText)
+
+mergeListsBy :: (a -> a -> Bool) -> (a -> a -> b) -> (a -> b) -> (a -> b) -> [a] -> [a] -> [b]
+mergeListsBy eq onBoth onLeft onRight lefts rights =
+ concat
+ [ [ maybe (onLeft left) (onBoth left) right
+ | left <- lefts,
+ right <-
+ let rights' = filter (eq left) rights
+ in if null rights' then [Nothing] else (map Just rights')
+ ],
+ [ onRight right
+ | right <- rights,
+ not (elemBy eq right lefts)
+ ]
+ ]
+
+-- | A variant of `Data.List.intersectBy` that retuns the witnesses of the
+-- intersection.
+intersectBy' :: (a -> a -> Bool) -> [a] -> [a] -> [[a]]
+intersectBy' eq xs ys = filter (not . null) (map (\x -> x : filter (eq x) ys) xs)
+
+-- | A variant of `elem` that uses a custom comparison function.
+elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool
+elemBy eq x xs = isJust $ find (eq x) xs
diff --git a/app/History/Cache.hs b/app/History/Cache.hs
index d0473e2..978f3d9 100644
--- a/app/History/Cache.hs
+++ b/app/History/Cache.hs
@@ -1,24 +1,33 @@
-module History.Cache (cached) where
+module History.Cache
+ ( cached,
+ cachedMaybe,
+ )
+where
import Data.Binary (Binary, decodeFileOrFail, encodeFile)
import Data.Text qualified as T
+import Debug
import Git qualified
import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath ((</>))
-cached :: Binary a => T.Text -> (T.Text -> IO a) -> IO a
-cached hash func = do
+cached :: Binary a => T.Text -> IO a -> IO a
+cached key func = do
root <- Git.getRootDir
createDirectoryIfMissing True (root </> ".anissue")
- let file = (root </> ".anissue" </> T.unpack hash)
+ let file = (root </> ".anissue" </> T.unpack key)
doesFileExist file >>= \case
True ->
decodeFileOrFail file >>= \case
- Left _ -> generate file
+ Left e -> debug "e" e `seq` generate file
Right blob -> pure blob
False -> generate file
where
generate file = do
- blob <- func hash
- encodeFile file blob
+ blob <- func
+ encodeFile (debug "cache miss" file) blob
pure blob
+
+cachedMaybe :: Binary a => Maybe T.Text -> IO a -> IO a
+cachedMaybe Nothing func = func
+cachedMaybe (Just key) func = cached key func
diff --git a/app/History/CommitHash.hs b/app/History/CommitHash.hs
index cbe4db1..1075b2f 100644
--- a/app/History/CommitHash.hs
+++ b/app/History/CommitHash.hs
@@ -6,6 +6,7 @@ module History.CommitHash
where
import Data.Binary (Binary)
+import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import GHC.Generics (Generic)
import Render qualified as P
@@ -15,13 +16,12 @@ data CommitHash
| Commit T.Text
deriving (Eq, Show, Binary, Generic)
-toShortText :: CommitHash -> T.Text
-toShortText WorkingTree = "<dirty>"
-toShortText (Commit hash) = T.take 7 hash
+toShortText :: CommitHash -> Maybe T.Text
+toShortText = fmap (T.take 7) . toText
-toText :: CommitHash -> T.Text
-toText WorkingTree = "<dirty>"
-toText (Commit hash) = hash
+toText :: CommitHash -> Maybe T.Text
+toText WorkingTree = Nothing
+toText (Commit hash) = Just hash
instance P.Render CommitHash where
render = P.render . P.Detailed
@@ -29,9 +29,9 @@ instance P.Render CommitHash where
instance P.Render (P.Detailed CommitHash) where
render (P.Detailed commitHash) =
P.styled [P.color P.Yellow] $
- P.render (toText commitHash)
+ P.render (fromMaybe "<dirty>" (toText commitHash))
instance P.Render (P.Summarized CommitHash) where
render (P.Summarized commitHash) =
P.styled [P.color P.Yellow] $
- P.render (toShortText commitHash)
+ P.render (fromMaybe "<dirty>" (toShortText commitHash))
diff --git a/app/History/CommitInfo.hs b/app/History/CommitInfo.hs
deleted file mode 100644
index 2c861a6..0000000
--- a/app/History/CommitInfo.hs
+++ /dev/null
@@ -1,137 +0,0 @@
-module History.CommitInfo
- ( CommitInfo (..),
- fromPartialCommitInfos,
- issueEvents,
- diffCommitInfos,
- )
-where
-
-import Data.Binary (Binary)
-import Data.Function (on, (&))
-import Data.List (deleteFirstsBy, find)
-import Data.Maybe (isJust)
-import Data.Text.IO qualified as T
-import Data.Text.Lazy qualified as LT
-import Data.Text.Lazy.Encoding qualified as LT
-import GHC.Generics (Generic)
-import History.CommitHash (CommitHash)
-import History.IssueEvent (IssueEvent (..))
-import History.PartialCommitInfo (PartialCommitInfo (..))
-import Issue (Issue (..))
-import Issue.Provenance qualified as I
-import Parallel (parSequence)
-import Patch qualified as A
-import Process (sh)
-import System.FilePath ((</>))
-import System.IO.Temp (withSystemTempDirectory)
-import System.Process.Typed (setWorkingDir)
-
--- TODO Change `CommitInfo` -> `CommitIssuesAll`
-data CommitInfo = CommitInfo
- { hash :: CommitHash,
- issues :: [Issue]
- }
- deriving (Show, Binary, Generic)
-
-fromPartialCommitInfos :: [PartialCommitInfo] -> [CommitInfo]
-fromPartialCommitInfos [] = []
-fromPartialCommitInfos (partialCommitInfo : partialCommitInfos) =
- scanl propagate (assume partialCommitInfo) partialCommitInfos
- where
- assume :: PartialCommitInfo -> CommitInfo
- assume (PartialCommitInfo {..}) = CommitInfo {..}
-
- propagate :: CommitInfo -> PartialCommitInfo -> CommitInfo
- propagate oldInfo newInfo@(PartialCommitInfo {..}) =
- CommitInfo
- { issues =
- mergeListsBy
- eq
- ( \old new ->
- new
- { provenance =
- I.Provenance
- { first = old.provenance.first,
- last =
- if ((/=) `on` (.rawText)) old new
- then new.provenance.last
- else old.provenance.last
- },
- closed = False
- }
- )
- ( \old ->
- if elemBy eq old newInfo.issues
- || not (old.file `elem` newInfo.filesChanged)
- then old
- else old {closed = True}
- )
- id
- oldInfo.issues
- newInfo.issues,
- ..
- }
-
- eq = (==) `on` (.id)
-
--- | We assume that [CommitInfo] is sorted starting with the oldest
--- commits.
-issueEvents :: [CommitInfo] -> IO [(CommitHash, [IssueEvent])]
-issueEvents xs = zip (map (.hash) xs) <$> parSequence (zipWith diffCommitInfos predecessors xs)
- where
- predecessors = Nothing : map Just xs
-
-diffCommitInfos :: Maybe CommitInfo -> CommitInfo -> IO [IssueEvent]
-diffCommitInfos maybeOldInfo newInfo =
- sequence $
- concat
- [ [IssueCreated newHash issue <$> patchCreated issue | issue <- deleteFirstsBy eq newIssues oldIssues],
- [ IssueChanged newHash oldIssue newIssue <$> patchChanged oldIssue newIssue
- | (newIssue : oldIssue : _) <- intersectBy' eq newIssues oldIssues,
- neq newIssue oldIssue
- ],
- [IssueDeleted newHash issue <$> patchDeleted issue | issue <- deleteFirstsBy eq oldIssues newIssues]
- ]
- where
- newHash = newInfo.hash
- newIssues' = newInfo.issues
- oldIssues' = maybe [] (.issues) maybeOldInfo
- newIssues = filter (not . (.closed)) newIssues'
- oldIssues = filter (not . (.closed)) oldIssues'
-
- eq = (==) `on` (.id)
- neq = (/=) `on` (.rawText)
-
- patchCreated new = diff "" new.rawText
- patchChanged old new = diff old.rawText new.rawText
- patchDeleted old = diff old.rawText ""
-
- diff old new = withSystemTempDirectory "diff" $ \tmp -> do
- let cwd = tmp
- T.writeFile (tmp </> "old") old
- T.writeFile (tmp </> "new") new
- A.parse . LT.toStrict . LT.decodeUtf8 <$> sh ("git diff --no-index -- old new || :" & setWorkingDir cwd)
-
-mergeListsBy :: (a -> a -> Bool) -> (a -> a -> b) -> (a -> b) -> (a -> b) -> [a] -> [a] -> [b]
-mergeListsBy eq onBoth onLeft onRight lefts rights =
- concat
- [ [ maybe (onLeft left) (onBoth left) right
- | left <- lefts,
- right <-
- let rights' = filter (eq left) rights
- in if null rights' then [Nothing] else (map Just rights')
- ],
- [ onRight right
- | right <- rights,
- not (elemBy eq right lefts)
- ]
- ]
-
--- | A variant of `Data.List.intersectBy` that retuns the witnesses of the
--- intersection.
-intersectBy' :: (a -> a -> Bool) -> [a] -> [a] -> [[a]]
-intersectBy' eq xs ys = filter (not . null) (map (\x -> x : filter (eq x) ys) xs)
-
--- | A variant of `elem` that uses a custom comparison function.
-elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool
-elemBy eq x xs = isJust $ find (eq x) xs
diff --git a/app/History/IssueEvent.hs b/app/History/IssueEvent.hs
index 93bd133..932cfd9 100644
--- a/app/History/IssueEvent.hs
+++ b/app/History/IssueEvent.hs
@@ -1,5 +1,7 @@
module History.IssueEvent (IssueEvent (..)) where
+import Data.Binary (Binary)
+import GHC.Generics (Generic)
import History.CommitHash (CommitHash)
import Issue (Issue)
import Issue.Render qualified as I
@@ -24,7 +26,7 @@ data IssueEvent
issue :: Issue,
patch :: Patch
}
- deriving (Show)
+ deriving (Show, Generic, Binary)
instance P.Render IssueEvent where
render = P.render . P.Detailed
diff --git a/app/History/PartialCommitInfo.hs b/app/History/PartialCommitInfo.hs
deleted file mode 100644
index 6d93e88..0000000
--- a/app/History/PartialCommitInfo.hs
+++ /dev/null
@@ -1,138 +0,0 @@
-module History.PartialCommitInfo
- ( PartialCommitInfo (..),
- getPartialCommitInfos,
- )
-where
-
-import CMark qualified as D
-import Control.Exception (catch, handle)
-import Data.Binary (Binary)
-import Data.ByteString.Lazy.Char8 qualified as LB8
-import Data.Function ((&))
-import Data.List.NonEmpty qualified as N
-import Data.Maybe (catMaybes)
-import Data.Text qualified as T
-import Die (die)
-import Exception qualified as E
-import GHC.Generics (Generic)
-import Git qualified
-import History.Cache (cached)
-import History.CommitHash (CommitHash (..))
-import Issue (Issue (..))
-import Issue.Parser qualified as I
-import Issue.Provenance qualified as I
-import Issue.Tag qualified as I
-import Issue.Text qualified as I
-import Parallel (parMapM)
-import Process (proc, sh)
-import Render qualified as P
-import System.Directory (getCurrentDirectory)
-import System.FilePath ((</>))
-import System.IO.Temp (withSystemTempDirectory)
-import System.Process.Typed (setWorkingDir)
-import TreeGrepper.Comment qualified as G
-
--- | `PartialCommitInfo` records the complete issues ONLY in files that have
--- been changed in the commit.
--- TODO Change `PartialCommitInfo` -> `CommitIssuesChanged`
-data PartialCommitInfo = PartialCommitInfo
- { hash :: CommitHash,
- filesChanged :: [FilePath],
- issues :: [Issue]
- }
- deriving (Show, Binary, Generic)
-
-getPartialCommitInfos :: IO [PartialCommitInfo]
-getPartialCommitInfos = do
- commitHashes <- N.toList <$> Git.getCommitHashes
- parMapM getCommitInfoOf (map Commit commitHashes ++ [WorkingTree])
-
-getCommitInfoOf :: CommitHash -> IO PartialCommitInfo
-getCommitInfoOf WorkingTree = do
- (issues, filesChanged) <- getIssuesAndFilesWorkingTreeChanged []
- pure $
- PartialCommitInfo
- { hash = WorkingTree,
- ..
- }
-getCommitInfoOf (Commit hash) = cached (hash <> (T.pack ".changed")) $ \_ -> do
- (issues, filesChanged) <- getIssuesAndFilesCommitChanged hash
- pure $
- PartialCommitInfo
- { hash = Commit hash,
- ..
- }
-
--- | Given the hash of a commit, get all issues in the files which have
--- been changed by this commit, as well as all changed files.
-getIssuesAndFilesCommitChanged :: T.Text -> IO ([Issue], [FilePath])
-getIssuesAndFilesCommitChanged hash = do
- withSystemTempDirectory "history" $ \tmp -> do
- let cwd = tmp </> T.unpack hash
- Git.withWorkingTree cwd hash do
- files <- gitShowChanged cwd
- issues <- concat <$> catch (mapM (getIssues cwd) files) dieOfInvalidTreeGrepperResult
- pure (issues, files)
-
--- | Get all issues in the given directory and file.
-getIssues :: FilePath -> FilePath -> IO [Issue]
-getIssues cwd filename =
- handle (\(_ :: E.UnknownFileExtension) -> pure []) $
- fmap catMaybes . mapM (fromComment cwd)
- =<< G.getComments cwd filename
-
--- | Note that `provenance` is trivial and needs to be fixed up later.
-fromComment :: FilePath -> G.Comment -> IO (Maybe Issue)
-fromComment cwd comment = do
- commit <- I.commitFromHEAD cwd
- let provenance = I.Provenance commit commit
-
- pure $
- ( \parseResult ->
- let (markers, title) =
- I.stripIssueMarkers (T.pack (show (P.render parseResult.heading)))
- in Issue
- { title = title,
- description = N.nonEmpty parseResult.paragraphs,
- file = comment.file,
- provenance = provenance,
- start = comment.start,
- end = comment.end,
- tags = I.extractTags parseResult.tags,
- markers = markers,
- rawText = rawText,
- commentStyle = commentStyle,
- comments = N.nonEmpty parseResult.comments,
- closed = False
- }
- )
- <$> I.parse I.issueMarkers (D.commonmarkToNode [] rawText)
- where
- (commentStyle, rawText) = G.uncomment comment.file_type comment.text
-
-dieOfInvalidTreeGrepperResult :: E.InvalidTreeGrepperResult -> IO a
-dieOfInvalidTreeGrepperResult (E.InvalidTreeGrepperResult e) =
- die e
-
--- | Gets issues in all files which have been changed in your current
--- [working
--- - tree](https://git-scm.com/docs/gitglossary#Documentation/gitglossary.txt-aiddefworkingtreeaworkingtree)
-getIssuesAndFilesWorkingTreeChanged :: [FilePath] -> IO ([Issue], [FilePath])
-getIssuesAndFilesWorkingTreeChanged paths = do
- cwd <- getCurrentDirectory
- files <- gitLsFilesModifiedIn cwd paths
- issues <- concat <$> catch (mapM (getIssues cwd) files) dieOfInvalidTreeGrepperResult
- pure (issues, files)
-
-gitShowChanged :: FilePath -> IO [FilePath]
-gitShowChanged cwd =
- Prelude.lines . LB8.unpack
- <$> sh ("git show -p --name-only --format=''" & setWorkingDir cwd)
-
-gitLsFilesModifiedIn :: FilePath -> [FilePath] -> IO [FilePath]
-gitLsFilesModifiedIn cwd paths =
- Prelude.lines . LB8.unpack
- <$> sh
- ( proc "git ls-files --modified %" ("--" : paths)
- & setWorkingDir cwd
- )
diff --git a/app/Issue.hs b/app/Issue.hs
index 303862d..2b9e568 100644
--- a/app/Issue.hs
+++ b/app/Issue.hs
@@ -44,7 +44,7 @@ data Issue = Issue
--
-- @related reduce-cached-data-size
instance Binary D.Node where
- put = put . show . P.render
+ put = put . T.pack . show . P.render
get = D.commonmarkToNode [] <$> get
id :: Issue -> T.Text
diff --git a/app/Main.hs b/app/Main.hs
index df63624..fe802ad 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -353,7 +353,7 @@ import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.IO qualified as LT
-import History (getHistory)
+import History (History (..), getHistory)
import Issue (Issue (..))
import Issue qualified as I
import Issue.Filter qualified as I
@@ -517,7 +517,10 @@ idArg =
O.strArgument
( O.metavar "ID"
<> O.completer
- (O.listIOCompleter $ map (T.unpack . I.id) . (._3) . last <$> getHistory)
+ ( O.listIOCompleter $
+ map (T.unpack . I.id) . (.issues)
+ <$> getHistory
+ )
)
editFlag :: O.Parser Bool
@@ -550,8 +553,7 @@ main = do
. I.applyFilters filters
. I.applyPath files
. I.applyClosed closed
- . (._3)
- . last
+ . (.issues)
<$> getHistory
let groupedIssues = I.groupIssuesByTag group ungroupedIssues
putDoc colorize noPager width (group, groupedIssues)
@@ -561,28 +563,26 @@ main = do
. I.applyFilters filters
. I.applyPath files
. I.applyClosed closed
- . (._3)
- . last
+ . (.issues)
<$> getHistory
putDoc colorize noPager width . (P.vsep . intersperse "") $
map (P.render . P.Summarized) issues
Options {colorize, noPager, width, command = Log {patch}} -> do
- ess <- concatMap (._2) . reverse <$> getHistory
+ es <- reverse . (.issueEvents) <$> getHistory
putDoc colorize noPager width . P.vsep $
if patch
- then map (P.render . P.Detailed) ess
- else map (P.render . P.Summarized) ess
+ then map (P.render . P.Detailed) es
+ else map (P.render . P.Summarized) es
Options {colorize, noPager, width, command = Show {id = Nothing}} -> do
issues <-
I.applySorts []
. I.applyFilters []
. I.applyClosed False
- . (._3)
- . last
+ . (.issues)
<$> getHistory
putDoc colorize noPager width . P.vsep $ map (showIssue issues) issues
Options {colorize, noPager, width, command = Show {id = Just id, edit}} -> do
- issues <- (._3) . last <$> getHistory
+ issues <- (.issues) <$> getHistory
issue <-
case find ((==) id . T.unpack . I.id) issues of
Nothing -> die (printf "no issue with id `%s'\n" id)
@@ -597,7 +597,7 @@ main = do
I.replaceText issue =<< T.readFile fp
else putDoc colorize noPager width $ showIssue issues issue
Options {colorize, noPager, width, internalTags, command = Tags} -> do
- issues <- (._3) . last <$> getHistory
+ issues <- (.issues) <$> getHistory
let tags =
concatMap
( \issue ->
diff --git a/app/Patch.hs b/app/Patch.hs
index 0600a34..9e6ed88 100644
--- a/app/Patch.hs
+++ b/app/Patch.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DerivingStrategies #-}
+
module Patch
( Patch,
parse,
@@ -5,17 +7,21 @@ module Patch
where
import Control.Exception (throw)
+import Data.Binary (Binary (..))
import Data.Text qualified as T
import Exception qualified as E
+import GHC.Generics (Generic)
import Render ((<<<))
import Render qualified as P
+import Text.Diff.Extra ()
import Text.Diff.Parse qualified as D
import Text.Diff.Parse.Types qualified as D
newtype Patch = Patch
{ fileDeltas :: D.FileDeltas
}
- deriving (Show)
+ deriving (Show, Generic)
+ deriving newtype (Binary)
parse :: T.Text -> Patch
parse = either (throw . E.InvalidDiff) Patch . D.parseDiff
diff --git a/app/Text/Diff/Extra.hs b/app/Text/Diff/Extra.hs
new file mode 100644
index 0000000..f558495
--- /dev/null
+++ b/app/Text/Diff/Extra.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Text.Diff.Extra where
+
+import Data.Binary (Binary)
+import Generics.Deriving.TH (deriveAll0)
+import Text.Diff.Parse.Types
+
+deriveAll0 ''FileDelta
+deriveAll0 ''FileStatus
+deriveAll0 ''Content
+deriveAll0 ''Hunk
+deriveAll0 ''Range
+deriveAll0 ''Line
+deriveAll0 ''Annotation
+
+instance Binary FileDelta
+
+instance Binary FileStatus
+
+instance Binary Content
+
+instance Binary Hunk
+
+instance Binary Range
+
+instance Binary Line
+
+instance Binary Annotation
--
cgit v1.2.3