Parametrised unit tests and Template Haskell

parametrised-unit-tests-in-haskell.diff

@@ -1,11 +1,13 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 module Main (main) where
 
 import           Data.Fixed (Pico)
 import           Data.Time (LocalTime(..), TimeOfDay(..), ZonedTime(..),
                             fromGregorian, hoursToTimeZone)
-import           Test.Framework (defaultMain)
+import           Discordia.TH
 import           Test.Framework.Providers.HUnit (hUnitTestToTests)
 import           Test.HUnit (Test(..), (~:), (~=?))
 
 newtype ZonedTimeEq =
   ZT ZonedTime deriving (Show)
@@ -22,12 +24,12 @@ zt (y, mth, d) (h, m, s) tz =
     (hoursToTimeZone tz)
 
 adjustToBusinessHours :: a -> a
 adjustToBusinessHours = id
 
-adjustToBusinessHoursReturnsCorrectResult :: [Test]
-adjustToBusinessHoursReturnsCorrectResult = do
+case_adjustToBusinessHoursReturnsCorrectResult :: [Test]
+case_adjustToBusinessHoursReturnsCorrectResult = do
   (dt, expected) <-
     [
       (zt (2017, 10, 2) (6, 59,  4) 0, zt (2017, 10, 2) (9,  0,  0) 0),
       (zt (2017, 10, 2) (9, 42, 41) 0, zt (2017, 10, 2) (9, 42, 41) 0),
       (zt (2017, 10, 2) (19, 1, 32) 0, zt (2017, 10, 3) (9,  0,  0) 0)
@@ -35,10 +37,6 @@ adjustToBusinessHoursReturnsCorrectResult = do
   let actual = adjustToBusinessHours dt
   return $ ZT expected ~=? ZT actual
 
 main :: IO ()
 main =
-    defaultMain
-  $ hUnitTestToTests
-  $ TestList [
-      "adjustToBusinessHours returns correct result" ~: adjustToBusinessHoursReturnsCorrectResult
-    ]
+  $(discover)

TH.hs

{-# LANGUAGE TemplateHaskell #-}

module Discordia.TH where

import           Language.Haskell.Extract (functionExtractorMap)
import           Language.Haskell.TH
import           Test.Framework (defaultMain)
import           Test.HUnit (Test(..))

discover :: ExpQ
discover = [|
    defaultMain
  $ hUnitTestToTests
  $ TestList $(createTest "^case_" "~:")
  |]

createTest :: String -> String -> ExpQ
createTest beginning funcName =
  functionExtractorMap beginning $ applyNameFix funcName

applyNameFix :: String -> ExpQ
applyNameFix n =
  do fn <- [|fixName|]
     return $
       LamE
         [VarP (mkName "n")]
         (AppE (VarE (mkName n)) (AppE (fn) (VarE (mkName "n"))))

fixName :: String -> String
fixName name =
  replace '_' ' ' $ drop 5 name

replace :: Eq a => a -> a -> [a] -> [a]
replace b v =
  map (\i -> if b == i then v else i)

Based on http://blog.ploeh.dk/2018/04/30/parametrised-unit-tests-in-haskell/.