Tobasco In Your Coffee Machine Testing Properties.

new_hotness.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module CoffeeMachineTestsNew where

import Control.Lens
import Control.Monad.State (MonadState, execStateT)
import Control.Monad.IO.Class (MonadIO)

import Data.Foldable (for_)

import           Test.Tasty             (TestTree)
import           Test.Tasty.Hedgehog    (testProperty)

import Hedgehog hiding (Command)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

import qualified CoffeeMachine          as C

data DrinkType = Coffee | HotChocolate | Tea deriving (Bounded, Enum, Show, Eq)

hasDrinkType :: DrinkType -> C.Drink -> Bool
hasDrinkType Coffee C.Coffee {} = True
hasDrinkType Tea C.Tea{} = True
hasDrinkType HotChocolate C.HotChocolate{} = True
hasDrinkType _ _ = False

data DrinkAdditive = Milk | Sugar deriving (Bounded, Enum, Show, Eq)

data Model = Model
  { _modelDrinkType :: DrinkType
  , _modelMilk :: Int
  , _modelSugar :: Int
  }
makeClassy ''Model

-- wat wat sumtype waaaaaaaat
data Command
  = SetDrinkType DrinkType
  | AddMilkOrSugar DrinkAdditive
  deriving (Eq, Show)
makeClassyPrisms ''Command

-- Delicious constraint kinds <3
type CanTest c m =
  ( MonadTest m
  , MonadIO m
  , MonadState c m
  , HasModel c
  )

-- Playing with frequencies of generated commands was possible before, but this seems to
-- be more straightforward and flexible.
genCommand :: Gen Command
genCommand = Gen.choice
  [ SetDrinkType <$> Gen.enumBounded
  , AddMilkOrSugar <$> Gen.enumBounded
  ]

viewDrinkSetting :: (MonadTest m, MonadIO m) => C.Machine -> m C.Drink
viewDrinkSetting mach = evalIO $ view C.drinkSetting <$> C.peek mach

execSetDrinkType
  :: CanTest c m
  => C.Machine
  -> DrinkType
  -> m ()
execSetDrinkType mach d = do
  _ <- evalIO $ mach & case d of
    Coffee -> C.coffee
    HotChocolate -> C.hotChocolate
    Tea -> C.tea

  newDrinkType <- viewDrinkSetting mach
  assert $ hasDrinkType d newDrinkType

  modelDrinkType .= d
  modelMilk .= 0
  modelSugar .= 0

execAddMilkOrSugar
  :: CanTest c m
  => C.Machine
  -> DrinkAdditive
  -> m ()
execAddMilkOrSugar mach add = do
  drink0 <- viewDrinkSetting mach
  -- Can't add milk or sugar to hot chocolate
  -- previously known as 'Require'
  if hasDrinkType HotChocolate drink0 then pure () else do
    let (addF, machL, modelGet, modelSet) = case add of
          Milk -> (C.addMilk, C.milk, modelMilk, modelMilk)
          Sugar -> (C.addSugar, C.sugar, modelSugar, modelSugar)

    -- Execute
    _ <- evalIO $ addF mach
    drink <- viewDrinkSetting mach

    -- Ensure
    milksugar <- use modelGet
    maybe failure (succ milksugar ===) $ drink ^? (C._Coffee `failing` C._Tea) . machL

    -- Update
    modelSet += 1
    -- label doesn't exist in this version of hedgehog, need to bump packages.

-- More flexibility in how commands are executed is quite nice and might make it harder to
-- introduce stealth bugs because of not resetting things or stepping on your testin
-- environment.
execCommands
  :: ( MonadIO m
     , MonadTest m
     )
  => C.Machine
  -> [Command]
  -> m Model
execCommands mach cmds =
  flip execStateT (Model Coffee 0 0) . for_ cmds $ \case
    SetDrinkType d -> execSetDrinkType mach d
    AddMilkOrSugar a -> execAddMilkOrSugar mach a

-- This is, effectively the same as before, but more "use these functions" over "give us
-- your functions". Composibility over attempting to handle all use-cases. <3
stateMachineTests :: TestTree
stateMachineTests = testProperty "State Machine Tests" . property $ do
  cmds <- forAll $ Gen.list (Range.linear 1 100) genCommand
  _ <- evalIO C.newMachine >>= flip execCommands cmds
  pure ()