Tests pass

addressbook.cabal

@@ -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

default.nix

@@ -1,5 +1,6 @@
-{ mkDerivation, attoparsec, base, bytestring-trie, hedgehog, mtl
+{ mkDerivation, attoparsec, base, bytestring-trie, hedgehog
-, pipes, pipes-bytestring, stdenv, tasty, tasty-hedgehog, text
+, 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;
 }

src/Data/Email/Header.hs

@@ -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)
 
 

test/MyLibTest.hs

@@ -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

test/Test/Data/Email/Header.hs

@@ -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 :: Gen Text
-    genEmail = do
+genEmail = do
-      name <- Gen.element Corpus.simpsons
+  name <- Gen.element Corpus.simpsons
-      domain <- Gen.element Corpus.cooking
+  domain <- Gen.element Corpus.cooking
-      tld <- Gen.element ["com","fi","org"]
+  tld <- Gen.element ["com","fi","org"]
-      pure $ name <> "@" <> domain <> "." <> tld
+  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
+  ]