version 0.8.0.00.8.0.0

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)