summaryrefslogtreecommitdiff
path: root/Text
diff options
context:
space:
mode:
authorkoral <>2019-02-13 18:23:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-02-13 18:23:00 (GMT)
commit5dafef5a54e88fd65ef6a01adc2a1c210db542ab (patch)
tree0dbac350a584fb818c61d2ec0420c0b0c4f6810f /Text
parent814967f39542fb170164daa961fc8a76be236734 (diff)
version 0.7.0.00.7.0.0
Diffstat (limited to 'Text')
-rw-r--r--Text/OPML/Conduit/Parse.hs70
-rw-r--r--Text/OPML/Conduit/Render.hs18
-rw-r--r--Text/OPML/Types.hs23
3 files changed, 53 insertions, 58 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
]
diff --git a/Text/OPML/Conduit/Render.hs b/Text/OPML/Conduit/Render.hs
index 9786203..611926d 100644
--- a/Text/OPML/Conduit/Render.hs
+++ b/Text/OPML/Conduit/Render.hs
@@ -16,7 +16,6 @@ import Control.Monad
import Data.Conduit
import Data.List.NonEmpty hiding (filter, map)
import Data.Monoid
-import Data.NonNull
import Data.String
import Data.Text (Text, intercalate, pack, toLower)
import Data.Text.Encoding
@@ -26,16 +25,13 @@ import Data.Time.RFC822
import Data.Tree
import Data.Version
import Data.XML.Types
-
import Lens.Simple
-
import Prelude hiding (foldr, lookup, show)
import qualified Prelude (show)
-
+import Refined hiding (NonEmpty)
import Text.OPML.Lens
import Text.OPML.Types
import Text.XML.Stream.Render
-
import URI.ByteString
-- }}}
@@ -52,8 +48,8 @@ toMaybe s | s == mempty = mempty
formatTime :: UTCTime -> Text
formatTime = formatTimeRFC822 . utcToZonedTime utc
-formatCategories :: [NonEmpty (NonNull Text)] -> Maybe Text
-formatCategories = toMaybe . intercalate "," . map (intercalate "/" . toList . fmap toNullable)
+formatCategories :: [NonEmpty (Refined (Not Null) Text)] -> Maybe Text
+formatCategories = toMaybe . intercalate "," . map (intercalate "/" . toList . fmap unrefine)
formatBool :: Bool -> Text
formatBool = toLower . show
@@ -62,7 +58,7 @@ formatURI :: URI -> Text
formatURI = decodeUtf8 . serializeURIRef'
-- | Render the @\<head\>@ section.
-renderOpmlHead :: (Monad m) => OpmlHead -> Source m Event
+renderOpmlHead :: (Monad m) => OpmlHead -> ConduitT () Event m ()
renderOpmlHead input = tag "head" mempty $ do
forM_ (input^.opmlCreatedL) $ tag "dateCreated" mempty . content . formatTime
forM_ (input^.modifiedL) $ tag "dateModified" mempty . content . formatTime
@@ -83,13 +79,13 @@ renderOpmlHead input = tag "head" mempty $ do
title = input ^. opmlTitleL
-- | Render an @\<outline\>@ section.
-renderOpmlOutline :: (Monad m) => Tree OpmlOutline -> Source m Event
+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)
OpmlOutlineSubscription b s -> baseAttr b <> subscriptionAttr s
- baseAttr b = attr "text" (toNullable $ b^.textL)
+ baseAttr b = attr "text" (unrefine $ b^.textL)
<> optionalAttr "isComment" (formatBool <$> b^.isCommentL)
<> optionalAttr "isBreakpoint" (formatBool <$> b^.isBreakpointL)
<> optionalAttr "created" (formatTime <$> b^.outlineCreatedL)
@@ -103,7 +99,7 @@ renderOpmlOutline (Node outline subOutlines) = tag "outline" attributes $ mapM_
<> optionalAttr "version" (toMaybe $ s^.subscriptionVersionL)
-- | Render the top-level @\<opml\>@ section.
-renderOpml :: (Monad m) => Opml -> Source m Event
+renderOpml :: Monad m => Opml -> ConduitT () Event m ()
renderOpml opml = tag "opml" (attr "version" . pack . showVersion $ opml^.opmlVersionL) $ do
renderOpmlHead $ opml^.opmlHeadL
tag "body" mempty . mapM_ renderOpmlOutline $ opml^.opmlOutlinesL
diff --git a/Text/OPML/Types.hs b/Text/OPML/Types.hs
index 101c884..2a4a1a2 100644
--- a/Text/OPML/Types.hs
+++ b/Text/OPML/Types.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
-- | OPML is an XML format for outlines.
--
@@ -31,24 +32,30 @@ module Text.OPML.Types
-- ** Subscription outlines
, OutlineSubscription(..)
, mkOutlineSubscription
+ -- * Others
+ , Null()
) where
-- {{{ Imports
import Control.Monad
-
import Data.List.NonEmpty
-import Data.NonNull
-import Data.Text
+import Data.Text as Text
import Data.Time.Clock
import Data.Time.LocalTime ()
import Data.Tree
+import Data.Typeable
import Data.Version
-
import GHC.Generics
-
+import Refined hiding (NonEmpty)
import URI.ByteString
-- }}}
+-- | 'Predicate' on 'Text', true iff text is null.
+data Null deriving(Typeable)
+
+instance Predicate Null Text where
+ validate p value = unless (Text.null value) $ throwRefine $ RefineOtherException (typeOf p) "Text is not null"
+
data OpmlHead = OpmlHead
{ opmlTitle :: Text
, opmlCreated :: Maybe UTCTime
@@ -74,11 +81,11 @@ mkOpmlHead :: OpmlHead
mkOpmlHead = OpmlHead mempty mzero mzero mempty mempty mzero mzero mzero mzero mzero mzero mzero mzero
data OutlineBase = OutlineBase
- { text :: NonNull Text
+ { text :: Refined (Not Null) Text
, isComment :: Maybe Bool
, isBreakpoint :: Maybe Bool
, outlineCreated :: Maybe UTCTime
- , categories :: [NonEmpty (NonNull Text)] -- ^
+ , categories :: [NonEmpty (Refined (Not Null) Text)] -- ^
}
deriving instance Eq OutlineBase
@@ -87,7 +94,7 @@ deriving instance Show OutlineBase
-- | Smart constructor for 'OutlineBase'.
-mkOutlineBase :: NonNull Text -> OutlineBase
+mkOutlineBase :: Refined (Not Null) Text -> OutlineBase
mkOutlineBase t = OutlineBase t mzero mzero mzero mzero