summaryrefslogtreecommitdiff
path: root/Text/OPML/Conduit/Parse.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Text/OPML/Conduit/Parse.hs')
-rw-r--r--Text/OPML/Conduit/Parse.hs85
1 files changed, 43 insertions, 42 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
generated by cgit v0.10.2 at 2021-02-26 16:20:06 (GMT)