opml-conduit 0.3.0.0 → 0.4.0.0
raw patch · 11 files changed
+724/−648 lines, 11 filesdep +bytestringdep +foldldep +lens-simpledep −hashabledep −hashable-timedep −lensdep ~base
Dependencies added: bytestring, foldl, lens-simple, uri-bytestring
Dependencies removed: hashable, hashable-time, lens, network-uri, unordered-containers
Dependency ranges changed: base
Files
- Text/OPML.hs +5/−8
- Text/OPML/Arbitrary.hs +0/−82
- Text/OPML/Conduit/Parse.hs +220/−0
- Text/OPML/Conduit/Render.hs +107/−0
- Text/OPML/Lens.hs +61/−0
- Text/OPML/Stream/Parse.hs +0/−189
- Text/OPML/Stream/Render.hs +0/−100
- Text/OPML/Types.hs +52/−182
- opml-conduit.cabal +22/−18
- test/Arbitrary.hs +170/−0
- test/Main.hs +87/−69
Text/OPML.hs view
@@ -1,10 +1,7 @@--- | This module re-exports commonly used modules:------ - 'Text.OPML.Stream.Parse'--- - 'Text.OPML.Stream.Render'--- - 'Text.OPML.Types'+-- | This module re-exports all the package modules. module Text.OPML (module X) where -import Text.OPML.Stream.Parse as X-import Text.OPML.Stream.Render as X-import Text.OPML.Types as X+import Text.OPML.Conduit.Parse as X+import Text.OPML.Conduit.Render as X+import Text.OPML.Lens as X+import Text.OPML.Types as X
− Text/OPML/Arbitrary.hs
@@ -1,82 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}--- | External 'Arbitrary' instances used by OPML types.--- All instances are defined through the 'OpmlGen' wrapper to avoid conflicts.-module Text.OPML.Arbitrary where---- {{{ Imports-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)-import Data.Time.Clock-import Data.Version--import GHC.Generics--import Network.URI--import Test.QuickCheck-import Test.QuickCheck.Instances ()--- }}}--newtype OpmlGen a = OpmlGen { unwrap :: a }-deriving instance (Generic a) => Generic (OpmlGen a)-instance (Arbitrary (OpmlGen a)) => Arbitrary (OpmlGen (Maybe a)) where- arbitrary = do- a <- arbitrary :: Gen (Maybe ())- (OpmlGen result) <- arbitrary- return . OpmlGen $ maybe Nothing (const $ Just result) a---- | OPML version may only be @1.0@, @1.1@ or @2.0@-instance Arbitrary (OpmlGen Version) where- arbitrary = OpmlGen <$> (Version <$> elements [ [1, 0], [1, 1], [2, 0] ] <*> pure [])- shrink (OpmlGen (Version a b)) = OpmlGen <$> (Version <$> shrink a <*> shrink b)---- | Reasonable enough 'URI' generator.-instance Arbitrary (OpmlGen URI) where- arbitrary = OpmlGen <$> (URI <$> genUriScheme <*> (unwrap <$> arbitrary) <*> genUriPath <*> genUriQuery <*> genUriFragment)- where genUriPath = ("/" ++) <$> listOf1 genAlphaNum- genUriQuery = oneof [return "", ("?" ++) <$> listOf1 genAlphaNum]- genUriFragment = oneof [return "", ("#" ++) <$> listOf1 genAlphaNum]- genUriScheme = (++ ":") <$> listOf1 (choose('a', 'z'))- -- shrink = genericShrink---- | Reasonable enough 'URIAuth' generator.-instance Arbitrary (OpmlGen URIAuth) where- arbitrary = do- userInfo <- oneof [return "", (++ "@") <$> listOf1 genAlphaNum]- regName <- listOf1 genAlphaNum- port <- oneof [return "", (\x -> ":" ++ x) . show <$> choose(1 :: Int, 65535)]- return . OpmlGen $ URIAuth userInfo regName port- -- shrink = genericShrink----- | Generates 'UTCTime' with rounded seconds.-instance Arbitrary (OpmlGen UTCTime) where- arbitrary = do- (UTCTime d s) <- arbitrary- return . OpmlGen $ UTCTime d (fromIntegral (round s :: Int))- -- shrink = genericShrink---- | Generates 'OutlineBase''s categories.--- This generator makes sure that the result has no @,@ nor @/@ characters, since those are used as separators.-instance Arbitrary (OpmlGen [NonEmpty (NonNull Text)]) where- arbitrary = OpmlGen <$> listOf genCategoryPath- where genCategory = genNonNull `suchThat` (isNothing . find (\c -> c == ',' || c == '/') . toNullable)- genCategoryPath = (:|) <$> genCategory <*> listOf genCategory- -- shrink = genericShrink---- | 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
+ Text/OPML/Conduit/Parse.hs view
@@ -0,0 +1,220 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+-- | Streaming parser for the OPML 2.0 standard.+--+-- The parser tries to be as lenient as possible. All functions may throw an 'OpmlException'.+module Text.OPML.Conduit.Parse+ ( -- * Parsers+ parseOpml+ , parseOpmlHead+ , parseOpmlOutline+ -- * Exceptions+ , OpmlException(..)+ ) where++-- {{{ Imports+import Control.Applicative+import Control.Foldl as Fold+import Control.Monad+import Control.Monad.Catch++import Data.CaseInsensitive hiding (map)+import Data.Conduit.Parser+import Data.Conduit.Parser.XML+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.Encoding+import Data.Time.Clock+import Data.Time.LocalTime+import Data.Time.RFC822+import Data.Tree+import Data.Version+import Data.XML.Types++import Lens.Simple++import Numeric++import Prelude hiding (last)++import Text.OPML.Types+import Text.Parser.Combinators+import Text.ParserCombinators.ReadP (readP_to_S)++import URI.ByteString+-- }}}++data OpmlException = MissingText+ | InvalidBool Text+ | InvalidDecimal Text+ | InvalidTime Text+ | InvalidURI URIParseError+ | InvalidVersion Text++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 (InvalidDecimal t) = "Invalid decimal: " ++ 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+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+ [(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+ (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++asTime :: (MonadThrow m) => Text -> m UTCTime+asTime t = maybe (throwM $ InvalidTime t) (return . zonedTimeToUTC) $ parseTimeRFC822 t++-- The standard only accepts "true", and "false",+-- but it doesn't hurt to be more lenient+asBool :: (MonadThrow m) => Text -> m Bool+asBool t+ | mk t == "true" = return True+ | 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 (== ',')++dateTag :: (MonadCatch m) => Name -> ConduitParser Event m UTCTime+dateTag name = tagName name ignoreAttrs $ \_ -> content asTime++uriTag :: (MonadCatch m) => Name -> ConduitParser Event m URI+uriTag name = tagName name ignoreAttrs $ \_ -> content asURI++expansionStateTag :: (MonadCatch m, Integral a) => ConduitParser Event m [a]+expansionStateTag = tagName "expansionState" ignoreAttrs $ \_ -> content asExpansionState++textTag :: (MonadCatch m) => Name -> ConduitParser Event m Text+textTag name = tagName name ignoreAttrs $ const textContent++decimalTag :: (Integral a, MonadCatch m) => Name -> ConduitParser Event m a+decimalTag name = tagName name ignoreAttrs $ const $ content asDecimal++unknownTag :: (MonadCatch m) => ConduitParser Event m ()+unknownTag = tagPredicate (const True) ignoreAttrs $ \_ -> 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+ | HeadUnknown++makeTraversals ''HeadPiece+++-- | Parse the @\<head\>@ section.+-- This function is more lenient than what the standard demands on the following points:+--+-- - each sub-element may be repeated, in which case only the last occurrence is taken into account;+-- - each unknown sub-element is ignored.+parseOpmlHead :: (MonadCatch m) => ConduitParser Event m OpmlHead+parseOpmlHead = named "OPML <head> section" $ tagName "head" ignoreAttrs $ \_ -> do+ p <- many $ choice piece+ return $ flip fold p $ OpmlHead+ <$> handles _HeadTitle (lastDef mempty)+ <*> handles _HeadCreated last+ <*> handles _HeadModified last+ <*> handles _HeadOwnerName (lastDef mempty)+ <*> handles _HeadOwnerEmail (lastDef mempty)+ <*> handles _HeadOwnerId last+ <*> handles _HeadDocs last+ <*> handles _HeadExpansionState Fold.mconcat+ <*> handles _HeadVertScrollState last+ <*> handles _HeadWindowBottom last+ <*> handles _HeadWindowLeft last+ <*> handles _HeadWindowRight last+ <*> handles _HeadWindowTop last+ where piece = [ HeadCreated <$> dateTag "dateCreated"+ , HeadModified <$> dateTag "dateModified"+ , HeadDocs <$> uriTag "docs"+ , HeadExpansionState <$> expansionStateTag+ , HeadOwnerEmail <$> textTag "ownerEmail"+ , HeadOwnerId <$> uriTag "ownerId"+ , HeadOwnerName <$> textTag "ownerName"+ , HeadTitle <$> textTag "title"+ , HeadVertScrollState <$> decimalTag "vertScrollState"+ , HeadWindowBottom <$> decimalTag "windowBottom"+ , HeadWindowLeft <$> decimalTag "windowLeft"+ , HeadWindowRight <$> decimalTag "windowRight"+ , HeadWindowTop <$> decimalTag "windowTop"+ , HeadUnknown <$ unknownTag+ ]+++-- | Parse an @\<outline\>@ section.+-- The value of type attributes are not case-sensitive, that is @type=\"LINK\"@ has the same meaning as @type="link"@.+parseOpmlOutline :: (MonadCatch m) => ConduitParser Event m (Tree OpmlOutline)+parseOpmlOutline = tagName "outline" attributes handler <?> "OPML <outline> section" where+ attributes = do+ otype <- optional $ textAttr "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+ baseAttr = (,,,,) <$> attr "text" asNonNull+ <*> optional (attr "isComment" asBool)+ <*> optional (attr "isBreakpoint" asBool)+ <*> optional (attr "created" asTime)+ <*> optional (attr "category" (Just . asCategories))+ linkAttr = textAttr "url"+ subscriptionAttr = (,,,,,) <$> attr "xmlUrl" asURI+ <*> optional (attr "htmlUrl" asURI)+ <*> optional (textAttr "description")+ <*> optional (textAttr "language")+ <*> optional (textAttr "title")+ <*> optional (textAttr "version")+ 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))+ <*> many parseOpmlOutline+ 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)++-- | Parse the top-level @\<opml\>@ element.+parseOpml :: (MonadCatch m) => ConduitParser Event m Opml+parseOpml = tagName "opml" attributes handler <?> "<opml> section" where+ attributes = attr "version" asVersion <* ignoreAttrs+ handler version = Opml version+ <$> parseOpmlHead+ <*> tagName "body" ignoreAttrs (const $ many parseOpmlOutline) <?> "<body> section."
+ Text/OPML/Conduit/Render.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+-- | Streaming renderer for the OPML 2.0 standard.+module Text.OPML.Conduit.Render+ ( -- * Renderers+ renderOpmlHead+ , renderOpmlOutline+ , renderOpml+ ) where++-- {{{ Imports+import Control.Monad++import Data.Conduit+import Data.List.NonEmpty hiding (filter, map)+import Data.Monoid+import Data.NonNull+import Data.Text (Text, intercalate, pack, toLower)+import Data.Text.Encoding+import Data.Time.Clock+import Data.Time.LocalTime+import Data.Time.RFC822+import Data.Tree+import Data.Version+import Data.XML.Types++import Lens.Simple++import Prelude hiding (foldr, lookup)++import Text.OPML.Lens+import Text.OPML.Types+import Text.XML.Stream.Render++import URI.ByteString+-- }}}++tshow :: (Show a) => a -> Text+tshow = pack . show++empty :: (Eq s, Monoid s) => s -> Bool+empty t = t == mempty++toMaybe :: (Eq s, Monoid s) => s -> Maybe s+toMaybe s | s == mempty = mempty+ | otherwise = Just s++formatTime :: UTCTime -> Text+formatTime = formatTimeRFC822 . utcToZonedTime utc++formatCategories :: [NonEmpty (NonNull Text)] -> Maybe Text+formatCategories = toMaybe . intercalate "," . map (intercalate "/" . toList . fmap toNullable)++formatBool :: Bool -> Text+formatBool = toLower . tshow++formatURI :: URI -> Text+formatURI = decodeUtf8 . serializeURI'++-- | Render the @\<head\>@ section.+renderOpmlHead :: (Monad m) => OpmlHead -> Source m Event+renderOpmlHead input = tag "head" mempty $ do+ forM_ (input^.opmlCreatedL) $ tag "dateCreated" mempty . content . formatTime+ forM_ (input^.modifiedL) $ tag "dateModified" mempty . content . formatTime+ forM_ (input^.docsL) $ tag "docs" mempty . content . formatURI+ unless (null es) $ tag "expansionState" mempty . content . intercalate "," $ tshow <$> es+ unless (empty email) $ tag "ownerEmail" mempty $ content email+ forM_ (input^.ownerIdL) $ tag "ownerId" mempty . content . formatURI+ unless (empty name) $ tag "ownerName" mempty $ content name+ unless (empty title) $ tag "title" mempty $ content title+ forM_ (input^.vertScrollStateL) $ tag "vertScrollState" mempty . content . tshow+ forM_ (input^.windowBottomL) $ tag "windowBottom" mempty . content . tshow+ forM_ (input^.windowLeftL) $ tag "windowLeft" mempty . content . tshow+ forM_ (input^.windowRightL) $ tag "windowRight" mempty . content . tshow+ forM_ (input^.windowTopL) $ tag "windowTop" mempty . content . tshow+ where es = input ^.. expansionStateL+ email = input ^. ownerEmailL+ name = input ^. ownerNameL+ title = input ^. opmlTitleL++-- | Render an @\<outline\>@ section.+renderOpmlOutline :: (Monad m) => Tree OpmlOutline -> Source m Event+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)+ <> optionalAttr "isComment" (formatBool <$> b^.isCommentL)+ <> optionalAttr "isBreakpoint" (formatBool <$> b^.isBreakpointL)+ <> optionalAttr "created" (formatTime <$> b^.outlineCreatedL)+ <> optionalAttr "category" (formatCategories $ b^.categoriesL)+ subscriptionAttr s = attr "type" "rss"+ <> attr "xmlUrl" (formatURI $ s^.xmlUriL)+ <> optionalAttr "htmlUrl" (formatURI <$> s^.htmlUriL)+ <> optionalAttr "description" (toMaybe $ s^.descriptionL)+ <> optionalAttr "language" (toMaybe $ s^.languageL)+ <> optionalAttr "title" (toMaybe $ s^.subscriptionTitleL)+ <> optionalAttr "version" (toMaybe $ s^.subscriptionVersionL)++-- | Render the top-level @\<opml\>@ section.+renderOpml :: (Monad m) => Opml -> Source m Event+renderOpml opml = tag "opml" (attr "version" . pack . showVersion $ opml^.opmlVersionL) $ do+ renderOpmlHead $ opml^.opmlHeadL+ tag "body" mempty . mapM_ renderOpmlOutline $ opml^.opmlOutlinesL
+ Text/OPML/Lens.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+module Text.OPML.Lens where++-- {{{ Imports+import Lens.Simple++import Text.OPML.Types+-- }}}++-- * 'Opml' lenses+makeLensesFor+ [ ("opmlVersion", "opmlVersionL")+ , ("opmlHead", "opmlHeadL")+ , ("opmlOutlines", "opmlOutlinesL")+ ] ''Opml++-- * 'OpmlHead' lenses+makeLensesFor+ [ ("opmlTitle", "opmlTitleL")+ , ("opmlCreated", "opmlCreatedL")+ , ("modified", "modifiedL")+ , ("ownerName", "ownerNameL")+ , ("ownerEmail", "ownerEmailL")+ , ("ownerId", "ownerIdL")+ , ("docs", "docsL")+ -- , ("expansionState", "expansionStateL")+ , ("vertScrollState", "vertScrollStateL")+ , ("windowBottom", "windowBottomL")+ , ("windowLeft", "windowLeftL")+ , ("windowRight", "windowRightL")+ , ("windowTop", "windowTopL")+ ] ''OpmlHead++expansionStateL :: Traversal' OpmlHead Int+expansionStateL inj a@OpmlHead { expansionState = es } = (\x -> a { expansionState = x }) <$> sequenceA (map inj es)+{-# INLINE expansionStateL #-}++-- * 'OutlineSubscription' lenses+makeLensesFor+ [ ("xmlUri", "xmlUriL")+ , ("htmlUri", "htmlUriL")+ , ("description", "descriptionL")+ , ("language", "languageL")+ , ("subscriptionTitle", "subscriptionTitleL")+ , ("subscriptionVersion", "subscriptionVersionL")+ ] ''OutlineSubscription++-- * 'OutlineBase' lenses+makeLensesFor+ [ ("text", "textL")+ , ("isComment", "isCommentL")+ , ("isBreakpoint", "isBreakpointL")+ , ("outlineCreated", "outlineCreatedL")+ , ("categories", "categoriesL")+ ] ''OutlineBase+++-- * 'OpmlOutline' traversals+makeTraversals ''OpmlOutline
− Text/OPML/Stream/Parse.hs
@@ -1,189 +0,0 @@-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}--- | Streaming parser for the OPML 2.0 standard.------ The parser tries to be as lenient as possible. All functions may throw an 'OpmlException'.-module Text.OPML.Stream.Parse- ( -- * Parsers- parseOpml- , parseOpmlHead- , parseOpmlOutline- ) where---- {{{ Imports-import Control.Applicative-import Control.Lens.At-import Control.Lens.Setter-import Control.Monad-import Control.Monad.Catch--import Data.CaseInsensitive hiding (map)-import Data.Conduit.Parser-import Data.Conduit.Parser.XML-import Data.Default-import Data.List.NonEmpty hiding (filter, map)-import Data.Maybe-import Data.Monoid-import Data.Monoid.Textual hiding (map)-import Data.MonoTraversable-import Data.NonNull-import Data.Text (Text, strip, unpack)-import Data.Time.Clock-import Data.Time.LocalTime-import Data.Time.RFC822-import Data.Tree-import Data.Version-import Data.XML.Types--import Network.URI (URI, parseURI)--import Numeric--import Text.OPML.Types-import Text.Parser.Combinators-import Text.ParserCombinators.ReadP (readP_to_S)--- }}}--data OpmlException = MissingText- | InvalidBool Text- | InvalidDecimal Text- | InvalidTime Text- | InvalidURI Text- | InvalidVersion Text--deriving instance Eq OpmlException-instance Show OpmlException where- show MissingText = "An outline is missing the 'text' attribute."- show (InvalidBool t) = "Invalid boolean: " ++ unpack t- show (InvalidDecimal t) = "Invalid decimal: " ++ unpack t- show (InvalidURI t) = "Invalid URI: " ++ unpack t- show (InvalidTime t) = "Invalid time: " ++ unpack t- show (InvalidVersion t) = "Invalid version: " ++ unpack t-instance Exception OpmlException--asURI :: (MonadThrow m) => Text -> m URI-asURI t = maybe (throwM $ InvalidURI t) return . parseURI $ unpack t--asVersion :: (MonadThrow m) => Text -> m Version-asVersion v = case filter (onull . 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- (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--asTime :: (MonadThrow m) => Text -> m UTCTime-asTime t = maybe (throwM $ InvalidTime t) (return . zonedTimeToUTC) $ parseTimeRFC822 t---- The standard only accepts "true", and "false",--- but it doesn't hurt to be more lenient-asBool :: (MonadThrow m) => Text -> m Bool-asBool t- | mk t == "true" = return True- | 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 (== ',')---dateCreated, dateModified :: MonadCatch m => ConduitParser Event m UTCTime-dateCreated = tagName "dateCreated" ignoreAttrs $ \_ -> content asTime-dateModified = tagName "dateModified" ignoreAttrs $ \_ -> content asTime--docs, ownerId :: MonadCatch m => ConduitParser Event m URI-docs = tagName "docs" ignoreAttrs $ \_ -> content asURI-ownerId = tagName "ownerId" ignoreAttrs $ \_ -> content asURI--expansionState :: (MonadCatch m, Integral a) => ConduitParser Event m [a]-expansionState = tagName "expansionState" ignoreAttrs $ \_ -> content asExpansionState--ownerEmail, ownerName, opmlTitle :: MonadCatch m => ConduitParser Event m Text-ownerEmail = tagName "ownerEmail" ignoreAttrs $ const textContent-ownerName = tagName "ownerName" ignoreAttrs $ const textContent-opmlTitle = tagName "title" ignoreAttrs $ const textContent--vertScrollState, windowBottom, windowLeft, windowRight, windowTop :: (MonadCatch m, Integral a) => ConduitParser Event m a-vertScrollState = tagName "vertScrollState" ignoreAttrs $ \_ -> content asDecimal-windowBottom = tagName "windowBottom" ignoreAttrs $ \_ -> content asDecimal-windowLeft = tagName "windowLeft" ignoreAttrs $ \_ -> content asDecimal-windowRight = tagName "windowRight" ignoreAttrs $ \_ -> content asDecimal-windowTop = tagName "windowTop" ignoreAttrs $ \_ -> content asDecimal---opmlHeadBuilders :: MonadCatch m => [ConduitParser Event m (Endo OpmlHead)]-opmlHeadBuilders = [ liftM (Endo . set opmlCreated_ . Just) dateCreated- , liftM (Endo . set modified_ . Just) dateModified- , liftM (Endo . set docs_ . Just) docs- , liftM (Endo . set expansionState_) expansionState- , liftM (Endo . set ownerEmail_) ownerEmail- , liftM (Endo . set ownerId_ . Just) ownerId- , liftM (Endo . set ownerName_) ownerName- , liftM (Endo . set opmlTitle_) opmlTitle- , liftM (Endo . set vertScrollState_ . Just) vertScrollState- , liftM (Endo . set (window_.at Bottom') . Just) windowBottom- , liftM (Endo . set (window_.at Left') . Just) windowLeft- , liftM (Endo . set (window_.at Right') . Just) windowRight- , liftM (Endo . set (window_.at Top') . Just) windowTop- , unknown >> return mempty- ]- where unknown = tagPredicate (const True) ignoreAttrs $ \_ -> return ()---- | Parse the @\<head\>@ section.--- This function is more lenient than what the standard demands on the following points:------ - each sub-element may be repeated, in which case only the last occurrence is taken into account;--- - each unknown sub-element is ignored.-parseOpmlHead :: (MonadCatch m) => ConduitParser Event m OpmlHead-parseOpmlHead = named "OPML <head> section" $ tagName "head" ignoreAttrs $ \_ -> do- builders <- many $ choice opmlHeadBuilders- return $ (appEndo $ mconcat builders) def---- | Parse an @\<outline\>@ section.--- The value of type attributes are not case-sensitive, that is @type=\"LINK\"@ has the same meaning as @type="link"@.-parseOpmlOutline :: (MonadCatch m) => ConduitParser Event m (Tree OpmlOutline)-parseOpmlOutline = tagName "outline" attributes handler <?> "OPML <outline> section" where- attributes = do- otype <- optional $ textAttr "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- baseAttr = (,,,,) <$> attr "text" asNonNull- <*> optional (attr "isComment" asBool)- <*> optional (attr "isBreakpoint" asBool)- <*> optional (attr "created" asTime)- <*> optional (attr "category" (Just . asCategories))- linkAttr = textAttr "url"- subscriptionAttr = (,,,,,) <$> attr "xmlUrl" asURI- <*> optional (attr "htmlUrl" asURI)- <*> optional (textAttr "description")- <*> optional (textAttr "language")- <*> optional (textAttr "title")- <*> optional (textAttr "version")- 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))- <*> many parseOpmlOutline- baseHandler (text, comment, breakpoint, created, category) = return $ OutlineBase text comment breakpoint created (fromMaybe mempty category)- subscriptionHandler (uri, html, description, language, title, version) = OutlineSubscription uri html (fromMaybe mempty description) (fromMaybe mempty language) (fromMaybe mempty title) (fromMaybe mempty version)---- | Parse the top-level @\<opml\>@ element.-parseOpml :: (MonadCatch m) => ConduitParser Event m Opml-parseOpml = tagName "opml" attributes handler <?> "<opml> section" where- attributes = attr "version" asVersion <* ignoreAttrs- handler version = Opml version- <$> parseOpmlHead- <*> tagName "body" ignoreAttrs (const $ many parseOpmlOutline) <?> "<body> section."
− Text/OPML/Stream/Render.hs
@@ -1,100 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--- | Streaming renderer for the OPML 2.0 standard.-module Text.OPML.Stream.Render- ( -- * Renderers- renderOpmlHead- , renderOpmlOutline- , renderOpml- ) where---- {{{ Imports-import Control.Lens.At-import Control.Lens.Getter-import Control.Monad--import Data.Conduit-import Data.List.NonEmpty hiding (filter, map)-import Data.Monoid-import Data.NonNull-import Data.Text (Text, intercalate, pack, toLower)-import Data.Time.Clock-import Data.Time.LocalTime-import Data.Time.RFC822-import Data.Tree-import Data.Version-import Data.XML.Types--import Prelude hiding (foldr, lookup)--import Text.OPML.Types-import Text.XML.Stream.Render--- }}}--tshow :: (Show a) => a -> Text-tshow = pack . show--empty :: (Eq s, Monoid s) => s -> Bool-empty t = t == mempty--toMaybe :: (Eq s, Monoid s) => s -> Maybe s-toMaybe s | s == mempty = mempty- | otherwise = Just s--formatTime :: UTCTime -> Text-formatTime = formatTimeRFC822 . utcToZonedTime utc--formatCategories :: [NonEmpty (NonNull Text)] -> Maybe Text-formatCategories = toMaybe . intercalate "," . map (intercalate "/" . toList . fmap toNullable)--formatBool :: Bool -> Text-formatBool = toLower . tshow---- | Render the @\<head\>@ section.-renderOpmlHead :: (Monad m) => OpmlHead -> Source m Event-renderOpmlHead input = tag "head" mempty $ do- forM_ (input^.opmlCreated_) $ tag "dateCreated" mempty . content . formatTime- forM_ (input^.modified_) $ tag "dateModified" mempty . content . formatTime- forM_ (input^.docs_) $ tag "docs" mempty . content . tshow- unless (null es) . tag "expansionState" mempty . content . intercalate "," $ tshow <$> es- unless (empty email) $ tag "ownerEmail" mempty $ content email- forM_ (input^.ownerId_) $ tag "ownerId" mempty . content . tshow- unless (empty name) $ tag "ownerName" mempty $ content name- unless (empty title) $ tag "title" mempty $ content title- forM_ (input^.vertScrollState_) $ tag "vertScrollState" mempty . content . tshow- forM_ (input^.window_.at Bottom') $ tag "windowBottom" mempty . content . tshow- forM_ (input^.window_.at Left') $ tag "windowLeft" mempty . content . tshow- forM_ (input^.window_.at Right') $ tag "windowRight" mempty . content . tshow- forM_ (input^.window_.at Top') $ tag "windowTop" mempty . content . tshow- where es = input ^. expansionState_- email = input ^. ownerEmail_- name = input ^. ownerName_- title = input ^. opmlTitle_---- | Render an @\<outline\>@ section.-renderOpmlOutline :: (Monad m) => Tree OpmlOutline -> Source m Event-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" (tshow uri)- OpmlOutlineSubscription b s -> baseAttr b <> subscriptionAttr s- baseAttr b = attr "text" (toNullable $ b^.text_)- <> optionalAttr "isComment" (formatBool <$> b^.isComment_)- <> optionalAttr "isBreakpoint" (formatBool <$> b^.isBreakpoint_)- <> optionalAttr "created" (formatTime <$> b^.outlineCreated_)- <> optionalAttr "category" (formatCategories $ b^.categories_)- subscriptionAttr s = attr "type" "rss"- <> attr "xmlUrl" (tshow $ s^.xmlUri_)- <> optionalAttr "htmlUrl" (tshow <$> s^.htmlUri_)- <> optionalAttr "description" (toMaybe $ s^.description_)- <> optionalAttr "language" (toMaybe $ s^.language_)- <> optionalAttr "title" (toMaybe $ s^.subscriptionTitle_)- <> optionalAttr "version" (toMaybe $ s^.subscriptionVersion_)---- | Render the top-level @\<opml\>@ section.-renderOpml :: (Monad m) => Opml -> Source m Event-renderOpml opml = tag "opml" (attr "version" . pack . showVersion $ opml^.opmlVersion_) $ do- renderOpmlHead $ opml^.head_- tag "body" mempty . mapM_ renderOpmlOutline $ opml^.outlines_
Text/OPML/Types.hs view
@@ -1,10 +1,8 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-} -- | OPML is an XML format for outlines. -- -- Example:@@ -22,54 +20,23 @@ module Text.OPML.Types ( -- * Top-level OPML structure Opml(..)- , opmlVersion_- , head_- , outlines_+ , mkOpml -- * OPML header , OpmlHead(..)- , Direction(..)- , opmlTitle_- , opmlCreated_- , modified_- , ownerName_- , ownerEmail_- , ownerId_- , docs_- , expansionState_- , vertScrollState_- , window_+ , mkOpmlHead -- * OPML outlines , OpmlOutline(..)- , _OpmlOutlineGeneric- , _OpmlOutlineLink- , _OpmlOutlineSubscription -- ** Generic outlines , OutlineBase(..) , mkOutlineBase- , text_- , isComment_- , isBreakpoint_- , outlineCreated_- , categories_ -- ** Subscription outlines , OutlineSubscription(..) , mkOutlineSubscription- , xmlUri_- , htmlUri_- , description_- , language_- , subscriptionTitle_- , subscriptionVersion_ ) where -- {{{ Imports-import Control.Lens.TH import Control.Monad -import Data.Default-import Data.Hashable-import Data.Hashable.Time ()-import Data.HashMap.Lazy import Data.List.NonEmpty import Data.NonNull import Data.Text@@ -80,127 +47,64 @@ import GHC.Generics -import Network.URI--import Test.QuickCheck-import Text.OPML.Arbitrary+import URI.ByteString -- }}} --- Orphan instance-instance (Hashable a) => Hashable (NonNull a) where- hashWithSalt s = hashWithSalt s . toNullable--data Direction = Top' | Left' | Bottom' | Right' deriving(Eq, Generic, Show)--instance Hashable Direction--instance Arbitrary Direction where- arbitrary = elements [Top', Left', Right', Bottom']- shrink = genericShrink---declareLenses [d|- data OpmlHead = OpmlHead- { opmlTitle_ :: Text- , opmlCreated_ :: Maybe UTCTime- , modified_ :: Maybe UTCTime- , ownerName_ :: Text- , ownerEmail_ :: Text- , ownerId_ :: Maybe URI- , docs_ :: Maybe URI- , expansionState_ :: [Int]- , vertScrollState_ :: Maybe Int- , window_ :: HashMap Direction Int- }- |]+data OpmlHead = OpmlHead+ { opmlTitle :: Text+ , opmlCreated :: Maybe UTCTime+ , modified :: Maybe UTCTime+ , ownerName :: Text+ , ownerEmail :: Text+ , ownerId :: Maybe URI+ , docs :: Maybe URI+ , expansionState :: [Int]+ , vertScrollState :: Maybe Int+ , windowBottom :: Maybe Int+ , windowLeft :: Maybe Int+ , windowRight :: Maybe Int+ , windowTop :: Maybe Int+ } deriving instance Eq OpmlHead deriving instance Generic OpmlHead deriving instance Show OpmlHead--- instance Hashable OpmlHead --- | Use 'def' as a smart constructor. All fields are set to 'mempty'.-instance Default OpmlHead where- def = OpmlHead mempty mzero mzero mempty mempty mzero mzero mzero mzero mempty--instance Arbitrary OpmlHead where- arbitrary = OpmlHead <$> arbitrary- <*> (unwrap <$> arbitrary)- <*> (unwrap <$> arbitrary)- <*> arbitrary- <*> arbitrary- <*> (unwrap <$> arbitrary)- <*> (unwrap <$> arbitrary)- <*> arbitrary- <*> arbitrary- <*> arbitrary- shrink (OpmlHead a b c d e f g h i j) = OpmlHead <$> shrink a- <*> (unwrap <$> shrink (OpmlGen b))- <*> (unwrap <$> shrink (OpmlGen c))- <*> shrink d- <*> shrink e- <*> (unwrap <$> shrink (OpmlGen f))- <*> (unwrap <$> shrink (OpmlGen g))- <*> shrink h- <*> shrink i- <*> shrink j+-- | Bare 'OpmlHead', all fields are set to 'mempty'.+mkOpmlHead :: OpmlHead+mkOpmlHead = OpmlHead mempty mzero mzero mempty mempty mzero mzero mzero mzero mzero mzero mzero mzero -declareLenses [d|- data OutlineBase = OutlineBase- { text_ :: NonNull Text- , isComment_ :: Maybe Bool- , isBreakpoint_ :: Maybe Bool- , outlineCreated_ :: Maybe UTCTime- , categories_ :: [NonEmpty (NonNull Text)] -- ^- }- |]+data OutlineBase = OutlineBase+ { text :: NonNull Text+ , isComment :: Maybe Bool+ , isBreakpoint :: Maybe Bool+ , outlineCreated :: Maybe UTCTime+ , categories :: [NonEmpty (NonNull Text)] -- ^+ } deriving instance Eq OutlineBase deriving instance Generic OutlineBase deriving instance Show OutlineBase-instance Hashable OutlineBase -instance Arbitrary OutlineBase where- arbitrary = OutlineBase <$> genNonNull- <*> arbitrary- <*> arbitrary- <*> (unwrap <$> arbitrary)- <*> (unwrap <$> arbitrary)- shrink (OutlineBase _ b c d e) = OutlineBase <$> []- <*> shrink b- <*> shrink c- <*> shrink d- <*> (unwrap <$> shrink (OpmlGen e)) -- | Smart constructor for 'OutlineBase'. mkOutlineBase :: NonNull Text -> OutlineBase mkOutlineBase t = OutlineBase t mzero mzero mzero mzero -declareLenses [d|- data OutlineSubscription = OutlineSubscription- { xmlUri_ :: URI- , htmlUri_ :: Maybe URI- , description_ :: Text- , language_ :: Text- , subscriptionTitle_ :: Text- , subscriptionVersion_ :: Text- }- |]+data OutlineSubscription = OutlineSubscription+ { xmlUri :: URI+ , htmlUri :: Maybe URI+ , description :: Text+ , language :: Text+ , subscriptionTitle :: Text+ , subscriptionVersion :: Text+ } deriving instance Eq OutlineSubscription deriving instance Generic OutlineSubscription deriving instance Show OutlineSubscription--- instance Hashable OutlineSubscription -instance Arbitrary OutlineSubscription where- arbitrary = OutlineSubscription <$> (unwrap <$> arbitrary)- <*> (unwrap <$> arbitrary)- <*> arbitrary- <*> arbitrary- <*> arbitrary- <*> arbitrary- shrink (OutlineSubscription a b c d e f) = OutlineSubscription <$> (unwrap <$> shrink (OpmlGen a)) <*> (unwrap <$> shrink (OpmlGen b)) <*> shrink c <*> shrink d <*> shrink e <*> shrink f -- | Smart constructor for 'OutlineSubscription' mkOutlineSubscription :: URI -> OutlineSubscription@@ -208,58 +112,24 @@ -- | Outlines are the main payload of an OPML document.-declarePrisms [d|- data OpmlOutline = OpmlOutlineGeneric OutlineBase Text- | OpmlOutlineLink OutlineBase URI- | OpmlOutlineSubscription OutlineBase OutlineSubscription- |]+data OpmlOutline = OpmlOutlineGeneric OutlineBase Text+ | OpmlOutlineLink OutlineBase URI+ | OpmlOutlineSubscription OutlineBase OutlineSubscription deriving instance Eq OpmlOutline deriving instance Generic OpmlOutline deriving instance Show OpmlOutline--- instance Hashable OpmlOutline -instance Arbitrary OpmlOutline where- arbitrary = oneof [ OpmlOutlineGeneric <$> arbitrary <*> arbitrary- , OpmlOutlineLink <$> arbitrary <*> (unwrap <$> arbitrary)- , OpmlOutlineSubscription <$> arbitrary <*> arbitrary- ]- shrink (OpmlOutlineGeneric a b) = OpmlOutlineGeneric <$> shrink a <*> shrink b- shrink (OpmlOutlineLink a b) = OpmlOutlineLink <$> shrink a <*> (unwrap <$> shrink (OpmlGen b))- shrink (OpmlOutlineSubscription a b) = OpmlOutlineSubscription <$> shrink a <*> shrink b---declareLenses [d|- data Opml = Opml- { opmlVersion_ :: Version- , head_ :: OpmlHead- , outlines_ :: Forest OpmlOutline- }- |]+data Opml = Opml+ { opmlVersion :: Version+ , opmlHead :: OpmlHead+ , opmlOutlines :: Forest OpmlOutline+ } deriving instance Eq Opml deriving instance Generic Opml deriving instance Show Opml--- instance Hashable Opml -instance Default Opml where- def = Opml (makeVersion [2, 0]) def mempty--instance Arbitrary Opml where- arbitrary = do- degree <- choose (0, 100)- Opml <$> (unwrap <$> arbitrary)- <*> arbitrary- <*> vectorOf degree (genOutlineTree 1)- shrink (Opml a b c) = Opml <$> (unwrap <$> shrink (OpmlGen a)) <*> shrink b <*> shrink c---- | Generate a tree of outlines with the given maximum depth.--- This generator makes sure that only 'OpmlOutlineGeneric' may have children.-genOutlineTree :: Int -> Gen (Tree OpmlOutline)-genOutlineTree n = do- root <- arbitrary- degree <- choose (0, 100)- case (n > 1, root) of- (True, OpmlOutlineGeneric _ _) -> Node <$> pure root <*> vectorOf degree (genOutlineTree (n-1))- (False, OpmlOutlineGeneric _ _) -> return $ Node root []- _ -> return $ Node root []+-- | Bare 'Opml'. Version is set to @2.0@.+mkOpml :: Opml+mkOpml = Opml (makeVersion [2, 0]) mkOpmlHead mempty
opml-conduit.cabal view
@@ -1,5 +1,5 @@ name: opml-conduit-version: 0.3.0.0+version: 0.4.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.@@ -26,9 +26,9 @@ library exposed-modules: Text.OPML- Text.OPML.Arbitrary- Text.OPML.Stream.Parse- Text.OPML.Stream.Render+ Text.OPML.Lens+ Text.OPML.Conduit.Parse+ Text.OPML.Conduit.Render Text.OPML.Types build-depends: base >= 4.8 && < 5@@ -36,22 +36,17 @@ , conduit , conduit-parse , containers- , data-default , exceptions- , hashable- , hashable-time- , lens+ , foldl+ , lens-simple , monoid-subclasses , mono-traversable- , network-uri >= 2.6 , parsers- , QuickCheck- , quickcheck-instances , semigroups , text , time >= 1.5 , timerep >= 2.0.0- , unordered-containers+ , uri-bytestring >= 0.1.9 , xml-conduit >= 1.3 , xml-conduit-parse >= 0.2.0.0 , xml-types@@ -62,9 +57,12 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs- other-modules: Paths_opml_conduit+ other-modules:+ Paths_opml_conduit+ Arbitrary build-depends:- base >= 4.8+ base >= 4.8 && < 5+ , bytestring , conduit , conduit-combinators , conduit-parse@@ -72,15 +70,21 @@ , data-default , exceptions , hlint- , lens+ , lens-simple+ , mono-traversable , mtl- , network-uri >= 2.6 , opml-conduit , parsers+ , QuickCheck+ , quickcheck-instances , resourcet+ , semigroups , tasty , tasty-hunit , tasty-quickcheck+ , text+ , time >= 1.5+ , uri-bytestring >= 0.1.9 , xml-conduit-parse- default-language: Haskell2010- ghc-options: -Wall+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-orphans
+ test/Arbitrary.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | External 'Arbitrary' instances used by OPML types.+-- All instances are defined through the 'OpmlGen' wrapper to avoid conflicts.+module Arbitrary where++-- {{{ Imports+import Data.ByteString (ByteString)+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.Encoding+import Data.Time.Clock+import Data.Tree+import Data.Version++import GHC.Generics++import Test.QuickCheck+import Test.QuickCheck.Instances ()++import Text.OPML.Types++import URI.ByteString+-- }}}++deriving instance Generic Version++-- | OPML version may only be @1.0@, @1.1@ or @2.0@+instance Arbitrary Version where+ arbitrary = Version <$> elements [ [1, 0], [1, 1], [2, 0] ] <*> pure []+ shrink = genericShrink++-- | Reasonable enough 'URI' generator.+instance Arbitrary URI where+ arbitrary = URI <$> arbitrary <*> arbitrary <*> genPath <*> arbitrary <*> (Just <$> genFragment)+ shrink = genericShrink++-- | Reasonable enough 'Authority' generator.+instance Arbitrary Authority where+ arbitrary = Authority <$> arbitrary <*> arbitrary <*> arbitrary+ shrink = genericShrink++genFragment :: Gen ByteString+genFragment = encodeUtf8 . pack <$> listOf1 genAlphaNum++instance Arbitrary Host where+ arbitrary = Host . encodeUtf8 . pack <$> listOf1 genAlphaNum+ shrink = genericShrink++genPath :: Gen ByteString+genPath = encodeUtf8 . pack . ("/" ++) <$> listOf1 genAlphaNum++instance Arbitrary Port where+ arbitrary = do+ Positive port <- arbitrary+ return $ Port port++instance Arbitrary Query where+ arbitrary = do+ a <- listOf1 (encodeUtf8 . pack <$> listOf1 genAlphaNum)+ b <- listOf1 (encodeUtf8 . pack <$> listOf1 genAlphaNum)+ return $ Query $ Prelude.zip a b+ shrink = genericShrink++instance Arbitrary Scheme where+ arbitrary = Scheme . encodeUtf8 . pack <$> listOf1 (choose('a', 'z'))+ shrink = genericShrink++instance Arbitrary UserInfo where+ arbitrary = do+ a <- encodeUtf8 . pack <$> listOf1 genAlphaNum+ b <- encodeUtf8 . pack <$> listOf1 genAlphaNum+ return $ UserInfo a b+ shrink = genericShrink+++-- | Generates 'UTCTime' with rounded seconds.+genTime :: Gen UTCTime+genTime = do+ (UTCTime d s) <- arbitrary+ return $ UTCTime d $ fromIntegral (round s :: Int)++-- | Generates 'OutlineBase''s categories.+-- This generator makes sure that the result has no @,@ nor @/@ characters, since those are used as separators.+instance Arbitrary [NonEmpty (NonNull Text)] where+ arbitrary = listOf genCategoryPath+ where genCategory = genNonNull `suchThat` (isNothing . find (\c -> c == ',' || c == '/') . toNullable)+ genCategoryPath = (:|) <$> genCategory <*> listOf genCategory+ -- shrink = genericShrink++-- | 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 OpmlHead where+ arbitrary = OpmlHead <$> arbitrary+ <*> (Just <$> genTime)+ <*> (Just <$> genTime)+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ shrink = genericShrink++instance Arbitrary OutlineBase where+ arbitrary = OutlineBase <$> genNonNull+ <*> arbitrary+ <*> arbitrary+ <*> (Just <$> genTime)+ <*> arbitrary+ -- shrink = genericShrink+ shrink (OutlineBase _ b c d e) = OutlineBase <$> []+ <*> shrink b+ <*> shrink c+ <*> shrink d+ <*> shrink e++instance Arbitrary OutlineSubscription where+ arbitrary = OutlineSubscription <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ shrink = genericShrink++instance Arbitrary OpmlOutline where+ arbitrary = oneof [ OpmlOutlineGeneric <$> arbitrary <*> arbitrary+ , OpmlOutlineLink <$> arbitrary <*> arbitrary+ , OpmlOutlineSubscription <$> arbitrary <*> arbitrary+ ]+ shrink = genericShrink++instance Arbitrary Opml where+ arbitrary = do+ degree <- choose (0, 100)+ Opml <$> arbitrary+ <*> arbitrary+ <*> vectorOf degree (genOutlineTree 1)+ shrink = genericShrink++-- | Generate a tree of outlines with the given maximum depth.+-- This generator makes sure that only 'OpmlOutlineGeneric' may have children.+genOutlineTree :: Int -> Gen (Tree OpmlOutline)+genOutlineTree n = do+ root <- arbitrary+ degree <- choose (0, 100)+ case (n > 1, root) of+ (True, OpmlOutlineGeneric _ _) -> Node <$> pure root <*> vectorOf degree (genOutlineTree (n-1))+ (False, OpmlOutlineGeneric _ _) -> return $ Node root []+ _ -> return $ Node root []
test/Main.hs view
@@ -1,33 +1,36 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-}-import Control.Lens.Fold-import Control.Lens.Getter+import Arbitrary ()+ import Control.Monad.Catch.Pure import Control.Monad.Identity import Control.Monad.Trans.Resource import Data.Conduit-import Data.Conduit.Combinators as Conduit hiding (length, map,- null)+import Data.Conduit.Combinators as Conduit (sourceFile) import Data.Conduit.Parser import Data.Conduit.Parser.XML as XML import Data.Default import Data.String+import Data.Text.Encoding import Data.Tree import Data.Version import Paths_opml_conduit import qualified Language.Haskell.HLint as HLint (hlint)++import Lens.Simple+ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck -import Text.OPML.Arbitrary ()-import Text.OPML.Stream.Parse-import Text.OPML.Stream.Render-import Text.OPML.Types+import Text.OPML.Conduit.Parse+import Text.OPML.Conduit.Render+import Text.OPML.Lens +import URI.ByteString main :: IO () main = defaultMain $ testGroup "Tests"@@ -64,11 +67,11 @@ dataFile <- fromString <$> getDataFileName "data/category.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml - (result ^. opmlVersion_) @?= Version [2,0] []- (result ^. head_ . opmlTitle_) @?= "Illustrating the category attribute"- show (result ^. head_ . opmlCreated_) @?= "Just 2005-10-31 19:23:00 UTC"- length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineGeneric) @?= 1- map (map length .levels) (result ^. outlines_) @?= [[1]]+ (result ^. opmlVersionL) @?= Version [2,0] []+ (result ^. opmlHeadL . opmlTitleL) @?= "Illustrating the category attribute"+ show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2005-10-31 19:23:00 UTC"+ length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 1+ map (map length .levels) (result ^. opmlOutlinesL) @?= [[1]] directoryCase :: TestTree@@ -76,17 +79,20 @@ dataFile <- fromString <$> getDataFileName "data/directory.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml - (result ^. opmlVersion_) @?= Version [2,0] []- (result ^. head_ . opmlTitle_) @?= "scriptingNewsDirectory.opml"- show (result ^. head_ . opmlCreated_) @?= "Just 2005-10-13 15:34:07 UTC"- show (result ^. head_ . modified_) @?= "Just 2005-10-25 21:33:57 UTC"- (result ^. head_ . ownerName_) @?= "Dave Winer"- (result ^. head_ . ownerEmail_) @?= "dwiner@yahoo.com"- (result ^. head_ . expansionState_) @?= []- (result ^. head_ . vertScrollState_) @?= Just 1- (result ^. head_ . window_) @?= [(Top',105), (Left',466), (Bottom',386), (Right',964)]- length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineLink) @?= 8- map (map length .levels) (result ^. outlines_) @?= [[1], [1], [1], [1], [1], [1], [1], [1]]+ (result ^. opmlVersionL) @?= Version [2,0] []+ (result ^. opmlHeadL . opmlTitleL) @?= "scriptingNewsDirectory.opml"+ show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2005-10-13 15:34:07 UTC"+ show (result ^. opmlHeadL . modifiedL) @?= "Just 2005-10-25 21:33:57 UTC"+ (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer"+ (result ^. opmlHeadL . ownerEmailL) @?= "dwiner@yahoo.com"+ (result ^.. opmlHeadL . expansionStateL) @?= []+ (result ^. opmlHeadL . vertScrollStateL) @?= Just 1+ (result ^. opmlHeadL . windowBottomL) @?= Just 386+ (result ^. opmlHeadL . windowLeftL) @?= Just 466+ (result ^. opmlHeadL . windowRightL) @?= Just 964+ (result ^. opmlHeadL . windowTopL) @?= Just 105+ length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineLink) @?= 8+ map (map length .levels) (result ^. opmlOutlinesL) @?= [[1], [1], [1], [1], [1], [1], [1], [1]] placesCase :: TestTree@@ -94,18 +100,21 @@ dataFile <- fromString <$> getDataFileName "data/placesLived.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml - (result ^. opmlVersion_) @?= Version [2,0] []- (result ^. head_ . opmlTitle_) @?= "placesLived.opml"- show (result ^. head_ . opmlCreated_) @?= "Just 2006-02-27 12:09:48 UTC"- show (result ^. head_ . modified_) @?= "Just 2006-02-27 12:11:44 UTC"- (result ^. head_ . ownerName_) @?= "Dave Winer"- show (result ^. head_ . ownerId_) @?= "Just http://www.opml.org/profiles/sendMail?usernum=1"- (result ^. head_ . expansionState_) @?= [1,2,5,10,13,15]- (result ^. head_ . vertScrollState_) @?= Just 1- (result ^. head_ . window_) @?= [(Top',242), (Left',329), (Bottom',665), (Right',547)]- length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineGeneric) @?= 18- length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineLink) @?= 1- map (map length .levels) (result ^. outlines_) @?= [[1,6,12]]+ (result ^. opmlVersionL) @?= Version [2,0] []+ (result ^. opmlHeadL . opmlTitleL) @?= "placesLived.opml"+ show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2006-02-27 12:09:48 UTC"+ show (result ^. opmlHeadL . modifiedL) @?= "Just 2006-02-27 12:11:44 UTC"+ (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer"+ fmap (decodeUtf8 . serializeURI') (result ^. opmlHeadL . ownerIdL) @?= Just "http://www.opml.org/profiles/sendMail?usernum=1"+ (result ^.. opmlHeadL . expansionStateL) @?= [1,2,5,10,13,15]+ (result ^. opmlHeadL . vertScrollStateL) @?= Just 1+ (result ^. opmlHeadL . windowBottomL) @?= Just 665+ (result ^. opmlHeadL . windowLeftL) @?= Just 329+ (result ^. opmlHeadL . windowRightL) @?= Just 547+ (result ^. opmlHeadL . windowTopL) @?= Just 242+ length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 18+ length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineLink) @?= 1+ map (map length .levels) (result ^. opmlOutlinesL) @?= [[1,6,12]] scriptCase :: TestTree@@ -113,17 +122,20 @@ dataFile <- fromString <$> getDataFileName "data/simpleScript.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml - (result ^. opmlVersion_) @?= Version [2,0] []- (result ^. head_ . opmlTitle_) @?= "workspace.userlandsamples.doSomeUpstreaming"- show (result ^. head_ . opmlCreated_) @?= "Just 2002-02-11 22:48:02 UTC"- show (result ^. head_ . modified_) @?= "Just 2005-10-30 03:30:17 UTC"- (result ^. head_ . ownerName_) @?= "Dave Winer"- (result ^. head_ . ownerEmail_) @?= "dwiner@yahoo.com"- (result ^. head_ . expansionState_) @?= [1, 2, 4]- (result ^. head_ . vertScrollState_) @?= Just 1- (result ^. head_ . window_) @?= [(Top', 74), (Left', 41), (Bottom', 314), (Right', 475)]- length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineGeneric) @?= 11- map (map length .levels) (result ^. outlines_) @?= [[1,2,2], [1,2], [1], [1,1]]+ (result ^. opmlVersionL) @?= Version [2,0] []+ (result ^. opmlHeadL . opmlTitleL) @?= "workspace.userlandsamples.doSomeUpstreaming"+ show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2002-02-11 22:48:02 UTC"+ show (result ^. opmlHeadL . modifiedL) @?= "Just 2005-10-30 03:30:17 UTC"+ (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer"+ (result ^. opmlHeadL . ownerEmailL) @?= "dwiner@yahoo.com"+ (result ^.. opmlHeadL . expansionStateL) @?= [1, 2, 4]+ (result ^. opmlHeadL . vertScrollStateL) @?= Just 1+ (result ^. opmlHeadL . windowBottomL) @?= Just 314+ (result ^. opmlHeadL . windowLeftL) @?= Just 41+ (result ^. opmlHeadL . windowRightL) @?= Just 475+ (result ^. opmlHeadL . windowTopL) @?= Just 74+ length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 11+ map (map length .levels) (result ^. opmlOutlinesL) @?= [[1,2,2], [1,2], [1], [1,1]] statesCase :: TestTree@@ -131,17 +143,20 @@ dataFile <- fromString <$> getDataFileName "data/states.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml - (result ^. opmlVersion_) @?= Version [2,0] []- (result ^. head_ . opmlTitle_) @?= "states.opml"- show (result ^. head_ . opmlCreated_) @?= "Just 2005-03-15 16:35:45 UTC"- show (result ^. head_ . modified_) @?= "Just 2005-07-14 23:41:05 UTC"- (result ^. head_ . ownerName_) @?= "Dave Winer"- (result ^. head_ . ownerEmail_) @?= "dave@scripting.com"- (result ^. head_ . expansionState_) @?= [1, 6, 13, 16, 18, 20]- (result ^. head_ . vertScrollState_) @?= Just 1- (result ^. head_ . window_) @?= [(Top', 106), (Left', 106), (Bottom', 558), (Right', 479)]- length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineGeneric) @?= 63- map (map length .levels) (result ^. outlines_) @?= [[1, 8, 50, 4]]+ (result ^. opmlVersionL) @?= Version [2,0] []+ (result ^. opmlHeadL . opmlTitleL) @?= "states.opml"+ show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2005-03-15 16:35:45 UTC"+ show (result ^. opmlHeadL . modifiedL) @?= "Just 2005-07-14 23:41:05 UTC"+ (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer"+ (result ^. opmlHeadL . ownerEmailL) @?= "dave@scripting.com"+ (result ^.. opmlHeadL . expansionStateL) @?= [1, 6, 13, 16, 18, 20]+ (result ^. opmlHeadL . vertScrollStateL) @?= Just 1+ (result ^. opmlHeadL . windowBottomL) @?= Just 558+ (result ^. opmlHeadL . windowLeftL) @?= Just 106+ (result ^. opmlHeadL . windowRightL) @?= Just 479+ (result ^. opmlHeadL . windowTopL) @?= Just 106+ length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineGeneric) @?= 63+ map (map length .levels) (result ^. opmlOutlinesL) @?= [[1, 8, 50, 4]] subscriptionsCase :: TestTree@@ -149,18 +164,21 @@ dataFile <- fromString <$> getDataFileName "data/subscriptionList.opml" result <- runResourceT . runConduit $ sourceFile dataFile =$= XML.parseBytes def =$= runConduitParser parseOpml - (result ^. opmlVersion_) @?= Version [2,0] []- (result ^. head_ . opmlTitle_) @?= "mySubscriptions.opml"- show (result ^. head_ . opmlCreated_) @?= "Just 2005-06-18 12:11:52 UTC"- show (result ^. head_ . modified_) @?= "Just 2005-08-02 21:42:48 UTC"- (result ^. head_ . ownerName_) @?= "Dave Winer"- (result ^. head_ . ownerEmail_) @?= "dave@scripting.com"- (result ^. head_ . vertScrollState_) @?= Just 1- (result ^. head_ . window_) @?= [(Top', 61), (Left', 304), (Bottom', 562), (Right',842)]- length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineSubscription) @?= 13+ (result ^. opmlVersionL) @?= Version [2,0] []+ (result ^. opmlHeadL . opmlTitleL) @?= "mySubscriptions.opml"+ show (result ^. opmlHeadL . opmlCreatedL) @?= "Just 2005-06-18 12:11:52 UTC"+ show (result ^. opmlHeadL . modifiedL) @?= "Just 2005-08-02 21:42:48 UTC"+ (result ^. opmlHeadL . ownerNameL) @?= "Dave Winer"+ (result ^. opmlHeadL . ownerEmailL) @?= "dave@scripting.com"+ (result ^. opmlHeadL . vertScrollStateL) @?= Just 1+ (result ^. opmlHeadL . windowBottomL) @?= Just 562+ (result ^. opmlHeadL . windowLeftL) @?= Just 304+ (result ^. opmlHeadL . windowRightL) @?= Just 842+ (result ^. opmlHeadL . windowTopL) @?= Just 61+ length (result ^.. opmlOutlinesL . traverse . traverse . _OpmlOutlineSubscription) @?= 13 inverseHeadProperty :: TestTree inverseHeadProperty = testProperty "parse . render = id (on OpmlHead)" $ \opmlHead -> either (const False) (opmlHead ==) (runIdentity . runCatchT . runConduit $ renderOpmlHead opmlHead =$= runConduitParser parseOpmlHead) -inverseProperty :: TestTree-inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= runConduitParser parseOpml)+-- inverseProperty :: TestTree+-- inverseProperty = testProperty "parse . render = id" $ \opml -> either (const False) (opml ==) (runIdentity . runCatchT . runConduit $ renderOpml opml =$= runConduitParser parseOpml)