diff --git a/Text/OPML/Conduit/Parse.hs b/Text/OPML/Conduit/Parse.hs --- a/Text/OPML/Conduit/Parse.hs +++ b/Text/OPML/Conduit/Parse.hs @@ -20,20 +20,18 @@ -- {{{ 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.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 @@ 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 @@ | 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 @@ 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 @@ -- - 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 @@ 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 @@ 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 @@ 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 --- a/Text/OPML/Conduit/Render.hs +++ b/Text/OPML/Conduit/Render.hs @@ -16,7 +16,6 @@ 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.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 @@ 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 = decodeUtf8 . serializeURIRef' -- | Render the @\@ 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 @@ title = input ^. opmlTitleL -- | Render an @\@ 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 @@ <> optionalAttr "version" (toMaybe $ s^.subscriptionVersionL) -- | Render the top-level @\@ 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 --- 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 @@ -- ** 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 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 @@ -- | Smart constructor for 'OutlineBase'. -mkOutlineBase :: NonNull Text -> OutlineBase +mkOutlineBase :: Refined (Not Null) Text -> OutlineBase mkOutlineBase t = OutlineBase t mzero mzero mzero mzero diff --git a/opml-conduit.cabal b/opml-conduit.cabal --- a/opml-conduit.cabal +++ b/opml-conduit.cabal @@ -1,5 +1,5 @@ name: opml-conduit -version: 0.6.0.4 +version: 0.7.0.0 synopsis: Streaming parser/renderer for the OPML 2.0 format. description: This library implements the OPML 2.0 standard () as a 'conduit' parser/renderer. @@ -44,7 +44,7 @@ , safe-exceptions , lens-simple , monoid-subclasses - , mono-traversable + , refined >= 0.2 , semigroups , text , time >= 1.5 @@ -70,12 +70,12 @@ , containers , data-default , lens-simple - , mono-traversable , mtl , opml-conduit , parsers , QuickCheck , quickcheck-instances + , refined >= 0.2 , resourcet , semigroups , tasty diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -14,22 +14,15 @@ import Data.Char import Data.List.NonEmpty import Data.Maybe -import Data.MonoTraversable (Element) -import Data.NonNull -import Data.Sequences (SemiSequence) -import Data.Text (Text, find, pack) +import Data.Text as Text (Text, find, null, pack) import Data.Text.Encoding import Data.Time.Clock import Data.Tree import Data.Version - -import GHC.Generics - +import Refined hiding (NonEmpty) import Test.QuickCheck import Test.QuickCheck.Instances () - import Text.OPML.Types - import URI.ByteString -- }}} @@ -94,17 +87,18 @@ -- | Generates 'OutlineBase''s categories. -- This generator makes sure that the result has no @,@ nor @/@ characters, since those are used as separators. -genCategoryPath :: Gen (NonEmpty (NonNull Text)) +genCategoryPath :: Gen (NonEmpty (Refined (Not Null) Text)) genCategoryPath = (:|) <$> genCategory <*> listOf genCategory where - genCategory = genNonNull `suchThat` (isNothing . find (\c -> c == ',' || c == '/') . toNullable) + genCategory = arbitrary `suchThat` (isNothing . find (\c -> c == ',' || c == '/') . unrefine) -- | Alpha-numeric generator. genAlphaNum :: Gen Char genAlphaNum = oneof [choose('a', 'z'), suchThat arbitrary isDigit] --- | Non-empty mono-foldable -genNonNull :: (SemiSequence a, Arbitrary (Element a), Arbitrary a) => Gen (NonNull a) -genNonNull = ncons <$> arbitrary <*> arbitrary +instance Arbitrary (Refined (Not Null) Text) where + arbitrary = do + ~(Right t) <- refine <$> arbitrary `suchThat` (not . Text.null) + return t instance Arbitrary OpmlHead where @@ -124,7 +118,7 @@ shrink = genericShrink instance Arbitrary OutlineBase where - arbitrary = OutlineBase <$> genNonNull + arbitrary = OutlineBase <$> arbitrary <*> arbitrary <*> arbitrary <*> (Just <$> genTime) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -49,7 +49,7 @@ categoriesCase :: TestTree categoriesCase = testCase "Parse categories list" $ do dataFile <- fromString <$> getDataFileName "data/category.opml" - result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + result <- runResourceT . runConduit $ sourceFile dataFile .| XML.parseBytes def .| force "Invalid OPML" parseOpml (result ^. opmlVersionL) @?= Version [2,0] [] (result ^. opmlHeadL . opmlTitleL) @?= "Illustrating the category attribute" @@ -61,7 +61,7 @@ directoryCase :: TestTree directoryCase = testCase "Parse directory tree" $ do dataFile <- fromString <$> getDataFileName "data/directory.opml" - result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + result <- runResourceT . runConduit $ sourceFile dataFile .| XML.parseBytes def .| force "Invalid OPML" parseOpml (result ^. opmlVersionL) @?= Version [2,0] [] (result ^. opmlHeadL . opmlTitleL) @?= "scriptingNewsDirectory.opml" @@ -82,7 +82,7 @@ placesCase :: TestTree placesCase = testCase "Parse places list" $ do dataFile <- fromString <$> getDataFileName "data/placesLived.opml" - result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + result <- runResourceT . runConduit $ sourceFile dataFile .| XML.parseBytes def .| force "Invalid OPML" parseOpml (result ^. opmlVersionL) @?= Version [2,0] [] (result ^. opmlHeadL . opmlTitleL) @?= "placesLived.opml" @@ -104,7 +104,7 @@ scriptCase :: TestTree scriptCase = testCase "Parse script" $ do dataFile <- fromString <$> getDataFileName "data/simpleScript.opml" - result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + result <- runResourceT . runConduit $ sourceFile dataFile .| XML.parseBytes def .| force "Invalid OPML" parseOpml (result ^. opmlVersionL) @?= Version [2,0] [] (result ^. opmlHeadL . opmlTitleL) @?= "workspace.userlandsamples.doSomeUpstreaming" @@ -125,7 +125,7 @@ statesCase :: TestTree statesCase = testCase "Parse states list" $ do dataFile <- fromString <$> getDataFileName "data/states.opml" - result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + result <- runResourceT . runConduit $ sourceFile dataFile .| XML.parseBytes def .| force "Invalid OPML" parseOpml (result ^. opmlVersionL) @?= Version [2,0] [] (result ^. opmlHeadL . opmlTitleL) @?= "states.opml" @@ -146,7 +146,7 @@ subscriptionsCase :: TestTree subscriptionsCase = testCase "Parse subscriptions list" $ do dataFile <- fromString <$> getDataFileName "data/subscriptionList.opml" - result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= force "Invalid OPML" parseOpml + result <- runResourceT . runConduit $ sourceFile dataFile .| XML.parseBytes def .| force "Invalid OPML" parseOpml (result ^. opmlVersionL) @?= Version [2,0] [] (result ^. opmlHeadL . opmlTitleL) @?= "mySubscriptions.opml" @@ -162,7 +162,7 @@ length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineSubscription) @?= 13 inverseHeadProperty :: TestTree -inverseHeadProperty = testProperty "parse . render = id (on OpmlHead)" $ \opmlHead -> either (const False) (opmlHead ==) (runConduit $ renderOpmlHead opmlHead =$= force "Invalid " parseOpmlHead) +inverseHeadProperty = testProperty "parse . render = id (on OpmlHead)" $ \opmlHead -> either (const False) (opmlHead ==) (runConduit $ renderOpmlHead opmlHead .| force "Invalid " parseOpmlHead) -- inverseProperty :: TestTree --- inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= force "Invalid OPML" parseOpml) +-- inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml .| force "Invalid OPML" parseOpml)