Defining overridable default generators for Hedgehog using Higgledy

HiggledyHedgehog.hs

{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE DeriveGeneric    #-}
{-# LANGUAGE NamedFieldPuns   #-}
{-# LANGUAGE TypeApplications #-}
module HiggledyHedgehog where

import           Control.Lens
import           Data.Generic.HKD
import           GHC.Generics     (Generic)
import           Hedgehog
import qualified Hedgehog.Gen     as Gen
import qualified Hedgehog.Range   as Range

-- * Implementation
--------------------------------------------------------------------------------

data Programmer = Programmer
  { name                        :: String
  , writesTests                 :: Bool
  , nbrOwnedMechanicalKeyboards :: Int
  } deriving (Generic, Show)

maxKeyboardOneCanOwn :: Int
maxKeyboardOneCanOwn = 10 -- I mean, seriously.

-- It's important to be a hip programmer.
hipness :: Programmer -> Double
hipness Programmer { nbrOwnedMechanicalKeyboards } =
  let ratio = fromIntegral nbrOwnedMechanicalKeyboards
        / fromIntegral maxKeyboardOneCanOwn
  in  max 0.05 ratio

-- Less so, hired.
hired :: Programmer -> Bool
hired programmer =
  -- Either you're very responsible and keep the mechanical keyboard
  -- madness at a minimum.
  (  writesTests programmer
    && nbrOwnedMechanicalKeyboards programmer <= 3
    )
  -- Or you're just so hip that you'll get the job regardless.
    || hipness programmer >= 0.5

-- * Generators and Tests
--------------------------------------------------------------------------------

-- Default generator of 'Programmer' values, lifted to a HKD.
genProgrammer :: MonadGen m => HKD Programmer m
genProgrammer =
  build @Programmer
  (Gen.element ["Alice", "Bob", "Carol"])
  Gen.bool
  (Gen.integral (Range.linear 0 maxKeyboardOneCanOwn))

-- For this property we can use the default generator. The property
-- should hold for all generated 'Programmer' values.
prop_every_programmer_is_a_bit_hip = property $ do
  person <- forAll (construct genProgrammer)
  assert (hipness person >= 0.05)

-- The default 'genProgrammer' won't cut it for this test. We need to
-- override some generators.
prop_some_programmers_get_hired = property $ do
  let genResponibleProgrammer =
        genProgrammer
        & field @"writesTests".~ pure True
        & field @"nbrOwnedMechanicalKeyboards"  .~ Gen.integral (Range.linear 0 3)
        & construct
  person <- forAll genResponibleProgrammer
  assert (hired person)

-- Again, we need to override some things.
prop_super_hip_programmers_get_hired = property $ do
  let genSuperHipProgrammer =
        genProgrammer
          & field @"writesTests" .~ pure False
          & field @"nbrOwnedMechanicalKeyboards" .~ Gen.integral (Range.linear 5 maxKeyboardOneCanOwn)
          &  construct
  person <- forAll genSuperHipProgrammer
  assert (hired person)

Sweet! @cmeeren has been doing similar in F#: https://github.com/cmeeren/fsharp-hedgehog-experimental