refactor history

15 files changed, 484 insertions, 416 deletions

diff --git a/anissue.cabal b/anissue.cabal
index f2e62cb..7b3a9e7 100644
--- a/anissue.cabal
+++ b/anissue.cabal
@@ -66,8 +66,15 @@ executable anissue
 
     -- Modules included in this executable, other than Main.
     other-modules:
+      Die
+      Exception
       Git
       History
+      History.Cache
+      History.CommitHash
+      History.CommitInfo
+      History.IssueEvent
+      History.PartialCommitInfo
       Issue
       Issue.Filter
       Issue.Provenance
@@ -120,5 +127,6 @@ executable anissue
       OverloadedRecordDot
       OverloadedStrings
       PartialTypeSignatures
+      RecordWildCards
       TypeFamilies
       ViewPatterns
diff --git a/app/Die.hs b/app/Die.hs
new file mode 100644
index 0000000..a14f6b8
--- /dev/null
+++ b/app/Die.hs
@@ -0,0 +1,9 @@
+module Die (die) where
+
+import System.Exit (ExitCode (ExitFailure), exitWith)
+import Text.Printf (printf)
+
+die :: String -> IO a
+die s = do
+  printf "error: %s\n" s
+  exitWith (ExitFailure 1)
diff --git a/app/Exception.hs b/app/Exception.hs
new file mode 100644
index 0000000..83d624d
--- /dev/null
+++ b/app/Exception.hs
@@ -0,0 +1,38 @@
+module Exception
+  ( AnyException (..),
+    InvalidTreeGrepperResult (..),
+    ProcessException (..),
+    UnknownFileExtension (..),
+  )
+where
+
+import Control.Exception
+import Data.ByteString.Lazy.Char8 as LB
+import System.Exit (ExitCode)
+
+data AnyException
+  = InvalidTreeGrepperResult' InvalidTreeGrepperResult
+  | ProcessException' ProcessException
+  | UnknownFileExtension' UnknownFileExtension
+  deriving (Show)
+
+instance Exception AnyException
+
+data InvalidTreeGrepperResult = InvalidTreeGrepperResult
+  { error :: String
+  }
+  deriving (Show)
+
+instance Exception InvalidTreeGrepperResult
+
+data ProcessException = ProcessException String ExitCode LB.ByteString
+  deriving (Show)
+
+instance Exception ProcessException
+
+data UnknownFileExtension = UnknownFileExtension
+  { extension :: String
+  }
+  deriving (Show)
+
+instance Exception UnknownFileExtension
diff --git a/app/Git.hs b/app/Git.hs
index 57fffdc..7891288 100644
--- a/app/Git.hs
+++ b/app/Git.hs
@@ -1,15 +1,24 @@
-module Git (withWorkingTree) where
+module Git
+  ( withWorkingTree,
+    getCommitHashes,
+  )
+where
 
 import Control.Exception (finally)
-import Data.Text (Text)
-import Process (proc, sh_)
+import Data.ByteString.Lazy.Char8 qualified as LB8
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Process (proc, sh, sh_)
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath (dropTrailingPathSeparator, takeDirectory)
 
 -- | Runs an IO-action within a working tree.
-withWorkingTree :: FilePath -> Text -> IO a -> IO a
+withWorkingTree :: FilePath -> T.Text -> IO a -> IO a
 withWorkingTree path hash action = do
   createDirectoryIfMissing True (takeDirectory (dropTrailingPathSeparator path))
   sh_ $ proc "git worktree add --quiet --detach % %" path hash
   action `finally` do
     sh_ $ proc "git worktree remove --force %" path
+
+getCommitHashes :: IO [T.Text]
+getCommitHashes = T.lines . T.decodeUtf8 . LB8.toStrict <$> sh "git log --format=%H"
diff --git a/app/History.hs b/app/History.hs
index 002ca32..efb7015 100644
--- a/app/History.hs
+++ b/app/History.hs
@@ -1,373 +1,31 @@
 module History
