Skip to content

Commit

Permalink
Merge pull request #52 from k0ral/master
Browse files Browse the repository at this point in the history 
Reuse 'MonadThrow' and 'force' for 'AttrParser'
  • Loading branch information
@snoyberg
snoyberg committed May 9, 2015
2 parents a23e65b + 67a380c commit dd3765d
Showing 1 changed file with 63 additions and 59 deletions.
122 changes: 63 additions & 59 deletions xml-conduit/Text/XML/Stream/Parse.hs
View file
Original file line number Diff line number Diff line change
@@ -1,10 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
-- | This module provides both a native Haskell solution for parsing XML
-- documents into a stream of events, and a set of parser combinators for
-- dealing with a stream of events.
Expand Down Expand Up @@ -75,6 +75,7 @@ module Text.XML.Stream.Parse
, contentMaybe
-- * Attribute parsing
, AttrParser
, attr
, requireAttr
, optionalAttr
, requireAttrRaw
Expand All @@ -91,47 +92,47 @@ module Text.XML.Stream.Parse
, PositionRange
, EventPos
) where
import Data.Attoparsec.Text
( char, Parser, takeWhile1, skipWhile, string
, manyTill, takeWhile, try, anyChar
)
import qualified Control.Applicative as A
import Control.Monad.Trans.Resource (MonadThrow, monadThrow, MonadResource)
import Data.Conduit.Attoparsec (conduitParser, PositionRange)
import Data.XML.Types
( Name (..), Event (..), Content (..)
, Instruction (..), ExternalID (..)
)
import qualified Control.Applicative as A
import Control.Monad.Trans.Resource (MonadResource, MonadThrow (..),
monadThrow)
import Data.Attoparsec.Text (Parser, anyChar, char, manyTill,
skipWhile, string, takeWhile,
takeWhile1, try)
import Data.Conduit.Attoparsec (PositionRange, conduitParser)
import Data.XML.Types (Content (..), Event (..),
ExternalID (..),
Instruction (..), Name (..))

