Tests pass

This commit is contained in:
Mats Rauhala 2020-12-10 21:24:23 +02:00
parent a43b0bf471
commit b483ccb3f4
5 changed files with 63 additions and 12 deletions

View File

@ -18,8 +18,11 @@ extra-source-files: CHANGELOG.md
library
exposed-modules: MyLib
, Data.Email.Header
-- other-modules:
-- other-extensions:
default-extensions: OverloadedStrings
LambdaCase
build-depends: base ^>=4.13.0.0
, attoparsec
, mtl
@ -27,6 +30,7 @@ library
, pipes-bytestring
, text
, bytestring-trie
, vector
hs-source-dirs: src
default-language: Haskell2010
@ -40,6 +44,9 @@ executable addressbook
test-suite addressbook-test
default-language: Haskell2010
default-extensions: OverloadedStrings
LambdaCase
other-modules: Test.Data.Email.Header
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: MyLibTest.hs
@ -48,3 +55,6 @@ test-suite addressbook-test
, tasty
, tasty-hedgehog
, hedgehog
, hedgehog-corpus
, text
, vector

View File

@ -1,5 +1,6 @@
{ mkDerivation, attoparsec, base, bytestring-trie, hedgehog, mtl
, pipes, pipes-bytestring, stdenv, tasty, tasty-hedgehog, text
{ mkDerivation, attoparsec, base, bytestring-trie, hedgehog
, hedgehog-corpus, mtl, pipes, pipes-bytestring, stdenv, tasty
, tasty-hedgehog, text, vector
}:
mkDerivation {
pname = "addressbook";
@ -9,8 +10,11 @@ mkDerivation {
isExecutable = true;
libraryHaskellDepends = [
attoparsec base bytestring-trie mtl pipes pipes-bytestring text
vector
];
executableHaskellDepends = [ base ];
testHaskellDepends = [ base hedgehog tasty tasty-hedgehog ];
testHaskellDepends = [
base hedgehog hedgehog-corpus tasty tasty-hedgehog
];
license = stdenv.lib.licenses.bsd3;
}

View File

@ -41,6 +41,7 @@ decode = parseOnly parseHeader
name <- T.pack <$> many' (notChar '@')
_ <- char '@'
rest <- T.pack <$> many' (satisfy (\c -> not (isSpace c) && c /= ','))
_ <- many' (notChar ',')
pure (name <> "@" <> rest)

View File

@ -1,4 +1,13 @@
module Main (main) where
import Test.Tasty
import qualified Test.Data.Email.Header as Data.Email.Header
tests :: TestTree
tests = testGroup "tests"
[ Data.Email.Header.tests
]
main :: IO ()
main = putStrLn "Test suite not yet implemented."
main = defaultMain tests

View File

@ -1,3 +1,4 @@
{-# LANGUAGE OverloadedLists #-}
module Test.Data.Email.Header where
import Test.Tasty
@ -9,6 +10,7 @@ import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Data.Text
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Email.Header
@ -18,19 +20,44 @@ genHeader = Gen.choice
[ From <$> genEmail
, To . V.fromList <$> Gen.list (Range.linear 0 10) genEmail
]
where
genEmail :: Gen Text
genEmail = do
genEmail :: Gen Text
genEmail = do
name <- Gen.element Corpus.simpsons
domain <- Gen.element Corpus.cooking
tld <- Gen.element ["com","fi","org"]
pure $ name <> "@" <> domain <> "." <> tld
genComment :: Gen Text
genComment = do
x <- Gen.element Corpus.simpsons
Gen.element [ "<" <> x <> ">", "(" <> x <> ")" ]
prop_roundtrip_parse :: Property
prop_roundtrip_parse = property $ do
header <- forAll genHeader
tripping header encode decode
prop_parse_from :: Property
prop_parse_from = property $ do
email <- forAll genEmail
decode ("From: " <> email) === Right (From email)
prop_parse_from_and_comments :: Property
prop_parse_from_and_comments = property $ do
(email, comment) <- forAll $ (,) <$> genEmail <*> genComment
decode ("From: " <> email <> " " <> comment) === Right (From email)
prop_parse_to_and_comments :: Property
prop_parse_to_and_comments = property $ do
emails <- forAll $ Gen.list (Range.linear 1 10) ((,) <$> genEmail <*> genComment)
let wanted = V.fromList $ fmap fst emails
decode ("To: " <> T.intercalate ", " (fmap (\(e,c) -> e <> " " <> c) emails)) === Right (To wanted)
tests :: TestTree
tests = testGroup "Data.Email.Header"
[ testProperty "roundtrip property" $ prop_roundtrip_parse ]
[ testProperty "roundtrip property" $ prop_roundtrip_parse
, testProperty "any email can be read as from" $ prop_parse_from
, testProperty "any email with comments can be parsed" $ prop_parse_from_and_comments
, testProperty "any list of emails with comments can be parsed" $ prop_parse_to_and_comments
]