diff --git a/Text/OPML/Conduit/Parse.hs b/Text/OPML/Conduit/Parse.hs --- a/Text/OPML/Conduit/Parse.hs +++ b/Text/OPML/Conduit/Parse.hs @@ -30,8 +30,7 @@ import Data.Maybe import Data.Monoid import Data.Monoid.Textual hiding (map) -import Data.Text as Text (Text, null, strip, - unpack) +import Data.Text as Text (Text, null, strip, unpack) import Data.Text.Encoding import Data.Time.Clock import Data.Time.LocalTime @@ -39,7 +38,8 @@ import Data.Tree import Data.Version import Data.XML.Types -import Lens.Simple +import Lens.Micro +import Lens.Micro.TH import Numeric import Prelude hiding (last) import Refined hiding (NonEmpty) @@ -61,11 +61,11 @@ deriving instance Show OpmlException instance Exception OpmlException where - displayException MissingText = "An outline is missing the 'text' attribute." - displayException (InvalidBool t) = "Invalid boolean: " ++ unpack t + displayException MissingText = "An outline is missing the 'text' attribute." + displayException (InvalidBool t) = "Invalid boolean: " ++ unpack t displayException (InvalidDecimal t) = "Invalid decimal: " ++ unpack t - displayException (InvalidURI e) = "Invalid URI: " ++ show e - displayException (InvalidTime t) = "Invalid time: " ++ unpack t + displayException (InvalidURI e) = "Invalid URI: " ++ show e + displayException (InvalidTime t) = "Invalid time: " ++ unpack t displayException (InvalidVersion t) = "Invalid version: " ++ unpack t asURI :: (MonadThrow m) => Text -> m URI @@ -113,7 +113,7 @@ decimalTag :: (Integral i, MonadThrow m) => NameMatcher a -> ConduitM Event o m (Maybe i) decimalTag name = tagIgnoreAttrs name $ content >>= asDecimal -projectC :: Monad m => Fold a a' b b' -> ConduitT a b m () +projectC :: Monad m => Traversal' a b -> ConduitT a b m () projectC prism = fix $ \recurse -> do item <- await case (item, item ^? (_Just . prism)) of @@ -122,21 +122,21 @@ _ -> return () -data HeadPiece = HeadCreated UTCTime - | HeadModified UTCTime - | HeadDocs URI - | HeadExpansionState [Int] - | HeadOwnerEmail Text - | HeadOwnerId URI - | HeadOwnerName Text - | HeadTitle Text - | HeadVertScrollState Int - | HeadWindowBottom Int - | HeadWindowLeft Int - | HeadWindowRight Int - | HeadWindowTop Int +data HeadPiece = HeadCreated { __headCreated :: UTCTime } + | HeadModified { __headModified :: UTCTime } + | HeadDocs { __headDocs :: URI } + | HeadExpansionState { __headExpansionState :: [Int] } + | HeadOwnerEmail { __headOwnerEmail :: Text } + | HeadOwnerId { __headOwnerId :: URI } + | HeadOwnerName { __headOwnerName :: Text } + | HeadTitle { __headTitle :: Text } + | HeadVertScrollState { __headVertScrollState :: Int } + | HeadWindowBottom { __headWindowBottom :: Int } + | HeadWindowLeft { __headWindowLeft :: Int } + | HeadWindowRight { __headWindowRight :: Int } + | HeadWindowTop { __headWindowTop :: Int } -makeTraversals ''HeadPiece +makeLenses ''HeadPiece -- | Parse the @\@ section. @@ -147,19 +147,19 @@ parseOpmlHead :: (MonadCatch m) => ConduitM Event o m (Maybe OpmlHead) parseOpmlHead = tagIgnoreAttrs "head" $ (manyYield' (choose piece) <* many ignoreAnyTreeContent) .| zipConduit where zipConduit = getZipConduit $ OpmlHead - <$> ZipConduit (projectC _HeadTitle .| headDefC mempty) - <*> ZipConduit (projectC _HeadCreated .| headC) - <*> ZipConduit (projectC _HeadModified .| headC) - <*> ZipConduit (projectC _HeadOwnerName .| headDefC mempty) - <*> ZipConduit (projectC _HeadOwnerEmail .| headDefC mempty) - <*> ZipConduit (projectC _HeadOwnerId .| headC) - <*> ZipConduit (projectC _HeadDocs .| headC) - <*> ZipConduit (projectC _HeadExpansionState .| concatC .| sinkList) - <*> ZipConduit (projectC _HeadVertScrollState .| headC) - <*> ZipConduit (projectC _HeadWindowBottom .| headC) - <*> ZipConduit (projectC _HeadWindowLeft .| headC) - <*> ZipConduit (projectC _HeadWindowRight .| headC) - <*> ZipConduit (projectC _HeadWindowTop .| headC) + <$> ZipConduit (projectC _headTitle .| headDefC mempty) + <*> ZipConduit (projectC _headCreated .| headC) + <*> ZipConduit (projectC _headModified .| headC) + <*> ZipConduit (projectC _headOwnerName .| headDefC mempty) + <*> ZipConduit (projectC _headOwnerEmail .| headDefC mempty) + <*> ZipConduit (projectC _headOwnerId .| headC) + <*> ZipConduit (projectC _headDocs .| headC) + <*> ZipConduit (projectC _headExpansionState .| concatC .| sinkList) + <*> ZipConduit (projectC _headVertScrollState .| headC) + <*> ZipConduit (projectC _headWindowBottom .| headC) + <*> ZipConduit (projectC _headWindowLeft .| headC) + <*> ZipConduit (projectC _headWindowRight .| headC) + <*> ZipConduit (projectC _headWindowTop .| headC) piece = [ fmap HeadCreated <$> dateTag "dateCreated" , fmap HeadModified <$> dateTag "dateModified" , fmap HeadDocs <$> uriTag "docs" @@ -184,9 +184,9 @@ otype <- optional $ requireAttr "type" case mk <$> otype of Just "include" -> (,,,) otype <$> baseAttr <*> pure Nothing <*> (Just <$> linkAttr) <* ignoreAttrs - Just "link" -> (,,,) otype <$> baseAttr <*> pure Nothing <*> (Just <$> linkAttr) <* ignoreAttrs - Just "rss" -> (,,,) otype <$> baseAttr <*> (Just <$> subscriptionAttr) <*> pure Nothing <* ignoreAttrs - _ -> (,,,) otype <$> baseAttr <*> pure Nothing <*> pure Nothing <* ignoreAttrs + Just "link" -> (,,,) otype <$> baseAttr <*> pure Nothing <*> (Just <$> linkAttr) <* ignoreAttrs + Just "rss" -> (,,,) otype <$> baseAttr <*> (Just <$> subscriptionAttr) <*> pure Nothing <* ignoreAttrs + _ -> (,,,) otype <$> baseAttr <*> pure Nothing <*> pure Nothing <* ignoreAttrs baseAttr = (,,,,) <$> (requireAttr "text" >>= refineThrow) <*> optional (requireAttr "isComment" >>= asBool) <*> optional (requireAttr "isBreakpoint" >>= asBool) @@ -207,9 +207,10 @@ subscriptionHandler (uri, html, desc, lang, title, version) = OutlineSubscription uri html (fromMaybe mempty desc) (fromMaybe mempty lang) (fromMaybe mempty title) (fromMaybe mempty version) -data OpmlDocPiece = DocHead OpmlHead | DocBody [Tree OpmlOutline] +data OpmlDocPiece = DocHead { __docHead :: OpmlHead } + | DocBody { __docBody :: [Tree OpmlOutline] } -makeTraversals ''OpmlDocPiece +makeLenses ''OpmlDocPiece -- | Parse the top-level @\@ element. @@ -218,8 +219,8 @@ attributes = (requireAttr "version" >>= asVersion) <* ignoreAttrs handler version = (manyYield' (choose piece) <* many ignoreAnyTreeContent) .| zipConduit version zipConduit version = getZipConduit $ Opml version - <$> ZipConduit (projectC _DocHead .| headDefC mkOpmlHead) - <*> ZipConduit (projectC _DocBody .| headDefC mempty) + <$> ZipConduit (projectC _docHead .| headDefC mkOpmlHead) + <*> ZipConduit (projectC _docBody .| headDefC mempty) parseOpmlBody = tagIgnoreAttrs "body" $ manyYield' parseOpmlOutline .| sinkList piece = [ fmap DocHead <$> parseOpmlHead , fmap DocBody <$> parseOpmlBody diff --git a/Text/OPML/Conduit/Render.hs b/Text/OPML/Conduit/Render.hs --- a/Text/OPML/Conduit/Render.hs +++ b/Text/OPML/Conduit/Render.hs @@ -25,7 +25,7 @@ import Data.Tree import Data.Version import Data.XML.Types -import Lens.Simple +import Lens.Micro import Prelude hiding (foldr, lookup, show) import qualified Prelude (show) import Refined hiding (NonEmpty) @@ -73,7 +73,7 @@ forM_ (input^.windowLeftL) $ tag "windowLeft" mempty . content . show forM_ (input^.windowRightL) $ tag "windowRight" mempty . content . show forM_ (input^.windowTopL) $ tag "windowTop" mempty . content . show - where es = input ^.. expansionStateL + where es = input ^. expansionStateL email = input ^. ownerEmailL name = input ^. ownerNameL title = input ^. opmlTitleL @@ -82,8 +82,8 @@ renderOpmlOutline :: (Monad m) => Tree OpmlOutline -> ConduitT () Event m () renderOpmlOutline (Node outline subOutlines) = tag "outline" attributes $ mapM_ renderOpmlOutline subOutlines where attributes = case outline of - OpmlOutlineGeneric b t -> baseAttr b <> optionalAttr "type" (toMaybe t) - OpmlOutlineLink b uri -> baseAttr b <> attr "type" "link" <> attr "url" (formatURI uri) + OpmlOutlineGeneric b t -> baseAttr b <> optionalAttr "type" (toMaybe t) + OpmlOutlineLink b uri -> baseAttr b <> attr "type" "link" <> attr "url" (formatURI uri) OpmlOutlineSubscription b s -> baseAttr b <> subscriptionAttr s baseAttr b = attr "text" (unrefine $ b^.textL) <> optionalAttr "isComment" (formatBool <$> b^.isCommentL) diff --git a/Text/OPML/Lens.hs b/Text/OPML/Lens.hs --- a/Text/OPML/Lens.hs +++ b/Text/OPML/Lens.hs @@ -4,7 +4,7 @@ module Text.OPML.Lens (module Text.OPML.Lens) where -- {{{ Imports -import Lens.Simple +import Lens.Micro.TH import Text.OPML.Types -- }}} @@ -25,7 +25,7 @@ , ("ownerEmail", "ownerEmailL") , ("ownerId", "ownerIdL") , ("docs", "docsL") - -- , ("expansionState", "expansionStateL") + , ("expansionState", "expansionStateL") , ("vertScrollState", "vertScrollStateL") , ("windowBottom", "windowBottomL") , ("windowLeft", "windowLeftL") @@ -33,10 +33,6 @@ , ("windowTop", "windowTopL") ] ''OpmlHead -expansionStateL :: Traversal' OpmlHead Int -expansionStateL inj a@OpmlHead { expansionState = es } = (\x -> a { expansionState = x }) <$> traverse inj es -{-# INLINE expansionStateL #-} - -- * 'OutlineSubscription' lenses makeLensesFor [ ("xmlUri", "xmlUriL") @@ -57,5 +53,10 @@ ] ''OutlineBase --- * 'OpmlOutline' traversals -makeTraversals ''OpmlOutline +-- * 'OpmlOutline' lenses +makeLensesFor + [ ("opmlOutlineBase", "opmlOutlineBaseL") + , ("opmlOutlineContent", "opmlOutlineContentL") + , ("opmlOutlineUri", "opmlOutlineUriL") + , ("opmlOutlineSubscription", "opmlOutlineSubscriptionL") + ] ''OpmlOutline diff --git a/Text/OPML/Types.hs b/Text/OPML/Types.hs --- a/Text/OPML/Types.hs +++ b/Text/OPML/Types.hs @@ -118,9 +118,9 @@ -- | Outlines are the main payload of an OPML document. -data OpmlOutline = OpmlOutlineGeneric OutlineBase Text - | OpmlOutlineLink OutlineBase URI - | OpmlOutlineSubscription OutlineBase OutlineSubscription +data OpmlOutline = OpmlOutlineGeneric { opmlOutlineBase :: OutlineBase, opmlOutlineContent :: Text } + | OpmlOutlineLink { opmlOutlineBase :: OutlineBase, opmlOutlineUri :: URI } + | OpmlOutlineSubscription { opmlOutlineBase :: OutlineBase, opmlOutlineSubscription :: OutlineSubscription } deriving instance Eq OpmlOutline deriving instance Generic OpmlOutline diff --git a/opml-conduit.cabal b/opml-conduit.cabal --- a/opml-conduit.cabal +++ b/opml-conduit.cabal @@ -1,16 +1,17 @@ name: opml-conduit -version: 0.7.0.0 +version: 0.8.0.0 synopsis: Streaming parser/renderer for the OPML 2.0 format. description: This library implements the OPML 2.0 standard () as a 'conduit' parser/renderer. homepage: https://github.com/k0ral/opml-conduit license: PublicDomain license-file: LICENSE -author: koral -maintainer: koral +author: koral +maintainer: mail@cmoreau.info category: Conduit, Text, XML build-type: Simple cabal-version: >=1.10 +tested-with: GHC <8.10 && >=8.4.2 data-files: data/category.opml data/directory.opml @@ -42,7 +43,8 @@ , conduit-combinators , containers , safe-exceptions - , lens-simple + , microlens + , microlens-th , monoid-subclasses , refined >= 0.2 , semigroups @@ -69,7 +71,7 @@ , conduit-combinators , containers , data-default - , lens-simple + , microlens , mtl , opml-conduit , parsers diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -14,7 +14,7 @@ import Data.Text.Encoding import Data.Tree import Data.Version -import Lens.Simple +import Lens.Micro import Paths_opml_conduit import Test.Tasty import Test.Tasty.HUnit @@ -54,7 +54,7 @@ (result ^. opmlVersionL) @?= Version [2,0] [] (result ^. opmlHeadL . opmlTitleL) @?= "Illustrating the category attribute" show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2005-10-31 19:23:00 UTC" - length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 1 + length (result ^.. opmlOutlinesL . traverse . traverse . opmlOutlineContentL) @?= 1 map (map length .levels) (result ^. opmlOutlinesL) @?= [[1]] @@ -69,13 +69,13 @@ show (result ^. opmlHeadL . modifiedL) @?= "Just 2005-10-25 21:33:57 UTC" (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer" (result ^. opmlHeadL . ownerEmailL) @?= "dwiner@yahoo.com" - (result ^.. opmlHeadL . expansionStateL) @?= [] + (result ^. opmlHeadL . expansionStateL) @?= [] (result ^. opmlHeadL . vertScrollStateL) @?= Just 1 (result ^. opmlHeadL . windowBottomL) @?= Just 386 (result ^. opmlHeadL . windowLeftL) @?= Just 466 (result ^. opmlHeadL . windowRightL) @?= Just 964 (result ^. opmlHeadL . windowTopL) @?= Just 105 - length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineLink) @?= 8 + length (result ^.. opmlOutlinesL . traverse . traverse . opmlOutlineUriL) @?= 8 map (map length .levels) (result ^. opmlOutlinesL) @?= [[1], [1], [1], [1], [1], [1], [1], [1]] @@ -90,14 +90,14 @@ show (result ^. opmlHeadL . modifiedL) @?= "Just 2006-02-27 12:11:44 UTC" (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer" fmap (decodeUtf8 . serializeURIRef') (result ^. opmlHeadL . ownerIdL) @?= Just "http://www.opml.org/profiles/sendMail?usernum=1" - (result ^.. opmlHeadL . expansionStateL) @?= [1,2,5,10,13,15] + (result ^. opmlHeadL . expansionStateL) @?= [1,2,5,10,13,15] (result ^. opmlHeadL . vertScrollStateL) @?= Just 1 (result ^. opmlHeadL . windowBottomL) @?= Just 665 (result ^. opmlHeadL . windowLeftL) @?= Just 329 (result ^. opmlHeadL . windowRightL) @?= Just 547 (result ^. opmlHeadL . windowTopL) @?= Just 242 - length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 18 - length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineLink) @?= 1 + length (result ^.. opmlOutlinesL . traverse . traverse . opmlOutlineContentL) @?= 18 + length (result ^.. opmlOutlinesL . traverse . traverse . opmlOutlineUriL) @?= 1 map (map length .levels) (result ^. opmlOutlinesL) @?= [[1,6,12]] @@ -112,13 +112,13 @@ show (result ^. opmlHeadL . modifiedL) @?= "Just 2005-10-30 03:30:17 UTC" (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer" (result ^. opmlHeadL . ownerEmailL) @?= "dwiner@yahoo.com" - (result ^.. opmlHeadL . expansionStateL) @?= [1, 2, 4] + (result ^. opmlHeadL . expansionStateL) @?= [1, 2, 4] (result ^. opmlHeadL . vertScrollStateL) @?= Just 1 (result ^. opmlHeadL . windowBottomL) @?= Just 314 (result ^. opmlHeadL . windowLeftL) @?= Just 41 (result ^. opmlHeadL . windowRightL) @?= Just 475 (result ^. opmlHeadL . windowTopL) @?= Just 74 - length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 11 + length (result ^.. opmlOutlinesL . traverse . traverse . opmlOutlineContentL) @?= 11 map (map length .levels) (result ^. opmlOutlinesL) @?= [[1,2,2], [1,2], [1], [1,1]] @@ -133,13 +133,13 @@ show (result ^. opmlHeadL . modifiedL) @?= "Just 2005-07-14 23:41:05 UTC" (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer" (result ^. opmlHeadL . ownerEmailL) @?= "dave@scripting.com" - (result ^.. opmlHeadL . expansionStateL) @?= [1, 6, 13, 16, 18, 20] + (result ^. opmlHeadL . expansionStateL) @?= [1, 6, 13, 16, 18, 20] (result ^. opmlHeadL . vertScrollStateL) @?= Just 1 (result ^. opmlHeadL . windowBottomL) @?= Just 558 (result ^. opmlHeadL . windowLeftL) @?= Just 106 (result ^. opmlHeadL . windowRightL) @?= Just 479 (result ^. opmlHeadL . windowTopL) @?= Just 106 - length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 63 + length (result ^.. opmlOutlinesL . traverse . traverse . opmlOutlineContentL) @?= 63 map (map length .levels) (result ^. opmlOutlinesL) @?= [[1, 8, 50, 4]] @@ -159,7 +159,7 @@ (result ^. opmlHeadL . windowLeftL) @?= Just 304 (result ^. opmlHeadL . windowRightL) @?= Just 842 (result ^. opmlHeadL . windowTopL) @?= Just 61 - length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineSubscription) @?= 13 + length (result ^.. opmlOutlinesL . traverse . traverse . opmlOutlineSubscriptionL) @?= 13 inverseHeadProperty :: TestTree inverseHeadProperty = testProperty "parse . render = id (on OpmlHead)" $ \opmlHead -> either (const False) (opmlHead ==) (runConduit $ renderOpmlHead opmlHead .| force "Invalid " parseOpmlHead)