summaryrefslogtreecommitdiff
path: root/Text
diff options
context:
space:
mode:
Diffstat (limited to 'Text')
-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
4 files changed, 59 insertions, 57 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
generated by cgit v0.10.2 at 2021-03-08 10:35:43 (GMT)