import Filesystem.Path.CurrentOS (FilePath, encodeString)
import Control.Applicative (Applicative(..), Alternative(empty,(<|>)), (<$>))
import Data.Text (Text, pack)
import Control.Arrow ((***))
import qualified Data.Text as T
import Data.Text.Read (Reader, decimal, hexadecimal)
import Data.Text.Encoding (decodeUtf32BEWith)
import Data.Text.Encoding.Error (ignore)
import Data.Word (Word32)
import Blaze.ByteString.Builder (fromWord32be, toByteString)
import Text.XML.Stream.Token
import Prelude hiding (takeWhile, FilePath)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import Data.Conduit
import qualified Data.Conduit.Text as CT
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Internal as CI
import Control.Monad (ap, liftM, void, guard)
import qualified Data.Text as TS
import Data.List (foldl')
import Data.Typeable (Typeable)
import Control.Exception (Exception)
import Data.Conduit.Binary (sourceFile)
import Data.Char (isSpace)
import Data.Default (Default (..))
import Control.Monad.Trans.Class (lift)
import Data.Maybe (fromMaybe, isNothing)
import Blaze.ByteString.Builder (fromWord32be, toByteString)
import Control.Applicative (Alternative (empty, (<|>)),
Applicative (..), (<$>))
import Control.Arrow ((***))
import Control.Exception (Exception (..), SomeException)
import Control.Monad (ap, guard, liftM, void)
import Control.Monad.Trans.Class (lift)
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import Data.Char (isSpace)
import Data.Conduit
import Data.Conduit.Binary (sourceFile)
import qualified Data.Conduit.Internal as CI
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Text as CT
import Data.Default (Default (..))
import Data.List (foldl')
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, isNothing)
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Text as TS
import Data.Text.Encoding (decodeUtf32BEWith)
import Data.Text.Encoding.Error (ignore)
import Data.Text.Read (Reader, decimal, hexadecimal)
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Filesystem.Path.CurrentOS (FilePath, encodeString)
import Prelude hiding (FilePath, takeWhile)
import Text.XML.Stream.Token

type Ents = [(Text, Text)]

Expand Down Expand Up @@ -618,7 +619,7 @@ tag checkName attrParser f = do
case runAttrParser p as of
Left e -> Left e
Right ([], x) -> Right x
Right (attr, _) -> Left $ UnparsedAttributes attr
Right (attr, _) -> Left $ toException $ UnparsedAttributes attr

-- | A simplified version of 'tag' which matches against boolean predicates.
tagPredicate :: MonadThrow m
Expand Down Expand Up @@ -675,14 +676,13 @@ choose (i:is) =
i >>= maybe (choose is) (return . Just)

-- | Force an optional parser into a required parser. All of the 'tag'
-- functions, 'choose' and 'many' deal with 'Maybe' parsers. Use this when you
-- functions, 'attr', 'choose' and 'many' deal with 'Maybe' parsers. Use this when you
-- want to finally force something to happen.
force :: MonadThrow m
=> String -- ^ Error message
-> CI.ConduitM Event o m (Maybe a) -- ^ Optional parser to be forced
-> CI.ConduitM Event o m a
force msg i =
i >>= maybe (lift $ monadThrow $ XmlException msg Nothing) return
-> m (Maybe a) -- ^ Optional parser to be forced
-> m a
force msg i = i >>= maybe (throwM $ XmlException msg Nothing) return

-- | A helper function which reads a file from disk using 'enumFile', detects
-- character encoding using 'detectUtf', parses the XML using 'parseBytes', and
Expand Down Expand Up @@ -718,7 +718,7 @@ instance Exception XmlException
--
-- 'Alternative' instance behave like 'First' monoid. It chooses first
-- parser which doesn't fail.
newtype AttrParser a = AttrParser { runAttrParser :: [(Name, [Content])] -> Either XmlException ([(Name, [Content])], a) }
newtype AttrParser a = AttrParser { runAttrParser :: [(Name, [Content])] -> Either SomeException ([(Name, [Content])], a) }

instance Monad AttrParser where
return a = AttrParser $ \as -> Right (as, a)
Expand All @@ -730,9 +730,11 @@ instance Applicative AttrParser where
pure = return
(<*>) = ap
instance Alternative AttrParser where
empty = AttrParser $ const $ Left $ XmlException "AttrParser.empty" Nothing
empty = AttrParser $ const $ Left $ toException $ XmlException "AttrParser.empty" Nothing
AttrParser f <|> AttrParser g = AttrParser $ \x ->
either (const $ g x) Right (f x)
instance MonadThrow AttrParser where
throwM = AttrParser . const . throwM

optionalAttrRaw :: ((Name, [Content]) -> Maybe b) -> AttrParser (Maybe b)
optionalAttrRaw f =
Expand All @@ -746,16 +748,18 @@ optionalAttrRaw f =

requireAttrRaw :: String -> ((Name, [Content]) -> Maybe b) -> AttrParser b
requireAttrRaw msg f = optionalAttrRaw f >>=
maybe (AttrParser $ const $ Left $ XmlException msg Nothing)
maybe (AttrParser $ const $ Left $ toException $ XmlException msg Nothing)
return

-- | Require that a certain attribute be present and return its value.
-- | Return the value for an attribute if present.
attr :: Name -> AttrParser (Maybe Text)
attr = optionalAttr

-- | Shortcut composition of 'force' and 'attr'.
requireAttr :: Name -> AttrParser Text
requireAttr n = requireAttrRaw
("Missing attribute: " ++ show n)
(\(x, y) -> if x == n then Just (contentsToText y) else Nothing)
requireAttr n = force ("Missing attribute: " ++ show n) $ attr n

-- | Return the value for an attribute if present.
{-# DEPRECATED optionalAttr "Please use 'attr'." #-}
optionalAttr :: Name -> AttrParser (Maybe Text)
optionalAttr n = optionalAttrRaw
(\(x, y) -> if x == n then Just (contentsToText y) else Nothing)
Expand Down

0 comments on commit dd3765d

Please sign in to comment.