chore: drop `Git.withWorkingTree`

8 files changed, 154 insertions, 159 deletions

diff --git a/app/Cache.hs b/app/Cache.hs
index 52d18ca..7af9ee7 100644
--- a/app/Cache.hs
+++ b/app/Cache.hs
@@ -6,7 +6,6 @@ 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 ((</>))
@@ -19,13 +18,13 @@ cached key func = do
   doesFileExist file >>= \case
     True ->
       decodeFileOrFail file >>= \case
-        Left e -> debug "e" e `seq` generate file
+        Left _ -> generate file
         Right blob -> pure blob
     False -> generate file
   where
     generate file = do
       blob <- func
-      encodeFile (debug "cache miss" file) blob
+      encodeFile file blob
       pure blob
 
 cachedMaybe :: Binary a => Maybe T.Text -> IO a -> IO a
diff --git a/app/Exception.hs b/app/Exception.hs
index a809616..41097b3 100644
--- a/app/Exception.hs
+++ b/app/Exception.hs
@@ -6,6 +6,7 @@ module Exception
     UnknownFileExtension (..),
     InvalidDiff (..),
     InvalidIssue (..),
+    CannotReadFile (..),
   )
 where
 
@@ -60,3 +61,8 @@ data InvalidIssue = InvalidIssue (P.ParseErrorBundle [D.Node] Void)
   deriving (Show)
 
 instance Exception InvalidIssue
+
+data CannotReadFile = CannotReadFile
+  deriving (Show)
+
+instance Exception CannotReadFile
diff --git a/app/Git.hs b/app/Git.hs
index 0b8a561..a3c82fa 100644
--- a/app/Git.hs
+++ b/app/Git.hs
@@ -1,36 +1,111 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Git
   ( module Git.CommitHash,
-    withWorkingTree,
     getCommitHashes,
     getRootDir,
+    getChangedFilesOf,
+    Commit (..),
+    Author (..),
+    getCommitOf,
+    readTextFileOf,
   )
 where
 
-import Control.Exception (finally, throw)
-import Data.ByteString.Lazy.Char8 qualified as LB8
+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, sh_)
-import System.Directory (createDirectoryIfMissing)
-import System.FilePath (dropTrailingPathSeparator, takeDirectory)
-
--- | Runs an IO-action within a working tree.
-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
+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 . LB8.toStrict <$> sh "git log --format=%H"
+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 . LB8.toStrict <$> sh (proc "git rev-parse --show-toplevel")
+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
+
+readTextFileOf :: CommitHash -> FilePath -> IO LT.Text
+readTextFileOf WorkingTree filePath = LT.readFile filePath
+readTextFileOf (Commit hash) filePath =
+  LT.decodeUtf8 <$> sh (proc "git show %:%" hash filePath)
diff --git a/app/History.hs b/app/History.hs
index 70fc123..5b2dab3 100644
--- a/app/History.hs
+++ b/app/History.hs
@@ -26,14 +26,12 @@ import Git.CommitHash (CommitHash (..))
 import Git.CommitHash qualified as C
 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 IssueEvent (IssueEvent (..))
 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)
@@ -97,35 +95,31 @@ data Scramble = Scramble
   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
+getScrambleOf commitHash = do
+  (issues, filesChanged) <- getIssuesAndFilesChanged commitHash
   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)
+getIssuesAndFilesChanged :: CommitHash -> IO ([I.Issue], [FilePath])
+getIssuesAndFilesChanged commitHash = do
+  files <- Git.getChangedFilesOf commitHash
+  issues <-
+    concat
+      <$> catch
+        (mapM (getIssues commitHash) files)
+        (\(e :: E.InvalidTreeGrepperResult) -> die (show e))
+  pure (issues, files)
 
 -- | Get all issues in the given directory and file.
-getIssues :: FilePath -> FilePath -> IO [I.Issue]
-getIssues cwd filename =
+getIssues :: CommitHash -> FilePath -> IO [I.Issue]
+getIssues commitHash filename =
   handle (\(_ :: E.UnknownFileExtension) -> pure []) $
-    fmap catMaybes . mapM (fromComment cwd)
-      =<< G.getComments cwd filename
+    fmap catMaybes . mapM (fromComment commitHash)
+      =<< G.getComments commitHash 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
+fromComment :: CommitHash -> G.Comment -> IO (Maybe I.Issue)
+fromComment commitHash comment = do
+  commit <- Git.getCommitOf commitHash
   let provenance = I.Provenance commit commit
 
   pure $
@@ -151,33 +145,6 @@ fromComment cwd comment = do
   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
diff --git a/app/Issue.hs b/app/Issue.hs
index 2b9e568..83e7141 100644
--- a/app/Issue.hs
+++ b/app/Issue.hs
@@ -17,7 +17,8 @@ import Data.Text.IO qualified as T
 import Data.Time.Clock (UTCTime (utctDay))
 import GHC.Generics (Generic)
 import GHC.Records (HasField (..))
-import Issue.Provenance (Author (..), Commit (..), Provenance (..))
+import Git (Author (..), Commit (..))
+import Issue.Provenance (Provenance (..))
 import Issue.Tag (Tag (..))
 import Render qualified as P
 import TreeGrepper.Comment qualified as G
diff --git a/app/Issue/Provenance.hs b/app/Issue/Provenance.hs
index 18255da..321f6a2 100644
--- a/app/Issue/Provenance.hs
+++ b/app/Issue/Provenance.hs
@@ -1,80 +1,14 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
 module Issue.Provenance
   ( Provenance (..),
-    Commit (..),
-    Author (..),
-    commitFromHEAD,
   )
 where
 
