From f92c593a3d2c4bdb023fdd834b6e8c874d063cc8 Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Thu, 29 Feb 2024 04:11:10 +0100 Subject: feat: add `review` command Prototype of the `review` command, cf. `anissue review -h`. Also adds the `status` command. --- app/Data/List/NonEmpty/Zipper/Extra.hs | 8 ++ app/Git.hs | 23 +++- app/Git/CommitHash.hs | 5 + app/Main.hs | 64 ++++++++- app/Patch.hs | 29 ++++- app/Render.hs | 16 +-- app/Review.hs | 232 +++++++++++++++++++++++++++++++++ app/Status.hs | 122 +++++++++++++++++ 8 files changed, 482 insertions(+), 17 deletions(-) create mode 100644 app/Data/List/NonEmpty/Zipper/Extra.hs create mode 100644 app/Review.hs create mode 100644 app/Status.hs (limited to 'app') 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 put $ Just $ plan {R.steps = steps'} + Nothing -> put Nothing -- cgit v1.2.3