initial coverage tracking for hedgehog tests. :D

CoverHog.hs

data Tally = Tally
  { _tallyTally     :: Map Text Int
  }
  deriving (Eq, Show)
makeLenses ''Tally

newtype CoveredProperty = PC
  { unPC :: PropertyT (StateT Tally IO) ()
  }

data Cover = Cover
  { _coverageName :: !PropertyConfig
  , _coverageProp :: CoveredProperty
  }

cover_prop :: HasCallStack => PropertyT (StateT Tally IO) () -> Cover
cover_prop = Cover defaultConfig . PC

cover :: MonadState Tally m => Bool -> Text -> m ()
cover b l = when b $ tallyTally . at l %= Just . maybe 1 (+1)

prop_reverse_coverage :: Cover
prop_reverse_coverage = cover_prop $ do
  xs <- forAll $ Gen.list (Range.linear 0 100) Gen.bool

  cover (length xs > 50) "non-trivial"
  cover (length xs < 10) "trivial"

  reverse (reverse xs) === xs
  
testPropertyCoverage
  :: PropertyName
  -> Cover
  -> IO ()
testPropertyCoverage pName (Cover pConf (PC prop)) = do
  randSeed <- Seed.random
  let
    size = 0
    seed = randSeed

    runProp :: StateT Tally IO (Report Result)
    runProp = checkReport pConf size seed prop (pure . const ())

  (rresult, tally) <- runStateT runProp (Tally mempty)

  out <- Report.renderResult Nothing (Just pName) rresult

  putStrLn out
  print tally

f :: IO ()
f = testPropertyCoverage "floop" prop_reverse_coverage