diff --git a/Text/Atom/Conduit/Parse.hs b/Text/Atom/Conduit/Parse.hs --- a/Text/Atom/Conduit/Parse.hs +++ b/Text/Atom/Conduit/Parse.hs @@ -25,30 +25,23 @@ -- {{{ Imports import Blaze.ByteString.Builder (toByteString) - import Conduit (foldC, headC, headDefC, sinkList) - import Control.Applicative hiding (many) import Control.Exception.Safe as Exception import Control.Monad import Control.Monad.Fix - import Data.Conduit import Data.Maybe import Data.Monoid -import Data.MonoTraversable -import Data.NonNull (NonNull, fromNullable, toNullable) import Data.Text as Text (Text, unpack) import Data.Text.Encoding import Data.Time.Clock import Data.Time.LocalTime import Data.Time.RFC3339 import Data.XML.Types - import Lens.Simple - import Prelude - +import Refined import Text.Atom.Types import Text.XML.Stream.Parse import qualified Text.XML.Stream.Render as Render @@ -79,9 +72,6 @@ where parseURI' = parseURI laxURIParserOptions . encodeUtf8 parseRelativeRef' = parseRelativeRef laxURIParserOptions . encodeUtf8 -asNonNull :: (MonoFoldable a, MonadThrow m) => a -> m (NonNull a) -asNonNull = liftMaybe NullElement . fromNullable - liftMaybe :: (MonadThrow m, Exception e) => e -> Maybe a -> m a liftMaybe e = maybe (throw e) return @@ -123,7 +113,7 @@ -- }}} -data PersonPiece = PersonName (NonNull Text) +data PersonPiece = PersonName (Refined (Not Null) Text) | PersonEmail Text | PersonUri AtomURI @@ -143,7 +133,7 @@ <$> ZipConduit (projectC _PersonName .| headRequiredC "Missing or invalid element") <*> ZipConduit (projectC _PersonEmail .| headDefC "") <*> ZipConduit (projectC _PersonUri .| headC) - piece = [ fmap PersonName <$> tagIgnoreAttrs' "name" (content >>= asNonNull) + piece = [ fmap PersonName <$> tagIgnoreAttrs' "name" (content >>= refineThrow) , fmap PersonEmail <$> tagIgnoreAttrs' "email" content , fmap PersonUri <$> tagIgnoreAttrs' "uri" (content >>= asURIReference) ] @@ -155,7 +145,7 @@ -- > atomCategory :: MonadThrow m => ConduitM Event o m (Maybe AtomCategory) atomCategory = tagName' "category" categoryAttrs $ \(t, s, l) -> do - term <- asNonNull t + term <- refineThrow t return $ AtomCategory term s l where categoryAttrs = (,,) <$> requireAttr "term" <*> (requireAttr "scheme" <|> pure mempty) @@ -216,7 +206,7 @@ -- > Example Toolkit -- > atomGenerator :: MonadThrow m => ConduitM Event o m (Maybe AtomGenerator) -atomGenerator = tagName' "generator" generatorAttrs $ \(uri, version) -> AtomGenerator uri version <$> (asNonNull =<< content) +atomGenerator = tagName' "generator" generatorAttrs $ \(uri, version) -> AtomGenerator uri version <$> (refineThrow =<< content) where generatorAttrs = (,) <$> optional (requireAttr "uri" >>= asURIReference) <*> (requireAttr "version" <|> pure mempty) <* ignoreAttrs diff --git a/Text/Atom/Conduit/Render.hs b/Text/Atom/Conduit/Render.hs --- a/Text/Atom/Conduit/Render.hs +++ b/Text/Atom/Conduit/Render.hs @@ -21,21 +21,17 @@ import Text.Atom.Types import Control.Monad - import Data.Conduit import Data.Monoid -import Data.NonNull import Data.Text as Text import Data.Text.Encoding import Data.Time.Clock import Data.Time.LocalTime import Data.Time.RFC3339 import Data.XML.Types - import Lens.Simple - +import Refined import Text.XML.Stream.Render - import URI.ByteString -- }}} @@ -99,7 +95,7 @@ -- | Render an @atom:generator@ element. renderAtomGenerator :: (Monad m) => AtomGenerator -> ConduitT () Event m () -renderAtomGenerator g = atomTag "generator" attributes . content . toNullable $ g^.generatorContentL +renderAtomGenerator g = atomTag "generator" attributes . content . unrefine $ g^.generatorContentL where attributes = optionalAttr "uri" (decodeUtf8 . withAtomURI serializeURIRef' <$> generatorUri g) <> nonEmptyAttr "version" (g^.generatorVersionL) @@ -116,14 +112,14 @@ -- | Render an @atom:category@ element. renderAtomCategory :: (Monad m) => AtomCategory -> ConduitT () Event m () renderAtomCategory c = atomTag "category" attributes $ return () - where attributes = attr "term" (toNullable $ c^.categoryTermL) + where attributes = attr "term" (unrefine $ c^.categoryTermL) <> nonEmptyAttr "scheme" (c^.categorySchemeL) <> nonEmptyAttr "label" (c^.categoryLabelL) -- | Render an atom person construct. renderAtomPerson :: (Monad m) => Text -> AtomPerson -> ConduitT () Event m () renderAtomPerson name p = atomTag name mempty $ do - atomTag "name" mempty . content . toNullable $ p^.personNameL + atomTag "name" mempty . content . unrefine $ p^.personNameL unless (Text.null $ p^.personEmailL) $ atomTag "email" mempty . content $ p^.personEmailL forM_ (personUri p) $ atomTag "uri" mempty . content . decodeUtf8 . withAtomURI serializeURIRef' diff --git a/Text/Atom/Types.hs b/Text/Atom/Types.hs --- a/Text/Atom/Types.hs +++ b/Text/Atom/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} -- | Atom is an XML-based Web content and metadata syndication format. @@ -31,15 +32,22 @@ module Text.Atom.Types (module Text.Atom.Types) where -- {{{ Imports -import Data.NonNull -import Data.Text +import Control.Monad +import Data.Text as Text import Data.Time.Clock import Data.Time.LocalTime () +import Data.Typeable import GHC.Generics +import Refined import URI.ByteString -- }}} +-- | 'Predicate' on 'Text', true iff text is null. +data Null deriving(Typeable) +instance Predicate Null Text where + validate p value = unless (Text.null value) $ throwRefine $ RefineOtherException (typeOf p) "Text is not null" + data AtomURI = forall a . AtomURI (URIRef a) withAtomURI :: (forall a . URIRef a -> b) -> AtomURI -> b @@ -74,7 +82,7 @@ -- | An atom person construct. data AtomPerson = AtomPerson - { personName :: NonNull Text + { personName :: Refined (Not Null) Text , personEmail :: Text , personUri :: Maybe AtomURI } @@ -82,11 +90,12 @@ deriving instance Eq AtomPerson deriving instance Ord AtomPerson deriving instance Generic AtomPerson +-- deriving instance Read AtomPerson deriving instance Show AtomPerson -- | The @atom:category@ element. data AtomCategory = AtomCategory - { categoryTerm :: NonNull Text + { categoryTerm :: Refined (Not Null) Text , categoryScheme :: Text , categoryLabel :: Text } @@ -115,7 +124,7 @@ data AtomGenerator = AtomGenerator { generatorUri :: Maybe AtomURI , generatorVersion :: Text - , generatorContent :: NonNull Text + , generatorContent :: Refined (Not Null) Text } deriving instance Eq AtomGenerator diff --git a/atom-conduit.cabal b/atom-conduit.cabal --- a/atom-conduit.cabal +++ b/atom-conduit.cabal @@ -1,5 +1,5 @@ name: atom-conduit -version: 0.5.0.3 +version: 0.6.0.0 cabal-version: >=1.10 build-type: Simple license: PublicDomain @@ -33,8 +33,8 @@ conduit >=1.3, safe-exceptions -any, lens-simple -any, - mono-traversable >=1.0.0.1, parsers -any, + refined -any, text -any, time >=1.5, timerep >=2.0, @@ -54,9 +54,10 @@ data-default -any, filepath -any, lens-simple -any, - mono-traversable >=1.0.0.1, parsers -any, + pretty-simple -any, quickcheck-instances -any, + refined -any, resourcet -any, safe-exceptions -any, tasty -any, diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -10,8 +10,6 @@ import Data.Default import Data.Functor.Identity import Data.Monoid -import Data.MonoTraversable -import Data.NonNull import Data.String import Data.Text as Text import Data.Text.Encoding as Text @@ -20,6 +18,7 @@ import Data.Void import Data.XML.Types import Lens.Simple +import Refined import System.FilePath import Test.QuickCheck.Instances import Test.Tasty @@ -31,6 +30,7 @@ import Text.Atom.Lens import Text.Atom.Types import Text.Parser.Combinators +import Text.Pretty.Simple import qualified Text.XML.Stream.Parse as XML import URI.ByteString @@ -55,7 +55,7 @@ return $ testGroup "Atom golden tests" $ do xmlFile <- xmlFiles let goldenFile = addExtension xmlFile ".golden" - f file = fmap (Lazy.encodeUtf8 . fromString . show) $ runResourceT $ runConduit $ sourceFile file .| Conduit.decodeUtf8 .| XML.parseText' def .| XML.force "Invalid " atomFeed + f file = fmap (Lazy.encodeUtf8 . pShowNoColor) $ runResourceT $ runConduit $ sourceFile file .| Conduit.decodeUtf8 .| XML.parseText' def .| XML.force "Invalid " atomFeed return $ goldenVsString xmlFile goldenFile $ f xmlFile properties :: TestTree @@ -81,7 +81,7 @@ personCase :: TestTree personCase = testCase "Person construct" $ do result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid " (atomPerson "author") - toNullable (result ^. personNameL) @?= "John Doe" + unrefine (result ^. personNameL) @?= "John Doe" result ^. personEmailL @?= "JohnDoe@example.com" result ^. personUriL @?= Just (AtomURI $ URI (Scheme "http") (Just $ Authority Nothing (Host "example.com") Nothing) "/~johndoe" (Query []) Nothing) where input = @@ -97,7 +97,7 @@ result <- runResourceT . runConduit $ yieldMany input .| XML.parseText' def .| XML.force "Invalid " atomGenerator result ^. generatorUriL @?= Just (AtomURI $ RelativeRef Nothing "/myblog.php" (Query []) Nothing) (result ^. generatorVersionL) @?= "1.0" - toNullable (result ^. generatorContentL) @?= "Example Toolkit" + unrefine (result ^. generatorContentL) @?= "Example Toolkit" where input = [ "" , "Example Toolkit" @@ -151,8 +151,10 @@ digit = arbitrary `suchThat` isDigit alphaNum = oneof [letter, digit] -instance (MonoFoldable a, Arbitrary a) => Arbitrary (NonNull a) where - arbitrary = impureNonNull <$> arbitrary `suchThat` (not . onull) +instance Arbitrary (Refined (Not Null) Text) where + arbitrary = do + ~(Right text) <- refine <$> arbitrary `suchThat` (not . Text.null) + return text instance Arbitrary Scheme where arbitrary = do @@ -214,7 +216,7 @@ instance Arbitrary AtomGenerator where arbitrary = do - ~(Just content) <- fromNullable . pack <$> listOf1 alphaNum + ~(Right content) <- refine . pack <$> listOf1 alphaNum AtomGenerator <$> arbitrary <*> arbitrary <*> pure content shrink = genericShrink