tests/HUnits.hs

   1 {-# LANGUAGE ConstraintKinds #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 {-# LANGUAGE RankNTypes #-}
   4 {-# LANGUAGE UndecidableInstances #-}
   5
   6 module HUnits where
   7
   8 import Data.Tree
   9 import Network.URI.Slug
  10 import Relude
  11 import Test.Tasty
  12 import Test.Tasty.HUnit
  13
  14 import Examples.Ex01 qualified as Ex01
  15 import Utils
  16 import Webc
  17
  18 test :: TestTree
  19 test =
  20   testGroup
  21     "HUnits"
  22     [ testGroup
  23         "Generator"
  24         [ testGenerator
  25             "Ex01"
  26             Ex01.site
  27             [ Node (GeneratorNode Ex01.Index ["index.html"]) []
  28             , Node (GeneratorNode Ex01.About ["about.html"]) []
  29             , Node (GeneratorNode (Ex01.Contact "user") ["user", "contact.html"]) []
  30             , Node (GeneratorNode (Ex01.Post []) ["post"]) []
  31             , Node (GeneratorNode (Ex01.Post ["dir"]) ["post", "dir"]) []
  32             , Node (GeneratorNode (Ex01.Post ["dir", "dir"]) ["post", "dir", "dir"]) []
  33             ]
  34             [ Ex01.Index
  35             , Ex01.About
  36             , Ex01.Contact "user"
  37             , Ex01.Post []
  38             , Ex01.Post ["dir"]
  39             , Ex01.Post ["dir", "dir"]
  40             ]
  41         ]
  42     , testGroup
  43         "CoderIsomorphism"
  44         [ testCoderIsomorphism "Ex01" Ex01.site
  45         ]
  46     , testGroup
  47         "Encoder"
  48         [ testEncoder
  49             "Ex01"
  50             Ex01.site
  51             [ (Ex01.Index, ["index.html"])
  52             , (Ex01.About, ["about.html"])
  53             , (Ex01.Contact "user", ["user", "contact.html"])
  54             , (Ex01.Post ["a", "b"], ["post", "a", "b"])
  55             ]
  56         ]
  57     , testGroup
  58         "Decoder"
  59         [ testDecoder
  60             "Ex01"
  61             Ex01.site
  62             [ (Ex01.Index, ["index.html"])
  63             , (Ex01.About, ["about.html"])
  64             , (Ex01.Contact "user", ["user", "contact.html"])
  65             , (Ex01.Post ["a", "b"], ["post", "a", "b"])
  66             ]
  67         ]
  68     ]
  69
  70 testGenerator ::
  71   Eq a =>
  72   Show a =>
  73   String ->
  74   Generator a ->
  75   {-expected-} (Forest (GeneratorNode a)) ->
  76   {-expected-} [a] ->
  77   TestTree
  78 testGenerator tn site expectedCheck expectedValues =
  79   let lay = generator site
  80    in testGroup
  81         tn
  82         [ testCase "generate" $ generate lay @?= expectedCheck
  83         , testCase "generateValues" $ generateValues lay @?= expectedValues
  84         ]
  85
  86 testCoderIsomorphism ::
  87   Eq a =>
  88   Show a =>
  89   String ->
  90   (forall repr. Testable repr => repr a) ->
  91   TestTree
  92 testCoderIsomorphism tn site =
  93   testGroup tn $
  94     zipWith
  95       ( \n (a, slugs) ->
  96           testGroup n $
  97             [ (testCase "decode . encode" $ decode site (encode site a) @?= Right a)
  98             , (testCase "encode . decode" $ encode site <$> decode site slugs @?= Right slugs)
  99             ]
 100       )
 101       (show <$> [1 :: Int ..])
 102       (zip (generateValues site) (generateSlugs site))
 103
 104 testDecoder :: (Eq a, Show a) => String -> Decoder a -> [(a, [Slug])] -> TestTree
 105 testDecoder tn site as =
 106   testGroup tn $
 107     zipWith
 108       (\n (expected, slugs) -> testCase n $ decode site slugs @?= Right expected)
 109       (show <$> [1 :: Int ..])
 110       as
 111
 112 testEncoder :: String -> Encoder a -> [(a, [Slug])] -> TestTree
 113 testEncoder tn site as =
 114   testGroup tn $
 115     zipWith
 116       (\n (a, expected) -> testCase n $ encode site a @?= expected)
 117       (show <$> [1 :: Int ..])
 118       as