diff --git a/Text/RSS/Conduit/Parse.hs b/Text/RSS/Conduit/Parse.hs --- a/Text/RSS/Conduit/Parse.hs +++ b/Text/RSS/Conduit/Parse.hs @@ -35,7 +35,6 @@ import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.Maybe import Data.Monoid -import Data.MonoTraversable import Data.Set hiding (fold) import Data.Text as Text import Data.Text.Encoding @@ -46,6 +45,7 @@ import Data.XML.Types import Lens.Simple import Prelude hiding (last, lookup) +import Safe import Text.ParserCombinators.ReadP (readP_to_S) import Text.Read (readMaybe) import Text.XML.Stream.Parse @@ -204,7 +204,7 @@ -- | Parse an @\@ element. -- --- RSS extensions are automatically parsed based on the expected result type. +-- RSS extensions are automatically parsed based on the inferred result type. rssItem :: ParseRssExtensions e => MonadThrow m => ConduitM Event o m (Maybe (RssItem e)) rssItem = tagIgnoreAttrs "item" $ (manyYield' (choose piece) =$= parser) <* many ignoreAnyTreeContent where parser = getZipConduit $ RssItem @@ -246,7 +246,7 @@ -- | Parse an @\@ element. -- --- RSS extensions are automatically parsed based on the expected result type. +-- RSS extensions are automatically parsed based on the inferred result type. rssDocument :: ParseRssExtensions e => MonadThrow m => ConduitM Event o m (Maybe (RssDocument e)) rssDocument = tagName' "rss" attributes $ \version -> force "Missing " $ tagIgnoreAttrs "channel" (manyYield' (choose piece) =$= parser version) <* many ignoreAnyTreeContent where parser version = getZipConduit $ RssDocument version diff --git a/Text/RSS/Conduit/Parse/Simple.hs b/Text/RSS/Conduit/Parse/Simple.hs --- a/Text/RSS/Conduit/Parse/Simple.hs +++ b/Text/RSS/Conduit/Parse/Simple.hs @@ -2,7 +2,7 @@ {-# LANGUAGE RankNTypes #-} -- | Streaming parsers for the RSS 2.0 standard. -- --- This module re-exports a monomorphic version of the parsers from 'Text.RSS.Conduit.Parse' that ignores RSS extensions. +-- This module re-exports a monomorphic version of the parsers from "Text.RSS.Conduit.Parse" that ignores RSS extensions. module Text.RSS.Conduit.Parse.Simple ( -- * Top-level rssDocument diff --git a/Text/RSS/Conduit/Render.hs b/Text/RSS/Conduit/Render.hs --- a/Text/RSS/Conduit/Render.hs +++ b/Text/RSS/Conduit/Render.hs @@ -21,11 +21,10 @@ import Text.RSS.Types import Control.Monad - import Data.Conduit import Data.Monoid -import Data.MonoTraversable import Data.Set (Set) +import qualified Data.Set as Set import Data.Text as Text hiding (map) import Data.Text.Encoding import Data.Time.Clock @@ -33,13 +32,9 @@ import Data.Time.RFC822 import Data.Version import Data.XML.Types - import Lens.Simple - import Safe - import Text.XML.Stream.Render - import URI.ByteString -- }}} @@ -153,11 +148,11 @@ -- | Render a @\@ element. renderRssSkipDays :: (Monad m) => Set Day -> Source m Event -renderRssSkipDays s = unless (onull s) $ tag "skipDays" mempty $ forM_ s $ textTag "day" . tshow +renderRssSkipDays s = unless (Set.null s) $ tag "skipDays" mempty $ forM_ s $ textTag "day" . tshow -- | Render a @\@ element. renderRssSkipHours :: (Monad m) => Set Hour -> Source m Event -renderRssSkipHours s = unless (onull s) $ tag "skipHour" mempty $ forM_ s $ textTag "hour" . tshow +renderRssSkipHours s = unless (Set.null s) $ tag "skipHour" mempty $ forM_ s $ textTag "hour" . tshow -- {{{ Utils @@ -167,8 +162,8 @@ textTag :: (Monad m) => Name -> Text -> Source m Event textTag name = tag name mempty . content -optionalTextTag :: (Monad m) => Name -> Text -> Source m Event -optionalTextTag name value = unless (onull value) $ textTag name value +optionalTextTag :: Monad m => Name -> Text -> Source m Event +optionalTextTag name value = unless (Text.null value) $ textTag name value dateTag :: (Monad m) => Name -> UTCTime -> Source m Event dateTag name = tag name mempty . content . formatTimeRFC822 . utcToZonedTime utc diff --git a/Text/RSS/Extensions/Atom.hs b/Text/RSS/Extensions/Atom.hs --- a/Text/RSS/Extensions/Atom.hs +++ b/Text/RSS/Extensions/Atom.hs @@ -30,5 +30,7 @@ parseRssChannelExtension = AtomChannel <$> (manyYield' atomLink =$= headC) parseRssItemExtension = AtomItem <$> (manyYield' atomLink =$= headC) -data instance RssChannelExtension AtomModule = AtomChannel (Maybe AtomLink) deriving(Eq, Generic, Show) -data instance RssItemExtension AtomModule = AtomItem (Maybe AtomLink) deriving(Eq, Generic, Show) +data instance RssChannelExtension AtomModule = AtomChannel { channelAtomLink :: Maybe AtomLink } + deriving(Eq, Generic, Show) +data instance RssItemExtension AtomModule = AtomItem { itemAtomLink :: Maybe AtomLink } + deriving(Eq, Generic, Show) diff --git a/Text/RSS/Extensions/Content.hs b/Text/RSS/Extensions/Content.hs --- a/Text/RSS/Extensions/Content.hs +++ b/Text/RSS/Extensions/Content.hs @@ -48,7 +48,8 @@ data instance RssChannelExtension ContentModule = ContentChannel deriving(Eq, Generic, Ord, Show) -data instance RssItemExtension ContentModule = ContentItem Text deriving(Eq, Generic, Ord, Show) +data instance RssItemExtension ContentModule = ContentItem { itemContent :: Text } + deriving(Eq, Generic, Ord, Show) -- | XML prefix is @content@. diff --git a/Text/RSS/Extensions/DublinCore.hs b/Text/RSS/Extensions/DublinCore.hs --- a/Text/RSS/Extensions/DublinCore.hs +++ b/Text/RSS/Extensions/DublinCore.hs @@ -10,7 +10,9 @@ module Text.RSS.Extensions.DublinCore ( DublinCoreModule(..) , RssChannelExtension(DublinCoreChannel) + , channelDcMetaData , RssItemExtension(DublinCoreItem) + , itemDcMetaData , DcMetaData(..) , mkDcMetaData ) where @@ -126,5 +128,7 @@ parseRssItemExtension = DublinCoreItem <$> dcMetadata -data instance RssChannelExtension DublinCoreModule = DublinCoreChannel DcMetaData deriving(Eq, Generic, Ord, Show) -data instance RssItemExtension DublinCoreModule = DublinCoreItem DcMetaData deriving(Eq, Generic, Ord, Show) +data instance RssChannelExtension DublinCoreModule = DublinCoreChannel { channelDcMetaData :: DcMetaData } + deriving(Eq, Generic, Ord, Show) +data instance RssItemExtension DublinCoreModule = DublinCoreItem { itemDcMetaData :: DcMetaData } + deriving(Eq, Generic, Ord, Show) diff --git a/Text/RSS/Extensions/Syndication.hs b/Text/RSS/Extensions/Syndication.hs --- a/Text/RSS/Extensions/Syndication.hs +++ b/Text/RSS/Extensions/Syndication.hs @@ -150,5 +150,6 @@ parseRssItemExtension = pure SyndicationItem -data instance RssChannelExtension SyndicationModule = SyndicationChannel SyndicationInfo deriving(Eq, Generic, Ord, Show) +data instance RssChannelExtension SyndicationModule = SyndicationChannel { channelSyndicationInfo :: SyndicationInfo} + deriving(Eq, Generic, Ord, Show) data instance RssItemExtension SyndicationModule = SyndicationItem deriving(Eq, Generic, Ord, Show) diff --git a/Text/RSS/Lens.hs b/Text/RSS/Lens.hs --- a/Text/RSS/Lens.hs +++ b/Text/RSS/Lens.hs @@ -1,11 +1,14 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} module Text.RSS.Lens (module Text.RSS.Lens) where -- {{{ Imports -import Lens.Simple - import Text.RSS.Types +import Data.Singletons.Prelude +import Data.Vinyl.Lens +import Data.Vinyl.TypeLevel +import Lens.Simple import URI.ByteString -- }}} @@ -29,6 +32,11 @@ itemEnclosureL inj a@RssItem { itemEnclosure = e } = (\x -> a { itemEnclosure = e }) <$> traverse inj e {-# INLINE itemEnclosureL #-} +itemExtensionL :: SingI a => RElem a e (RIndex a e) => Lens' (RssItem e) (RssItemExtension a) +itemExtensionL = itemExtensionsL . f . rlens sing where + f inj (RssItemExtensions a) = RssItemExtensions <$> inj a +{-# INLINE itemExtensionL #-} + $(makeLensesBy (\n -> Just (n ++ "L")) ''RssTextInput) $(makeLensesBy (\n -> Just (n ++ "L")) ''RssCloud) $(makeLensesBy (\n -> Just (n ++ "L")) ''RssImage) @@ -46,3 +54,8 @@ channelCategoriesL :: Traversal' (RssDocument e) RssCategory channelCategoriesL inj a@RssDocument { channelCategories = c } = (\x -> a { channelCategories = c }) <$> traverse inj c {-# INLINE channelCategoriesL #-} + +channelExtensionL :: SingI a => RElem a e (RIndex a e) => Lens' (RssDocument e) (RssChannelExtension a) +channelExtensionL = channelExtensionsL . f . rlens sing where + f inj (RssChannelExtensions a) = RssChannelExtensions <$> inj a +{-# INLINE channelExtensionL #-} diff --git a/Text/RSS/Types.hs b/Text/RSS/Types.hs --- a/Text/RSS/Types.hs +++ b/Text/RSS/Types.hs @@ -288,7 +288,7 @@ -- > data instance RssChannelExtension MyExtension = MyExtensionChannel { {- ... fields -} } -- > data instance RssItemExtension MyExtension = MyExtensionItem { {- ... fields -} } -- --- - Implement corresponding parsers (cf 'Text.RSS.Extensions'). +-- - Implement corresponding parsers (cf "Text.RSS.Extensions"). -- | @\@ extension type. data family RssChannelExtension extensionTag :: * diff --git a/Text/RSS1/Conduit/Parse.hs b/Text/RSS1/Conduit/Parse.hs --- a/Text/RSS1/Conduit/Parse.hs +++ b/Text/RSS1/Conduit/Parse.hs @@ -120,7 +120,7 @@ -- | Parse an @\@ element. -- --- RSS extensions are automatically parsed based on the expected result type. +-- RSS extensions are automatically parsed based on the inferred result type. rss1Item :: ParseRssExtensions e => MonadCatch m => ConduitM Event o m (Maybe (RssItem e)) rss1Item = rss1Tag "item" attributes $ \uri -> (manyYield' (choose piece) =$= parser uri) <* many ignoreAnyTreeContent where parser uri = getZipConduit $ RssItem @@ -196,7 +196,7 @@ -- | Parse a @\@ element. -- --- RSS extensions are automatically parsed based on the expected result type. +-- RSS extensions are automatically parsed based on the inferred result type. rss1Channel :: ParseRssExtensions e => MonadThrow m => ConduitM Event o m (Maybe (Rss1Channel e)) rss1Channel = rss1Tag "channel" attributes $ \channelId -> (manyYield' (choose piece) =$= parser channelId) <* many ignoreAnyTreeContent where parser channelId = getZipConduit $ Rss1Channel channelId @@ -255,7 +255,7 @@ -- | Parse an @\@ element. -- --- RSS extensions are automatically parsed based on the expected result type. +-- RSS extensions are automatically parsed based on the inferred result type. rss1Document :: ParseRssExtensions e => MonadCatch m => ConduitM Event o m (Maybe (RssDocument e)) rss1Document = fmap (fmap rss1ToRss2) $ rdfTag "RDF" ignoreAttrs $ const $ (manyYield' (choose piece) =$= parser) <* many ignoreAnyTreeContent where parser = getZipConduit $ Rss1Document diff --git a/rss-conduit.cabal b/rss-conduit.cabal --- a/rss-conduit.cabal +++ b/rss-conduit.cabal @@ -1,86 +1,89 @@ -name: rss-conduit -version: 0.4.0.0 -synopsis: Streaming parser/renderer for the RSS standard. -description: Cf README file. -license: PublicDomain -license-file: LICENSE -author: koral -maintainer: koral att mailoo dott org -category: XML, Conduit -build-type: Simple -extra-source-files: README.md -cabal-version: >=1.10 +name: rss-conduit +version: 0.4.1.0 +cabal-version: >=1.10 +build-type: Simple +license: PublicDomain +license-file: LICENSE +maintainer: koral att mailoo dott org +synopsis: Streaming parser/renderer for the RSS standard. +description: + Cf README file. +category: XML, Conduit +author: koral +extra-source-files: + README.md source-repository head - type: git - location: git://github.com/k0ral/rss-conduit.git + type: git + location: git://github.com/k0ral/rss-conduit.git library - exposed-modules: - Text.RSS1.Conduit.Parse - Text.RSS.Conduit.Parse - Text.RSS.Conduit.Parse.Simple - Text.RSS.Conduit.Render - Text.RSS.Extensions - Text.RSS.Extensions.Atom - Text.RSS.Extensions.Content - Text.RSS.Extensions.DublinCore - Text.RSS.Extensions.Syndication - Text.RSS.Lens - Text.RSS.Types - -- other-modules: - build-depends: - atom-conduit - , base >= 4.8 && < 5 - , conduit - , conduit-combinators - , containers - , dublincore-xml-conduit - , safe-exceptions - , lens-simple - , mono-traversable - , safe - , singletons - , text - , time >= 1.5 - , timerep >= 2.0 - , uri-bytestring >= 0.2 - , vinyl - , xml-conduit >= 1.5 - , xml-types - if impl(ghc < 8) - build-depends: semigroups - default-language: Haskell2010 -test-suite Tests - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - other-modules: Arbitrary - build-depends: - rss-conduit - , atom-conduit - , base >= 4.8 && < 5 - , bytestring - , conduit - , conduit-combinators - , data-default - , dublincore-xml-conduit - , hlint - , lens-simple - , mono-traversable - , QuickCheck - , quickcheck-instances - , resourcet - , safe-exceptions - , singletons - , tasty - , tasty-hunit - , tasty-quickcheck - , time >= 1.5 - , text - , uri-bytestring >= 0.2 - , vinyl - , xml-conduit >= 1.3 - , xml-types - default-language: Haskell2010 + if impl(ghc <8) + build-depends: + semigroups -any + exposed-modules: + Text.RSS1.Conduit.Parse + Text.RSS.Conduit.Parse + Text.RSS.Conduit.Parse.Simple + Text.RSS.Conduit.Render + Text.RSS.Extensions + Text.RSS.Extensions.Atom + Text.RSS.Extensions.Content + Text.RSS.Extensions.DublinCore + Text.RSS.Extensions.Syndication + Text.RSS.Lens + Text.RSS.Types + build-depends: + atom-conduit -any, + base >=4.8 && <5, + conduit -any, + conduit-combinators -any, + containers -any, + dublincore-xml-conduit -any, + safe-exceptions -any, + lens-simple -any, + safe -any, + singletons -any, + text -any, + time >=1.5, + timerep >=2.0, + uri-bytestring >=0.2, + vinyl -any, + xml-conduit >=1.5, + xml-types -any + default-language: Haskell2010 + +test-suite Tests + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: + rss-conduit -any, + atom-conduit -any, + base >=4.8 && <5, + bytestring -any, + conduit -any, + conduit-combinators -any, + data-default -any, + dublincore-xml-conduit -any, + hlint -any, + lens-simple -any, + mono-traversable -any, + QuickCheck -any, + quickcheck-instances -any, + resourcet -any, + safe-exceptions -any, + singletons -any, + tasty -any, + tasty-hunit -any, + tasty-quickcheck -any, + time >=1.5, + text -any, + uri-bytestring >=0.2, + vinyl -any, + xml-conduit >=1.3, + xml-types -any + default-language: Haskell2010 + hs-source-dirs: test + other-modules: + Arbitrary