diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +#### 1.0.1.0 + +* Support for GHC 8.6.x libraries + +* Add `textFeed` and `textRSS` helpers (thanks to Francesco Ariis) + # 1.0.0.0 * Thanks to Dmitry Dzhus feed has been modernized to use the `text`, diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,159 @@ +# Feed + +[![feed](https://img.shields.io/hackage/v/feed.svg)](http://hackage.haskell.org/package/feed) +[![Build Status](https://travis-ci.org/bergmark/feed.svg?branch=master)](https://travis-ci.org/bergmark/feed) + +## Goal + +Interfacing with *RSS* (v 0.9x, 2.x, 1.0) + *Atom* feeds. + +- Parsers +- Pretty Printers +- Querying + +To help working with the multiple feed formats we've ended up with +this set of modules providing parsers, pretty printers and some utility +code for querying and just generally working with a concrete +representation of feeds in Haskell. + +For basic reading and editing of feeds, consult the documentation of +the Text.Feed.* hierarchy. + +## Usage + +Building an Atom feed is similar to building an RSS feed, but we'll +arbitrarily pick Atom here: + +We'd like to generate the XML for a minimal working example. +Constructing our base `Feed` can use the smart constructor called `nullFeed`: + +*This is a pattern the library maintains for smart constructors. If you want the +minimum viable 'X', use the 'nullX' constructor.* + + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Prelude.Compat hiding (take) + +import Data.Text +import Data.XML.Types as XML +import qualified Data.Text.Lazy as Lazy +import qualified Text.Atom.Feed as Atom +import qualified Text.Atom.Feed.Export as Export (textFeed) + +myFeed :: Atom.Feed +myFeed = Atom.nullFeed + "http://example.com/atom.xml" -- ^ id + (Atom.TextString "Example Website") -- ^ title + "2017-08-01" -- ^ last updated +``` + +Now we can export the feed to `Text`. + +```haskell +renderFeed :: Atom.Feed -> Maybe Lazy.Text +renderFeed = Export.textFeed +``` + +``` +> renderFeed myFeed + + + Example Website + http://example.com/atom.xml + 2017-08-01 + +``` + +The `TextContent` sum type allows us to specify which type of text we're providing. + +```haskell +data TextContent + = TextString Text + | HTMLString Text + | XHTMLString XML.Element + deriving (Show) +``` + +A feed isn't very useful without some content though, so we'll need to build up an `Entry`. + +```haskell +data Post + = Post + { _postedOn :: Text + , _url :: Text + , _content :: Text + } + +examplePosts :: [Post] +examplePosts = + [ Post "2000-02-02T18:30:00Z" "http://example.com/2" "Bar." + , Post "2000-01-01T18:30:00Z" "http://example.com/1" "Foo." + ] +``` + +Our `Post` data type will need to be converted into an `Entry` in order to use it in the top level `Feed`. The required fields for an entry are an url "id" from which an entry's presence can be validated, a title for the entry, and a posting date. In this example we'll also add authors, link, and the entries actual content, since we have all of this available in the `Post` provided. + +```haskell +toEntry :: Post -> Atom.Entry +toEntry (Post date url content) = + (Atom.nullEntry + url -- The ID field. Must be a link to validate. + (Atom.TextString (take 20 content)) -- Title + date) + { Atom.entryAuthors = [Atom.nullPerson {Atom.personName = "J. Smith"}] + , Atom.entryLinks = [Atom.nullLink url] + , Atom.entryContent = Just (Atom.HTMLContent content) + } +``` + +From the base feed we created earlier, we can add further details (`Link` and `Entry` content) as well as map our `toEntry` function over the posts we'd like to include in the feed. + +```haskell +feed :: Atom.Feed +feed = + myFeed { Atom.feedEntries = fmap toEntry examplePosts + , Atom.feedLinks = [Atom.nullLink "http://example.com/"] + } +``` + +``` +> renderFeed feed + + + Example Website + http://example.com/atom.xml + 2017-08-01 + + + http://example.com/2 + Bar. + 2000-02-02T18:30:00Z + + J. Smith + + Bar. + + + + http://example.com/1 + Foo. + 2000-01-01T18:30:00Z + + J. Smith + + Foo. + + + +``` +See [here](https://github.com/bergmark/feed/blob/master/tests/Example/CreateAtom.hs) for this content as an uninterrupted running example. + +```haskell +-- Dummy main needed to compile this file with markdown-unlit +main :: IO () +main = return () +``` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,15 +1,159 @@ -[![feed](https://img.shields.io/hackage/v/feed.svg)](https://hackage.haskell.org/package/feed) +# Feed + +[![feed](https://img.shields.io/hackage/v/feed.svg)](http://hackage.haskell.org/package/feed) [![Build Status](https://travis-ci.org/bergmark/feed.svg?branch=master)](https://travis-ci.org/bergmark/feed) -Interfacing with RSS (v 0.9x, 2.x, 1.0) + Atom feeds. +## Goal -To help working with the multiple feed formats we've ended up with, -this set of modules provides parsers, pretty printers and some utility +Interfacing with *RSS* (v 0.9x, 2.x, 1.0) + *Atom* feeds. + +- Parsers +- Pretty Printers +- Querying + +To help working with the multiple feed formats we've ended up with +this set of modules providing parsers, pretty printers and some utility code for querying and just generally working with a concrete representation of feeds in Haskell. -See [here](https://github.com/bergmark/feed/blob/master/tests/Example/CreateAtom.hs) for an example -of how to create an Atom feed. - For basic reading and editing of feeds, consult the documentation of the Text.Feed.* hierarchy. + +## Usage + +Building an Atom feed is similar to building an RSS feed, but we'll +arbitrarily pick Atom here: + +We'd like to generate the XML for a minimal working example. +Constructing our base `Feed` can use the smart constructor called `nullFeed`: + +*This is a pattern the library maintains for smart constructors. If you want the +minimum viable 'X', use the 'nullX' constructor.* + + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Prelude.Compat hiding (take) + +import Data.Text +import Data.XML.Types as XML +import qualified Data.Text.Lazy as Lazy +import qualified Text.Atom.Feed as Atom +import qualified Text.Atom.Feed.Export as Export (textFeed) + +myFeed :: Atom.Feed +myFeed = Atom.nullFeed + "http://example.com/atom.xml" -- ^ id + (Atom.TextString "Example Website") -- ^ title + "2017-08-01" -- ^ last updated +``` + +Now we can export the feed to `Text`. + +```haskell +renderFeed :: Atom.Feed -> Maybe Lazy.Text +renderFeed = Export.textFeed +``` + +``` +> renderFeed myFeed + + + Example Website + http://example.com/atom.xml + 2017-08-01 + +``` + +The `TextContent` sum type allows us to specify which type of text we're providing. + +```haskell +data TextContent + = TextString Text + | HTMLString Text + | XHTMLString XML.Element + deriving (Show) +``` + +A feed isn't very useful without some content though, so we'll need to build up an `Entry`. + +```haskell +data Post + = Post + { _postedOn :: Text + , _url :: Text + , _content :: Text + } + +examplePosts :: [Post] +examplePosts = + [ Post "2000-02-02T18:30:00Z" "http://example.com/2" "Bar." + , Post "2000-01-01T18:30:00Z" "http://example.com/1" "Foo." + ] +``` + +Our `Post` data type will need to be converted into an `Entry` in order to use it in the top level `Feed`. The required fields for an entry are an url "id" from which an entry's presence can be validated, a title for the entry, and a posting date. In this example we'll also add authors, link, and the entries actual content, since we have all of this available in the `Post` provided. + +```haskell +toEntry :: Post -> Atom.Entry +toEntry (Post date url content) = + (Atom.nullEntry + url -- The ID field. Must be a link to validate. + (Atom.TextString (take 20 content)) -- Title + date) + { Atom.entryAuthors = [Atom.nullPerson {Atom.personName = "J. Smith"}] + , Atom.entryLinks = [Atom.nullLink url] + , Atom.entryContent = Just (Atom.HTMLContent content) + } +``` + +From the base feed we created earlier, we can add further details (`Link` and `Entry` content) as well as map our `toEntry` function over the posts we'd like to include in the feed. + +```haskell +feed :: Atom.Feed +feed = + myFeed { Atom.feedEntries = fmap toEntry examplePosts + , Atom.feedLinks = [Atom.nullLink "http://example.com/"] + } +``` + +``` +> renderFeed feed + + + Example Website + http://example.com/atom.xml + 2017-08-01 + + + http://example.com/2 + Bar. + 2000-02-02T18:30:00Z + + J. Smith + + Bar. + + + + http://example.com/1 + Foo. + 2000-01-01T18:30:00Z + + J. Smith + + Foo. + + + +``` +See [here](https://github.com/bergmark/feed/blob/master/tests/Example/CreateAtom.hs) for this content as an uninterrupted running example. + +```haskell +-- Dummy main needed to compile this file with markdown-unlit +main :: IO () +main = return () +``` diff --git a/feed.cabal b/feed.cabal --- a/feed.cabal +++ b/feed.cabal @@ -1,5 +1,5 @@ name: feed -version: 1.0.0.0 +version: 1.0.1.0 license: BSD3 license-file: LICENSE category: Text @@ -30,6 +30,8 @@ , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.1 + , GHC == 8.4.1 + , GHC == 8.6.1 data-files: tests/files/*.xml extra-source-files: @@ -43,7 +45,9 @@ library ghc-options: -Wall hs-source-dirs: src - extensions: OverloadedStrings + extensions: + NoImplicitPrelude + OverloadedStrings exposed-modules: Text.Atom.Feed Text.Atom.Feed.Export @@ -71,8 +75,8 @@ Data.Text.Util Data.XML.Compat build-depends: - base >= 4 && < 4.11 - , base-compat == 0.9.* + base >= 4 && < 4.13 + , base-compat >= 0.9 && < 0.11 , bytestring >= 0.9 && < 0.11 , old-locale == 1.0.* , old-time >= 1 && < 1.2 @@ -82,14 +86,16 @@ , time-locale-compat == 0.1.* , utf8-string < 1.1 , xml-types >= 0.3.6 && < 0.4 - , xml-conduit >= 1.3 && < 1.6 + , xml-conduit >= 1.3 && < 1.9 test-suite tests ghc-options: -Wall hs-source-dirs: tests main-is: Main.hs type: exitcode-stdio-1.0 - extensions: OverloadedStrings + extensions: + NoImplicitPrelude + OverloadedStrings other-modules: Paths_feed Example @@ -102,17 +108,32 @@ Text.RSS.Tests Text.RSS.Utils build-depends: - base >= 4 && < 4.11 + base >= 4 && < 4.13 + , base-compat >= 0.9 && < 0.11 , HUnit >= 1.2 && < 1.7 - , base-compat == 0.9.* , feed - , old-locale == 1.0.* , old-time >= 1 && < 1.2 , test-framework == 0.8.* , test-framework-hunit == 0.3.* , text < 1.3 , time < 1.9 - , time-locale-compat == 0.1.* - , utf8-string < 1.1 , xml-types >= 0.3.6 && < 0.4 - , xml-conduit >= 1.3 && < 1.6 + , xml-conduit >= 1.3 && < 1.9 + +test-suite readme + ghc-options: -Wall -pgmL markdown-unlit + main-is: README.lhs + extensions: + NoImplicitPrelude + OverloadedStrings + type: exitcode-stdio-1.0 + build-depends: + base >= 4 && < 4.13 + , base-compat >= 0.9 && < 0.11 + , text + , xml-types + , feed + , xml-conduit + , xml-types + build-tool-depends: + markdown-unlit:markdown-unlit == 0.4.* diff --git a/src/Data/Text/Util.hs b/src/Data/Text/Util.hs --- a/src/Data/Text/Util.hs +++ b/src/Data/Text/Util.hs @@ -1,12 +1,32 @@ module Data.Text.Util ( readInt + , renderFeed ) where +import Prelude.Compat + import Data.Text import Data.Text.Read +import qualified Data.XML.Types as XT -- from xml-types +import qualified Text.XML as XC -- from xml-conduit +import qualified Data.Text.Lazy as TL + readInt :: Text -> Maybe Integer readInt s = case decimal s of Right (x, _) -> Just x _ -> Nothing + +renderFeed :: (a -> XT.Element) -> a -> Maybe TL.Text +renderFeed cf f = let e = cf f + d = elToDoc e + in XC.renderText XC.def <$> d + + +-- Ancillaries -- + +elToDoc :: XT.Element -> Maybe XC.Document +elToDoc el = let txd = XT.Document (XC.Prologue [] Nothing []) el [] + cxd = XC.fromXMLDocument txd + in either (const Nothing) Just cxd diff --git a/src/Data/XML/Compat.hs b/src/Data/XML/Compat.hs --- a/src/Data/XML/Compat.hs +++ b/src/Data/XML/Compat.hs @@ -3,7 +3,6 @@ -- | Compatibility interface between `xml` and `xml-types`. module Data.XML.Compat where -import Prelude () import Prelude.Compat import Data.Text (Text) diff --git a/src/Text/Atom/Feed.hs b/src/Text/Atom/Feed.hs --- a/src/Text/Atom/Feed.hs +++ b/src/Text/Atom/Feed.hs @@ -37,7 +37,6 @@ , nullPerson ) where -import Prelude () import Prelude.Compat import Data.Text (Text, unpack) @@ -187,22 +186,22 @@ -> Feed nullFeed i t u = Feed - { feedId = i - , feedTitle = t - , feedUpdated = u - , feedAuthors = [] - , feedCategories = [] - , feedContributors = [] - , feedGenerator = Nothing - , feedIcon = Nothing - , feedLinks = [] - , feedLogo = Nothing - , feedRights = Nothing - , feedSubtitle = Nothing - , feedEntries = [] - , feedAttrs = [] - , feedOther = [] - } + { feedId = i + , feedTitle = t + , feedUpdated = u + , feedAuthors = [] + , feedCategories = [] + , feedContributors = [] + , feedGenerator = Nothing + , feedIcon = Nothing + , feedLinks = [] + , feedLogo = Nothing + , feedRights = Nothing + , feedSubtitle = Nothing + , feedEntries = [] + , feedAttrs = [] + , feedOther = [] + } nullEntry :: URI -- ^entryId @@ -211,23 +210,23 @@ -> Entry nullEntry i t u = Entry - { entryId = i - , entryTitle = t - , entryUpdated = u - , entryAuthors = [] - , entryCategories = [] - , entryContent = Nothing - , entryContributor = [] - , entryLinks = [] - , entryPublished = Nothing - , entryRights = Nothing - , entrySource = Nothing - , entrySummary = Nothing - , entryInReplyTo = Nothing - , entryInReplyTotal = Nothing - , entryAttrs = [] - , entryOther = [] - } + { entryId = i + , entryTitle = t + , entryUpdated = u + , entryAuthors = [] + , entryCategories = [] + , entryContent = Nothing + , entryContributor = [] + , entryLinks = [] + , entryPublished = Nothing + , entryRights = Nothing + , entrySource = Nothing + , entrySummary = Nothing + , entryInReplyTo = Nothing + , entryInReplyTotal = Nothing + , entryAttrs = [] + , entryOther = [] + } nullGenerator :: Text -- ^genText @@ -239,32 +238,32 @@ -> Link nullLink uri = Link - { linkHref = uri - , linkRel = Nothing - , linkType = Nothing - , linkHrefLang = Nothing - , linkTitle = Nothing - , linkLength = Nothing - , linkAttrs = [] - , linkOther = [] - } + { linkHref = uri + , linkRel = Nothing + , linkType = Nothing + , linkHrefLang = Nothing + , linkTitle = Nothing + , linkLength = Nothing + , linkAttrs = [] + , linkOther = [] + } nullSource :: Source nullSource = Source - { sourceAuthors = [] - , sourceCategories = [] - , sourceGenerator = Nothing - , sourceIcon = Nothing - , sourceId = Nothing - , sourceLinks = [] - , sourceLogo = Nothing - , sourceRights = Nothing - , sourceSubtitle = Nothing - , sourceTitle = Nothing - , sourceUpdated = Nothing - , sourceOther = [] - } + { sourceAuthors = [] + , sourceCategories = [] + , sourceGenerator = Nothing + , sourceIcon = Nothing + , sourceId = Nothing + , sourceLinks = [] + , sourceLogo = Nothing + , sourceRights = Nothing + , sourceSubtitle = Nothing + , sourceTitle = Nothing + , sourceUpdated = Nothing + , sourceOther = [] + } nullPerson :: Person nullPerson = Person {personName = "", personURI = Nothing, personEmail = Nothing, personOther = []} diff --git a/src/Text/Atom/Feed/Export.hs b/src/Text/Atom/Feed/Export.hs --- a/src/Text/Atom/Feed/Export.hs +++ b/src/Text/Atom/Feed/Export.hs @@ -29,6 +29,7 @@ , atomThreadNode , atomThreadLeaf , xmlFeed + , textFeed , xmlEntry , xmlContent , xmlCategory @@ -53,12 +54,13 @@ , mb ) where -import Prelude () import Prelude.Compat import Data.Text (Text, pack) import Data.XML.Types as XML import Text.Atom.Feed +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Util as U atom_prefix :: Maybe Text atom_prefix = Nothing -- Just "atom" @@ -83,10 +85,10 @@ Nothing -> Name {nameLocalName = "xmlns", nameNamespace = Nothing, namePrefix = Nothing} Just s -> Name - { nameLocalName = s - , nameNamespace = Nothing -- XXX: is this ok? - , namePrefix = Just "xmlns" - } + { nameLocalName = s + , nameNamespace = Nothing -- XXX: is this ok? + , namePrefix = Just "xmlns" + } xmlns_atom_thread :: Attr xmlns_atom_thread = (qn, [ContentText atomThreadNS]) @@ -96,10 +98,10 @@ Nothing -> Name {nameLocalName = "xmlns", nameNamespace = Nothing, namePrefix = Nothing} Just s -> Name - { nameLocalName = s - , nameNamespace = Nothing -- XXX: is this ok? - , namePrefix = Just "xmlns" - } + { nameLocalName = s + , nameNamespace = Nothing -- XXX: is this ok? + , namePrefix = Just "xmlns" + } atomName :: Text -> Name atomName nc = Name {nameLocalName = nc, nameNamespace = Just atomNS, namePrefix = atom_prefix} @@ -143,8 +145,11 @@ mb xmlLogo (feedLogo f) ++ mb xmlRights (feedRights f) ++ mb xmlSubtitle (feedSubtitle f) ++ map xmlEntry (feedEntries f) ++ feedOther f) - {elementAttributes = [xmlns_atom]} + {elementAttributes = [xmlns_atom]} +textFeed :: Feed -> Maybe TL.Text +textFeed = U.renderFeed xmlFeed + xmlEntry :: Entry -> XML.Element xmlEntry e = (atomNode "entry" $ @@ -162,7 +167,7 @@ mb xmlSource (entrySource e) ++ mb xmlSummary (entrySummary e) ++ mb xmlInReplyTo (entryInReplyTo e) ++ mb xmlInReplyTotal (entryInReplyTotal e) ++ entryOther e) - {elementAttributes = entryAttrs e} + {elementAttributes = entryAttrs e} xmlContent :: EntryContent -> XML.Element xmlContent cont = @@ -178,21 +183,21 @@ xmlCategory :: Category -> XML.Element xmlCategory c = (atomNode "category" (map NodeElement (catOther c))) - { elementAttributes = - [atomAttr "term" (catTerm c)] ++ - mb (atomAttr "scheme") (catScheme c) ++ mb (atomAttr "label") (catLabel c) - } + { elementAttributes = + [atomAttr "term" (catTerm c)] ++ + mb (atomAttr "scheme") (catScheme c) ++ mb (atomAttr "label") (catLabel c) + } xmlLink :: Link -> XML.Element xmlLink l = (atomNode "link" (map NodeElement (linkOther l))) - { elementAttributes = - [atomAttr "href" (linkHref l)] ++ - mb (atomAttr "rel" . either id id) (linkRel l) ++ - mb (atomAttr "type") (linkType l) ++ - mb (atomAttr "hreflang") (linkHrefLang l) ++ - mb (atomAttr "title") (linkTitle l) ++ mb (atomAttr "length") (linkLength l) ++ linkAttrs l - } + { elementAttributes = + [atomAttr "href" (linkHref l)] ++ + mb (atomAttr "rel" . either id id) (linkRel l) ++ + mb (atomAttr "type") (linkType l) ++ + mb (atomAttr "hreflang") (linkHrefLang l) ++ + mb (atomAttr "title") (linkTitle l) ++ mb (atomAttr "length") (linkLength l) ++ linkAttrs l + } xmlSource :: Source -> Element xmlSource s = @@ -213,7 +218,7 @@ xmlGenerator :: Generator -> Element xmlGenerator g = (atomLeaf "generator" (genText g)) - {elementAttributes = mb (atomAttr "uri") (genURI g) ++ mb (atomAttr "version") (genVersion g)} + {elementAttributes = mb (atomAttr "uri") (genURI g) ++ mb (atomAttr "version") (genVersion g)} xmlAuthor :: Person -> XML.Element xmlAuthor p = atomNode "author" (xmlPerson p) @@ -230,17 +235,17 @@ xmlInReplyTo :: InReplyTo -> XML.Element xmlInReplyTo irt = (atomThreadNode "in-reply-to" (replyToContent irt)) - { elementAttributes = - mb (atomThreadAttr "ref") (Just $ replyToRef irt) ++ - mb (atomThreadAttr "href") (replyToHRef irt) ++ - mb (atomThreadAttr "type") (replyToType irt) ++ - mb (atomThreadAttr "source") (replyToSource irt) ++ replyToOther irt - } + { elementAttributes = + mb (atomThreadAttr "ref") (Just $ replyToRef irt) ++ + mb (atomThreadAttr "href") (replyToHRef irt) ++ + mb (atomThreadAttr "type") (replyToType irt) ++ + mb (atomThreadAttr "source") (replyToSource irt) ++ replyToOther irt + } xmlInReplyTotal :: InReplyTotal -> XML.Element xmlInReplyTotal irt = (atomThreadLeaf "total" (pack $ show $ replyToTotal irt)) - {elementAttributes = replyToTotalOther irt} + {elementAttributes = replyToTotalOther irt} xmlId :: Text -> XML.Element xmlId = atomLeaf "id" diff --git a/src/Text/Atom/Feed/Import.hs b/src/Text/Atom/Feed/Import.hs --- a/src/Text/Atom/Feed/Import.hs +++ b/src/Text/Atom/Feed/Import.hs @@ -38,12 +38,11 @@ , pInReplyTo ) where -import Prelude () import Prelude.Compat -import Control.Monad (guard, mplus) -import Data.List (find) -import Data.Maybe (isJust, listToMaybe, mapMaybe) +import Control.Monad.Compat (guard, mplus) +import Data.List.Compat (find) +import Data.Maybe (isNothing, listToMaybe, mapMaybe) import Data.Text (Text) import Data.Text.Read import Data.XML.Types as XML @@ -75,7 +74,7 @@ pAttr x e = (`attributeText` e) =<< fst <$> find sameAttr (elementAttributes e) where ax = atomName x - sameAttr (k, _) = k == ax || (not (isJust (nameNamespace k)) && nameLocalName k == x) + sameAttr (k, _) = k == ax || (isNothing (nameNamespace k) && nameLocalName k == x) pAttrs :: Text -> XML.Element -> [Text] pAttrs x e = [t | ContentText t <- cnts] @@ -103,25 +102,25 @@ u <- pLeaf "updated" es return Feed - { feedId = i - , feedTitle = t - , feedSubtitle = pTextContent "subtitle" es - , feedUpdated = u - , feedAuthors = pMany "author" pPerson es - , feedContributors = pMany "contributor" pPerson es - , feedCategories = pMany "category" pCategory es - , feedGenerator = pGenerator `fmap` pNode "generator" es - , feedIcon = pLeaf "icon" es - , feedLogo = pLeaf "logo" es - , feedRights = pTextContent "rights" es - , feedLinks = pMany "link" pLink es - , feedEntries = pMany "entry" pEntry es - , feedOther = other_es es - , feedAttrs = other_as (elementAttributes e) - } + { feedId = i + , feedTitle = t + , feedSubtitle = pTextContent "subtitle" es + , feedUpdated = u + , feedAuthors = pMany "author" pPerson es + , feedContributors = pMany "contributor" pPerson es + , feedCategories = pMany "category" pCategory es + , feedGenerator = pGenerator `fmap` pNode "generator" es + , feedIcon = pLeaf "icon" es + , feedLogo = pLeaf "logo" es + , feedRights = pTextContent "rights" es + , feedLinks = pMany "link" pLink es + , feedEntries = pMany "entry" pEntry es + , feedOther = other_es es + , feedAttrs = other_as (elementAttributes e) + } where - other_es = filter (\el -> not (elementName el `elem` known_elts)) - other_as = filter (\a -> not (fst a `elem` known_attrs)) + other_es = filter ((`notElem` known_elts) . elementName) + other_as = filter ((`notElem` known_attrs) . fst) -- let's have them all (including xml:base and xml:lang + xmlns: stuff) known_attrs = [] known_elts = @@ -162,22 +161,22 @@ name <- pLeaf "name" es -- or missing "name" return Person - { personName = name - , personURI = pLeaf "uri" es - , personEmail = pLeaf "email" es - , personOther = [] -- XXX? - } + { personName = name + , personURI = pLeaf "uri" es + , personEmail = pLeaf "email" es + , personOther = [] -- XXX? + } pCategory :: XML.Element -> Maybe Category pCategory e = do term <- pAttr "term" e -- or missing "term" attribute return Category - { catTerm = term - , catScheme = pAttr "scheme" e - , catLabel = pAttr "label" e - , catOther = [] -- XXX? - } + { catTerm = term + , catScheme = pAttr "scheme" e + , catLabel = pAttr "label" e + , catOther = [] -- XXX? + } pGenerator :: XML.Element -> Generator pGenerator e = @@ -186,37 +185,37 @@ pSource :: XML.Element -> Source pSource e = let es = children e - in Source - { sourceAuthors = pMany "author" pPerson es - , sourceCategories = pMany "category" pCategory es - , sourceGenerator = pGenerator `fmap` pNode "generator" es - , sourceIcon = pLeaf "icon" es - , sourceId = pLeaf "id" es - , sourceLinks = pMany "link" pLink es - , sourceLogo = pLeaf "logo" es - , sourceRights = pTextContent "rights" es - , sourceSubtitle = pTextContent "subtitle" es - , sourceTitle = pTextContent "title" es - , sourceUpdated = pLeaf "updated" es - , sourceOther = [] -- XXX ? - } + in Source + { sourceAuthors = pMany "author" pPerson es + , sourceCategories = pMany "category" pCategory es + , sourceGenerator = pGenerator `fmap` pNode "generator" es + , sourceIcon = pLeaf "icon" es + , sourceId = pLeaf "id" es + , sourceLinks = pMany "link" pLink es + , sourceLogo = pLeaf "logo" es + , sourceRights = pTextContent "rights" es + , sourceSubtitle = pTextContent "subtitle" es + , sourceTitle = pTextContent "title" es + , sourceUpdated = pLeaf "updated" es + , sourceOther = [] -- XXX ? + } pLink :: XML.Element -> Maybe Link pLink e = do uri <- pAttr "href" e return Link - { linkHref = uri - , linkRel = Right `fmap` pAttr "rel" e - , linkType = pAttr "type" e - , linkHrefLang = pAttr "hreflang" e - , linkTitle = pAttr "title" e - , linkLength = pAttr "length" e - , linkAttrs = other_as (elementAttributes e) - , linkOther = [] - } + { linkHref = uri + , linkRel = Right `fmap` pAttr "rel" e + , linkType = pAttr "type" e + , linkHrefLang = pAttr "hreflang" e + , linkTitle = pAttr "title" e + , linkLength = pAttr "length" e + , linkAttrs = other_as (elementAttributes e) + , linkOther = [] + } where - other_as = filter (\a -> not (fst a `elem` known_attrs)) + other_as = filter ((`notElem` known_attrs) . fst) known_attrs = map atomName ["href", "rel", "type", "hreflang", "title", "length"] pEntry :: XML.Element -> Maybe Entry @@ -227,25 +226,25 @@ u <- pLeaf "updated" es `mplus` pLeaf "published" es return Entry - { entryId = i - , entryTitle = t - , entryUpdated = u - , entryAuthors = pMany "author" pPerson es - , entryContributor = pMany "contributor" pPerson es - , entryCategories = pMany "category" pCategory es - , entryContent = pContent =<< pNode "content" es - , entryLinks = pMany "link" pLink es - , entryPublished = pLeaf "published" es - , entryRights = pTextContent "rights" es - , entrySource = pSource `fmap` pNode "source" es - , entrySummary = pTextContent "summary" es - , entryInReplyTo = pInReplyTo es - , entryInReplyTotal = pInReplyTotal es - , entryAttrs = other_as (elementAttributes e) - , entryOther = [] -- ? - } + { entryId = i + , entryTitle = t + , entryUpdated = u + , entryAuthors = pMany "author" pPerson es + , entryContributor = pMany "contributor" pPerson es + , entryCategories = pMany "category" pCategory es + , entryContent = pContent =<< pNode "content" es + , entryLinks = pMany "link" pLink es + , entryPublished = pLeaf "published" es + , entryRights = pTextContent "rights" es + , entrySource = pSource `fmap` pNode "source" es + , entrySummary = pTextContent "summary" es + , entryInReplyTo = pInReplyTo es + , entryInReplyTotal = pInReplyTotal es + , entryAttrs = other_as (elementAttributes e) + , entryOther = [] -- ? + } where - other_as = filter (\a -> not (fst a `elem` known_attrs)) + other_as = filter ((`notElem` known_attrs) . fst) -- let's have them all (including xml:base and xml:lang + xmlns: stuff) known_attrs = [] @@ -281,11 +280,11 @@ Just ref -> return InReplyTo - { replyToRef = ref - , replyToHRef = pQAttr (atomThreadName "href") t - , replyToType = pQAttr (atomThreadName "type") t - , replyToSource = pQAttr (atomThreadName "source") t - , replyToOther = elementAttributes t -- ToDo: snip out matched ones. - , replyToContent = elementNodes t - } + { replyToRef = ref + , replyToHRef = pQAttr (atomThreadName "href") t + , replyToType = pQAttr (atomThreadName "type") t + , replyToSource = pQAttr (atomThreadName "source") t + , replyToOther = elementAttributes t -- ToDo: snip out matched ones. + , replyToContent = elementNodes t + } _ -> fail "no parse" diff --git a/src/Text/Atom/Feed/Link.hs b/src/Text/Atom/Feed/Link.hs --- a/src/Text/Atom/Feed/Link.hs +++ b/src/Text/Atom/Feed/Link.hs @@ -16,7 +16,6 @@ , showLinkAttr ) where -import Prelude () import Prelude.Compat -- | Atom feeds uses typed IRI links to represent diff --git a/src/Text/Atom/Feed/Validate.hs b/src/Text/Atom/Feed/Validate.hs --- a/src/Text/Atom/Feed/Validate.hs +++ b/src/Text/Atom/Feed/Validate.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TupleSections #-} + -------------------------------------------------------------------- -- | -- Module : Text.Atom.Feed.Validate @@ -42,7 +44,6 @@ , checkUri ) where -import Prelude () import Prelude.Compat import Data.XML.Types @@ -149,16 +150,16 @@ xs -> case map fst $ filter (\(_, n) -> n == "alternate") $ - mapMaybe (\ex -> (\x -> (ex, x)) <$> pAttr "rel" ex) xs of + mapMaybe (\ex -> (ex,) <$> pAttr "rel" ex) xs of xs1 -> let jmb (Just x) (Just y) = Just (x, y) jmb _ _ = Nothing - in case mapMaybe (\ex -> pAttr "type" ex `jmb` pAttr "hreflang" ex) xs1 of - xs2 -> - if any (\x -> length x > 1) (group xs2) - then demand - "An 'entry' element cannot have duplicate 'link-rel-alternate-type-hreflang' elements" - else valid + in case mapMaybe (\ex -> pAttr "type" ex `jmb` pAttr "hreflang" ex) xs1 of + xs2 -> + if any (\x -> length x > 1) (group xs2) + then demand + "An 'entry' element cannot have duplicate 'link-rel-alternate-type-hreflang' elements" + else valid checkId :: Element -> ValidatorResult checkId e = diff --git a/src/Text/Atom/Pub.hs b/src/Text/Atom/Pub.hs --- a/src/Text/Atom/Pub.hs +++ b/src/Text/Atom/Pub.hs @@ -20,7 +20,6 @@ , Accept(..) ) where -import Prelude () import Prelude.Compat import Data.Text (Text) diff --git a/src/Text/Atom/Pub/Export.hs b/src/Text/Atom/Pub/Export.hs --- a/src/Text/Atom/Pub/Export.hs +++ b/src/Text/Atom/Pub/Export.hs @@ -27,14 +27,12 @@ , xmlAccept ) where -import Prelude () import Prelude.Compat import Data.Text (Text) import Data.XML.Compat import Data.XML.Types -import Text.Atom.Feed.Export - (mb, xmlCategory, xmlTitle, xmlns_atom) +import Text.Atom.Feed.Export (mb, xmlCategory, xmlTitle, xmlns_atom) import Text.Atom.Pub -- ToDo: old crud; inline away. @@ -61,7 +59,7 @@ mkElem (appName "service") [xmlns_app, xmlns_atom] - (concat [map xmlWorkspace (serviceWorkspaces s), serviceOther s]) + (map xmlWorkspace (serviceWorkspaces s) ++ serviceOther s) xmlWorkspace :: Workspace -> Element xmlWorkspace w = @@ -87,17 +85,15 @@ xmlCategories (Categories mbFixed mbScheme cs) = mkElem (appName "categories") - (concat - [ mb - (\f -> - mkAttr - "fixed" - (if f - then "yes" - else "no")) - mbFixed - , mb (mkAttr "scheme") mbScheme - ]) + (mb + (\f -> + mkAttr + "fixed" + (if f + then "yes" + else "no")) + mbFixed ++ + mb (mkAttr "scheme") mbScheme) (map xmlCategory cs) xmlAccept :: Accept -> Element diff --git a/src/Text/DublinCore/Types.hs b/src/Text/DublinCore/Types.hs --- a/src/Text/DublinCore/Types.hs +++ b/src/Text/DublinCore/Types.hs @@ -19,7 +19,6 @@ , dc_element_names ) where -import Prelude () import Prelude.Compat import Data.Text diff --git a/src/Text/Feed/Constructor.hs b/src/Text/Feed/Constructor.hs --- a/src/Text/Feed/Constructor.hs +++ b/src/Text/Feed/Constructor.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -fno-warn-incomplete-patterns #-} + -------------------------------------------------------------------- -- | -- Module : Text.Feed.Constructor @@ -52,7 +54,6 @@ , withItemRights -- :: ItemSetter Text ) where -import Prelude () import Prelude.Compat import Text.Feed.Types as Feed.Types @@ -88,10 +89,10 @@ "dummy-and-bogus-update-date") RSSKind mbV -> let def = RSS.nullRSS "dummy-title" "default-channel-url" - in RSSFeed $ fromMaybe def $ fmap (\v -> def {RSS.rssVersion = v}) mbV + in RSSFeed $ maybe def (\v -> def {RSS.rssVersion = v}) mbV RDFKind mbV -> let def = RSS1.nullFeed "default-channel-url" "dummy-title" - in RSS1Feed $ fromMaybe def $ fmap (\v -> def {RSS1.feedVersion = v}) mbV + in RSS1Feed $ maybe def (\v -> def {RSS1.feedVersion = v}) mbV feedFromRSS :: RSS.RSS -> Feed.Types.Feed feedFromRSS = RSSFeed @@ -280,17 +281,18 @@ case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of (as, dci:bs) -> f - { RSS1.feedChannel = - (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = dateStr} : bs} - } + { RSS1.feedChannel = + (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = dateStr} : bs} + } (_, []) -> f - { RSS1.feedChannel = - (RSS1.feedChannel f) - { RSS1.channelDC = - DCItem {dcElt = DC_Date, dcText = dateStr} : RSS1.channelDC (RSS1.feedChannel f) - } - } + { RSS1.feedChannel = + (RSS1.feedChannel f) + { RSS1.channelDC = + DCItem {dcElt = DC_Date, dcText = dateStr} : + RSS1.channelDC (RSS1.feedChannel f) + } + } Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ mapMaybeChildren @@ -319,17 +321,18 @@ case break isDate $ RSS1.channelDC (RSS1.feedChannel f) of (as, dci:bs) -> f - { RSS1.feedChannel = - (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = dateStr} : bs} - } + { RSS1.feedChannel = + (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = dateStr} : bs} + } (_, []) -> f - { RSS1.feedChannel = - (RSS1.feedChannel f) - { RSS1.channelDC = - DCItem {dcElt = DC_Date, dcText = dateStr} : RSS1.channelDC (RSS1.feedChannel f) - } - } + { RSS1.feedChannel = + (RSS1.feedChannel f) + { RSS1.channelDC = + DCItem {dcElt = DC_Date, dcText = dateStr} : + RSS1.channelDC (RSS1.feedChannel f) + } + } Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ mapMaybeChildren @@ -362,15 +365,15 @@ Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f - { rssChannel = - (rssChannel f) {rssImage = Just $ RSS.nullImage imgURL (rssTitle (rssChannel f)) lnk} - } + { rssChannel = + (rssChannel f) {rssImage = Just $ RSS.nullImage imgURL (rssTitle (rssChannel f)) lnk} + } Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed $ f - { feedImage = Just $ RSS1.nullImage imgURL (RSS1.channelTitle (RSS1.feedChannel f)) lnk - , feedChannel = (feedChannel f) {channelImageURI = Just imgURL} - } + { feedImage = Just $ RSS1.nullImage imgURL (RSS1.channelTitle (RSS1.feedChannel f)) lnk + , feedChannel = (feedChannel f) {channelImageURI = Just imgURL} + } Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ mapMaybeChildren @@ -408,17 +411,18 @@ case break isLang $ RSS1.channelDC (RSS1.feedChannel f) of (as, dci:bs) -> f - { RSS1.feedChannel = - (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = lang} : bs} - } + { RSS1.feedChannel = + (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = lang} : bs} + } (_, []) -> f - { RSS1.feedChannel = - (RSS1.feedChannel f) - { RSS1.channelDC = - DCItem {dcElt = DC_Language, dcText = lang} : RSS1.channelDC (RSS1.feedChannel f) - } - } + { RSS1.feedChannel = + (RSS1.feedChannel f) + { RSS1.channelDC = + DCItem {dcElt = DC_Language, dcText = lang} : + RSS1.channelDC (RSS1.feedChannel f) + } + } Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ mapMaybeChildren @@ -442,29 +446,29 @@ Feed.Types.AtomFeed f -> Feed.Types.AtomFeed f - { Atom.feedCategories = - map (\(t, mb) -> (Atom.newCategory t) {Atom.catScheme = mb}) cats ++ feedCategories f - } + { Atom.feedCategories = + map (\(t, mb) -> (Atom.newCategory t) {Atom.catScheme = mb}) cats ++ feedCategories f + } Feed.Types.RSSFeed f -> Feed.Types.RSSFeed f - { rssChannel = - (rssChannel f) - { RSS.rssCategories = - map (\(t, mb) -> (RSS.newCategory t) {RSS.rssCategoryDomain = mb}) cats ++ - RSS.rssCategories (rssChannel f) - } - } + { rssChannel = + (rssChannel f) + { RSS.rssCategories = + map (\(t, mb) -> (RSS.newCategory t) {RSS.rssCategoryDomain = mb}) cats ++ + RSS.rssCategories (rssChannel f) + } + } Feed.Types.RSS1Feed f -> Feed.Types.RSS1Feed f - { feedChannel = - (feedChannel f) - { RSS1.channelDC = - map (\(t, _) -> DCItem {dcElt = DC_Subject, dcText = t}) cats ++ - RSS1.channelDC (feedChannel f) - } - } + { feedChannel = + (feedChannel f) + { RSS1.channelDC = + map (\(t, _) -> DCItem {dcElt = DC_Subject, dcText = t}) cats ++ + RSS1.channelDC (feedChannel f) + } + } Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ mapMaybeChildren @@ -476,10 +480,7 @@ addChild (unode "category" - (fromMaybe - (: []) - (fmap (\ v x -> [mkAttr "domain" v, x]) mb) - (mkAttr "term" t))) + (maybe (: []) (\v x -> [mkAttr "domain" v, x]) mb (mkAttr "term" t))) acc) e cats) @@ -499,15 +500,17 @@ case break isSource $ RSS1.channelDC (RSS1.feedChannel f) of (as, dci:bs) -> f - {RSS1.feedChannel = (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = gen} : bs}} + { RSS1.feedChannel = + (RSS1.feedChannel f) {RSS1.channelDC = as ++ dci {dcText = gen} : bs} + } (_, []) -> f - { RSS1.feedChannel = - (RSS1.feedChannel f) - { RSS1.channelDC = - DCItem {dcElt = DC_Source, dcText = gen} : RSS1.channelDC (RSS1.feedChannel f) - } - } + { RSS1.feedChannel = + (RSS1.feedChannel f) + { RSS1.channelDC = + DCItem {dcElt = DC_Source, dcText = gen} : RSS1.channelDC (RSS1.feedChannel f) + } + } Feed.Types.XMLFeed f -> Feed.Types.XMLFeed $ mapMaybeChildren @@ -601,9 +604,9 @@ Feed.Types.AtomItem e -> Feed.Types.AtomItem e - { Atom.entrySource = - Just Atom.nullSource {sourceId = Just url, sourceTitle = Just (TextString tit)} - } + { Atom.entrySource = + Just Atom.nullSource {sourceId = Just url, sourceTitle = Just (TextString tit)} + } Feed.Types.RSSItem i -> Feed.Types.RSSItem i {RSS.rssItemSource = Just (RSS.nullSource url tit)} Feed.Types.RSS1Item i -> Feed.Types.RSS1Item i {RSS1.itemTitle = tit} Feed.Types.XMLItem i -> @@ -638,28 +641,28 @@ Feed.Types.AtomItem e -> Feed.Types.AtomItem e - { Atom.entryLinks = - ((nullLink url) - { linkRel = Just (Left "enclosure") - , linkType = ty - , linkLength = fmap (pack . show) mb_len - }) : - Atom.entryLinks e - } + { Atom.entryLinks = + ((nullLink url) + { linkRel = Just (Left "enclosure") + , linkType = ty + , linkLength = fmap (pack . show) mb_len + }) : + Atom.entryLinks e + } Feed.Types.RSSItem i -> Feed.Types.RSSItem i {RSS.rssItemEnclosure = Just (nullEnclosure url mb_len (fromMaybe "text/html" ty))} Feed.Types.RSS1Item i -> Feed.Types.RSS1Item i - { RSS1.itemContent = - nullContentInfo {contentURI = Just url, contentFormat = ty} : RSS1.itemContent i - } + { RSS1.itemContent = + nullContentInfo {contentURI = Just url, contentFormat = ty} : RSS1.itemContent i + } Feed.Types.XMLItem i -> Feed.Types.XMLItem $ addChild ((unode "enclosure" url) - {elementAttributes = [mkAttr "length" "0", mkAttr "type" (fromMaybe "text/html" ty)]}) $ + {elementAttributes = [mkAttr "length" "0", mkAttr "type" (fromMaybe "text/html" ty)]}) $ filterChildren (\e -> elementName e /= "enclosure") i -- | 'withItemId isURL id' associates new unique identifier with a feed item. @@ -746,33 +749,28 @@ Feed.Types.AtomItem e -> Feed.Types.AtomItem e - { Atom.entryCategories = - map (\(t, mb) -> (Atom.newCategory t) {Atom.catScheme = mb}) cats ++ entryCategories e - } + { Atom.entryCategories = + map (\(t, mb) -> (Atom.newCategory t) {Atom.catScheme = mb}) cats ++ entryCategories e + } Feed.Types.RSSItem i -> Feed.Types.RSSItem i - { RSS.rssItemCategories = - map (\(t, mb) -> (RSS.newCategory t) {RSS.rssCategoryDomain = mb}) cats ++ - rssItemCategories i - } + { RSS.rssItemCategories = + map (\(t, mb) -> (RSS.newCategory t) {RSS.rssCategoryDomain = mb}) cats ++ + rssItemCategories i + } Feed.Types.RSS1Item i -> Feed.Types.RSS1Item i - { RSS1.itemDC = - map (\(t, _) -> DCItem {dcElt = DC_Subject, dcText = t}) cats ++ RSS1.itemDC i - } + { RSS1.itemDC = + map (\(t, _) -> DCItem {dcElt = DC_Subject, dcText = t}) cats ++ RSS1.itemDC i + } Feed.Types.XMLItem i -> Feed.Types.XMLItem $ foldr (\(t, mb) acc -> addChild - (unode - "category" - (fromMaybe - (: []) - (fmap (\ v x -> [mkAttr "domain" v, x]) mb) - (mkAttr "term" t))) + (unode "category" (maybe (: []) (\v x -> [mkAttr "domain" v, x]) mb (mkAttr "term" t))) acc) i cats diff --git a/src/Text/Feed/Export.hs b/src/Text/Feed/Export.hs --- a/src/Text/Feed/Export.hs +++ b/src/Text/Feed/Export.hs @@ -13,18 +13,20 @@ -------------------------------------------------------------------- module Text.Feed.Export ( Text.Feed.Export.xmlFeed -- :: Feed -> XML.Element + , Text.Feed.Export.textFeed -- :: Feed -> TL.Text ) where -import Prelude () -import Prelude.Compat () +import Prelude.Compat import Text.Feed.Types import Text.Atom.Feed.Export as Atom import Text.RSS.Export as RSS import Text.RSS1.Export as RSS1 +import qualified Data.Text.Util as U import Data.XML.Types as XML +import qualified Data.Text.Lazy as TL -- | 'xmlFeed f' serializes a @Feed@ document into a conforming -- XML toplevel element. @@ -35,3 +37,6 @@ RSSFeed f -> RSS.xmlRSS f RSS1Feed f -> RSS1.xmlFeed f XMLFeed e -> e -- that was easy! + +textFeed :: Feed -> Maybe TL.Text +textFeed = U.renderFeed Text.Feed.Export.xmlFeed diff --git a/src/Text/Feed/Import.hs b/src/Text/Feed/Import.hs --- a/src/Text/Feed/Import.hs +++ b/src/Text/Feed/Import.hs @@ -2,7 +2,6 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE CPP #-} - -------------------------------------------------------------------- -- | -- Module : Text.Feed.Import @@ -27,7 +26,6 @@ , readAtom -- :: XML.Element -> Maybe Feed ) where -import Prelude () import Prelude.Compat import Control.Exception @@ -41,7 +39,7 @@ import Text.RSS.Import as RSS import Text.RSS1.Import as RSS1 -import Control.Monad +import Control.Monad.Compat import qualified Text.XML as C #if MIN_VERSION_utf8_string(1,0,0) @@ -56,7 +54,6 @@ utf8readFile :: FilePath -> IO String utf8readFile = UTF8.readFile #endif - class FeedSource s where parseFeedSourceXML :: s -> Either SomeException C.Document @@ -86,10 +83,8 @@ parseFeedWithParser parser str = case parser str of Left _ -> Nothing - Right d -> - readAtom e `mplus` readRSS2 e `mplus` readRSS1 e `mplus` Just (XMLFeed e) - where - e = C.toXMLElement $ C.documentRoot d + Right d -> readAtom e `mplus` readRSS2 e `mplus` readRSS1 e `mplus` Just (XMLFeed e) + where e = C.toXMLElement $ C.documentRoot d parseFeedString :: String -> Maybe Feed parseFeedString = parseFeedSource diff --git a/src/Text/Feed/Query.hs b/src/Text/Feed/Query.hs --- a/src/Text/Feed/Query.hs +++ b/src/Text/Feed/Query.hs @@ -45,7 +45,6 @@ , getItemDescription -- :: ItemGetter Text (synonym of previous.) ) where -import Prelude () import Prelude.Compat import Text.Feed.Types as Feed @@ -62,7 +61,7 @@ import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) -import Control.Monad (mplus) +import Control.Monad.Compat (mplus) import Data.Maybe import Data.Text (Text) import qualified Data.Text as T @@ -72,8 +71,7 @@ import qualified Data.Time.Format as F -- for getItemPublishDate rfc822 date parsing. -import Data.Time.Locale.Compat - (defaultTimeLocale, iso8601DateFormat, rfc822DateFormat) +import Data.Time.Locale.Compat (defaultTimeLocale, iso8601DateFormat, rfc822DateFormat) feedItems :: Feed.Feed -> [Feed.Item] feedItems fe = @@ -143,7 +141,7 @@ where isSelf lr = let rel = Atom.linkRel lr - in (isNothing rel || toStr rel == "alternate") && isHTMLType (linkType lr) + in (isNothing rel || toStr rel == "alternate") && isHTMLType (linkType lr) isHTMLType (Just str) = "html" `T.isSuffixOf` str isHTMLType _ = True -- if none given, assume html. @@ -275,7 +273,7 @@ where isSelf lr = let rel = Atom.linkRel lr - in (isNothing rel || toStr rel == "alternate") && isHTMLType (linkType lr) + in (isNothing rel || toStr rel == "alternate") && isHTMLType (linkType lr) isHTMLType (Just str) = "html" `T.isSuffixOf` str isHTMLType _ = True -- if none given, assume html. diff --git a/src/Text/Feed/Translate.hs b/src/Text/Feed/Translate.hs --- a/src/Text/Feed/Translate.hs +++ b/src/Text/Feed/Translate.hs @@ -18,7 +18,6 @@ , withRSS1Item -- :: (RSS1.Item -> RSS1.Item) -> Item -> Item ) where -import Prelude () import Prelude.Compat import Control.Arrow ((&&&)) @@ -75,11 +74,10 @@ XMLItem {} -> error "toAtomItem: unimplemented (from shallow XML rep.)" Feed.RSSItem ri -> foldl (\oi f -> f oi) outIt pipeline_rss_atom where outIt = - flip - withAtomEntry - (newItem AtomKind) + withAtomEntry (\e -> e {Atom.entryOther = RSS.rssItemOther ri, Atom.entryAttrs = RSS.rssItemAttrs ri}) + (newItem AtomKind) pipeline_rss_atom = [ mb withItemTitle (rssItemTitle ri) , mb withItemLink (rssItemLink ri) diff --git a/src/Text/Feed/Types.hs b/src/Text/Feed/Types.hs --- a/src/Text/Feed/Types.hs +++ b/src/Text/Feed/Types.hs @@ -16,7 +16,6 @@ , FeedKind(..) ) where -import Prelude () import Prelude.Compat import Data.Text diff --git a/src/Text/Feed/Util.hs b/src/Text/Feed/Util.hs --- a/src/Text/Feed/Util.hs +++ b/src/Text/Feed/Util.hs @@ -15,7 +15,6 @@ , toFeedDateStringUTC ) where -import Prelude () import Prelude.Compat import Data.Time (UTCTime, formatTime) diff --git a/src/Text/RSS/Export.hs b/src/Text/RSS/Export.hs --- a/src/Text/RSS/Export.hs +++ b/src/Text/RSS/Export.hs @@ -14,6 +14,7 @@ ( qualNode , qualName , xmlRSS + , textRSS , xmlChannel , xmlItem , xmlSource @@ -30,14 +31,15 @@ , mb ) where -import Prelude () import Prelude.Compat import Data.XML.Compat import Data.XML.Types as XML import Text.RSS.Syntax +import qualified Data.Text.Util as U import Data.Text (Text, pack) +import qualified Data.Text.Lazy as TL qualName :: Text -> XML.Name qualName n = Name n Nothing Nothing @@ -49,32 +51,36 @@ xmlRSS :: RSS -> XML.Element xmlRSS r = (qualNode "rss" $ map NodeElement (xmlChannel (rssChannel r) : rssOther r)) - {elementAttributes = mkAttr "version" (rssVersion r) : rssAttrs r} + {elementAttributes = mkAttr "version" (rssVersion r) : rssAttrs r} +textRSS :: RSS -> Maybe TL.Text +textRSS = U.renderFeed xmlRSS + xmlChannel :: RSSChannel -> XML.Element xmlChannel ch = qualNode "channel" $ - map NodeElement - ([ xmlLeaf "title" (rssTitle ch) - , xmlLeaf "link" (rssLink ch) - , xmlLeaf "description" (rssDescription ch) - ] ++ - map xmlItem (rssItems ch) ++ - mb (xmlLeaf "language") (rssLanguage ch) ++ - mb (xmlLeaf "copyright") (rssCopyright ch) ++ - mb (xmlLeaf "managingEditor") (rssEditor ch) ++ - mb (xmlLeaf "webMaster") (rssWebMaster ch) ++ - mb (xmlLeaf "pubDate") (rssPubDate ch) ++ - mb (xmlLeaf "lastBuildDate") (rssLastUpdate ch) ++ - map xmlCategory (rssCategories ch) ++ - mb (xmlLeaf "generator") (rssGenerator ch) ++ - mb (xmlLeaf "docs") (rssDocs ch) ++ - mb xmlCloud (rssCloud ch) ++ - mb (xmlLeaf "ttl" . pack . show) (rssTTL ch) ++ - mb xmlImage (rssImage ch) ++ - mb (xmlLeaf "rating") (rssRating ch) ++ - mb xmlTextInput (rssTextInput ch) ++ - mb xmlSkipHours (rssSkipHours ch) ++ mb xmlSkipDays (rssSkipDays ch) ++ rssChannelOther ch) + map + NodeElement + ([ xmlLeaf "title" (rssTitle ch) + , xmlLeaf "link" (rssLink ch) + , xmlLeaf "description" (rssDescription ch) + ] ++ + map xmlItem (rssItems ch) ++ + mb (xmlLeaf "language") (rssLanguage ch) ++ + mb (xmlLeaf "copyright") (rssCopyright ch) ++ + mb (xmlLeaf "managingEditor") (rssEditor ch) ++ + mb (xmlLeaf "webMaster") (rssWebMaster ch) ++ + mb (xmlLeaf "pubDate") (rssPubDate ch) ++ + mb (xmlLeaf "lastBuildDate") (rssLastUpdate ch) ++ + map xmlCategory (rssCategories ch) ++ + mb (xmlLeaf "generator") (rssGenerator ch) ++ + mb (xmlLeaf "docs") (rssDocs ch) ++ + mb xmlCloud (rssCloud ch) ++ + mb (xmlLeaf "ttl" . pack . show) (rssTTL ch) ++ + mb xmlImage (rssImage ch) ++ + mb (xmlLeaf "rating") (rssRating ch) ++ + mb xmlTextInput (rssTextInput ch) ++ + mb xmlSkipHours (rssSkipHours ch) ++ mb xmlSkipDays (rssSkipDays ch) ++ rssChannelOther ch) xmlItem :: RSSItem -> XML.Element xmlItem it = @@ -91,37 +97,39 @@ mb xmlGuid (rssItemGuid it) ++ mb (xmlLeaf "pubDate") (rssItemPubDate it) ++ mb xmlSource (rssItemSource it) ++ rssItemOther it)) - {elementAttributes = rssItemAttrs it} + {elementAttributes = rssItemAttrs it} xmlSource :: RSSSource -> XML.Element xmlSource s = (xmlLeaf "source" (rssSourceTitle s)) - {elementAttributes = mkAttr "url" (rssSourceURL s) : rssSourceAttrs s} + {elementAttributes = mkAttr "url" (rssSourceURL s) : rssSourceAttrs s} xmlEnclosure :: RSSEnclosure -> XML.Element xmlEnclosure e = (xmlLeaf "enclosure" "") - { elementAttributes = - mkAttr "url" (rssEnclosureURL e) : - mkAttr "type" (rssEnclosureType e) : - mb (mkAttr "length" . pack . show) (rssEnclosureLength e) ++ rssEnclosureAttrs e - } + { elementAttributes = + mkAttr "url" (rssEnclosureURL e) : + mkAttr "type" (rssEnclosureType e) : + mb (mkAttr "length" . pack . show) (rssEnclosureLength e) ++ rssEnclosureAttrs e + } xmlCategory :: RSSCategory -> XML.Element xmlCategory c = (xmlLeaf "category" (rssCategoryValue c)) - { elementAttributes = - maybe id (\n -> (mkAttr "domain" n :)) (rssCategoryDomain c) - (rssCategoryAttrs c) - } + { elementAttributes = + maybe id (\n -> (mkAttr "domain" n :)) (rssCategoryDomain c) (rssCategoryAttrs c) + } xmlGuid :: RSSGuid -> XML.Element xmlGuid g = (xmlLeaf "guid" (rssGuidValue g)) - { elementAttributes = - maybe id (\n -> (mkAttr "isPermaLink" (toBool n) :)) (rssGuidPermanentURL g) - (rssGuidAttrs g) - } + { elementAttributes = + maybe + id + (\n -> (mkAttr "isPermaLink" (toBool n) :)) + (rssGuidPermanentURL g) + (rssGuidAttrs g) + } where toBool False = "false" toBool _ = "true" @@ -129,25 +137,26 @@ xmlImage :: RSSImage -> XML.Element xmlImage im = qualNode "image" $ - map NodeElement - ([ xmlLeaf "url" (rssImageURL im) - , xmlLeaf "title" (rssImageTitle im) - , xmlLeaf "link" (rssImageLink im) - ] ++ - mb (xmlLeaf "width" . pack . show) (rssImageWidth im) ++ - mb (xmlLeaf "height" . pack . show) (rssImageHeight im) ++ - mb (xmlLeaf "description") (rssImageDesc im) ++ rssImageOther im) + map + NodeElement + ([ xmlLeaf "url" (rssImageURL im) + , xmlLeaf "title" (rssImageTitle im) + , xmlLeaf "link" (rssImageLink im) + ] ++ + mb (xmlLeaf "width" . pack . show) (rssImageWidth im) ++ + mb (xmlLeaf "height" . pack . show) (rssImageHeight im) ++ + mb (xmlLeaf "description") (rssImageDesc im) ++ rssImageOther im) xmlCloud :: RSSCloud -> XML.Element xmlCloud cl = (xmlLeaf "cloud" "") - { elementAttributes = - mb (mkAttr "domain") (rssCloudDomain cl) ++ - mb (mkAttr "port") (rssCloudPort cl) ++ - mb (mkAttr "path") (rssCloudPath cl) ++ - mb (mkAttr "registerProcedure") (rssCloudRegisterProcedure cl) ++ - mb (mkAttr "protocol") (rssCloudProtocol cl) ++ rssCloudAttrs cl - } + { elementAttributes = + mb (mkAttr "domain") (rssCloudDomain cl) ++ + mb (mkAttr "port") (rssCloudPort cl) ++ + mb (mkAttr "path") (rssCloudPath cl) ++ + mb (mkAttr "registerProcedure") (rssCloudRegisterProcedure cl) ++ + mb (mkAttr "protocol") (rssCloudProtocol cl) ++ rssCloudAttrs cl + } xmlTextInput :: RSSTextInput -> XML.Element xmlTextInput ti = @@ -160,7 +169,7 @@ , xmlLeaf "link" (rssTextInputLink ti) ] ++ rssTextInputOther ti)) - {elementAttributes = rssTextInputAttrs ti} + {elementAttributes = rssTextInputAttrs ti} xmlSkipHours :: [Integer] -> XML.Element xmlSkipHours hs = @@ -175,10 +184,10 @@ xmlLeaf :: Text -> Text -> XML.Element xmlLeaf tg txt = Element - { elementAttributes = [] - , elementName = Name tg Nothing Nothing - , elementNodes = [NodeContent (ContentText txt)] - } + { elementAttributes = [] + , elementName = Name tg Nothing Nothing + , elementNodes = [NodeContent (ContentText txt)] + } --- mb :: (a -> b) -> Maybe a -> [b] diff --git a/src/Text/RSS/Import.hs b/src/Text/RSS/Import.hs --- a/src/Text/RSS/Import.hs +++ b/src/Text/RSS/Import.hs @@ -39,7 +39,6 @@ , readBool ) where -import Prelude () import Prelude.Compat import Data.XML.Compat @@ -48,7 +47,7 @@ import Text.RSS.Syntax import Text.RSS1.Utils (dcNS, dcPrefix) -import Control.Monad (guard, mplus) +import Control.Monad.Compat (guard, mplus) import Data.Char (isSpace) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Text (Text, dropWhile) @@ -96,11 +95,11 @@ ch <- pNode "channel" es >>= elementToChannel return RSS - { rssVersion = v - , rssAttrs = filter (\a -> not (fst a `elem` known_attrs)) as - , rssChannel = ch - , rssOther = filter (\e1 -> elementName e1 /= qualName "channel") es - } + { rssVersion = v + , rssAttrs = filter ((`notElem` known_attrs) . fst) as + , rssChannel = ch + , rssOther = filter (\e1 -> elementName e1 /= qualName "channel") es + } where known_attrs = ["version"] @@ -112,29 +111,29 @@ link <- pLeaf "link" es return RSSChannel - { rssTitle = title - , rssLink = link + { rssTitle = title + , rssLink = link -- being liberal, is a required channel element. - , rssDescription = fromMaybe title (pLeaf "description" es) - , rssItems = pMany "item" elementToItem es - , rssLanguage = pLeaf "language" es `mplus` pQLeaf (dcName "lang") es - , rssCopyright = pLeaf "copyright" es - , rssEditor = pLeaf "managingEditor" es `mplus` pQLeaf (dcName "creator") es - , rssWebMaster = pLeaf "webMaster" es - , rssPubDate = pLeaf "pubDate" es `mplus` pQLeaf (dcName "date") es - , rssLastUpdate = pLeaf "lastBuildDate" es `mplus` pQLeaf (dcName "date") es - , rssCategories = pMany "category" elementToCategory es - , rssGenerator = pLeaf "generator" es `mplus` pQLeaf (dcName "source") es - , rssDocs = pLeaf "docs" es - , rssCloud = pNode "cloud" es >>= elementToCloud - , rssTTL = pLeaf "ttl" es >>= readInt - , rssImage = pNode "image" es >>= elementToImage - , rssRating = pLeaf "rating" es - , rssTextInput = pNode "textInput" es >>= elementToTextInput - , rssSkipHours = pNode "skipHours" es >>= elementToSkipHours - , rssSkipDays = pNode "skipDays" es >>= elementToSkipDays - , rssChannelOther = filter (\e1 -> not (elementName e1 `elem` known_channel_elts)) es - } + , rssDescription = fromMaybe title (pLeaf "description" es) + , rssItems = pMany "item" elementToItem es + , rssLanguage = pLeaf "language" es `mplus` pQLeaf (dcName "lang") es + , rssCopyright = pLeaf "copyright" es + , rssEditor = pLeaf "managingEditor" es `mplus` pQLeaf (dcName "creator") es + , rssWebMaster = pLeaf "webMaster" es + , rssPubDate = pLeaf "pubDate" es `mplus` pQLeaf (dcName "date") es + , rssLastUpdate = pLeaf "lastBuildDate" es `mplus` pQLeaf (dcName "date") es + , rssCategories = pMany "category" elementToCategory es + , rssGenerator = pLeaf "generator" es `mplus` pQLeaf (dcName "source") es + , rssDocs = pLeaf "docs" es + , rssCloud = pNode "cloud" es >>= elementToCloud + , rssTTL = pLeaf "ttl" es >>= readInt + , rssImage = pNode "image" es >>= elementToImage + , rssRating = pLeaf "rating" es + , rssTextInput = pNode "textInput" es >>= elementToTextInput + , rssSkipHours = pNode "skipHours" es >>= elementToSkipHours + , rssSkipDays = pNode "skipDays" es >>= elementToSkipDays + , rssChannelOther = filter ((`notElem` known_channel_elts) . elementName) es + } where known_channel_elts = map @@ -170,14 +169,14 @@ link <- pLeaf "link" es return RSSImage - { rssImageURL = url - , rssImageTitle = title - , rssImageLink = link - , rssImageWidth = pLeaf "width" es >>= readInt - , rssImageHeight = pLeaf "height" es >>= readInt - , rssImageDesc = pLeaf "description" es - , rssImageOther = filter (\e1 -> not (elementName e1 `elem` known_image_elts)) es - } + { rssImageURL = url + , rssImageTitle = title + , rssImageLink = link + , rssImageWidth = pLeaf "width" es >>= readInt + , rssImageHeight = pLeaf "height" es >>= readInt + , rssImageDesc = pLeaf "description" es + , rssImageOther = filter ((`notElem` known_image_elts) . elementName) es + } where known_image_elts = map qualName ["url", "title", "link", "width", "height", "description"] @@ -187,10 +186,10 @@ let as = elementAttributes e return RSSCategory - { rssCategoryDomain = pAttr "domain" e - , rssCategoryAttrs = filter (\a -> not (nameLocalName (attrKey a) `elem` known_attrs)) as - , rssCategoryValue = strContent e - } + { rssCategoryDomain = pAttr "domain" e + , rssCategoryAttrs = filter ((`notElem` known_attrs) . nameLocalName . attrKey) as + , rssCategoryValue = strContent e + } where known_attrs = ["domain"] @@ -200,13 +199,13 @@ let as = elementAttributes e return RSSCloud - { rssCloudDomain = pAttr "domain" e - , rssCloudPort = pAttr "port" e - , rssCloudPath = pAttr "path" e - , rssCloudRegisterProcedure = pAttr "registerProcedure" e - , rssCloudProtocol = pAttr "protocol" e - , rssCloudAttrs = filter (\a -> not (nameLocalName (attrKey a) `elem` known_attrs)) as - } + { rssCloudDomain = pAttr "domain" e + , rssCloudPort = pAttr "port" e + , rssCloudPath = pAttr "path" e + , rssCloudRegisterProcedure = pAttr "registerProcedure" e + , rssCloudProtocol = pAttr "protocol" e + , rssCloudAttrs = filter ((`notElem` known_attrs) . nameLocalName . attrKey) as + } where known_attrs = ["domain", "port", "path", "registerProcedure", "protocol"] @@ -216,19 +215,19 @@ let es = children e return RSSItem - { rssItemTitle = pLeaf "title" es - , rssItemLink = pLeaf "link" es - , rssItemDescription = pLeaf "description" es - , rssItemAuthor = pLeaf "author" es `mplus` pQLeaf (dcName "creator") es - , rssItemCategories = pMany "category" elementToCategory es - , rssItemComments = pLeaf "comments" es - , rssItemEnclosure = pNode "enclosure" es >>= elementToEnclosure - , rssItemGuid = pNode "guid" es >>= elementToGuid - , rssItemPubDate = pLeaf "pubDate" es `mplus` pQLeaf (dcName "date") es - , rssItemSource = pNode "source" es >>= elementToSource - , rssItemAttrs = elementAttributes e - , rssItemOther = filter (\e1 -> not (elementName e1 `elem` known_item_elts)) es - } + { rssItemTitle = pLeaf "title" es + , rssItemLink = pLeaf "link" es + , rssItemDescription = pLeaf "description" es + , rssItemAuthor = pLeaf "author" es `mplus` pQLeaf (dcName "creator") es + , rssItemCategories = pMany "category" elementToCategory es + , rssItemComments = pLeaf "comments" es + , rssItemEnclosure = pNode "enclosure" es >>= elementToEnclosure + , rssItemGuid = pNode "guid" es >>= elementToGuid + , rssItemPubDate = pLeaf "pubDate" es `mplus` pQLeaf (dcName "date") es + , rssItemSource = pNode "source" es >>= elementToSource + , rssItemAttrs = elementAttributes e + , rssItemOther = filter ((`notElem` known_item_elts) . elementName) es + } where known_item_elts = map @@ -252,10 +251,10 @@ url <- pAttr "url" e return RSSSource - { rssSourceURL = url - , rssSourceAttrs = filter (\a -> not (nameLocalName (attrKey a) `elem` known_attrs)) as - , rssSourceTitle = strContent e - } + { rssSourceURL = url + , rssSourceAttrs = filter ((`notElem` known_attrs) . nameLocalName . attrKey) as + , rssSourceTitle = strContent e + } where known_attrs = ["url"] @@ -267,11 +266,11 @@ ty <- pAttr "type" e return RSSEnclosure - { rssEnclosureURL = url - , rssEnclosureType = ty - , rssEnclosureLength = pAttr "length" e >>= readInt - , rssEnclosureAttrs = filter (\a -> not (nameLocalName (attrKey a) `elem` known_attrs)) as - } + { rssEnclosureURL = url + , rssEnclosureType = ty + , rssEnclosureLength = pAttr "length" e >>= readInt + , rssEnclosureAttrs = filter ((`notElem` known_attrs) . nameLocalName . attrKey) as + } where known_attrs = ["url", "type", "length"] @@ -281,10 +280,10 @@ let as = elementAttributes e return RSSGuid - { rssGuidPermanentURL = pAttr "isPermaLink" e >>= readBool - , rssGuidAttrs = filter (\a -> not (nameLocalName (attrKey a) `elem` known_attrs)) as - , rssGuidValue = strContent e - } + { rssGuidPermanentURL = pAttr "isPermaLink" e >>= readBool + , rssGuidAttrs = filter ((`notElem` known_attrs) . nameLocalName . attrKey) as + , rssGuidValue = strContent e + } where known_attrs = ["isPermaLink"] @@ -298,13 +297,13 @@ link <- pLeaf "link" es return RSSTextInput - { rssTextInputTitle = title - , rssTextInputDesc = desc - , rssTextInputName = name - , rssTextInputLink = link - , rssTextInputAttrs = elementAttributes e - , rssTextInputOther = filter (\e1 -> not (elementName e1 `elem` known_ti_elts)) es - } + { rssTextInputTitle = title + , rssTextInputDesc = desc + , rssTextInputName = name + , rssTextInputLink = link + , rssTextInputAttrs = elementAttributes e + , rssTextInputOther = filter ((`notElem` known_ti_elts) . elementName) es + } where known_ti_elts = map qualName ["title", "description", "name", "link"] diff --git a/src/Text/RSS/Syntax.hs b/src/Text/RSS/Syntax.hs --- a/src/Text/RSS/Syntax.hs +++ b/src/Text/RSS/Syntax.hs @@ -39,7 +39,6 @@ , nullTextInput ) where -import Prelude () import Prelude.Compat import Data.Text (Text) @@ -167,47 +166,47 @@ -> RSSChannel nullChannel title link = RSSChannel - { rssTitle = title - , rssLink = link - , rssDescription = title - , rssItems = [] - , rssLanguage = Nothing - , rssCopyright = Nothing - , rssEditor = Nothing - , rssWebMaster = Nothing - , rssPubDate = Nothing - , rssLastUpdate = Nothing - , rssCategories = [] - , rssGenerator = Nothing - , rssDocs = Nothing - , rssCloud = Nothing - , rssTTL = Nothing - , rssImage = Nothing - , rssRating = Nothing - , rssTextInput = Nothing - , rssSkipHours = Nothing - , rssSkipDays = Nothing - , rssChannelOther = [] - } + { rssTitle = title + , rssLink = link + , rssDescription = title + , rssItems = [] + , rssLanguage = Nothing + , rssCopyright = Nothing + , rssEditor = Nothing + , rssWebMaster = Nothing + , rssPubDate = Nothing + , rssLastUpdate = Nothing + , rssCategories = [] + , rssGenerator = Nothing + , rssDocs = Nothing + , rssCloud = Nothing + , rssTTL = Nothing + , rssImage = Nothing + , rssRating = Nothing + , rssTextInput = Nothing + , rssSkipHours = Nothing + , rssSkipDays = Nothing + , rssChannelOther = [] + } nullItem :: Text -- ^title -> RSSItem nullItem title = RSSItem - { rssItemTitle = Just title - , rssItemLink = Nothing - , rssItemDescription = Nothing - , rssItemAuthor = Nothing - , rssItemCategories = [] - , rssItemComments = Nothing - , rssItemEnclosure = Nothing - , rssItemGuid = Nothing - , rssItemPubDate = Nothing - , rssItemSource = Nothing - , rssItemAttrs = [] - , rssItemOther = [] - } + { rssItemTitle = Just title + , rssItemLink = Nothing + , rssItemDescription = Nothing + , rssItemAuthor = Nothing + , rssItemCategories = [] + , rssItemComments = Nothing + , rssItemEnclosure = Nothing + , rssItemGuid = Nothing + , rssItemPubDate = Nothing + , rssItemSource = Nothing + , rssItemAttrs = [] + , rssItemOther = [] + } nullSource :: URLString -- ^source URL @@ -222,11 +221,11 @@ -> RSSEnclosure nullEnclosure url mb_len ty = RSSEnclosure - { rssEnclosureURL = url - , rssEnclosureLength = mb_len - , rssEnclosureType = ty - , rssEnclosureAttrs = [] - } + { rssEnclosureURL = url + , rssEnclosureLength = mb_len + , rssEnclosureType = ty + , rssEnclosureAttrs = [] + } newCategory :: Text -- ^category Value @@ -251,25 +250,25 @@ -> RSSImage nullImage url title link = RSSImage - { rssImageURL = url - , rssImageTitle = title - , rssImageLink = link - , rssImageWidth = Nothing - , rssImageHeight = Nothing - , rssImageDesc = Nothing - , rssImageOther = [] - } + { rssImageURL = url + , rssImageTitle = title + , rssImageLink = link + , rssImageWidth = Nothing + , rssImageHeight = Nothing + , rssImageDesc = Nothing + , rssImageOther = [] + } nullCloud :: RSSCloud nullCloud = RSSCloud - { rssCloudDomain = Nothing - , rssCloudPort = Nothing - , rssCloudPath = Nothing - , rssCloudRegisterProcedure = Nothing - , rssCloudProtocol = Nothing - , rssCloudAttrs = [] - } + { rssCloudDomain = Nothing + , rssCloudPort = Nothing + , rssCloudPath = Nothing + , rssCloudRegisterProcedure = Nothing + , rssCloudProtocol = Nothing + , rssCloudAttrs = [] + } nullTextInput :: Text -- ^inputTitle @@ -278,10 +277,10 @@ -> RSSTextInput nullTextInput title nm link = RSSTextInput - { rssTextInputTitle = title - , rssTextInputDesc = title - , rssTextInputName = nm - , rssTextInputLink = link - , rssTextInputAttrs = [] - , rssTextInputOther = [] - } + { rssTextInputTitle = title + , rssTextInputDesc = title + , rssTextInputName = nm + , rssTextInputLink = link + , rssTextInputAttrs = [] + , rssTextInputOther = [] + } diff --git a/src/Text/RSS1/Export.hs b/src/Text/RSS1/Export.hs --- a/src/Text/RSS1/Export.hs +++ b/src/Text/RSS1/Export.hs @@ -12,18 +12,20 @@ -------------------------------------------------------------------- module Text.RSS1.Export ( xmlFeed + , textFeed ) where -import Prelude () import Prelude.Compat import Text.DublinCore.Types import Text.RSS1.Syntax import Text.RSS1.Utils +import qualified Data.Text.Util as U import Data.List.Compat import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Data.XML.Compat import Data.XML.Types as XML @@ -48,16 +50,19 @@ , feedOther f ])) -- should we expect these to be derived by the XML pretty printer..? - { elementAttributes = - nub $ - mkNAttr (qualName (Nothing, Nothing) "xmlns") rss10NS : - mkNAttr (qualName (Nothing, Just "xmlns") rdfPrefix) rdfNS : - mkNAttr (qualName (Nothing, Just "xmlns") synPrefix) synNS : - mkNAttr (qualName (Nothing, Just "xmlns") taxPrefix) taxNS : - mkNAttr (qualName (Nothing, Just "xmlns") conPrefix) conNS : - mkNAttr (qualName (Nothing, Just "xmlns") dcPrefix) dcNS : feedAttrs f - } + { elementAttributes = + nub $ + mkNAttr (qualName (Nothing, Nothing) "xmlns") rss10NS : + mkNAttr (qualName (Nothing, Just "xmlns") rdfPrefix) rdfNS : + mkNAttr (qualName (Nothing, Just "xmlns") synPrefix) synNS : + mkNAttr (qualName (Nothing, Just "xmlns") taxPrefix) taxNS : + mkNAttr (qualName (Nothing, Just "xmlns") conPrefix) conNS : + mkNAttr (qualName (Nothing, Just "xmlns") dcPrefix) dcNS : feedAttrs f + } +textFeed :: Feed -> Maybe TL.Text +textFeed = U.renderFeed xmlFeed + xmlChannel :: Channel -> XML.Element xmlChannel ch = (qualNode (Just rss10NS, Nothing) "channel" $ @@ -77,9 +82,9 @@ , mb (xmlLeaf (synNS, Just synPrefix) "updateBase") (channelUpdateBase ch) ] ++ xmlContentItems (channelContent ch) ++ xmlTopics (channelTopics ch) ++ channelOther ch)) - { elementAttributes = - mkNAttr (qualName' (rdfNS, rdfPrefix) "about") (channelURI ch) : channelAttrs ch - } + { elementAttributes = + mkNAttr (qualName' (rdfNS, rdfPrefix) "about") (channelURI ch) : channelAttrs ch + } xmlImageURI :: URIString -> XML.Element xmlImageURI u = xmlEmpty (rss10NS, Nothing) "image" [mkNAttr (rdfName "resource") u] @@ -94,7 +99,7 @@ , xmlLeaf (rss10NS, Nothing) "link" (imageLink i) ] ++ map xmlDC (imageDC i) ++ imageOther i)) - {elementAttributes = mkNAttr (qualName' (rdfNS, rdfPrefix) "about") (imageURI i) : imageAttrs i} + {elementAttributes = mkNAttr (qualName' (rdfNS, rdfPrefix) "about") (imageURI i) : imageAttrs i} xmlItemURIs :: [URIString] -> [XML.Element] xmlItemURIs [] = [] @@ -120,7 +125,7 @@ , xmlLeaf (rss10NS, Nothing) "link" (textInputLink ti) ] ++ map xmlDC (textInputDC ti) ++ textInputOther ti) - {elementAttributes = mkNAttr (rdfName "about") (textInputURI ti) : textInputAttrs ti} + {elementAttributes = mkNAttr (rdfName "about") (textInputURI ti) : textInputAttrs ti} xmlDC :: DCItem -> XML.Element xmlDC dc = xmlLeaf (dcNS, Just dcPrefix) (infoToTag (dcElt dc)) (dcText dc) @@ -165,7 +170,7 @@ , mb (rdfResource (conNS, conPrefix) "encoding") (contentEncoding ci) , mb (rdfValue []) (contentValue ci) ])) - {elementAttributes = mb (mkNAttr (rdfName "about")) (contentURI ci)} + {elementAttributes = mb (mkNAttr (rdfName "about")) (contentURI ci)} rdfResource :: (Text, Text) -> Text -> Text -> XML.Element rdfResource (uri, pre) t v = xmlEmpty (uri, Just pre) t [mkNAttr (rdfName "resource") v] @@ -196,7 +201,7 @@ mb (xmlLeaf (rss10NS, Nothing) "title") (taxonomyTitle tt) ++ mb (xmlLeaf (rss10NS, Nothing) "description") (taxonomyDesc tt) ++ xmlTopics (taxonomyTopics tt) ++ map xmlDC (taxonomyDC tt) ++ taxonomyOther tt)) - {elementAttributes = [mkNAttr (rdfName "about") (taxonomyURI tt)]} + {elementAttributes = [mkNAttr (rdfName "about") (taxonomyURI tt)]} xmlItem :: Item -> XML.Element xmlItem i = @@ -209,15 +214,15 @@ mb (xmlLeaf (rss10NS, Nothing) "description") (itemDesc i) ++ map xmlDC (itemDC i) ++ xmlTopics (itemTopics i) ++ map xmlContentInfo (itemContent i) ++ itemOther i)) - {elementAttributes = mkNAttr (qualName' (rdfNS, rdfPrefix) "about") (itemURI i) : itemAttrs i} + {elementAttributes = mkNAttr (qualName' (rdfNS, rdfPrefix) "about") (itemURI i) : itemAttrs i} xmlLeaf :: (Text, Maybe Text) -> Text -> Text -> XML.Element xmlLeaf (ns, pre) tg txt = Element - { elementName = qualName (Just ns, pre) tg - , elementAttributes = [] - , elementNodes = [NodeContent $ ContentText txt] - } + { elementName = qualName (Just ns, pre) tg + , elementAttributes = [] + , elementNodes = [NodeContent $ ContentText txt] + } xmlEmpty :: (Text, Maybe Text) -> Text -> [Attr] -> XML.Element xmlEmpty (uri, pre) t as = (qualNode (Just uri, pre) t []) {elementAttributes = as} diff --git a/src/Text/RSS1/Import.hs b/src/Text/RSS1/Import.hs --- a/src/Text/RSS1/Import.hs +++ b/src/Text/RSS1/Import.hs @@ -14,7 +14,6 @@ ( elementToFeed ) where -import Prelude () import Prelude.Compat import Data.XML.Compat @@ -23,8 +22,8 @@ import Text.RSS1.Syntax import Text.RSS1.Utils -import Control.Monad (guard, mplus) -import Data.Maybe (fromMaybe, mapMaybe) +import Control.Monad.Compat (guard, mplus) +import Data.Maybe (mapMaybe) import Data.Text.Util --- @@ -34,7 +33,7 @@ ver <- pAttr (Nothing, Nothing) "xmlns" e `mplus` Just rss10NS ch <- pNode "channel" e >>= elementToChannel let mbImg = pNode "image" e >>= elementToImage - let is = fromMaybe [] $ fmap elementToItems $ pNode "items" e + let is = maybe [] elementToItems $ pNode "items" e let mbTI = pNode "textinput" e >>= elementToTextInput let ch1 = ch {channelItemURIs = is} let its = pMany (Just rss10NS, Nothing) "item" elementToItem e @@ -42,16 +41,16 @@ let as_rest = removeKnownAttrs e return Feed - { feedVersion = ver - , feedChannel = ch1 - , feedImage = mbImg - , feedItems = its - , feedTextInput = mbTI - , feedTopics = - mapMaybe elementToTaxonomyTopic $ pQNodes (qualName' (taxNS, taxPrefix) "topic") e - , feedOther = es_rest - , feedAttrs = as_rest - } + { feedVersion = ver + , feedChannel = ch1 + , feedImage = mbImg + , feedItems = its + , feedTextInput = mbTI + , feedTopics = + mapMaybe elementToTaxonomyTopic $ pQNodes (qualName' (taxNS, taxPrefix) "topic") e + , feedOther = es_rest + , feedAttrs = as_rest + } elementToItems :: XML.Element -> [URIString] elementToItems = seqLeaves @@ -67,15 +66,15 @@ let dcs = mapMaybe elementToDC es return TextInputInfo - { textInputURI = uri - , textInputTitle = ti - , textInputDesc = desc - , textInputName = na - , textInputLink = li - , textInputDC = dcs - , textInputOther = es - , textInputAttrs = elementAttributes e - } + { textInputURI = uri + , textInputTitle = ti + , textInputDesc = desc + , textInputName = na + , textInputLink = li + , textInputDC = dcs + , textInputOther = es + , textInputAttrs = elementAttributes e + } elementToItem :: XML.Element -> Maybe Item elementToItem e = do @@ -86,22 +85,22 @@ li <- pQLeaf (rss10NS, Nothing) "link" e let desc = pQLeaf (rss10NS, Nothing) "description" e let dcs = mapMaybe elementToDC es - let tos = fromMaybe [] (fmap bagLeaves $ pQNode (qualName' (taxNS, taxPrefix) "topics") e) + let tos = maybe [] bagLeaves $ pQNode (qualName' (taxNS, taxPrefix) "topics") e let cs = mapMaybe elementToContent es let es_other = removeKnownElts e let as_other = removeKnownAttrs e return Item - { itemURI = uri - , itemTitle = ti - , itemLink = li - , itemDesc = desc - , itemDC = dcs - , itemTopics = tos - , itemContent = cs - , itemOther = es_other - , itemAttrs = as_other - } + { itemURI = uri + , itemTitle = ti + , itemLink = li + , itemDesc = desc + , itemDC = dcs + , itemTopics = tos + , itemContent = cs + , itemOther = es_other + , itemAttrs = as_other + } elementToImage :: XML.Element -> Maybe Image elementToImage e = do @@ -114,14 +113,14 @@ let dcs = mapMaybe elementToDC es return Image - { imageURI = uri - , imageTitle = ti - , imageURL = ur - , imageLink = li - , imageDC = dcs - , imageOther = es - , imageAttrs = as - } + { imageURI = uri + , imageTitle = ti + , imageURL = ur + , imageLink = li + , imageDC = dcs + , imageOther = es + , imageAttrs = as + } elementToChannel :: XML.Element -> Maybe Channel elementToChannel e = do @@ -131,40 +130,40 @@ li <- pLeaf "link" e de <- pLeaf "description" e let mbImg = pLeaf "image" e - let is = fromMaybe [] (fmap seqLeaves $ pNode "items" e) + let is = maybe [] seqLeaves $ pNode "items" e let tinp = pLeaf "textinput" e let dcs = mapMaybe elementToDC es - let tos = fromMaybe [] (fmap bagLeaves $ pQNode (qualName' (taxNS, taxPrefix) "topics") e) + let tos = maybe [] bagLeaves $ pQNode (qualName' (taxNS, taxPrefix) "topics") e let cs = mapMaybe elementToContent es let es_other = removeKnownElts e let as_other = removeKnownAttrs e let def_chan = Channel - { channelURI = uri - , channelTitle = ti - , channelLink = li - , channelDesc = de - , channelImageURI = mbImg - , channelItemURIs = is - , channelTextInputURI = tinp - , channelDC = dcs - , channelUpdatePeriod = Nothing - , channelUpdateFreq = Nothing - , channelUpdateBase = Nothing - , channelContent = cs - , channelTopics = tos - , channelOther = es_other - , channelAttrs = as_other - } + { channelURI = uri + , channelTitle = ti + , channelLink = li + , channelDesc = de + , channelImageURI = mbImg + , channelItemURIs = is + , channelTextInputURI = tinp + , channelDC = dcs + , channelUpdatePeriod = Nothing + , channelUpdateFreq = Nothing + , channelUpdateBase = Nothing + , channelContent = cs + , channelTopics = tos + , channelOther = es_other + , channelAttrs = as_other + } return (addSyndication e def_chan) addSyndication :: XML.Element -> Channel -> Channel addSyndication e ch = ch - { channelUpdatePeriod = fmap toUpdatePeriod $ pQLeaf' (synNS, synPrefix) "updatePeriod" e - , channelUpdateFreq = readInt =<< pQLeaf' (synNS, synPrefix) "updateFrequency" e - , channelUpdateBase = pQLeaf' (synNS, synPrefix) "updateBase" e - } + { channelUpdatePeriod = toUpdatePeriod <$> pQLeaf' (synNS, synPrefix) "updatePeriod" e + , channelUpdateFreq = readInt =<< pQLeaf' (synNS, synPrefix) "updateFrequency" e + , channelUpdateBase = pQLeaf' (synNS, synPrefix) "updateBase" e + } where toUpdatePeriod x = case x of @@ -207,26 +206,25 @@ li <- pQLeaf' (taxNS, taxPrefix) "link" e return TaxonomyTopic - { taxonomyURI = uri - , taxonomyLink = li - , taxonomyTitle = pLeaf "title" e - , taxonomyDesc = pLeaf "description" e - , taxonomyTopics = - fromMaybe [] (fmap bagLeaves $ pQNode (qualName' (taxNS, taxPrefix) "topics") e) - , taxonomyDC = mapMaybe elementToDC es - , taxonomyOther = es - } + { taxonomyURI = uri + , taxonomyLink = li + , taxonomyTitle = pLeaf "title" e + , taxonomyDesc = pLeaf "description" e + , taxonomyTopics = maybe [] bagLeaves $ pQNode (qualName' (taxNS, taxPrefix) "topics") e + , taxonomyDC = mapMaybe elementToDC es + , taxonomyOther = es + } elementToContent :: XML.Element -> Maybe ContentInfo elementToContent e = do guard (elementName e == qualName' (conNS, conPrefix) "items") return ContentInfo - { contentURI = pAttr' (rdfNS, rdfPrefix) "about" e - , contentFormat = pQLeaf' (conNS, conPrefix) "format" e - , contentEncoding = pQLeaf' (conNS, conPrefix) "encoding" e - , contentValue = pQLeaf' (rdfNS, rdfPrefix) "value" e - } + { contentURI = pAttr' (rdfNS, rdfPrefix) "about" e + , contentFormat = pQLeaf' (conNS, conPrefix) "format" e + , contentEncoding = pQLeaf' (conNS, conPrefix) "encoding" e + , contentValue = pQLeaf' (rdfNS, rdfPrefix) "value" e + } bagLeaves :: XML.Element -> [URIString] bagLeaves be = @@ -235,7 +233,7 @@ guard (elementName e == qualName' (rdfNS, rdfPrefix) "li") pAttr' (rdfNS, rdfPrefix) "resource" e `mplus` fmap strContent (pQNode (qualName' (rdfNS, rdfPrefix) "li") e)) - (fromMaybe [] $ fmap children $ pQNode (qualName' (rdfNS, rdfPrefix) "Bag") be) + (maybe [] children $ pQNode (qualName' (rdfNS, rdfPrefix) "Bag") be) {- bagElements :: XML.Element -> [XML.Element] @@ -252,4 +250,4 @@ (\e -> do guard (elementName e == rdfName "li") return (strContent e)) - (fromMaybe [] $ fmap children $ pQNode (rdfName "Seq") se) + (maybe [] children $ pQNode (rdfName "Seq") se) diff --git a/src/Text/RSS1/Syntax.hs b/src/Text/RSS1/Syntax.hs --- a/src/Text/RSS1/Syntax.hs +++ b/src/Text/RSS1/Syntax.hs @@ -32,7 +32,6 @@ , nullContentInfo ) where -import Prelude () import Prelude.Compat import Data.Text @@ -141,88 +140,92 @@ nullFeed :: URIString -> TitleString -> Feed nullFeed uri title = Feed - { feedVersion = "1.0" - , feedChannel = nullChannel uri title - , feedImage = Nothing - , feedItems = [] - , feedTextInput = Nothing - , feedTopics = [] - , feedOther = [] - , feedAttrs = [] - } + { feedVersion = "1.0" + , feedChannel = nullChannel uri title + , feedImage = Nothing + , feedItems = [] + , feedTextInput = Nothing + , feedTopics = [] + , feedOther = [] + , feedAttrs = [] + } nullChannel :: URIString -> TitleString -> Channel nullChannel uri title = Channel - { channelURI = uri - , channelTitle = title - , channelLink = uri - , channelDesc = title - , channelImageURI = Nothing - , channelItemURIs = [] - , channelTextInputURI = Nothing - , channelDC = [] - , channelUpdatePeriod = Nothing - , channelUpdateFreq = Nothing - , channelUpdateBase = Nothing - , channelContent = [] - , channelTopics = [] - , channelOther = [] - , channelAttrs = [] - } + { channelURI = uri + , channelTitle = title + , channelLink = uri + , channelDesc = title + , channelImageURI = Nothing + , channelItemURIs = [] + , channelTextInputURI = Nothing + , channelDC = [] + , channelUpdatePeriod = Nothing + , channelUpdateFreq = Nothing + , channelUpdateBase = Nothing + , channelContent = [] + , channelTopics = [] + , channelOther = [] + , channelAttrs = [] + } nullImage :: URIString -> Text -> URIString -> Image nullImage imguri title link = Image - { imageURI = imguri - , imageTitle = title - , imageURL = imguri - , imageLink = link - , imageDC = [] - , imageOther = [] - , imageAttrs = [] - } + { imageURI = imguri + , imageTitle = title + , imageURL = imguri + , imageLink = link + , imageDC = [] + , imageOther = [] + , imageAttrs = [] + } nullItem :: URIString -> TextString -> URIString -> Item nullItem uri title link = Item - { itemURI = uri - , itemTitle = title - , itemLink = link - , itemDesc = Nothing - , itemDC = [] - , itemTopics = [] - , itemContent = [] - , itemOther = [] - , itemAttrs = [] - } + { itemURI = uri + , itemTitle = title + , itemLink = link + , itemDesc = Nothing + , itemDC = [] + , itemTopics = [] + , itemContent = [] + , itemOther = [] + , itemAttrs = [] + } nullTextInputInfo :: URIString -> TextString -> TextString -> URIString -> TextInputInfo nullTextInputInfo uri title nm link = TextInputInfo - { textInputURI = uri - , textInputTitle = title - , textInputDesc = title - , textInputName = nm - , textInputLink = link - , textInputDC = [] - , textInputOther = [] - , textInputAttrs = [] - } + { textInputURI = uri + , textInputTitle = title + , textInputDesc = title + , textInputName = nm + , textInputLink = link + , textInputDC = [] + , textInputOther = [] + , textInputAttrs = [] + } nullTaxonomyTopic :: URIString -> URIString -> TaxonomyTopic nullTaxonomyTopic uri link = TaxonomyTopic - { taxonomyURI = uri - , taxonomyLink = link - , taxonomyTitle = Nothing - , taxonomyDesc = Nothing - , taxonomyTopics = [] - , taxonomyDC = [] - , taxonomyOther = [] - } + { taxonomyURI = uri + , taxonomyLink = link + , taxonomyTitle = Nothing + , taxonomyDesc = Nothing + , taxonomyTopics = [] + , taxonomyDC = [] + , taxonomyOther = [] + } nullContentInfo :: ContentInfo nullContentInfo = ContentInfo - {contentURI = Nothing, contentFormat = Nothing, contentEncoding = Nothing, contentValue = Nothing} + { contentURI = Nothing + , contentFormat = Nothing + , contentEncoding = Nothing + , contentValue = Nothing + } diff --git a/src/Text/RSS1/Utils.hs b/src/Text/RSS1/Utils.hs --- a/src/Text/RSS1/Utils.hs +++ b/src/Text/RSS1/Utils.hs @@ -46,7 +46,6 @@ , removeKnownAttrs ) where -import Prelude () import Prelude.Compat import Data.XML.Compat @@ -145,12 +144,12 @@ known_con_elts = map (qualName' (conNS, conPrefix)) ["items", "item", "format", "encoding"] removeKnownElts :: XML.Element -> [XML.Element] -removeKnownElts e = filter (\e1 -> not (elementName e1 `elem` known_elts)) (elementChildren e) +removeKnownElts e = filter (\e1 -> elementName e1 `notElem` known_elts) (elementChildren e) where known_elts = concat [known_rss_elts, known_syn_elts, known_dc_elts, known_con_elts, known_tax_elts] removeKnownAttrs :: XML.Element -> [Attr] -removeKnownAttrs e = filter (\a -> not (fst a `elem` known_attrs)) (elementAttributes e) +removeKnownAttrs e = filter ((`notElem` known_attrs) . fst) (elementAttributes e) where known_attrs = map rdfName ["about"] diff --git a/tests/Example.hs b/tests/Example.hs --- a/tests/Example.hs +++ b/tests/Example.hs @@ -1,9 +1,10 @@ -module Example where +module Example + ( exampleTests + ) where -import Prelude () import Prelude.Compat -import Example.CreateAtom (createAtom) +import Example.CreateAtom (atomFeed) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion) @@ -14,7 +15,7 @@ typeCheckAtom :: Assertion typeCheckAtom = - case createAtom of + case atomFeed of Just "" -> error "createAtom returned an empty Text" Just _ -> return () Nothing -> error "createAtom returned document with unresolved entities" diff --git a/tests/Example/CreateAtom.hs b/tests/Example/CreateAtom.hs --- a/tests/Example/CreateAtom.hs +++ b/tests/Example/CreateAtom.hs @@ -1,8 +1,7 @@ module Example.CreateAtom - ( createAtom + ( atomFeed ) where -import Prelude () import Prelude.Compat hiding (take) import qualified Text.Atom.Feed as Atom @@ -13,38 +12,46 @@ import Data.Text.Lazy (toStrict) import Text.XML -createAtom :: Maybe Text -createAtom = feed examplePosts +atomFeed :: Maybe Text +atomFeed = renderFeed examplePosts -examplePosts :: [(Text, Text, Text)] -- Date, URL, Content +data Post = Post + { _postedOn :: Text + , _url :: Text + , _content :: Text + } + +examplePosts :: [Post] examplePosts = - [ ("2000-02-02T18:30:00Z", "http://example.com/2", "Bar.") - , ("2000-01-01T18:30:00Z", "http://example.com/1", "Foo.") + [ Post "2000-02-02T18:30:00Z" "http://example.com/2" "Bar." + , Post "2000-01-01T18:30:00Z" "http://example.com/1" "Foo." ] -feed :: [(Text, Text, Text)] -> Maybe Text +toEntry :: Post -> Atom.Entry +toEntry (Post date url content) = + (Atom.nullEntry + url -- The ID field. Must be a link to validate. + (Atom.TextString (take 20 content)) -- Title + date) + { Atom.entryAuthors = [Atom.nullPerson {Atom.personName = "J. Smith"}] + , Atom.entryLinks = [Atom.nullLink url] + , Atom.entryContent = Just (Atom.HTMLContent content) + } + +feed :: [Post] -> Atom.Feed feed posts = + Atom.nullFeed + "http://example.com/atom.xml" -- ID + (Atom.TextString "Example Website") -- Title + (case posts -- Updated + of + Post latestPostDate _ _:_ -> latestPostDate + _ -> "") + +renderFeed :: [Post] -> Maybe Text +renderFeed posts = fmap (toStrict . renderText def) $ elementToDoc $ Export.xmlFeed $ - fd {Atom.feedEntries = fmap toEntry posts, Atom.feedLinks = [Atom.nullLink "http://example.com/"]} - where - fd :: Atom.Feed - fd = - Atom.nullFeed - "http://example.com/atom.xml" -- ID - (Atom.TextString "Example Website") -- Title - (case posts -- Updated - of - (latestPostDate, _, _):_ -> latestPostDate - _ -> "") - toEntry :: (Text, Text, Text) -> Atom.Entry - toEntry (date, url, content) = - (Atom.nullEntry - url -- The ID field. Must be a link to validate. - (Atom.TextString (take 20 content)) -- Title - date) - { Atom.entryAuthors = [Atom.nullPerson {Atom.personName = "J. Smith"}] - , Atom.entryLinks = [Atom.nullLink url] - , Atom.entryContent = Just (Atom.HTMLContent content) - } + (feed posts) + {Atom.feedEntries = fmap toEntry posts, Atom.feedLinks = [Atom.nullLink "http://example.com/"]} diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -2,7 +2,6 @@ ( main ) where -import Prelude () import Prelude.Compat import Example (exampleTests) diff --git a/tests/Text/Atom/Tests.hs b/tests/Text/Atom/Tests.hs --- a/tests/Text/Atom/Tests.hs +++ b/tests/Text/Atom/Tests.hs @@ -1,6 +1,7 @@ -module Text.Atom.Tests where +module Text.Atom.Tests + ( atomTests + ) where -import Prelude () import Prelude.Compat import Data.Maybe (isJust) @@ -9,9 +10,9 @@ import Test.HUnit (Assertion, assertBool) import Text.XML -import Text.Atom.Feed -import Text.Feed.Export -import Text.Feed.Import +import Text.Atom.Feed (TextContent(TextString), entryLinks, nullEntry, nullLink) +import Text.Feed.Export (xmlFeed) +import Text.Feed.Import (parseFeedFromFile) import Text.Feed.Query import Text.Feed.Types import Text.RSS.Utils @@ -29,9 +30,9 @@ where testAtom :: Assertion testAtom = do - print . fmap (renderText def) . elementToDoc . xmlFeed =<< - parseFeedFromFile =<< getDataFileName "tests/files/atom.xml" - assertBool "OK" True + contents <- parseFeedFromFile =<< getDataFileName "tests/files/atom.xml" + let res = fmap (renderText def) . elementToDoc . xmlFeed $ contents + assertBool "Atom Parsing" $ isJust res testAtomAlternate :: Test testAtomAlternate = testCase "*unspecified* link relation means 'alternate'" testAlt @@ -40,4 +41,4 @@ testAlt = let nullent = nullEntry "" (TextString "") "" item = AtomItem nullent {entryLinks = [nullLink ""]} - in assertBool "unspecified means alternate" $ isJust $ getItemLink item + in assertBool "unspecified means alternate" $ isJust $ getItemLink item diff --git a/tests/Text/Feed/Util/Tests.hs b/tests/Text/Feed/Util/Tests.hs --- a/tests/Text/Feed/Util/Tests.hs +++ b/tests/Text/Feed/Util/Tests.hs @@ -1,6 +1,7 @@ -module Text.Feed.Util.Tests where +module Text.Feed.Util.Tests + ( feedUtilTests + ) where -import Prelude () import Prelude.Compat import Data.Time diff --git a/tests/Text/RSS/Equals.hs b/tests/Text/RSS/Equals.hs --- a/tests/Text/RSS/Equals.hs +++ b/tests/Text/RSS/Equals.hs @@ -2,7 +2,6 @@ module Text.RSS.Equals where -import Prelude () import Prelude.Compat import Text.RSS.Syntax (RSSCloud(..)) diff --git a/tests/Text/RSS/Export/Tests.hs b/tests/Text/RSS/Export/Tests.hs --- a/tests/Text/RSS/Export/Tests.hs +++ b/tests/Text/RSS/Export/Tests.hs @@ -1,6 +1,7 @@ -module Text.RSS.Export.Tests where +module Text.RSS.Export.Tests + ( rssExportTests + ) where -import Prelude () import Prelude.Compat import Data.Text (pack) @@ -39,69 +40,69 @@ testImage = do let other = XML.Element - { elementName = createQName "other" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "image other"] - } + { elementName = createQName "other" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image other"] + } let image = RSSImage - { rssImageURL = "image url" - , rssImageTitle = "image title" - , rssImageLink = "image link" - , rssImageWidth = Just 100 - , rssImageHeight = Just 200 - , rssImageDesc = Just "image desc" - , rssImageOther = [other] - } + { rssImageURL = "image url" + , rssImageTitle = "image title" + , rssImageLink = "image link" + , rssImageWidth = Just 100 + , rssImageHeight = Just 200 + , rssImageDesc = Just "image desc" + , rssImageOther = [other] + } let expected = XML.Element - { elementName = createQName "image" - , elementAttributes = [] :: [Attr] - , elementNodes = - [ NodeElement - XML.Element - { elementName = createQName "url" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "image url"] - } - , NodeElement - XML.Element - { elementName = createQName "title" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "image title"] - } - , NodeElement - XML.Element - { elementName = createQName "link" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "image link"] - } - , NodeElement - XML.Element - { elementName = createQName "width" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "100"] - } - , NodeElement - XML.Element - { elementName = createQName "height" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "200"] - } - , NodeElement - XML.Element - { elementName = createQName "description" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "image desc"] - } - , NodeElement - XML.Element - { elementName = createQName "other" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "image other"] - } - ] - } + { elementName = createQName "image" + , elementAttributes = [] :: [Attr] + , elementNodes = + [ NodeElement + XML.Element + { elementName = createQName "url" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image url"] + } + , NodeElement + XML.Element + { elementName = createQName "title" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image title"] + } + , NodeElement + XML.Element + { elementName = createQName "link" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image link"] + } + , NodeElement + XML.Element + { elementName = createQName "width" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "100"] + } + , NodeElement + XML.Element + { elementName = createQName "height" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "200"] + } + , NodeElement + XML.Element + { elementName = createQName "description" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image desc"] + } + , NodeElement + XML.Element + { elementName = createQName "other" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "image other"] + } + ] + } assertEqual "image" expected (xmlImage image) testCreateXMLCloud :: Test @@ -112,26 +113,26 @@ let attr = mkNAttr (createQName "attr") "text for attr" let cloud = RSSCloud - { rssCloudDomain = Just "domain cloud" - , rssCloudPort = Just "port cloud" - , rssCloudPath = Just "path cloud" - , rssCloudRegisterProcedure = Just "register cloud" - , rssCloudProtocol = Just "protocol cloud" - , rssCloudAttrs = [attr] - } + { rssCloudDomain = Just "domain cloud" + , rssCloudPort = Just "port cloud" + , rssCloudPath = Just "path cloud" + , rssCloudRegisterProcedure = Just "register cloud" + , rssCloudProtocol = Just "protocol cloud" + , rssCloudAttrs = [attr] + } let expected = XML.Element - { elementName = createQName "cloud" - , elementAttributes = - [ mkNAttr (createQName "domain") "domain cloud" - , mkNAttr (createQName "port") "port cloud" - , mkNAttr (createQName "path") "path cloud" - , mkNAttr (createQName "registerProcedure") "register cloud" - , mkNAttr (createQName "protocol") "protocol cloud" - , attr - ] :: [Attr] - , elementNodes = [createContent ""] - } + { elementName = createQName "cloud" + , elementAttributes = + [ mkNAttr (createQName "domain") "domain cloud" + , mkNAttr (createQName "port") "port cloud" + , mkNAttr (createQName "path") "path cloud" + , mkNAttr (createQName "registerProcedure") "register cloud" + , mkNAttr (createQName "protocol") "protocol cloud" + , attr + ] :: [Attr] + , elementNodes = [createContent ""] + } assertEqual "cloud" expected (xmlCloud cloud) testCreateXMLTextInput :: Test @@ -142,56 +143,56 @@ let attr = mkNAttr (createQName "attr") "text for attr" let other = XML.Element - { elementName = createQName "leaf" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "text for leaf"] - } + { elementName = createQName "leaf" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "text for leaf"] + } let input = RSSTextInput - { rssTextInputTitle = "title" - , rssTextInputDesc = "desc" - , rssTextInputName = "name" - , rssTextInputLink = "http://url.com" - , rssTextInputAttrs = [attr] - , rssTextInputOther = [other] - } + { rssTextInputTitle = "title" + , rssTextInputDesc = "desc" + , rssTextInputName = "name" + , rssTextInputLink = "http://url.com" + , rssTextInputAttrs = [attr] + , rssTextInputOther = [other] + } let expected = XML.Element - { elementName = createQName "textInput" - , elementAttributes = [attr] :: [Attr] - , elementNodes = - [ NodeElement - XML.Element - { elementName = createQName "title" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "title"] - } - , NodeElement - XML.Element - { elementName = createQName "description" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "desc"] - } - , NodeElement - XML.Element - { elementName = createQName "name" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "name"] - } - , NodeElement - XML.Element - { elementName = createQName "link" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "http://url.com"] - } - , NodeElement - XML.Element - { elementName = createQName "leaf" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent "text for leaf"] - } - ] - } + { elementName = createQName "textInput" + , elementAttributes = [attr] :: [Attr] + , elementNodes = + [ NodeElement + XML.Element + { elementName = createQName "title" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "title"] + } + , NodeElement + XML.Element + { elementName = createQName "description" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "desc"] + } + , NodeElement + XML.Element + { elementName = createQName "name" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "name"] + } + , NodeElement + XML.Element + { elementName = createQName "link" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "http://url.com"] + } + , NodeElement + XML.Element + { elementName = createQName "leaf" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent "text for leaf"] + } + ] + } assertEqual "text input" expected (xmlTextInput input) testCreateEmptyXMLSkipHours :: Test @@ -203,10 +204,10 @@ let hoursToSkip = [] let expected = XML.Element - { elementName = createQName "skipHours" - , elementAttributes = [] :: [Attr] - , elementNodes = [] - } + { elementName = createQName "skipHours" + , elementAttributes = [] :: [Attr] + , elementNodes = [] + } assertEqual "empty skip hours" expected (xmlSkipHours hoursToSkip) testCreateXMLSkipHours :: Test @@ -217,18 +218,18 @@ let hoursToSkip = [1, 2, 3] let expected = XML.Element - { elementName = createQName "skipHours" - , elementAttributes = [] :: [Attr] - , elementNodes = [hourElem 0, hourElem 1, hourElem 2] - } + { elementName = createQName "skipHours" + , elementAttributes = [] :: [Attr] + , elementNodes = [hourElem 0, hourElem 1, hourElem 2] + } where hourElem ind = NodeElement XML.Element - { elementName = createQName "hour" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent $ pack $ show $ hoursToSkip !! ind] - } + { elementName = createQName "hour" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent $ pack $ show $ hoursToSkip !! ind] + } assertEqual "skip hours" expected (xmlSkipHours hoursToSkip) testCreateEmptyXMLSkipDays :: Test @@ -240,10 +241,10 @@ let daysToSkip = [] let expected = XML.Element - { elementName = createQName "skipDays" - , elementAttributes = [] :: [Attr] - , elementNodes = [] - } + { elementName = createQName "skipDays" + , elementAttributes = [] :: [Attr] + , elementNodes = [] + } assertEqual "empty skip days" expected (xmlSkipDays daysToSkip) testCreateXMLSkipDays :: Test @@ -254,18 +255,18 @@ let daysToSkip = ["first day", "second day", "third day"] let expected = XML.Element - { elementName = createQName "skipDays" - , elementAttributes = [] :: [Attr] - , elementNodes = [dayElem 0, dayElem 1, dayElem 2] - } + { elementName = createQName "skipDays" + , elementAttributes = [] :: [Attr] + , elementNodes = [dayElem 0, dayElem 1, dayElem 2] + } where dayElem ind = NodeElement XML.Element - { elementName = createQName "day" - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent $ daysToSkip !! ind] - } + { elementName = createQName "day" + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent $ daysToSkip !! ind] + } assertEqual "skip days" expected (xmlSkipDays daysToSkip) testCreateXMLAttr :: Test @@ -287,8 +288,8 @@ let txt = "example of leaf text" let expected = XML.Element - { elementName = createQName tg - , elementAttributes = [] :: [Attr] - , elementNodes = [createContent txt] - } + { elementName = createQName tg + , elementAttributes = [] :: [Attr] + , elementNodes = [createContent txt] + } assertEqual "create a leaf" expected (xmlLeaf tg txt) diff --git a/tests/Text/RSS/Import/Tests.hs b/tests/Text/RSS/Import/Tests.hs --- a/tests/Text/RSS/Import/Tests.hs +++ b/tests/Text/RSS/Import/Tests.hs @@ -1,6 +1,7 @@ -module Text.RSS.Import.Tests where +module Text.RSS.Import.Tests + ( rssImportTests + ) where -import Prelude () import Prelude.Compat import Data.XML.Types as XML @@ -27,7 +28,7 @@ notCreateRSSCloud = do let notXmlCloudElement = XML.Element - {elementName = createQName "notCloud", elementAttributes = [], elementNodes = []} + {elementName = createQName "notCloud", elementAttributes = [], elementNodes = []} let expected = Nothing assertEqual "not create rss cloud" expected (elementToCloud notXmlCloudElement) @@ -39,25 +40,25 @@ let attr = mkNAttr (createQName "attr") "text for attr" let xmlCloudElement = XML.Element - { elementName = createQName "cloud" - , elementAttributes = - [ mkNAttr (createQName "domain") "domain cloud" - , mkNAttr (createQName "port") "port cloud" - , mkNAttr (createQName "path") "path cloud" - , mkNAttr (createQName "registerProcedure") "register cloud" - , mkNAttr (createQName "protocol") "protocol cloud" - , attr - ] :: [Attr] - , elementNodes = [createContent ""] - } + { elementName = createQName "cloud" + , elementAttributes = + [ mkNAttr (createQName "domain") "domain cloud" + , mkNAttr (createQName "port") "port cloud" + , mkNAttr (createQName "path") "path cloud" + , mkNAttr (createQName "registerProcedure") "register cloud" + , mkNAttr (createQName "protocol") "protocol cloud" + , attr + ] :: [Attr] + , elementNodes = [createContent ""] + } let expected = Just RSSCloud - { rssCloudDomain = Just "domain cloud" - , rssCloudPort = Just "port cloud" - , rssCloudPath = Just "path cloud" - , rssCloudRegisterProcedure = Just "register cloud" - , rssCloudProtocol = Just "protocol cloud" - , rssCloudAttrs = [attr] - } + { rssCloudDomain = Just "domain cloud" + , rssCloudPort = Just "port cloud" + , rssCloudPath = Just "path cloud" + , rssCloudRegisterProcedure = Just "register cloud" + , rssCloudProtocol = Just "protocol cloud" + , rssCloudAttrs = [attr] + } assertEqual "create rss cloud" expected (elementToCloud xmlCloudElement) diff --git a/tests/Text/RSS/Tests.hs b/tests/Text/RSS/Tests.hs --- a/tests/Text/RSS/Tests.hs +++ b/tests/Text/RSS/Tests.hs @@ -1,8 +1,10 @@ -module Text.RSS.Tests where +module Text.RSS.Tests + ( rssTests + ) where -import Prelude () import Prelude.Compat +import Data.Maybe (isJust) import Test.Framework (Test, mutuallyExclusive, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit (Assertion, assertBool) @@ -27,6 +29,6 @@ where testRss20 :: Assertion testRss20 = do - print . fmap (renderText def) . elementToDoc . xmlFeed =<< - parseFeedFromFile =<< getDataFileName "tests/files/rss20.xml" - assertBool "OK" True + contents <- parseFeedFromFile =<< getDataFileName "tests/files/rss20.xml" + let res = fmap (renderText def) . elementToDoc . xmlFeed $ contents + assertBool "RSS 2.0 Parsing" $ isJust res diff --git a/tests/Text/RSS/Utils.hs b/tests/Text/RSS/Utils.hs --- a/tests/Text/RSS/Utils.hs +++ b/tests/Text/RSS/Utils.hs @@ -1,6 +1,5 @@ module Text.RSS.Utils where -import Prelude () import Prelude.Compat import Data.Text