rss-conduit-0.5.0.0: test/QuickCheck.hs

{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedLists     #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
-- {{{ Imports
import           Text.RSS.Conduit.Parse          as Parser
import           Text.RSS.Conduit.Render         as Renderer
import           Text.RSS.Extensions
import           Text.RSS.Extensions.Atom
import           Text.RSS.Extensions.Content
import           Text.RSS.Extensions.DublinCore
import           Text.RSS.Extensions.Syndication
import           Text.RSS.Lens
import           Text.RSS.Types
import           Text.RSS1.Conduit.Parse         as Parser

import           Arbitrary
import           Blaze.ByteString.Builder        (toByteString)
import           Conduit
import           Control.Monad
import           Data.Char
import           Data.Conduit
import           Data.Conduit.List
import           Data.Maybe
import           Data.String
import           Data.Text                       (Text)
import           Data.Text.Encoding
import qualified Data.Text.Lazy.Encoding         as Lazy
import           Data.Time.Calendar
import           Data.Time.LocalTime
import           Data.Version
import           Data.Void
import           Data.XML.Types
import           Prelude                         ()
import           Prelude.Compat
import           System.FilePath
import           System.IO
import           System.Timeout
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Text.Atom.Conduit.Parse
import           Text.Atom.Types
import           Text.XML.Stream.Parse           as XML hiding (choose)
import           Text.XML.Stream.Render
import           URI.ByteString
import           URI.ByteString.QQ
-- }}}

main :: IO ()
main = defaultMain $ testGroup "Property tests"
  [ roundtripProperty "RssTextInput" renderRssTextInput rssTextInput
  , roundtripProperty "RssImage" renderRssImage rssImage
  , roundtripProperty "RssCategory" renderRssCategory rssCategory
  , roundtripProperty "RssEnclosure" renderRssEnclosure rssEnclosure
  , roundtripProperty "RssSource" renderRssSource rssSource
  , roundtripProperty "RssGuid" renderRssGuid rssGuid
--   , roundtripProperty "RssItem"
--       (renderRssItem :: RssItem '[] -> ConduitT () Event Maybe ())
--       rssItem
  , roundtripProperty "DublinCore"
      (renderRssChannelExtension @(DublinCoreModule NoExtensions))
      (Just <$> parseRssChannelExtension)
  , roundtripProperty "Syndication"
      (renderRssChannelExtension @(SyndicationModule NoExtensions))
      (Just <$> parseRssChannelExtension)
  , roundtripProperty "Atom"
      (renderRssChannelExtension @(AtomModule NoExtensions))
      (Just <$> parseRssChannelExtension)
  , roundtripProperty "Content"
      (renderRssItemExtension @(ContentModule NoExtensions))
      (Just <$> parseRssItemExtension)
  ]


roundtripProperty :: Eq a => Arbitrary a => Show a
                  => TestName -> (a -> ConduitT () Event Maybe ()) -> ConduitT Event Void Maybe (Maybe a) -> TestTree
roundtripProperty name render parse = testProperty ("parse . render = id (" <> name <> ")") $ do
  input <- arbitrary
  let intermediate = fmap (decodeUtf8 . toByteString) $ runConduit $ render input .| renderBuilder def .| foldC
      output = join $ runConduit $ render input .| parse
  return $ counterexample (show input <> " | " <> show intermediate <> " | " <> show output) $ Just input == output

roundtripTextInputProperty :: TestTree
roundtripTextInputProperty = testProperty "parse . render = id (RssTextInput)" $ \t -> either (const False) (t ==) (runConduit $ renderRssTextInput t .| force "ERROR" rssTextInput)

roundtripImageProperty :: TestTree
roundtripImageProperty = testProperty "parse . render = id (RssImage)" $ \t -> either (const False) (t ==) (runConduit $ renderRssImage t .| force "ERROR" rssImage)

roundtripCategoryProperty :: TestTree
roundtripCategoryProperty = testProperty "parse . render = id (RssCategory)" $ \t -> either (const False) (t ==) (runConduit $ renderRssCategory t .| force "ERROR" rssCategory)

roundtripEnclosureProperty :: TestTree
roundtripEnclosureProperty = testProperty "parse . render = id (RssEnclosure)" $ \t -> either (const False) (t ==) (runConduit $ renderRssEnclosure t .| force "ERROR" rssEnclosure)

roundtripSourceProperty :: TestTree
roundtripSourceProperty = testProperty "parse . render = id (RssSource)" $ \t -> either (const False) (t ==) (runConduit $ renderRssSource t .| force "ERROR" rssSource)

roundtripGuidProperty :: TestTree
roundtripGuidProperty = testProperty "parse . render = id (RssGuid)" $ \t -> either (const False) (t ==) (runConduit $ renderRssGuid t .| force "ERROR" rssGuid)

roundtripItemProperty :: TestTree
roundtripItemProperty = testProperty "parse . render = id (RssItem)" $ \(t :: RssItem NoExtensions) -> either (const False) (t ==) (runConduit $ renderRssItem t .| force "ERROR" rssItem)