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         "Layouter"
  24         [ testLayouter
  25             "Ex01"
  26             Ex01.site
  27             [ Node (LayoutNodeSlug Ex01.Index ["index.html"]) []
  28             , Node (LayoutNodeSlug Ex01.About ["about.html"]) []
  29             , Node (LayoutNodeSlug (Ex01.Contact "<user>") ["<user>", "contact.html"]) []
  30             ]
  31             [ Ex01.Index
  32             , Ex01.About
  33             , Ex01.Contact "<user>"
  34             ]
  35         ]
  36     , testGroup
  37         "CoderIsomorphism"
  38         [ testCoderIsomorphism "Ex01" Ex01.site
  39         ]
  40     , testGroup
  41         "Encoder"
  42         [ testEncoder
  43             "Ex01"
  44             Ex01.site
  45             [ (Ex01.Index, ["index.html"])
  46             , (Ex01.About, ["about.html"])
  47             ]
  48         ]
  49     ]
  50
  51 testLayouter ::
  52   Eq a =>
  53   Show a =>
  54   String ->
  55   Layouter a ->
  56   {-expected-} (Forest (LayoutNode a)) ->
  57   {-expected-} [a] ->
  58   TestTree
  59 testLayouter tn site expectedLayout expectedRoutes =
  60   let lay = layouter site
  61    in testGroup
  62         tn
  63         [ testCase "TreeLayout" $ layout lay @?= expectedLayout
  64         , testCase "ReachableRoutes" $ usedRoutes lay @?= expectedRoutes
  65         ]
  66
  67 testCoderIsomorphism ::
  68   Eq a =>
  69   Show a =>
  70   String ->
  71   (forall repr. Testable repr => repr a) ->
  72   TestTree
  73 testCoderIsomorphism tn site =
  74   testGroup tn $
  75     zipWith
  76       ( \n (a, slugs) ->
  77           testGroup n $
  78             [ (testCase "decode . encode" $ decode site (encode site a) @?= Right a)
  79             , (testCase "encode . decode" $ encode site <$> decode site slugs @?= Right slugs)
  80             ]
  81       )
  82       (show <$> [1 :: Int ..])
  83       (zip (usedRoutes site) (usedSlugs site))
  84
  85 testDecoder :: (Eq a, Show a) => String -> Decoder a -> [(a, [Slug])] -> TestTree
  86 testDecoder tn site as =
  87   testGroup tn $
  88     zipWith
  89       (\n (expected, slugs) -> testCase n $ decode site slugs @?= Right expected)
  90       (show <$> [1 :: Int ..])
  91       as
  92
  93 testEncoder :: String -> Encoder a -> [(a, [Slug])] -> TestTree
  94 testEncoder tn site as =
  95   testGroup tn $
  96     zipWith
  97       (\n (a, expected) -> testCase n $ encode site a @?= expected)
  98       (show <$> [1 :: Int ..])
  99       as