summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorkoral <>2016-09-30 20:17:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-09-30 20:17:00 (GMT)
commit7714cea6fbbad91d5a6c4f252a3314caf45112f3 (patch)
treeea874a2b8709c1f2fe8c5ecda18892366b545678
parentbc6baa347f006122bd6dba495a3bcd768553395c (diff)
version 0.6.0.00.6.0.0
-rw-r--r--LICENSE2
-rwxr-xr-x[-rw-r--r--]Text/OPML/Conduit/Parse.hs164
-rwxr-xr-x[-rw-r--r--]Text/OPML/Conduit/Render.hs22
-rwxr-xr-x[-rw-r--r--]Text/OPML/Lens.hs0
-rw-r--r--opml-conduit.cabal15
-rw-r--r--test/Main.hs23
6 files changed, 118 insertions, 108 deletions
diff --git a/LICENSE b/LICENSE
index 9c20de0..51039cd 100644
--- a/LICENSE
+++ b/LICENSE
@@ -1,7 +1,7 @@
DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
Version 2, December 2004
-Copyright (C) 2015 koral <koral at mailoo dot org>
+Copyright (C) 2016 koral <koral at mailoo dot org>
Everyone is permitted to copy and distribute verbatim or modified
copies of this license document, and changing it is allowed as long
diff --git a/Text/OPML/Conduit/Parse.hs b/Text/OPML/Conduit/Parse.hs
index 284e39f..5a6515d 100644..100755
--- a/Text/OPML/Conduit/Parse.hs
+++ b/Text/OPML/Conduit/Parse.hs
@@ -1,6 +1,7 @@
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
@@ -18,14 +19,14 @@ module Text.OPML.Conduit.Parse
) where
-- {{{ Imports
-import Control.Applicative
-import Control.Foldl as Fold
+import Conduit hiding (throwM)
+
+import Control.Applicative hiding(many)
+import Control.Exception.Safe as Exception
import Control.Monad
-import Control.Monad.Catch
+import Control.Monad.Fix
import Data.CaseInsensitive hiding (map)
-import Data.Conduit.Parser
-import Data.Conduit.Parser.XML
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Maybe
import Data.Monoid
@@ -48,8 +49,8 @@ import Numeric
import Prelude hiding (last)
import Text.OPML.Types
-import Text.Parser.Combinators
import Text.ParserCombinators.ReadP (readP_to_S)
+import Text.XML.Stream.Parse
import URI.ByteString
-- }}}
@@ -78,7 +79,7 @@ asURI t = either (throwM . InvalidURI) return . parseURI laxURIParserOptions $ e
asVersion :: (MonadThrow m) => Text -> m Version
asVersion v = case filter (onull . snd) . readP_to_S parseVersion $ unpack v of
[(a, "")] -> return a
- _ -> throwM $ InvalidVersion v
+ _ -> throwM $ InvalidVersion v
asDecimal :: (MonadThrow m, Integral a) => Text -> m a
asDecimal t = case filter (onull . snd) . readSigned readDec $ unpack t of
@@ -105,23 +106,28 @@ asNonNull = maybe (throwM MissingText) return . fromNullable
asCategories :: Text -> [NonEmpty (NonNull Text)]
asCategories = mapMaybe (nonEmpty . mapMaybe fromNullable . split (== '/')) . split (== ',')
-dateTag :: (MonadCatch m) => Name -> ConduitParser Event m UTCTime
-dateTag name = tagName name ignoreAttrs $ \_ -> content asTime
+dateTag :: (MonadThrow m) => Name -> ConduitM Event o m (Maybe UTCTime)
+dateTag name = tagIgnoreAttrs name $ content >>= asTime
-uriTag :: (MonadCatch m) => Name -> ConduitParser Event m URI
-uriTag name = tagName name ignoreAttrs $ \_ -> content asURI
+uriTag :: (MonadThrow m) => Name -> ConduitM Event o m (Maybe URI)
+uriTag name = tagIgnoreAttrs name $ content >>= asURI
-expansionStateTag :: (MonadCatch m, Integral a) => ConduitParser Event m [a]
-expansionStateTag = tagName "expansionState" ignoreAttrs $ \_ -> content asExpansionState
+expansionStateTag :: (MonadThrow m, Integral a) => ConduitM Event o m (Maybe [a])
+expansionStateTag = tagIgnoreAttrs "expansionState" $ content >>= asExpansionState
-textTag :: (MonadCatch m) => Name -> ConduitParser Event m Text
-textTag name = tagName name ignoreAttrs $ const textContent
+textTag :: (MonadThrow m) => Name -> ConduitM Event o m (Maybe Text)
+textTag name = tagIgnoreAttrs name content
-decimalTag :: (Integral a, MonadCatch m) => Name -> ConduitParser Event m a
-decimalTag name = tagName name ignoreAttrs $ const $ content asDecimal
+decimalTag :: (Integral a, MonadThrow m) => Name -> ConduitM Event o m (Maybe a)
+decimalTag name = tagIgnoreAttrs name $ content >>= asDecimal
-unknownTag :: (MonadCatch m) => ConduitParser Event m ()
-unknownTag = tagPredicate (const True) ignoreAttrs $ \_ -> return ()
+projectC :: Monad m => Fold a a' b b' -> Conduit a m b
+projectC prism = fix $ \recurse -> do
+ item <- await
+ case (item, item ^? (_Just . prism)) of
+ (_, Just a) -> yield a >> recurse
+ (Just _, _) -> recurse
+ _ -> return ()
data HeadPiece = HeadCreated UTCTime
@@ -137,7 +143,6 @@ data HeadPiece = HeadCreated UTCTime
| HeadWindowLeft Int
| HeadWindowRight Int
| HeadWindowTop Int
- | HeadUnknown
makeTraversals ''HeadPiece
@@ -145,76 +150,85 @@ makeTraversals ''HeadPiece
-- | Parse the @\<head\>@ section.
-- This function is more lenient than what the standard demands on the following points:
--
--- - each sub-element may be repeated, in which case only the last occurrence is taken into account;
+-- - each sub-element may be repeated, in which case only the first occurrence is taken into account;
-- - each unknown sub-element is ignored.
-parseOpmlHead :: (MonadCatch m) => ConduitParser Event m OpmlHead
-parseOpmlHead = named "OPML <head> section" $ tagName "head" ignoreAttrs $ \_ -> do
- p <- many $ choice piece
- return $ flip fold p $ OpmlHead
- <$> handles _HeadTitle (lastDef mempty)
- <*> handles _HeadCreated last
- <*> handles _HeadModified last
- <*> handles _HeadOwnerName (lastDef mempty)
- <*> handles _HeadOwnerEmail (lastDef mempty)
- <*> handles _HeadOwnerId last
- <*> handles _HeadDocs last
- <*> handles _HeadExpansionState Fold.mconcat
- <*> handles _HeadVertScrollState last
- <*> handles _HeadWindowBottom last
- <*> handles _HeadWindowLeft last
- <*> handles _HeadWindowRight last
- <*> handles _HeadWindowTop last
- where piece = [ HeadCreated <$> dateTag "dateCreated"
- , HeadModified <$> dateTag "dateModified"
- , HeadDocs <$> uriTag "docs"
- , HeadExpansionState <$> expansionStateTag
- , HeadOwnerEmail <$> textTag "ownerEmail"
- , HeadOwnerId <$> uriTag "ownerId"
- , HeadOwnerName <$> textTag "ownerName"
- , HeadTitle <$> textTag "title"
- , HeadVertScrollState <$> decimalTag "vertScrollState"
- , HeadWindowBottom <$> decimalTag "windowBottom"
- , HeadWindowLeft <$> decimalTag "windowLeft"
- , HeadWindowRight <$> decimalTag "windowRight"
- , HeadWindowTop <$> decimalTag "windowTop"
- , HeadUnknown <$ unknownTag
- ]
+parseOpmlHead :: (MonadCatch m) => ConduitM Event o m (Maybe OpmlHead)
+parseOpmlHead = tagIgnoreAttrs "head" $ (manyYield' (choose piece) <* many ignoreAllTreesContent) =$= zipConduit where
+ zipConduit = getZipConduit $ OpmlHead
+ <$> ZipConduit (projectC _HeadTitle =$= headDefC mempty)
+ <*> ZipConduit (projectC _HeadCreated =$= headC)
+ <*> ZipConduit (projectC _HeadModified =$= headC)
+ <*> ZipConduit (projectC _HeadOwnerName =$= headDefC mempty)
+ <*> ZipConduit (projectC _HeadOwnerEmail =$= headDefC mempty)
+ <*> ZipConduit (projectC _HeadOwnerId =$= headC)
+ <*> ZipConduit (projectC _HeadDocs =$= headC)
+ <*> ZipConduit (projectC _HeadExpansionState =$= concatC =$= sinkList)
+ <*> ZipConduit (projectC _HeadVertScrollState =$= headC)
+ <*> ZipConduit (projectC _HeadWindowBottom =$= headC)
+ <*> ZipConduit (projectC _HeadWindowLeft =$= headC)
+ <*> ZipConduit (projectC _HeadWindowRight =$= headC)
+ <*> ZipConduit (projectC _HeadWindowTop =$= headC)
+ piece = [ fmap HeadCreated <$> dateTag "dateCreated"
+ , fmap HeadModified <$> dateTag "dateModified"
+ , fmap HeadDocs <$> uriTag "docs"
+ , fmap HeadExpansionState <$> expansionStateTag
+ , fmap HeadOwnerEmail <$> textTag "ownerEmail"
+ , fmap HeadOwnerId <$> uriTag "ownerId"
+ , fmap HeadOwnerName <$> textTag "ownerName"
+ , fmap HeadTitle <$> textTag "title"
+ , fmap HeadVertScrollState <$> decimalTag "vertScrollState"
+ , fmap HeadWindowBottom <$> decimalTag "windowBottom"
+ , fmap HeadWindowLeft <$> decimalTag "windowLeft"
+ , fmap HeadWindowRight <$> decimalTag "windowRight"
+ , fmap HeadWindowTop <$> decimalTag "windowTop"
+ ]
-- | Parse an @\<outline\>@ section.
-- The value of type attributes are not case-sensitive, that is @type=\"LINK\"@ has the same meaning as @type="link"@.
-parseOpmlOutline :: (MonadCatch m) => ConduitParser Event m (Tree OpmlOutline)
-parseOpmlOutline = tagName "outline" attributes handler <?> "OPML <outline> section" where
+parseOpmlOutline :: (MonadCatch m) => ConduitM Event o m (Maybe (Tree OpmlOutline))
+parseOpmlOutline = tagName "outline" attributes handler where
attributes = do
- otype <- optional $ textAttr "type"
+ otype <- optional $ requireAttr "type"
case mk <$> otype of
Just "include" -> (,,,) otype <$> baseAttr <*> pure Nothing <*> (Just <$> linkAttr) <* ignoreAttrs
Just "link" -> (,,,) otype <$> baseAttr <*> pure Nothing <*> (Just <$> linkAttr) <* ignoreAttrs
Just "rss" -> (,,,) otype <$> baseAttr <*> (Just <$> subscriptionAttr) <*> pure Nothing <* ignoreAttrs
_ -> (,,,) otype <$> baseAttr <*> pure Nothing <*> pure Nothing <* ignoreAttrs
- baseAttr = (,,,,) <$> attr "text" asNonNull
- <*> optional (attr "isComment" asBool)
- <*> optional (attr "isBreakpoint" asBool)
- <*> optional (attr "created" asTime)
- <*> optional (attr "category" (Just . asCategories))
- linkAttr = textAttr "url"
- subscriptionAttr = (,,,,,) <$> attr "xmlUrl" asURI
- <*> optional (attr "htmlUrl" asURI)
- <*> optional (textAttr "description")
- <*> optional (textAttr "language")
- <*> optional (textAttr "title")
- <*> optional (textAttr "version")
+ baseAttr = (,,,,) <$> (requireAttr "text" >>= asNonNull)
+ <*> optional (requireAttr "isComment" >>= asBool)
+ <*> optional (requireAttr "isBreakpoint" >>= asBool)
+ <*> optional (requireAttr "created" >>= asTime)
+ <*> optional (asCategories <$> requireAttr "category")
+ linkAttr = requireAttr "url"
+ subscriptionAttr = (,,,,,) <$> (requireAttr "xmlUrl" >>= asURI)
+ <*> optional (requireAttr "htmlUrl" >>= asURI)
+ <*> optional (requireAttr "description")
+ <*> optional (requireAttr "language")
+ <*> optional (requireAttr "title")
+ <*> optional (requireAttr "version")
handler (_, b, Just s, _) = Node <$> (OpmlOutlineSubscription <$> baseHandler b <*> pure (subscriptionHandler s)) <*> pure []
handler (_, b, _, Just l) = Node <$> (OpmlOutlineLink <$> baseHandler b <*> asURI l) <*> pure []
handler (otype, b, _, _) = Node <$> (OpmlOutlineGeneric <$> baseHandler b <*> pure (fromMaybe mempty otype))
- <*> many parseOpmlOutline
+ <*> (manyYield' parseOpmlOutline =$= sinkList)
baseHandler (txt, comment, breakpoint, created, category) = return $ OutlineBase txt comment breakpoint created (fromMaybe mempty category)
subscriptionHandler (uri, html, desc, lang, title, version) = OutlineSubscription uri html (fromMaybe mempty desc) (fromMaybe mempty lang) (fromMaybe mempty title) (fromMaybe mempty version)
+
+data OpmlDocPiece = DocHead OpmlHead | DocBody [Tree OpmlOutline]
+
+makeTraversals ''OpmlDocPiece
+
+
-- | Parse the top-level @\<opml\>@ element.
-parseOpml :: (MonadCatch m) => ConduitParser Event m Opml
-parseOpml = tagName "opml" attributes handler <?> "<opml> section" where
- attributes = attr "version" asVersion <* ignoreAttrs
- handler version = Opml version
- <$> parseOpmlHead
- <*> tagName "body" ignoreAttrs (const $ many parseOpmlOutline) <?> "<body> section."
+parseOpml :: (MonadCatch m) => ConduitM Event o m (Maybe Opml)
+parseOpml = tagName "opml" attributes handler where
+ attributes = (requireAttr "version" >>= asVersion) <* ignoreAttrs
+ handler version = (manyYield' (choose piece) <* many ignoreAllTreesContent) =$= zipConduit version
+ zipConduit version = getZipConduit $ Opml version
+ <$> ZipConduit (projectC _DocHead =$= headDefC mkOpmlHead)
+ <*> ZipConduit (projectC _DocBody =$= headDefC mempty)
+ parseOpmlBody = tagIgnoreAttrs "body" $ manyYield' parseOpmlOutline =$= sinkList
+ piece = [ fmap DocHead <$> parseOpmlHead
+ , fmap DocBody <$> parseOpmlBody
+ ]
diff --git a/Text/OPML/Conduit/Render.hs b/Text/OPML/Conduit/Render.hs
index 0c6fd45..9786203 100644..100755
--- a/Text/OPML/Conduit/Render.hs
+++ b/Text/OPML/Conduit/Render.hs
@@ -17,6 +17,7 @@ import Data.Conduit
import Data.List.NonEmpty hiding (filter, map)
import Data.Monoid
import Data.NonNull
+import Data.String
import Data.Text (Text, intercalate, pack, toLower)
import Data.Text.Encoding
import Data.Time.Clock
@@ -28,7 +29,8 @@ import Data.XML.Types
import Lens.Simple
-import Prelude hiding (foldr, lookup)
+import Prelude hiding (foldr, lookup, show)
+import qualified Prelude (show)
import Text.OPML.Lens
import Text.OPML.Types
@@ -37,8 +39,8 @@ import Text.XML.Stream.Render
import URI.ByteString
-- }}}
-tshow :: (Show a) => a -> Text
-tshow = pack . show
+show :: (Show a, IsString t) => a -> t
+show = fromString . Prelude.show
empty :: (Eq s, Monoid s) => s -> Bool
empty t = t == mempty
@@ -54,7 +56,7 @@ formatCategories :: [NonEmpty (NonNull Text)] -> Maybe Text
formatCategories = toMaybe . intercalate "," . map (intercalate "/" . toList . fmap toNullable)
formatBool :: Bool -> Text
-formatBool = toLower . tshow
+formatBool = toLower . show
formatURI :: URI -> Text
formatURI = decodeUtf8 . serializeURIRef'
@@ -65,16 +67,16 @@ renderOpmlHead input = tag "head" mempty $ do
forM_ (input^.opmlCreatedL) $ tag "dateCreated" mempty . content . formatTime
forM_ (input^.modifiedL) $ tag "dateModified" mempty . content . formatTime
forM_ (input^.docsL) $ tag "docs" mempty . content . formatURI
- unless (null es) $ tag "expansionState" mempty . content . intercalate "," $ tshow <$> es
+ unless (null es) $ tag "expansionState" mempty . content . intercalate "," $ show <$> es
unless (empty email) $ tag "ownerEmail" mempty $ content email
forM_ (input^.ownerIdL) $ tag "ownerId" mempty . content . formatURI
unless (empty name) $ tag "ownerName" mempty $ content name
unless (empty title) $ tag "title" mempty $ content title
- forM_ (input^.vertScrollStateL) $ tag "vertScrollState" mempty . content . tshow
- forM_ (input^.windowBottomL) $ tag "windowBottom" mempty . content . tshow
- forM_ (input^.windowLeftL) $ tag "windowLeft" mempty . content . tshow
- forM_ (input^.windowRightL) $ tag "windowRight" mempty . content . tshow
- forM_ (input^.windowTopL) $ tag "windowTop" mempty . content . tshow
+ forM_ (input^.vertScrollStateL) $ tag "vertScrollState" mempty . content . show
+ forM_ (input^.windowBottomL) $ tag "windowBottom" mempty . content . show
+ forM_ (input^.windowLeftL) $ tag "windowLeft" mempty . content . show
+ forM_ (input^.windowRightL) $ tag "windowRight" mempty . content . show
+ forM_ (input^.windowTopL) $ tag "windowTop" mempty . content . show
where es = input ^.. expansionStateL
email = input ^. ownerEmailL
name = input ^. ownerNameL
diff --git a/Text/OPML/Lens.hs b/Text/OPML/Lens.hs
index 5236e35..5236e35 100644..100755
--- a/Text/OPML/Lens.hs
+++ b/Text/OPML/Lens.hs
diff --git a/opml-conduit.cabal b/opml-conduit.cabal
index 277fe5b..ce27c7a 100644
--- a/opml-conduit.cabal
+++ b/opml-conduit.cabal
@@ -1,10 +1,10 @@
name: opml-conduit
-version: 0.5.0.1
+version: 0.6.0.0
synopsis: Streaming parser/renderer for the OPML 2.0 format.
description:
This library implements the OPML 2.0 standard (<http://dev.opml.org/spec2.html>) as a 'conduit' parser/renderer.
homepage: https://github.com/k0ral/opml-conduit
-license: OtherLicense
+license: PublicDomain
license-file: LICENSE
author: koral <koral@mailoo.org>
maintainer: koral <koral@mailoo.org>
@@ -34,21 +34,18 @@ library
base >= 4.8 && < 5
, case-insensitive
, conduit
- , conduit-parse
+ , conduit-combinators
, containers
- , exceptions
- , foldl
+ , safe-exceptions
, lens-simple
, monoid-subclasses
, mono-traversable
- , parsers
, semigroups
, text
, time >= 1.5
, timerep >= 2.0.0
, uri-bytestring >= 0.2
, xml-conduit >= 1.3
- , xml-conduit-parse >= 0.2.0.0
, xml-types
default-language: Haskell2010
ghc-options: -Wall -fno-warn-unused-do-bind
@@ -65,10 +62,8 @@ test-suite tests
, bytestring
, conduit
, conduit-combinators
- , conduit-parse
, containers
, data-default
- , exceptions
, hlint
, lens-simple
, mono-traversable
@@ -85,6 +80,6 @@ test-suite tests
, text
, time >= 1.5
, uri-bytestring >= 0.1.9
- , xml-conduit-parse
+ , xml-conduit >= 1.3
default-language: Haskell2010
ghc-options: -Wall -fno-warn-orphans
diff --git a/test/Main.hs b/test/Main.hs
index fbd0ed4..b67f924 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,15 +1,12 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
+-- {{{ Imports
import Arbitrary ()
-import Control.Monad.Catch.Pure
-import Control.Monad.Identity
import Control.Monad.Trans.Resource
import Data.Conduit
import Data.Conduit.Combinators as Conduit (sourceFile)
-import Data.Conduit.Parser
-import Data.Conduit.Parser.XML as XML
import Data.Default
import Data.String
import Data.Text.Encoding
@@ -29,8 +26,10 @@ import Test.Tasty.QuickCheck
import Text.OPML.Conduit.Parse
import Text.OPML.Conduit.Render
import Text.OPML.Lens
+import Text.XML.Stream.Parse as XML
import URI.ByteString
+-- }}}
main :: IO ()
main = defaultMain $ testGroup "Tests"
@@ -65,7 +64,7 @@ hlint = testCase "HLint check" $ do
categoriesCase :: TestTree
categoriesCase = testCase "Parse categories list" $ do
dataFile <- fromString <$> getDataFileName "data/category.opml"
- result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml
+ result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml
(result ^. opmlVersionL) @?= Version [2,0] []
(result ^. opmlHeadL . opmlTitleL) @?= "Illustrating the category attribute"
@@ -77,7 +76,7 @@ categoriesCase = testCase "Parse categories list" $ do
directoryCase :: TestTree
directoryCase = testCase "Parse directory tree" $ do
dataFile <- fromString <$> getDataFileName "data/directory.opml"
- result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml
+ result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml
(result ^. opmlVersionL) @?= Version [2,0] []
(result ^. opmlHeadL . opmlTitleL) @?= "scriptingNewsDirectory.opml"
@@ -98,7 +97,7 @@ directoryCase = testCase "Parse directory tree" $ do
placesCase :: TestTree
placesCase = testCase "Parse places list" $ do
dataFile <- fromString <$> getDataFileName "data/placesLived.opml"
- result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml
+ result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml
(result ^. opmlVersionL) @?= Version [2,0] []
(result ^. opmlHeadL . opmlTitleL) @?= "placesLived.opml"
@@ -120,7 +119,7 @@ placesCase = testCase "Parse places list" $ do
scriptCase :: TestTree
scriptCase = testCase "Parse script" $ do
dataFile <- fromString <$> getDataFileName "data/simpleScript.opml"
- result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml
+ result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml
(result ^. opmlVersionL) @?= Version [2,0] []
(result ^. opmlHeadL . opmlTitleL) @?= "workspace.userlandsamples.doSomeUpstreaming"
@@ -141,7 +140,7 @@ scriptCase = testCase "Parse script" $ do
statesCase :: TestTree
statesCase = testCase "Parse states list" $ do
dataFile <- fromString <$> getDataFileName "data/states.opml"
- result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml
+ result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml
(result ^. opmlVersionL) @?= Version [2,0] []
(result ^. opmlHeadL . opmlTitleL) @?= "states.opml"
@@ -162,7 +161,7 @@ statesCase = testCase "Parse states list" $ do
subscriptionsCase :: TestTree
subscriptionsCase = testCase "Parse subscriptions list" $ do
dataFile <- fromString <$> getDataFileName "data/subscriptionList.opml"
- result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml
+ result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml
(result ^. opmlVersionL) @?= Version [2,0] []
(result ^. opmlHeadL . opmlTitleL) @?= "mySubscriptions.opml"
@@ -178,7 +177,7 @@ subscriptionsCase = testCase "Parse subscriptions list" $ do
length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineSubscription) @?= 13
inverseHeadProperty :: TestTree
-inverseHeadProperty = testProperty "parse . render = id (on OpmlHead)" $ \opmlHead -> either (const False) (opmlHead ==) (runIdentity . runCatchT . runConduit $ renderOpmlHead opmlHead =$= runConduitParser parseOpmlHead)
+inverseHeadProperty = testProperty "parse . render = id (on OpmlHead)" $ \opmlHead -> either (const False) (opmlHead ==) (runConduit $ renderOpmlHead opmlHead =$= force "Invalid <head>" parseOpmlHead)
-- inverseProperty :: TestTree
--- inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= runConduitParser parseOpml)
+-- inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= force "Invalid OPML" parseOpml)