opml-conduit 0.1.0.0 → 0.2.0.0
raw patch · 8 files changed
+111/−104 lines, 8 filesdep +hashabledep +hashable-timedep +hlint
Dependencies added: hashable, hashable-time, hlint, unordered-containers
Files
- Data/NotEmpty.hs +0/−43
- Text/OPML.hs +9/−9
- Text/OPML/Arbitrary.hs +20/−10
- Text/OPML/Stream/Parse.hs +17/−13
- Text/OPML/Stream/Render.hs +5/−5
- Text/OPML/Types.hs +34/−13
- opml-conduit.cabal +13/−10
- test/Main.hs +13/−1
− Data/NotEmpty.hs
@@ -1,43 +0,0 @@-module Data.NotEmpty- ( NE()- , notEmpty- , original- , NotEmptyException(..)- ) where---- {{{ Imports-import Control.Monad.Catch--import Data.Semigroup--import Test.QuickCheck--- }}}---- | For a monoid @s@, @NE s@ is @s@ without its neutral element 'mempty'.-newtype NE s = NE s--instance (Eq s) => Eq (NE s) where- (NE a) == (NE b) = a == b---- | @NE s@ is the semigroup derived from the monoid type @s@.-instance (Monoid s) => Semigroup (NE s) where- (NE a) <> (NE b) = NE (a `mappend` b)--instance (Show s) => Show (NE s) where- show (NE s) = show s--instance (Eq s, Monoid s, Arbitrary s) => Arbitrary (NE s) where- arbitrary = NE <$> arbitrary `suchThat` (/= mempty)---- | Smart constructor.-notEmpty :: (MonadThrow m, Eq s, Monoid s) => s -> m (NE s)-notEmpty s | s == mempty = throwM EmptyValue- | otherwise = return $ NE s---- | Unwrap the underlying value.-original :: NE s -> s-original (NE s) = s---data NotEmptyException = EmptyValue deriving(Eq, Show)-instance Exception NotEmptyException
Text/OPML.hs view
@@ -1,10 +1,10 @@--- | This module re-exports commonly used modules.-module Text.OPML- ( module Text.OPML.Stream.Parse- , module Text.OPML.Stream.Render- , module Text.OPML.Types- ) where+-- | This module re-exports commonly used modules:+--+-- - 'Text.OPML.Stream.Parse'+-- - 'Text.OPML.Stream.Render'+-- - 'Text.OPML.Types'+module Text.OPML (module X) where -import Text.OPML.Stream.Parse-import Text.OPML.Stream.Render-import Text.OPML.Types+import Text.OPML.Stream.Parse as X+import Text.OPML.Stream.Render as X+import Text.OPML.Types as X
Text/OPML/Arbitrary.hs view
@@ -1,6 +1,7 @@ {-# 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.@@ -8,8 +9,11 @@ -- {{{ Imports import Data.Char+import Data.List.NonEmpty import Data.Maybe-import Data.NotEmpty+import Data.MonoTraversable (Element)+import Data.NonNull+import Data.Sequences (SemiSequence) import Data.Text (Text, find) import Data.Time.Clock import Data.Version@@ -30,10 +34,6 @@ (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 [])@@ -45,13 +45,13 @@ where genUriPath = ("/" ++) <$> listOf1 genAlphaNum genUriQuery = oneof [return "", ("?" ++) <$> listOf1 genAlphaNum] genUriFragment = oneof [return "", ("#" ++) <$> listOf1 genAlphaNum]- genUriScheme = (\x -> x ++ ":") <$> listOf1 (choose('a', 'z'))+ genUriScheme = (++ ":") <$> 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]+ userInfo <- oneof [return "", (++ "@") <$> listOf1 genAlphaNum] regName <- listOf1 genAlphaNum port <- oneof [return "", (\x -> ":" ++ x) . show <$> choose(1 :: Int, 65535)] return . OpmlGen $ URIAuth userInfo regName port@@ -67,6 +67,16 @@ -- | 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+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/Stream/Parse.hs view
@@ -23,11 +23,12 @@ import Data.CaseInsensitive hiding (map) import Data.Conduit import Data.Containers+import Data.List.NonEmpty hiding (filter, map) import Data.Map (Map) import Data.Maybe import Data.Monoid.Textual hiding (map) import Data.MonoTraversable-import Data.NotEmpty+import Data.NonNull import Data.Text (Text, strip, unpack) import Data.Time.Clock import Data.Time.LocalTime@@ -48,7 +49,8 @@ import Text.XML.Stream.Parse -- }}} -data OpmlException = InvalidBool Text+data OpmlException = MissingText+ | InvalidBool Text | InvalidDecimal Text | InvalidTime Text | InvalidURI Text@@ -56,6 +58,7 @@ 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@@ -73,7 +76,7 @@ _ -> throwM $ InvalidVersion v parseDecimal :: (MonadThrow m, Integral a) => Text -> m a-parseDecimal t = case (filter (\(_, b) -> onull b) . readSigned readDec $ unpack t) of+parseDecimal t = case filter (onull . snd) . readSigned readDec $ unpack t of (result, _):_ -> return result _ -> throwM $ InvalidDecimal t @@ -109,7 +112,7 @@ ] -- | Parse the @\<head\>@ section.--- This function is more lenient than what the standards demands on the following points:+-- 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.@@ -122,8 +125,8 @@ unknownTag = tagPredicate (const True) ignoreAttrs $ \_ -> return return -parseCategories :: Text -> [[NE Text]]-parseCategories = filter (not . onull) . map (catMaybes . map notEmpty . split (== '/')) . split (== ',')+parseCategories :: Text -> [NonEmpty (NonNull Text)]+parseCategories = mapMaybe (nonEmpty . mapMaybe fromNullable . 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"@.@@ -151,13 +154,14 @@ 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)+ <*> many parseOpmlOutline+ baseHandler (t, comment, breakpoint, created, category) = do+ text <- maybe (throwM MissingText) return $ fromNullable t+ return $ OutlineBase text+ (parseBool =<< comment)+ (parseBool =<< breakpoint)+ (parseTime =<< created)+ (parseCategories =<< otoList category) subscriptionHandler (uri, html, description, language, title, version) = OutlineSubscription <$> parseURI uri <*> pure (parseURI =<< html)
Text/OPML/Stream/Render.hs view
@@ -16,9 +16,9 @@ import Control.Monad import Data.Conduit+import Data.List.NonEmpty hiding (filter, map) import Data.Monoid-import Data.MonoTraversable-import Data.NotEmpty+import Data.NonNull import Data.Text (Text, intercalate, pack, toLower) import Data.Time.Clock import Data.Time.LocalTime@@ -46,8 +46,8 @@ formatTime :: UTCTime -> Text formatTime = formatTimeRFC822 . utcToZonedTime utc -formatCategories :: [[NE Text]] -> Maybe Text-formatCategories = toMaybe . intercalate "," . map (intercalate "/") . filter (not . onull) . map (map original)+formatCategories :: [NonEmpty (NonNull Text)] -> Maybe Text+formatCategories = toMaybe . intercalate "," . map (intercalate "/" . toList . fmap toNullable) formatBool :: Bool -> Text formatBool = toLower . tshow@@ -80,7 +80,7 @@ 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_)+ baseAttr b = attr "text" (toNullable $ b^.text_) <> optionalAttr "isComment" (formatBool <$> b^.isComment_) <> optionalAttr "isBreakpoint" (formatBool <$> b^.isBreakpoint_) <> optionalAttr "created" (formatTime <$> b^.outlineCreated_)
Text/OPML/Types.hs view
@@ -67,8 +67,11 @@ import Control.Monad import Data.Default-import Data.Map-import Data.NotEmpty+import Data.Hashable+import Data.Hashable.Time ()+import Data.HashMap.Lazy+import Data.List.NonEmpty+import Data.NonNull import Data.Text import Data.Time.Clock import Data.Time.LocalTime ()@@ -83,8 +86,14 @@ import Text.OPML.Arbitrary -- }}} -data Direction = Top' | Left' | Bottom' | Right' deriving(Eq, Generic, Ord, Show)+-- 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@@ -101,13 +110,14 @@ , docs_ :: Maybe URI , expansionState_ :: [Int] , vertScrollState_ :: Maybe Int- , window_ :: Map Direction Int+ , window_ :: HashMap Direction 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@@ -137,28 +147,33 @@ declareLenses [d| data OutlineBase = OutlineBase- { text_ :: NE Text+ { text_ :: NonNull Text , isComment_ :: Maybe Bool , isBreakpoint_ :: Maybe Bool , outlineCreated_ :: Maybe UTCTime- , categories_ :: [[NE Text]]+ , 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 <$> arbitrary+ arbitrary = OutlineBase <$> genNonNull <*> arbitrary <*> arbitrary <*> (unwrap <$> arbitrary) <*> (unwrap <$> arbitrary)- shrink = genericShrink+ shrink (OutlineBase _ b c d e) = OutlineBase <$> []+ <*> shrink b+ <*> shrink c+ <*> shrink d+ <*> (unwrap <$> shrink (OpmlGen e)) -- | Smart constructor for 'OutlineBase'.-mkOutlineBase :: NE Text -> OutlineBase+mkOutlineBase :: NonNull Text -> OutlineBase mkOutlineBase t = OutlineBase t mzero mzero mzero mzero @@ -176,6 +191,7 @@ deriving instance Eq OutlineSubscription deriving instance Generic OutlineSubscription deriving instance Show OutlineSubscription+-- instance Hashable OutlineSubscription instance Arbitrary OutlineSubscription where arbitrary = OutlineSubscription <$> (unwrap <$> arbitrary)@@ -201,6 +217,7 @@ deriving instance Eq OpmlOutline deriving instance Generic OpmlOutline deriving instance Show OpmlOutline+-- instance Hashable OpmlOutline instance Arbitrary OpmlOutline where arbitrary = oneof [ OpmlOutlineGeneric <$> arbitrary <*> arbitrary@@ -223,14 +240,17 @@ 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 = Opml <$> (unwrap <$> arbitrary)- <*> arbitrary- <*> listOf (genOutlineTree 1)+ 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.@@ -238,7 +258,8 @@ genOutlineTree :: Int -> Gen (Tree OpmlOutline) genOutlineTree n = do root <- arbitrary+ degree <- choose (0, 100) case (n > 1, root) of- (True, OpmlOutlineGeneric _ _) -> Node <$> pure root <*> listOf (genOutlineTree (n-1))+ (True, OpmlOutlineGeneric _ _) -> Node <$> pure root <*> vectorOf degree (genOutlineTree (n-1)) (False, OpmlOutlineGeneric _ _) -> return $ Node root [] _ -> return $ Node root []
opml-conduit.cabal view
@@ -1,5 +1,5 @@ name: opml-conduit-version: 0.1.0.0+version: 0.2.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.@@ -10,7 +10,6 @@ maintainer: koral <koral@mailoo.org> category: Conduit, Text, XML build-type: Simple--- extra-source-files: cabal-version: >=1.10 data-files: data/category.opml@@ -25,12 +24,12 @@ location: git://github.com/k0ral/opml-conduit.git library- exposed-modules: Data.NotEmpty- , Text.OPML- , Text.OPML.Arbitrary- , Text.OPML.Stream.Parse- , Text.OPML.Stream.Render- , Text.OPML.Types+ exposed-modules:+ Text.OPML+ Text.OPML.Arbitrary+ Text.OPML.Stream.Parse+ Text.OPML.Stream.Render+ Text.OPML.Types build-depends: base >= 4.8 && < 5 , case-insensitive@@ -38,16 +37,19 @@ , containers , data-default , exceptions+ , hashable+ , hashable-time , lens , monoid-subclasses , mono-traversable- , network-uri+ , network-uri >= 2.6 , QuickCheck , quickcheck-instances , semigroups , text , time >= 1.5 , timerep >= 2.0.0+ , unordered-containers , xml-conduit >= 1.2.5 , xml-types default-language: Haskell2010@@ -64,9 +66,10 @@ , conduit-combinators , containers , exceptions+ , hlint , lens , mtl- , network-uri+ , network-uri >= 2.6 , opml-conduit , resourcet , tasty
test/Main.hs view
@@ -7,13 +7,15 @@ import Control.Monad.Trans.Resource import Data.Conduit-import Data.Conduit.Combinators as Conduit hiding (length, map)+import Data.Conduit.Combinators as Conduit hiding (length, map,+ null) import Data.String import Data.Tree import Data.Version import Paths_opml_conduit +import qualified Language.Haskell.HLint as HLint (hlint) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck@@ -28,6 +30,7 @@ main = defaultMain $ testGroup "Tests" [ unitTests , properties+ , hlint ] unitTests :: TestTree@@ -46,6 +49,13 @@ , inverseProperty ] ++hlint :: TestTree+hlint = testCase "HLint check" $ do+ result <- HLint.hlint [ "test", "Text" ]+ null result @?= True++ categoriesCase :: TestTree categoriesCase = testCase "Parse categories list" $ do dataFile <- fromString <$> getDataFileName "data/category.opml"@@ -57,6 +67,7 @@ length (result ^.. outlines_ . traverse . traverse . _OpmlOutlineGeneric) @?= 1 map (map length .levels) (result ^. outlines_) @?= [[1]] + directoryCase :: TestTree directoryCase = testCase "Parse directory tree" $ do dataFile <- fromString <$> getDataFileName "data/directory.opml"@@ -73,6 +84,7 @@ (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]]+ placesCase :: TestTree placesCase = testCase "Parse places list" $ do