-  ( getIssues,
-    listIssues,
-    listEvents,
-    IssueEvent (..),
+  ( getHistory,
   )
 where
 
-import Control.Exception (Exception, catch, handle, throw)
-import Data.Aeson (eitherDecode)
-import Data.Binary (Binary, decodeFileOrFail, encodeFile)
-import Data.ByteString.Lazy.Char8 qualified as L8
-import Data.Function ((&))
-import Data.List (foldl')
-import Data.Maybe (catMaybes, mapMaybe)
-import Data.Text (Text, append, isPrefixOf, lines, pack, unpack)
-import Data.Text.Encoding (decodeUtf8)
-import GHC.Generics (Generic)
-import Git qualified
-import Issue (Issue (..), fromMatch, id)
-import Issue.Filter (Filter, applyFilters)
-import Issue.Sort (Sort, applySorts)
-import Issue.Tag qualified as I
-import Parallel (parMapM)
-import Process (proc, sh)
-import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory)
-import System.Exit (ExitCode (ExitFailure), exitWith)
-import System.FilePath (takeExtension, (</>))
-import System.IO.Temp (withSystemTempDirectory)
-import System.Process.Typed (setWorkingDir)
-import Text.Printf (printf)
-import TreeGrepper.Match qualified as G
-import TreeGrepper.Result qualified as G
+import History.CommitHash (CommitHash)
+import History.CommitInfo (CommitInfo (..), fromPartialCommitInfos, issueEvents)
+import History.IssueEvent (IssueEvent (..))
+import History.PartialCommitInfo (getPartialCommitInfos)
+import Issue (Issue)
 import Prelude hiding (id, lines)
-import Prelude qualified as Prelude
 
-listEvents :: IO [[IssueEvent]]
-listEvents = do
-  commitHashes <- fmap reverse getCommitHashes
-  case commitHashes of
-    [] -> pure []
-    hashFirst : hashesRest -> do
-      issuesInitial <- getIssuesCommitAll hashFirst
-      commitInfos <- mapM getCommitInfo hashesRest
-      commitInfoWorkingTree <- getCommitInfoWorkingTree []
-      let eventses = getEvents hashFirst issuesInitial (commitInfos ++ [commitInfoWorkingTree])
-      pure eventses
-
-listIssues :: [Sort] -> [Filter] -> [FilePath] -> IO [Issue]
-listIssues sort filters paths = do
-  commitHashes <- fmap reverse getCommitHashes
-  case commitHashes of
-    [] ->
-      pure []
-    hashFirst : hashesRest -> do
-      -- TODO Reduce cached data size
-      --
-      -- Right now we are caching complete `Issue` instances, which
-      -- contain the full issue title and description.  For a fast
-      -- lookup it may already be enough to only store the issue's
-      --
-      -- \* filename
-      -- \* start position
-      -- \* end position
-      --
-      -- With this information we can use git to quickly look up the
-      -- complete issue text and parse it.
-      --
-      -- @topic caching
-      issuesInitial <- getIssuesCommitAll hashFirst
-      commitInfos <- mapM getCommitInfo hashesRest
-      commitInfoWorkingTree <- getCommitInfoWorkingTree paths
-      let eventses = getEvents hashFirst issuesInitial (commitInfos ++ [commitInfoWorkingTree])
-      let issues = mapMaybe issueFromIssueEvents eventses
-          issuesFiltered = applyFilters filters issues
-          issuesSorted = applySorts sort issuesFiltered
-          issuesWithinPaths =
-            case paths of
-              [] ->
-                issuesSorted
-              _ ->
-                filter withinPaths issuesSorted
-      pure issuesWithinPaths
-      where
-        withinPaths issue =
-          any (\path -> isPrefixOf (pack path) (pack issue.file)) paths
-
-getCommitHashes :: IO [Text]
-getCommitHashes =
-  fmap (lines . decodeUtf8 . L8.toStrict) $ sh "git log --format=%H"
-
-data IssueEvent
-  = IssueCreated
-      { hash :: Maybe Text,
-        issue :: Issue
-      }
-  | IssueChanged
-      { hash :: Maybe Text,
-        issue :: Issue
-      }
-  | IssueDeleted
-      { hash :: Maybe Text
-      }
-  deriving (Show)
-
-issueFromIssueEvent :: IssueEvent -> Maybe Issue
-issueFromIssueEvent issueEvent =
-  case issueEvent of
-    IssueCreated {issue} ->
-      Just issue
-    IssueChanged {issue} ->
-      Just issue
-    IssueDeleted _ ->
-      Nothing
-
-data CommitInfo = CommitInfo
-  -- TODO Extract CommitInfo so we can change hash' -> hash
-  --
-  -- @topic refactoring
-  { hash' :: Maybe Text,
-    filesChanged :: [FilePath],
-    issues :: [Issue]
-  }
-  deriving (Show, Binary, Generic)
-
-getCommitInfo :: Text -> IO CommitInfo
-getCommitInfo hash = cached (append hash (pack ".changed")) $ \_ -> do
-  (issuesCommitChanged, filesChanged) <- getIssuesAndFilesCommitChanged hash
-  pure $
-    CommitInfo
-      { hash' = Just hash,
-        filesChanged = filesChanged,
-        issues = issuesCommitChanged
-      }
-
-getCommitInfoWorkingTree :: [FilePath] -> IO CommitInfo
-getCommitInfoWorkingTree paths = do
-  (issuesWorkingTreeChanged, filesChanged) <- getIssuesAndFilesWorkingTreeChanged paths
-  pure $
-    CommitInfo
-      { hash' = Nothing,
-        filesChanged = filesChanged,
-        issues = issuesWorkingTreeChanged
-      }
-
-getEvents :: Text -> [Issue] -> [CommitInfo] -> [[IssueEvent]]
-getEvents hashInitial issuesInitial commitInfos =
-  let issueEventsesInitial =
-        map
-          ( \issueInitial ->
-              [ IssueCreated
-                  { hash = Just 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,
-            internalTags = I.internalTags issue.title issueFirst.provenance
-          }
-    IssueDeleted _ : _ ->
-      Nothing
-    _ ->
-      Nothing
-
--- | 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 (getIssuesPar cwd files) dieOfInvalidTreeGrepperResult
-  pure (issues, files)
-
--- | Given the hash of a commit, get all issues in all files at the
--- [tree](https://git-scm.com/docs/gitglossary#Documentation/gitglossary.txt-aiddeftreeatree)
--- of this commit.
-getIssuesCommitAll :: Text -> IO [Issue]
-getIssuesCommitAll hash = cached (append hash (pack ".all")) $ \_ -> do
-  withSystemTempDirectory "history" $ \tmp -> do
-    let cwd = tmp </> unpack hash
-    Git.withWorkingTree cwd hash do
-      files <- gitLsFilesAll cwd
-      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, as well as all changed files.
-getIssuesAndFilesCommitChanged :: Text -> IO ([Issue], [FilePath])
-getIssuesAndFilesCommitChanged hash = do
-  withSystemTempDirectory "history" $ \tmp -> do
-    let cwd = tmp </> unpack hash
-    Git.withWorkingTree cwd hash do
-      files <- gitShowChanged cwd
-      issues <- concat <$> catch (getIssuesPar cwd files) (dieOfInvalidTreeGrepperResult)
-      pure (issues, files)
-
-gitLsFilesAll :: FilePath -> IO [FilePath]
-gitLsFilesAll cwd =
-  Prelude.lines . L8.unpack
-    <$> sh ("git ls-files --cached --exclude-standard --other" & setWorkingDir cwd)
-
-gitShowChanged :: FilePath -> IO [FilePath]
-gitShowChanged cwd =
-  Prelude.lines . L8.unpack
-    <$> sh ("git show -p --name-only --format=''" & setWorkingDir cwd)
-
-gitLsFilesModifiedIn :: FilePath -> [FilePath] -> IO [FilePath]
-gitLsFilesModifiedIn cwd paths =
-  Prelude.lines . L8.unpack
-    <$> sh
-      ( proc "git ls-files --modified %" ("--" : paths)
-          & setWorkingDir cwd
-      )
-
--- | Get all issues in the given directory and files.  Runs
--- parallelized.
-getIssuesPar :: FilePath -> [FilePath] -> IO [[Issue]]
-getIssuesPar cwd files =
-  parMapM (handle forgetGetIssuesExceptions . getIssues cwd) files
-
-data UnknownFileExtension = UnknownFileExtension
-  { extension :: String
-  }
-  deriving (Show)
-
-instance Exception UnknownFileExtension
-
-forgetGetIssuesExceptions :: UnknownFileExtension -> IO [a]
-forgetGetIssuesExceptions _ = pure []
-
-data InvalidTreeGrepperResult = InvalidTreeGrepperResult
-  { error :: String
-  }
-  deriving (Show)
-
-instance Exception InvalidTreeGrepperResult
-
-dieOfInvalidTreeGrepperResult :: InvalidTreeGrepperResult -> IO a
-dieOfInvalidTreeGrepperResult (InvalidTreeGrepperResult e) =
-  die e
-
--- | Get all issues in the given directory and file.
-getIssues :: FilePath -> FilePath -> IO [Issue]
-getIssues cwd filename = do
-  let extension = takeExtension filename
-      treeGrepperLanguage =
-        -- TODO Add support for all tree-grepper supported files
-        --
-        -- tree-grepper supported files can be listed through `tree-grepper
-        -- --languages`.
-        case extension of
-          ".elm" -> "elm"
-          ".hs" -> "haskell"
-          ".nix" -> "nix"
-          ".sh" -> "sh"
-          _ -> throw (UnknownFileExtension extension)
-      treeGrepperQuery =
-        case extension of
-          ".elm" -> "([(line_comment) (block_comment)])"
-          ".hs" -> "(comment)"
-          ".nix" -> "(comment)"
-          ".sh" -> "(comment)"
-          _ -> throw (UnknownFileExtension extension)
-      decode raw =
-        case eitherDecode raw of
-          Left e -> throw (InvalidTreeGrepperResult e)
-          Right treeGrepperResult -> treeGrepperResult
-
-  matches <-
-    concatMap (\result -> map ((,) result) result.matches)
-      . map fixTreeGrepper
-      . decode
-      <$> sh
-        ( proc
-            "tree-grepper --query % % --format json %"
-            (treeGrepperLanguage :: String)
-            (treeGrepperQuery :: String)
-            filename
-            & setWorkingDir cwd
-        )
-
-  catMaybes <$> mapM (uncurry (fromMatch cwd)) matches
-
-fixTreeGrepper :: G.Result -> G.Result
-fixTreeGrepper treeGrepperResult =
-  treeGrepperResult {G.matches = G.merge treeGrepperResult.matches}
-
-cached :: Binary a => Text -> (Text -> IO a) -> IO a
-cached hash func = do
-  -- FIXME Cache inside Git root
-  --
-  -- The cache location should not be dependant on the current directory, but
-  -- should be placed alongside the `.git` directory.
-  cwd <- getCurrentDirectory
-  createDirectoryIfMissing True (cwd ++ "/.anissue")
-  let file = (cwd ++ "/.anissue/" ++ unpack hash)
-  doesFileExist file >>= \case
-    True ->
-      decodeFileOrFail file >>= \case
-        Left _ -> generate file
-        Right blob -> pure blob
-    False -> generate file
-  where
-    generate file = do
-      blob <- func hash
-      encodeFile file blob
-      pure blob
-
-die :: String -> IO a
-die s = do
-  printf "error: %s\n" s
-  exitWith (ExitFailure 1)
+-- TODO Reduce cached data size
+--
+-- Right now we are caching complete `Issue` instances, which
+-- contain the full issue title and description.  For a fast
+-- lookup it may already be enough to only store the issue's
+--
+-- \* filename
+-- \* start position
+-- \* end position
+--
+-- With this information we can use git to quickly look up the
+-- complete issue text and parse it.
+--
+-- @topic caching
+
+getHistory :: IO ([Issue], [(CommitHash, [IssueEvent])])
+getHistory = do
+  commitInfos <- fromPartialCommitInfos <$> getPartialCommitInfos
+  pure ((last commitInfos).issues, issueEvents commitInfos)
diff --git a/app/History/Cache.hs b/app/History/Cache.hs
new file mode 100644
index 0000000..af40a84
--- /dev/null
+++ b/app/History/Cache.hs
@@ -0,0 +1,26 @@
+module History.Cache (cached) where
+
+import Data.Binary (Binary, decodeFileOrFail, encodeFile)
+import Data.Text qualified as T
+import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory)
+
+cached :: Binary a => T.Text -> (T.Text -> IO a) -> IO a
+cached hash func = do
+  -- FIXME Cache inside Git root
+  --
+  -- The cache location should not be dependant on the current directory, but
+  -- should be placed alongside the `.git` directory.
+  cwd <- getCurrentDirectory
+  createDirectoryIfMissing True (cwd ++ "/.anissue")
+  let file = (cwd ++ "/.anissue/" ++ T.unpack hash)
+  doesFileExist file >>= \case
+    True ->
+      decodeFileOrFail file >>= \case
+        Left _ -> generate file
+        Right blob -> pure blob
+    False -> generate file
+  where
+    generate file = do
+      blob <- func hash
+      encodeFile file blob
+      pure blob
diff --git a/app/History/CommitHash.hs b/app/History/CommitHash.hs
new file mode 100644
index 0000000..3fcbb90
--- /dev/null
+++ b/app/History/CommitHash.hs
@@ -0,0 +1,23 @@
+module History.CommitHash
+  ( CommitHash (..),
+    toShortText,
+    toText,
+  )
+where
+
+import Data.Binary (Binary)
+import Data.Text qualified as T
+import GHC.Generics (Generic)
+
+data CommitHash
+  = WorkingTree
+  | Commit T.Text
+  deriving (Show, Binary, Generic)
+
+toShortText :: CommitHash -> T.Text
+toShortText WorkingTree = "<dirty>"
+toShortText (Commit hash) = T.take 7 hash
+
+toText :: CommitHash -> T.Text
+toText WorkingTree = "<dirty>"
+toText (Commit hash) = hash
diff --git a/app/History/CommitInfo.hs b/app/History/CommitInfo.hs
new file mode 100644
index 0000000..8461b8e
--- /dev/null
+++ b/app/History/CommitInfo.hs
@@ -0,0 +1,122 @@
+module History.CommitInfo
+  ( CommitInfo (..),
+    fromPartialCommitInfos,
+    issueEvents,
+    diffCommitInfos,
+  )
+where
+
+import Data.Binary (Binary)
+import Data.Function (on)
+import Data.List (deleteFirstsBy, find)
+import Data.Maybe (catMaybes, isJust)
+import GHC.Generics (Generic)
+import History.CommitHash (CommitHash)
+import History.IssueEvent (IssueEvent (..))
+import History.PartialCommitInfo (PartialCommitInfo (..))
+import Issue (Issue (..), id)
+import Issue.Tag qualified as I
+import TreeGrepper.Match (Position (..))
+import Prelude hiding (id)
+
+data CommitInfo = CommitInfo
+  { hash :: CommitHash,
+    filesChanged :: [FilePath],
+    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 =
+            catMaybes $
+              mergeListsBy
+                eq
+                ( \old new ->
+                    Just
+                      new
+                        { provenance = old.provenance,
+                          internalTags = I.internalTags new.title old.provenance
+                        }
+                )
+                ( \old ->
+                    if elemBy eq old newInfo.issues
+                      || not (old.file `elem` newInfo.filesChanged)
+                      then Just old
+                      else Nothing
+                )
+                (\new -> Just new)
+                oldInfo.issues
+                newInfo.issues,
+          ..
+        }
+
+    eq = (==) `on` id
+
+issueEvents :: [CommitInfo] -> [(CommitHash, [IssueEvent])]
+issueEvents xs = zip (map (.hash) xs') (zipWith diffCommitInfos xs xs')
+  where
+    xs' = tail xs
+
+diffCommitInfos :: CommitInfo -> CommitInfo -> [IssueEvent]
+diffCommitInfos oldInfo newInfo =
+  concat
+    [ [IssueCreated newHash issue | issue <- deleteFirstsBy eq newIssues oldIssues],
+      [ IssueChanged newHash (last issues)
+        | issues <- intersectBy' eq newIssues oldIssues,
+          not (null [(x, y) | x <- issues, y <- issues, clear x /= clear y])
+      ],
+      [IssueDeleted newHash issue | issue <- deleteFirstsBy eq oldIssues newIssues]
+    ]
+  where
+    newHash = newInfo.hash
+    newIssues = newInfo.issues
+    oldIssues = oldInfo.issues
+
+    -- TODO Fix issue comparison
+    --
+    -- Because issues carry `provenance` and `internalTags`, issues compare
+    -- unequally when we want them to be equal.
+    clear i =
+      i
+        { provenance = Nothing,
+          internalTags = [],
+          start = Position 0 0,
+          end = Position 0 0,
+          file = ""
+        }
+
+    eq = (==) `on` id
+
+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
new file mode 100644
index 0000000..88886dd
--- /dev/null
+++ b/app/History/IssueEvent.hs
@@ -0,0 +1,19 @@
+module History.IssueEvent (IssueEvent (..)) where
+
+import History.CommitHash (CommitHash)
+import Issue (Issue)
+
+data IssueEvent
+  = IssueCreated
+      { hash :: CommitHash,
+        issue :: Issue
+      }
+  | IssueChanged
+      { hash :: CommitHash,
+        issue :: Issue
+      }
+  | IssueDeleted
+      { hash :: CommitHash,
+        issue :: Issue
+      }
+  deriving (Show)
diff --git a/app/History/PartialCommitInfo.hs b/app/History/PartialCommitInfo.hs
new file mode 100644
index 0000000..fb53fbf
--- /dev/null
+++ b/app/History/PartialCommitInfo.hs
@@ -0,0 +1,97 @@
+module History.PartialCommitInfo
+  ( PartialCommitInfo (..),
+    getPartialCommitInfos,
+  )
+where
+
+import Control.Exception (catch)
+import Data.Binary (Binary)
+import Data.ByteString.Lazy.Char8 qualified as LB8
+import Data.Function ((&))
+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, getIssuesPar)
+import Process (proc, sh)
+import System.Directory (getCurrentDirectory)
+import System.FilePath ((</>))
+import System.IO.Temp (withSystemTempDirectory)
+import System.Process.Typed (setWorkingDir)
+
+-- | `PartialCommitInfo` records the complete issues ONLY in files that have
+-- been changed in the commit.
+data PartialCommitInfo = PartialCommitInfo
+  { hash :: CommitHash,
+    filesChanged :: [FilePath],
+    issues :: [Issue]
+  }
+  deriving (Show, Binary, Generic)
+
+getPartialCommitInfos :: IO [PartialCommitInfo]
+getPartialCommitInfos = do
+  -- TODO Revise `getCommitHashes`
+  --
+  -- - Should throw if no commits.
+  -- - Should always be reversed?
+  commitHashes <- reverse <$> Git.getCommitHashes
+  mapM getCommitInfoOf (map Commit commitHashes ++ [WorkingTree])
+
+getCommitInfoOf :: CommitHash -> IO PartialCommitInfo
+getCommitInfoOf WorkingTree = do
+  (issuesWorkingTreeChanged, filesChanged) <- getIssuesAndFilesWorkingTreeChanged []
+  pure $
+    PartialCommitInfo
+      { hash = WorkingTree,
+        filesChanged = filesChanged,
+        issues = issuesWorkingTreeChanged
+      }
+getCommitInfoOf (Commit hash) = cached (hash <> (T.pack ".changed")) $ \_ -> do
+  (issuesCommitChanged, filesChanged) <- getIssuesAndFilesCommitChanged hash
+  pure $
+    PartialCommitInfo
+      { hash = Commit hash,
+        filesChanged = filesChanged,
+        issues = issuesCommitChanged
+      }
+
+-- | 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 (getIssuesPar cwd files) dieOfInvalidTreeGrepperResult
+      pure (issues, files)
+
+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 (getIssuesPar 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 efb61b7..a4e2d73 100644
--- a/app/Issue.hs
+++ b/app/Issue.hs
@@ -1,14 +1,30 @@
-module Issue (Issue (..), Provenance (..), fromMatch, id) where
+module Issue
+  ( Issue (..),
+    Provenance (..),
+    fromMatch,
+    id,
+    getIssuesPar,
+  )
+where
 
+import Control.Exception (handle, throw)
+import Data.Aeson (eitherDecode)
 import Data.Binary (Binary)
+import Data.Function ((&))
 import Data.List (find, foldl')
+import Data.Maybe (catMaybes)
 import Data.Text (Text)
 import Data.Text qualified as T
+import Exception qualified as E
 import GHC.Generics (Generic)
 import Issue.Provenance (Provenance (..), provenanceFromHEAD)
 import Issue.Tag (Tag (..))
 import Issue.Tag qualified as I
 import Issue.Text qualified as I
+import Parallel (parMapM)
+import Process (proc, sh)
+import System.FilePath (takeExtension)
+import System.Process.Typed (setWorkingDir)
 import TreeGrepper.Match (Match (..))
 import TreeGrepper.Match qualified as G
 import TreeGrepper.Result (Result (..))
@@ -25,7 +41,7 @@ data Issue = Issue
     tags :: [Tag],
     internalTags :: [Tag]
   }
-  deriving (Show, Binary, Generic)
+  deriving (Show, Binary, Generic, Eq)
 
 id :: Issue -> Maybe String
 id issue =
@@ -70,3 +86,58 @@ stripIssueMarkers text =
 stripIssueMarker :: Text -> Text -> Text
 stripIssueMarker text marker =
   maybe text T.stripStart (T.stripPrefix marker text)
+
+-- | Get all issues in the given directory and files.  Runs
+-- parallelized.
+getIssuesPar :: FilePath -> [FilePath] -> IO [[Issue]]
+getIssuesPar cwd files =
+  parMapM (handle forgetGetIssuesExceptions . getIssues cwd) files
+
+-- | Get all issues in the given directory and file.
+getIssues :: FilePath -> FilePath -> IO [Issue]
+getIssues cwd filename = do
+  let extension = takeExtension filename
+      treeGrepperLanguage =
+        -- TODO Add support for all tree-grepper supported files
+        --
+        -- tree-grepper supported files can be listed through `tree-grepper
+        -- --languages`.
+        case extension of
+          ".elm" -> "elm"
+          ".hs" -> "haskell"
+          ".nix" -> "nix"
+          ".sh" -> "sh"
+          _ -> throw (E.UnknownFileExtension extension)
+      treeGrepperQuery =
+        case extension of
+          ".elm" -> "([(line_comment) (block_comment)])"
+          ".hs" -> "(comment)"
+          ".nix" -> "(comment)"
+          ".sh" -> "(comment)"
+          _ -> throw (E.UnknownFileExtension extension)
+      decode raw =
+        case eitherDecode raw of
+          Left e -> throw (E.InvalidTreeGrepperResult e)
+          Right treeGrepperResult -> treeGrepperResult
+
+  matches <-
+    concatMap (\result -> map ((,) result) result.matches)
+      . map fixTreeGrepper
+      . decode
+      <$> sh
+        ( proc
+            "tree-grepper --query % % --format json %"
+            (treeGrepperLanguage :: String)
+            (treeGrepperQuery :: String)
+            filename
+            & setWorkingDir cwd
+        )
+
+  catMaybes <$> mapM (uncurry (fromMatch cwd)) matches
+
+fixTreeGrepper :: G.Result -> G.Result
+fixTreeGrepper treeGrepperResult =
+  treeGrepperResult {G.matches = G.merge treeGrepperResult.matches}
+
+forgetGetIssuesExceptions :: E.UnknownFileExtension -> IO [a]
+forgetGetIssuesExceptions _ = pure []
diff --git a/app/Issue/Provenance.hs b/app/Issue/Provenance.hs
index 7cf4faa..f3d382c 100644
--- a/app/Issue/Provenance.hs
+++ b/app/Issue/Provenance.hs
@@ -25,7 +25,7 @@ data Provenance = Provenance
     authorEmail :: Text,
     authorName :: Text
   }
-  deriving (Show, Generic, Binary)
+  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.
diff --git a/app/Issue/Tag.hs b/app/Issue/Tag.hs
index 85636b5..42a371d 100644
--- a/app/Issue/Tag.hs
+++ b/app/Issue/Tag.hs
@@ -15,7 +15,7 @@ import Data.Time.Clock (UTCTime (utctDay))
 import GHC.Generics (Generic)
 import Issue.Provenance (Provenance (..))
 
-data Tag = Tag Text (Maybe Text) deriving (Show, Generic, Binary)
+data Tag = Tag Text (Maybe Text) deriving (Show, Generic, Binary, Eq)
 
 tagKey :: Tag -> Text
 tagKey (Tag k _) = k
diff --git a/app/Main.hs b/app/Main.hs
index a7901bd..3bb60e2 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -447,18 +447,20 @@ module Main where
 
 import Control.Applicative ((<|>))
 import Data.Function ((&))
-import Data.List (find)
+import Data.List (find, isPrefixOf)
 import Data.Maybe (catMaybes)
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as LT
 import Data.Text.Lazy.IO qualified as LT
 import Data.Time.Clock (UTCTime (utctDay))
-import History (IssueEvent (..), listEvents, listIssues)
+import History (getHistory)
+import History.CommitHash qualified as CH
+import History.IssueEvent (IssueEvent (..))
 import Issue (Issue (..))
 import Issue qualified as I
-import Issue.Filter (Filter)
+import Issue.Filter (Filter, applyFilters)
 import Issue.Filter qualified as I
-import Issue.Sort (Sort)
+import Issue.Sort (Sort, applySorts)
 import Issue.Sort qualified as I
 import Options.Applicative ((<**>))
 import Options.Applicative qualified as O
@@ -586,9 +588,7 @@ idArg =
   O.strArgument
     ( O.metavar "ID"
         <> O.completer
-          ( O.listIOCompleter $
-              catMaybes . map I.id <$> listIssues [] [] []
-          )
+          (O.listIOCompleter $ catMaybes . map I.id . fst <$> getHistory)
     )
 
 die :: String -> IO a
@@ -600,7 +600,8 @@ main :: IO ()
 main = do
   O.execParser (O.info (options <**> O.helper) O.idm) >>= \case
     Options {colorize, noPager, width, command = List {sort, filters, files}} -> do
-      issues <- listIssues sort filters files
+      let withinPath issue = if null files then True else any (\file -> file `isPrefixOf` issue.file) files
+      issues <- applySorts sort . applyFilters filters . filter withinPath . fst <$> getHistory
       putDoc colorize noPager width . P.vsep $
         map
           ( \issue ->
@@ -633,34 +634,25 @@ main = do
           )
           issues
     Options {colorize, noPager, width, command = Log} -> do
-      -- TODO Reconcile log
-      --
-      -- When viewing the log I am confused by
-      --
-      -- (1) lots of sequential commits "changing" the same one issue, but no
-      -- others,
-      -- (2) having unknown hashes interleaved
-      --
-      -- I would assume changes to be less frequent, or, if no changes are
-      -- considered changes, the log output sorted by hashes (and not
-      -- commits?). I would expect only the first commit hash to be unknown.
-      --
-      -- Thoughts? :-)
-      es <- concat <$> listEvents
+      (_, ess') <- getHistory
       putDoc colorize noPager width . P.vsep $
-        map
-          ( \e ->
-              let shortHash = P.annotate (P.color P.Yellow) . P.pretty $ maybe "UNKNOWN" (T.take 7) e.hash
-                  kwd = P.annotate (P.color P.Green) . P.pretty . T.pack
-                  title issue = P.annotate (P.color P.Blue) . P.annotate P.bold $ P.pretty issue.title
-               in case e of
-                    IssueCreated {issue} -> shortHash <+> kwd "created" <+> title issue
-                    IssueChanged {issue} -> shortHash <+> kwd "changed" <+> title issue
-                    IssueDeleted {} -> shortHash <+> kwd "deleted"
+        concatMap
+          ( \(hash, es') ->
+              let shortHash = P.annotate (P.color P.Yellow) . P.pretty $ CH.toShortText hash
+               in map
+                    ( \e ->
+                        let kwd = P.annotate (P.color P.Green) . P.pretty . T.pack
+                            title issue = P.annotate (P.color P.Blue) . P.annotate P.bold $ P.pretty issue.title
+                         in case e of
+                              IssueCreated {issue} -> shortHash <+> kwd "created" <+> title issue
+                              IssueChanged {issue} -> shortHash <+> kwd "changed" <+> title issue
+                              IssueDeleted {issue} -> shortHash <+> kwd "deleted" <+> title issue
+                    )
+                    es'
           )
-          es
+          (reverse ess')
     Options {colorize, width, command = Show {id}} -> do
-      issues <- listIssues [] [] []
+      issues <- fst <$> getHistory
       case find ((==) (Just id) . I.id) issues of
         Nothing -> die (printf "no issue with id `%s'\n" id)
         Just issue -> do
diff --git a/app/Process.hs b/app/Process.hs
index 9ce5e46..2b3eaf6 100644
--- a/app/Process.hs
+++ b/app/Process.hs
@@ -11,34 +11,30 @@ module Process
   )
 where
 
-import Control.Exception (Exception, throwIO)
+import Control.Exception (throwIO)
 import Data.ByteString.Lazy.Char8 qualified as LB
 import Data.List (intercalate)
 import Data.String (fromString)
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as LT
 import Data.Text.Lazy.Encoding qualified as LT
+import Exception qualified as E
 import System.Exit (ExitCode (ExitSuccess))
 import System.Process.Typed (ProcessConfig, StreamSpec, StreamType (STInput), byteStringInput, readProcess, readProcessStderr)
 
-data ProcessException = ProcessException String ExitCode LB.ByteString
-  deriving (Show)
-
-instance Exception ProcessException
-
 sh :: ProcessConfig stdin stdoutIgnored stderr -> IO LB.ByteString
 sh processConfig = do
   (exitCode, out, err) <- readProcess processConfig
   if exitCode == ExitSuccess
     then pure out
-    else throwIO $ ProcessException (show processConfig) exitCode err
+    else throwIO $ E.ProcessException (show processConfig) exitCode err
 
 sh_ :: ProcessConfig stdin stdoutIgnored stderr -> IO ()
 sh_ processConfig = do
   (exitCode, err) <- readProcessStderr processConfig
   if exitCode == ExitSuccess
     then pure ()
-    else throwIO $ ProcessException (show processConfig) exitCode err
+    else throwIO $ E.ProcessException (show processConfig) exitCode err
 
 class Quotable a where
   quote :: a -> String