From 3810eecbbe7b2c78eaaed28046cd18896e6b8849 Mon Sep 17 00:00:00 2001
From: Fabian Kirchner <kirchner@posteo.de>
Date: Sat, 14 Oct 2023 18:17:52 +0200
Subject: collect issues starting from the first commit via intermediate
IssueEvent's
---
app/History.hs | 164 ++++++++++++++++++++++++++++++++++++++++++++++++---------
1 file changed, 138 insertions(+), 26 deletions(-)
(limited to 'app')
diff --git a/app/History.hs b/app/History.hs
index 59b3961..3a81fa3 100644
--- a/app/History.hs
+++ b/app/History.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -8,11 +9,12 @@ import Data.Aeson (eitherDecode)
import Data.Binary (Binary, decodeFile, encodeFile)
import Data.ByteString.Lazy.Char8 qualified as L8
import Data.Function ((&))
-import Data.List (intercalate)
+import Data.List (foldl', intercalate)
import Data.Maybe (catMaybes, mapMaybe)
import Data.String (fromString)
import Data.Text (Text, lines, unpack)
import Data.Text.Encoding (decodeUtf8)
+import GHC.Generics (Generic)
import Issue (Issue (..), fromMatch, id)
import Issue.Filter (Filter, applyFilter)
import Parallel (parMapM)
@@ -30,34 +32,143 @@ import Prelude qualified as Prelude
listIssues :: [Filter] -> [FilePath] -> IO [Issue]
listIssues filters paths = do
- commitHashes <- getCommitHashes
- issuesWorkingTreeAll <- getIssuesWorkingTreeAll paths
- historicalIssues <- fmap concat $ parMapM (\hash -> cached hash (\_ -> getIssuesCommitChanged hash)) commitHashes
- let currentIssuesFiltered = filter (applyFilter filters) issuesWorkingTreeAll
- pure $ map (fixProvenance historicalIssues) currentIssuesFiltered
+ commitHashes <- fmap reverse getCommitHashes
+ case commitHashes of
+ [] ->
+ pure []
+ hashFirst : hashesRest -> do
+ -- TODO Append ".all" to cache id
+ issuesInitial <- cached hashFirst (\_ -> getIssuesCommitAll hashFirst)
+ -- TODO Append ".changed" to cache id
+ commitInfos <- mapM (\hash -> cached hash (\_ -> getCommitInfo hash)) hashesRest
+ -- TODO We also have to get the issues which changed in the working tree
+ let eventses = getEvents hashFirst issuesInitial commitInfos
+ let issues = mapMaybe issueFromIssueEvents eventses
+ issuesFiltered = filter (applyFilter filters) issues
+ -- FIXME We have to only consider issues in the specified paths
+ pure issuesFiltered
getCommitHashes :: IO [Text]
getCommitHashes =
fmap (lines . decodeUtf8 . L8.toStrict) $ sh "git log --format=%H"
-fixProvenance :: [Issue] -> Issue -> Issue
-fixProvenance historicalIssues =
- merge . pick historicalIssues
+data IssueEvent
+ = IssueCreated
+ { hash :: Text,
+ issue :: Issue
+ }
+ | IssueChanged
+ { hash :: Text,
+ issue :: Issue
+ }
+ | IssueDeleted
+ { hash :: Text
+ }
+ deriving (Show)
-pick :: [Issue] -> Issue -> (Issue, [Issue])
-pick issues issue =
- (issue, filter (isSameIssue) issues)
- where
- isSameIssue otherIssue =
- id otherIssue == id issue
+issueFromIssueEvent :: IssueEvent -> Maybe Issue
+issueFromIssueEvent issueEvent =
+ case issueEvent of
+ IssueCreated {issue} ->
+ Just issue
+ IssueChanged {issue} ->
+ Just issue
+ IssueDeleted _ ->
+ Nothing
-merge :: (Issue, [Issue]) -> Issue
-merge (issue, issues) =
- case (mapMaybe provenance (reverse issues)) of
- [] ->
- issue
- provenance : _ ->
- issue {provenance = Just provenance}
+data CommitInfo = CommitInfo
+ -- TODO Extact CommitInfo so we can change hash' -> hash
+ { hash' :: Text,
+ filesChanged :: [FilePath],
+ issues :: [Issue]
+ }
+ deriving (Show, Binary, Generic)
+
+getCommitInfo :: Text -> IO CommitInfo
+getCommitInfo hash = do
+ (issuesCommitChanged, filesChanged) <- getIssuesAndFilesCommitChanged hash
+ pure $
+ CommitInfo
+ { hash' = hash,
+ filesChanged = filesChanged,
+ issues = issuesCommitChanged
+ }
+
+getEvents :: Text -> [Issue] -> [CommitInfo] -> [[IssueEvent]]
+getEvents hashInitial issuesInitial commitInfos =
+ let issueEventsesInitial =
+ map
+ ( \issueInitial ->
+ [ IssueCreated
+ { hash = hashInitial,
+ issue = issueInitial
+ }
+ ]
+ )
+ issuesInitial
+ addIssueEventsFromCommitInfo issueEventses commitInfo =
+ let issuesCreated =
+ map
+ ( \issue ->
+ [ IssueCreated
+ { hash = commitInfo.hash',
+ issue = issue
+ }
+ ]
+ )
+ $ filter isNewIssue commitInfo.issues
+ isNewIssue issue =
+ all
+ (\issueOther -> id issueOther /= id issue)
+ (mapMaybe issueFromIssueEvents $ issueEventses)
+ addIssueChangedOrDeleted issueEventses' =
+ map
+ ( \issueEvents ->
+ case issueFromIssueEvent $ head issueEvents of
+ Nothing ->
+ issueEvents
+ Just issue ->
+ case filter isSameIssue commitInfo.issues of
+ [] ->
+ if any isSameFile commitInfo.filesChanged
+ then
+ IssueDeleted
+ { hash = commitInfo.hash'
+ }
+ : issueEvents
+ else issueEvents
+ issueCommit : _ ->
+ IssueChanged
+ { hash = commitInfo.hash',
+ issue = issueCommit
+ }
+ : issueEvents
+ where
+ isSameIssue issueCommit =
+ id issueCommit == id issue
+ isSameFile fileChanged =
+ fileChanged == issue.file
+ )
+ issueEventses'
+ in issuesCreated ++ addIssueChangedOrDeleted issueEventses
+ in foldl'
+ ( addIssueEventsFromCommitInfo
+ )
+ issueEventsesInitial
+ commitInfos
+
+issueFromIssueEvents :: [IssueEvent] -> Maybe Issue
+issueFromIssueEvents issueEvents =
+ case issueEvents of
+ IssueCreated {issue} : [] ->
+ Just issue
+ IssueChanged {issue} : _ -> do
+ issueFirst <- issueFromIssueEvent $ head $ reverse issueEvents
+ pure $ issue {provenance = issueFirst.provenance}
+ IssueDeleted _ : _ ->
+ Nothing
+ _ ->
+ Nothing
-- | Gets issues in all files in your current [working
-- - tree](https://git-scm.com/docs/gitglossary#Documentation/gitglossary.txt-aiddefworkingtreeaworkingtree)
@@ -90,16 +201,17 @@ getIssuesCommitAll hash = do
concat <$> catch (getIssuesPar cwd files) (dieOfInvalidTreeGrepperResult)
-- | Given the hash of a commit, get all issues in the files which have
--- been changed by this commit.
-getIssuesCommitChanged :: Text -> IO [Issue]
-getIssuesCommitChanged hash = do
+-- been changed by this commit, as well as all changed files.
+getIssuesAndFilesCommitChanged :: Text -> IO ([Issue], [FilePath])
+getIssuesAndFilesCommitChanged hash = do
withSystemTempDirectory "history" $ \tmp -> do
cwd <- do
let cwd = tmp </> unpack hash
sh_ $ fromString $ printf "git worktree add --detach %s %s" (quote cwd) (quote $ unpack hash)
pure cwd
files <- gitShowChanged cwd
- concat <$> catch (getIssuesPar cwd files) (dieOfInvalidTreeGrepperResult)
+ issues <- concat <$> catch (getIssuesPar cwd files) (dieOfInvalidTreeGrepperResult)
+ pure (issues, files)
gitLsFilesAll :: FilePath -> IO [FilePath]
gitLsFilesAll cwd =
--
cgit v1.2.3