Test the encoding and decoding

This commit is contained in:
Mats Rauhala 2020-12-31 08:51:37 +02:00
parent 213e94c896
commit 98f732dbd2
4 changed files with 54 additions and 0 deletions

View File

@ -67,6 +67,7 @@ executable buuka
test-suite buuka-test test-suite buuka-test
import: common-stanza import: common-stanza
other-modules: Test.Database.Migrations other-modules: Test.Database.Migrations
Test.Data.Buuka
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
hs-source-dirs: test hs-source-dirs: test
main-is: MyLibTest.hs main-is: MyLibTest.hs

View File

@ -5,6 +5,7 @@ module Data.Buuka
, BuukaU(..) , BuukaU(..)
, BuukaEntry(..) , BuukaEntry(..)
, URL(..) , URL(..)
, Buuka
, insert , insert
) )
@ -38,6 +39,7 @@ instance SafeJSON BuukaEntry where
type Version BuukaEntry = 0 type Version BuukaEntry = 0
newtype Buuka = Buuka ( Map URL BuukaEntry ) newtype Buuka = Buuka ( Map URL BuukaEntry )
deriving stock (Show, Eq)
deriving newtype (Semigroup, Monoid, FromJSON, ToJSON) deriving newtype (Semigroup, Monoid, FromJSON, ToJSON)
insert :: BuukaEntry -> Buuka -> Buuka insert :: BuukaEntry -> Buuka -> Buuka

View File

@ -2,11 +2,13 @@ module Main (main) where
import Test.Tasty import Test.Tasty
import qualified Test.Data.Buuka as Data.Buuka
import qualified Test.Database.Migrations as Database.Migrations import qualified Test.Database.Migrations as Database.Migrations
tests :: TestTree tests :: TestTree
tests = testGroup "buuka" tests = testGroup "buuka"
[ Database.Migrations.tests [ Database.Migrations.tests
, Data.Buuka.tests
] ]
main :: IO () main :: IO ()

49
test/Test/Data/Buuka.hs Normal file
View File

@ -0,0 +1,49 @@
module Test.Data.Buuka where
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Tasty
import Test.Tasty.Hedgehog
import qualified Data.Aeson as A
import Data.List
(intercalate)
import qualified Data.Foldable as F
import Data.Buuka
genUrl :: Gen URL
genUrl = URL . concat <$> sequence go
where
go = [ Gen.element protocols, Gen.element domains, Gen.element tlds, pure "/", genPath ]
protocols = ["http://", "https://"]
domains = ["example", "foo", "bar"]
tlds = ["com", "fi", "org", "net", "info"]
genPath = intercalate "/" <$> Gen.list (Range.linear 0 10) (Gen.element paths)
paths = ["foo", "bar", "asd", "xyzzy"]
genBuukaEntry :: Gen BuukaEntry
genBuukaEntry = BuukaEntry <$> genUrl <*> genTitle
where
genTitle = Gen.maybe (Gen.string (Range.linear 0 10) Gen.unicode)
genBuuka :: Gen Buuka
genBuuka = F.foldl' (flip insert) mempty <$> Gen.list (Range.linear 0 10) genBuukaEntry
prop_buukaentry_encode_decode :: Property
prop_buukaentry_encode_decode = property $ do
x <- forAll genBuukaEntry
tripping x A.encode A.eitherDecode
prop_buuka_encode_decode :: Property
prop_buuka_encode_decode = property $ do
x <- forAll genBuuka
tripping x A.encode A.eitherDecode
tests :: TestTree
tests = testGroup "Data.Buuka"
[ testProperty "Entries can be encoded and decoded" prop_buukaentry_encode_decode
, testProperty "Entire set can be encoded and decoded" prop_buuka_encode_decode
]