Present code-coverage input in PRs

Author: MaximilianAlgehed

.github/workflows/haskell-ci.yml

@@ -1,5 +1,9 @@
 name: Haskell-CI
 
+permissions:
+  contents: read
+  pull-requests: write
+
 on:
   push:
     branches:
@@ -21,25 +25,67 @@ jobs:
     strategy:
       matrix:
         ghc-version: [latest, 9.12, "9.10", 9.8, 9.6]
-        os: [ubuntu-24.04]
       fail-fast: false
 
-    runs-on: ${{ matrix.os }}
+    runs-on: ubuntu-latest
 
     steps:
       - uses: actions/checkout@v4
       - uses: haskell-actions/setup@v2
         with:
           ghc-version: ${{matrix.ghc-version}}
-      - uses: actions/cache/restore@v4
+      - uses: actions/cache@v4
+        with:
+          key: ${{ matrix.ghc-version }}-${{ github.sha }}
+          path: |
+            ~/.cabal/store
+            dist-newstyle
+            .hpc
+          restore-keys: ${{ matrix.ghc-version }}-
+      - run: cabal build all --ghc-options=-fhpc
+      - run: cabal test all --ghc-options=-fhpc
+      - run: ./scripts/generate-coverage-comment.sh constrained.tix > coverage-report.md
+      - run: cat coverage-report.md
+      - run: cabal haddock all --ghc-options=-fhpc
+      - name: Upload coverage report
+        uses: actions/upload-artifact@v4
         with:
-          key: ${{ matrix.os }}-${{ matrix.ghc-version }}-${{ github.sha }}
-          path: ~/.cabal/store
-          restore-keys: ${{ matrix.os }}-${{ matrix.ghc-version }}-
-      - run: cabal build all
-      - run: cabal test all
-      - run: cabal haddock all
-      - uses: actions/cache/save@v4
+          name: constrained-${{matrix.ghc-version}}-coverage
+          path: coverage-report.md
+          if-no-files-found: error
+          compression-level: 0
+          retention-days: 1
+
+  report:
+    name: Generate coverage report
+
+    if: github.event.pull_request
+
+    needs: linux
+
+    runs-on: ubuntu-latest
+
+    steps:
+      - name: Download coverage report
+        uses: actions/download-artifact@v4
+        with:
+          pattern: 'constrained-latest-coverage'
+          merge-multiple: true
+
+      - run: cat coverage-report.md
+
+      - name: Find Comment
+        uses: peter-evans/find-comment@v3
+        id: fc
+        with:
+          issue-number: ${{ github.event.pull_request.number }}
+          comment-author: 'github-actions[bot]'
+          body-includes: "expressions used"
+
+      - name: Create or update comment
+        uses: peter-evans/create-or-update-comment@v4
         with:
-          key: ${{ matrix.os }}-${{ matrix.ghc-version }}-${{ github.sha }}
-          path: ~/.cabal/store
+          comment-id: ${{ steps.fc.outputs.comment-id }}
+          issue-number: ${{ github.event.pull_request.number }}
+          body-path: coverage-report.md
+          edit-mode: replace

.gitignore

@@ -22,3 +22,4 @@ cabal.project.local~
 .HTF/
 .ghc.environment.*
 *.*.sw*
+*.tix

scripts/generate-coverage-comment.sh

@@ -0,0 +1,4 @@
+#!/bin/sh
+
+echo "# Coverage report"
+hpc report $1 | awk '{sub(/^[ \t]*/, "& - ")1; sub(/^  /, "", $0); print}'

test/Constrained/Tests.hs

@@ -59,21 +59,18 @@ testAll = hspec $ tests False
 tests :: Bool -> Spec
 tests nightly =
   describe "constrained" . modifyMaxSuccess (\ms -> if nightly then ms * 10 else ms) $ do
-    -- TODO: double-shrinking
+    -- TODO: figure out why this doesn't shrink
     testSpecNoShrink "reifiesMultiple" reifiesMultiple
     testSpec "assertReal" assertReal
     testSpecNoShrink "chooseBackwards" chooseBackwards
     testSpecNoShrink "chooseBackwards'" chooseBackwards'
-    -- TODO: turn this on again when QuickCheck version is bumped
-    -- testSpec "whenTrueExists" whenTrueExists
+    testSpec "whenTrueExists" whenTrueExists
     testSpec "assertRealMultiple" assertRealMultiple
-    -- TODO: quickcheck version
-    testSpecNoShrink "setSpec" setSpec
+    testSpec "setSpec" setSpec
     testSpec "leqPair" leqPair
     testSpec "setPair" setPair
     testSpecNoShrink "listEmpty" listEmpty
