summaryrefslogtreecommitdiff
path: root/Text/OPML
diff options
context:
space:
mode:
authorkoral <>2015-05-05 14:52:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-05-05 14:52:00 (GMT)
commita1e6694f40a0bbc0e8736f9a9c69d08afc313382 (patch)
tree808616e0811b7b4a7f537f4ee893ab06e779b71e /Text/OPML
version 0.1.0.00.1.0.0
Diffstat (limited to 'Text/OPML')
-rw-r--r--Text/OPML/Arbitrary.hs72
-rw-r--r--Text/OPML/Stream/Parse.hs175
-rw-r--r--Text/OPML/Stream/Render.hs100
-rw-r--r--Text/OPML/Types.hs244
4 files changed, 591 insertions, 0 deletions
diff --git a/Text/OPML/Arbitrary.hs b/Text/OPML/Arbitrary.hs
new file mode 100644
index 0000000..da75845
--- /dev/null
+++ b/Text/OPML/Arbitrary.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# 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.Maybe
+import Data.NotEmpty
+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
+
+-- | Alpha-numeric generator.
+genAlphaNum :: Gen Char
+genAlphaNum = oneof [choose('a', 'z'), suchThat arbitrary isDigit]
+
+-- | 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 = (\x -> x ++ ":") <$> listOf1 (choose('a', 'z'))
+ -- shrink = genericShrink
+
+-- | Reasonable enough 'URIAuth' generator.
+instance Arbitrary (OpmlGen URIAuth) where
+ arbitrary = do
+ userInfo <- oneof [return "", fmap (\x -> x ++ "@") $ 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 [[NE Text]]) where
+ arbitrary = OpmlGen <$> listOf (listOf1 $ arbitrary `suchThat` (isNothing . find (\c -> c == ',' || c == '/') . original))
+ shrink = genericShrink
diff --git a/Text/OPML/Stream/Parse.hs b/Text/OPML/Stream/Parse.hs
new file mode 100644
index 0000000..9fa5f7f
--- /dev/null
+++ b/Text/OPML/Stream/Parse.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# 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
+ -- * Exceptions
+ , OpmlException(..)
+ ) where
+
+-- {{{ Imports
+import Control.Lens.At
+import Control.Lens.Setter
+import Control.Monad
+import Control.Monad.Catch
+
+import Data.CaseInsensitive hiding (map)
+import Data.Conduit
+import Data.Containers
+import Data.Map (Map)
+import Data.Maybe
+import Data.Monoid.Textual hiding (map)
+import Data.MonoTraversable
+import Data.NotEmpty
+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)
+import qualified Network.URI as N
+
+import Numeric
+
+import Prelude hiding (foldr, lookup)
+
+import Text.OPML.Types
+import Text.ParserCombinators.ReadP (readP_to_S)
+import Text.XML.Stream.Parse
+-- }}}
+
+data OpmlException = InvalidBool Text
+ | InvalidDecimal Text
+ | InvalidTime Text
+ | InvalidURI Text
+ | InvalidVersion Text
+
+deriving instance Eq OpmlException
+instance Show OpmlException where
+ 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
+
+-- | Generic version of 'Network.URI.parseURI'.
+parseURI :: (MonadThrow m) => Text -> m URI
+parseURI t = maybe (throwM $ InvalidURI t) return . N.parseURI $ unpack t
+
+parseVersion' :: (MonadThrow m) => Text -> m Version
+parseVersion' v = case filter (onull . snd) . readP_to_S parseVersion $ unpack v of
+ [(a, "")] -> return a
+ _ -> throwM $ InvalidVersion v
+
+parseDecimal :: (MonadThrow m, Integral a) => Text -> m a
+parseDecimal t = case (filter (\(_, b) -> onull b) . readSigned readDec $ unpack t) of
+ (result, _):_ -> return result
+ _ -> throwM $ InvalidDecimal t
+
+parseExpansionState :: (MonadThrow m, Integral a) => Text -> m [a]
+parseExpansionState t = mapM parseDecimal . filter (not . onull) . map strip $ split (== ',') t
+
+parseTime :: (MonadThrow m) => Text -> m UTCTime
+parseTime 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
+parseBool :: (MonadThrow m) => Text -> m Bool
+parseBool t
+ | mk t == "true" = return True
+ | mk t == "false" = return False
+ | otherwise = throwM $ InvalidBool t
+
+
+opmlHeadBuilder :: (MonadThrow m) => Map Text (Text -> OpmlHead -> m OpmlHead)
+opmlHeadBuilder = [ ("dateCreated", \v h -> set opmlCreated_ <$> (Just <$> parseTime v) <*> pure h)
+ , ("dateModified", \v h -> set modified_ <$> (Just <$> parseTime v) <*> pure h)
+ , ("docs", \v h -> set docs_ <$> (Just <$> parseURI v) <*> pure h)
+ , ("expansionState", \v h -> set expansionState_ <$> parseExpansionState v <*> pure h)
+ , ("ownerEmail", \v -> return . set ownerEmail_ v)
+ , ("ownerId", \v h -> set ownerId_ <$> (Just <$> parseURI v) <*> pure h)
+ , ("ownerName", \v -> return . set ownerName_ v)
+ , ("title", \v -> return . set opmlTitle_ v)
+ , ("vertScrollState", \v h -> set vertScrollState_ <$> (Just <$> parseDecimal v) <*> pure h)
+ , ("windowBottom", \v h -> set (window_.at Bottom') <$> (Just <$> parseDecimal v) <*> pure h)
+ , ("windowLeft", \v h -> set (window_.at Left') <$> (Just <$> parseDecimal v) <*> pure h)
+ , ("windowRight", \v h -> set (window_.at Right') <$> (Just <$> parseDecimal v) <*> pure h)
+ , ("windowTop", \v h -> set (window_.at Top') <$> (Just <$> parseDecimal v) <*> pure h)
+ ]
+
+-- | Parse the @\<head\>@ section.
+-- This function is more lenient than what the standards 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 :: (MonadThrow m) => Consumer Event m (Maybe OpmlHead)
+parseOpmlHead = tagName "head" ignoreAttrs $ \_ -> foldM (\a f' -> f' a) def =<< many (tagHead `orE` unknownTag)
+ where tagHead, unknownTag :: (MonadThrow m, MonadThrow m') => ConduitM Event o m (Maybe (OpmlHead -> m' OpmlHead))
+ tagHead = tag ((`lookup` opmlHeadBuilder) . nameLocalName) (\f -> ignoreAttrs *> pure f) $ \f -> do
+ c <- content
+ return $ f c
+ unknownTag = tagPredicate (const True) ignoreAttrs $ \_ -> return return
+
+
+parseCategories :: Text -> [[NE Text]]
+parseCategories = filter (not . onull) . map (catMaybes . map notEmpty . split (== '/')) . split (== ',')
+
+-- | 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 :: (MonadThrow m) => Consumer Event m (Maybe (Tree OpmlOutline))
+parseOpmlOutline = tagName "outline" attributes handler
+ where attributes = do
+ otype <- optionalAttr "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 = (,,,,) <$> requireAttr "text"
+ <*> optionalAttr "isComment"
+ <*> optionalAttr "isBreakpoint"
+ <*> optionalAttr "created"
+ <*> optionalAttr "category"
+ linkAttr = requireAttr "url"
+ subscriptionAttr = (,,,,,) <$> requireAttr "xmlUrl"
+ <*> optionalAttr "htmlUrl"
+ <*> optionalAttr "description"
+ <*> optionalAttr "language"
+ <*> optionalAttr "title"
+ <*> optionalAttr "version"
+ handler (_, b, Just s, _) = Node <$> (OpmlOutlineSubscription <$> baseHandler b <*> subscriptionHandler s) <*> pure []
+ handler (_, b, _, Just l) = Node <$> (OpmlOutlineLink <$> baseHandler b <*> parseURI l) <*> pure []
+ handler (otype, b, _, _) = Node <$> (OpmlOutlineGeneric <$> baseHandler b <*> pure (fromMaybe mempty otype))
+ <*> many parseOpmlOutline
+ baseHandler (t, comment, breakpoint, created, category) =
+ OutlineBase <$> notEmpty t
+ <*> pure (parseBool =<< comment)
+ <*> pure (parseBool =<< breakpoint)
+ <*> pure (parseTime =<< created)
+ <*> pure (parseCategories =<< otoList category)
+ subscriptionHandler (uri, html, description, language, title, version) =
+ OutlineSubscription <$> parseURI uri
+ <*> pure (parseURI =<< html)
+ <*> pure (fromMaybe mempty description)
+ <*> pure (fromMaybe mempty language)
+ <*> pure (fromMaybe mempty title)
+ <*> pure (fromMaybe mempty version)
+
+-- | Parse the top-level @\<opml\>@ element.
+parseOpml :: (MonadThrow m) => Consumer Event m (Maybe Opml)
+parseOpml = tagName "opml" attributes handler
+ where attributes = requireAttr "version" <* ignoreAttrs
+ handler version = Opml <$> parseVersion' version
+ <*> force "Missing <head>." parseOpmlHead
+ <*> force "Missing <body>." (tagName "body" ignoreAttrs $ \_ -> many parseOpmlOutline)
diff --git a/Text/OPML/Stream/Render.hs b/Text/OPML/Stream/Render.hs
new file mode 100644
index 0000000..339d6e9
--- /dev/null
+++ b/Text/OPML/Stream/Render.hs
@@ -0,0 +1,100 @@
+{-# 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.Monoid
+import Data.MonoTraversable
+import Data.NotEmpty
+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 :: [[NE Text]] -> Maybe Text
+formatCategories = toMaybe . intercalate "," . map (intercalate "/") . filter (not . onull) . map (map original)
+
+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" (original $ 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_
diff --git a/Text/OPML/Types.hs b/Text/OPML/Types.hs
new file mode 100644
index 0000000..2de5f64
--- /dev/null
+++ b/Text/OPML/Types.hs
@@ -0,0 +1,244 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- | OPML is an XML format for outlines.
+--
+-- Example:
+--
+-- > <opml version="2.0">
+-- > <head>
+-- > <title>OPML title</title>
+-- > <dateCreated>Mon, 31 Oct 2005 19:23:00 GMT</dateCreated>
+-- > </head>
+-- > <body>
+-- > <outline text="Outline 1" created="Mon, 31 Oct 2005 18:21:33 GMT"/>
+-- > <outline text="Outline 2" created="Mon, 31 Oct 2005 18:21:33 GMT"/>
+-- > </body>
+-- > </opml>
+module Text.OPML.Types
+ ( -- * Top-level OPML structure
+ Opml(..)
+ , opmlVersion_
+ , head_
+ , outlines_
+ -- * OPML header
+ , OpmlHead(..)
+ , Direction(..)
+ , opmlTitle_
+ , opmlCreated_
+ , modified_
+ , ownerName_
+ , ownerEmail_
+ , ownerId_
+ , docs_
+ , expansionState_
+ , vertScrollState_
+ , window_
+ -- * 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.Map
+import Data.NotEmpty
+import Data.Text
+import Data.Time.Clock
+import Data.Time.LocalTime ()
+import Data.Tree
+import Data.Version
+
+import GHC.Generics
+
+import Network.URI
+
+import Test.QuickCheck
+import Text.OPML.Arbitrary
+-- }}}
+
+data Direction = Top' | Left' | Bottom' | Right' deriving(Eq, Generic, Ord, Show)
+
+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_ :: Map Direction Int
+ }
+ |]
+
+deriving instance Eq OpmlHead
+deriving instance Generic OpmlHead
+deriving instance Show 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
+
+declareLenses [d|
+ data OutlineBase = OutlineBase
+ { text_ :: NE Text
+ , isComment_ :: Maybe Bool
+ , isBreakpoint_ :: Maybe Bool
+ , outlineCreated_ :: Maybe UTCTime
+ , categories_ :: [[NE Text]]
+ }
+ |]
+
+deriving instance Eq OutlineBase
+deriving instance Generic OutlineBase
+deriving instance Show OutlineBase
+
+instance Arbitrary OutlineBase where
+ arbitrary = OutlineBase <$> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> (unwrap <$> arbitrary)
+ <*> (unwrap <$> arbitrary)
+ shrink = genericShrink
+
+-- | Smart constructor for 'OutlineBase'.
+mkOutlineBase :: NE 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
+ }
+ |]
+
+deriving instance Eq OutlineSubscription
+deriving instance Generic OutlineSubscription
+deriving instance Show 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
+mkOutlineSubscription uri = OutlineSubscription uri mzero mempty mempty mempty mempty
+
+
+-- | Outlines are the main payload of an OPML document.
+declarePrisms [d|
+ data OpmlOutline = OpmlOutlineGeneric OutlineBase Text
+ | OpmlOutlineLink OutlineBase URI
+ | OpmlOutlineSubscription OutlineBase OutlineSubscription
+ |]
+
+deriving instance Eq OpmlOutline
+deriving instance Generic OpmlOutline
+deriving instance Show 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
+ }
+ |]
+
+deriving instance Eq Opml
+deriving instance Generic Opml
+deriving instance Show Opml
+
+instance Default Opml where
+ def = Opml (makeVersion [2, 0]) def mempty
+
+instance Arbitrary Opml where
+ arbitrary = Opml <$> (unwrap <$> arbitrary)
+ <*> arbitrary
+ <*> listOf (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
+ case (n > 1, root) of
+ (True, OpmlOutlineGeneric _ _) -> Node <$> pure root <*> listOf (genOutlineTree (n-1))
+ (False, OpmlOutlineGeneric _ _) -> return $ Node root []
+ _ -> return $ Node root []