Merge remote-tracking branch 'origin/feature/review'main

1 files changed, 219 insertions, 0 deletions

diff --git a/app/Review.hs b/app/Review.hs
new file mode 100644
index 0000000..721d8e3
--- /dev/null
+++ b/app/Review.hs
@@ -0,0 +1,219 @@
+module Review
+  ( Plan (..),
+    PlanStep (..),
+    formulatePlan,
+    reviewStep,
+    commitReview,
+  )
+where
+
+import Comment.Language qualified as L
+import Control.Monad (ap, forM, forM_, when)
+import Data.Binary qualified as B
+import Data.ByteString.Lazy qualified as LB
+import Data.Function ((&))
+import Data.List.NonEmpty qualified as NE
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Data.Text.IO qualified as T
+import GHC.Generics (Generic)
+import Git qualified
+import Patch qualified as A
+import Process (proc, sh, sh_)
+import Render (renderAsText)
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath (takeDirectory, (</>))
+import System.IO.Temp (withSystemTempDirectory)
+import System.Process.Typed qualified as P
+import Text.Diff.Extra ()
+import Text.Diff.Parse.Types qualified as D
+
+data Plan = Plan
+  { baseBranch :: BranchName,
+    featureBranch :: BranchName,
+    commit :: Git.CommitHash,
+    perCommit :: Bool,
+    steps :: NE.NonEmpty PlanStep
+  }
+  deriving (Show, Generic, B.Binary)
+
+type BranchName = T.Text
+
+data PlanStep = PlanStep
+  { commit :: Git.CommitHash,
+    earlierCommit :: Git.CommitHash,
+    changes :: D.FileDeltas
+  }
+  deriving (Show, Generic, B.Binary)
+
+formulatePlan :: Bool -> T.Text -> T.Text -> IO Plan
+formulatePlan perCommit baseBranch featureBranch = do
+  baseCommit <- Git.resolveRef baseBranch
+  featureCommit <- Git.resolveRef featureBranch
+
+  commits <-
+    if perCommit
+      then do
+        commits <-
+          reverse <$> Git.getCommitsBetween baseCommit featureCommit
+        pure $ zipWith (,) commits (baseCommit : commits)
+      else pure [(featureCommit, baseCommit)]
+
+  fileDeltas <-
+    fmap concat . forM commits $
+      \(commit, earlierCommit) ->
+        map ((commit, earlierCommit),) . (: []) . (.fileDeltas)
+          <$> Git.diffOf earlierCommit commit
+
+  pure
+    Plan
+      { steps =
+          NE.fromList
+            ( map
+                ( \((commit, earlierCommit), changes) ->
+                    PlanStep {..}
+                )
+                fileDeltas
+            ),
+        commit = featureCommit,
+        ..
+      }
+
+reviewStep :: PlanStep -> IO D.FileDeltas
+reviewStep step = do
+  commitMessages <-
+    T.decodeUtf8 . LB.toStrict
+      <$> sh
+        ( proc
+            "git log %..%"
+            (Git.toTextUnsafe step.earlierCommit)
+            (Git.toTextUnsafe step.commit)
+        )
+  separateReview step.earlierCommit step.changes
+    =<< reviewPatch commitMessages step.changes
+
+reviewPatch :: T.Text -> D.FileDeltas -> IO D.FileDeltas
+reviewPatch commitMessages fileDeltas =
+  withSystemTempDirectory "anissue" $ \tmp -> do
+    let patchFile = tmp </> "a.patch"
+        patchFile' = tmp </> "b.patch"
+        patchContents = renderAsText (A.Patch fileDeltas)
+    T.writeFile patchFile patchContents
+    T.writeFile patchFile' (addCommitMessages <> patchContents)
+    sh_ (proc "${EDITOR-vi} %" patchFile')
+    T.writeFile patchFile'
+      . (renderAsText . A.Patch)
+      . addComments
+      . ((.fileDeltas) . A.parse)
+      . stripCommitMessages
+      =<< T.readFile patchFile'
+    ((.fileDeltas) . A.parse . T.decodeUtf8 . LB.toStrict)
+      <$> sh (proc "rediff % %" patchFile patchFile')
+  where
+    addCommitMessages =
+      T.unlines . map ("# " <>) . T.lines $ commitMessages
+    stripCommitMessages =
+      T.unlines . dropWhile ("# " `T.isPrefixOf`) . T.lines
+
+addComments :: D.FileDeltas -> D.FileDeltas
+addComments =
+  map
+    ( \fileDelta@(D.FileDelta {D.fileDeltaSourceFile}) ->
+        ( mapContent . mapHunks . mapLines $
+            \line@(D.Line {..}) ->
+              if lineAnnotation == D.Comment
+                then
+                  let language = L.fromPath (T.unpack fileDeltaSourceFile)
+                   in D.Line D.Added (L.lineStart language <> " REVIEW" <> lineContent)
+                else line
+        )
+          fileDelta
+    )
+  where
+    mapContent f x = x {D.fileDeltaContent = f x.fileDeltaContent}
+    mapHunks _ D.Binary = D.Binary
+    mapHunks f (D.Hunks hs) = D.Hunks (map f hs)
+    mapLines f x = x {D.hunkLines = map f x.hunkLines}
+
+separateReview ::
+  Git.CommitHash ->
+  D.FileDeltas ->
+  D.FileDeltas ->
+  IO D.FileDeltas
+separateReview commit fileDeltas fileDeltas' =
+  withTempSourceFiles commit fileDeltas $ \tmp -> do
+    T.writeFile (tmp </> patchFile) (renderAsText (A.Patch fileDeltas))
+    T.writeFile (tmp </> patchFile') (renderAsText (A.Patch fileDeltas'))
+    sh_
+      ( proc "patch --quiet -p0 <../%" patchFile
+          & P.setWorkingDir (tmp </> "a")
+      )
+    sh_
+      ( proc "patch --quiet -p0 <../%" patchFile'
+          & P.setWorkingDir (tmp </> "b")
+      )
+    ( ap (flip if' [] . LB.null) $
+        (.fileDeltas) . A.parse . T.decodeUtf8 . LB.toStrict
+      )
+      <$> sh
+        ( proc "git diff --no-index -- a b || :"
+            & P.setWorkingDir tmp
+        )
+  where
+    patchFile = "a.patch"
+    patchFile' = "b.patch"
+
+withTempSourceFiles :: Git.CommitHash -> D.FileDeltas -> (FilePath -> IO a) -> IO a
+withTempSourceFiles commit fileDeltas action = do
+  withSystemTempDirectory "anissue" $ \tmp -> do
+    createDirectoryIfMissing False (tmp </> "a")
+    createDirectoryIfMissing False (tmp </> "b")
+    forM_ sourceFiles $ \sourceFile -> do
+      let sourceDir = takeDirectory sourceFile
+      fileContents <-
+        if sourceFile /= "/dev/null"
+          then case commit of
+            Git.Commit hash -> sh (proc "git show %:%" hash sourceFile)
+            Git.WorkingTree -> sh (proc "cat" sourceFile)
+          else pure ""
+      createDirectoryIfMissing True (tmp </> "a" </> sourceDir)
+      LB.writeFile (tmp </> "a" </> sourceFile) fileContents
+      createDirectoryIfMissing True (tmp </> "b" </> sourceDir)
+      LB.writeFile (tmp </> "b" </> sourceFile) fileContents
+    action tmp
+  where
+    sourceFiles = map (T.unpack . (.fileDeltaSourceFile)) fileDeltas
+
+if' :: Bool -> a -> a -> a
+if' True a _ = a
+if' False _ b = b
+
+commitReview :: Plan -> A.Patch -> IO ()
+commitReview plan patch = do
+  withSystemTempDirectory "anissue" $ \tmp -> do
+    when (not (null patch.fileDeltas)) do
+      T.writeFile (tmp </> "review.patch") (renderAsText patch)
+      sh_ (proc "patch -p1 <%/review.patch" tmp)
+    T.writeFile (tmp </> "commit_editmsg") (commit_editmsg plan)
+    sh_ (proc "git add %" (map (T.drop (T.length "b/") . (.fileDeltaDestFile)) patch.fileDeltas))
+    sh_ (proc "git commit --allow-empty --template %/commit_editmsg" tmp)
+
+commit_editmsg :: Plan -> T.Text
+commit_editmsg plan = do
+  T.unlines
+    [ "",
+      "# Please enter the commit message for your review. Lines starting",
+      "# with '#' will be ignored, and an empty message aborts the commit.",
+      "#",
+      "# To approve the changes, format your commit message like this:",
+      "#",
+      "# review: approve " <> plan.featureBranch,
+      "#",
+      "# Reviewed branch " <> plan.featureBranch <> " at commit " <> Git.toTextUnsafe plan.commit <> ".",
+      "#",
+      "# To requst changes, format your commit message like this:",
+      "#",
+      "# review: request-changes " <> plan.featureBranch,
+      "#",
+      "# Reviewed branch " <> plan.featureBranch <> " at commit " <> Git.toTextUnsafe plan.commit <> "."
+    ]