-import Control.Exception (throwIO)
-import Data.Binary (Binary, Put, get, put)
-import Data.ByteString.Lazy.Char8 (toStrict)
-import Data.Fixed (Pico)
-import Data.Function ((&))
-import Data.Text (lines, splitOn, unpack)
-import Data.Text qualified as T
-import Data.Text.Encoding (decodeUtf8)
-import Data.Time.Calendar (Day (..), toModifiedJulianDay)
-import Data.Time.Clock (DiffTime, UTCTime (..), picosecondsToDiffTime)
-import Exception qualified as E
+import Data.Binary (Binary)
 import GHC.Generics (Generic)
-import Git.CommitHash (CommitHash)
-import Git.CommitHash qualified as C
-import Process (sh)
-import System.Process.Typed (setWorkingDir)
-import Prelude hiding (lines)
+import Git qualified
 
 data Provenance = Provenance
-  { first :: Commit,
-    last :: Commit
-  }
-  deriving (Show, Generic, Binary, Eq)
-
-data Commit = Commit
-  { hash :: CommitHash,
-    date :: UTCTime,
-    author :: Author
-  }
-  deriving (Show, Generic, Binary, Eq)
-
-data Author = Author
-  { name :: T.Text,
-    email :: T.Text
+  { first :: Git.Commit,
+    last :: Git.Commit
   }
-  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
-
-commitFromHEAD :: FilePath -> IO Commit
-commitFromHEAD cwd = do
-  rawProvenance <-
-    fmap (splitOn "\NUL" . head . lines . decodeUtf8 . toStrict) $
-      sh $
-        "git show --quiet --format='%H%x00%ai%x00%ae%x00%an'"
-          & setWorkingDir cwd
-  case rawProvenance of
-    hash : rawDate : authorEmail : authorName : _ ->
-      let date = read (unpack rawDate)
-       in pure
-            Commit
-              { hash = C.Commit hash,
-                date = date,
-                author = Author authorName authorEmail
-              }
-    _ -> throwIO E.NoCommits
+  deriving (Eq, Show, Generic, Binary)
diff --git a/app/Issue/Render.hs b/app/Issue/Render.hs
index ed40ed7..39249ae 100644
--- a/app/Issue/Render.hs
+++ b/app/Issue/Render.hs
@@ -15,8 +15,9 @@ import Data.List.NonEmpty qualified as N
 import Data.Map qualified as M
 import Data.Text qualified as T
 import Data.Time.Clock (UTCTime (utctDay))
+import Git (Author (..), Commit (..))
 import Issue (Issue (..))
-import Issue.Provenance (Author (..), Commit (..), Provenance (..))
+import Issue.Provenance (Provenance (..))
 import Render ((<<<))
 import Render qualified as P
 
diff --git a/app/TreeGrepper/Comment.hs b/app/TreeGrepper/Comment.hs
index 0ca9543..7c2ca90 100644
--- a/app/TreeGrepper/Comment.hs
+++ b/app/TreeGrepper/Comment.hs
@@ -7,7 +7,7 @@ module TreeGrepper.Comment
   )
 where
 
-import Control.Exception (throw)
+import Control.Exception (catch, throw)
 import Data.Aeson qualified as A
 import Data.Binary (Binary)
 import Data.ByteString.Lazy.Char8 qualified as B
@@ -15,11 +15,15 @@ import Data.Function ((&))
 import Data.List (find)
 import Data.Maybe (fromMaybe)
 import Data.Text qualified as T
+import Data.Text.Lazy.IO qualified as LT
 import Exception qualified as E
 import GHC.Generics (Generic)
+import Git qualified
 import Process (proc, sh)
-import System.FilePath (takeExtension)
-import System.Process.Typed (setWorkingDir)
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath (takeDirectory, takeExtension, takeFileName, (</>))
+import System.IO.Temp (withSystemTempDirectory)
+import System.Process.Typed qualified as P
 import TreeGrepper.FileType (FileType (..))
 import TreeGrepper.FileType qualified as G
 import TreeGrepper.Match (Match (..), Position (..))
@@ -90,20 +94,28 @@ stripBlockComment blockStart blockEnd text =
 fromMatch :: Result -> Match -> Comment
 fromMatch Result {..} Match {..} = Comment {..}
 
-getComments :: FilePath -> FilePath -> IO [Comment]
-getComments cwd fn = do
+getComments :: Git.CommitHash -> FilePath -> IO [Comment]
+getComments commitHash fn = do
   let ext = takeExtension fn
-  concatMap (\result -> map (fromMatch result) result.matches)
-    . map fixTreeGrepper
-    . decode
-    <$> sh
-      ( proc
-          "tree-grepper --query % % --format json %"
-          (treeGrepperLanguage ext)
-          (treeGrepperQuery ext)
-          fn
-          & setWorkingDir cwd
-      )
+  s <-
+    catch
+      (Git.readTextFileOf commitHash fn)
+      (\(_ :: E.ProcessException) -> pure "")
+  withSystemTempDirectory (takeFileName fn) $ \cwd -> do
+    createDirectoryIfMissing True (cwd </> takeDirectory fn)
+    LT.writeFile (cwd </> fn) s
+    concatMap (\result -> map (fromMatch result) result.matches)
+      . map fixTreeGrepper
+      . decode
+      <$> sh
+        ( ( proc
+              "tree-grepper % --query % % --format json"
+              fn
+              (treeGrepperLanguage ext)
+              (treeGrepperQuery ext)
+          )
+            & P.setWorkingDir cwd
+        )
 
 decode :: B.ByteString -> [Result]
 decode = either (throw . E.InvalidTreeGrepperResult) id . A.eitherDecode