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.hs70
1 files changed, 31 insertions, 39 deletions
diff --git a/Text/OPML/Conduit/Parse.hs b/Text/OPML/Conduit/Parse.hs
index bfd820e..0194e31 100644
--- a/Text/OPML/Conduit/Parse.hs
+++ b/Text/OPML/Conduit/Parse.hs
@@ -20,20 +20,18 @@ module Text.OPML.Conduit.Parse
-- {{{ Imports
import Conduit hiding (throwM)
-
import Control.Applicative hiding (many)
import Control.Exception.Safe as Exception
import Control.Monad
import Control.Monad.Fix
-
import Data.CaseInsensitive hiding (map)
+import Data.Either
import Data.List.NonEmpty (NonEmpty, nonEmpty)
import Data.Maybe
import Data.Monoid
import Data.Monoid.Textual hiding (map)
-import Data.MonoTraversable
-import Data.NonNull (NonNull, fromNullable)
-import Data.Text (Text, strip, unpack)
+import Data.Text as Text (Text, null, strip,
+ unpack)
import Data.Text.Encoding
import Data.Time.Clock
import Data.Time.LocalTime
@@ -41,13 +39,10 @@ import Data.Time.RFC822
import Data.Tree
import Data.Version
import Data.XML.Types
-
import Lens.Simple
-
import Numeric
-
import Prelude hiding (last)
-
+import Refined hiding (NonEmpty)
import Text.OPML.Types
import Text.ParserCombinators.ReadP (readP_to_S)
import Text.XML.Stream.Parse
@@ -76,18 +71,18 @@ instance Exception OpmlException where
asURI :: (MonadThrow m) => Text -> m URI
asURI t = either (throwM . InvalidURI) return . parseURI laxURIParserOptions $ encodeUtf8 t
-asVersion :: (MonadThrow m) => Text -> m Version
-asVersion v = case filter (onull . snd) . readP_to_S parseVersion $ unpack v of
+asVersion :: MonadThrow m => Text -> m Version
+asVersion v = case filter (Prelude.null . snd) . readP_to_S parseVersion $ unpack v of
[(a, "")] -> return a
_ -> throwM $ InvalidVersion v
asDecimal :: (MonadThrow m, Integral a) => Text -> m a
-asDecimal t = case filter (onull . snd) . readSigned readDec $ unpack t of
+asDecimal t = case filter (Prelude.null . snd) . readSigned readDec $ unpack t of
(result, _):_ -> return result
_ -> throwM $ InvalidDecimal t
asExpansionState :: (MonadThrow m, Integral a) => Text -> m [a]
-asExpansionState t = mapM asDecimal . filter (not . onull) . map strip $ split (== ',') t
+asExpansionState t = mapM asDecimal . filter (not . Text.null) . map strip $ split (== ',') t
asTime :: (MonadThrow m) => Text -> m UTCTime
asTime t = maybe (throwM $ InvalidTime t) (return . zonedTimeToUTC) $ parseTimeRFC822 t
@@ -100,11 +95,8 @@ asBool t
| mk t == "false" = return False
| otherwise = throwM $ InvalidBool t
-asNonNull :: (MonoFoldable mono, MonadThrow m) => mono -> m (NonNull mono)
-asNonNull = maybe (throwM MissingText) return . fromNullable
-
-asCategories :: Text -> [NonEmpty (NonNull Text)]
-asCategories = mapMaybe (nonEmpty . mapMaybe fromNullable . split (== '/')) . split (== ',')
+asCategories :: Text -> [NonEmpty (Refined (Not Null) Text)]
+asCategories = mapMaybe (nonEmpty . rights . map refine . split (== '/')) . split (== ',')
dateTag :: (MonadThrow m) => NameMatcher a -> ConduitM Event o m (Maybe UTCTime)
dateTag name = tagIgnoreAttrs name $ content >>= asTime
@@ -121,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' -> Conduit a m b
+projectC :: Monad m => Fold a a' b b' -> ConduitT a b m ()
projectC prism = fix $ \recurse -> do
item <- await
case (item, item ^? (_Just . prism)) of
@@ -153,21 +145,21 @@ makeTraversals ''HeadPiece
-- - each sub-element may be repeated, in which case only the first occurrence is taken into account;
-- - each unknown sub-element is ignored.
parseOpmlHead :: (MonadCatch m) => ConduitM Event o m (Maybe OpmlHead)
-parseOpmlHead = tagIgnoreAttrs "head" $ (manyYield' (choose piece) <* many ignoreAnyTreeContent) =$= zipConduit where
+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"
@@ -195,7 +187,7 @@ parseOpmlOutline = tag' "outline" attributes handler where
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" >>= asNonNull)
+ baseAttr = (,,,,) <$> (requireAttr "text" >>= refineThrow)
<*> optional (requireAttr "isComment" >>= asBool)
<*> optional (requireAttr "isBreakpoint" >>= asBool)
<*> optional (requireAttr "created" >>= asTime)
@@ -210,7 +202,7 @@ parseOpmlOutline = tag' "outline" attributes handler where
handler (_, b, Just s, _) = Node <$> (OpmlOutlineSubscription <$> baseHandler b <*> pure (subscriptionHandler s)) <*> pure []
handler (_, b, _, Just l) = Node <$> (OpmlOutlineLink <$> baseHandler b <*> asURI l) <*> pure []
handler (otype, b, _, _) = Node <$> (OpmlOutlineGeneric <$> baseHandler b <*> pure (fromMaybe mempty otype))
- <*> (manyYield' parseOpmlOutline =$= sinkList)
+ <*> (manyYield' parseOpmlOutline .| sinkList)
baseHandler (txt, comment, breakpoint, created, category) = return $ OutlineBase txt comment breakpoint created (fromMaybe mempty category)
subscriptionHandler (uri, html, desc, lang, title, version) = OutlineSubscription uri html (fromMaybe mempty desc) (fromMaybe mempty lang) (fromMaybe mempty title) (fromMaybe mempty version)
@@ -224,11 +216,11 @@ makeTraversals ''OpmlDocPiece
parseOpml :: (MonadCatch m) => ConduitM Event o m (Maybe Opml)
parseOpml = tag' "opml" attributes handler where
attributes = (requireAttr "version" >>= asVersion) <* ignoreAttrs
- handler version = (manyYield' (choose piece) <* many ignoreAnyTreeContent) =$= zipConduit version
+ handler version = (manyYield' (choose piece) <* many ignoreAnyTreeContent) .| zipConduit version
zipConduit version = getZipConduit $ Opml version
- <$> ZipConduit (projectC _DocHead =$= headDefC mkOpmlHead)
- <*> ZipConduit (projectC _DocBody =$= headDefC mempty)
- parseOpmlBody = tagIgnoreAttrs "body" $ manyYield' parseOpmlOutline =$= sinkList
+ <$> ZipConduit (projectC _DocHead .| headDefC mkOpmlHead)
+ <*> ZipConduit (projectC _DocBody .| headDefC mempty)
+ parseOpmlBody = tagIgnoreAttrs "body" $ manyYield' parseOpmlOutline .| sinkList
piece = [ fmap DocHead <$> parseOpmlHead
, fmap DocBody <$> parseOpmlBody
]