pr-tools 0.1.0.0 → 0.2.0.0
raw patch · 17 files changed
+1054/−161 lines, 17 filesdep +hashabledep +hspecdep +hspec-discoverdep ~basedep ~containers
Dependencies added: hashable, hspec, hspec-discover
Dependency ranges changed: base, containers
Files
- CHANGELOG.md +16/−0
- README.md +13/−10
- app/pr-fix.hs +7/−37
- app/pr-merge.hs +55/−35
- app/pr-review.hs +94/−29
- app/pr-track.hs +159/−26
- pr-tools.cabal +27/−1
- src/PRTools/CommentRenderer.hs +26/−9
- src/PRTools/ContentHash.hs +67/−0
- src/PRTools/FixParser.hs +62/−0
- src/PRTools/PRState.hs +382/−14
- src/PRTools/ReviewLogic.hs +10/−0
- test/CommentRendererSpec.hs +19/−0
- test/FixParserSpec.hs +19/−0
- test/PRStateSpec.hs +69/−0
- test/ReviewLogicSpec.hs +28/−0
- test/Spec.hs +1/−0
CHANGELOG.md view
@@ -0,0 +1,16 @@++- Merged feature/improve-approval-workflow using fast-forward on 2026-01-07++- Merged fix/60-pr-review-mark-approved using fast-forward on 2026-01-09++- Merged feature/issue-55-same-end-of-line-convention using fast-forward on 2026-01-16++- Merged feature/rebase-approvals using fast-forward on 2026-02-23++- Merged fix/rebase-approvals-content-changed using fast-forward on 2026-02-23++- Merged feature/record-reviewed-commits using fast-forward on 2026-02-23++- Merged feature/readable-list-of-commits using fast-forward on 2026-02-23++- Merged feature/improve-readability-of-pt-track-list using fast-forward on 2026-02-25
README.md view
@@ -148,12 +148,14 @@ pr-track record [BRANCH] pr-track update [BRANCH] pr-track list+pr-track rebase --old-commit HASH [--branch BRANCH] [--new-commit HASH] ``` - `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.+- `status [BRANCH]`: Get the status, approvals, review status, and merge status for the PR. Checks if commits are merged into the base branch, validates approvals against current content, and shows if the current content has been reviewed. `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.+- `rebase --old-commit HASH [--branch BRANCH] [--new-commit HASH]`: Transfer approvals after a rebase if the content hasn't changed. `BRANCH` defaults to current, `--new-commit` defaults to current HEAD. ### pr-merge @@ -174,10 +176,10 @@ Subcommands: ```-pr-review start [--base-branch BASE]-pr-review next-pr-review previous-pr-review open+pr-review [--all] start [--base-branch BASE]+pr-review [--all] next+pr-review [--all] previous+pr-review [--all] open pr-review files pr-review changes pr-review comment --file FILE --line LINE --text "COMMENT"@@ -185,7 +187,7 @@ pr-review end pr-review list pr-review send-pr-review comments [--with-context]+pr-review comments [--all] [--with-context] ``` - `start [--base-branch BASE]`: Start or resume a review session. `--base-branch` overrides configured base.@@ -196,10 +198,10 @@ - `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.+- `end`: End the review session and record the content hash of the reviewed commits. - `list`: List all review sessions. - `send`: Send the review comments to Slack.-- `comments [--with-context]`: List comments, optionally with code context.+- `comments [--with-context] [--all]`: List comments,By default, shows unresolved comments. Use `--all` for all, or `--resolved` for only resolved. `--with-context` adds surrounding code. ### pr-view @@ -263,9 +265,10 @@ 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.+8. **Handle Rebases**: If you need to rebase before merging, run `pr-track rebase --old-commit <old-head>` after rebasing to transfer approvals if content hasn't changed.+9. **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.+This workflow enables collaborative reviews without committing review files to the repo, using Slack for communication. The approval system now handles rebases intelligently by tracking both commit IDs and content hashes. ## Contributing
app/pr-fix.hs view
@@ -24,9 +24,9 @@ import PRTools.ReviewState import PRTools.CommentRenderer import PRTools.CommentFormatter-import PRTools.PRState (recordPR)+import PRTools.PRState (recordPR, recordFixEvent) import PRTools.Slack (sendViaApi, sendViaWebhook)-+import PRTools.FixParser import Control.Monad (unless) import qualified Data.Map.Strict as Map import Data.Maybe (isJust)@@ -121,13 +121,14 @@ if editedContent == augmentedContent then do putStrLn "No changes detected; skipping overwrite." else do- let editedLines = lines editedContent+ let editedLines = normalizeLines 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)+ let eol = detectEol editedContent+ writeFile file (joinLines eol cleanLines) currentRev <- trimTrailing <$> readProcess "git" ["rev-parse", "HEAD"] "" let updatedWithRev = map (\c -> c { cmRevision = currentRev }) updatedCmts let newState = latest { rsComments = updatedWithRev }@@ -147,39 +148,6 @@ 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 ()@@ -248,6 +216,7 @@ let uniqueFiles = nub (map cmFile updatedCmts) let state = ReviewState "fixing" 0 uniqueFiles updatedCmts branch fixer saveReviewState fixFile state+ recordFixEvent branch fixer "start" putStrLn "Fix session started" recordPR branch >>= putStrLn FComments withCtx showAll showResolved -> do@@ -292,6 +261,7 @@ then do let newState = state { rsStatus = "fixed" } saveReviewState fixFile newState+ recordFixEvent branch fixer "end" putStrLn "Fix session ended" else do hPutStrLn stderr "Please commit your changes before ending the fix session."
app/pr-merge.hs view
@@ -6,7 +6,7 @@ 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.List (head, length, null, (!!), notElem) import Data.Time (formatTime, getCurrentTime) import Data.Time.Format (defaultTimeLocale) import Network.HTTP.Client (RequestBody(RequestBodyLBS), httpLbs, method, newManager, parseRequest, requestBody, requestHeaders, responseStatus)@@ -44,49 +44,69 @@ branch <- case optBranch opts of Just b -> return b Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ merger <- fmap trimTrailing (readProcess "git" ["config", "user.name"] "") 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+ Just pr -> if null (approvalHistory 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+ -- Stale check+ currentTip <- fmap trimTrailing (readProcess "git" ["rev-parse", branch] "")+ let latestApproval = last (approvalHistory pr)+ let approvedHashes = map ciHash (apCommits latestApproval)+ + if currentTip `notElem` approvedHashes+ then do+ hPutStrLn stderr $ "PR " ++ branch ++ " has new commits since approval. Please request re-approval."+ exitFailure+ else do+ logOutBefore <- readProcess "git" ["log", "--format=%H %s", baseB ++ ".." ++ branch, "--"] ""+ let commitLinesBefore = lines logOutBefore++ let commits = map (uncurry CommitInfo . (\ln -> (take 40 ln, drop 41 ln))) (filter (not . null) commitLinesBefore)+ 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+ + currentTime <- getCurrentTime+ let timeStr = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" currentTime+ + let mergeInfo = MergeInfo merger timeStr commits+ let newState = Map.insert branch (pr { prStatus = "merged", prMergeInfo = Just mergeInfo }) state+ saveState newState+ + 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
app/pr-review.hs view
@@ -8,6 +8,7 @@ import Data.Char (isSpace) import Data.List (any, filter, findIndex, foldl', intercalate, zipWith, isPrefixOf) import Data.List.Split (splitOn)+import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, catMaybes, listToMaybe) import Data.UUID (toString) import Data.UUID.V4 (nextRandom)@@ -27,11 +28,15 @@ import PRTools.ReviewState import PRTools.CommentRenderer import PRTools.CommentFormatter-import PRTools.PRState (recordPR)+import PRTools.PRState (recordPR, recordReviewEvent, recordReviewEventWithHash, recordApproval, recordReviewEventWithCommitHashes, loadState, prSnapshots, psCommits, ciHash)+import PRTools.ContentHash (generatePatchHash) import PRTools.Slack (sendViaApi, sendViaWebhook)--data Global = Global { gBaseBranch :: Maybe String }+import PRTools.ReviewLogic (filterComments) +data Global = Global+ { gBaseBranch :: Maybe String+ , gShowAll :: Bool+ } globalParser :: Parser Global globalParser = Global <$> optional (strOption@@ -39,7 +44,10 @@ <> metavar "BASE" <> help "Override the base branch" ))-+ <*> switch+ ( long "all"+ <> help "Show all comments (including resolved ones) in review files"+ ) data Command = Start | Next@@ -52,6 +60,7 @@ | End | List | Send+ | Approve | Comments Bool Bool Bool | ImportAnswers @@ -70,6 +79,7 @@ <> 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 "approve" (info (pure Approve <**> helper) (progDesc "Approve the PR (must have no unresolved comments)")) <> 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")) )@@ -107,10 +117,10 @@ editor <- fromMaybe "vim" <$> lookupEnv "EDITOR" callProcess editor [tmpPath] editedContent <- readFile tmpPath- let editedLines = lines editedContent+ let editedLines = normalizeLines editedContent let editedFeature = extractEditedFeature editedLines -- Reuse existing extraction featureContent <- readProcess "git" ["show", branch ++ ":" ++ filePath] ""- let featureLines = lines featureContent+ let featureLines = normalizeLines featureContent let newPairs = extractComments featureLines editedFeature -- Reuse currentRev <- trimTrailing <$> readProcess "git" ["rev-parse", "HEAD"] "" mapM (\(l, t) -> do@@ -175,6 +185,7 @@ let files = lines filesOut let resumed = existing { rsStatus = "active", rsFiles = files, rsCurrentIndex = 0 } saveReviewState reviewFile resumed+ recordReviewEvent branch reviewer "start" putStrLn "Resuming existing review" recordPR branch >>= putStrLn Nothing -> do@@ -182,11 +193,12 @@ let files = lines filesOut let newState = ReviewState "active" 0 files [] branch reviewer saveReviewState reviewFile newState+ recordReviewEvent branch reviewer "start" 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+ Next -> handleNav global NavNext reviewFile branch mergeBase Nothing+ Previous -> handleNav global NavPrevious reviewFile branch mergeBase Nothing+ Open mbFile -> handleNav global NavOpen reviewFile branch mergeBase mbFile Files -> do mState <- loadReviewState reviewFile case mState of@@ -240,7 +252,31 @@ Just state -> do let newState = state { rsStatus = "closed" } saveReviewState reviewFile newState- putStrLn "Review ended"+ + -- Generate content hashes for each commit in the latest snapshot+ prState <- loadState+ case Map.lookup branch prState of+ Nothing -> do+ hPutStrLn stderr "No PR state found"+ exitFailure+ Just pr -> do+ if null (prSnapshots pr)+ then do+ hPutStrLn stderr "No snapshots found for this PR"+ exitFailure+ else do+ let latestSnapshot = last (prSnapshots pr)+ let commits = psCommits latestSnapshot+ + -- Generate content hash for each commit+ commitHashes <- mapM (\ci -> do+ contentHash <- generatePatchHash baseB (ciHash ci)+ return (ciHash ci, contentHash)+ ) commits+ + let commitHashMap = Map.fromList commitHashes+ recordReviewEventWithCommitHashes branch reviewer "end" commitHashMap+ putStrLn $ "Review ended - recorded review for " ++ show (length commits) ++ " commits" List -> do rfs <- glob (reviewDir </> "*.yaml") mapM_ (\rf -> do@@ -259,23 +295,50 @@ 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+ if total == 0+ then putStrLn "Nothing to send: there are no comments in the review."+ else do+ let solved = length (filter cmResolved comments)+ let unsolved = total - solved+ let summary = if 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+ Approve -> do+ mState <- loadReviewState reviewFile+ case mState of+ Nothing -> do+ hPutStrLn stderr "No active review"+ exitFailure+ Just state -> do+ let comments = rsComments state+ let unresolved = filter (not . cmResolved) comments+ if not (null unresolved) then do+ hPutStrLn stderr $ "Cannot approve: There are " ++ show (length unresolved) ++ " unresolved comments."+ exitFailure+ else do+ currentHash <- trimTrailing <$> readProcess "git" ["rev-parse", "HEAD"] ""+ recordApproval branch reviewer currentHash+ putStrLn $ "PR " ++ branch ++ " approved at commit " ++ currentHash+ + mbWebhook <- getSlackWebhook+ case mbWebhook of+ Nothing -> putStrLn "Slack webhook not configured, skipping notification." Just webhook -> do- let message = summary ++ "\n" ++ fullContent+ let trackCmd = "pr-track approve " ++ branch ++ " --by \"" ++ reviewer ++ "\" --commit " ++ currentHash+ let message = "✅ PR " ++ branch ++ " approved by " ++ reviewer ++ " at commit " ++ currentHash ++ " (with content hash for rebase safety)\nRun this to track approval:\n`" ++ trackCmd ++ "`" sendViaWebhook webhook message Comments withCtx showAll showResolved -> do mState <- loadReviewState reviewFile@@ -306,10 +369,11 @@ 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+ recordReviewEvent branch reviewer "import-answers" putStrLn "Imported answers for matching comments" -handleNav :: NavAction -> FilePath -> String -> String -> Maybe String -> IO ()-handleNav action rf branch mergeBase mbFile = do+handleNav :: Global -> NavAction -> FilePath -> String -> String -> Maybe String -> IO ()+handleNav global action rf branch mergeBase mbFile = do mState <- loadReviewState rf case mState of Nothing -> do@@ -330,7 +394,8 @@ Nothing -> return state let doOpen st = do let filePath = rsFiles st !! rsCurrentIndex st- let fileCmts = filter (\c -> cmFile c == filePath) (rsComments st)+ let allFileCmts = filter (\c -> cmFile c == filePath) (rsComments st)+ let fileCmts = filterComments (gShowAll global) allFileCmts newCmts <- openEditor filePath branch mergeBase fileCmts mLatest <- loadReviewState rf let latest = case mLatest of
app/pr-track.hs view
@@ -1,53 +1,73 @@ import Control.Monad (when) import qualified Data.Map.Strict as Map-import Data.List (head, intercalate, length, notElem, null, (!!), sortBy)+import Data.List (head, intercalate, length, notElem, null, (!!), sortBy, nub) 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+import PRTools.ContentHash (generatePatchHash, debugPatchDifference)+import Data.Time (getCurrentTime, formatTime)+import Data.Time.Format (defaultTimeLocale) data Command =- Approve { aBranch :: Maybe String, aBy :: String }+ Approve { aBranch :: Maybe String, aBy :: String, aCommit :: Maybe String } | Status { sBranch :: Maybe String } | Record { rBranch :: Maybe String } | List+ | Rebase { reBranch :: Maybe String, reOldCommit :: String, reNewCommit :: Maybe String }+ | Debug { dBranch :: Maybe String, dOldCommit :: String, dNewCommit :: Maybe String } 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"))+ ( command "approve" (info (approveParser <**> helper) (progDesc "Approve a PR by name"))+ <> command "status" (info (statusParser <**> helper) (progDesc "Get PR status, approvals, and review history"))+ <> command "record" (info (recordParser <**> helper) (progDesc "Record/update PR commit snapshot"))+ <> command "update" (info (recordParser <**> helper) (progDesc "Synonym for record"))+ <> command "u" (info (recordParser <**> helper) (progDesc "Shortcut for update"))+ <> command "r" (info (recordParser <**> helper) (progDesc "Shortcut for record"))+ <> command "rec" (info (recordParser <**> helper) (progDesc "Shortcut for record"))+ <> command "list" (info (pure List <**> helper) (progDesc "List all tracked PRs with status"))+ <> command "rebase" (info (rebaseParser <**> helper) (progDesc "Transfer approvals after rebase if content unchanged"))+ <> command "debug" (info (debugParser <**> helper) (progDesc "Debug content hash differences between commits")) ) where approveParser = Approve <$> optional (strArgument (metavar "BRANCH" <> help "Branch to approve (default: current)")) <*> strOption (long "by" <> metavar "NAME" <> help "Approver name")+ <*> optional (strOption (long "commit" <> metavar "HASH" <> help "Commit hash being approved")) statusParser = Status <$> optional (strArgument (metavar "BRANCH" <> help "Branch to check (default: current)")) recordParser = Record <$> optional (strArgument (metavar "BRANCH" <> help "Branch to record (default: current)"))+ rebaseParser = Rebase+ <$> optional (strOption (long "branch" <> metavar "BRANCH" <> help "Branch that was rebased (default: current)"))+ <*> strOption (long "old-commit" <> metavar "HASH" <> help "Commit hash before rebase")+ <*> optional (strOption (long "new-commit" <> metavar "HASH" <> help "Commit hash after rebase (default: current HEAD)"))+ debugParser = Debug+ <$> optional (strOption (long "branch" <> metavar "BRANCH" <> help "Branch to debug (default: current)"))+ <*> strOption (long "old-commit" <> metavar "HASH" <> help "Old commit hash")+ <*> optional (strOption (long "new-commit" <> metavar "HASH" <> help "New commit hash (default: current HEAD)")) main :: IO () main = do- cmd <- execParser $ info (commandParser <**> helper) idm+ cmd <- execParser $ info (commandParser <**> helper) + ( fullDesc+ <> progDesc "Track PR approvals, status, and commit history"+ <> header "pr-track - PR tracking and approval management tool" ) state <- loadState case cmd of- Approve mbBranch by -> do+ Approve mbBranch by mbCommit -> 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+ + tip <- case mbCommit of+ Just c -> return c+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", branch] "")++ recordApproval branch by tip putStrLn $ "Approved " ++ branch ++ " by " ++ by Status mbBranch -> do branch <- case mbBranch of@@ -57,8 +77,61 @@ Nothing -> putStrLn $ "No status for " ++ branch Just pr -> do putStrLn $ "Status: " ++ prStatus pr+ + -- Check current valid approvals+ validApprovals <- checkValidApprovals branch+ let allApprovers = nub (map apApprover (approvalHistory pr))+ let validApprovers = nub (map apApprover validApprovals)+ putStr "Approvals: "- putStrLn $ if null (prApprovals pr) then "none" else intercalate ", " (prApprovals pr)+ if null allApprovers + then putStrLn "none"+ else do+ putStrLn $ intercalate ", " validApprovers+ when (length validApprovers < length allApprovers) $+ putStrLn $ " (Note: " ++ show (length allApprovers - length validApprovers) ++ " approvals are no longer valid due to changes)"++ when (not (null (approvalHistory pr))) $ do+ putStrLn "Approval History:"+ mapM_ (\ap -> do+ let isValid = ap `elem` validApprovals+ let validityNote = if isValid then "" else " (INVALID - content changed)"+ putStrLn $ "- Approved by " ++ apApprover ap ++ " at " ++ apTimestamp ap ++ validityNote+ putStrLn " Approved commits:"+ mapM_ (\c -> putStrLn $ " - " ++ take 7 (ciHash c) ++ " " ++ ciMessage c) (apCommits ap)+ case apContentHash ap of+ Just hash -> putStrLn $ " Content hash: " ++ hash+ Nothing -> putStrLn " Content hash: (legacy approval)"+ ) (approvalHistory pr)++ -- Check review status+ (isReviewed, reviewers) <- checkReviewStatus branch+ putStr "Review Status: "+ if isReviewed+ then putStrLn $ "Reviewed by " ++ intercalate ", " reviewers+ else putStrLn "Not reviewed"++ when (not (null (prReviews pr))) $ do+ putStrLn "Review History:"+ mapM_ (\re -> do+ let hashInfo = case reContentHash re of+ Just hash -> " (content hash: " ++ hash ++ ")"+ Nothing -> ""+ putStrLn $ "- " ++ reAction re ++ " by " ++ reReviewer re ++ " at " ++ reTimestamp re ++ hashInfo+ ) (prReviews pr)++ when (not (null (prFixes pr))) $ do+ putStrLn "Fix History:"+ mapM_ (\fe -> putStrLn $ "- " ++ feAction fe ++ " by " ++ feFixer fe ++ " at " ++ feTimestamp fe) (prFixes pr)++ case prMergeInfo pr of+ Just mi -> do+ putStrLn "Merge Info:"+ putStrLn $ "- Merged by " ++ miMerger mi ++ " at " ++ miTimestamp mi+ putStrLn " Merged commits:"+ mapM_ (\c -> putStrLn $ " - " ++ take 7 (ciHash c) ++ " " ++ ciMessage c) (miCommits mi)+ Nothing -> return ()+ if null (prSnapshots pr) then putStrLn "No snapshots recorded" else do@@ -71,24 +144,33 @@ 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)+ -- Get the actual commit timestamp from git+ commitTime <- trimTrailing <$> readProcess "git" ["log", "-1", "--format=%ct", ciHash ci] ""+ let commitTimestamp = read commitTime :: Int+ return (ci, s, ts, commitTimestamp) ) (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 sorted_statuses = sortBy (\(_,_,_,t1) (_,_,_,t2) -> compare t2 t1) temp_list -- newest first+ 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 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+ mapM_ (\(ci, s, _, _) -> do+ isReviewed <- checkCommitReviewStatus branch (ciHash ci)+ let reviewStatus = if isReviewed then ", reviewed" else ", not reviewed"+ let boldStart = if s == "merged" || s == "pending" then "\ESC[1m" else ""+ let boldEnd = if s == "merged" || s == "pending" then "\ESC[0m" else ""+ putStrLn $ "- " ++ boldStart ++ take 7 (ciHash ci) ++ " " ++ ciMessage ci ++ " (" ++ s ++ reviewStatus ++ ")" ++ boldEnd+ ) sorted_statuses Record mbBranch -> do branch <- case mbBranch of Just b -> return b@@ -98,4 +180,55 @@ 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+ else do+ -- Convert to list and sort by most recent activity+ let prList = Map.toList state+ sortedPRs <- mapM (\(branch, pr) -> do+ let lastActivity = if null (prSnapshots pr) + then "1970-01-01 00:00:00" -- Very old date for PRs with no snapshots+ else psTimestamp (last (prSnapshots pr))+ return (branch, pr, lastActivity)+ ) prList+ + let sortedByActivity = sortBy (\(_, _, time1) (_, _, time2) -> + compare time2 time1 -- Most recent first+ ) sortedPRs+ + mapM_ (\(b, pr, _) -> do+ let status = prStatus pr+ let approvalCount = length $ approvalHistory pr+ let boldStart = if status == "open" || status == "stale" then "\ESC[1m" else ""+ let boldEnd = if status == "open" || status == "stale" then "\ESC[0m" else ""+ putStrLn $ boldStart ++ b ++ ": " ++ status ++ " (approvals: " ++ show approvalCount ++ ")" ++ boldEnd+ ) sortedByActivity+ Rebase mbBranch oldCommit mbNewCommit -> do+ branch <- case mbBranch of+ Just b -> return b+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ + newCommit <- case mbNewCommit of+ Just c -> return c+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", branch] "")+ + transferApprovalsAfterRebase branch oldCommit newCommit+ Debug mbBranch oldCommit mbNewCommit -> do+ branch <- case mbBranch of+ Just b -> return b+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] "")+ + newCommit <- case mbNewCommit of+ Just c -> return c+ Nothing -> fmap trimTrailing (readProcess "git" ["rev-parse", branch] "")+ + base <- getBaseBranch+ putStrLn $ "Debugging content hash difference between " ++ oldCommit ++ " and " ++ newCommit+ putStrLn $ "Base branch: " ++ base+ + oldHash <- generatePatchHash base oldCommit+ newHash <- generatePatchHash base newCommit+ + putStrLn $ "Old content hash: " ++ oldHash+ putStrLn $ "New content hash: " ++ newHash+ putStrLn $ "Hashes match: " ++ show (oldHash == newHash)+ + debugPatchDifference base oldCommit newCommit
pr-tools.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: pr-tools-version: 0.1.0.0+version: 0.2.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@@ -50,6 +50,9 @@ , PRTools.CommentRenderer , PRTools.CommentFormatter , PRTools.Slack+ , PRTools.ReviewLogic+ , PRTools.FixParser+ , PRTools.ContentHash build-depends: aeson >= 2.2.3 && < 2.3 , containers >= 0.6.7 && < 0.7 , directory >= 1.3.8 && < 1.4@@ -66,6 +69,7 @@ , text >= 2.0.2 && < 2.1 , case-insensitive >= 1.2.1 && < 1.3 , split >= 0.2.5 && < 0.3+ , hashable >= 1.3.0 && < 1.6 hs-source-dirs: src executable pr-snapshot@@ -126,6 +130,7 @@ build-depends: pr-tools , aeson >= 2.2.3 && < 2.3 , bytestring >= 0.11.5 && < 0.12+ , containers >= 0.6.7 && < 0.7 , Diff >= 1.0.2 && < 1.1 , directory >= 1.3.8 && < 1.4 , filepath >= 1.4.301 && < 1.5@@ -179,3 +184,24 @@ , directory >= 1.3.8 && < 1.4 , process >= 1.6.19 && < 1.7 hs-source-dirs: app+++test-suite pr-tools-tests+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs: test+ build-depends:+ base >=4.7 && <5+ , pr-tools+ , hspec+ , hspec-discover+ , containers+ build-tool-depends:+ hspec-discover:hspec-discover+ other-modules:+ FixParserSpec+ , ReviewLogicSpec+ , PRStateSpec+ , CommentRendererSpec+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010
src/PRTools/CommentRenderer.hs view
@@ -6,7 +6,7 @@ import Control.Exception (catch, IOException) import Data.Algorithm.Diff (PolyDiff(..), getGroupedDiff)-import Data.List (foldl', sortBy, isPrefixOf, intercalate, dropWhile, span)+import Data.List (foldl', sortBy, isPrefixOf, intercalate, dropWhile, span, isInfixOf) import Data.List.Extra (trim, splitOn) import System.IO (hPutStrLn, stderr) import System.Process (readProcess)@@ -16,14 +16,30 @@ import PRTools.Config (trimTrailing) import Control.Arrow (first) +stripCR :: String -> String+stripCR s = case reverse s of+ '\r' : xs -> reverse xs+ _ -> s++normalizeLines :: String -> [String]+normalizeLines = map stripCR . lines++detectEol :: String -> String+detectEol content = if "\r\n" `isInfixOf` content then "\r\n" else "\n"++joinLines :: String -> [String] -> String+joinLines eol ls = case ls of+ [] -> ""+ _ -> intercalate eol ls ++ eol+ -- 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 oldLines = normalizeLines oldContent+ let currentLines = normalizeLines currentContent let diffs = getGroupedDiff oldLines currentLines return $ go diffs 1 1 target where@@ -49,8 +65,9 @@ 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+ let eol = detectEol (if null featureContent then baseContent else featureContent)+ let baseLines = normalizeLines baseContent+ let featureLines = normalizeLines 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 }@@ -59,7 +76,7 @@ let groups = getGroupedDiff baseLines featureLines let conflictLines = recBuild 1 groups let augmented = insertComments conflictLines sortedCmts- return $ unlines augmented+ return $ joinLines eol augmented where annotateFeatureLines :: Int -> [String] -> [(Maybe Int, String)] annotateFeatureLines n ls = let feature_lines = zip [n ..] ls@@ -105,14 +122,15 @@ 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+ let eol = detectEol content+ let fileLines = normalizeLines 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+ return $ joinLines eol augmentedLines where insertComment :: ([String], Int) -> Cmt -> ([String], Int) insertComment (acc, offset) c =@@ -147,4 +165,3 @@ 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/ContentHash.hs view
@@ -0,0 +1,67 @@+module PRTools.ContentHash where++import Data.Hashable (hash)+import Data.List (isPrefixOf)+import System.Process (readProcess)+import PRTools.Config (trimTrailing)++-- Generate a hash from the patch content, excluding metadata+-- Uses the merge-base to ensure consistent comparison point+generatePatchHash :: String -> String -> IO String+generatePatchHash baseCommit headCommit = do+ -- Find the actual merge base between the base branch and the commit+ mergeBase <- trimTrailing <$> readProcess "git" ["merge-base", baseCommit, headCommit] ""+ patchContent <- readProcess "git" ["diff", mergeBase, headCommit] ""+ let normalizedPatch = normalizePatch patchContent+ return $ take 12 $ show $ abs $ hash normalizedPatch++-- Normalize patch content by removing line numbers and normalizing whitespace+normalizePatch :: String -> String+normalizePatch patch = + let patchLines = lines patch+ -- Remove @@ line number headers and file headers, keep only actual changes+ contentLines = filter (not . isPatchHeader) patchLines+ -- Normalize whitespace but preserve structure+ normalized = map normalizeWhitespace contentLines+ -- Remove empty lines that might vary between diffs+ nonEmpty = filter (not . null . trim) normalized+ in unlines nonEmpty+ where+ trim = dropWhile (`elem` " \t") . reverse . dropWhile (`elem` " \t") . reverse++-- Check if a line is a patch header that should be ignored for content comparison+isPatchHeader :: String -> Bool+isPatchHeader line = + "@@" `isPrefixOf` line ||+ "diff --git" `isPrefixOf` line ||+ "index " `isPrefixOf` line ||+ "--- " `isPrefixOf` line ||+ "+++ " `isPrefixOf` line++-- Normalize whitespace while preserving the +/- prefix structure+normalizeWhitespace :: String -> String+normalizeWhitespace line+ | "+" `isPrefixOf` line = "+" ++ (unwords . words . drop 1) line+ | "-" `isPrefixOf` line = "-" ++ (unwords . words . drop 1) line+ | otherwise = unwords . words $ line++-- Debug function to compare patch content (for troubleshooting)+debugPatchDifference :: String -> String -> String -> IO ()+debugPatchDifference baseCommit oldCommit newCommit = do+ -- Use merge-base for consistent comparison+ oldMergeBase <- trimTrailing <$> readProcess "git" ["merge-base", baseCommit, oldCommit] ""+ newMergeBase <- trimTrailing <$> readProcess "git" ["merge-base", baseCommit, newCommit] ""+ + putStrLn $ "Old merge base: " ++ oldMergeBase+ putStrLn $ "New merge base: " ++ newMergeBase+ + oldPatch <- readProcess "git" ["diff", oldMergeBase, oldCommit] ""+ newPatch <- readProcess "git" ["diff", newMergeBase, newCommit] ""+ let oldNormalized = normalizePatch oldPatch+ let newNormalized = normalizePatch newPatch+ putStrLn "=== OLD PATCH (normalized) ==="+ putStrLn oldNormalized+ putStrLn "=== NEW PATCH (normalized) ==="+ putStrLn newNormalized+ putStrLn "=== PATCHES EQUAL? ==="+ putStrLn $ show (oldNormalized == newNormalized)
+ src/PRTools/FixParser.hs view
@@ -0,0 +1,62 @@+module PRTools.FixParser+ ( parseBlock+ ) where++import Data.List (findIndex, intercalate, isPrefixOf)+import Data.List.Extra (trim)+import PRTools.ReviewState (Cmt(..))++-- | Parses a block of text representing a single comment from an edited source file+-- | during a fix session. It updates a list of existing comments with any changes+-- | found in the block.+parseBlock :: [String] -> [Cmt] -> [Cmt]+parseBlock (header:body) accCmts =+ let cidStart = length ("-- REVIEW COMMENT BEGIN [" :: String)+ cidEnd = findIndex (== ']') (drop cidStart header)+ cid = maybe "" (\end -> take end (drop cidStart header)) cidEnd+ afterCid = maybe "" (\end -> drop (cidStart + end + 1) header) cidEnd+ statusStart = findSub "[status:" afterCid+ afterStatusLabel = maybe afterCid (\start -> drop (start + 8) afterCid) statusStart+ statusEnd = findIndex (== ']') afterStatusLabel+ status = maybe "not-solved" (\end -> take end afterStatusLabel) statusEnd+ afterStatus = maybe afterStatusLabel (\end -> drop (end + 1) afterStatusLabel) statusEnd+ answerStart = findSub "[answer:" afterStatus++ headerAnswer = case answerStart of+ Nothing -> Nothing+ Just start ->+ let answerWithBracket = drop (start + 8) afterStatus+ answerEnd = findIndex (== ']') answerWithBracket+ in Just $ maybe answerWithBracket (\end -> take end answerWithBracket) answerEnd++ (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 the [answer: line itself++ finalAnswer = case (headerAnswer, bodyAnswer) of+ (Just ha, Just ba) -> Just (ha ++ "\n" ++ ba)+ (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++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)
src/PRTools/PRState.hs view
@@ -12,7 +12,9 @@ import Data.Time.Format (defaultTimeLocale, parseTimeM) import System.Process (readProcess, readProcessWithExitCode) import PRTools.Config (getBaseBranch, trimTrailing, getStaleDays)+import PRTools.ContentHash (generatePatchHash) import System.Exit (ExitCode(..))+import Data.List (nub) data CommitInfo = CommitInfo { ciHash :: String, ciMessage :: String } deriving (Eq, Show) @@ -40,19 +42,129 @@ , fromString "commits" .= psCommits ps ] -data PRState = PRState { prStatus :: String, prApprovals :: [String], prSnapshots :: [PRSnapshot] } deriving (Eq, Show)+data ReviewEvent = ReviewEvent+ { reReviewer :: String+ , reAction :: String -- "start", "end", "import-answers"+ , reTimestamp :: String+ , reContentHash :: Maybe String -- Content hash for "end" actions (legacy)+ , reReviewedCommits :: Maybe (Map.Map String String) -- commit hash -> content hash for that commit+ } deriving (Eq, Show) +instance FromJSON ReviewEvent where+ parseJSON = withObject "ReviewEvent" $ \v -> ReviewEvent+ <$> v .: fromString "reviewer"+ <*> v .: fromString "action"+ <*> v .: fromString "timestamp"+ <*> v .:? fromString "content_hash"+ <*> v .:? fromString "reviewed_commits"++instance ToJSON ReviewEvent where+ toJSON re = object+ [ fromString "reviewer" .= reReviewer re+ , fromString "action" .= reAction re+ , fromString "timestamp" .= reTimestamp re+ , fromString "content_hash" .= reContentHash re+ , fromString "reviewed_commits" .= reReviewedCommits re+ ]++data FixEvent = FixEvent+ { feFixer :: String+ , feAction :: String -- "start", "end"+ , feTimestamp :: String+ } deriving (Eq, Show)++instance FromJSON FixEvent where+ parseJSON = withObject "FixEvent" $ \v -> FixEvent+ <$> v .: fromString "fixer"+ <*> v .: fromString "action"+ <*> v .: fromString "timestamp"++instance ToJSON FixEvent where+ toJSON fe = object+ [ fromString "fixer" .= feFixer fe+ , fromString "action" .= feAction fe+ , fromString "timestamp" .= feTimestamp fe+ ]++data Approval = Approval+ { apApprover :: String+ , apTimestamp :: String+ , apCommits :: [CommitInfo]+ , apContentHash :: Maybe String -- New field for content-based approval+ } deriving (Eq, Show)++instance FromJSON Approval where+ parseJSON = withObject "Approval" $ \v -> Approval+ <$> v .: fromString "approver"+ <*> v .: fromString "timestamp"+ <*> v .:? fromString "commits" .!= []+ <*> v .:? fromString "content_hash"++instance ToJSON Approval where+ toJSON ap = object+ [ fromString "approver" .= apApprover ap+ , fromString "timestamp" .= apTimestamp ap+ , fromString "commits" .= apCommits ap+ , fromString "content_hash" .= apContentHash ap+ ]++data MergeInfo = MergeInfo+ { miMerger :: String+ , miTimestamp :: String+ , miCommits :: [CommitInfo]+ } deriving (Eq, Show)++instance FromJSON MergeInfo where+ parseJSON = withObject "MergeInfo" $ \v -> MergeInfo+ <$> v .: fromString "merger"+ <*> v .: fromString "timestamp"+ <*> v .: fromString "commits"++instance ToJSON MergeInfo where+ toJSON mi = object+ [ fromString "merger" .= miMerger mi+ , fromString "timestamp" .= miTimestamp mi+ , fromString "commits" .= miCommits mi+ ]++data PRState = PRState+ { prStatus :: String+ , prSnapshots :: [PRSnapshot]+ , approvalHistory :: [Approval]+ , prReviews :: [ReviewEvent]+ , prFixes :: [FixEvent]+ , prMergeInfo :: Maybe MergeInfo+ } deriving (Eq, Show)+ instance FromJSON PRState where- parseJSON = withObject "PRState" $ \v -> PRState- <$> v .: fromString "status"- <*> v .:? fromString "approvals" .!= []- <*> v .:? fromString "snapshots" .!= []+ parseJSON = withObject "PRState" $ \v -> do+ maybeNewApprovals <- v .:? fromString "approval_history"+ maybeIntermediateApprovals <- v .:? fromString "approvals2"+ maybeOldApprovals <- v .:? fromString "approvals" .!= [] + let finalApprovals = case maybeNewApprovals of+ Just new -> new+ Nothing -> case maybeIntermediateApprovals of+ Just intermediate -> intermediate+ Nothing -> map (\name -> Approval name "migrated-approval" [] Nothing) maybeOldApprovals++ PRState+ <$> v .: fromString "status"+ <*> v .:? fromString "snapshots" .!= []+ <*> pure finalApprovals+ <*> v .:? fromString "reviews" .!= []+ <*> v .:? fromString "fixes" .!= []+ <*> v .:? fromString "merge_info"++ instance ToJSON PRState where toJSON p = object [ fromString "status" .= prStatus p- , fromString "approvals" .= prApprovals p , fromString "snapshots" .= prSnapshots p+ , fromString "approval_history" .= approvalHistory p+ , fromString "reviews" .= prReviews p+ , fromString "fixes" .= prFixes p+ , fromString "merge_info" .= prMergeInfo p ] statePath :: FilePath@@ -88,7 +200,7 @@ (code, out, _) <- readProcessWithExitCode "git" ["rev-parse", "--verify", branch] "" if code == ExitSuccess then do- logOut <- readProcess "git" ["log", "--format=%H %s", base ++ ".." ++ branch] ""+ 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@@ -103,14 +215,12 @@ hPutStrLn stderr $ "Branch " ++ branch ++ " does not exist and is not tracked." exitFailure else do- -- Create new entry and proceed- let ex = PRState "open" [] []+ let ex = PRState "open" [] [] [] [] Nothing 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@@ -122,7 +232,6 @@ 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@@ -139,7 +248,6 @@ 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@@ -151,10 +259,25 @@ 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+ + -- Check if all commits are removed (not reachable from branch or base)+ allRemoved <- if null checkCommits then return False else do+ -- Check if branch exists+ (branchCode, _, _) <- readProcessWithExitCode "git" ["rev-parse", "--verify", branch] ""+ if branchCode == ExitSuccess then do+ -- Branch exists, check if commits are reachable from it+ branchReachable <- and <$> mapM (\ci -> isAncestor (ciHash ci) branch) checkCommits+ return (not branchReachable)+ else do+ -- Branch doesn't exist, commits are removed if not in base+ baseReachable <- and <$> mapM (\ci -> isAncestor (ciHash ci) base) checkCommits+ return (not baseReachable)+ + let finalStatus = if allMerged then "merged" + else if allRemoved then "removed"+ else statusAfterStale let updated = ex { prSnapshots = updatedSnapshots, prStatus = finalStatus } let newState = Map.insert branch updated state@@ -166,3 +289,248 @@ else "" let extraMsg = if not branchExists then " (branch does not exist; using latest snapshot for checks)" else "" return $ msg ++ extraMsg++recordReviewEvent :: String -> String -> String -> IO ()+recordReviewEvent branch reviewer action = do+ state <- loadState+ currentTime <- getCurrentTime+ let timeStr = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" currentTime+ let newEvent = ReviewEvent reviewer action timeStr Nothing Nothing+ let pr = Map.findWithDefault (PRState "open" [] [] [] [] Nothing) branch state+ let updatedPr = pr { prReviews = prReviews pr ++ [newEvent] }+ let newState = Map.insert branch updatedPr state+ saveState newState++-- Record review event with content hash (for "end" actions)+recordReviewEventWithHash :: String -> String -> String -> Maybe String -> IO ()+recordReviewEventWithHash branch reviewer action mbContentHash = do+ state <- loadState+ currentTime <- getCurrentTime+ let timeStr = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" currentTime+ let newEvent = ReviewEvent reviewer action timeStr mbContentHash Nothing+ let pr = Map.findWithDefault (PRState "open" [] [] [] [] Nothing) branch state+ let updatedPr = pr { prReviews = prReviews pr ++ [newEvent] }+ let newState = Map.insert branch updatedPr state+ saveState newState++-- Record review event with individual commit hashes (for "end" actions)+recordReviewEventWithCommitHashes :: String -> String -> String -> Map.Map String String -> IO ()+recordReviewEventWithCommitHashes branch reviewer action commitHashes = do+ state <- loadState+ currentTime <- getCurrentTime+ let timeStr = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" currentTime+ let newEvent = ReviewEvent reviewer action timeStr Nothing (Just commitHashes)+ let pr = Map.findWithDefault (PRState "open" [] [] [] [] Nothing) branch state+ let updatedPr = pr { prReviews = prReviews pr ++ [newEvent] }+ let newState = Map.insert branch updatedPr state+ saveState newState++recordFixEvent :: String -> String -> String -> IO ()+recordFixEvent branch fixer action = do+ state <- loadState+ currentTime <- getCurrentTime+ let timeStr = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" currentTime+ let newEvent = FixEvent fixer action timeStr+ let pr = Map.findWithDefault (PRState "open" [] [] [] [] Nothing) branch state+ let updatedPr = pr { prFixes = prFixes pr ++ [newEvent] }+ let newState = Map.insert branch updatedPr state+ saveState newState++-- Check if approvals are still valid for the current branch state+checkValidApprovals :: String -> IO [Approval]+checkValidApprovals branch = do+ state <- loadState+ case Map.lookup branch state of+ Nothing -> return []+ Just pr -> do+ base <- getBaseBranch+ (code, out, _) <- readProcessWithExitCode "git" ["rev-parse", branch] ""+ if code /= ExitSuccess+ then return [] -- Branch doesn't exist, no valid approvals+ else do+ let currentCommit = trimTrailing out+ currentContentHash <- generatePatchHash base currentCommit+ + let approvals = approvalHistory pr+ validApprovals <- filterM (\approval -> do+ -- Check if approval is valid by commit ID or content hash+ let commitValid = any (\ci -> ciHash ci == currentCommit) (apCommits approval)+ let contentValid = case apContentHash approval of+ Just hash -> hash == currentContentHash+ Nothing -> False+ -- For debugging, let's see what's happening+ -- putStrLn $ "Checking approval by " ++ apApprover approval ++ ": commitValid=" ++ show commitValid ++ ", contentValid=" ++ show contentValid+ return (commitValid || contentValid)+ ) approvals+ + return validApprovals+ where+ filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]+ filterM _ [] = return []+ filterM p (x:xs) = do+ flg <- p x+ ys <- filterM p xs+ return (if flg then x:ys else ys)++-- Transfer approvals after a rebase by updating commit hashes while preserving content hashes+transferApprovalsAfterRebase :: String -> String -> String -> IO ()+transferApprovalsAfterRebase branch oldCommit newCommit = do+ state <- loadState+ case Map.lookup branch state of+ Nothing -> putStrLn "No PR state found for branch"+ Just pr -> do+ base <- getBaseBranch+ oldContentHash <- generatePatchHash base oldCommit+ newContentHash <- generatePatchHash base newCommit+ + putStrLn $ "Old content hash: " ++ oldContentHash+ putStrLn $ "New content hash: " ++ newContentHash+ + -- Only transfer if content is the same+ if oldContentHash == newContentHash then do+ -- Get new commit list+ logOut <- readProcess "git" ["log", "--format=%H %s", base ++ ".." ++ newCommit, "--"] ""+ let commitLines = lines logOut+ let newCommits = map (\ln -> let h = take 40 ln+ m = drop 41 ln+ in CommitInfo h m) (filter (not . null) commitLines)+ + putStrLn $ "Found " ++ show (length (approvalHistory pr)) ++ " approvals to check"+ + -- Update approvals with new commit hashes but keep content hash+ let updatedApprovals = map (\approval -> + case apContentHash approval of+ Just hash | hash == oldContentHash -> do+ let updated = approval { apCommits = newCommits }+ updated+ _ -> approval+ ) (approvalHistory pr)+ + let updatedPr = pr { approvalHistory = updatedApprovals }+ let newState = Map.insert branch updatedPr state+ saveState newState+ putStrLn $ "Approvals transferred after rebase. Updated " ++ show (length updatedApprovals) ++ " approvals."+ else+ putStrLn "Content has changed - approvals cannot be transferred automatically"++recordApproval :: String -> String -> String -> IO ()+recordApproval branch approver commitHash = do+ state <- loadState+ let pr = Map.findWithDefault (PRState "open" [] [] [] [] Nothing) branch state+ + base <- getBaseBranch+ logOut <- readProcess "git" ["log", "--format=%H %s", base ++ ".." ++ commitHash, "--"] ""+ let commitLines = lines logOut+ let commits = map (\ln -> let h = take 40 ln+ m = drop 41 ln+ in CommitInfo h m) (filter (not . null) commitLines)++ -- Generate content hash for the patch+ contentHash <- generatePatchHash base commitHash++ currentTime <- getCurrentTime+ let timeStr = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" currentTime+ let newApproval = Approval approver timeStr commits (Just contentHash)+ let newApprovalHistory = approvalHistory pr ++ [newApproval]+ + let newPr = pr { approvalHistory = newApprovalHistory }+ let newState = Map.insert branch newPr state+ saveState newState++-- Check if current content has been reviewed+checkReviewStatus :: String -> IO (Bool, [String])+checkReviewStatus branch = do+ state <- loadState+ case Map.lookup branch state of+ Nothing -> return (False, [])+ Just pr -> do+ base <- getBaseBranch+ (code, out, _) <- readProcessWithExitCode "git" ["rev-parse", branch] ""+ if code /= ExitSuccess+ then do+ -- Branch doesn't exist, check if all non-removed commits from latest snapshot are reviewed+ if null (prSnapshots pr)+ then return (False, [])+ else do+ let latestSnapshot = last (prSnapshots pr)+ let commits = psCommits latestSnapshot+ if null commits+ then return (False, [])+ else do+ -- Filter out removed commits (commits that no longer exist)+ existingCommits <- filterM (\ci -> do+ (commitCode, _, _) <- readProcessWithExitCode "git" ["rev-parse", "--verify", ciHash ci] ""+ return (commitCode == ExitSuccess)+ ) commits+ + if null existingCommits+ then return (True, []) -- All commits are removed, consider reviewed+ else do+ -- Check if all existing commits are reviewed+ reviewStatuses <- mapM (checkCommitReviewStatus branch . ciHash) existingCommits+ let allReviewed = and reviewStatuses+ if allReviewed+ then do+ -- Get reviewers from review events+ let reviewEvents = prReviews pr+ let endEvents = filter (\re -> reAction re == "end") reviewEvents+ let reviewers = nub [reReviewer re | re <- endEvents]+ return (True, reviewers)+ else return (False, [])+ else do+ -- Branch exists, get current commits and check if all are reviewed+ let currentCommit = trimTrailing out+ logOut <- readProcess "git" ["log", "--format=%H", base ++ ".." ++ currentCommit] ""+ let commitHashes = lines logOut+ if null commitHashes+ then return (True, []) -- No commits to review+ else do+ -- Check if all current commits are reviewed+ reviewStatuses <- mapM (checkCommitReviewStatus branch) commitHashes+ let allReviewed = and reviewStatuses+ if allReviewed+ then do+ -- Get reviewers from review events+ let reviewEvents = prReviews pr+ let endEvents = filter (\re -> reAction re == "end") reviewEvents+ let reviewers = nub [reReviewer re | re <- endEvents]+ return (True, reviewers)+ else return (False, [])+ where+ filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]+ filterM _ [] = return []+ filterM p (x:xs) = do+ flg <- p x+ ys <- filterM p xs+ return (if flg then x:ys else ys)++-- Check if a specific commit has been reviewed+checkCommitReviewStatus :: String -> String -> IO Bool+checkCommitReviewStatus branch commitHash = do+ state <- loadState+ case Map.lookup branch state of+ Nothing -> return False+ Just pr -> do+ let reviewEvents = prReviews pr+ let endEvents = filter (\re -> reAction re == "end") reviewEvents+ + -- Check new format first (individual commit hashes)+ let reviewedCommitMaps = [commitMap | re <- endEvents, Just commitMap <- [reReviewedCommits re]]+ let directlyReviewed = any (Map.member commitHash) reviewedCommitMaps+ + if directlyReviewed+ then return True+ else do+ -- Fall back to legacy format for backward compatibility+ base <- getBaseBranch+ (code, _, _) <- readProcessWithExitCode "git" ["rev-parse", "--verify", commitHash] ""+ if code /= ExitSuccess+ then return False -- Commit doesn't exist+ else do+ let legacyHashes = [hash | re <- endEvents, Just hash <- [reContentHash re], reReviewedCommits re == Nothing]+ if null legacyHashes+ then return False+ else do+ -- For legacy events, check if this commit's content matches any reviewed content+ commitContentHash <- generatePatchHash base commitHash+ return (commitContentHash `elem` legacyHashes)
+ src/PRTools/ReviewLogic.hs view
@@ -0,0 +1,10 @@+module PRTools.ReviewLogic+ ( filterComments+ ) where++import PRTools.ReviewState (Cmt (..))++-- | Filters comments based on the showAll flag.+-- If showAll is False, only unresolved comments are returned.+filterComments :: Bool -> [Cmt] -> [Cmt]+filterComments showAll = if showAll then id else filter (not . cmResolved)
+ test/CommentRendererSpec.hs view
@@ -0,0 +1,19 @@+module CommentRendererSpec where++import Test.Hspec+import PRTools.CommentRenderer (detectEol, normalizeLines, joinLines)++spec :: Spec+spec = do+ describe "EOL handling" $ do+ it "detects CRLF and preserves it in joinLines" $ do+ let content = "a\r\nb\r\n"+ detectEol content `shouldBe` "\r\n"+ normalizeLines content `shouldBe` ["a", "b"]+ joinLines "\r\n" ["a", "b"] `shouldBe` "a\r\nb\r\n"++ it "defaults to LF when no CRLF is present" $ do+ let content = "a\nb\n"+ detectEol content `shouldBe` "\n"+ normalizeLines content `shouldBe` ["a", "b"]+ joinLines "\n" ["a", "b"] `shouldBe` "a\nb\n"
+ test/FixParserSpec.hs view
@@ -0,0 +1,19 @@+module FixParserSpec (spec) where++import Test.Hspec+import PRTools.ReviewState (Cmt(..))+import PRTools.FixParser (parseBlock)++spec :: Spec+spec = do+ describe "PRTools.FixParser.parseBlock" $ do+ it "should correctly parse an answer without the trailing square bracket" $ do+ let initialComment = Cmt "id123" "file.hs" 1 "text" False "not-solved" Nothing ""+ let comments = [initialComment]+ -- THIS IS THE CORRECTED LINE:+ let header = "-- REVIEW COMMENT BEGIN [id123] [status:solved] [answer:My answer is here]]"+ let block = [header]++ let updatedComments = parseBlock block comments+ let resultComment = head updatedComments+ cmAnswer resultComment `shouldBe` Just "My answer is here"
+ test/PRStateSpec.hs view
@@ -0,0 +1,69 @@+module PRStateSpec (spec) where++import Test.Hspec+import PRTools.PRState+import qualified Data.Map.Strict as Map++spec :: Spec+spec = do+ describe "PRState event tracking" $ do+ it "should correctly add a review event" $ do+ let branch = "feature-branch"+ let reviewer = "John Doe"+ let action = "start"+ let pr = PRState "open" [] [] [] [] Nothing+ let state = Map.singleton branch pr+ + let currentTime = "2025-08-12 10:00:00"+ let newEvent = ReviewEvent reviewer action currentTime+ let updatedPr = pr { prReviews = [newEvent] }+ let newState = Map.insert branch updatedPr state+ + let retrievedPr = newState Map.! branch+ prReviews retrievedPr `shouldBe` [newEvent]++ it "should correctly add a fix event" $ do+ let branch = "feature-branch"+ let fixer = "Jane Doe"+ let action = "start"+ let pr = PRState "open" [] [] [] [] Nothing+ let state = Map.singleton branch pr+ + let currentTime = "2025-08-12 11:00:00"+ let newEvent = FixEvent fixer action currentTime+ let updatedPr = pr { prFixes = [newEvent] }+ let newState = Map.insert branch updatedPr state+ + let retrievedPr = newState Map.! branch+ prFixes retrievedPr `shouldBe` [newEvent]++ it "should correctly add an approval" $ do+ let branch = "feature-branch"+ let approver = "Jane Smith"+ let commits = [CommitInfo "hash1" "commit1", CommitInfo "hash2" "commit2"]+ let pr = PRState "open" [] [] [] [] Nothing+ let state = Map.singleton branch pr++ let currentTime = "2025-08-12 12:00:00"+ let newApproval = Approval approver currentTime commits+ let updatedPr = pr { approvalHistory = [newApproval] }+ let newState = Map.insert branch updatedPr state++ let retrievedPr = newState Map.! branch+ approvalHistory retrievedPr `shouldBe` [newApproval]++ it "should correctly record merge info" $ do+ let branch = "feature-branch"+ let merger = "Admin"+ let commits = [CommitInfo "hash1" "commit1", CommitInfo "hash2" "commit2"]+ let pr = PRState "open" [] [] [] [] Nothing+ let state = Map.singleton branch pr++ let currentTime = "2025-08-12 13:00:00"+ let mergeInfo = MergeInfo merger currentTime commits+ let updatedPr = pr { prStatus = "merged", prMergeInfo = Just mergeInfo }+ let newState = Map.insert branch updatedPr state++ let retrievedPr = newState Map.! branch+ prMergeInfo retrievedPr `shouldBe` Just mergeInfo+ prStatus retrievedPr `shouldBe` "merged"
+ test/ReviewLogicSpec.hs view
@@ -0,0 +1,28 @@+module ReviewLogicSpec (spec) where++import PRTools.ReviewLogic (filterComments)+import PRTools.ReviewState (Cmt (..))+import Test.Hspec++spec :: Spec+spec = do+ describe "PRTools.ReviewLogic.filterComments" $ do+ let resolvedComment = Cmt "id1" "file.hs" 1 "resolved" True "solved" Nothing ""+ let unresolvedComment = Cmt "id2" "file.hs" 2 "unresolved" False "not-solved" Nothing ""+ let comments = [resolvedComment, unresolvedComment]++ it "returns all comments when showAll is True" $ do+ filterComments True comments `shouldBe` comments++ it "returns only unresolved comments when showAll is False" $ do+ filterComments False comments `shouldBe` [unresolvedComment]++ it "returns an empty list if all comments are resolved and showAll is False" $ do+ filterComments False [resolvedComment] `shouldBe` []++ it "returns all comments if all are unresolved and showAll is False" $ do+ filterComments False [unresolvedComment] `shouldBe` [unresolvedComment]++ it "returns an empty list for an empty input list" $ do+ filterComments True ([] :: [Cmt]) `shouldBe` []+ filterComments False ([] :: [Cmt]) `shouldBe` []
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}