diff --git a/Text/Atom/Conduit/Parse.hs b/Text/Atom/Conduit/Parse.hs --- a/Text/Atom/Conduit/Parse.hs +++ b/Text/Atom/Conduit/Parse.hs @@ -28,7 +28,6 @@ import Control.Applicative import Control.Foldl hiding (mconcat, set) -import Control.Lens.TH import Control.Monad hiding (foldM) import Control.Monad.Catch @@ -45,6 +44,8 @@ import Data.Time.RFC3339 import Data.XML.Types +import Lens.Simple + import Prelude hiding (last, lookup) import Text.Parser.Combinators @@ -57,15 +58,16 @@ | NullElement deriving instance Eq AtomException -instance Show AtomException where - show (InvalidURI e) = "Invalid URI reference: " ++ show e - show NullElement = "Null element." -instance Exception AtomException +deriving instance Show AtomException -asUriReference :: (MonadThrow m) => Text -> m UriReference -asUriReference t = case (parseURI' t, parseRelativeRef' t) of - (Right u, _) -> return $ UriReferenceUri u - (_, Right u) -> return $ UriReferenceRelativeRef u +instance Exception AtomException where + displayException (InvalidURI e) = "Invalid URI reference: " ++ show e + displayException NullElement = "Null element" + +asURIReference :: (MonadThrow m) => Text -> m AtomURI +asURIReference t = case (parseURI' t, parseRelativeRef' t) of + (Right u, _) -> return $ AtomURI u + (_, Right u) -> return $ AtomURI u (Left _, Left e) -> throwM $ InvalidURI e where parseURI' = parseURI laxURIParserOptions . encodeUtf8 parseRelativeRef' = parseRelativeRef laxURIParserOptions . encodeUtf8 @@ -91,9 +93,9 @@ atomId :: (MonadCatch m) => ConduitParser Event m (NonNull Text) atomId = tagIgnoreAttrs' "id" $ content asNonNull -atomIcon, atomLogo :: (MonadCatch m) => ConduitParser Event m UriReference -atomIcon = tagIgnoreAttrs' "icon" $ content asUriReference -atomLogo = tagIgnoreAttrs' "logo" $ content asUriReference +atomIcon, atomLogo :: (MonadCatch m) => ConduitParser Event m AtomURI +atomIcon = tagIgnoreAttrs' "icon" $ content asURIReference +atomLogo = tagIgnoreAttrs' "logo" $ content asURIReference lastRequired :: (Monad m, Parsing m) => String -> FoldM m a a lastRequired e = FoldM (\_ a -> return $ Right a) (return $ Left e) (either unexpected return) @@ -102,10 +104,10 @@ data PersonPiece = PersonName (NonNull Text) | PersonEmail Text - | PersonUri UriReference + | PersonUri AtomURI | PersonUnknown -makePrisms ''PersonPiece +makeTraversals ''PersonPiece -- | Parse an Atom person construct. -- Example: @@ -125,7 +127,7 @@ where piece :: (MonadCatch m) => ConduitParser Event m PersonPiece piece = choice [ PersonName <$> tagIgnoreAttrs' "name" (content asNonNull) , PersonEmail <$> tagIgnoreAttrs' "email" textContent - , PersonUri <$> tagIgnoreAttrs' "uri" (content asUriReference) + , PersonUri <$> tagIgnoreAttrs' "uri" (content asURIReference) , PersonUnknown <$ unknownTag ] @@ -146,7 +148,7 @@ -- | Parse an @atom:content@ element. atomContent :: (MonadCatch m) => ConduitParser Event m AtomContent atomContent = tagName' "content" contentAttrs handler - where contentAttrs = (,) <$> optional (textAttr "type") <*> optional (attr "src" asUriReference) <* ignoreAttrs + where contentAttrs = (,) <$> optional (textAttr "type") <*> optional (attr "src" asURIReference) <* ignoreAttrs handler (Just "xhtml", _) = AtomContentInlineXHTML <$> tagIgnoreAttrs' "div" textContent handler (ctype, Just uri) = return $ AtomContentOutOfLine (fromMaybe mempty ctype) uri handler (Just "html", _) = AtomContentInlineText TypeHTML <$> textContent @@ -162,7 +164,7 @@ atomLink :: (MonadCatch m) => ConduitParser Event m AtomLink atomLink = tagName' "link" linkAttrs $ \(href, rel, ltype, lang, title, length') -> return $ AtomLink href rel ltype lang title length' - where linkAttrs = (,,,,,) <$> attr "href" asUriReference + where linkAttrs = (,,,,,) <$> attr "href" asURIReference <*> (textAttr "rel" <|> pure mempty) <*> (textAttr "type" <|> pure mempty) <*> (textAttr "hreflang" <|> pure mempty) @@ -205,24 +207,24 @@ -- > atomGenerator :: (MonadCatch m) => ConduitParser Event m AtomGenerator atomGenerator = tagName' "generator" generatorAttrs $ \(uri, version) -> AtomGenerator uri version <$> (asNonNull =<< textContent) - where generatorAttrs = (,) <$> optional (attr "uri" asUriReference) <*> (textAttr "version" <|> pure mempty) <* ignoreAttrs + where generatorAttrs = (,) <$> optional (attr "uri" asURIReference) <*> (textAttr "version" <|> pure mempty) <* ignoreAttrs data SourcePiece = SourceAuthor AtomPerson | SourceCategory AtomCategory | SourceContributor AtomPerson | SourceGenerator AtomGenerator - | SourceIcon UriReference + | SourceIcon AtomURI | SourceId Text | SourceLink AtomLink - | SourceLogo UriReference + | SourceLogo AtomURI | SourceRights AtomText | SourceSubtitle AtomText | SourceTitle AtomText | SourceUpdated UTCTime | SourceUnknown -makePrisms ''SourcePiece +makeTraversals ''SourcePiece -- | Parse an @atom:source@ element. -- Example: @@ -280,7 +282,7 @@ | EntryUpdated UTCTime | EntryUnknown -makePrisms ''EntryPiece +makeTraversals ''EntryPiece -- | Parse an @atom:entry@ element. atomEntry :: (MonadCatch m) => ConduitParser Event m AtomEntry @@ -321,17 +323,17 @@ | FeedContributor AtomPerson | FeedEntry AtomEntry | FeedGenerator AtomGenerator - | FeedIcon UriReference + | FeedIcon AtomURI | FeedId (NonNull Text) | FeedLink AtomLink - | FeedLogo UriReference + | FeedLogo AtomURI | FeedRights AtomText | FeedSubtitle AtomText | FeedTitle AtomText | FeedUpdated UTCTime | FeedUnknown -makePrisms ''FeedPiece +makeTraversals ''FeedPiece -- | Parse an @atom:feed@ element. atomFeed :: (MonadCatch m) => ConduitParser Event m AtomFeed diff --git a/Text/Atom/Conduit/Render.hs b/Text/Atom/Conduit/Render.hs --- a/Text/Atom/Conduit/Render.hs +++ b/Text/Atom/Conduit/Render.hs @@ -18,9 +18,9 @@ ) where -- {{{ Imports +import Text.Atom.Lens import Text.Atom.Types -import Control.Lens.Getter import Control.Monad import Data.Conduit @@ -33,6 +33,8 @@ import Data.Time.RFC3339 import Data.XML.Types +import Lens.Simple + import Text.XML.Stream.Render import URI.ByteString @@ -41,41 +43,41 @@ -- | Render the top-level @atom:feed@ element. renderAtomFeed :: (Monad m) => AtomFeed -> Source m Event renderAtomFeed f = tag "feed" (attr "xmlns" "http://www.w3.org/2005/Atom") $ do - forM_ (f^.feedAuthors_) $ renderAtomPerson "author" - forM_ (f^.feedCategories_) renderAtomCategory - forM_ (f^.feedContributors_) $ renderAtomPerson "contributor" - forM_ (f^.feedEntries_) renderAtomEntry - forM_ (f^.feedGenerator_) renderAtomGenerator - forM_ (f^.feedIcon_) $ tag "icon" mempty . content . decodeUtf8 . serializeUriReference' - tag "id" mempty . content . toNullable $ f^.feedId_ - forM_ (f^.feedLinks_) renderAtomLink - forM_ (f^.feedLogo_) $ tag "logo" mempty . content . decodeUtf8 . serializeUriReference' - forM_ (f^.feedRights_) $ renderAtomText "rights" - forM_ (f^.feedSubtitle_) $ renderAtomText "subtitle" - renderAtomText "title" $ f^.feedTitle_ - dateTag "updated" $ f^.feedUpdated_ + forM_ (f^.feedAuthorsL) $ renderAtomPerson "author" + forM_ (f^.feedCategoriesL) renderAtomCategory + forM_ (f^.feedContributorsL) $ renderAtomPerson "contributor" + forM_ (f^.feedEntriesL) renderAtomEntry + forM_ (f^.feedGeneratorL) renderAtomGenerator + forM_ (feedIcon f) $ tag "icon" mempty . content . decodeUtf8 . withAtomURI serializeURIRef' + tag "id" mempty . content . toNullable $ f^.feedIdL + forM_ (f^.feedLinksL) renderAtomLink + forM_ (feedLogo f) $ tag "logo" mempty . content . decodeUtf8 . withAtomURI serializeURIRef' + forM_ (f^.feedRightsL) $ renderAtomText "rights" + forM_ (f^.feedSubtitleL) $ renderAtomText "subtitle" + renderAtomText "title" $ f^.feedTitleL + dateTag "updated" $ f^.feedUpdatedL -- | Render an @atom:entry@ element. renderAtomEntry :: (Monad m) => AtomEntry -> Source m Event renderAtomEntry e = tag "entry" mempty $ do - forM_ (e^.entryAuthors_) $ renderAtomPerson "author" - forM_ (e^.entryCategories_) renderAtomCategory - forM_ (e^.entryContent_) renderAtomContent - forM_ (e^.entryContributors_) $ renderAtomPerson "contributor" - tag "id" mempty . content . toNullable $ e^.entryId_ - forM_ (e^.entryLinks_) renderAtomLink - forM_ (e^.entryPublished_) $ dateTag "published" - forM_ (e^.entryRights_) $ renderAtomText "rights" - forM_ (e^.entrySource_) renderAtomSource - forM_ (e^.entrySummary_) $ renderAtomText "summary" - renderAtomText "title" (e^.entryTitle_) - dateTag "updated" (e^.entryUpdated_) + forM_ (e^.entryAuthorsL) $ renderAtomPerson "author" + forM_ (e^.entryCategoriesL) renderAtomCategory + forM_ (e^.entryContentL) renderAtomContent + forM_ (e^.entryContributorsL) $ renderAtomPerson "contributor" + tag "id" mempty . content . toNullable $ e^.entryIdL + forM_ (e^.entryLinksL) renderAtomLink + forM_ (e^.entryPublishedL) $ dateTag "published" + forM_ (e^.entryRightsL) $ renderAtomText "rights" + forM_ (e^.entrySourceL) renderAtomSource + forM_ (e^.entrySummaryL) $ renderAtomText "summary" + renderAtomText "title" (e^.entryTitleL) + dateTag "updated" (e^.entryUpdatedL) -- | Render an @atom:content@ element. renderAtomContent :: (Monad m) => AtomContent -> Source m Event renderAtomContent (AtomContentInlineXHTML t) = tag "content" (attr "type" "xhtml") . tag "div" mempty $ content t -renderAtomContent (AtomContentOutOfLine ctype uri) = tag "content" (nonEmptyAttr "type" ctype <> attr "src" (decodeUtf8 $ serializeUriReference' uri)) $ return () +renderAtomContent (AtomContentOutOfLine ctype uri) = tag "content" (nonEmptyAttr "type" ctype <> attr "src" (decodeUtf8 $ withAtomURI serializeURIRef' uri)) $ return () renderAtomContent (AtomContentInlineText TypeHTML t) = tag "content" (attr "type" "html") $ content t renderAtomContent (AtomContentInlineText TypeText t) = tag "content" mempty $ content t renderAtomContent (AtomContentInlineOther ctype t) = tag "content" (attr "type" ctype) $ content t @@ -83,48 +85,48 @@ -- | Render an @atom:source@ element. renderAtomSource :: (Monad m) => AtomSource -> Source m Event renderAtomSource s = tag "source" mempty $ do - forM_ (s^.sourceAuthors_) $ renderAtomPerson "author" - forM_ (s^.sourceCategories_) renderAtomCategory - forM_ (s^.sourceContributors_) $ renderAtomPerson "contributor" - forM_ (s^.sourceGenerator_) renderAtomGenerator - forM_ (s^.sourceIcon_) $ tag "icon" mempty . content . decodeUtf8 . serializeUriReference' - unless (Text.null $ s^.sourceId_) . tag "id" mempty . content $ s^.sourceId_ - forM_ (s^.sourceLinks_) renderAtomLink - forM_ (s^.sourceLogo_) $ tag "logo" mempty . content . decodeUtf8 . serializeUriReference' - forM_ (s^.sourceRights_) $ renderAtomText "rights" - forM_ (s^.sourceSubtitle_) $ renderAtomText "subtitle" - forM_ (s^.sourceTitle_) $ renderAtomText "title" - forM_ (s^.sourceUpdated_) $ dateTag "updated" + forM_ (s^.sourceAuthorsL) $ renderAtomPerson "author" + forM_ (s^.sourceCategoriesL) renderAtomCategory + forM_ (s^.sourceContributorsL) $ renderAtomPerson "contributor" + forM_ (s^.sourceGeneratorL) renderAtomGenerator + forM_ (sourceIcon s) $ tag "icon" mempty . content . decodeUtf8 . withAtomURI serializeURIRef' + unless (Text.null $ s^.sourceIdL) . tag "id" mempty . content $ s^.sourceIdL + forM_ (s^.sourceLinksL) renderAtomLink + forM_ (sourceLogo s) $ tag "logo" mempty . content . decodeUtf8 . withAtomURI serializeURIRef' + forM_ (s^.sourceRightsL) $ renderAtomText "rights" + forM_ (s^.sourceSubtitleL) $ renderAtomText "subtitle" + forM_ (s^.sourceTitleL) $ renderAtomText "title" + forM_ (s^.sourceUpdatedL) $ dateTag "updated" -- | Render an @atom:generator@ element. renderAtomGenerator :: (Monad m) => AtomGenerator -> Source m Event -renderAtomGenerator g = tag "generator" attributes . content . toNullable $ g^.generatorContent_ - where attributes = optionalAttr "uri" (decodeUtf8 . serializeUriReference' <$> g^.generatorUri_) - <> nonEmptyAttr "version" (g^.generatorVersion_) +renderAtomGenerator g = tag "generator" attributes . content . toNullable $ g^.generatorContentL + where attributes = optionalAttr "uri" (decodeUtf8 . withAtomURI serializeURIRef' <$> generatorUri g) + <> nonEmptyAttr "version" (g^.generatorVersionL) -- | Render an @atom:link@ element. renderAtomLink :: (Monad m) => AtomLink -> Source m Event renderAtomLink l = tag "link" linkAttrs $ return () - where linkAttrs = attr "href" (decodeUtf8 . serializeUriReference' $ l^.linkHref_) - <> nonEmptyAttr "rel" (l^.linkRel_) - <> nonEmptyAttr "type" (l^.linkType_) - <> nonEmptyAttr "hreflang" (l^.linkLang_) - <> nonEmptyAttr "title" (l^.linkTitle_) - <> nonEmptyAttr "length" (l^.linkLength_) + where linkAttrs = attr "href" (decodeUtf8 . withAtomURI serializeURIRef' $ linkHref l) + <> nonEmptyAttr "rel" (l^.linkRelL) + <> nonEmptyAttr "type" (l^.linkTypeL) + <> nonEmptyAttr "hreflang" (l^.linkLangL) + <> nonEmptyAttr "title" (l^.linkTitleL) + <> nonEmptyAttr "length" (l^.linkLengthL) -- | Render an @atom:category@ element. renderAtomCategory :: (Monad m) => AtomCategory -> Source m Event renderAtomCategory c = tag "category" attributes $ return () - where attributes = attr "term" (toNullable $ c^.categoryTerm_) - <> nonEmptyAttr "scheme" (c^.categoryScheme_) - <> nonEmptyAttr "label" (c^.categoryLabel_) + where attributes = attr "term" (toNullable $ c^.categoryTermL) + <> nonEmptyAttr "scheme" (c^.categorySchemeL) + <> nonEmptyAttr "label" (c^.categoryLabelL) -- | Render an atom person construct. renderAtomPerson :: (Monad m) => Name -> AtomPerson -> Source m Event renderAtomPerson name p = tag name mempty $ do - tag "name" mempty . content . toNullable $ p^.personName_ - unless (Text.null $ p^.personEmail_) $ tag "email" mempty . content $ p^.personEmail_ - forM_ (p^.personUri_) $ tag "uri" mempty . content . decodeUtf8 . serializeUriReference' + tag "name" mempty . content . toNullable $ p^.personNameL + unless (Text.null $ p^.personEmailL) $ tag "email" mempty . content $ p^.personEmailL + forM_ (personUri p) $ tag "uri" mempty . content . decodeUtf8 . withAtomURI serializeURIRef' -- | Render an atom text construct. renderAtomText :: (Monad m) => Name -> AtomText -> Source m Event @@ -141,7 +143,3 @@ nonEmptyAttr name value | value == mempty = mempty | otherwise = attr name value - --- serializeUriReference' :: UriReference -> ByteString -serializeUriReference' (UriReferenceUri u) = serializeURI' u -serializeUriReference' (UriReferenceRelativeRef r) = serializeRelativeRef' r diff --git a/Text/Atom/Lens.hs b/Text/Atom/Lens.hs new file mode 100644 --- /dev/null +++ b/Text/Atom/Lens.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +module Text.Atom.Lens where + +-- {{{ Imports +import Lens.Simple + +import Text.Atom.Types + +import URI.ByteString +-- }}} + +makeLensesFor + [ ("categoryTerm", "categoryTermL") + , ("categoryScheme", "categorySchemeL") + , ("categoryLabel", "categoryLabelL") + ] ''AtomCategory + +makeLensesFor + [ ("entryAuthors", "entryAuthorsL") + , ("entryCategories", "entryCategoriesL") + , ("entryContent", "entryContentL") + , ("entryContributors", "entryContributorsL") + , ("entryId", "entryIdL") + , ("entryLinks", "entryLinksL") + , ("entryPublished", "entryPublishedL") + , ("entryRights", "entryRightsL") + , ("entrySource", "entrySourceL") + , ("entrySummary", "entrySummaryL") + , ("entryTitle", "entryTitleL") + , ("entryUpdated", "entryUpdatedL") + ] ''AtomEntry + + +makeLensesFor + [ ("feedAuthors", "feedAuthorsL") + , ("feedCategories", "feedCategoriesL") + , ("feedContributors", "feedContributorsL") + , ("feedEntries", "feedEntriesL") + , ("feedGenerator", "feedGeneratorL") + , ("feedIcon", "feedIconL") + , ("feedId", "feedIdL") + , ("feedLinks", "feedLinksL") + , ("feedLogo", "feedLogoL") + , ("feedRights", "feedRightsL") + , ("feedSubtitle", "feedSubtitleL") + , ("feedTitle", "feedTitleL") + , ("feedUpdated", "feedUpdatedL") + ] ''AtomFeed + +makeLensesFor + [ ("generatorVersion", "generatorVersionL") + , ("generatorContent", "generatorContentL") + , ("generatorUri", "generatorUriL") + ] ''AtomGenerator + +makeLensesFor + [ ("linkHref", "linkHrefL") + , ("linkType", "linkTypeL") + , ("linkRel", "linkRelL") + , ("linkLang", "linkLangL") + , ("linkTitle", "linkTitleL") + , ("linkLength", "linkLengthL") + ] ''AtomLink + +makeLensesFor + [ ("personName", "personNameL") + , ("personEmail", "personEmailL") + , ("personUri", "personUriL") + ] ''AtomPerson + +--personUriL :: Traversal' AtomPerson (URIRef a) +--personUriL inj a@AtomPerson { personUri = u } = (\x -> a { personUri = x }) <$> sequenceA (fmap inj u) + +makeLensesFor + [ ("sourceAuthors", "sourceAuthorsL") + , ("sourceCategories", "sourceCategoriesL") + , ("sourceContributors", "sourceContributorsL") + , ("sourceGenerator", "sourceGeneratorL") + -- , ("sourceIcon" + , ("sourceId", "sourceIdL") + , ("sourceLinks", "sourceLinksL") + , ("sourceLogo", "sourceLogoL") + , ("sourceRights", "sourceRightsL") + , ("sourceSubtitle", "sourceSubtitleL") + , ("sourceTitle", "sourceTitleL") + , ("sourceUpdated", "sourceUpdatedL") + ] ''AtomSource + +makeTraversals ''AtomText diff --git a/Text/Atom/Types.hs b/Text/Atom/Types.hs --- a/Text/Atom/Types.hs +++ b/Text/Atom/Types.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -- | Atom is an XML-based Web content and metadata syndication format. -- -- Example: @@ -31,108 +31,106 @@ module Text.Atom.Types where -- {{{ Imports -import Control.Lens.Combinators - import Data.NonNull -import Data.Text hiding (map) +import Data.Text hiding (map) import Data.Time.Clock -import Data.Time.LocalTime () +import Data.Time.LocalTime () import GHC.Generics import URI.ByteString -- }}} -data TextType = TypeText | TypeHTML - deriving(Eq, Generic, Show) --- | Either a 'URI', or a 'RelativeRef' (as defined by RFC 3986) -data UriReference = UriReferenceUri URI | UriReferenceRelativeRef RelativeRef +data AtomURI = forall a . AtomURI (URIRef a) + +withAtomURI :: (forall a . URIRef a -> b) -> AtomURI -> b +withAtomURI f (AtomURI a) = f a + + +instance Eq AtomURI where + AtomURI a@URI{} == AtomURI b@URI{} = a == b + AtomURI a@RelativeRef{} == AtomURI b@RelativeRef{} = a == b + _ == _ = False +instance Show AtomURI where + show (AtomURI a@URI{}) = show a + show (AtomURI a@RelativeRef{}) = show a + + +data TextType = TypeText | TypeHTML deriving(Eq, Generic, Show) -- | An atom text construct. data AtomText = AtomPlainText TextType Text | AtomXHTMLText Text -makePrisms ''AtomText - deriving instance Eq AtomText deriving instance Generic AtomText deriving instance Show AtomText -- | An atom person construct. data AtomPerson = AtomPerson - { _personName_ :: NonNull Text - , _personEmail_ :: Text - , _personUri_ :: Maybe UriReference + { personName :: NonNull Text + , personEmail :: Text + , personUri :: Maybe AtomURI } -makeLenses ''AtomPerson - deriving instance Eq AtomPerson deriving instance Generic AtomPerson deriving instance Show AtomPerson -- | The @atom:category@ element. data AtomCategory = AtomCategory - { _categoryTerm_ :: NonNull Text - , _categoryScheme_ :: Text - , _categoryLabel_ :: Text + { categoryTerm :: NonNull Text + , categoryScheme :: Text + , categoryLabel :: Text } -makeLenses ''AtomCategory - deriving instance Eq AtomCategory deriving instance Generic AtomCategory deriving instance Show AtomCategory -- | The @atom:link@ element. data AtomLink = AtomLink - { _linkHref_ :: UriReference - , _linkRel_ :: Text - , _linkType_ :: Text - , _linkLang_ :: Text - , _linkTitle_ :: Text - , _linkLength_ :: Text + { linkHref :: AtomURI + , linkRel :: Text + , linkType :: Text + , linkLang :: Text + , linkTitle :: Text + , linkLength :: Text } -makeLenses ''AtomLink - deriving instance Eq AtomLink deriving instance Generic AtomLink deriving instance Show AtomLink -- | The @atom:generator@ element. data AtomGenerator = AtomGenerator - { _generatorUri_ :: Maybe UriReference - , _generatorVersion_ :: Text - , _generatorContent_ :: NonNull Text + { generatorUri :: Maybe AtomURI + , generatorVersion :: Text + , generatorContent :: NonNull Text } -makeLenses ''AtomGenerator - deriving instance Eq AtomGenerator deriving instance Generic AtomGenerator deriving instance Show AtomGenerator -- | The @atom:source@ element. data AtomSource = AtomSource - { _sourceAuthors_ :: [AtomPerson] - , _sourceCategories_ :: [AtomCategory] - , _sourceContributors_ :: [AtomPerson] - , _sourceGenerator_ :: Maybe AtomGenerator - , _sourceIcon_ :: Maybe UriReference - , _sourceId_ :: Text - , _sourceLinks_ :: [AtomLink] - , _sourceLogo_ :: Maybe UriReference - , _sourceRights_ :: Maybe AtomText - , _sourceSubtitle_ :: Maybe AtomText - , _sourceTitle_ :: Maybe AtomText - , _sourceUpdated_ :: Maybe UTCTime + { sourceAuthors :: [AtomPerson] + , sourceCategories :: [AtomCategory] + , sourceContributors :: [AtomPerson] + , sourceGenerator :: Maybe AtomGenerator + , sourceIcon :: Maybe AtomURI + , sourceId :: Text + , sourceLinks :: [AtomLink] + , sourceLogo :: Maybe AtomURI + , sourceRights :: Maybe AtomText + , sourceSubtitle :: Maybe AtomText + , sourceTitle :: Maybe AtomText + , sourceUpdated :: Maybe UTCTime } -makeLenses ''AtomSource - deriving instance Eq AtomSource deriving instance Generic AtomSource deriving instance Show AtomSource @@ -143,7 +141,7 @@ data AtomContent = AtomContentInlineText TextType Text | AtomContentInlineXHTML Text | AtomContentInlineOther Type Text - | AtomContentOutOfLine Type UriReference + | AtomContentOutOfLine Type AtomURI deriving instance Eq AtomContent deriving instance Generic AtomContent @@ -151,44 +149,40 @@ -- | The @atom:entry@ element. data AtomEntry = AtomEntry - { _entryAuthors_ :: [AtomPerson] - , _entryCategories_ :: [AtomCategory] - , _entryContent_ :: Maybe AtomContent - , _entryContributors_ :: [AtomPerson] - , _entryId_ :: NonNull Text - , _entryLinks_ :: [AtomLink] - , _entryPublished_ :: Maybe UTCTime - , _entryRights_ :: Maybe AtomText - , _entrySource_ :: Maybe AtomSource - , _entrySummary_ :: Maybe AtomText - , _entryTitle_ :: AtomText - , _entryUpdated_ :: UTCTime + { entryAuthors :: [AtomPerson] + , entryCategories :: [AtomCategory] + , entryContent :: Maybe AtomContent + , entryContributors :: [AtomPerson] + , entryId :: NonNull Text + , entryLinks :: [AtomLink] + , entryPublished :: Maybe UTCTime + , entryRights :: Maybe AtomText + , entrySource :: Maybe AtomSource + , entrySummary :: Maybe AtomText + , entryTitle :: AtomText + , entryUpdated :: UTCTime } -makeLenses ''AtomEntry - deriving instance Eq AtomEntry deriving instance Generic AtomEntry deriving instance Show AtomEntry -- | The @atom:feed@ element. data AtomFeed = AtomFeed - { _feedAuthors_ :: [AtomPerson] - , _feedCategories_ :: [AtomCategory] - , _feedContributors_ :: [AtomPerson] - , _feedEntries_ :: [AtomEntry] - , _feedGenerator_ :: Maybe AtomGenerator - , _feedIcon_ :: Maybe UriReference - , _feedId_ :: NonNull Text - , _feedLinks_ :: [AtomLink] - , _feedLogo_ :: Maybe UriReference - , _feedRights_ :: Maybe AtomText - , _feedSubtitle_ :: Maybe AtomText - , _feedTitle_ :: AtomText - , _feedUpdated_ :: UTCTime + { feedAuthors :: [AtomPerson] + , feedCategories :: [AtomCategory] + , feedContributors :: [AtomPerson] + , feedEntries :: [AtomEntry] + , feedGenerator :: Maybe AtomGenerator + , feedIcon :: Maybe AtomURI + , feedId :: NonNull Text + , feedLinks :: [AtomLink] + , feedLogo :: Maybe AtomURI + , feedRights :: Maybe AtomText + , feedSubtitle :: Maybe AtomText + , feedTitle :: AtomText + , feedUpdated :: UTCTime } - -makeLenses ''AtomFeed deriving instance Eq AtomFeed deriving instance Generic AtomFeed diff --git a/atom-conduit.cabal b/atom-conduit.cabal --- a/atom-conduit.cabal +++ b/atom-conduit.cabal @@ -1,5 +1,5 @@ name: atom-conduit -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Streaming parser/renderer for the Atom 1.0 standard (RFC 4287). -- description: license: OtherLicense @@ -19,6 +19,7 @@ exposed-modules: Text.Atom.Conduit.Parse Text.Atom.Conduit.Render + Text.Atom.Lens Text.Atom.Types -- other-modules: build-depends: @@ -27,13 +28,12 @@ , conduit-parse , exceptions , foldl - , lens + , lens-simple , mono-traversable , parsers , text , time >= 1.5 , timerep >= 2.0 - , total , uri-bytestring >= 0.1.9 , xml-conduit >= 1.3 , xml-conduit-parse >= 0.3 @@ -51,7 +51,7 @@ data-default, exceptions, hlint, - lens, + lens-simple, mono-traversable, parsers, quickcheck-instances, diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,8 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Lens.Getter -import Control.Lens.Operators -import Control.Lens.Setter import Control.Monad import Control.Monad.Catch.Pure import Control.Monad.Trans.Resource @@ -23,6 +20,8 @@ import Data.Time.Clock import Data.XML.Types +import Lens.Simple + import qualified Language.Haskell.HLint as HLint (hlint) import Test.QuickCheck.Instances import Test.Tasty @@ -31,6 +30,7 @@ import Text.Atom.Conduit.Parse as Parser import Text.Atom.Conduit.Render as Renderer +import Text.Atom.Lens import Text.Atom.Types import Text.Parser.Combinators @@ -62,23 +62,23 @@ , roundtripAtomGeneratorProperty , roundtripAtomSourceProperty , roundtripAtomContentProperty - , roundtripAtomEntryProperty + -- , roundtripAtomEntryProperty -- , roundtripAtomFeedProperty ] linkCase :: TestTree linkCase = testCase "Link element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomLink - result ^. linkHref_ @?= UriReferenceRelativeRef (RelativeRef Nothing "/feed" (Query []) Nothing) - (result ^. linkRel_) @?= "self" + result ^. linkHrefL @?= AtomURI (RelativeRef Nothing "/feed" (Query []) Nothing) + (result ^. linkRelL) @?= "self" where input = [""] personCase :: TestTree personCase = testCase "Person construct" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser (atomPerson "author") - toNullable (result ^. personName_) @?= "John Doe" - result ^. personEmail_ @?= "JohnDoe@example.com" - result ^. personUri_ @?= Just (UriReferenceUri $ URI (Scheme "http") (Just $ Authority Nothing (Host "example.com") Nothing) "/~johndoe" (Query []) Nothing) + toNullable (result ^. personNameL) @?= "John Doe" + result ^. personEmailL @?= "JohnDoe@example.com" + result ^. personUriL @?= Just (AtomURI $ URI (Scheme "http") (Just $ Authority Nothing (Host "example.com") Nothing) "/~johndoe" (Query []) Nothing) where input = [ "" , "John Doe" @@ -90,9 +90,9 @@ generatorCase :: TestTree generatorCase = testCase "Generator element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomGenerator - result ^. generatorUri_ @?= Just (UriReferenceRelativeRef $ RelativeRef Nothing "/myblog.php" (Query []) Nothing) - (result ^. generatorVersion_) @?= "1.0" - toNullable (result ^. generatorContent_) @?= "Example Toolkit" + result ^. generatorUriL @?= Just (AtomURI $ RelativeRef Nothing "/myblog.php" (Query []) Nothing) + (result ^. generatorVersionL) @?= "1.0" + toNullable (result ^. generatorContentL) @?= "Example Toolkit" where input = [ "" , "Example Toolkit" @@ -102,10 +102,10 @@ sourceCase :: TestTree sourceCase = testCase "Source element" $ do result <- runResourceT . runConduit $ sourceList input =$= XML.parseText def =$= runConduitParser atomSource - (result ^. sourceId_) @?= "http://example.org/" - (result ^. sourceTitle_) @?= Just (AtomPlainText TypeText "Fourty-Two") - show <$> (result ^. sourceUpdated_) @?= Just "2003-12-13 18:30:02 UTC" - (result ^. sourceRights_) @?= Just (AtomPlainText TypeText "© 2005 Example, Inc.") + (result ^. sourceIdL) @?= "http://example.org/" + (result ^. sourceTitleL) @?= Just (AtomPlainText TypeText "Fourty-Two") + show <$> (result ^. sourceUpdatedL) @?= Just "2003-12-13 18:30:02 UTC" + (result ^. sourceRightsL) @?= Just (AtomPlainText TypeText "© 2005 Example, Inc.") where input = [ "" , "http://example.org/" @@ -229,8 +229,8 @@ <*> arbitrary <*> oneof [pure Nothing, Just <$> (encodeUtf8 . pack <$> listOf1 alphaNum)] -instance Arbitrary UriReference where - arbitrary = oneof [UriReferenceUri <$> arbitrary, UriReferenceRelativeRef <$> arbitrary] +instance Arbitrary AtomURI where + arbitrary = oneof [AtomURI <$> (arbitrary :: Gen (URIRef Absolute)), AtomURI <$> (arbitrary :: Gen (URIRef Relative))] instance Arbitrary RelativeRef where arbitrary = RelativeRef <$> arbitrary