opml-conduit 0.6.0.4 → 0.7.0.0

raw patch · 6 files changed

+73/−84 lines, 6 filesdep +refineddep −mono-traversablePVP ok

version bump matches the API change (PVP)

Dependencies added: refined

Dependencies removed: mono-traversable

API changes (from Hackage documentation)

Files

• Text/OPML/Conduit/Parse.hs +31/−39
• Text/OPML/Conduit/Render.hs +7/−11
• Text/OPML/Types.hs +15/−8
• opml-conduit.cabal +3/−3
• test/Arbitrary.hs +9/−15
• test/Main.hs +8/−8

@@ -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           ]

@@ -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 @\<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 @@         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 @@                              <> 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

@@ -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  

@@ -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 (<http://dev.opml.org/spec2.html>) 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

@@ -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)

@@ -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 <head>" parseOpmlHead)+inverseHeadProperty = testProperty "parse . render = id (on OpmlHead)" $ \opmlHead -> either (const False) (opmlHead ==) (runConduit $ renderOpmlHead opmlHead .| force "Invalid <head>" 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)