hextream (empty) → 0.1.0.0
raw patch · 18 files changed
+2096/−0 lines, 18 filesdep +attoparsecdep +basedep +base-compatbuild-type:Customsetup-changed
Dependencies added: attoparsec, base, base-compat, containers, data-default, doctest, filepath, hextream, parsers, pretty-simple, resourcet, streaming-attoparsec, streaming-bytestring, tasty, tasty-golden, tasty-hunit, text
Files
- LICENSE +121/−0
- Setup.hs +6/−0
- hextream.cabal +85/−0
- src/Data/XML/Parser/High.hs +278/−0
- src/Data/XML/Parser/High/AttrParser.hs +84/−0
- src/Data/XML/Parser/High/NameParser.hs +59/−0
- src/Data/XML/Parser/Low.hs +183/−0
- src/Data/XML/Parser/Low/Entity.hs +301/−0
- src/Data/XML/Parser/Low/Name.hs +106/−0
- src/Data/XML/Parser/Mid.hs +235/−0
- src/Data/XML/Parser/Mid/Attribute.hs +36/−0
- src/Data/XML/Parser/Mid/Doctype.hs +111/−0
- test/doc.hs +13/−0
- test/feed.xml +17/−0
- test/feed.xml.high.golden +137/−0
- test/feed.xml.mid.golden +250/−0
- test/golden.hs +36/−0
- test/unit.hs +38/−0
+ LICENSE view
@@ -0,0 +1,121 @@+Creative Commons Legal Code++CC0 1.0 Universal++ CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE+ LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN+ ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS+ INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES+ REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS+ PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM+ THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED+ HEREUNDER.++Statement of Purpose++The laws of most jurisdictions throughout the world automatically confer+exclusive Copyright and Related Rights (defined below) upon the creator+and subsequent owner(s) (each and all, an "owner") of an original work of+authorship and/or a database (each, a "Work").++Certain owners wish to permanently relinquish those rights to a Work for+the purpose of contributing to a commons of creative, cultural and+scientific works ("Commons") that the public can reliably and without fear+of later claims of infringement build upon, modify, incorporate in other+works, reuse and redistribute as freely as possible in any form whatsoever+and for any purposes, including without limitation commercial purposes.+These owners may contribute to the Commons to promote the ideal of a free+culture and the further production of creative, cultural and scientific+works, or to gain reputation or greater distribution for their Work in+part through the use and efforts of others.++For these and/or other purposes and motivations, and without any+expectation of additional consideration or compensation, the person+associating CC0 with a Work (the "Affirmer"), to the extent that he or she+is an owner of Copyright and Related Rights in the Work, voluntarily+elects to apply CC0 to the Work and publicly distribute the Work under its+terms, with knowledge of his or her Copyright and Related Rights in the+Work and the meaning and intended legal effect of CC0 on those rights.++1. Copyright and Related Rights. A Work made available under CC0 may be+protected by copyright and related or neighboring rights ("Copyright and+Related Rights"). Copyright and Related Rights include, but are not+limited to, the following:++ i. the right to reproduce, adapt, distribute, perform, display,+ communicate, and translate a Work;+ ii. moral rights retained by the original author(s) and/or performer(s);+iii. publicity and privacy rights pertaining to a person's image or+ likeness depicted in a Work;+ iv. rights protecting against unfair competition in regards to a Work,+ subject to the limitations in paragraph 4(a), below;+ v. rights protecting the extraction, dissemination, use and reuse of data+ in a Work;+ vi. database rights (such as those arising under Directive 96/9/EC of the+ European Parliament and of the Council of 11 March 1996 on the legal+ protection of databases, and under any national implementation+ thereof, including any amended or successor version of such+ directive); and+vii. other similar, equivalent or corresponding rights throughout the+ world based on applicable law or treaty, and any national+ implementations thereof.++2. Waiver. To the greatest extent permitted by, but not in contravention+of, applicable law, Affirmer hereby overtly, fully, permanently,+irrevocably and unconditionally waives, abandons, and surrenders all of+Affirmer's Copyright and Related Rights and associated claims and causes+of action, whether now known or unknown (including existing as well as+future claims and causes of action), in the Work (i) in all territories+worldwide, (ii) for the maximum duration provided by applicable law or+treaty (including future time extensions), (iii) in any current or future+medium and for any number of copies, and (iv) for any purpose whatsoever,+including without limitation commercial, advertising or promotional+purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each+member of the public at large and to the detriment of Affirmer's heirs and+successors, fully intending that such Waiver shall not be subject to+revocation, rescission, cancellation, termination, or any other legal or+equitable action to disrupt the quiet enjoyment of the Work by the public+as contemplated by Affirmer's express Statement of Purpose.++3. Public License Fallback. Should any part of the Waiver for any reason+be judged legally invalid or ineffective under applicable law, then the+Waiver shall be preserved to the maximum extent permitted taking into+account Affirmer's express Statement of Purpose. In addition, to the+extent the Waiver is so judged Affirmer hereby grants to each affected+person a royalty-free, non transferable, non sublicensable, non exclusive,+irrevocable and unconditional license to exercise Affirmer's Copyright and+Related Rights in the Work (i) in all territories worldwide, (ii) for the+maximum duration provided by applicable law or treaty (including future+time extensions), (iii) in any current or future medium and for any number+of copies, and (iv) for any purpose whatsoever, including without+limitation commercial, advertising or promotional purposes (the+"License"). The License shall be deemed effective as of the date CC0 was+applied by Affirmer to the Work. Should any part of the License for any+reason be judged legally invalid or ineffective under applicable law, such+partial invalidity or ineffectiveness shall not invalidate the remainder+of the License, and in such case Affirmer hereby affirms that he or she+will not (i) exercise any of his or her remaining Copyright and Related+Rights in the Work or (ii) assert any associated claims and causes of+action with respect to the Work, in either case contrary to Affirmer's+express Statement of Purpose.++4. Limitations and Disclaimers.++ a. No trademark or patent rights held by Affirmer are waived, abandoned,+ surrendered, licensed or otherwise affected by this document.+ b. Affirmer offers the Work as-is and makes no representations or+ warranties of any kind concerning the Work, express, implied,+ statutory or otherwise, including without limitation warranties of+ title, merchantability, fitness for a particular purpose, non+ infringement, or the absence of latent or other defects, accuracy, or+ the present or absence of errors, whether or not discoverable, all to+ the greatest extent permissible under applicable law.+ c. Affirmer disclaims responsibility for clearing rights of other persons+ that may apply to the Work or any use thereof, including without+ limitation any person's Copyright and Related Rights in the Work.+ Further, Affirmer disclaims responsibility for obtaining any necessary+ consents, permissions or other rights required for any use of the+ Work.+ d. Affirmer understands and acknowledges that Creative Commons is not a+ party to this document and has no duty or obligation with respect to+ this CC0 or use of the Work.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main where++import Distribution.Extra.Doctest (defaultMainWithDoctests)++main :: IO ()+main = defaultMainWithDoctests "doctest"
+ hextream.cabal view
@@ -0,0 +1,85 @@+cabal-version: 2.4++name: hextream+version: 0.1.0.0+synopsis: Streaming-friendly XML parsers+description: Cf README file+homepage: https://github.com/k0ral/hextream+bug-reports: https://github.com/k0ral/hextream/issues+license: CC0-1.0+license-file: LICENSE+author: koral+maintainer: mail@cmoreau.info+category: Parsing, XML+build-type: Custom+extra-source-files: test/*.xml, test/*.golden+tested-with: GHC <8.10 && >=8.6++source-repository head+ type: git+ location: git://github.com/k0ral/hextream.git++common common+ build-depends: base >=4.12 && <5, base-compat+ default-language: Haskell2010++custom-setup+ setup-depends: base >=4.12 && <5, Cabal >=2.4, cabal-doctest++library+ import: common+ exposed-modules:+ Data.XML.Parser.Low+ Data.XML.Parser.Low.Entity+ Data.XML.Parser.Low.Name+ Data.XML.Parser.Mid+ Data.XML.Parser.Mid.Attribute+ Data.XML.Parser.Mid.Doctype+ Data.XML.Parser.High+ Data.XML.Parser.High.AttrParser+ Data.XML.Parser.High.NameParser+ build-depends: containers, parsers, text+ hs-source-dirs: src++test-suite doctest+ import: common+ type: exitcode-stdio-1.0+ main-is: doc.hs+ hs-source-dirs: test+ build-depends: attoparsec, doctest >= 0.8, hextream++test-suite golden+ import: common+ type: exitcode-stdio-1.0+ main-is: golden.hs+ build-depends:+ hextream,+ attoparsec,+ data-default,+ filepath,+ pretty-simple,+ resourcet,+ streaming-attoparsec,+ streaming-bytestring,+ tasty,+ tasty-golden,+ text+ hs-source-dirs: test++test-suite unit+ import: common+ type: exitcode-stdio-1.0+ main-is: unit.hs+ build-depends:+ hextream,+ attoparsec,+ filepath,+ parsers,+ resourcet,+ streaming-attoparsec,+ streaming-bytestring,+ tasty,+ tasty-hunit,+ text+ hs-source-dirs: test+
+ src/Data/XML/Parser/High.hs view
@@ -0,0 +1,278 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+-- | High-level XML parsers, built on top of "Data.XML.Parser.Mid":+--+-- - entity references are expanded+-- - CDATAs are abstracted away+-- - comments are ignored+-- - whitespace between tokens is ignored+-- - duplicate attributes are ignored+--+-- All documentation examples assume the following setup:+--+-- > :set -XOverloadedStrings+-- > import Data.Attoparsec.ByteString+module Data.XML.Parser.High+ ( module Data.XML.Parser.High.AttrParser+ , module Data.XML.Parser.High.NameParser+ , Prolog(..)+ , Token(..)+ , TokenParser()+ , ContentParser()+ , noContent+ , withContent+ , anyContent+ , runTokenParser+ , prolog+ , instruction+ , textContent+ , textContent'+ , tag+ , tag'+ , anyTag+ , anyToken+ , anyToken'+ ) where++import Control.Applicative+import Control.Arrow+import Control.Monad.Compat+import Control.Monad.Fail.Compat+import Data.Function+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text+import Data.XML.Parser.High.AttrParser+import Data.XML.Parser.High.NameParser+import Data.XML.Parser.Low+import qualified Data.XML.Parser.Mid as L1+import Data.XML.Parser.Mid.Attribute+import Prelude ()+import Prelude.Compat+import Text.Parser.Char+import Text.Parser.Combinators+import Text.ParserCombinators.ReadP (readP_to_S)+++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Attoparsec.ByteString++-- | XML document prolog.+data Prolog = Prolog+ { prologXmlDeclaration :: Maybe L1.XMLDeclaration+ , prologInstructions :: [L1.Instruction]+ , prologDoctype :: Maybe L1.Doctype+ } deriving (Eq, Ord, Read, Show)++data Token+ = TokenProlog Prolog+ | TokenInstruction L1.Instruction+ | TokenTag QName (Map QName Text) [Token]+ | TokenTextContent Text+ deriving (Eq, Ord, Read, Show)+++-- | A parser that consumes whole 'Token's.+newtype TokenParser m a = TokenParser { runTokenParser :: m a }++deriving instance Functor m => Functor (TokenParser m)+deriving instance Applicative m => Applicative (TokenParser m)+deriving instance Alternative m => Alternative (TokenParser m)+deriving instance Monad m => Monad (TokenParser m)++instance (Parsing m, Monad m) => MonadFail (TokenParser m) where+ fail = TokenParser . unexpected++-- | How to parse tag content.+data ContentParser m a+ = NoContent (m a)+ | AnyContent ([Token] -> m a)+ | WithContent (TokenParser m a)++deriving instance Functor m => Functor (ContentParser m)++-- | Assert that content is not empty, and parse it using given token parser.+--+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr (withContent textContent')) "<tag key='value'>body</tag>"+-- Right "body"+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr (withContent textContent')) "<tag key='value'></tag>"+-- Left ...+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr (withContent textContent')) "<tag key='value'/>"+-- Left ...+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr (withContent $ pure ())) "<tag key='value'/>"+-- Left ...+withContent :: TokenParser m a -> ContentParser m a+withContent = WithContent++-- | Assert that content is empty.+--+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr noContent) "<tag key='value'>body</tag>"+-- Left ...+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr noContent) "<tag key='value'></tag>"+-- Right ()+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr noContent) "<tag key='value'/>"+-- Right ()+noContent :: Applicative m => ContentParser m ()+noContent = NoContent $ pure ()++-- | Accept any content, including empty content.+--+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr anyContent) "<tag key='value'>body</tag>"+-- Right ()+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr anyContent) "<tag key='value'></tag>"+-- Right ()+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr anyContent) "<tag key='value'/>"+-- Right ()+anyContent :: CharParsing m => Monad m => ContentParser m ()+anyContent = AnyContent $ const $ pure ()++-- | Parse a processing instruction.+--+-- <https://www.w3.org/TR/REC-xml/#dt-pi>+--+-- >>> parseOnly (runTokenParser instruction) "<?php echo 'Hello World!'; ?>"+-- Right (Instruction "php" "echo 'Hello World!'; ")+-- >>> parseOnly (runTokenParser instruction) "<!-- comments and whitespace are ignored --> <?php echo 'Hello World!'; ?>"+-- Right (Instruction "php" "echo 'Hello World!'; ")+instruction :: CharParsing m => Monad m => TokenParser m L1.Instruction+instruction = TokenParser $ do+ skipCommentsWhitespace+ L1.runTokenParser L1.tokenInstruction++-- | <https://www.w3.org/TR/REC-xml/#NT-prolog>+--+-- >>> parseOnly (runTokenParser prolog) "<?xml version='1.0'?><!DOCTYPE greeting>"+-- Right (Prolog {prologXmlDeclaration = Just (XMLDeclaration "1.0" ...), prologInstructions = [], prologDoctype = Just (Doctype "greeting" ...)})+-- >>> parseOnly (runTokenParser prolog) "<?xml version='1.0'?> <!-- comments and whitespace are ignored --><!DOCTYPE greeting>"+-- Right (Prolog {prologXmlDeclaration = Just (XMLDeclaration "1.0" ...), prologInstructions = [], prologDoctype = Just (Doctype "greeting" ...)})+prolog :: CharParsing m => Monad m => TokenParser m Prolog+prolog = TokenParser $ do+ xmlDeclaration <- optional $ L1.runTokenParser L1.tokenXmlDeclaration+ skipCommentsWhitespace+ instructions <- runTokenParser $ many instruction+ doctype <- optional $ do+ skipCommentsWhitespace+ L1.runTokenParser L1.tokenDoctype++ when (isNothing xmlDeclaration && null instructions && isNothing doctype)+ $ unexpected "Expected XML prolog"++ return $ Prolog xmlDeclaration instructions doctype+++-- | Parse textual content of a tag, including CDATA.+textContent :: CharParsing m => Monad m => EntityDecoder -> TokenParser m Text+textContent entityDecoder = TokenParser $ mconcat <$> do+ skipComments+ (textualData <|> L1.runTokenParser L1.tokenCdata) `sepBy1` L1.runTokenParser L1.tokenComment+ where textualData = expandContents entityDecoder =<< L1.runTokenParser L1.tokenData++-- | Same as @textContent (decodePredefinedEntities <> decodeHtmlEntities)@, provided for convenience.+--+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr (withContent textContent')) "<tag>body<!-- Ignored comment --><![CDATA[<innertag>innerbody</innertag>]]></tag>"+-- Right "body<innertag>innerbody</innertag>"+textContent' :: CharParsing m => Monad m => TokenParser m Text+textContent' = textContent decodeStandardEntities+++normalizeAttributes :: EntityDecoder -> [Attribute] -> Map QName Text+normalizeAttributes entityDecoder attributes = Map.fromList $ do+ Attribute name contents <- attributes+ value <- maybeToList $ expandContents entityDecoder contents+ return (name, value)++-- | Generic tag parser.+tag :: CharParsing m => Monad m+ => EntityDecoder -- ^ How to expand entity references+ -> NameParser a -- ^ How to parse tag name+ -> (a -> AttrParser b) -- ^ How to parse tag attributes+ -> (b -> ContentParser m c) -- ^ How to parse tag content+ -> TokenParser m c+tag entityDecoder parseName parseAttributes parseContent = parseStartToEnd <|> parseEmptyElement where+ parseStartToEnd = TokenParser $ do+ skipCommentsWhitespace+ L1.StartTag name attributes <- L1.runTokenParser L1.tokenStartTag+ a <- processName name+ b <- processAttributes a attributes+ c <- case parseContent b of+ NoContent f -> f+ AnyContent f -> f =<< runTokenParser (many $ anyToken entityDecoder)+ WithContent parser -> runTokenParser parser+ skipCommentsWhitespace+ L1.runTokenParser $ do+ name' <- L1.tokenEndTag+ when (name /= name') $ fail "Invalid end tag name"+ return c+ parseEmptyElement = TokenParser $ do+ skipCommentsWhitespace+ L1.EmptyElementTag name attributes <- L1.runTokenParser L1.tokenEmptyElementTag+ a <- processName name+ b <- processAttributes a attributes+ case parseContent b of+ NoContent f -> f+ AnyContent f -> f mempty+ WithContent parser -> unexpected "Expected non-empty tag"+ processName name = runNameParser parseName name+ & maybe (unexpected "Unexpected name") return+ processAttributes state attributes = runAttrParser (parseAttributes state) (normalizeAttributes entityDecoder attributes)+ & maybe (unexpected "Unexpected attributes") return++-- | Simplified version of 'tag':+--+-- - no state forwarding between name, attributes and content parsers+-- - uses @decodePredefinedEntities <> decodeHtmlEntities@ to expand entity references+tag' :: CharParsing m => Monad m+ => NameParser a -- ^ How to parse tag name+ -> AttrParser b -- ^ How to parse tag attributes+ -> ContentParser m c -- ^ How to parse tag content+ -> TokenParser m c+tag' parseName parseAttributes parseBody = tag decodeStandardEntities parseName (const parseAttributes) (const parseBody)++-- | Parse a tag with any name, any attributes and any content.+--+-- >>> parseOnly (runTokenParser anyTag) "<tag key='value'>body</tag>"+-- Right ()+-- >>> parseOnly (runTokenParser anyTag) "<tag key='value'/>"+-- Right ()+-- >>> parseOnly (runTokenParser anyTag) "<!-- ignored comment --><tag key='value'/>"+-- Right ()+-- >>> parseOnly (runTokenParser anyTag) "<tag key='value'>body<!-- ignored comment --></tag>"+-- Right ()+anyTag :: CharParsing m => Monad m => TokenParser m ()+anyTag = tag' anyName anyAttr anyContent+++-- | Parse any 'Token'.+anyToken :: CharParsing m => Monad m => EntityDecoder -> TokenParser m Token+anyToken entityDecoder = (TokenProlog <$> prolog)+ <|> (TokenInstruction <$> instruction)+ <|> tokenTag+ <|> (TokenTextContent <$> textContent entityDecoder)+ where tokenTag = tag entityDecoder anyName (\name -> (name,) <$> forwardAttrs) $ \(name, attributes) ->+ TokenTag name attributes <$> AnyContent pure+ forwardAttrs = AttrParser Just++-- | Same as @anyToken (decodePredefinedEntities <> decodeHtmlEntities)@, provided for convenience.+anyToken' :: CharParsing m => Monad m => TokenParser m Token+anyToken' = anyToken decodeStandardEntities+++-- * Private functions++skipComments :: CharParsing m => Monad m => m ()+skipComments = void $ many $ L1.runTokenParser L1.tokenComment++skipCommentsWhitespace :: CharParsing m => Monad m => m ()+skipCommentsWhitespace = void $ many $ void (L1.runTokenParser L1.tokenComment) <|> void tokenWhitespace++decodeStandardEntities :: EntityDecoder+decodeStandardEntities = decodePredefinedEntities <> decodeHtmlEntities
+ src/Data/XML/Parser/High/AttrParser.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | All documentation examples assume the following setup:+--+-- > :set -XOverloadedStrings+-- > import Data.Attoparsec.ByteString+-- > import Data.XML.Parser.High+module Data.XML.Parser.High.AttrParser+ ( AttrParser(..)+ , anyAttr+ , noAttr+ , attrValue+ , hasAttr+ ) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Text (Text)+import Data.XML.Parser.Low.Name++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Attoparsec.ByteString+-- >>> import Data.XML.Parser.High++-- | How to parse tag attributes.+newtype AttrParser a = AttrParser { runAttrParser :: Map QName Text -> Maybe a }++deriving instance Functor AttrParser+deriving via (WrappedArrow (Kleisli Maybe) (Map QName Text)) instance Applicative AttrParser++-- | Can be combined with @\<|\>@+deriving via (WrappedArrow (Kleisli Maybe) (Map QName Text)) instance Alternative AttrParser++-- | Can be combined with @>>=@. Attributes map is forwarded without change.+instance Monad AttrParser where+ (AttrParser f) >>= g = AttrParser $ \attributes -> do+ a <- f attributes+ let AttrParser g' = g a+ g' attributes++-- | Parse any set of attributes.+--+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr noContent) "<tag></tag>"+-- Right ()+-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr noContent) "<tag key='value'></tag>"+-- Right ()+anyAttr :: AttrParser ()+anyAttr = pure ()++-- | Assert that no attributes exist.+--+-- >>> parseOnly (runTokenParser $ tag' anyName noAttr noContent) "<tag></tag>"+-- Right ()+-- >>> parseOnly (runTokenParser $ tag' anyName noAttr noContent) "<tag key='value'></tag>"+-- Left ...+noAttr :: AttrParser ()+noAttr = AttrParser $ \attributes -> if null attributes then Just () else Nothing++-- | Parse attribute by name, and return its value.+--+-- >>> parseOnly (runTokenParser $ tag' anyName (attrValue "foo") noContent) "<tag></tag>"+-- Left ...+-- >>> parseOnly (runTokenParser $ tag' anyName (attrValue "foo") noContent) "<tag foo='bar'></tag>"+-- Right ()+attrValue :: QName -> AttrParser Text+attrValue name = AttrParser $ Map.lookup name++-- | Assert that an attribute exists, with given name and value.+--+-- >>> parseOnly (runTokenParser $ tag' anyName (hasAttr "foo" "bar") noContent) "<tag></tag>"+-- Left ...+-- >>> parseOnly (runTokenParser $ tag' anyName (hasAttr "foo" "bar") noContent) "<tag foo='baz'></tag>"+-- Left ...+-- >>> parseOnly (runTokenParser $ tag' anyName (hasAttr "foo" "bar") noContent) "<tag foo='bar'></tag>"+-- Right ()+hasAttr :: QName -> Text -> AttrParser ()+hasAttr name value = attrValue name >>= \value' -> guard (value == value')
+ src/Data/XML/Parser/High/NameParser.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+-- | All documentation examples assume the following setup:+--+-- > :set -XOverloadedStrings+-- > import Data.Attoparsec.ByteString+-- > import Data.XML.Parser.High+module Data.XML.Parser.High.NameParser+ ( NameParser(..)+ , anyName+ , anyNameExcept+ ) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Data.String+import Data.XML.Parser.Low++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Attoparsec.ByteString+-- >>> import Data.XML.Parser.High++-- | How to parse tag names.+newtype NameParser a = NameParser { runNameParser :: QName -> Maybe a }++deriving instance Functor NameParser+deriving via (WrappedArrow (Kleisli Maybe) QName) instance Applicative NameParser++-- | Can be combined with @\<|\>@+deriving via (WrappedArrow (Kleisli Maybe) QName) instance Alternative NameParser++-- | Match a single 'QName' in a concise way.+--+-- >>> parseOnly (runTokenParser $ tag' "foo" anyAttr anyContent) "<foo></foo>"+-- Right ()+instance (a ~ ()) => IsString (NameParser a) where+ fromString s = NameParser $ \(QName _ name) ->+ unless (fromString s == name) mempty++-- | Match any qualified name.+anyName :: NameParser QName+anyName = NameParser Just++-- | Match any qualified name, except for the given value.+--+-- >>> parseOnly (runTokenParser $ tag' (anyNameExcept "foo") anyAttr anyContent) "<foo></foo>"+-- Left ...+-- >>> parseOnly (runTokenParser $ tag' (anyNameExcept "foo") anyAttr anyContent) "<bar></bar>"+-- Right ()+anyNameExcept :: QName -> NameParser QName+anyNameExcept name = NameParser $ \name' -> do+ guard $ name /= name'+ return name'
+ src/Data/XML/Parser/Low.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Low-level XML parsers:+--+-- - parsed tokens are small and may overlap; it is not possible to tokenize XML document in a stateless way+-- - parsers are reversible: all formatting details are retained (e.g. whitespacing)+--+-- All documentation examples assume the following setup:+--+-- > :set -XOverloadedStrings+-- > import Data.Attoparsec.ByteString+module Data.XML.Parser.Low+ ( module Data.XML.Parser.Low.Entity+ , module Data.XML.Parser.Low.Name+ , module Data.XML.Parser.Low+ ) where++import Control.Applicative+import Control.Arrow ((>>>))+import Control.Monad+import Data.Char+import Data.Functor+import Data.Text (Text)+import qualified Data.Text as Text+import Data.XML.Parser.Low.Entity+import Data.XML.Parser.Low.Name+import Numeric+import Text.Parser.Char+import Text.Parser.Combinators+++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Attoparsec.ByteString++-- | Raw text or reference.+data Content = ContentText Text | ContentReference Reference+ deriving (Eq, Ord, Read, Show)++-- | Expand content reference, if any.+expandContent :: Alternative m => EntityDecoder -> Content -> m Text+expandContent _ (ContentText t) = pure t+expandContent f (ContentReference r) = expandReference f r++-- | Same as 'expandContent', but on a list. Provided for convenience.+expandContents :: Alternative m => Monad m => EntityDecoder -> [Content] -> m Text+expandContents f contents = mconcat <$> mapM (expandContent f) contents++-- | Entity reference, or character reference.+data Reference = EntityRef Text | CharRef Char+ deriving (Eq, Ord, Read, Show)++-- | Resolve reference into raw text.+expandReference :: Alternative m => EntityDecoder -> Reference -> m Text+expandReference _ (CharRef c) = pure $ Text.pack [c]+expandReference f (EntityRef name) = maybe empty pure $ runEntityDecoder f name++-- | Same as @expandReference decodePredefinedEntities@, provided for convenience.+expandReference' :: Reference -> Maybe Text+expandReference' = expandReference decodePredefinedEntities++-- | @'@+tokenSingleQuote :: CharParsing m => m Char+tokenSingleQuote = char '\''++-- | @"@+tokenDoubleQuote :: CharParsing m => m Char+tokenDoubleQuote = char '"'++-- | Single or double quote.+tokenQuote :: CharParsing m => m Char+tokenQuote = tokenSingleQuote <|> tokenDoubleQuote++-- | <https://www.w3.org/TR/REC-xml/#NT-S>+tokenWhitespace :: CharParsing m => m String+tokenWhitespace = some (satisfy isXmlSpace) where+ isXmlSpace ' ' = True+ isXmlSpace '\t' = True+ isXmlSpace '\r' = True+ isXmlSpace '\n' = True+ isXmlSpace _ = False++-- | <https://www.w3.org/TR/REC-xml/#NT-Eq>+tokenEqual :: CharParsing m => Monad m => m ()+tokenEqual = do+ optional tokenWhitespace+ char '='+ optional tokenWhitespace+ return ()++-- | <https://www.w3.org/TR/REC-xml/#NT-Reference>+--+-- >>> parseOnly tokenReference "<"+-- Right (CharRef '<')+-- >>> parseOnly tokenReference "&docdate;"+-- Right (EntityRef "docdate")+tokenReference :: CharParsing m => Monad m => m Reference+tokenReference = (EntityRef <$> entityRef) <|> (CharRef <$> decCharRef) <|> (CharRef <$> hexCharRef) where+ entityRef = char '&' *> tokenName <* char ';'+ decCharRef = between (string "&#") (char ';') $+ some digit >>= (readDec >>> liftParser "decimal") <&> chr++ hexCharRef = between (string "&#x") (char ';') $+ some hexDigit >>= (readHex >>> liftParser "hexadecimal") <&> chr+ liftParser _ ((result, _):_) = return result+ liftParser message _ = unexpected $ "Failed to parse " <> message++tokenContent :: CharParsing m => Monad m => String -> m Content+tokenContent forbiddenChars = (ContentText . Text.pack <$> some (noneOf $ '&':forbiddenChars))+ <|> (ContentReference <$> tokenReference)++-- | @<!ENTITY@+tokenEntityDeclarationOpen :: CharParsing m => m ()+tokenEntityDeclarationOpen = void $ string "<!ENTITY"++-- | Return processing instruction name.+--+-- >>> parseOnly tokenInstructionOpen "<?php"+-- Right "php"+tokenInstructionOpen :: CharParsing m => Monad m => m Text+tokenInstructionOpen = do+ string "<?"+ name <- tokenName+ guard $ Text.toLower name /= "xml"+ return name++-- | @?>@+tokenInstructionClose :: CharParsing m => m ()+tokenInstructionClose = void $ string "?>"++-- | @<![CDATA[@+--+-- <https://www.w3.org/TR/REC-xml/#NT-CDStart>+tokenCdataOpen :: CharParsing m => m ()+tokenCdataOpen = void $ string "<![CDATA["++-- | @]]>@+--+-- <https://www.w3.org/TR/REC-xml/#NT-CDEnd>+tokenCdataClose :: CharParsing m => m ()+tokenCdataClose = void $ string "]]>"++-- | @<!--@+tokenCommentOpen :: CharParsing m => m ()+tokenCommentOpen = void $ string "<!--"++-- | @-->@+tokenCommentClose :: CharParsing m => m ()+tokenCommentClose = void $ string "-->"++-- | @<!DOCTYPE@+tokenDoctypeOpen :: CharParsing m => m ()+tokenDoctypeOpen = void $ string "<!DOCTYPE"++-- | @<?xml@+tokenXmlDeclarationOpen :: CharParsing m => m ()+tokenXmlDeclarationOpen = void $ string "<?xml"++-- | @?>@+tokenXmlDeclarationClose :: CharParsing m => m ()+tokenXmlDeclarationClose = void $ string "?>"++-- | @/>@+tokenEmptyElementTagClose :: CharParsing m => m ()+tokenEmptyElementTagClose = void $ string "/>"++-- | Return tag name.+--+-- >>> parseOnly tokenStartTagOpen "<foo"+-- Right (QName {namePrefix = "", nameLocal = "foo"})+tokenStartTagOpen :: CharParsing m => Monad m => m QName+tokenStartTagOpen = char '<' *> tokenQualifiedName++-- | Return tag name.+--+-- >>> parseOnly tokenEndTagOpen "</foo"+-- Right (QName {namePrefix = "", nameLocal = "foo"})+tokenEndTagOpen :: CharParsing m => Monad m => m QName+tokenEndTagOpen = string "</" *> tokenQualifiedName++-- | @>@+tokenElementClose :: CharParsing m => m ()+tokenElementClose = void $ char '>'+
+ src/Data/XML/Parser/Low/Entity.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | Utilities to handle entity references.+module Data.XML.Parser.Low.Entity+ ( EntityDecoder(..)+ , decodePredefinedEntities+ , decodeHtmlEntities+ ) where++import Control.Applicative+import Control.Arrow (Kleisli (..), (>>>))+import Control.Monad+import Data.Function+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as Text+import Text.Parser.Char+import Text.Parser.Combinators+++-- | A function that describes how to expand entity references.+newtype EntityDecoder = EntityDecoder { runEntityDecoder :: Text -> Maybe Text }++-- | Can be combined with '(<>)' to try multiple decoders, from left to right.+deriving via (Alt (WrappedArrow (Kleisli Maybe) Text) Text) instance Semigroup EntityDecoder+deriving via (Alt (WrappedArrow (Kleisli Maybe) Text) Text) instance Monoid EntityDecoder+++-- | <https://www.w3.org/TR/REC-xml/#sec-predefined-ent>+decodePredefinedEntities :: EntityDecoder+decodePredefinedEntities = EntityDecoder $ \name ->+ Map.lookup name predefinedEntities & maybe empty pure++predefinedEntities :: Map Text Text+predefinedEntities = Map.fromList+ [ ("lt", "<")+ , ("gt", ">")+ , ("amp", "&")+ , ("quot", "\"")+ , ("apos", "'")+ ]++-- | <https://www.w3.org/TR/xhtml1/dtds.html#h-A2>+decodeHtmlEntities :: EntityDecoder+decodeHtmlEntities = EntityDecoder $ \name ->+ Map.lookup name htmlEntities & maybe empty pure++htmlEntities :: Map Text Text+htmlEntities = Map.fromList+ [ ("nbsp", "\160")+ , ("iexcl", "\161")+ , ("cent", "\162")+ , ("pound", "\163")+ , ("curren", "\164")+ , ("yen", "\165")+ , ("brvbar", "\166")+ , ("sect", "\167")+ , ("uml", "\168")+ , ("copy", "\169")+ , ("ordf", "\170")+ , ("laquo", "\171")+ , ("not", "\172")+ , ("shy", "\173")+ , ("reg", "\174")+ , ("macr", "\175")+ , ("deg", "\176")+ , ("plusmn", "\177")+ , ("sup2", "\178")+ , ("sup3", "\179")+ , ("acute", "\180")+ , ("micro", "\181")+ , ("para", "\182")+ , ("middot", "\183")+ , ("cedil", "\184")+ , ("sup1", "\185")+ , ("ordm", "\186")+ , ("raquo", "\187")+ , ("frac14", "\188")+ , ("frac12", "\189")+ , ("frac34", "\190")+ , ("iquest", "\191")+ , ("Agrave", "\192")+ , ("Aacute", "\193")+ , ("Acirc", "\194")+ , ("Atilde", "\195")+ , ("Auml", "\196")+ , ("Aring", "\197")+ , ("AElig", "\198")+ , ("Ccedil", "\199")+ , ("Egrave", "\200")+ , ("Eacute", "\201")+ , ("Ecirc", "\202")+ , ("Euml", "\203")+ , ("Igrave", "\204")+ , ("Iacute", "\205")+ , ("Icirc", "\206")+ , ("Iuml", "\207")+ , ("ETH", "\208")+ , ("Ntilde", "\209")+ , ("Ograve", "\210")+ , ("Oacute", "\211")+ , ("Ocirc", "\212")+ , ("Otilde", "\213")+ , ("Ouml", "\214")+ , ("times", "\215")+ , ("Oslash", "\216")+ , ("Ugrave", "\217")+ , ("Uacute", "\218")+ , ("Ucirc", "\219")+ , ("Uuml", "\220")+ , ("Yacute", "\221")+ , ("THORN", "\222")+ , ("szlig", "\223")+ , ("agrave", "\224")+ , ("aacute", "\225")+ , ("acirc", "\226")+ , ("atilde", "\227")+ , ("auml", "\228")+ , ("aring", "\229")+ , ("aelig", "\230")+ , ("ccedil", "\231")+ , ("egrave", "\232")+ , ("eacute", "\233")+ , ("ecirc", "\234")+ , ("euml", "\235")+ , ("igrave", "\236")+ , ("iacute", "\237")+ , ("icirc", "\238")+ , ("iuml", "\239")+ , ("eth", "\240")+ , ("ntilde", "\241")+ , ("ograve", "\242")+ , ("oacute", "\243")+ , ("ocirc", "\244")+ , ("otilde", "\245")+ , ("ouml", "\246")+ , ("divide", "\247")+ , ("oslash", "\248")+ , ("ugrave", "\249")+ , ("uacute", "\250")+ , ("ucirc", "\251")+ , ("uuml", "\252")+ , ("yacute", "\253")+ , ("thorn", "\254")+ , ("yuml", "\255")+ , ("OElig", "\338")+ , ("oelig", "\339")+ , ("Scaron", "\352")+ , ("scaron", "\353")+ , ("Yuml", "\376")+ , ("fnof", "\402")+ , ("circ", "\710")+ , ("tilde", "\732")+ , ("Alpha", "\913")+ , ("Beta", "\914")+ , ("Gamma", "\915")+ , ("Delta", "\916")+ , ("Epsilon", "\917")+ , ("Zeta", "\918")+ , ("Eta", "\919")+ , ("Theta", "\920")+ , ("Iota", "\921")+ , ("Kappa", "\922")+ , ("Lambda", "\923")+ , ("Mu", "\924")+ , ("Nu", "\925")+ , ("Xi", "\926")+ , ("Omicron", "\927")+ , ("Pi", "\928")+ , ("Rho", "\929")+ , ("Sigma", "\931")+ , ("Tau", "\932")+ , ("Upsilon", "\933")+ , ("Phi", "\934")+ , ("Chi", "\935")+ , ("Psi", "\936")+ , ("Omega", "\937")+ , ("alpha", "\945")+ , ("beta", "\946")+ , ("gamma", "\947")+ , ("delta", "\948")+ , ("epsilon", "\949")+ , ("zeta", "\950")+ , ("eta", "\951")+ , ("theta", "\952")+ , ("iota", "\953")+ , ("kappa", "\954")+ , ("lambda", "\955")+ , ("mu", "\956")+ , ("nu", "\957")+ , ("xi", "\958")+ , ("omicron", "\959")+ , ("pi", "\960")+ , ("rho", "\961")+ , ("sigmaf", "\962")+ , ("sigma", "\963")+ , ("tau", "\964")+ , ("upsilon", "\965")+ , ("phi", "\966")+ , ("chi", "\967")+ , ("psi", "\968")+ , ("omega", "\969")+ , ("thetasym", "\977")+ , ("upsih", "\978")+ , ("piv", "\982")+ , ("ensp", "\8194")+ , ("emsp", "\8195")+ , ("thinsp", "\8201")+ , ("zwnj", "\8204")+ , ("zwj", "\8205")+ , ("lrm", "\8206")+ , ("rlm", "\8207")+ , ("ndash", "\8211")+ , ("mdash", "\8212")+ , ("lsquo", "\8216")+ , ("rsquo", "\8217")+ , ("sbquo", "\8218")+ , ("ldquo", "\8220")+ , ("rdquo", "\8221")+ , ("bdquo", "\8222")+ , ("dagger", "\8224")+ , ("Dagger", "\8225")+ , ("bull", "\8226")+ , ("hellip", "\8230")+ , ("permil", "\8240")+ , ("prime", "\8242")+ , ("Prime", "\8243")+ , ("lsaquo", "\8249")+ , ("rsaquo", "\8250")+ , ("oline", "\8254")+ , ("frasl", "\8260")+ , ("euro", "\8364")+ , ("image", "\8465")+ , ("weierp", "\8472")+ , ("real", "\8476")+ , ("trade", "\8482")+ , ("alefsym", "\8501")+ , ("larr", "\8592")+ , ("uarr", "\8593")+ , ("rarr", "\8594")+ , ("darr", "\8595")+ , ("harr", "\8596")+ , ("crarr", "\8629")+ , ("lArr", "\8656")+ , ("uArr", "\8657")+ , ("rArr", "\8658")+ , ("dArr", "\8659")+ , ("hArr", "\8660")+ , ("forall", "\8704")+ , ("part", "\8706")+ , ("exist", "\8707")+ , ("empty", "\8709")+ , ("nabla", "\8711")+ , ("isin", "\8712")+ , ("notin", "\8713")+ , ("ni", "\8715")+ , ("prod", "\8719")+ , ("sum", "\8721")+ , ("minus", "\8722")+ , ("lowast", "\8727")+ , ("radic", "\8730")+ , ("prop", "\8733")+ , ("infin", "\8734")+ , ("ang", "\8736")+ , ("and", "\8743")+ , ("or", "\8744")+ , ("cap", "\8745")+ , ("cup", "\8746")+ , ("int", "\8747")+ , ("there4", "\8756")+ , ("sim", "\8764")+ , ("cong", "\8773")+ , ("asymp", "\8776")+ , ("ne", "\8800")+ , ("equiv", "\8801")+ , ("le", "\8804")+ , ("ge", "\8805")+ , ("sub", "\8834")+ , ("sup", "\8835")+ , ("nsub", "\8836")+ , ("sube", "\8838")+ , ("supe", "\8839")+ , ("oplus", "\8853")+ , ("otimes", "\8855")+ , ("perp", "\8869")+ , ("sdot", "\8901")+ , ("lceil", "\8968")+ , ("rceil", "\8969")+ , ("lfloor", "\8970")+ , ("rfloor", "\8971")+ , ("lang", "\9001")+ , ("rang", "\9002")+ , ("loz", "\9674")+ , ("spades", "\9824")+ , ("clubs", "\9827")+ , ("hearts", "\9829")+ , ("diams", "\9830")+ ]
+ src/Data/XML/Parser/Low/Name.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}+-- | All documentation examples assume the following setup:+--+-- > :set -XOverloadedStrings+-- > import Data.Attoparsec.ByteString+module Data.XML.Parser.Low.Name+ ( QName(..)+ , tokenQualifiedName+ , tokenNCName+ , tokenName+ ) where++import Control.Applicative+import Data.Char+import Data.Maybe+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text+import Text.Parser.Char++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Attoparsec.ByteString++-- | A qualified name.+--+-- <https://www.w3.org/TR/xml-names/#dt-qualname>+data QName = QName+ { namePrefix :: Text+ , nameLocal :: Text+ } deriving (Eq, Ord, Read, Show)++-- | Build a qualified name in a concise way. Prefix is assumed to be empty.+--+-- >>> "foo" :: QName+-- QName {namePrefix = "", nameLocal = "foo"}+instance IsString QName where+ fromString s = QName mempty $ Text.pack s++-- | <https://www.w3.org/TR/xml-names/#NT-QName>+--+-- >>> parseOnly tokenQualifiedName "price"+-- Right (QName {namePrefix = "", nameLocal = "price"})+-- >>> parseOnly tokenQualifiedName "edi:price"+-- Right (QName {namePrefix = "edi", nameLocal = "price"})+tokenQualifiedName :: CharParsing m => Monad m => m QName+tokenQualifiedName = do+ prefix <- optional $ tokenNCName <* char ':'+ value <- tokenNCName+ return $ QName (fromMaybe mempty prefix) value++-- | <https://www.w3.org/TR/REC-xml/#NT-NameStartChar>+isNameStartChar :: Char -> Bool+isNameStartChar ':' = True+isNameStartChar '_' = True+isNameStartChar c+ | isLetter c = True+ | fromEnum c > 0xC0 && fromEnum c < 0xD6 = True+ | fromEnum c > 0xD8 && fromEnum c < 0xF6 = True+ | fromEnum c > 0xF8 && fromEnum c < 0x2FF = True+ | fromEnum c > 0x370 && fromEnum c < 0x37D = True+ | fromEnum c > 0x37F && fromEnum c < 0x1FFF = True+ | fromEnum c > 0x200C && fromEnum c < 0x200D = True+ | fromEnum c > 0x2070 && fromEnum c < 0x218F = True+ | fromEnum c > 0x2C00 && fromEnum c < 0x2FEF = True+ | fromEnum c > 0x3001 && fromEnum c < 0xD7FF = True+ | fromEnum c > 0xF900 && fromEnum c < 0xFDCF = True+ | fromEnum c > 0xFDF0 && fromEnum c < 0xFFFD = True+ | fromEnum c > 0x10000 && fromEnum c < 0xEFFFF = True+ | otherwise = False++-- | <https://www.w3.org/TR/REC-xml/#NT-NameChar>+isNameChar :: Char -> Bool+isNameChar '-' = True+isNameChar '.' = True+isNameChar c+ | isDigit c = True+ | isNameStartChar c = True+ | fromEnum c == 0xB7 = True+ | fromEnum c > 0x0300 && fromEnum c < 0x036F = True+ | fromEnum c > 0x203F && fromEnum c < 0x2040 = True+ | otherwise = False++-- | <https://www.w3.org/TR/xml-names/#NT-NCName>+--+-- >>> parseOnly tokenNCName "price"+-- Right "price"+-- >>> parse tokenNCName "edi:price"+-- Done ":price" "edi"+tokenNCName :: CharParsing m => Monad m => m Text+tokenNCName = Text.pack <$> do+ c <- satisfy (\c -> isNameStartChar c && c /= ':')+ t <- many $ satisfy (\c -> isNameChar c && c /= ':')+ return $ c : t++-- | <https://www.w3.org/TR/REC-xml/#NT-Name>+--+-- >>> parseOnly tokenName "price"+-- Right "price"+-- >>> parseOnly tokenName "edi:price"+-- Right "edi:price"+tokenName :: CharParsing m => Monad m => m Text+tokenName = Text.pack <$> do+ c <- satisfy isNameStartChar+ t <- many $ satisfy isNameChar+ return $ c : t
+ src/Data/XML/Parser/Mid.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | Mid-level XML parsers, built on top of "Data.XML.Parser.Low":+--+-- - some formatting details are abstracted away (e.g. quoting, whitespacing), therefore parsers are not reversible+-- - entities delimited by an opening and closing sequence are recognized, except for tags which need a more complex, recursive logic+-- - token parsers do not overlap, therefore XML document can be tokenized in a stateless way+--+-- All documentation examples assume the following setup:+--+-- > :set -XOverloadedStrings+-- > import Data.Attoparsec.ByteString+module Data.XML.Parser.Mid+ ( module Data.XML.Parser.Mid.Attribute+ , module Data.XML.Parser.Mid.Doctype+ , Instruction(..)+ , XMLDeclaration(..)+ , StartTag(..)+ , EmptyElementTag(..)+ , Token(..)+ , TokenParser()+ , runTokenParser+ , tokenInstruction+ , tokenComment+ , tokenCdata+ , tokenDoctype+ , tokenXmlDeclaration+ , tokenStartTag+ , tokenEndTag+ , tokenEmptyElementTag+ , tokenData+ , anyToken+ ) where++import Control.Applicative+import Control.Arrow ((>>>))+import Control.Monad.Compat+import Control.Monad.Fail.Compat+import Data.Char+import Data.Functor+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as Text+import Data.XML.Parser.Low+import Data.XML.Parser.Mid.Attribute+import Data.XML.Parser.Mid.Doctype+import Numeric+import Text.Parser.Char+import Text.Parser.Combinators+++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Attoparsec.ByteString++data Token+ = TokenXMLDeclaration XMLDeclaration+ | TokenDoctype Doctype+ | TokenInstruction Instruction+ | TokenStartTag StartTag+ | TokenEndTag QName+ | TokenEmptyElementTag EmptyElementTag+ | TokenData [Content]+ | TokenComment Text+ | TokenCDATA Text+ deriving (Eq, Ord, Show)++-- | Processing instruction.+--+-- <https://www.w3.org/TR/REC-xml/#dt-pi>+data Instruction = Instruction Text Text+ deriving (Eq, Ord, Read, Show)++-- | <https://www.w3.org/TR/REC-xml/#dt-xmldecl>+data XMLDeclaration = XMLDeclaration Text (Maybe Text) (Maybe Bool)+ deriving (Eq, Ord, Read, Show)++-- | <https://www.w3.org/TR/REC-xml/#dt-stag>+data StartTag = StartTag QName [Attribute]+ deriving (Eq, Ord, Read, Show)++-- | <https://www.w3.org/TR/REC-xml/#dt-eetag>+data EmptyElementTag = EmptyElementTag QName [Attribute]+ deriving (Eq, Ord, Read, Show)++-- | A parser that consumes whole 'Token's.+newtype TokenParser m a = TokenParser { runTokenParser :: m a }++deriving instance Functor m => Functor (TokenParser m)+deriving instance Applicative m => Applicative (TokenParser m)+deriving instance Alternative m => Alternative (TokenParser m)+deriving instance Monad m => Monad (TokenParser m)++instance (Parsing m, Monad m) => MonadFail (TokenParser m) where+ fail = TokenParser . unexpected+++-- | <https://www.w3.org/TR/REC-xml/#NT-doctypedecl>+--+-- >>> parseOnly (runTokenParser tokenDoctype) "<!DOCTYPE greeting SYSTEM 'hello.dtd'>"+-- Right (Doctype "greeting" (Just (SystemID "hello.dtd")) [])+-- >>> parseOnly (runTokenParser tokenDoctype) "<!DOCTYPE foo [ <!ENTITY x '<'> ]>"+-- Right (Doctype "foo" Nothing [GeneralEntityDeclaration "x" [ContentReference (EntityRef "lt")]])+tokenDoctype :: CharParsing m => Monad m => TokenParser m Doctype+tokenDoctype = TokenParser doctype++-- | <https://www.w3.org/TR/REC-xml/#dt-pi>+--+-- >>> parseOnly (runTokenParser tokenInstruction) "<?xml-stylesheet type='text/xsl' href='style.xsl'?>"+-- Right (Instruction "xml-stylesheet" "type='text/xsl' href='style.xsl'")+tokenInstruction :: CharParsing m => Monad m => TokenParser m Instruction+tokenInstruction = TokenParser $ do+ name <- tokenInstructionOpen+ tokenWhitespace+ content <- manyTill anyChar $ try tokenInstructionClose+ return $ Instruction name $ Text.pack content++-- | <https://www.w3.org/TR/REC-xml/#NT-Comment>+--+-- >>> parseOnly (runTokenParser tokenComment) "<!-- declarations for <head> & <body> -->"+-- Right " declarations for <head> & <body> "+-- >>> parseOnly (runTokenParser tokenComment) "<!-- B+, B, or B--->"+-- Right " B+, B, or B-"+tokenComment :: CharParsing m => Monad m => TokenParser m Text+tokenComment = TokenParser $ do+ tokenCommentOpen+ content <- manyTill anyChar $ try tokenCommentClose+ return $ Text.pack content++-- | <https://www.w3.org/TR/REC-xml/#dt-cdsection>+--+-- >>> parseOnly (runTokenParser tokenCdata) "<![CDATA[<greeting>Hello, world!</greeting>]]>"+-- Right "<greeting>Hello, world!</greeting>"+tokenCdata :: CharParsing m => Monad m => TokenParser m Text+tokenCdata = TokenParser $ do+ tokenCdataOpen+ content <- manyTill anyChar $ try tokenCdataClose+ return $ Text.pack content++-- | <https://www.w3.org/TR/REC-xml/#NT-XMLDecl>+--+-- >>> parseOnly (runTokenParser tokenXmlDeclaration) "<?xml version='1.0' encoding='UTF-8' standalone='yes'?>"+-- Right (XMLDeclaration "1.0" (Just "UTF-8") (Just True))+tokenXmlDeclaration :: CharParsing m => Monad m => TokenParser m XMLDeclaration+tokenXmlDeclaration = TokenParser $ do+ tokenXmlDeclarationOpen+ tokenWhitespace++ Attribute key value <- attribute+ guard $ key == QName "" "version"+ version <- expandContents decodePredefinedEntities value++ encoding <- optional $ do+ tokenWhitespace+ Attribute key value <- attribute+ guard $ key == QName "" "encoding"+ expandContents decodePredefinedEntities value++ standalone <- optional $ do+ tokenWhitespace+ Attribute key value <- attribute+ guard $ key == QName "" "standalone"+ boolean <- expandContents decodePredefinedEntities value+ case boolean of+ "yes" -> return True+ "no" -> return False+ _ -> empty++ optional tokenWhitespace+ tokenXmlDeclarationClose+ return $ XMLDeclaration version encoding standalone++-- | <https://www.w3.org/TR/REC-xml/#NT-STag>+--+-- >>> parseOnly (runTokenParser tokenStartTag) "<termdef id='dt-dog' term='dog'>"+-- Right (StartTag (QName {namePrefix = "", nameLocal = "termdef"}) [Attribute (QName {namePrefix = "", nameLocal = "id"}) [ContentText "dt-dog"],Attribute (QName {namePrefix = "", nameLocal = "term"}) [ContentText "dog"]])+-- >>> parse (runTokenParser tokenStartTag) "<updated>2003-12-13T18:30:02Z</updated>"+-- Done "2003-12-13T18:30:02Z</updated>" (StartTag (QName {namePrefix = "", nameLocal = "updated"}) [])+tokenStartTag :: CharParsing m => Monad m => TokenParser m StartTag+tokenStartTag = TokenParser $ do+ name <- tokenStartTagOpen+ attributes <- many (tokenWhitespace >> attribute)+ optional tokenWhitespace+ tokenElementClose+ return $ StartTag name attributes++-- | <https://www.w3.org/TR/REC-xml/#NT-ETag>+--+-- >>> parseOnly (runTokenParser tokenEndTag) "</termdef>"+-- Right (QName {namePrefix = "", nameLocal = "termdef"})+tokenEndTag :: CharParsing m => Monad m => TokenParser m QName+tokenEndTag = TokenParser $ do+ name <- tokenEndTagOpen+ optional tokenWhitespace+ tokenElementClose+ return name++-- | <https://www.w3.org/TR/REC-xml/#NT-EmptyElemTag>+--+-- >>> parseOnly (runTokenParser tokenEmptyElementTag) "<IMG align='left' src='http://www.w3.org/Icons/WWW/w3c_home' />"+-- Right (EmptyElementTag (QName {namePrefix = "", nameLocal = "IMG"}) [Attribute (QName {namePrefix = "", nameLocal = "align"}) [ContentText "left"],Attribute (QName {namePrefix = "", nameLocal = "src"}) [ContentText "http://www.w3.org/Icons/WWW/w3c_home"]])+tokenEmptyElementTag :: CharParsing m => Monad m => TokenParser m EmptyElementTag+tokenEmptyElementTag = TokenParser $ do+ name <- tokenStartTagOpen+ attributes <- optional $ do+ tokenWhitespace+ attribute `sepBy` tokenWhitespace+ optional tokenWhitespace+ tokenEmptyElementTagClose+ return $ EmptyElementTag name $ fromMaybe mempty attributes++-- | <https://www.w3.org/TR/REC-xml/#NT-CharData>+--+-- >>> parseOnly (runTokenParser tokenData) "Rock & roll"+-- Right [ContentText "Rock ",ContentReference (EntityRef "amp"),ContentText " roll"]+tokenData :: CharParsing m => Monad m => TokenParser m [Content]+tokenData = TokenParser $ some (tokenContent "<")++-- | Parse any 'Token'.+anyToken :: CharParsing m => Monad m => TokenParser m Token+anyToken = TokenDoctype <$> tokenDoctype+ <|> TokenInstruction <$> tokenInstruction+ <|> TokenComment <$> tokenComment+ <|> TokenCDATA <$> tokenCdata+ <|> TokenXMLDeclaration <$> tokenXmlDeclaration+ <|> TokenStartTag <$> tokenStartTag+ <|> TokenEndTag <$> tokenEndTag+ <|> TokenEmptyElementTag <$> tokenEmptyElementTag+ <|> TokenData <$> tokenData
+ src/Data/XML/Parser/Mid/Attribute.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}+-- | All documentation examples assume the following setup:+--+-- > :set -XOverloadedStrings+-- > import Data.Attoparsec.ByteString+module Data.XML.Parser.Mid.Attribute+ ( Attribute(..)+ , attribute+ ) where++import Data.XML.Parser.Low+import Text.Parser.Char+import Text.Parser.Combinators++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Attoparsec.ByteString++-- | <https://www.w3.org/TR/REC-xml/#dt-attr>+data Attribute = Attribute QName [Content]+ deriving (Eq, Ord, Read, Show)++-- | <https://www.w3.org/TR/REC-xml/#NT-Attribute>+--+-- >>> parseOnly attribute "name = 'value'"+-- Right (Attribute (QName {namePrefix = "", nameLocal = "name"}) [ContentText "value"])+attribute :: CharParsing m => Monad m => m Attribute+attribute = do+ key <- tokenQualifiedName+ tokenEqual+ quote <- oneOf "'\""+ value <- many $ tokenContent [quote, '<']+ char quote+ return $ Attribute key value++
+ src/Data/XML/Parser/Mid/Doctype.hs view
@@ -0,0 +1,111 @@+-- | Document type declaration parsers.+--+-- <https://www.w3.org/TR/REC-xml/#dt-doctype>+--+-- All documentation examples assume the following setup:+--+-- > :set -XOverloadedStrings+-- > import Data.Attoparsec.ByteString+module Data.XML.Parser.Mid.Doctype+ ( ExternalID(..)+ , externalID+ , GeneralEntityDeclaration(..)+ , generalEntityDeclaration+ , Doctype(..)+ , doctype+ ) where++import Control.Applicative+import Data.Maybe+import qualified Data.Text as Text+import Data.Text (Text)+import Data.XML.Parser.Low+import Text.Parser.Char+import Text.Parser.Combinators++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Attoparsec.ByteString++-- | External entity identifier+--+-- <https://www.w3.org/TR/REC-xml/#dt-extent>+data ExternalID = PublicID Text Text | SystemID Text+ deriving (Eq, Ord, Read, Show)++-- | <https://www.w3.org/TR/REC-xml/#gen-entity>+data GeneralEntityDeclaration = GeneralEntityDeclaration Text [Content]+ deriving (Eq, Ord, Read, Show)++-- | <https://www.w3.org/TR/REC-xml/#dt-doctype>+data Doctype = Doctype Text (Maybe ExternalID) [GeneralEntityDeclaration]+ deriving (Eq, Ord, Read, Show)+++-- | <https://www.w3.org/TR/REC-xml/#NT-GEDecl>+--+-- >>> parseOnly generalEntityDeclaration "<!ENTITY d '
'>"+-- Right (GeneralEntityDeclaration "d" [ContentReference (CharRef '\r')])+-- >>> parseOnly generalEntityDeclaration "<!ENTITY da '
'>"+-- Right (GeneralEntityDeclaration "da" [ContentReference (CharRef '\r'),ContentReference (CharRef '\n')])+-- >>> parseOnly generalEntityDeclaration "<!ENTITY Pub-Status 'This is a pre-release of the specification.'>"+-- Right (GeneralEntityDeclaration "Pub-Status" [ContentText "This is a pre-release of the specification."])+generalEntityDeclaration :: CharParsing m => Monad m => m GeneralEntityDeclaration+generalEntityDeclaration = do+ tokenEntityDeclarationOpen+ tokenWhitespace+ name <- tokenName+ tokenWhitespace+ quote <- tokenQuote+ definition <- many (tokenContent $ quote:"%")+ char quote+ optional tokenWhitespace+ tokenElementClose+ return $ GeneralEntityDeclaration name definition++-- | <https://www.w3.org/TR/REC-xml/#NT-ExternalID>+--+-- >>> parseOnly externalID "PUBLIC '-//Textuality//TEXT Standard open-hatch boilerplate//EN' 'http://www.textuality.com/boilerplate/OpenHatch.xml'"+-- Right (PublicID "-//Textuality//TEXT Standard open-hatch boilerplate//EN" "http://www.textuality.com/boilerplate/OpenHatch.xml")+-- >>> parseOnly externalID "SYSTEM '../grafix/OpenHatch.gif'"+-- Right (SystemID "../grafix/OpenHatch.gif")+externalID :: CharParsing m => Monad m => m ExternalID+externalID = publicID <|> systemID where+ publicID = do+ string "PUBLIC"+ tokenWhitespace+ a <- systemLiteral+ tokenWhitespace+ b <- systemLiteral+ return $ PublicID a b+ systemID = string "SYSTEM" *> tokenWhitespace *> (SystemID <$> systemLiteral)+ systemLiteral = Text.pack <$> manyQuoted anyChar++-- | <https://www.w3.org/TR/REC-xml/#NT-doctypedecl>+--+-- >>> parseOnly doctype "<!DOCTYPE greeting SYSTEM 'hello.dtd'>"+-- Right (Doctype "greeting" (Just (SystemID "hello.dtd")) [])+-- >>> parseOnly doctype "<!DOCTYPE foo [ <!ENTITY x '<'> ]>"+-- Right (Doctype "foo" Nothing [GeneralEntityDeclaration "x" [ContentReference (EntityRef "lt")]])+doctype :: CharParsing m => Monad m => m Doctype+doctype = do+ tokenDoctypeOpen+ tokenWhitespace+ name <- tokenName+ externalID <- optional $ tokenWhitespace >> externalID+ optional tokenWhitespace+ entities <- fromMaybe mempty <$> optional+ (between (char '[' >> optional tokenWhitespace) (optional tokenWhitespace >> char ']') $+ many generalEntityDeclaration)+ tokenElementClose+ return $ Doctype name externalID entities+++quoted :: CharParsing m => Monad m => m a -> m a+quoted x = x `surroundedBy` tokenSingleQuote <|> x `surroundedBy` tokenDoubleQuote++manyQuoted :: CharParsing m => Monad m => m a -> m [a]+manyQuoted x = manyQuotedBy tokenSingleQuote x <|> manyQuotedBy tokenDoubleQuote x where+ manyQuotedBy quote x = do+ quote+ manyTill x (try quote)
+ test/doc.hs view
@@ -0,0 +1,13 @@+module Main where++import Build_doctests (flags, module_sources, pkgs)+import Data.Foldable (traverse_)+import System.Environment (unsetEnv)+import Test.DocTest (doctest)++main :: IO ()+main = do+ traverse_ putStrLn args+ doctest args+ where+ args = flags ++ pkgs ++ module_sources
+ test/feed.xml view
@@ -0,0 +1,17 @@+<?xml version="1.0" encoding="utf-8"?>+<feed xmlns="http://www.w3.org/2005/Atom">+ <title type="text"><em>Example</em> Feed</title>+ <link href="http://example.org/"/>+ <updated>2003-12-13T18:30:02Z</updated>+ <author>+ <name>John Doe</name>+ </author>+ <id>urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6</id>+ <entry>+ <title>Atom-Powered Robots Run Amok</title>+ <link href="http://example.org/2003/12/13/atom03"/>+ <id>urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a</id>+ <updated>2003-12-13T18:30:02Z</updated>+ <summary>Some text.</summary>+ </entry>+</feed>
+ test/feed.xml.high.golden view
@@ -0,0 +1,137 @@+Right+ [ TokenProlog+ ( Prolog+ { prologXmlDeclaration = Just+ ( XMLDeclaration "1.0" ( Just "utf-8" ) Nothing )+ , prologInstructions = []+ , prologDoctype = Nothing+ }+ )+ , TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "feed"+ }+ )+ ( fromList+ [+ ( QName+ { namePrefix = ""+ , nameLocal = "xmlns"+ }+ , "http://www.w3.org/2005/Atom"+ )+ ]+ )+ [ TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "title"+ }+ )+ ( fromList+ [+ ( QName+ { namePrefix = ""+ , nameLocal = "type"+ }+ , "text"+ )+ ]+ ) [ TokenTextContent "<em>Example</em> Feed" ]+ , TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "link"+ }+ )+ ( fromList+ [+ ( QName+ { namePrefix = ""+ , nameLocal = "href"+ }+ , "http://example.org/"+ )+ ]+ ) []+ , TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "updated"+ }+ ) ( fromList [] ) [ TokenTextContent "2003-12-13T18:30:02Z" ]+ , TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "author"+ }+ ) ( fromList [] )+ [ TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "name"+ }+ ) ( fromList [] ) [ TokenTextContent "John Doe" ]+ , TokenTextContent "+ "+ ]+ , TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "id"+ }+ ) ( fromList [] ) [ TokenTextContent "urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6" ]+ , TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "entry"+ }+ ) ( fromList [] )+ [ TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "title"+ }+ ) ( fromList [] ) [ TokenTextContent "Atom-Powered Robots Run Amok" ]+ , TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "link"+ }+ )+ ( fromList+ [+ ( QName+ { namePrefix = ""+ , nameLocal = "href"+ }+ , "http://example.org/2003/12/13/atom03"+ )+ ]+ ) []+ , TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "id"+ }+ ) ( fromList [] ) [ TokenTextContent "urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a" ]+ , TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "updated"+ }+ ) ( fromList [] ) [ TokenTextContent "2003-12-13T18:30:02Z" ]+ , TokenTag+ ( QName+ { namePrefix = ""+ , nameLocal = "summary"+ }+ ) ( fromList [] ) [ TokenTextContent "Some text." ]+ , TokenTextContent "+ "+ ]+ , TokenTextContent ""+ ]+ , TokenTextContent ""+ ]
+ test/feed.xml.mid.golden view
@@ -0,0 +1,250 @@+Right+ [ TokenXMLDeclaration+ ( XMLDeclaration "1.0" ( Just "utf-8" ) Nothing )+ , TokenData [ ContentText "" ]+ , TokenStartTag+ ( StartTag+ ( QName+ { namePrefix = ""+ , nameLocal = "feed"+ }+ )+ [ Attribute+ ( QName+ { namePrefix = ""+ , nameLocal = "xmlns"+ }+ ) [ ContentText "http://www.w3.org/2005/Atom" ]+ ]+ )+ , TokenData [ ContentText "+ " ]+ , TokenStartTag+ ( StartTag+ ( QName+ { namePrefix = ""+ , nameLocal = "title"+ }+ )+ [ Attribute+ ( QName+ { namePrefix = ""+ , nameLocal = "type"+ }+ ) [ ContentText "text" ]+ ]+ )+ , TokenData+ [ ContentReference ( EntityRef "lt" )+ , ContentText "em"+ , ContentReference ( EntityRef "gt" )+ , ContentText "Example"+ , ContentReference ( EntityRef "lt" )+ , ContentText "/em"+ , ContentReference ( EntityRef "gt" )+ , ContentText " Feed"+ ]+ , TokenEndTag+ ( QName+ { namePrefix = ""+ , nameLocal = "title"+ }+ )+ , TokenData [ ContentText "+ " ]+ , TokenEmptyElementTag+ ( EmptyElementTag+ ( QName+ { namePrefix = ""+ , nameLocal = "link"+ }+ )+ [ Attribute+ ( QName+ { namePrefix = ""+ , nameLocal = "href"+ }+ ) [ ContentText "http://example.org/" ]+ ]+ )+ , TokenData [ ContentText "+ " ]+ , TokenStartTag+ ( StartTag+ ( QName+ { namePrefix = ""+ , nameLocal = "updated"+ }+ ) []+ )+ , TokenData [ ContentText "2003-12-13T18:30:02Z" ]+ , TokenEndTag+ ( QName+ { namePrefix = ""+ , nameLocal = "updated"+ }+ )+ , TokenData [ ContentText "+ " ]+ , TokenStartTag+ ( StartTag+ ( QName+ { namePrefix = ""+ , nameLocal = "author"+ }+ ) []+ )+ , TokenData [ ContentText "+ " ]+ , TokenStartTag+ ( StartTag+ ( QName+ { namePrefix = ""+ , nameLocal = "name"+ }+ ) []+ )+ , TokenData [ ContentText "John Doe" ]+ , TokenEndTag+ ( QName+ { namePrefix = ""+ , nameLocal = "name"+ }+ )+ , TokenData [ ContentText "+ " ]+ , TokenEndTag+ ( QName+ { namePrefix = ""+ , nameLocal = "author"+ }+ )+ , TokenData [ ContentText "+ " ]+ , TokenStartTag+ ( StartTag+ ( QName+ { namePrefix = ""+ , nameLocal = "id"+ }+ ) []+ )+ , TokenData [ ContentText "urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6" ]+ , TokenEndTag+ ( QName+ { namePrefix = ""+ , nameLocal = "id"+ }+ )+ , TokenData [ ContentText "+ " ]+ , TokenStartTag+ ( StartTag+ ( QName+ { namePrefix = ""+ , nameLocal = "entry"+ }+ ) []+ )+ , TokenData [ ContentText "+ " ]+ , TokenStartTag+ ( StartTag+ ( QName+ { namePrefix = ""+ , nameLocal = "title"+ }+ ) []+ )+ , TokenData [ ContentText "Atom-Powered Robots Run Amok" ]+ , TokenEndTag+ ( QName+ { namePrefix = ""+ , nameLocal = "title"+ }+ )+ , TokenData [ ContentText "+ " ]+ , TokenEmptyElementTag+ ( EmptyElementTag+ ( QName+ { namePrefix = ""+ , nameLocal = "link"+ }+ )+ [ Attribute+ ( QName+ { namePrefix = ""+ , nameLocal = "href"+ }+ ) [ ContentText "http://example.org/2003/12/13/atom03" ]+ ]+ )+ , TokenData [ ContentText "+ " ]+ , TokenStartTag+ ( StartTag+ ( QName+ { namePrefix = ""+ , nameLocal = "id"+ }+ ) []+ )+ , TokenData [ ContentText "urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a" ]+ , TokenEndTag+ ( QName+ { namePrefix = ""+ , nameLocal = "id"+ }+ )+ , TokenData [ ContentText "+ " ]+ , TokenStartTag+ ( StartTag+ ( QName+ { namePrefix = ""+ , nameLocal = "updated"+ }+ ) []+ )+ , TokenData [ ContentText "2003-12-13T18:30:02Z" ]+ , TokenEndTag+ ( QName+ { namePrefix = ""+ , nameLocal = "updated"+ }+ )+ , TokenData [ ContentText "+ " ]+ , TokenStartTag+ ( StartTag+ ( QName+ { namePrefix = ""+ , nameLocal = "summary"+ }+ ) []+ )+ , TokenData [ ContentText "Some text." ]+ , TokenEndTag+ ( QName+ { namePrefix = ""+ , nameLocal = "summary"+ }+ )+ , TokenData [ ContentText "+ " ]+ , TokenEndTag+ ( QName+ { namePrefix = ""+ , nameLocal = "entry"+ }+ )+ , TokenData [ ContentText "" ]+ , TokenEndTag+ ( QName+ { namePrefix = ""+ , nameLocal = "feed"+ }+ )+ , TokenData [ ContentText "" ]+ ]
+ test/golden.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+import Control.Applicative+import Control.Monad.Trans.Resource+import Data.Attoparsec.ByteString.Streaming+import Data.ByteString.Streaming+import Data.Default+import Data.Function+import qualified Data.Text.Lazy.Encoding as Lazy+import Data.XML.Parser.High as High+import Data.XML.Parser.Mid as Mid+import Prelude hiding (readFile)+import System.FilePath+import Test.Tasty+import Test.Tasty.Golden (findByExtension, goldenVsString)+import Text.Pretty.Simple++main :: IO ()+main = defaultMain =<< do+ xmlFiles <- findByExtension [".xml"] "."++ return $ testGroup "Golden tests" $ do+ xmlFile <- xmlFiles+ return $ testGroup xmlFile [ testMidToken xmlFile, testHighToken xmlFile ]++testMidToken xmlFile = goldenVsString xmlFile goldenFile $ f xmlFile where+ goldenFile = addExtension xmlFile ".mid.golden"+ f file = do+ (result, _) <- runResourceT $ readFile file & parse (Mid.runTokenParser $ some Mid.anyToken)+ return $ Lazy.encodeUtf8 $ pShowNoColor result++testHighToken xmlFile = goldenVsString xmlFile goldenFile $ f xmlFile where+ goldenFile = addExtension xmlFile ".high.golden"+ f file = do+ (result, _) <- runResourceT $ readFile file & parse (High.runTokenParser $ some High.anyToken')+ return $ Lazy.encodeUtf8 $ pShowNoColor result
+ test/unit.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Resource+import Data.Attoparsec.ByteString.Streaming+import Data.ByteString.Streaming+import Data.Function+import Data.Functor+import Data.Maybe+import Data.XML.Parser.High as XML+import Data.XML.Parser.Low.Entity as XML+import Prelude hiding (readFile)+import Test.Tasty+import Test.Tasty.HUnit+import Text.Parser.Combinators++main :: IO ()+main = defaultMain $ testGroup "Unit tests"+ [ feedCase+ ]++feedCase :: TestTree+feedCase = testCase "Feed" $ do+ (result, _) <- runResourceT $ readFile "test/feed.xml" & parse (runTokenParser parser)+ result @?= Right "http://example.org/2003/12/13/atom03"++ where+ parser = do+ prolog+ tag' "feed" anyAttr $ withContent $ do+ many $ tag' (anyNameExcept "entry") anyAttr anyContent+ url <- tag' "entry" anyAttr $ withContent $ do+ many $ tag' (anyNameExcept "link") anyAttr anyContent+ url <- tag decodeHtmlEntities "link" (const $ attrValue "href") (anyContent $>)+ many anyTag+ return url+ many anyTag+ return url