pr-tools (empty) → 0.1.0.0
raw patch · 18 files changed
+2398/−0 lines, 18 filesdep +Diffdep +Globdep +aeson
Dependencies added: Diff, Glob, aeson, base, bytestring, case-insensitive, containers, directory, extra, filepath, http-client, http-client-tls, http-types, optparse-applicative, pr-tools, process, split, temporary, text, time, uuid, yaml
Files
- CHANGELOG.md +0/−0
- LICENSE +28/−0
- README.md +276/−0
- app/pr-fix.hs +330/−0
- app/pr-init.hs +72/−0
- app/pr-merge.hs +108/−0
- app/pr-review.hs +358/−0
- app/pr-send.hs +48/−0
- app/pr-snapshot.hs +73/−0
- app/pr-track.hs +101/−0
- app/pr-view.hs +147/−0
- pr-tools.cabal +181/−0
- src/PRTools/CommentFormatter.hs +81/−0
- src/PRTools/CommentRenderer.hs +150/−0
- src/PRTools/Config.hs +97/−0
- src/PRTools/PRState.hs +168/−0
- src/PRTools/ReviewState.hs +83/−0
- src/PRTools/Slack.hs +97/−0
+ CHANGELOG.md view
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2025, Mihai Giurgeanu++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,276 @@+# PR Tools++A set of command-line tools for managing descentralized git pull requests and code review workflows. These tools help with creating PR snapshots, sending notifications to Slack, tracking approvals, merging PRs, reviewing changes, and viewing annotated diffs.++Please read the [motivation](https://copilot.microsoft.com/shares/pages/VKL8KZ8pMhsYY68x7TZsr) for a more in-depth info about the purpose of these tools.++## Features++- **pr-snapshot**: Generate a Markdown snapshot of the PR including commits and diff summary.+- **pr-send**: Send the PR snapshot to a Slack channel for review.+- **pr-track**: Track PR approvals, status, and commit history.+- **pr-merge**: Merge approved PRs with various strategies and update changelog.+- **pr-review**: Interactive code review tool with comment management.+- **pr-view**: View annotated diffs with review comments.+- **pr-fix**: Fix comments received in a review.+- **pr-init**: Interactively generate configuration file for pr-tools.++## Installation++This project is built with Haskell and Cabal. To install:++1. Ensure you have [GHC](https://www.haskell.org/ghc/) and [Cabal](https://www.haskell.org/cabal/) installed. Use [GHCup](https://www.haskell.org/ghcup/) for easy installation.+ - For Windows, you can use the [Haskell Platform](https://www.haskell.org/platform/).+ - For macOS, you can install GHC and Cabal via Homebrew:+ ```+ brew install ghc cabal-install+ ```+2. Clone the repository:+ ```+ git clone <repository-url>+ cd pr-tools+ ```+3. Build and install the executables:+ ```+ cabal update+ cabal install+ ```++This will install the binaries in `~/.cabal/bin` (or equivalent). Add this directory to your PATH if necessary.++## How to upgrade from source++Update the source tree and reinstall:++ cd pr-tools+ git checkout master && git pull && cabal install --overwrite-policy=always++## Configuration+++## Slack Configurations++PR Tools supports two Slack integration methods: Incoming Webhooks for simple text messages and Slack API Tokens for advanced features like file attachments. Webhooks are easier to set up and sufficient for basic notifications, while API Tokens enable uploading detailed content as files, improving readability for long messages (e.g., reviews or snapshots). If both are configured, the tool prioritizes API Tokens for commands that benefit from attachments; otherwise, it falls back to webhooks.++### Webhook Configuration++Webhooks allow posting plain text messages to a Slack channel. This is ideal for short notifications but may truncate or clutter long content.++To obtain a webhook:+1. Go to [Slack Apps](https://api.slack.com/apps) and create a new app.+2. Enable "Incoming Webhooks" under "Add features & functionality".+3. Activate webhooks and add one to a channel, copying the generated URL (starts with `https://hooks.slack.com/services/`).++Add to your `.pr-tools.yaml`:+```yaml+slack-webhook: "https://hooks.slack.com/services/T00000000/B00000000/XXXXXXXXXXXXXXXXXXXXXXXX"+```++If not set, commands like `pr-send` will fail, and others (e.g., `pr-merge`) will skip notifications.++### Slack API Token Configuration++API Tokens enable file attachments, allowing detailed messages (e.g., from `pr-review send`, `pr-fix send`, `pr-send`) to be uploaded as .md files with a short summary message. This requires a bot token with `files:write` scope.++To obtain a token:+1. Go to [Slack Apps](https://api.slack.com/apps) and create a new app.+2. Under "Add features & functionality", select "Bots" and create a bot user.+3. Under "OAuth & Permissions", add the `files:write` scope (and optionally `chat:write` for messages).+4. Install the app to your workspace, granting permissions.+5. Copy the "Bot User OAuth Token" (starts with `xoxb-`).+6. Find the channel ID: In Slack, right-click the channel, select "View channel details", and copy the ID (starts with `C` or `G`).+7. Invite the `pr-tools` bot to the channel:+ ```+ /invite @pr-tools+ ```++Add to your `.pr-tools.yaml`:+```yaml+slack-token: "xoxb-your-bot-token"+slack-channel: "C0123456789" # Channel ID+```++### Base Branch and Slack Configuration++Use `pr-init` or manually create a `.pr-tools.yaml` file in the project root with:+```yaml+base-branch: main # or your default base branch+slack-webhook: "https://hooks.slack.com/services/T00000000/B00000000/XXXXXXXXXXXXXXXXXXXXXXXX" # optional+slack-token: "xoxb-your-bot-token" # optional for attachments+slack-channel: "C0123456789" # required if using token+```++### Recommended .gitignore Entries++To avoid committing temporary files generated by pr-tools, add the following to your `.gitignore` file:++```+.pr-drafts/+.pr-reviews/+.pr-fixes/+.pr-state.yaml+.pr-tools.yaml # Optional, if you don't want to commit the config+```++## Usage++### pr-snapshot++Generate a Markdown snapshot of the PR including commits and diff summary. The snapshot is saved in .pr-drafts/<branch>.md. If no message is provided, it opens an editor to enter the description.++```+pr-snapshot [BRANCH] [--base-branch BASE] [--message MESSAGE]+```++- `BRANCH`: The feature branch (default: current branch).+- `--base-branch BASE`: Override the configured base branch.+- `--message MESSAGE`, `-m MESSAGE`: Provide the PR description directly without opening an editor.++### pr-send++Send the PR snapshot to a Slack channel for review. Requires slack-webhook configured.++```+pr-send [BRANCH]+```++- `BRANCH`: The feature branch (default: current branch).++### pr-track++Track PR approvals and status.++Subcommands:++```+pr-track approve [BRANCH] --by NAME+pr-track status [BRANCH]+pr-track record [BRANCH]+pr-track update [BRANCH]+pr-track list+```++- `approve [BRANCH] --by NAME`: Approve the PR by the given name. `BRANCH` defaults to current.+- `status [BRANCH]`: Get the status, approvals, and merge status for the PR. Checks if commits are merged into the base branch. `BRANCH` defaults to current.+- `record [BRANCH]`: Record or update the commit snapshot for the PR. Synonyms: update, u, r, rec. `BRANCH` defaults to current.+- `list`: List all tracked PRs with status and approval counts.++### pr-merge++Merge approved PRs with various strategies and update changelog. Optionally sends notification to Slack.++```+pr-merge [BRANCH] [--strategy {fast-forward|squash|rebase}] [--base-branch BASE]+```++- `BRANCH`: The feature branch (default: current).+- `--strategy STRATEGY`: Merge strategy (default: fast-forward).+- `--base-branch BASE`: Override the configured base branch.++### pr-review++Interactive code review tool with comment management.++Subcommands:++```+pr-review start [--base-branch BASE]+pr-review next+pr-review previous+pr-review open+pr-review files+pr-review changes+pr-review comment --file FILE --line LINE --text "COMMENT"+pr-review resolve --id ID+pr-review end+pr-review list+pr-review send+pr-review comments [--with-context]+```++- `start [--base-branch BASE]`: Start or resume a review session. `--base-branch` overrides configured base.+- `next`: Move to the next file and open in editor for commenting.+- `previous`: Move to the previous file and open in editor.+- `open`: Open the current file in editor for commenting.+- `files`: List files with changes, indicating current.+- `changes`: Show the git diff.+- `comment --file FILE --line LINE --text "COMMENT"`: Add a comment via CLI.+- `resolve --id ID`: Mark a comment as resolved.+- `end`: End the review session.+- `list`: List all review sessions.+- `send`: Send the review comments to Slack.+- `comments [--with-context]`: List comments, optionally with code context.++### pr-view++View annotated diff or comments.++Subcommands:++```+pr-view diff [BRANCH] [--base-branch BASE] [--full]+pr-view comments [BRANCH]+```++- `diff [BRANCH] [--base-branch BASE] [--full]`: Show annotated diff with comments. `--full` shows complete files including unchanged areas. `BRANCH` defaults to current.+- `comments [BRANCH]`: List all comments with context. `BRANCH` defaults to current.+- `--base-branch BASE`: Override the configured base branch.++### pr-fix++Manage fix sessions for review comments.++Subcommands:++```+pr-fix start+pr-fix comments [--with-context]+pr-fix files+pr-fix open+pr-fix next+pr-fix previous+pr-fix resolve --id ID --status STATUS [--answer "Explanation"]+pr-fix end+pr-fix send+```++- `start`: Start a fix session by pasting review comments into an editor.+- `comments [--with-context]`: Display comments, optionally with context.+- `files`: List files with comments, indicating current.+- `open`: Open current file with comments inserted for editing and updating status/answers.+- `next`: Move to next file and open.+- `previous`: Move to previous file and open.+- `resolve --id ID --status STATUS [--answer "EXPLANATION"]`: Update comment status (e.g., solved, not-solved, will-not-solve) and optional answer via CLI.+- `end`: End the fix session, requires changes to be committed.+- `send`: Send fix summary to Slack.++### pr-init++Interactively generate or update configuration file (.pr-tools.yaml) for pr-tools, prompting for base-branch, optional slack-webhook, slack-token, slack-channel, and stale-days (with current values as defaults if updating). Also updates .gitignore with recommended entries.++```+pr-init+```++No additional flags.++## Sample Workflow++1. **Create a Feature Branch**: Developer creates a branch, makes changes, and commits.+2. **Generate Snapshot**: Run `pr-snapshot` to create a Markdown description of the PR.+3. **Send to Slack**: Run `pr-send` to notify the team via Slack.+4. **Track Approvals**: Team members approve using `pr-track approve <branch>` or Slack reactions.+5. **Conduct Review**: Reviewer runs `pr-review start`, navigates files with `next`/`open`, adds comments, then `pr-review send` to send compact review to Slack.+6. **Fix Comments**: Developer runs `pr-fix start`, pastes the Slack review message, navigates with `pr-fix next`/`open` to edit files and mark comments (solved/not-solved/will-not-solve), adds answers, or use `pr-fix resolve` for CLI updates, then `pr-fix end` to commit changes, and `pr-fix send` to report back via Slack.+7. **View Annotated Diff**: Anyone can run `pr-view <branch>` to see changes with comments (use --full for full files or `pr-view comments` for comment list).+8. **Merge PR**: Once approved, run `pr-merge <branch>` to merge and update changelog.++This workflow enables collaborative reviews without committing review files to the repo, using Slack for communication.++## Contributing++Contributions are welcome! Please open an issue or submit a pull request.++## License++This project is licensed under the BSD-3-Clause License.
+ app/pr-fix.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.Aeson (encode, object, (.=))+import Data.List (findIndex, foldl', intercalate, isPrefixOf, nub, sortBy, zipWith)+import Data.List.Split (splitOn)+import qualified Data.ByteString.Lazy as LBS+import Data.Char (isSpace, toLower)+import Data.Maybe (fromMaybe, catMaybes, listToMaybe)+import Data.Ord (comparing)+import Data.UUID (toString)+import Data.UUID.V4 (nextRandom)+import Network.HTTP.Client (Response, RequestBody(RequestBodyLBS), httpLbs, method, newManager, parseRequest, requestBody, requestHeaders, responseStatus)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (statusCode)+import Options.Applicative+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.Environment (lookupEnv)+import System.Exit (exitFailure)+import System.FilePath ((</>))+import System.IO (hClose, hPutStr, hPutStrLn, stderr)+import System.IO.Temp (withSystemTempFile)+import System.Process (callProcess, readProcess)+import PRTools.Config (getSlackWebhook, trimTrailing, sanitizeBranch, getSlackToken, getSlackChannel)+import PRTools.ReviewState+import PRTools.CommentRenderer+import PRTools.CommentFormatter+import PRTools.PRState (recordPR)+import PRTools.Slack (sendViaApi, sendViaWebhook)++import Control.Monad (unless)+import qualified Data.Map.Strict as Map+import Data.Maybe (isJust)++trim :: String -> String+trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse++fixDir :: FilePath+fixDir = ".pr-fixes"++getFixFile :: String -> String -> IO FilePath+getFixFile branch fixer = do+ createDirectoryIfMissing False fixDir+ let safeBranch = sanitizeBranch branch+ return $ fixDir </> safeBranch ++ "-fix-" ++ fixer ++ ".yaml"++data FixCommand =+ FStart+ | FComments Bool Bool Bool+ | FFiles+ | FOpen (Maybe String)+ | FNext+ | FPrevious+ | FEnd+ | FSend+ | FResolve { fId :: String, fStatus :: String, fAnswer :: Maybe String }++data Global = Global {}++globalParser :: Parser Global+globalParser = pure Global++commandParser :: Parser FixCommand+commandParser = subparser+ ( command "start" (info (pure FStart <**> helper) (progDesc "Start fix session"))+ <> command "comments" (info (commentsParser <**> helper) (progDesc "Display comments (compact by default)"))+ <> command "files" (info (pure FFiles <**> helper) (progDesc "List files"))+ <> command "open" (info (FOpen <$> optional (strOption (long "file" <> metavar "FILE" <> help "Specific file to open")) <**> helper) (progDesc "Open current or specific file"))+ <> command "next" (info (pure FNext <**> helper) (progDesc "Next file"))+ <> command "previous" (info (pure FPrevious <**> helper) (progDesc "Previous file"))+ <> command "end" (info (pure FEnd <**> helper) (progDesc "End fix session"))+ <> command "send" (info (pure FSend <**> helper) (progDesc "Send fix summary to Slack"))+ <> command "resolve" (info (resolveParser <**> helper) (progDesc "Resolve a comment"))+ )+ where+ commentsParser = FComments+ <$> switch (long "with-context" <> help "Display comments with context")+ <*> switch (long "all" <> help "Display all comments (default: unresolved only)")+ <*> switch (long "resolved" <> help "Display only resolved comments")+ resolveParser = FResolve+ <$> strOption (long "id" <> metavar "ID" <> help "Comment ID")+ <*> strOption (long "status" <> metavar "STATUS" <> help "Status (e.g., solved, not-solved, will-not-solve)")+ <*> optional (strOption (long "answer" <> metavar "ANSWER" <> help "Optional answer/explanation"))++data App = App { appGlobal :: Global, appCommand :: FixCommand }++appParser :: Parser App+appParser = App <$> globalParser <*> commandParser+++handleOpen :: FilePath -> String -> IO ()+handleOpen fixFile branch = do+ mState <- loadReviewState fixFile+ case mState of+ Nothing -> do+ hPutStrLn stderr "No active fix session"+ exitFailure+ Just state -> if rsStatus state /= "fixing" then do+ hPutStrLn stderr "No active fix session"+ exitFailure+ else do+ let idx = rsCurrentIndex state+ let files = rsFiles state+ if idx < 0 || idx >= length files then do+ hPutStrLn stderr "Invalid file index"+ exitFailure+ else do+ let file = files !! idx+ status <- readProcess "git" ["status", "--porcelain", file] ""+ if not (null (trim status)) then do+ hPutStrLn stderr $ "Please commit your changes to " ++ file ++ " before using pr-fix open/next/previous to avoid overwriting uncommitted work in that file."+ exitFailure+ else do+ let fileCmts = filter (\c -> cmFile c == file) (rsComments state)+ augmentedContent <- renderForFix branch file fileCmts+ withSystemTempFile "fix.tmp" $ \tmpPath handle -> do+ hPutStr handle augmentedContent+ hClose handle+ editor <- fromMaybe "vim" <$> lookupEnv "EDITOR"+ callProcess editor [tmpPath]+ editedContent <- readFile tmpPath+ if editedContent == augmentedContent then do+ putStrLn "No changes detected; skipping overwrite."+ else do+ let editedLines = lines editedContent+ mLatest <- loadReviewState fixFile+ let latest = case mLatest of+ Just l -> l+ Nothing -> state+ let (cleanLines, updatedCmts) = parseEditedFix editedLines (rsComments latest)+ writeFile file (unlines cleanLines)+ currentRev <- trimTrailing <$> readProcess "git" ["rev-parse", "HEAD"] ""+ let updatedWithRev = map (\c -> c { cmRevision = currentRev }) updatedCmts+ let newState = latest { rsComments = updatedWithRev }+ saveReviewState fixFile newState++parseEditedFix :: [String] -> [Cmt] -> ([String], [Cmt])+parseEditedFix lines cmts = go lines [] cmts+ where+ go [] accLines accCmts = (reverse accLines, accCmts)+ go (ln:lns) accLines accCmts+ | "-- REVIEW COMMENT BEGIN [" `isPrefixOf` ln =+ let (block, rest) = span (\l -> not ("-- REVIEW COMMENT END" `isPrefixOf` l)) lns+ fullBlock = ln : block -- Exclude the END line if present+ updated = parseBlock fullBlock accCmts+ skipEnd = if not (null rest) && "-- REVIEW COMMENT END" `isPrefixOf` (head rest) then 1 else 0+ afterRest = drop skipEnd rest+ in go afterRest accLines updated -- Skip block, continue with rest+ | otherwise = go lns (ln : accLines) accCmts++ parseBlock :: [String] -> [Cmt] -> [Cmt] -- Returns only updated cmts+ parseBlock (header:body) accCmts =+ let cidStart = length ("-- REVIEW COMMENT BEGIN [" :: String)+ cidEnd = findIndex (== ']') (drop cidStart header) -- Safer than maybe+ cid = case cidEnd of+ Just end -> take 8 (drop cidStart header)+ Nothing -> ""+ afterCid = maybe "" (\end -> drop (cidStart + end + 1) header) cidEnd -- +1 for ]+ statusStart = findSub "[status:" afterCid+ afterStatusLabel = maybe afterCid (\start -> drop (start + 8) afterCid) statusStart+ statusEnd = findSub "]" afterStatusLabel+ status = maybe "not-solved" (\end -> take end afterStatusLabel) statusEnd+ afterStatus = maybe afterStatusLabel (\end -> drop (end + 1) afterStatusLabel) statusEnd+ answerStart = findSub "[answer:" afterStatus+ headerAnswer = maybe Nothing (\start -> Just (drop (start + 8) afterStatus)) answerStart -- Up to end of header+ -- Body: Split comment text and any multi-line answer+ (textLines, answerLines) = span (not . ("[answer:" `isPrefixOf`)) body+ text = intercalate "\n" (map trim textLines)+ bodyAnswer = if null answerLines then Nothing else Just (intercalate "\n" (map trim (tail answerLines))) -- Skip [answer: line if present+ finalAnswer = case (headerAnswer, bodyAnswer) of+ (Just ha, Just ba) -> Just (ha ++ "\n" ++ ba) -- Combine if both+ (Just ha, Nothing) -> Just ha+ (Nothing, Just ba) -> Just ba+ _ -> Nothing+ updated = map (\c -> if cmId c == cid then c { cmText = if null text then cmText c else text, cmStatus = status, cmAnswer = finalAnswer } else c) accCmts+ in updated+ parseBlock _ accCmts = accCmts -- Invalid block, skip++ findSub :: String -> String -> Maybe Int+ findSub sub str = go 0 str+ where go _ [] = Nothing+ go i xs = if sub `isPrefixOf` xs then Just i else go (i+1) (tail xs)++data NavAction = NavNext | NavPrevious | NavOpen++handleNav :: NavAction -> FilePath -> String -> Maybe String -> IO ()+handleNav action ff branch mbFile = do+ mState <- loadReviewState ff+ case mState of+ Nothing -> do+ hPutStrLn stderr "No active fix session"+ exitFailure+ Just state -> if rsStatus state /= "fixing" then do+ hPutStrLn stderr "No active fix session"+ exitFailure+ else do+ updatedState <- case mbFile of+ Just filePath -> do+ let files = rsFiles state+ case findIndex (== filePath) files of+ Just idx -> return state { rsCurrentIndex = idx }+ Nothing -> do+ hPutStrLn stderr $ "File " ++ filePath ++ " not in fix session"+ exitFailure+ Nothing -> return state+ let (finalState, maybeMsg) = case action of+ NavOpen -> (updatedState, Nothing)+ NavPrevious -> if rsCurrentIndex updatedState > 0+ then (updatedState { rsCurrentIndex = rsCurrentIndex updatedState - 1 }, Nothing)+ else (updatedState, Just "No previous files")+ NavNext -> if rsCurrentIndex updatedState < length (rsFiles updatedState) - 1+ then (updatedState { rsCurrentIndex = rsCurrentIndex updatedState + 1 }, Nothing)+ else (updatedState, Just "No more files")+ case maybeMsg of+ Just msg -> putStrLn msg+ Nothing -> do+ saveReviewState ff finalState+ handleOpen ff branch++main :: IO ()+main = do+ App _ cmd <- execParser $ info (appParser <**> helper) idm+ branch <- fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ fixer <- fmap trimTrailing (readProcess "git" ["config", "user.name"] "")+ fixFile <- getFixFile branch fixer+ case cmd of+ FStart -> do+ exists <- doesFileExist fixFile+ if exists then do+ mState <- loadReviewState fixFile+ case mState of+ Just state | rsStatus state == "fixing" -> do+ putStrLn "Active fix session found. Overwrite? (y/n)"+ response <- getLine+ unless (trim (map toLower response) == "y") $ do+ putStrLn "Aborted."+ exitFailure+ _ -> return ()+ else return ()+ withSystemTempFile "paste.tmp" $ \tmpPath handle -> do+ hPutStr handle ""+ hClose handle+ editor <- fromMaybe "vim" <$> lookupEnv "EDITOR"+ callProcess editor [tmpPath]+ pasted <- readFile tmpPath+ parsedCmts <- parsePastedMessage pasted+ currentRev <- trimTrailing <$> readProcess "git" ["rev-parse", "HEAD"] ""+ let updatedCmts = map (\c -> if null (cmRevision c) then c { cmRevision = currentRev } else c) parsedCmts+ let uniqueFiles = nub (map cmFile updatedCmts)+ let state = ReviewState "fixing" 0 uniqueFiles updatedCmts branch fixer+ saveReviewState fixFile state+ putStrLn "Fix session started"+ recordPR branch >>= putStrLn+ FComments withCtx showAll showResolved -> do+ mState <- loadReviewState fixFile+ case mState of+ Just state | rsStatus state == "fixing" -> do+ let filteredCmts = if showAll then rsComments state+ else if showResolved then filter cmResolved (rsComments state)+ else filter (not . cmResolved) (rsComments state)+ displayComments (rsBranch state) filteredCmts withCtx+ _ -> hPutStrLn stderr "No active fix session"+ FFiles -> do+ mState <- loadReviewState fixFile+ case mState of+ Just state | rsStatus state == "fixing" -> do+ let files = rsFiles state+ let current = rsCurrentIndex state+ mapM_ (\(i, f) -> putStrLn $ (if i == current then "> " else " ") ++ f) (zip [0..] files)+ _ -> hPutStrLn stderr "No active fix session"+ FOpen mbFile -> handleNav NavOpen fixFile branch mbFile+ FNext -> handleNav NavNext fixFile branch Nothing+ FPrevious -> handleNav NavPrevious fixFile branch Nothing+ FResolve rid status mbAnswer -> do+ mState <- loadReviewState fixFile+ case mState of+ Nothing -> hPutStrLn stderr "No fix session"+ Just state -> do+ let updatedComments = map (\c -> if cmId c == rid then c { cmStatus = status, cmAnswer = mbAnswer } else c) (rsComments state)+ if updatedComments == rsComments state+ then putStrLn "Comment not found"+ else do+ let newState = state { rsComments = updatedComments }+ saveReviewState fixFile newState+ putStrLn $ "Updated " ++ rid ++ " to " ++ status+ FEnd -> do+ mState <- loadReviewState fixFile+ case mState of+ Nothing -> hPutStrLn stderr "No fix session"+ Just state -> do+ status <- readProcess "git" ["status", "--porcelain"] ""+ if null (trimTrailing status)+ then do+ let newState = state { rsStatus = "fixed" }+ saveReviewState fixFile newState+ putStrLn "Fix session ended"+ else do+ hPutStrLn stderr "Please commit your changes before ending the fix session."+ exitFailure+ FSend -> do+ mState <- loadReviewState fixFile+ case mState of+ Nothing -> hPutStrLn stderr "No fix session"+ Just state -> do+ let comments = rsComments state+ let fullContent = concatMap formatComment comments+ let total = length comments+ let solved = length (filter (\c -> cmStatus c == "solved") comments)+ let answered = length (filter (isJust . cmAnswer) comments)+ let unsolved = length (filter (\c -> cmStatus c == "not-solved") comments)+ let statusCounts = foldl' (\m c -> Map.insertWith (+) (cmStatus c) 1 m) Map.empty comments+ let breakdown = intercalate ", " [k ++ ": " ++ show v | (k, v) <- Map.toList statusCounts]+ let happyAllAnswered = if answered == total then "All comments were answered! 🎉" else ""+ let happyAllSolved = if solved == total then "Everything has been solved! 🎉" else ""+ let happyNoUnsolved = if unsolved == 0 then "No unsolved comments! 🎉" else ""+ let stats = "Solved: " ++ show solved ++ ", Answered: " ++ show answered ++ ", Status breakdown: " ++ breakdown+ let summaryParts = filter (not . null) [happyAllAnswered, happyAllSolved, happyNoUnsolved, stats]+ let summary = "Fix summary for " ++ branch ++ " by " ++ fixer ++ " attached. " ++ intercalate " " summaryParts+ let filename = "fix-summary-" ++ sanitizeBranch branch ++ "-" ++ fixer ++ ".md"+ mbToken <- getSlackToken+ mbChannel <- getSlackChannel+ mbWebhook <- getSlackWebhook+ case (mbToken, mbChannel) of+ (Just token, Just channel) -> sendViaApi summary fullContent filename channel token+ _ -> case mbWebhook of+ Nothing -> do+ hPutStrLn stderr "Slack not configured"+ exitFailure+ Just webhook -> do+ let message = summary ++ "\n" ++ fullContent+ sendViaWebhook webhook message
+ app/pr-init.hs view
@@ -0,0 +1,72 @@+import Data.Maybe (fromMaybe)+import System.Directory (doesFileExist)+import System.IO (hPutStrLn, stderr)+import System.Process (readProcess)+import PRTools.Config (Config(..), getBaseBranch, getSlackWebhook, getSlackToken, getSlackChannel, getStaleDays)++import Control.Monad (when)+import Data.List (isInfixOf)+import System.IO (IOMode(ReadMode, AppendMode), hGetContents, hPutStr, withFile, hFlush, stdout)++main :: IO ()+main = do+ -- Handle .gitignore+ gitignorePath <- return ".gitignore"+ gitignoreExists <- doesFileExist gitignorePath+ let recommended = [ ".pr-drafts/"+ , ".pr-reviews/"+ , ".pr-fixes/"+ , ".pr-state.yaml"+ , ".pr-tools.yaml"+ ]+ if gitignoreExists+ then do+ content <- readFile gitignorePath+ let linesC = lines content+ let missing = filter (\e -> not (any (== e) linesC)) recommended+ if null missing+ then putStrLn ".gitignore already has all recommended entries."+ else do+ putStrLn $ "Adding missing entries to .gitignore: " ++ unwords missing+ withFile gitignorePath AppendMode $ \h -> mapM_ (hPutStrLn h) missing+ else do+ putStrLn "Creating .gitignore with recommended entries."+ writeFile gitignorePath (unlines recommended)++ -- Handle .pr-tools.yaml+ configPath <- return ".pr-tools.yaml"+ configExists <- doesFileExist configPath+ currentBase <- getBaseBranch+ currentWebhook <- getSlackWebhook+ currentToken <- getSlackToken+ currentChannel <- getSlackChannel+ currentStale <- getStaleDays+ let action = if configExists then "Updating" else "Creating"+ putStrLn $ action ++ " .pr-tools.yaml"+ putStr $ "Enter base-branch (current/default: " ++ currentBase ++ "): "+ hFlush stdout+ baseInput <- getLine+ let base = if null baseInput then currentBase else baseInput+ putStr $ "Enter slack-webhook (current: " ++ fromMaybe "not set" currentWebhook ++ ", press Enter to keep): "+ hFlush stdout+ webhookInput <- getLine+ let webhook = if null webhookInput then fromMaybe "" currentWebhook else webhookInput+ let webhookLine = if null webhook then "" else "slack-webhook: " ++ webhook ++ "\n"+ putStr $ "Enter slack-token (current: " ++ fromMaybe "not set" currentToken ++ ", press Enter to keep): "+ hFlush stdout+ tokenInput <- getLine+ let token = if null tokenInput then fromMaybe "" currentToken else tokenInput+ let tokenLine = if null token then "" else "slack-token: " ++ token ++ "\n"+ putStr $ "Enter slack-channel (current: " ++ fromMaybe "not set" currentChannel ++ ", press Enter to keep): "+ hFlush stdout+ channelInput <- getLine+ let channel = if null channelInput then fromMaybe "" currentChannel else channelInput+ let channelLine = if null channel then "" else "slack-channel: " ++ channel ++ "\n"+ putStr $ "Enter stale-days (current/default: " ++ show currentStale ++ ", press Enter to keep): "+ hFlush stdout+ staleInput <- getLine+ let stale = if null staleInput then show currentStale else staleInput+ let staleLine = "stale-days: " ++ stale ++ "\n"+ let content = "base-branch: " ++ base ++ "\n" ++ webhookLine ++ tokenLine ++ channelLine ++ staleLine+ writeFile configPath content+ putStrLn $ ".pr-tools.yaml " ++ (if configExists then "updated." else "created.")
+ app/pr-merge.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Monad (when)+import Data.Aeson (encode, object, (.=))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.CaseInsensitive (mk)+import qualified Data.Map.Strict as Map+import Data.List (head, length, null, (!!))+import Data.Time (formatTime, getCurrentTime)+import Data.Time.Format (defaultTimeLocale)+import Network.HTTP.Client (RequestBody(RequestBodyLBS), httpLbs, method, newManager, parseRequest, requestBody, requestHeaders, responseStatus)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (statusCode)+import Options.Applicative+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.FilePath ((</>))+import System.IO (IOMode(AppendMode), hPutStrLn, stderr, withFile)+import System.Process (callProcess, readProcess)+import PRTools.Config (getBaseBranch, getSlackWebhook, trimTrailing)+import PRTools.PRState++data Opts = Opts+ { optBranch :: Maybe String+ , optStrategy :: String+ , optBase :: Maybe String+ }++optsParser :: Parser Opts+optsParser = Opts+ <$> optional (strArgument (metavar "BRANCH" <> help "The feature branch to merge (default: current branch)"))+ <*> strOption (long "strategy" <> value "fast-forward" <> showDefault <> metavar "STRATEGY" <> help "Merge strategy (fast-forward, squash, rebase)")+ <*> optional (strOption (long "base-branch" <> metavar "BASE" <> help "Override the base branch"))++main :: IO ()+main = do+ args <- getArgs+ if not (null args) && head args == "help" then putStrLn helpText else do+ opts <- execParser $ info (optsParser <**> helper) idm+ baseB <- case optBase opts of+ Just b -> return b+ Nothing -> getBaseBranch+ branch <- case optBranch opts of+ Just b -> return b+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ let strategy = optStrategy opts+ state <- loadState+ case Map.lookup branch state of+ Nothing -> do+ hPutStrLn stderr $ "PR " ++ branch ++ " not approved or not tracked"+ exitFailure+ Just pr -> if null (prApprovals pr) then do+ hPutStrLn stderr $ "PR " ++ branch ++ " not approved or not tracked"+ exitFailure+ else do+ callProcess "git" ["checkout", baseB]+ case strategy of+ "fast-forward" -> callProcess "git" ["merge", "--ff-only", branch]+ "squash" -> do+ callProcess "git" ["merge", "--squash", branch]+ callProcess "git" ["commit", "--message", "Squashed merge of " ++ branch]+ "rebase" -> do+ callProcess "git" ["checkout", branch]+ callProcess "git" ["rebase", baseB]+ callProcess "git" ["checkout", baseB]+ callProcess "git" ["merge", "--ff-only", branch]+ _ -> do+ hPutStrLn stderr "Invalid strategy"+ exitFailure+ let newState = Map.insert branch (PRState "merged" (prApprovals pr) (prSnapshots pr)) state+ saveState newState+ currentTime <- getCurrentTime+ let dateStr = formatTime defaultTimeLocale "%Y-%m-%d" currentTime+ withFile "CHANGELOG.md" AppendMode $ \h -> hPutStrLn h $ "\n- Merged " ++ branch ++ " using " ++ strategy ++ " on " ++ dateStr+ mbWebhook <- getSlackWebhook+ case mbWebhook of+ Nothing -> return ()+ Just webhook -> do+ manager <- newManager tlsManagerSettings+ initReq <- parseRequest webhook+ let req = initReq+ { method = "POST"+ , requestBody = RequestBodyLBS $ encode $ object ["text" .= ("PR " ++ branch ++ " merged using " ++ strategy)]+ , requestHeaders = [(mk "Content-Type", "application/json")]+ }+ response <- httpLbs req manager+ return ()+ putStrLn $ "Merged " ++ branch ++ " using " ++ strategy++helpText :: String+helpText = unlines+ [ "pr-merge"+ , ""+ , "Merge approved PRs with various strategies and update changelog."+ , ""+ , "Usage: pr-merge [BRANCH] [--strategy STRATEGY] [--base-branch BASE]"+ , ""+ , "Arguments:"+ , " BRANCH The feature branch to merge (default: current)"+ , ""+ , "Options:"+ , " --strategy STRATEGY Merge strategy (fast-forward, squash, rebase) (default: fast-forward)"+ , " --base-branch BASE Override the base branch"+ , ""+ , "Examples:"+ , " pr-merge my-feature --strategy squash"+ ]
+ app/pr-review.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Exception (catch, IOException)+import Control.Monad (unless)+import Data.Aeson (encode, object, (.=))+import qualified Data.ByteString.Lazy as LBS+import Data.Algorithm.Diff (PolyDiff(..), getGroupedDiff)+import Data.Char (isSpace)+import Data.List (any, filter, findIndex, foldl', intercalate, zipWith, isPrefixOf)+import Data.List.Split (splitOn)+import Data.Maybe (fromMaybe, catMaybes, listToMaybe)+import Data.UUID (toString)+import Data.UUID.V4 (nextRandom)+import Network.HTTP.Client (Response, RequestBody(RequestBodyLBS), httpLbs, method, newManager, parseRequest, requestBody, requestHeaders, responseStatus)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (statusCode)+import Options.Applicative+import System.Directory (createDirectoryIfMissing, doesFileExist)+import System.Environment (lookupEnv)+import System.Exit (exitFailure)+import System.FilePath ((</>))+import System.FilePath.Glob (glob)+import System.IO (hClose, hPutStr, hPutStrLn, stderr)+import System.IO.Temp (withSystemTempFile)+import System.Process (callProcess, readProcess)+import PRTools.Config (getBaseBranch, getSlackWebhook, reviewDir, trimTrailing, sanitizeBranch, getSlackToken, getSlackChannel)+import PRTools.ReviewState+import PRTools.CommentRenderer+import PRTools.CommentFormatter+import PRTools.PRState (recordPR)+import PRTools.Slack (sendViaApi, sendViaWebhook)++data Global = Global { gBaseBranch :: Maybe String }++globalParser :: Parser Global+globalParser = Global+ <$> optional (strOption+ ( long "base-branch"+ <> metavar "BASE"+ <> help "Override the base branch"+ ))++data Command =+ Start+ | Next+ | Previous+ | Open (Maybe String)+ | Files+ | Changes+ | Comment { cFile :: String, cLine :: Int, cText :: String }+ | Resolve { rId :: String, rStatus :: Maybe String, rAnswer :: Maybe String }+ | End+ | List+ | Send+ | Comments Bool Bool Bool+ | ImportAnswers++data NavAction = NavNext | NavPrevious | NavOpen++commandParser :: Parser Command+commandParser = subparser+ ( command "start" (info (pure Start <**> helper) (progDesc "Start review"))+ <> command "next" (info (pure Next <**> helper) (progDesc "Next file"))+ <> command "previous" (info (pure Previous <**> helper) (progDesc "Previous file"))+ <> command "open" (info (Open <$> optional (strOption (long "file" <> metavar "FILE" <> help "Specific file to open")) <**> helper) (progDesc "Open current or specific file"))+ <> command "files" (info (pure Files <**> helper) (progDesc "List files"))+ <> command "changes" (info (pure Changes <**> helper) (progDesc "Show changes"))+ <> command "comment" (info (commentParser <**> helper) (progDesc "Add comment"))+ <> command "resolve" (info (resolveParser <**> helper) (progDesc "Resolve comment"))+ <> command "end" (info (pure End <**> helper) (progDesc "End review"))+ <> command "list" (info (pure List <**> helper) (progDesc "List reviews"))+ <> command "send" (info (pure Send <**> helper) (progDesc "Send review to Slack"))+ <> command "comments" (info (commentsParser <**> helper) (progDesc "List all comments (compact by default)"))+ <> command "import-answers" (info (pure ImportAnswers <**> helper) (progDesc "Import answers from fix summary"))+ )+ where+ commentParser = Comment+ <$> strOption (long "file" <> metavar "FILE")+ <*> option auto (long "line" <> metavar "LINE")+ <*> strOption (long "text" <> metavar "TEXT")+ resolveParser = Resolve+ <$> strOption (long "id" <> metavar "ID")+ <*> optional (strOption (long "status" <> metavar "STATUS" <> help "Optional status (e.g., solved, not-solved, will-not-solve)"))+ <*> optional (strOption (long "answer" <> metavar "ANSWER" <> help "Optional answer/explanation"))+ commentsParser = Comments+ <$> switch (long "with-context" <> help "Display comments with context")+ <*> switch (long "all" <> help "Display all comments (default: unresolved only)")+ <*> switch (long "resolved" <> help "Display only resolved comments")++trim :: String -> String+trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse++-- No local parsePastedMessage; use shared++getReviewFile :: String -> String -> IO FilePath+getReviewFile branch reviewer = do+ createDirectoryIfMissing False reviewDir+ let safeBranch = sanitizeBranch branch+ return $ reviewDir </> safeBranch ++ "-" ++ reviewer ++ ".yaml"++openEditor :: String -> String -> String -> [Cmt] -> IO [Cmt]+openEditor filePath branch mergeBase existingCmts = do+ conflictContent <- renderForReview mergeBase branch filePath existingCmts+ withSystemTempFile "review.tmp" $ \tmpPath handle -> do+ hPutStr handle conflictContent+ hClose handle+ editor <- fromMaybe "vim" <$> lookupEnv "EDITOR"+ callProcess editor [tmpPath]+ editedContent <- readFile tmpPath+ let editedLines = lines editedContent+ let editedFeature = extractEditedFeature editedLines -- Reuse existing extraction+ featureContent <- readProcess "git" ["show", branch ++ ":" ++ filePath] ""+ let featureLines = lines featureContent+ let newPairs = extractComments featureLines editedFeature -- Reuse+ currentRev <- trimTrailing <$> readProcess "git" ["rev-parse", "HEAD"] ""+ mapM (\(l, t) -> do+ u <- nextRandom+ let cid = take 8 $ filter (/= '-') $ toString u+ return $ Cmt cid filePath l (normalizeComment t) False "not-solved" Nothing currentRev+ ) newPairs++-- Reused helpers+extractEditedFeature :: [String] -> [String]+extractEditedFeature editedLines = go editedLines [] False False+ where+ go [] acc _ _ = reverse acc+ go (ln:lns) acc inBase inFeature+ | ln == "<<<<<<< BASE" = go lns acc True False+ | ln == "=======" = go lns acc False True+ | ln == ">>>>>>> FEATURE" = go lns acc False False+ | "-- REVIEW COMMENT BEGIN [" `isPrefixOf` ln =+ let (block, rest) = span (\l -> not ("-- REVIEW COMMENT END" `isPrefixOf` l)) lns+ skipEnd = if not (null rest) && "-- REVIEW COMMENT END" `isPrefixOf` (head rest) then 1 else 0+ after = drop skipEnd rest+ in go after acc inBase inFeature -- Skip entire block+ | inFeature || (not inBase && not inFeature) = go lns (ln : acc) inBase inFeature+ | otherwise = go lns acc inBase inFeature++extractComments :: [String] -> [String] -> [(Int, String)]+extractComments original edited =+ let diffs = getGroupedDiff original edited+ (cmts, al, current) = foldl' (\(cs, al, cur) d ->+ case d of+ Both ls _ ->+ let newCs = if null cur then cs else cs ++ [(if al == 0 then 1 else al, normalizeComment (intercalate "\n" cur))]+ in (newCs, al + length ls, [])+ First ls ->+ (cs, al + length ls, cur)+ Second ls -> (cs, al, cur ++ ls)+ ) ([], 1, []) diffs+ finalCmts = if null current then cmts else cmts ++ [(if al == 0 then 1 else al, normalizeComment (intercalate "\n" current))]+ in filter (\(_, t) -> not (all isSpace t)) finalCmts -- filter non-empty++data App = App { appGlobal :: Global, appCommand :: Command }++appParser :: Parser App+appParser = App <$> globalParser <*> commandParser++main :: IO ()+main = do+ App global cmd <- execParser $ info (appParser <**> helper) idm+ baseB <- case gBaseBranch global of+ Just b -> return b+ Nothing -> getBaseBranch+ branch <- fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ mergeBase <- trimTrailing <$> readProcess "git" ["merge-base", baseB, branch] ""+ reviewer <- fmap trimTrailing (readProcess "git" ["config", "user.name"] "")+ reviewFile <- getReviewFile branch reviewer+ case cmd of+ Start -> do+ mState <- loadReviewState reviewFile+ case mState of+ Just existing -> do+ filesOut <- readProcess "git" ["diff", "--name-only", mergeBase, "--"] ""+ let files = lines filesOut+ let resumed = existing { rsStatus = "active", rsFiles = files, rsCurrentIndex = 0 }+ saveReviewState reviewFile resumed+ putStrLn "Resuming existing review"+ recordPR branch >>= putStrLn+ Nothing -> do+ filesOut <- readProcess "git" ["diff", "--name-only", mergeBase, "--"] ""+ let files = lines filesOut+ let newState = ReviewState "active" 0 files [] branch reviewer+ saveReviewState reviewFile newState+ putStrLn "New review started"+ recordPR branch >>= putStrLn+ Next -> handleNav NavNext reviewFile branch mergeBase Nothing+ Previous -> handleNav NavPrevious reviewFile branch mergeBase Nothing+ Open mbFile -> handleNav NavOpen reviewFile branch mergeBase mbFile+ Files -> do+ mState <- loadReviewState reviewFile+ case mState of+ Just state | rsStatus state == "active" -> do+ let files = rsFiles state+ let current = rsCurrentIndex state+ mapM_ (\(i, f) -> putStrLn $ (if i == current then "> " else " ") ++ f) (zip [0..] files)+ _ -> do+ out <- readProcess "git" ["diff", "--name-only", mergeBase, "--"] ""+ putStr out+ Changes -> do+ out <- readProcess "git" ["diff", mergeBase, "--"] ""+ putStr out+ Comment file line text -> do+ mState <- loadReviewState reviewFile+ case mState of+ Nothing -> do+ hPutStrLn stderr "No active review"+ exitFailure+ Just state -> if rsStatus state /= "active" then do+ hPutStrLn stderr "No active review"+ exitFailure+ else do+ u <- nextRandom+ let cmtId = take 8 $ filter (/= '-') $ toString u+ currentRev <- trimTrailing <$> readProcess "git" ["rev-parse", "HEAD"] ""+ let newComment = Cmt cmtId file line text False "not-solved" Nothing currentRev+ let newState = state { rsComments = rsComments state ++ [newComment] }+ saveReviewState reviewFile newState+ putStrLn $ "Added comment " ++ cmtId+ Resolve rid mbRStatus mbRAnswer -> do+ mState <- loadReviewState reviewFile+ case mState of+ Nothing -> do+ hPutStrLn stderr "No review"+ exitFailure+ Just state -> do+ let updatedComments = map (\c -> if cmId c == rid then c { cmResolved = True, cmStatus = fromMaybe (cmStatus c) mbRStatus, cmAnswer = fromMaybe (cmAnswer c) (Just mbRAnswer) } else c) (rsComments state)+ if updatedComments == rsComments state+ then putStrLn "Comment not found"+ else do+ let newState = state { rsComments = updatedComments }+ saveReviewState reviewFile newState+ putStrLn $ "Resolved " ++ rid+ End -> do+ mState <- loadReviewState reviewFile+ case mState of+ Nothing -> do+ hPutStrLn stderr "No review"+ exitFailure+ Just state -> do+ let newState = state { rsStatus = "closed" }+ saveReviewState reviewFile newState+ putStrLn "Review ended"+ List -> do+ rfs <- glob (reviewDir </> "*.yaml")+ mapM_ (\rf -> do+ mState <- loadReviewState rf+ case mState of+ Just state -> putStrLn $ rsBranch state ++ " by " ++ rsReviewer state ++ ": " ++ rsStatus state+ Nothing -> return ()+ ) rfs+ Send -> do+ mState <- loadReviewState reviewFile+ case mState of+ Nothing -> do+ hPutStrLn stderr "No review"+ exitFailure+ Just state -> do+ let comments = rsComments state+ let fullContent = concatMap formatComment comments+ let total = length comments+ let solved = length (filter cmResolved comments)+ let unsolved = total - solved+ let summary = if total == 0 || solved == total+ then "Review for " ++ branch ++ " by " ++ reviewer ++ ": Everything is solved! 🎉"+ else "Review for " ++ branch ++ " by " ++ reviewer ++ " attached. Total comments: " ++ show total ++ ", Solved: " ++ show solved ++ ", To solve: " ++ show unsolved ++ "."+ let filename = "review-summary-" ++ sanitizeBranch branch ++ "-" ++ reviewer ++ ".md"+ mbToken <- getSlackToken+ mbChannel <- getSlackChannel+ mbWebhook <- getSlackWebhook+ case (mbToken, mbChannel) of+ (Just token, Just channel) -> sendViaApi summary fullContent filename channel token+ _ -> case mbWebhook of+ Nothing -> do+ hPutStrLn stderr "Slack not configured"+ exitFailure+ Just webhook -> do+ let message = summary ++ "\n" ++ fullContent+ sendViaWebhook webhook message+ Comments withCtx showAll showResolved -> do+ mState <- loadReviewState reviewFile+ case mState of+ Nothing -> do+ hPutStrLn stderr "No review"+ exitFailure+ Just state -> do+ let filteredCmts = if showAll then rsComments state+ else if showResolved then filter cmResolved (rsComments state)+ else filter (not . cmResolved) (rsComments state)+ displayComments branch filteredCmts withCtx+ ImportAnswers -> do+ withSystemTempFile "paste.tmp" $ \tmpPath handle -> do+ hPutStr handle ""+ hClose handle+ editor <- fromMaybe "vim" <$> lookupEnv "EDITOR"+ callProcess editor [tmpPath]+ pasted <- readFile tmpPath+ parsedCmts <- PRTools.CommentFormatter.parsePastedMessage pasted+ mState <- loadReviewState reviewFile+ case mState of+ Nothing -> do+ hPutStrLn stderr "No review"+ exitFailure+ Just state -> do+ let updatedComments = foldl' (\cs pc -> map (\c -> if cmId c == cmId pc then c { cmStatus = cmStatus pc, cmAnswer = cmAnswer pc } else c) cs) (rsComments state) parsedCmts+ mapM_ (\pc -> unless (any (\c -> cmId c == cmId pc) (rsComments state)) $ putStrLn $ "Warning: No matching comment for ID " ++ cmId pc) parsedCmts+ let newState = state { rsComments = updatedComments }+ saveReviewState reviewFile newState+ putStrLn "Imported answers for matching comments"++handleNav :: NavAction -> FilePath -> String -> String -> Maybe String -> IO ()+handleNav action rf branch mergeBase mbFile = do+ mState <- loadReviewState rf+ case mState of+ Nothing -> do+ hPutStrLn stderr "No active review"+ exitFailure+ Just state -> if rsStatus state /= "active" then do+ hPutStrLn stderr "No active review"+ exitFailure+ else do+ updatedState <- case mbFile of+ Just filePath -> do+ let files = rsFiles state+ case findIndex (== filePath) files of+ Just idx -> return state { rsCurrentIndex = idx }+ Nothing -> do+ let newFiles = files ++ [filePath]+ return state { rsFiles = newFiles, rsCurrentIndex = length files }+ Nothing -> return state+ let doOpen st = do+ let filePath = rsFiles st !! rsCurrentIndex st+ let fileCmts = filter (\c -> cmFile c == filePath) (rsComments st)+ newCmts <- openEditor filePath branch mergeBase fileCmts+ mLatest <- loadReviewState rf+ let latest = case mLatest of+ Just l -> l+ Nothing -> st+ let finalState = latest { rsComments = rsComments latest ++ newCmts }+ saveReviewState rf finalState+ return finalState+ let tryOpen st = catch (doOpen st) (\e -> do+ hPutStrLn stderr $ "Error opening file: " ++ show (e :: IOException)+ return st)+ let (finalState, maybeMsg) = case action of+ NavOpen -> (updatedState, Nothing)+ NavPrevious -> if rsCurrentIndex updatedState > 0+ then (updatedState { rsCurrentIndex = rsCurrentIndex updatedState - 1 }, Nothing)+ else (updatedState, Just "No previous files")+ NavNext -> if rsCurrentIndex updatedState < length (rsFiles updatedState) - 1+ then (updatedState { rsCurrentIndex = rsCurrentIndex updatedState + 1 }, Nothing)+ else (updatedState, Just "No more files")+ case maybeMsg of+ Just msg -> putStrLn msg+ Nothing -> do+ saveReviewState rf finalState+ _ <- tryOpen finalState+ return ()
+ app/pr-send.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}++import PRTools.Config (trimTrailing, sanitizeBranch, getSlackWebhook, getSlackToken, getSlackChannel)++import Data.Aeson (encode, object, (.=))+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.CaseInsensitive (mk)+import Network.HTTP.Client (RequestBody(RequestBodyLBS), httpLbs, method, newManager, parseRequest, requestBody, requestHeaders, responseStatus)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (statusCode)+import System.Directory (doesFileExist, getHomeDirectory)+import System.Environment (getArgs)+import System.Exit (exitWith, ExitCode(..))+import System.FilePath ((</>))+import System.IO (hPutStrLn, stderr)+import System.Process (readProcess)+import PRTools.Slack (sendViaApi, sendViaWebhook)++main :: IO ()+main = do+ args <- getArgs+ branch <- if not (null args) then return (head args) else fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ root <- fmap trimTrailing (readProcess "git" ["rev-parse", "--show-toplevel"] "")+ let safeBranch = sanitizeBranch branch+ let mdPath = root </> ".pr-drafts" </> (safeBranch ++ ".md")+ exists <- doesFileExist mdPath+ if not exists+ then do+ hPutStrLn stderr $ "Error: Snapshot not found at " ++ mdPath+ exitWith (ExitFailure 1)+ else do+ md <- readFile mdPath+ let summary = "New PR: " ++ branch ++ ". See attached for details.\n\nReact with :thumbsup: to approve or :thumbsdown: to request changes."+ let fileContent = md+ let filename = "pr-snapshot-" ++ safeBranch ++ ".md"+ mbToken <- getSlackToken+ mbChannel <- getSlackChannel+ mbWebhook <- getSlackWebhook+ case (mbToken, mbChannel) of+ (Just token, Just channel) -> sendViaApi summary fileContent filename channel token+ _ -> case mbWebhook of+ Nothing -> do+ hPutStrLn stderr "Slack not configured"+ exitWith (ExitFailure 1)+ Just webhook -> do+ let message = "New PR: " ++ branch ++ "\n\n" ++ md ++ "\n\nReact with :thumbsup: to approve or :thumbsdown: to request changes."+ sendViaWebhook webhook message
+ app/pr-snapshot.hs view
@@ -0,0 +1,73 @@+import PRTools.Config (getBaseBranch, trimTrailing, sanitizeBranch)+import PRTools.PRState (recordPR)++import Data.List (head, lines, null, unlines)+import Options.Applicative+import System.Directory (createDirectoryIfMissing, getHomeDirectory)+import System.Environment (getArgs, lookupEnv)+import System.FilePath ((</>))+import System.Process (readProcess, callProcess)++data Opts = Opts+ { optBranch :: Maybe String+ , optBase :: Maybe String+ , optMessage :: Maybe String+ }++optsParser :: Parser Opts+optsParser = Opts+ <$> optional (strArgument (metavar "BRANCH" <> help "The feature branch (default: current branch)"))+ <*> optional (strOption (long "base-branch" <> metavar "BASE" <> help "Override the base branch"))+ <*> optional (strOption (long "message" <> short 'm' <> metavar "MESSAGE" <> help "PR description"))++main :: IO ()+main = do+ opts <- execParser $ info (optsParser <**> helper) idm+ baseB <- case optBase opts of+ Just b -> return b+ Nothing -> getBaseBranch+ branch <- case optBranch opts of+ Just b -> return b+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ mergeBase <- trimTrailing <$> readProcess "git" ["merge-base", baseB, branch] ""+ author <- fmap trimTrailing (readProcess "git" ["config", "user.name"] "")+ commitsOut <- readProcess "git" ["log", "--format=%h %s", baseB ++ ".." ++ branch, "--"] ""+ let commitList = unlines $ map ("- " ++) $ lines commitsOut+ diffSummary <- readProcess "git" ["diff", "--stat", mergeBase, branch, "--"] ""+ let descLines = case optMessage opts of+ Just msg -> lines msg+ Nothing -> ["(Enter your PR description here)"]++ let md = unlines+ ( [ "# PR Snapshot for " ++ branch+ , ""+ , "**Author:** " ++ author+ , ""+ , "## Description"+ , ""+ ] ++ descLines +++ [ ""+ , "## Commits"+ , ""+ , commitList+ , ""+ , "## Diff Summary"+ , ""+ , "```"+ , diffSummary+ , "```"+ ] )+ root <- fmap trimTrailing (readProcess "git" ["rev-parse", "--show-toplevel"] "")+ let outputDir = root </> ".pr-drafts"+ createDirectoryIfMissing True outputDir+ let safeBranch = sanitizeBranch branch+ let outputPath = outputDir </> (safeBranch ++ ".md")+ writeFile outputPath md+ case optMessage opts of+ Just _ -> return ()+ Nothing -> do+ editorM <- lookupEnv "EDITOR"+ let editor = maybe "vi" id editorM+ callProcess editor [outputPath]+ putStrLn $ "Snapshot written to " ++ outputPath+ recordPR branch >>= putStrLn
+ app/pr-track.hs view
@@ -0,0 +1,101 @@+import Control.Monad (when)+import qualified Data.Map.Strict as Map+import Data.List (head, intercalate, length, notElem, null, (!!), sortBy)+import Options.Applicative+import System.Exit (exitFailure, ExitCode(..))+import System.IO (hPutStrLn, stderr)+import System.Process (readProcess, readProcessWithExitCode)+import PRTools.Config (trimTrailing, getBaseBranch)+import PRTools.PRState++data Command =+ Approve { aBranch :: Maybe String, aBy :: String }+ | Status { sBranch :: Maybe String }+ | Record { rBranch :: Maybe String }+ | List++commandParser :: Parser Command+commandParser = subparser+ ( command "approve" (info approveParser (progDesc "Approve a PR"))+ <> command "status" (info statusParser (progDesc "Get PR status"))+ <> command "record" (info recordParser (progDesc "Record/update PR commit snapshot"))+ <> command "update" (info recordParser (progDesc "Synonym for record"))+ <> command "u" (info recordParser (progDesc "Shortcut for update"))+ <> command "r" (info recordParser (progDesc "Shortcut for record"))+ <> command "rec" (info recordParser (progDesc "Shortcut for record"))+ <> command "list" (info (pure List) (progDesc "List tracked PRs"))+ )+ where+ approveParser = Approve+ <$> optional (strArgument (metavar "BRANCH" <> help "Branch to approve (default: current)"))+ <*> strOption (long "by" <> metavar "NAME" <> help "Approver name")+ statusParser = Status+ <$> optional (strArgument (metavar "BRANCH" <> help "Branch to check (default: current)"))+ recordParser = Record+ <$> optional (strArgument (metavar "BRANCH" <> help "Branch to record (default: current)"))++main :: IO ()+main = do+ cmd <- execParser $ info (commandParser <**> helper) idm+ state <- loadState+ case cmd of+ Approve mbBranch by -> do+ branch <- case mbBranch of+ Just b -> return b+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ let pr = Map.findWithDefault (PRState "open" [] []) branch state+ let newApprovals = if by `notElem` prApprovals pr then by : prApprovals pr else prApprovals pr+ let newPr = pr { prStatus = prStatus pr, prApprovals = newApprovals, prSnapshots = prSnapshots pr }+ let newState = Map.insert branch newPr state+ saveState newState+ putStrLn $ "Approved " ++ branch ++ " by " ++ by+ Status mbBranch -> do+ branch <- case mbBranch of+ Just b -> return b+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ case Map.lookup branch state of+ Nothing -> putStrLn $ "No status for " ++ branch+ Just pr -> do+ putStrLn $ "Status: " ++ prStatus pr+ putStr "Approvals: "+ putStrLn $ if null (prApprovals pr) then "none" else intercalate ", " (prApprovals pr)+ if null (prSnapshots pr)+ then putStrLn "No snapshots recorded"+ else do+ base <- getBaseBranch+ (code, out, _) <- readProcessWithExitCode "git" ["rev-parse", "--verify", branch] ""+ let branch_exists = code == ExitSuccess+ let branch_tip = if branch_exists then trimTrailing out else ""+ let all_commits = foldl (\m ps -> foldl (\m' ci -> if Map.member (ciHash ci) m' then m' else Map.insert (ciHash ci) (ci, psTimestamp ps) m') m (psCommits ps)) Map.empty (prSnapshots pr)+ temp_list <- mapM (\(ci, ts) -> do+ is_m <- isAncestor (ciHash ci) base+ is_p <- if not branch_exists then return False else isAncestor (ciHash ci) branch_tip+ let s = if is_m then "merged" else if is_p then "pending" else "removed"+ return (ci, s, ts)+ ) (Map.elems all_commits)+ let sorted_statuses = sortBy (\(_,_,ts1) (_,_,ts2) -> compare ts1 ts2) temp_list+ let mergedCount = length [() | (_,s,_) <- sorted_statuses, s == "merged"]+ let pendingCount = length [() | (_,s,_) <- sorted_statuses, s == "pending"]+ let removedCount = length [() | (_,s,_) <- sorted_statuses, s == "removed"]+ let total = length sorted_statuses+ putStrLn $ "Latest snapshot at " ++ psTimestamp (last (prSnapshots pr))+ putStrLn $ "Commit status: " ++ show mergedCount ++ " merged, " ++ show pendingCount ++ " pending, " ++ show removedCount ++ " removed out of " ++ show total+ let latest = last (prSnapshots pr)+ let latest_hashes = map ciHash (psCommits latest)+ let hash_to_s = Map.fromList [ (ciHash ci, s) | (ci, s, _) <- temp_list ]+ let all_latest_merged = not (null latest_hashes) && all (\h -> Map.lookup h hash_to_s == Just "merged") latest_hashes+ if all_latest_merged+ then putStrLn $ "PR is fully merged into " ++ base+ else return ()+ putStrLn "All historical commits:"+ mapM_ (\(ci, s, _) -> putStrLn $ "- " ++ take 7 (ciHash ci) ++ " " ++ ciMessage ci ++ " (" ++ s ++ ")") sorted_statuses+ Record mbBranch -> do+ branch <- case mbBranch of+ Just b -> return b+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ msg <- recordPR branch+ putStrLn $ "Recorded snapshot for " ++ branch ++ (if null msg then "" else ". " ++ msg)+ List -> do+ if Map.null state+ then putStrLn "No PRs tracked"+ else Map.foldrWithKey (\b pr acc -> putStrLn (b ++ ": " ++ prStatus pr ++ " (approvals: " ++ show (length $ prApprovals pr) ++ ")") >> acc) (return ()) state
+ app/pr-view.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE ScopedTypeVariables #-}++import Control.Exception (catch, IOException)+import Control.Monad (foldM)+import Data.List (drop, dropWhile, foldl', head, length, lines, null, take, takeWhile, words, zipWith)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe)+import Data.Yaml (decodeFileEither)+import Options.Applicative+import System.Environment (getArgs)+import System.FilePath ( (</>) )+import System.FilePath.Glob (glob)+import System.Process (readProcess)+import PRTools.Config (getBaseBranch, reviewDir, trimTrailing, sanitizeBranch)+import PRTools.ReviewState (ReviewState(..), Cmt(..))++data Comment = Comment { cReviewer :: String, cText :: String, cResolved :: Bool, cId :: String } deriving Show++type Comments = Map.Map String (Map.Map Int [Comment])++collectComments :: String -> IO Comments+collectComments branch = do+ let safeBranch = sanitizeBranch branch+ rfs <- glob (reviewDir </> (safeBranch ++ "-*.yaml"))+ foldM (\acc rf -> do+ mState <- decodeFileEither rf+ case mState of+ Left _ -> return acc+ Right state -> return $ foldl' (\accC c ->+ let file = cmFile c+ line = cmLine c+ newC = Comment (rsReviewer state) (cmText c) (cmResolved c) (cmId c)+ in Map.alter (\maybeInner ->+ let inner = fromMaybe Map.empty maybeInner+ newInner = Map.alter (\maybeList -> Just (newC : fromMaybe [] maybeList)) line inner+ in Just newInner+ ) file accC+ ) acc (rsComments state)+ ) Map.empty rfs++data Command =+ Diff { dBranch :: Maybe String, dBase :: Maybe String, dFull :: Bool }+ | Comments { cBranch :: Maybe String }++commandParser :: Parser Command+commandParser = subparser+ ( command "diff" (info diffParser (progDesc "View annotated diff (default)"))+ <> command "comments" (info commentsParser (progDesc "List all comments with context"))+ ) <|> (Diff+ <$> optional (strArgument (metavar "BRANCH" <> help "The feature branch (default: current)"))+ <*> optional (strOption (long "base-branch" <> metavar "BASE" <> help "Override the base branch"))+ <*> switch (long "full" <> help "Show full file contents with comments (including unchanged areas)")+ )+ where+ diffParser = Diff+ <$> optional (strArgument (metavar "BRANCH" <> help "The feature branch (default: current)"))+ <*> optional (strOption (long "base-branch" <> metavar "BASE" <> help "Override the base branch"))+ <*> switch (long "full" <> help "Show full file contents with comments (including unchanged areas)")+ commentsParser = Comments+ <$> optional (strArgument (metavar "BRANCH" <> help "The feature branch (default: current)"))++main :: IO ()+main = do+ cmd <- execParser $ info (commandParser <**> helper) idm+ case cmd of+ Diff mbBranch mbBase full -> do+ baseB <- case mbBase of+ Just b -> return b+ Nothing -> getBaseBranch+ branch <- case mbBranch of+ Just b -> return b+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ mergeBase <- trimTrailing <$> readProcess "git" ["merge-base", baseB, branch] ""+ comms <- collectComments branch+ if full then do+ let allFiles = Map.keys comms -- Files with comments+ outputs <- mapM (renderFullFile branch mergeBase comms) allFiles+ putStr (unlines $ ("# Full Annotated Files for " ++ branch) : concat outputs)+ else do+ diffText <- readProcess "git" ["diff", mergeBase, branch, "--"] ""+ let diffLines = lines diffText+ go [] _ _ _ = ["```"]+ go (l:ls) cf cl comms = l : (case cf of+ Just f -> fromMaybe [] (do+ inner <- Map.lookup f comms+ cs <- Map.lookup cl inner+ return $ map (\c -> let status = if cResolved c then "RESOLVED" else "COMMENT"+ txt = map (\ch -> if ch == '\n' then ' ' else ch) (cText c)+ in " # " ++ status ++ " (" ++ cReviewer c ++ ") [id:" ++ cId c ++ "]: " ++ txt) cs+ ) + Nothing -> []) ++ if startsWith "diff --git " l then+ let parts = words l+ newFile = drop 2 (parts !! 3)+ in go ls (Just newFile) 0 comms+ else if startsWith "@@ " l then+ let hunk = words l !! 2+ start = drop 1 hunk+ newCl = read (takeWhile (/= ',') start) :: Int+ in go ls cf newCl comms+ else if not (null l) && (l !! 0 == '+' || l !! 0 == ' ') then go ls cf (cl + 1) comms+ else go ls cf cl comms++ startsWith :: String -> String -> Bool+ startsWith pre str = take (length pre) str == pre+ output = ("# Annotated Diff for " ++ branch) : "" : "```diff" : go diffLines Nothing 0 comms+ putStr (unlines output)+ Comments mbBranch -> do+ branch <- case mbBranch of+ Just b -> return b+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ comms <- collectComments branch+ let allComments = Map.foldrWithKey+ (\file lineMap acc ->+ Map.foldrWithKey+ (\line cs acc' ->+ acc' ++ map (\c -> (file, line, c)) cs+ )+ acc+ lineMap+ )+ []+ comms+ mapM_ (\(file, line, c) -> do+ content <- readProcess "git" ["show", branch ++ ":" ++ file] "" `catch` (\(_ :: IOException) -> return "")+ let fileLines = lines content+ let start = max 0 (line - 4)+ let context = take 7 (drop start fileLines)+ let numberedContext = zipWith (\i ln -> " " ++ show (start + 1 + i) ++ ": " ++ ln) [0..] context+ putStrLn $ "File: " ++ file ++ "\nLine: " ++ show line ++ "\nID: " ++ cId c ++ "\nStatus: " ++ (if cResolved c then "resolved" else "unresolved") ++ "\nComment: " ++ cText c ++ "\nContext:\n" ++ unlines numberedContext ++ "\n---"+ ) allComments++renderFullFile :: String -> String -> Comments -> String -> IO [String]+renderFullFile branch mergeBase comms file = do+ content <- readProcess "git" ["show", branch ++ ":" ++ file] "" `catch` (\(_ :: IOException) -> return "")+ let fileLines = lines content+ baseContent <- readProcess "git" ["show", mergeBase ++ ":" ++ file] "" `catch` (\(_ :: IOException) -> return "")+ let baseLines = lines baseContent+ let lineComments = fromMaybe Map.empty (Map.lookup file comms)+ let annotated = foldl' (\acc (i, line) ->+ let cs = fromMaybe [] (Map.lookup (i+1) lineComments) -- 1-based+ cLines = map (\c -> " # " ++ (if cResolved c then "RESOLVED" else "COMMENT") ++ " (" ++ cReviewer c ++ ") [id:" ++ cId c ++ "]: " ++ trimTrailingNewlines (cText c)) cs+ prefix = if i < length baseLines && baseLines !! i /= line then "+ " else " "+ in acc ++ [prefix ++ line] ++ cLines+ ) [] (zip [0..] fileLines)+ return $ "" : ("## " ++ file) : "```" : annotated ++ ["```"]+ where+ trimTrailingNewlines s = reverse $ dropWhile (== '\n') $ reverse s
+ pr-tools.cabal view
@@ -0,0 +1,181 @@+cabal-version: 3.0+name: pr-tools+version: 0.1.0.0+synopsis: Decentralized git pull request and code review flows+description: A set of command-line tools for managing descentralized+ git pull requests and code review workflows. These tools+ help with creating PR snapshots, sending notifications+ to Slack, tracking approvals, merging PRs, reviewing+ changes, and viewing annotated diffs.++ - pr-snapshot: Generate a Markdown snapshot of the PR including commits and diff summary.+ - pr-send: Send the PR snapshot to a Slack channel for review.+ - pr-track: Track PR approvals, status, and commit history.+ - pr-merge: Merge approved PRs with various strategies and update changelog.+ - pr-review: Interactive code review tool with comment management.+ - pr-view: View annotated diffs with review comments.+ - pr-fix: Fix comments received in a review.+ - pr-init: Interactively generate configuration file for pr-tools.++license: BSD-3-Clause+license-file: LICENSE+author: Mihai Giurgeanu+copyright: (c) 2025 Mihai Giurgeanu+maintainer: mihai.giurgeanu@gmail.com+homepage: https://github.com/mihaigiurgeanu/pr-tools+build-type: Simple+extra-doc-files: README.md, CHANGELOG.md+category: Git, Development+stability: beta+bug-reports: https://github.com/mihaigiurgeanu/pr-tools/issues++source-repository head+ type: git+ location: https://github.com/mihaigiurgeanu/pr-tools.git++source-repository this+ type: git+ location: https://github.com/mihaigiurgeanu/pr-tools.git+ tag: 0.1.0.0++common commons+ default-language: Haskell2010+ build-depends: base >=4.14 && <5++library+ import: commons+ exposed-modules: PRTools.Config+ , PRTools.PRState+ , PRTools.ReviewState+ , PRTools.CommentRenderer+ , PRTools.CommentFormatter+ , PRTools.Slack+ build-depends: aeson >= 2.2.3 && < 2.3+ , containers >= 0.6.7 && < 0.7+ , directory >= 1.3.8 && < 1.4+ , process >= 1.6.19 && < 1.7+ , yaml >= 0.11.11 && < 0.12+ , Diff >= 1.0.2 && < 1.1+ , time >= 1.12.2 && < 1.13+ , extra >= 1.8 && < 1.9+ , uuid >= 1.3.16 && < 1.4+ , bytestring >= 0.11.5 && < 0.12+ , http-client >= 0.7.19 && < 0.8+ , http-client-tls >= 0.3.6 && < 0.4+ , http-types >= 0.12.4 && < 0.13+ , text >= 2.0.2 && < 2.1+ , case-insensitive >= 1.2.1 && < 1.3+ , split >= 0.2.5 && < 0.3+ hs-source-dirs: src++executable pr-snapshot+ import: commons+ main-is: pr-snapshot.hs+ build-depends: pr-tools+ , directory >= 1.3.8 && < 1.4+ , filepath >= 1.4.301 && < 1.5+ , optparse-applicative >= 0.19.0 && < 0.20+ , process >= 1.6.19 && < 1.7+ hs-source-dirs: app++executable pr-send+ import: commons+ main-is: pr-send.hs+ build-depends: aeson >= 2.2.3 && < 2.3+ , bytestring >= 0.11.5 && < 0.12+ , case-insensitive >= 1.2.1 && < 1.3+ , directory >= 1.3.8 && < 1.4+ , filepath >= 1.4.301 && < 1.5+ , http-client >= 0.7.19 && < 0.8+ , http-client-tls >= 0.3.6 && < 0.4+ , http-types >= 0.12.4 && < 0.13+ , process >= 1.6.19 && < 1.7+ , pr-tools+ hs-source-dirs: app++executable pr-track+ import: commons+ main-is: pr-track.hs+ build-depends: pr-tools+ , containers >= 0.6.7 && < 0.7+ , optparse-applicative >= 0.19.0 && < 0.20+ , process >= 1.6.19 && < 1.7+ , time >= 1.12.2 && < 1.13+ hs-source-dirs: app++executable pr-merge+ import: commons+ main-is: pr-merge.hs+ build-depends: pr-tools+ , aeson >= 2.2.3 && < 2.3+ , bytestring >= 0.11.5 && < 0.12+ , case-insensitive >= 1.2.1 && < 1.3+ , containers >= 0.6.7 && < 0.7+ , filepath >= 1.4.301 && < 1.5+ , http-client >= 0.7.19 && < 0.8+ , http-client-tls >= 0.3.6 && < 0.4+ , http-types >= 0.12.4 && < 0.13+ , optparse-applicative >= 0.19.0 && < 0.20+ , process >= 1.6.19 && < 1.7+ , time >= 1.12.2 && < 1.13+ hs-source-dirs: app++executable pr-review+ import: commons+ main-is: pr-review.hs+ build-depends: pr-tools+ , aeson >= 2.2.3 && < 2.3+ , bytestring >= 0.11.5 && < 0.12+ , Diff >= 1.0.2 && < 1.1+ , directory >= 1.3.8 && < 1.4+ , filepath >= 1.4.301 && < 1.5+ , Glob >= 0.10.2 && < 0.11+ , http-client >= 0.7.19 && < 0.8+ , http-client-tls >= 0.3.6 && < 0.4+ , http-types >= 0.12.4 && < 0.13+ , optparse-applicative >= 0.19.0 && < 0.20+ , process >= 1.6.19 && < 1.7+ , temporary >= 1.3 && < 1.4+ , uuid >= 1.3.16 && < 1.4+ , split >= 0.2.5 && < 0.3+ hs-source-dirs: app++executable pr-view+ import: commons+ main-is: pr-view.hs+ build-depends: pr-tools+ , containers >= 0.6.7 && < 0.7+ , filepath >= 1.4.301 && < 1.5+ , Glob >= 0.10.2 && < 0.11+ , optparse-applicative >= 0.19.0 && < 0.20+ , process >= 1.6.19 && < 1.7+ , yaml >= 0.11.11 && < 0.12+ hs-source-dirs: app++executable pr-fix+ import: commons+ main-is: pr-fix.hs+ build-depends: pr-tools+ , aeson >= 2.2.3 && < 2.3+ , bytestring >= 0.11.5 && < 0.12+ , containers >= 0.6.7 && < 0.7+ , directory >= 1.3.8 && < 1.4+ , filepath >= 1.4.301 && < 1.5+ , http-client >= 0.7.19 && < 0.8+ , http-client-tls >= 0.3.6 && < 0.4+ , http-types >= 0.12.4 && < 0.13+ , optparse-applicative >= 0.19.0 && < 0.20+ , process >= 1.6.19 && < 1.7+ , split >= 0.2.5 && < 0.3+ , temporary >= 1.3 && < 1.4+ , uuid >= 1.3.16 && < 1.4+ , yaml >= 0.11.11 && < 0.12+ hs-source-dirs: app++executable pr-init+ import: commons+ main-is: pr-init.hs+ build-depends: pr-tools+ , directory >= 1.3.8 && < 1.4+ , process >= 1.6.19 && < 1.7+ hs-source-dirs: app
+ src/PRTools/CommentFormatter.hs view
@@ -0,0 +1,81 @@+module PRTools.CommentFormatter where++import Data.Char (isSpace)+import Data.List (findIndex, intercalate, isPrefixOf)+import Data.List.Extra (trim)+import Data.List.Split (splitOn)+import Data.Maybe (fromMaybe, catMaybes, listToMaybe)+import Data.UUID (toString)+import Data.UUID.V4 (nextRandom)+import PRTools.ReviewState (Cmt(..))+import System.IO (hPutStrLn, stderr)++formatComment :: Cmt -> String+formatComment c =+ unlines [ "File: " ++ cmFile c+ , "Line: " ++ show (cmLine c)+ , "ID: " ++ cmId c+ , "Status: " ++ cmStatus c+ , "Resolved: " ++ show (cmResolved c)+ , "Revision: " ++ cmRevision c+ , "Comment:"+ ] ++ cmText c ++ "\n" +++ (case cmAnswer c of+ Just a | not (all isSpace a) -> "Answer: " ++ a ++ "\n"+ _ -> []) +++ "---"++parseSection :: String -> IO (Maybe Cmt)+parseSection s = do+ let ls = lines s+ let findKeyIdx key = findIndex (\ln -> key `isPrefixOf` trim ln) ls+ let getValue :: Int -> String -> Maybe String+ getValue idx key = if idx < 0 then Nothing else let ln = ls !! idx in Just (drop (length key) ln)+ let fileIdx = findKeyIdx "File:"+ let lineIdx = findKeyIdx "Line:"+ let idIdx = findKeyIdx "ID:"+ let statusIdx = findKeyIdx "Status:"+ let resolvedIdx = findKeyIdx "Resolved:"+ let revisionIdx = findKeyIdx "Revision:"+ let commentIdx = findKeyIdx "Comment:"+ let answerIdx = findKeyIdx "Answer:"+ case (fileIdx, lineIdx, idIdx, statusIdx, commentIdx) of+ (Just fIdx, Just lIdx, Just iIdx, Just sIdx, Just cIdx) -> do+ let fileM = trim <$> getValue fIdx "File:"+ let lineStrM = trim <$> getValue lIdx "Line:"+ let lineM = lineStrM >>= \str -> case reads str of {[(l, "")] -> Just l; _ -> Nothing}+ let cidM = trim <$> getValue iIdx "ID:"+ let statusM = trim <$> getValue sIdx "Status:"+ let resolvedM = resolvedIdx >>= (\rIdx -> trim <$> getValue rIdx "Resolved:") >>= \str -> Just (str == "True")+ let revisionM = revisionIdx >>= (\rIdx -> trim <$> getValue rIdx "Revision:")+ case (fileM, lineM, cidM) of+ (Just file, Just line, Just cid) | not (null file) && not (null cid) -> do+ let status = fromMaybe "not-solved" statusM+ let resolved = fromMaybe False resolvedM+ let revision = fromMaybe "" revisionM+ let commentStart = getValue cIdx "Comment:"+ let commentEndIdx = fromMaybe (length ls) answerIdx+ let commentRest = take (commentEndIdx - cIdx - 1) (drop (cIdx + 1) ls)+ let commentParts = maybe [] (: commentRest) commentStart+ let commentText = intercalate "\n" (map trim commentParts)+ let answerStart = answerIdx >>= ( `getValue` "Answer:")+ let answerRest = drop (commentEndIdx + 1) ls+ let answerParts = maybe [] (: answerRest) answerStart+ let answerText = intercalate "\n" (map trim answerParts)+ let finalAnswer = if all isSpace answerText then Nothing else Just answerText+ u <- if null cid then nextRandom else return undefined+ let finalId = if null cid then take 8 $ filter (/= '-') $ toString u else cid+ return $ Just $ Cmt finalId file line commentText resolved status finalAnswer revision+ _ -> putStrLn "Section skipped: missing or invalid required fields." >> return Nothing+ _ -> putStrLn "Section skipped: missing or misordered fields." >> return Nothing++parsePastedMessage :: String -> IO [Cmt]+parsePastedMessage content = do+ let sections = filter (not . all isSpace . unlines . lines) $ splitOn "---" content+ putStrLn $ "Found " ++ show (length sections) ++ " sections to parse."+ parsedSections <- mapM parseSection sections+ let validCmts = catMaybes parsedSections+ if null validCmts+ then putStrLn "No valid comments parsed from any sections."+ else putStrLn $ "Successfully parsed " ++ show (length validCmts) ++ " comments."+ return validCmts
+ src/PRTools/CommentRenderer.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}++module PRTools.CommentRenderer where++import Control.Exception (catch, IOException)+import Data.Algorithm.Diff (PolyDiff(..), getGroupedDiff)+import Data.List (foldl', sortBy, isPrefixOf, intercalate, dropWhile, span)+import Data.List.Extra (trim, splitOn)+import System.IO (hPutStrLn, stderr)+import System.Process (readProcess)+import PRTools.ReviewState (Cmt(..))+import Data.Maybe (fromMaybe, catMaybes)+import Data.Ord (comparing)+import PRTools.Config (trimTrailing)+import Control.Arrow (first)++-- Remap a line number from old revision to current+remapLine :: String -> String -> String -> Int -> IO Int+remapLine revision file branch target = do+ oldContent <- catch (readProcess "git" ["show", revision ++ ":" ++ file] "")+ (\e -> do hPutStrLn stderr $ "Warning: " ++ show (e :: IOException); return "")+ currentContent <- readProcess "git" ["show", branch ++ ":" ++ file] ""+ let oldLines = lines oldContent+ let currentLines = lines currentContent+ let diffs = getGroupedDiff oldLines currentLines+ return $ go diffs 1 1 target+ where+ go [] o n t = n + (t - o)+ go (d:ds) o n t = case d of+ Both ls _ ->+ let size = length ls+ in if o + size > t then n + (t - o)+ else go ds (o + size) (n + size) t+ First ls ->+ let size = length ls+ in if o + size > t then n+ else go ds (o + size) n t+ Second ls ->+ let size = length ls+ in go ds o (n + size) t++-- Render for review: conflict style with comments inserted+renderForReview :: String -> String -> String -> [Cmt] -> IO String+renderForReview mergeBase branch file cmts = do+ baseContent <- catch (readProcess "git" ["show", mergeBase ++ ":" ++ file] "")+ (\(_ :: IOException) -> return "")+ featureContent <- catch (readProcess "git" ["show", branch ++ ":" ++ file] "")+ (\e -> do hPutStrLn stderr $ "Warning: " ++ show (e :: IOException); return "")+ currentRev <- trimTrailing <$> readProcess "git" ["rev-parse", branch] ""+ let baseLines = lines baseContent+ let featureLines = lines featureContent+ adjustedCmts <- mapM (\c -> do+ newLine <- if cmRevision c == currentRev then return (cmLine c) else remapLine (cmRevision c) (cmFile c) branch (cmLine c)+ return c { cmLine = newLine }+ ) cmts+ let sortedCmts = sortBy (comparing cmLine) adjustedCmts+ let groups = getGroupedDiff baseLines featureLines+ let conflictLines = recBuild 1 groups+ let augmented = insertComments conflictLines sortedCmts+ return $ unlines augmented+ where+ annotateFeatureLines :: Int -> [String] -> [(Maybe Int, String)]+ annotateFeatureLines n ls = let feature_lines = zip [n ..] ls+ in map (first Just) feature_lines++ recBuild :: Int -> [PolyDiff [String] [String]] -> [(Maybe Int, String)]+ recBuild _ [] = []+ recBuild n (g:gs) = case g of+ Both ls _ ->+ let annotated = annotateFeatureLines n ls+ in annotated ++ recBuild (n + length ls) gs+ First ls ->+ let base_lines = map (Nothing ,) ls+ in case gs of+ (Second ms : rest) ->+ let annotated = annotateFeatureLines n ms+ in (Nothing, "<<<<<<< BASE") : base_lines ++ (Nothing, "=======") : annotated ++ (Nothing, ">>>>>>> FEATURE") : recBuild (n + length ms) rest+ _ ->+ (Nothing, "<<<<<<< BASE") : base_lines ++ (Nothing, "=======") : (Nothing, ">>>>>>> FEATURE") : recBuild n gs+ Second ms ->+ let annotated = annotateFeatureLines n ms+ in (Nothing, "<<<<<<< BASE") : (Nothing, "=======") : annotated ++ (Nothing, ">>>>>>> FEATURE") : recBuild (n + length ms) gs++ insertComments :: [(Maybe Int, String)] -> [Cmt] -> [String]+ insertComments clines scmts =+ let go (rev_acc, rem_cmts) (mb_l, line) =+ case mb_l of+ Nothing -> (line : rev_acc, rem_cmts)+ Just l ->+ let (inserted, remaining) = span (\c -> cmLine c == l) rem_cmts+ markers = concatMap renderCommentMarker inserted+ to_add = markers ++ [line]+ new_rev = foldl' (flip (:)) rev_acc to_add+ in (new_rev, remaining)+ (final_rev, final_rem) = foldl' go ([], scmts) clines+ augmented = reverse final_rev+ final_aug = if null final_rem then augmented else augmented ++ concatMap renderCommentMarker final_rem+ in final_aug++-- Render for fix: current content with editable markers+renderForFix :: String -> String -> [Cmt] -> IO String+renderForFix branch file cmts = do+ content <- catch (readProcess "git" ["show", branch ++ ":" ++ file] "")+ (\e -> do hPutStrLn stderr $ "Warning: " ++ show (e :: IOException); return "")+ currentRev <- trimTrailing <$> readProcess "git" ["rev-parse", branch] ""+ let fileLines = lines content+ adjustedCmts <- mapM (\c -> do+ newLine <- if cmRevision c == currentRev then return (cmLine c) else remapLine (cmRevision c) (cmFile c) branch (cmLine c)+ return c { cmLine = newLine }+ ) cmts+ let sortedCmts = sortBy (comparing cmLine) adjustedCmts+ let (augmentedLines, _) = foldl' insertComment (fileLines, 0) sortedCmts+ return $ unlines augmentedLines+ where+ insertComment :: ([String], Int) -> Cmt -> ([String], Int)+ insertComment (acc, offset) c =+ let insert_pos' = cmLine c + offset - 1+ insert_pos = max 0 insert_pos'+ before = take insert_pos acc+ after = drop insert_pos acc+ markerLines = renderCommentMarker c+ in (before ++ markerLines ++ after, offset + length markerLines)++normalizeComment :: String -> String+normalizeComment = intercalate "\n" . map trim . lines++renderCommentMarker :: Cmt -> [String]+renderCommentMarker c =+ let header = "-- REVIEW COMMENT BEGIN [" ++ cmId c ++ "] [status:" ++ cmStatus c ++ "]" ++ (if cmResolved c then " [resolved]" else "") ++ " [answer:" ++ fromMaybe "" (cmAnswer c) ++ "]"+ textLines = lines (cmText c)+ in header : textLines ++ ["-- REVIEW COMMENT END"]++displayComments :: String -> [Cmt] -> Bool -> IO ()+displayComments branch cmts withCtx = do+ if withCtx then+ mapM_ (\c -> do+ content <- readProcess "git" ["show", branch ++ ":" ++ cmFile c] ""+ let fileLines = lines content+ let start = max 0 (cmLine c - 4)+ let context = take 7 (drop start fileLines)+ let numberedContext = zipWith (\i ln -> " " ++ show (start + 1 + i) ++ ": " ++ ln) [0..] context+ putStrLn $ "File: " ++ cmFile c ++ "\nLine: " ++ show (cmLine c) ++ "\nID: " ++ cmId c ++ "\nResolved: " ++ show (cmResolved c) ++ "\nStatus: " ++ cmStatus c ++ "\nComment: " ++ cmText c ++ "\nAnswer: " ++ fromMaybe "" (cmAnswer c) ++ "\nContext:\n" ++ unlines numberedContext ++ "\n---"+ ) cmts+ else+ mapM_ (\c -> putStrLn $ cmFile c ++ ":" ++ show (cmLine c) ++ " [" ++ cmId c ++ "][" ++ (if cmResolved c then "Resolved" else "") ++ "]\n\t" ++ replace '\n' " | " (trim (cmText c)) ++ " [" ++ cmStatus c ++ "]" ++ maybe "" (\a -> " answer: " ++ replace '\n' " | " (trim a)) (cmAnswer c) ++ "\n") cmts+ where+ replace old new s = intercalate new (splitOn [old] s)+
+ src/PRTools/Config.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module PRTools.Config where++import Control.Exception (catch, IOException)+import Data.List (drop, init, length, null)+import Data.Maybe (fromMaybe)+import Data.Yaml (FromJSON(..), ParseException, decodeFileEither, parseJSON, withObject, (.:), (.:?))+import System.Directory (doesFileExist)+import System.Process (readProcess)++data Config = Config { cfgBaseBranch :: String, cfgSlackWebhook :: Maybe String, cfgStaleDays :: Maybe Int, cfgSlackToken :: Maybe String, cfgSlackChannel :: Maybe String } deriving Show++instance FromJSON Config where+ parseJSON = withObject "Config" $ \v -> Config <$> v .: "base-branch" <*> v .:? "slack-webhook" <*> v .:? "stale-days" <*> v .:? "slack-token" <*> v .:? "slack-channel"++getBaseBranch :: IO String+getBaseBranch = do+ let configPath = ".pr-tools.yaml"+ exists <- doesFileExist configPath+ if exists+ then do+ res <- decodeFileEither configPath+ case res of+ Right config -> return $ cfgBaseBranch config+ Left _ -> getDynamicBase+ else getDynamicBase++getSlackWebhook :: IO (Maybe String)+getSlackWebhook = do+ let configPath = ".pr-tools.yaml"+ exists <- doesFileExist configPath+ if exists+ then do+ res <- decodeFileEither configPath+ case res of+ Right config -> return $ cfgSlackWebhook config+ Left _ -> return Nothing+ else return Nothing++getSlackToken :: IO (Maybe String)+getSlackToken = do+ let configPath = ".pr-tools.yaml"+ exists <- doesFileExist configPath+ if exists+ then do+ res <- decodeFileEither configPath+ case res of+ Right config -> return $ cfgSlackToken config+ Left _ -> return Nothing+ else return Nothing++getSlackChannel :: IO (Maybe String)+getSlackChannel = do+ let configPath = ".pr-tools.yaml"+ exists <- doesFileExist configPath+ if exists+ then do+ res <- decodeFileEither configPath+ case res of+ Right config -> return $ cfgSlackChannel config+ Left _ -> return Nothing+ else return Nothing++getStaleDays :: IO Int+getStaleDays = do+ let configPath = ".pr-tools.yaml"+ exists <- doesFileExist configPath+ if exists+ then do+ res <- decodeFileEither configPath+ case res of+ Right config -> return $ fromMaybe 14 (cfgStaleDays config)+ Left _ -> return 14+ else return 14++getDynamicBase :: IO String+getDynamicBase = do+ ref <- catch (readProcess "git" ["symbolic-ref", "refs/remotes/origin/HEAD"] "")+ (\(_ :: IOException) -> return "")+ let trimmedRef = reverse $ dropWhile (== '\n') $ reverse ref -- remove trailing newlines+ if null trimmedRef+ then return "main"+ else do+ let prefix :: String = "refs/remotes/origin/"+ let branch = drop (length prefix) trimmedRef+ return $ if null branch then "main" else branch++trimTrailing :: String -> String+trimTrailing str = reverse $ dropWhile (== '\n') $ reverse str++sanitizeBranch :: String -> String+sanitizeBranch = map (\c -> if c == '/' then '-' else c)++reviewDir :: FilePath+reviewDir = ".pr-reviews"
+ src/PRTools/PRState.hs view
@@ -0,0 +1,168 @@+module PRTools.PRState where++import Data.Aeson (ToJSON(..), object, (.=))+import Data.Aeson.Key (fromString)+import Data.Aeson.Types ((.!=))+import qualified Data.Map.Strict as Map+import Data.Yaml (FromJSON(..), decodeFileEither, encodeFile, parseJSON, withObject, (.:), (.:?))+import System.Directory (doesFileExist)+import System.Exit (exitFailure)+import System.IO (hPutStrLn, stderr)+import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, formatTime, getCurrentTime)+import Data.Time.Format (defaultTimeLocale, parseTimeM)+import System.Process (readProcess, readProcessWithExitCode)+import PRTools.Config (getBaseBranch, trimTrailing, getStaleDays)+import System.Exit (ExitCode(..))++data CommitInfo = CommitInfo { ciHash :: String, ciMessage :: String } deriving (Eq, Show)++instance FromJSON CommitInfo where+ parseJSON = withObject "CommitInfo" $ \v -> CommitInfo+ <$> v .: fromString "hash"+ <*> v .: fromString "message"++instance ToJSON CommitInfo where+ toJSON ci = object+ [ fromString "hash" .= ciHash ci+ , fromString "message" .= ciMessage ci+ ]++data PRSnapshot = PRSnapshot { psTimestamp :: String, psCommits :: [CommitInfo] } deriving (Eq, Show)++instance FromJSON PRSnapshot where+ parseJSON = withObject "PRSnapshot" $ \v -> PRSnapshot+ <$> v .: fromString "timestamp"+ <*> v .: fromString "commits"++instance ToJSON PRSnapshot where+ toJSON ps = object+ [ fromString "timestamp" .= psTimestamp ps+ , fromString "commits" .= psCommits ps+ ]++data PRState = PRState { prStatus :: String, prApprovals :: [String], prSnapshots :: [PRSnapshot] } deriving (Eq, Show)++instance FromJSON PRState where+ parseJSON = withObject "PRState" $ \v -> PRState+ <$> v .: fromString "status"+ <*> v .:? fromString "approvals" .!= []+ <*> v .:? fromString "snapshots" .!= []++instance ToJSON PRState where+ toJSON p = object+ [ fromString "status" .= prStatus p+ , fromString "approvals" .= prApprovals p+ , fromString "snapshots" .= prSnapshots p+ ]++statePath :: FilePath+statePath = ".pr-state.yaml"++loadState :: IO (Map.Map String PRState)+loadState = do+ exists <- doesFileExist statePath+ if exists+ then do+ res <- decodeFileEither statePath+ case res of+ Left err -> do+ hPutStrLn stderr (show err)+ exitFailure+ Right val -> return val+ else return Map.empty++saveState :: Map.Map String PRState -> IO ()+saveState = encodeFile statePath++isAncestor :: String -> String -> IO Bool+isAncestor commit branch = do+ (code, _, _) <- readProcessWithExitCode "git" ["merge-base", "--is-ancestor", commit, branch] ""+ return (code == ExitSuccess)++recordPR :: String -> IO String+recordPR branch = do+ state <- loadState+ let existing = Map.lookup branch state+ base <- getBaseBranch+ (branchExists, commits) <- do+ (code, out, _) <- readProcessWithExitCode "git" ["rev-parse", "--verify", branch] ""+ if code == ExitSuccess+ then do+ logOut <- readProcess "git" ["log", "--format=%H %s", base ++ ".." ++ branch] ""+ let commitLines = lines logOut+ let cs = map (\ln -> let h = take 40 ln+ m = drop 41 ln+ in CommitInfo h m) (filter (not . null) commitLines)+ return (True, cs)+ else return (False, [])++ case existing of+ Nothing -> do+ if not branchExists+ then do+ hPutStrLn stderr $ "Branch " ++ branch ++ " does not exist and is not tracked."+ exitFailure+ else do+ -- Create new entry and proceed+ let ex = PRState "open" [] []+ currentTime <- getCurrentTime+ let timeStr = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" currentTime+ let newSnapshot = PRSnapshot timeStr commits+ let updatedSnapshots = prSnapshots ex ++ [newSnapshot]++ -- Stale check (use latest snapshot even if no new one)+ staleDays <- getStaleDays+ let snapsForStale = if null updatedSnapshots then prSnapshots ex else updatedSnapshots+ let isStale = case snapsForStale of+ [] -> False+ snaps -> let lastSnap = last snaps+ lastTimeM = parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (psTimestamp lastSnap)+ in case lastTimeM of+ Just lastTime -> diffUTCTime currentTime lastTime > fromIntegral (staleDays * 86400) && null commits+ Nothing -> False+ let statusAfterStale = if isStale && prStatus ex /= "stale" && prStatus ex /= "merged" then "stale" else prStatus ex++ -- Merged check (use latest commits if branch missing)+ let checkCommits = commits+ allMerged <- if null checkCommits then return False else and <$> mapM (\ci -> isAncestor (ciHash ci) base) checkCommits+ let finalStatus = if allMerged && statusAfterStale /= "merged" then "merged" else statusAfterStale++ let updated = ex { prSnapshots = updatedSnapshots, prStatus = finalStatus }+ let newState = Map.insert branch updated state+ saveState newState+ let msg = if finalStatus /= prStatus ex then "Status updated to " ++ finalStatus else ""+ return $ msg ++ " (new tracking started)"+ Just ex -> do+ currentTime <- getCurrentTime+ let timeStr = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" currentTime+ let updatedSnapshots = if null commits+ then prSnapshots ex+ else prSnapshots ex ++ [PRSnapshot timeStr commits]++ -- Stale check (use latest snapshot even if no new one)+ staleDays <- getStaleDays+ let snapsForStale = if null updatedSnapshots then prSnapshots ex else updatedSnapshots+ let isStale = case snapsForStale of+ [] -> False+ snaps -> let lastSnap = last snaps+ lastTimeM = parseTimeM True defaultTimeLocale "%Y-%m-%d %H:%M:%S" (psTimestamp lastSnap)+ in case lastTimeM of+ Just lastTime -> diffUTCTime currentTime lastTime > fromIntegral (staleDays * 86400) && null commits+ Nothing -> False+ let statusAfterStale = if isStale && prStatus ex /= "stale" && prStatus ex /= "merged" then "stale" else prStatus ex++ -- Merged check (use latest commits if branch missing)+ let checkCommits = if not (null commits) then commits else if null (prSnapshots ex) then [] else psCommits (last (prSnapshots ex))+ allMerged <- if null checkCommits then return False else and <$> mapM (\ci -> isAncestor (ciHash ci) base) checkCommits+ let finalStatus = if allMerged && statusAfterStale /= "merged" then "merged" else statusAfterStale++ let updated = ex { prSnapshots = updatedSnapshots, prStatus = finalStatus }+ let newState = Map.insert branch updated state+ saveState newState+ let msg = if finalStatus /= prStatus ex+ then "Status updated to " ++ finalStatus+ else if null commits+ then "No update performed"+ else ""+ let extraMsg = if not branchExists then " (branch does not exist; using latest snapshot for checks)" else ""+ return $ msg ++ extraMsg
+ src/PRTools/ReviewState.hs view
@@ -0,0 +1,83 @@+module PRTools.ReviewState where++import Data.Aeson (ToJSON(..), object, (.=))+import Data.Aeson.Key (fromString)+import Data.Aeson.Types ((.!=))+import Data.Yaml (FromJSON(..), decodeFileEither, encodeFile, parseJSON, withObject, (.:), (.:?))+import System.Directory (doesFileExist)++data ReviewState = ReviewState+ { rsStatus :: String+ , rsCurrentIndex :: Int+ , rsFiles :: [String]+ , rsComments :: [Cmt]+ , rsBranch :: String+ , rsReviewer :: String+ } deriving (Eq, Show)++data Cmt = Cmt+ { cmId :: String+ , cmFile :: String+ , cmLine :: Int+ , cmText :: String+ , cmResolved :: Bool+ , cmStatus :: String+ , cmAnswer :: Maybe String+ , cmRevision :: String+ } deriving (Eq, Show)++instance FromJSON ReviewState where+ parseJSON = withObject "ReviewState" $ \v -> ReviewState+ <$> v .: fromString "status"+ <*> v .: fromString "current_index"+ <*> v .: fromString "files"+ <*> v .: fromString "comments"+ <*> v .: fromString "branch"+ <*> v .: fromString "reviewer"++instance ToJSON ReviewState where+ toJSON rs = object+ [ fromString "status" .= rsStatus rs+ , fromString "current_index" .= rsCurrentIndex rs+ , fromString "files" .= rsFiles rs+ , fromString "comments" .= rsComments rs+ , fromString "branch" .= rsBranch rs+ , fromString "reviewer" .= rsReviewer rs+ ]++instance FromJSON Cmt where+ parseJSON = withObject "Cmt" $ \v -> Cmt+ <$> v .: fromString "id"+ <*> v .: fromString "file"+ <*> v .: fromString "line"+ <*> v .: fromString "text"+ <*> v .: fromString "resolved"+ <*> (v .:? fromString "status" .!= "not-solved")+ <*> (v .:? fromString "answer")+ <*> (v .:? fromString "revision" .!= "")++instance ToJSON Cmt where+ toJSON cm = object+ [ fromString "id" .= cmId cm+ , fromString "file" .= cmFile cm+ , fromString "line" .= cmLine cm+ , fromString "text" .= cmText cm+ , fromString "resolved" .= cmResolved cm+ , fromString "status" .= cmStatus cm+ , fromString "answer" .= cmAnswer cm+ , fromString "revision" .= cmRevision cm+ ]++loadReviewState :: FilePath -> IO (Maybe ReviewState)+loadReviewState rf = do+ exists <- doesFileExist rf+ if not exists+ then return Nothing+ else do+ res <- decodeFileEither rf+ case res of+ Left _ -> return Nothing+ Right val -> return (Just val)++saveReviewState :: FilePath -> ReviewState -> IO ()+saveReviewState = encodeFile
+ src/PRTools/Slack.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}++module PRTools.Slack where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Aeson (Value(..), encode, object, (.=), decode)+import qualified Data.Aeson.KeyMap as KM+import Network.HTTP.Client (RequestBody(RequestBodyLBS), httpLbs, method, newManager, parseRequest, requestBody, requestHeaders, responseBody, responseStatus, urlEncodedBody)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types (statusCode)+import System.IO (hPutStrLn, stderr)+import Data.UUID.V4 (nextRandom)+import Data.UUID (toString)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.CaseInsensitive (mk)+import Data.Maybe (fromMaybe)+import qualified Data.ByteString.Char8 as BSC++sendViaWebhook :: String -> String -> IO ()+sendViaWebhook webhook message = do+ manager <- newManager tlsManagerSettings+ initReq <- parseRequest webhook+ let req = initReq+ { method = "POST"+ , requestBody = RequestBodyLBS $ encode $ object ["text" .= message]+ , requestHeaders = [(mk (TE.encodeUtf8 (T.pack "Content-Type")), TE.encodeUtf8 (T.pack "application/json"))]+ }+ response <- httpLbs req manager+ if statusCode (responseStatus response) == 200+ then putStrLn "Sent to Slack"+ else hPutStrLn stderr "Error sending to Slack"++sendViaApi :: String -> String -> String -> String -> String -> IO ()+sendViaApi summary fileContent filename channel token = do+ manager <- newManager tlsManagerSettings++ -- Step 1: Get upload URL+ initUrlReq <- parseRequest "https://slack.com/api/files.getUploadURLExternal"+ let pairs = [ ("filename", BSC.pack filename)+ , ("length", BSC.pack $ show $ BS.length (TE.encodeUtf8 (T.pack fileContent)))+ ]+ let urlReq = urlEncodedBody pairs initUrlReq+ { method = "POST"+ , requestHeaders =+ [ (mk "Authorization", TE.encodeUtf8 (T.pack ("Bearer " ++ token)))+ ]+ }+ urlResp <- httpLbs urlReq manager+ let urlStatus = statusCode (responseStatus urlResp)+ if urlStatus /= 200+ then hPutStrLn stderr $ "HTTP error getting upload URL: " ++ show urlStatus+ else case decode (responseBody urlResp) of+ Just (Object val) -> case (KM.lookup "ok" val, KM.lookup "upload_url" val, KM.lookup "file_id" val) of+ (Just (Bool True), Just (String url), Just (String fileId)) -> do+ -- Step 2: Upload file to URL+ initUploadReq <- parseRequest (T.unpack url)+ let uploadReq = initUploadReq+ { method = "POST"+ , requestBody = RequestBodyLBS (LBS.fromStrict (TE.encodeUtf8 (T.pack fileContent)))+ , requestHeaders = [(mk "Content-Type", "application/octet-stream")]+ }+ uploadResp <- httpLbs uploadReq manager+ let uploadStatus = statusCode (responseStatus uploadResp)+ if uploadStatus /= 200+ then hPutStrLn stderr $ "HTTP error uploading file: " ++ show uploadStatus+ else do+ -- Step 3: Complete upload+ initCompleteReq <- parseRequest "https://slack.com/api/files.completeUploadExternal"+ let completeReq = initCompleteReq+ { method = "POST"+ , requestBody = RequestBodyLBS $ encode $ object+ [ "files" .= [object ["id" .= fileId, "title" .= filename]]+ , "channel_id" .= channel+ , "initial_comment" .= summary+ ]+ , requestHeaders =+ [ (mk "Authorization", TE.encodeUtf8 (T.pack ("Bearer " ++ token)))+ , (mk "Content-Type", "application/json")+ ]+ }+ completeResp <- httpLbs completeReq manager+ let completeStatus = statusCode (responseStatus completeResp)+ if completeStatus /= 200+ then hPutStrLn stderr $ "HTTP error completing upload: " ++ show completeStatus+ else case decode (responseBody completeResp) of+ Just (Object cVal) -> case KM.lookup "ok" cVal of+ Just (Bool True) -> putStrLn "Sent to Slack as attachment"+ _ -> do+ let errMsg = fromMaybe "Unknown error" (KM.lookup "error" cVal >>= \v -> case v of {String s -> Just (T.unpack s); _ -> Nothing})+ hPutStrLn stderr $ "Slack API error: " ++ errMsg+ _ -> hPutStrLn stderr "Failed to parse complete response"+ _ -> do+ let errMsg = fromMaybe "Unknown error" (KM.lookup "error" val >>= \v -> case v of {String s -> Just (T.unpack s); _ -> Nothing})+ hPutStrLn stderr $ "Slack API error getting URL: " ++ errMsg+ _ -> hPutStrLn stderr "Failed to parse URL response"