summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorkoral <>2020-05-26 12:09:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-05-26 12:09:00 (GMT)
commit13e2a350a8d7b35d80ad2b7da46ea142b8211c7f (patch)
treece5094c3b233f5af4658966cc5a7e1c1590c202b
parent5dafef5a54e88fd65ef6a01adc2a1c210db542ab (diff)
version 0.8.0.00.8.0.0
-rw-r--r--Text/OPML/Conduit/Parse.hs85
-rw-r--r--Text/OPML/Conduit/Render.hs8
-rw-r--r--Text/OPML/Lens.hs17
-rw-r--r--Text/OPML/Types.hs6
-rw-r--r--opml-conduit.cabal12
-rw-r--r--test/Main.hs24
6 files changed, 78 insertions, 74 deletions
diff --git a/Text/OPML/Conduit/Parse.hs b/Text/OPML/Conduit/Parse.hs
index 0194e31..3b565ef 100644
--- a/Text/OPML/Conduit/Parse.hs
+++ b/Text/OPML/Conduit/Parse.hs
@@ -30,8 +30,7 @@ import Data.List.NonEmpty (NonEmpty, nonEmpty)
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.Time.RFC822
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 Eq OpmlException
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 @@ textTag name = tagIgnoreAttrs name content
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 @@ projectC prism = fix $ \recurse -> do
_ -> 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 @\<head\>@ section.
@@ -147,19 +147,19 @@ makeTraversals ''HeadPiece
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 @@ parseOpmlOutline = tag' "outline" attributes handler where
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 @@ parseOpmlOutline = tag' "outline" attributes handler where
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 @\<opml\>@ element.
@@ -218,8 +219,8 @@ parseOpml = tag' "opml" attributes handler where
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
index 611926d..27feaf2 100644
--- a/Text/OPML/Conduit/Render.hs
+++ b/Text/OPML/Conduit/Render.hs
@@ -25,7 +25,7 @@ import Data.Time.RFC822
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 @@ renderOpmlHead input = tag "head" mempty $ do
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 @@ renderOpmlHead input = tag "head" mempty $ do
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
index ac905c0..b8c26bc 100644
--- 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 @@ makeLensesFor
, ("ownerEmail", "ownerEmailL")
, ("ownerId", "ownerIdL")
, ("docs", "docsL")
- -- , ("expansionState", "expansionStateL")
+ , ("expansionState", "expansionStateL")
, ("vertScrollState", "vertScrollStateL")
, ("windowBottom", "windowBottomL")
, ("windowLeft", "windowLeftL")
@@ -33,10 +33,6 @@ makeLensesFor
, ("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 @@ makeLensesFor
] ''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
index 2a4a1a2..3bf821c 100644
--- a/Text/OPML/Types.hs
+++ b/Text/OPML/Types.hs
@@ -118,9 +118,9 @@ mkOutlineSubscription uri = OutlineSubscription uri mzero mempty mempty mempty m
-- | 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
index 3fb364e..f57dfc4 100644
--- 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 (<http://dev.opml.org/spec2.html>) as a 'conduit' parser/renderer.
homepage: https://github.com/k0ral/opml-conduit
license: PublicDomain
license-file: LICENSE
-author: koral <koral@mailoo.org>
-maintainer: koral <koral@mailoo.org>
+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 @@ library
, conduit-combinators
, containers
, safe-exceptions
- , lens-simple
+ , microlens
+ , microlens-th
, monoid-subclasses
, refined >= 0.2
, semigroups
@@ -69,7 +71,7 @@ test-suite tests
, conduit-combinators
, containers
, data-default
- , lens-simple
+ , microlens
, mtl
, opml-conduit
, parsers
diff --git a/test/Main.hs b/test/Main.hs
index 7b39cb9..94f790c 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -14,7 +14,7 @@ import Data.String
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 @@ categoriesCase = testCase "Parse categories list" $ do
(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 @@ directoryCase = testCase "Parse directory tree" $ do
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 @@ placesCase = testCase "Parse places list" $ do
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 @@ scriptCase = testCase "Parse script" $ do
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 @@ statesCase = testCase "Parse states list" $ do
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 @@ subscriptionsCase = testCase "Parse subscriptions list" $ do
(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 <head>" parseOpmlHead)