aboutsummaryrefslogtreecommitdiffstats
path: root/app
diff options
context:
space:
mode:
Diffstat (limited to 'app')
-rw-r--r--app/Data/List/NonEmpty/Zipper/Extra.hs8
-rw-r--r--app/Git.hs23
-rw-r--r--app/Git/CommitHash.hs5
-rw-r--r--app/Main.hs64
-rw-r--r--app/Patch.hs29
-rw-r--r--app/Render.hs16
-rw-r--r--app/Review.hs232
-rw-r--r--app/Status.hs122
8 files changed, 482 insertions, 17 deletions
diff --git a/app/Data/List/NonEmpty/Zipper/Extra.hs b/app/Data/List/NonEmpty/Zipper/Extra.hs
new file mode 100644
index 0000000..638a9bd
--- /dev/null
+++ b/app/Data/List/NonEmpty/Zipper/Extra.hs
@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.List.NonEmpty.Zipper.Extra where
+
+import Data.Binary (Binary)
+import Data.List.NonEmpty.Zipper (Zipper)
+
+instance Binary a => Binary (Zipper a)
diff --git a/app/Git.hs b/app/Git.hs
index 6431259..7859503 100644
--- a/app/Git.hs
+++ b/app/Git.hs
@@ -8,6 +8,9 @@ module Git
getCommitOf,
readTextFileOfText,
readTextFileOfBS,
+ resolveRef,
+ getCommitsBetween,
+ diffOf,
)
where
@@ -27,6 +30,7 @@ import Data.Time.Clock (UTCTime, getCurrentTime)
import Exception qualified as E
import GHC.Generics (Generic)
import Git.CommitHash
+import Patch qualified as A
import Process (proc, sh)
import Text.Printf (printf)
@@ -91,7 +95,7 @@ readTextFileOfText :: CommitHash -> FilePath -> IO LT.Text
readTextFileOfText = readTextFileOf LT.readFile LT.decodeUtf8
readTextFileOfBS :: CommitHash -> FilePath -> IO LB.ByteString
-readTextFileOfBS = readTextFileOf LB.readFile (\x->x)
+readTextFileOfBS = readTextFileOf LB.readFile (\x -> x)
readTextFileOf :: (FilePath -> IO a) -> (LB.ByteString -> a) -> CommitHash -> FilePath -> IO a
readTextFileOf readFile _ WorkingTree filePath =
@@ -102,3 +106,20 @@ readTextFileOf _ decode (Commit hash) filePath =
catch
(decode <$> sh (proc "git show %:%" hash filePath))
(\(_ :: E.ProcessException) -> throwIO (E.CannotReadFile (printf "%s:%s" hash filePath)))
+
+resolveRef :: T.Text -> IO CommitHash
+resolveRef =
+ fmap (Commit . T.strip . T.decodeUtf8 . LB.toStrict)
+ . sh
+ . proc "git rev-parse %"
+
+-- TODO Throw if `prevHash` is not an ancestor of `hash`.
+getCommitsBetween :: CommitHash -> CommitHash -> IO [CommitHash]
+getCommitsBetween (Commit prevHash) (Commit hash) = do
+ map (Commit . T.strip) . T.lines . T.decodeUtf8 . LB.toStrict
+ <$> sh (proc "git log --format=%%H %..%" prevHash hash)
+
+diffOf :: CommitHash -> CommitHash -> IO A.Patch
+diffOf prevHash hash =
+ A.parse . T.decodeUtf8 . LB.toStrict
+ <$> sh (proc "git diff % %" (toTextUnsafe prevHash) (toTextUnsafe hash))
diff --git a/app/Git/CommitHash.hs b/app/Git/CommitHash.hs
index db7a478..0caecf4 100644
--- a/app/Git/CommitHash.hs
+++ b/app/Git/CommitHash.hs
@@ -2,6 +2,7 @@ module Git.CommitHash
( CommitHash (..),
toShortText,
toText,
+ toTextUnsafe,
)
where
@@ -23,6 +24,10 @@ toText :: CommitHash -> Maybe T.Text
toText WorkingTree = Nothing
toText (Commit hash) = Just hash
+toTextUnsafe :: CommitHash -> T.Text
+toTextUnsafe (Commit hash) = hash
+toTextUnsafe _ = error "toTextUnsafe: WorkingDir"
+
instance P.Render CommitHash where
render = P.render . P.Detailed
diff --git a/app/Main.hs b/app/Main.hs
index 52a316d..5d29923 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,5 +1,5 @@
-- TODO Compute history from the top
---
+-- _
-- Currently we are computing the history from the bottom (ie. earliest commit
-- first). When computing history from the top, it might allow us to interrupt
-- the process and present slightly inaccurate information earlier.
@@ -319,6 +319,7 @@ module Main where
import Comment qualified as G
import Control.Applicative ((<|>))
+import Control.Exception (catch)
import Data.Function ((&))
import Data.List (find, intersperse)
import Data.Map qualified as M
@@ -327,6 +328,7 @@ import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Text.Lazy qualified as LT
import Data.Text.Lazy.IO qualified as LT
+import Exception qualified as E
import Git qualified
import History qualified as H
import Issue (Issue (..))
@@ -341,7 +343,9 @@ import Options.Applicative qualified as O
import Process (proc, sh_, textInput)
import Render ((<<<))
import Render qualified as P
+import Review qualified as R
import Settings (Settings (..), readSettings)
+import Status qualified as S
import System.Console.Terminal.Size qualified as Terminal
import System.Exit (ExitCode (ExitFailure), exitWith)
import System.FilePath ((</>))
@@ -424,6 +428,12 @@ data Command
| Open
{ id :: String
}
+ | Status
+ | Review
+ { baseBranch :: T.Text,
+ featureBranch :: T.Text,
+ granularity :: R.Granularity
+ }
| Search
{ pattern :: R.RE,
closed :: Bool,
@@ -444,10 +454,14 @@ cmd =
O.progDesc "Show a log of all issues",
O.command "open" . O.info openCmd $
O.progDesc "Open file containing an issue",
+ O.command "review" . O.info reviewCmd $
+ O.progDesc "Review changes",
O.command "search" . O.info searchCmd $
O.progDesc "List issues matching a pattern",
O.command "show" . O.info showCmd $
O.progDesc "Show details of all issues",
+ O.command "status" . O.info statusCmd $
+ O.progDesc "Describe the current anissue action.",
O.command "tags" . O.info tagsCmd $
O.progDesc "Show all tags"
]
@@ -480,6 +494,36 @@ openCmd =
Open
<$> idArg
+reviewCmd :: O.Parser Command
+reviewCmd =
+ Review
+ <$> baseBranchArg
+ <*> featureBranchArg
+ <*> granularityArg
+
+baseBranchArg :: O.Parser T.Text
+baseBranchArg =
+ O.option O.auto $
+ O.long "base"
+ <> O.short 'b'
+ <> O.metavar "BRANCH"
+ <> O.help "Base branch from which to review changes. Defaults to `main`."
+ <> O.value "main"
+
+featureBranchArg :: O.Parser T.Text
+featureBranchArg =
+ O.strArgument (O.metavar "BRANCH_NAME" <> O.value "HEAD")
+
+granularityArg :: O.Parser R.Granularity
+granularityArg =
+ O.option
+ O.auto
+ ( O.long "granularity"
+ <> O.metavar "GRANULARITY"
+ <> O.help "Granularity of the review. One of `as-one`, `per-commit`, `per-file` or `per-hunk`. Default: `as-one`."
+ <> O.value R.AsOne
+ )
+
showCmd :: O.Parser Command
showCmd =
Show
@@ -492,6 +536,10 @@ patternArg =
(O.maybeReader R.compileRegex)
(O.metavar "PATTERN")
+statusCmd :: O.Parser Command
+statusCmd =
+ pure Status
+
tagsCmd :: O.Parser Command
tagsCmd =
pure Tags
@@ -548,6 +596,20 @@ main :: IO ()
main = do
settings <- readSettings
O.execParser (O.info (options <**> O.helper) O.idm) >>= \case
+ Options {colorize, noPager, width, command = Status} -> do
+ status <- S.readStatus ".anissue/status"
+ putDoc colorize noPager width status
+ Options {colorize, noPager, width, command = Review {baseBranch, featureBranch, granularity}} -> do
+ sh_ "test -z $(git status --porcelain --untracked-files=no)"
+ `catch` \(_ :: E.ProcessException) ->
+ error "working directory not clean, aborting.."
+ S.withReviewing
+ (putDoc colorize noPager width)
+ granularity
+ baseBranch
+ featureBranch
+ ".anissue/status"
+ S.continueReview
Options {colorize, noPager, width, command = List {sort, filters, files, group = Just group, closed}} -> do
ungroupedIssues <-
I.applySorts sort
diff --git a/app/Patch.hs b/app/Patch.hs
index 9e6ed88..a301382 100644
--- a/app/Patch.hs
+++ b/app/Patch.hs
@@ -1,11 +1,12 @@
{-# LANGUAGE DerivingStrategies #-}
module Patch
- ( Patch,
+ ( Patch (..),
parse,
)
where
+import Prettyprinter (pretty)
import Control.Exception (throw)
import Data.Binary (Binary (..))
import Data.Text qualified as T
@@ -31,14 +32,28 @@ instance P.Render Patch where
instance P.Render (P.Detailed Patch) where
render (P.Detailed (Patch {..})) =
- P.vsep $ map prettyFileDelta fileDeltas
+ P.vsep (map prettyFileDelta fileDeltas) <<< ("\n" :: T.Text)
where
- prettyFileDelta (D.FileDelta {..}) = prettyContent fileDeltaContent
+ prettyFileDelta (D.FileDelta {..}) =
+ ("diff --git " <> fileDeltaSourceFile <> " " <> fileDeltaDestFile <> "\n")
+ <<< (prettySourceFile fileDeltaSourceFile <<< ("\n" :: T.Text))
+ <<< (prettyDestFile fileDeltaDestFile <<< ("\n" :: T.Text))
+ <<< prettyContent fileDeltaContent
+ prettySourceFile file = P.styled [P.bold] $ ("---" :: T.Text) <<< file
+ prettyDestFile file = P.styled [P.bold] $ ("+++" :: T.Text) <<< file
prettyContent D.Binary = P.emptyDoc
prettyContent (D.Hunks hunks) = P.vsep (map prettyHunk hunks)
- prettyHunk (D.Hunk {..}) = P.vsep $ map prettyLine hunkLines
+ prettyHunk (D.Hunk {..}) =
+ P.styled [P.color P.Blue] $
+ (prettySourceRange hunkSourceRange hunkDestRange <<< ("\n" :: T.Text))
+ <<< P.vsep (map prettyLine hunkLines)
+ prettySourceRange srcRange dstRange =
+ ("" :: T.Text) <<< ("@@ -" <> prettyRange srcRange <> " +" <> prettyRange dstRange <> " @@")
+ prettyRange (D.Range line lineNo) =
+ T.pack (show line) <> "," <> T.pack (show lineNo)
prettyLine (D.Line {..}) =
case lineAnnotation of
- D.Added -> P.styled [P.color P.Green] $ P.plus @P.AnsiStyle <<< lineContent
- D.Removed -> P.styled [P.color P.Red] $ P.minus @P.AnsiStyle <<< lineContent
- D.Context -> P.styled [P.color P.White] $ P.space @P.AnsiStyle <<< lineContent
+ D.Added -> P.styled [P.color P.Green] $ P.plus @P.AnsiStyle <> pretty lineContent
+ D.Removed -> P.styled [P.color P.Red] $ P.minus @P.AnsiStyle <> pretty lineContent
+ D.Context -> P.styled [P.color P.White] $ P.space @P.AnsiStyle <> pretty lineContent
+ D.Comment -> P.styled [P.color P.White] $ P.hash @P.AnsiStyle <> pretty lineContent
diff --git a/app/Render.hs b/app/Render.hs
index 907ef15..56d78aa 100644
--- a/app/Render.hs
+++ b/app/Render.hs
@@ -24,8 +24,9 @@ module Render
renderAsMarkdown,
-- * Additional symbols
- plus,
+ hash,
minus,
+ plus,
)
where
@@ -81,15 +82,15 @@ instance Render a => Render (IO a) where
(Just a, Nothing) -> a
(Nothing, Just b) -> b
(Just a, Just b) ->
- if endsWithNL a || startsWithNL b
+ if endsWithWS a || startsWithWS b
then a <> b
else a <> space <> b
where
nonEmpty x' =
let x = render x'
in if not (null (show x)) then Just (render x) else Nothing
- startsWithNL = ("\n" `isPrefixOf`) . show . render
- endsWithNL = ("\n" `isSuffixOf`) . show . render
+ startsWithWS = ((||) <$> ("\n" `isPrefixOf`) <*> (" " `isPrefixOf`)) . show . render
+ endsWithWS = ((||) <$> ("\n" `isSuffixOf`) <*> (" " `isSuffixOf`)) . show . render
(===) :: (Render a, Render b) => a -> b -> Doc AnsiStyle
(===) a' b' =
@@ -244,8 +245,7 @@ instance Render D.Node where
pretty ("\")" :: T.Text)
]
-plus :: Doc ann
-plus = pretty ("+" :: T.Text)
-
-minus :: Doc ann
+hash, minus, plus :: Doc ann
+hash = pretty ("#" :: T.Text)
minus = pretty ("-" :: T.Text)
+plus = pretty ("+" :: T.Text)
diff --git a/app/Review.hs b/app/Review.hs
new file mode 100644
index 0000000..e296cee
--- /dev/null
+++ b/app/Review.hs
@@ -0,0 +1,232 @@
+module Review
+ ( Plan (..),
+ Granularity (..),
+ PlanStep (..),
+ formulatePlan,
+ reviewPatch,
+ separateReview,
+ )
+where
+
+import Control.Exception (SomeException, catch)
+import Control.Monad (ap, forM, forM_)
+import Data.Binary qualified as B
+import Data.ByteString.Lazy qualified as LB
+import Data.Function (on, (&))
+import Data.List (groupBy, sortOn)
+import Data.List.NonEmpty qualified as NE
+import Data.List.NonEmpty.Zipper qualified as Z
+import Data.List.NonEmpty.Zipper.Extra ()
+import Data.Maybe (fromMaybe)
+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
+import Text.Read (Lexeme (Ident, Symbol), choice, lexP, readPrec)
+
+data Plan = Plan
+ { baseBranch :: BranchName,
+ granularity :: Granularity,
+ steps :: Z.Zipper PlanStep
+ }
+ deriving (Show, Generic, B.Binary)
+
+type BranchName = T.Text
+
+data Granularity
+ = AsOne
+ | PerCommit
+ | PerFile
+ | PerHunk
+ deriving (Eq, Ord, Generic, B.Binary)
+
+instance Show Granularity where
+ show AsOne = "as-one"
+ show PerCommit = "per-commit"
+ show PerFile = "per-file"
+ show PerHunk = "per-hunk"
+
+instance Read Granularity where
+ readPrec =
+ choice
+ [ do
+ Ident "as" <- lexP
+ Symbol "-" <- lexP
+ Ident "one" <- lexP
+ pure AsOne,
+ do
+ Ident "per" <- lexP
+ Symbol "-" <- lexP
+ choice
+ [ do
+ Ident "commit" <- lexP
+ pure PerCommit,
+ do
+ Ident "file" <- lexP
+ pure PerFile,
+ do
+ Ident "hunk" <- lexP
+ pure PerHunk
+ ]
+ ]
+
+data PlanStep = PlanStep
+ { id :: [Int],
+ commit :: Git.CommitHash,
+ changes :: D.FileDeltas
+ }
+ deriving (Show, Generic, B.Binary)
+
+formulatePlan :: Granularity -> T.Text -> T.Text -> IO Plan
+formulatePlan granularity baseBranch featureBranch = do
+ baseCommit <- Git.resolveRef baseBranch
+ featureCommit <- Git.resolveRef featureBranch
+
+ commits <-
+ if granularity >= 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 (earlierCommit,)
+ . if
+ | granularity >= PerHunk -> splitPerHunk
+ | granularity >= PerFile -> splitPerFile
+ | otherwise -> (: [])
+ . (.fileDeltas)
+ <$> Git.diffOf earlierCommit commit
+
+ pure
+ Plan
+ { steps =
+ Z.fromNonEmpty . fromMaybe (error "TODO") . NE.nonEmpty $
+ map (uncurry (PlanStep {- TODO -} [])) fileDeltas,
+ ..
+ }
+
+splitPerFile :: D.FileDeltas -> [D.FileDeltas]
+splitPerFile =
+ groupBy
+ ((==) `on` (.fileDeltaSourceFile))
+ . sortOn (.fileDeltaSourceFile)
+
+splitPerHunk :: D.FileDeltas -> [D.FileDeltas]
+splitPerHunk =
+ concatMap
+ ( \fileDeltas ->
+ [ hunkToFileDeltas fileDelta hunk
+ | fileDelta <- fileDeltas,
+ let D.Hunks hunks = fileDelta.fileDeltaContent,
+ hunk <- hunks
+ ]
+ )
+ . splitPerFile
+
+hunkToFileDeltas :: D.FileDelta -> D.Hunk -> D.FileDeltas
+hunkToFileDeltas fileDelta hunk =
+ [ fileDelta
+ { D.fileDeltaContent = D.Hunks [hunk]
+ }
+ ]
+
+reviewPatch :: D.FileDeltas -> IO D.FileDeltas
+reviewPatch fileDeltas =
+ withSystemTempDirectory "anissue" $ \tmp -> do
+ let patchFile = tmp </> "a.patch"
+ loop =
+ ( do
+ sh_ (proc "${EDITOR-vi} %" patchFile)
+ T.writeFile patchFile
+ . (renderAsText . A.Patch)
+ . addComments
+ . ((.fileDeltas) . A.parse)
+ =<< T.readFile patchFile
+ ((.fileDeltas) . A.parse . T.decodeUtf8 . LB.toStrict)
+ <$> sh (proc "recountdiff %" patchFile)
+ )
+ `catch` (\(_ :: SomeException) -> loop)
+ T.writeFile patchFile (renderAsText (A.Patch fileDeltas))
+ loop
+
+addComments :: D.FileDeltas -> D.FileDeltas
+addComments =
+ map . mapContent . mapHunks . mapLines $ \line@(D.Line {..}) ->
+ if lineAnnotation == D.Comment
+ then -- TODO Haskell comment
+ D.Line D.Added ("--" <> lineContent)
+ else line
+ 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 (Git.Commit hash) 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 sh (proc "git show %:%" hash 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
diff --git a/app/Status.hs b/app/Status.hs
new file mode 100644
index 0000000..1a0fd4c
--- /dev/null
+++ b/app/Status.hs
@@ -0,0 +1,122 @@
+{-# LANGUAGE DerivingStrategies #-}
+
+module Status
+ ( Status,
+ writeStatus,
+ readStatus,
+ deleteStatus,
+ withReviewing,
+ continueReview,
+ )
+where
+
+import Control.Exception (SomeException, catch)
+import Control.Monad.State (MonadState, StateT, get, put, runStateT)
+import Control.Monad.Trans (MonadIO, liftIO)
+import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)
+import Data.Binary qualified as B
+import Data.List.NonEmpty.Zipper qualified as Z
+import Data.List.NonEmpty.Zipper.Extra ()
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+import GHC.Generics (Generic)
+import Patch qualified as A
+import Render (Render, Summarized (Summarized), render, renderAsText, (<<<), (===))
+import Review qualified as R
+import System.Directory (removeFile)
+import Text.Diff.Extra ()
+import Text.Diff.Parse.Types qualified as D
+
+data Status = Reviewing {plan :: R.Plan, changes :: D.FileDeltas}
+ deriving (Show, Generic, B.Binary)
+
+writeStatus :: FilePath -> Status -> IO ()
+writeStatus = B.encodeFile
+
+readStatus :: FilePath -> IO Status
+readStatus = B.decodeFile
+
+deleteStatus :: FilePath -> IO ()
+deleteStatus fp = removeFile fp
+
+instance Render Status where
+ render (Reviewing {..}) =
+ render ("review in progress\n" :: T.Text)
+ <<< (render (" " :: T.Text) <<< render (Z.lefts plan.steps) <<< render ("\n" :: T.Text))
+ <<< (render ("*" :: T.Text) <<< render (Z.current plan.steps) <<< render ("\n" :: T.Text))
+ <<< (render (" " :: T.Text) <<< render (Z.rights plan.steps) <<< render ("\n" :: T.Text))
+ <<< (render ("run `anissue review` to continue" :: T.Text))
+
+instance Render R.PlanStep where
+ render (R.PlanStep {..}) =
+ render id <<< render (Summarized commit)
+
+instance Render [R.PlanStep] where
+ render [] = render ("" :: T.Text)
+ render (x : xs) = render x === render xs
+
+instance Render [Int] where
+ render [] = render ("[]" :: T.Text)
+ render (x : xs) = render (show x) <<< render xs
+
+newtype ReviewingT m a = ReviewingT
+ { runReviewingT :: StateT (Maybe R.Plan) (WriterT D.FileDeltas m) a
+ }
+ deriving newtype
+ ( Functor,
+ Applicative,
+ Monad,
+ MonadIO,
+ MonadFail,
+ MonadState (Maybe R.Plan),
+ MonadWriter D.FileDeltas
+ )
+
+type BranchName = T.Text
+
+withReviewing ::
+ (forall a. Render a => a -> IO ()) ->
+ R.Granularity ->
+ BranchName ->
+ BranchName ->
+ FilePath ->
+ ReviewingT IO a ->
+ IO a
+withReviewing putDoc granularity baseBranch featureBranch fp action = do
+ (plan, changes) <-
+ (Just <$> readStatus fp)
+ `catch` (\(_ :: SomeException) -> pure Nothing)
+ >>= \case
+ Nothing -> do
+ plan <- R.formulatePlan granularity baseBranch featureBranch
+ let changes = []
+ writeStatus fp $ Reviewing plan changes
+ pure (plan, changes)
+ Just (Reviewing plan changes) -> pure (plan, changes)
+ ((result, maybePlan), ((++) changes) -> changes') <-
+ runWriterT (runStateT (runReviewingT action) (Just plan))
+ case maybePlan of
+ Just plan' -> do
+ let status' = Reviewing plan' changes'
+ writeStatus fp status'
+ putDoc status'
+ Nothing -> do
+ T.writeFile "review.patch" (renderAsText (A.Patch changes'))
+ putDoc $
+ render ("your review has been put into `review.patch`\n" :: T.Text)
+ <<< render ("please apply it manually (`patch -p0 <review.patch`)" :: T.Text)
+ deleteStatus fp
+ pure result
+
+continueReview :: ReviewingT IO ()
+continueReview = do
+ Just plan <- get
+ let step = Z.current plan.steps
+ tell
+ =<< liftIO
+ ( R.separateReview step.commit step.changes
+ =<< R.reviewPatch step.changes
+ )
+ case Z.right plan.steps of
+ Just steps' -> put $ Just $ plan {R.steps = steps'}
+ Nothing -> put Nothing
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 21:40:26 +0000