chore: increase performance by caching everything

Initial cache generation is slower, as we are losing out on parallelism.

5 files changed, 27 insertions, 291 deletions

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
-      )