-    -- TODO: quickcheck version
-    testSpecNoShrink "compositionalSpec" compositionalSpec
+    testSpec "compositionalSpec" compositionalSpec
     testSpec "simplePairSpec" simplePairSpec
     testSpec "trickyCompositional" trickyCompositional
     testSpec "emptyListSpec" emptyListSpec
@@ -83,18 +80,19 @@ tests nightly =
     testSpec "fooSpec" fooSpec
     testSpec "mapElemSpec" mapElemSpec
     testSpec "mapElemKeySpec" mapElemKeySpec
-    -- TODO: double shrinking
+    -- TODO: figure out why this doesn't shrink
     testSpecNoShrink "mapIsJust" mapIsJust
     testSpecNoShrink "eitherKeys" eitherKeys
+    -- TODO: figure out why this doesn't shrink
     testSpecNoShrink "intSpec" intSpec
-    testSpecNoShrink "mapPairSpec" mapPairSpec
+    testSpec "mapPairSpec" mapPairSpec
+    -- TODO: figure out why this doesn't shrink
     testSpecNoShrink "mapEmptyDomainSpec" mapEmptyDomainSpec
     -- TODO: this _can_ be shrunk, but it's incredibly expensive to do
     -- so and it's not obvious if there is a faster way without implementing
     -- more detailed shrinking of `SuspendedSpec`s
     testSpecNoShrink "setPairSpec" setPairSpec
-    -- TODO: quickcheck version
-    testSpecNoShrink "fixedSetSpec" fixedSetSpec
+    testSpec "fixedSetSpec" fixedSetSpec
     testSpec "setOfPairLetSpec" setOfPairLetSpec
     testSpecNoShrink "emptyEitherSpec" emptyEitherSpec
     testSpecNoShrink "emptyEitherMemberSpec" emptyEitherMemberSpec
@@ -107,19 +105,19 @@ tests nightly =
     testSpec "maybeJustSetSpec" maybeJustSetSpec
     testSpec "weirdSetPairSpec" weirdSetPairSpec
     testSpec "knownDomainMap" knownDomainMap
-    -- TODO: figure out double-shrinking
+    -- TODO: figure out why this doesn't shrink
     testSpecNoShrink "testRewriteSpec" testRewriteSpec
     testSpec "parallelLet" parallelLet
     testSpec "letExists" letExists
     testSpec "letExistsLet" letExistsLet
     testSpec "notSubset" notSubset
     testSpec "unionSized" unionSized
-    -- TODO: figure out double-shrinking
+    -- TODO: figure out why this doesn't shrink
     testSpecNoShrink "dependencyWeirdness" dependencyWeirdness
     testSpec "foldTrueCases" foldTrueCases
     testSpec "foldSingleCase" foldSingleCase
     testSpec "listSumPair" (listSumPair @Int)
-    -- TODO: figure out double-shrinking
+    -- TODO: figure out why this doesn't shrink
     testSpecNoShrink "parallelLetPair" parallelLetPair
     testSpec "mapSizeConstrained" mapSizeConstrained
     testSpec "isAllZeroTree" isAllZeroTree
@@ -137,13 +135,12 @@ tests nightly =
     testSpec "sumRange" sumRange
     testSpec "sumListBad" sumListBad
     testSpec "listExistsUnfree" listExistsUnfree
-    -- TODO: turn this on when we bump quickcheck version
-    -- testSpec "listSumShort" listSumShort
+    testSpec "listSumShort" listSumShort
     testSpec "existsUnfree" existsUnfree
     testSpec "appendSize" appendSize
     testSpecNoShrink "appendSingleton" appendSingleton
     testSpec "singletonSubset" singletonSubset
-    -- TODO: double shrinking
+    -- TODO: figure out why this doesn't shrink
     testSpecNoShrink "reifyYucky" reifyYucky
     testSpec "fixedRange" fixedRange
     testSpec "rangeHint" rangeHint
@@ -470,6 +467,3 @@ foldWithSizeTests = do
     prop "something of size 2, can add to 0 in type with negative values." $
       testFoldSpec @Int (between 2 2) (between (-10) 10) (MemberSpec (pure 0)) Succeed
     prop "TEST listSum" $ prop_constrained_satisfies_sound (listSum @Int)
-
--- TODO Needs to sample like this: OR [pick t c | t <- total, c <- count]
--- prop "count =0, total is 0,1,2" $ testFoldSpec @Int (between 0 1) evenSpec (between 0 2) Succeed