diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctest" diff --git a/hextream.cabal b/hextream.cabal new file mode 100644 --- /dev/null +++ b/hextream.cabal @@ -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 + diff --git a/src/Data/XML/Parser/High.hs b/src/Data/XML/Parser/High.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Parser/High.hs @@ -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')) "body" +-- Right "body" +-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr (withContent textContent')) "" +-- Left ... +-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr (withContent textContent')) "" +-- Left ... +-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr (withContent $ pure ())) "" +-- Left ... +withContent :: TokenParser m a -> ContentParser m a +withContent = WithContent + +-- | Assert that content is empty. +-- +-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr noContent) "body" +-- Left ... +-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr noContent) "" +-- Right () +-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr noContent) "" +-- Right () +noContent :: Applicative m => ContentParser m () +noContent = NoContent $ pure () + +-- | Accept any content, including empty content. +-- +-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr anyContent) "body" +-- Right () +-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr anyContent) "" +-- Right () +-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr anyContent) "" +-- Right () +anyContent :: CharParsing m => Monad m => ContentParser m () +anyContent = AnyContent $ const $ pure () + +-- | Parse a processing instruction. +-- +-- +-- +-- >>> parseOnly (runTokenParser instruction) "" +-- Right (Instruction "php" "echo 'Hello World!'; ") +-- >>> parseOnly (runTokenParser instruction) " " +-- Right (Instruction "php" "echo 'Hello World!'; ") +instruction :: CharParsing m => Monad m => TokenParser m L1.Instruction +instruction = TokenParser $ do + skipCommentsWhitespace + L1.runTokenParser L1.tokenInstruction + +-- | +-- +-- >>> parseOnly (runTokenParser prolog) "" +-- Right (Prolog {prologXmlDeclaration = Just (XMLDeclaration "1.0" ...), prologInstructions = [], prologDoctype = Just (Doctype "greeting" ...)}) +-- >>> parseOnly (runTokenParser prolog) " " +-- 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')) "bodyinnerbody]]>" +-- Right "bodyinnerbody" +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) "body" +-- Right () +-- >>> parseOnly (runTokenParser anyTag) "" +-- Right () +-- >>> parseOnly (runTokenParser anyTag) "" +-- Right () +-- >>> parseOnly (runTokenParser anyTag) "body" +-- 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 diff --git a/src/Data/XML/Parser/High/AttrParser.hs b/src/Data/XML/Parser/High/AttrParser.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Parser/High/AttrParser.hs @@ -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) "" +-- Right () +-- >>> parseOnly (runTokenParser $ tag' anyName anyAttr noContent) "" +-- Right () +anyAttr :: AttrParser () +anyAttr = pure () + +-- | Assert that no attributes exist. +-- +-- >>> parseOnly (runTokenParser $ tag' anyName noAttr noContent) "" +-- Right () +-- >>> parseOnly (runTokenParser $ tag' anyName noAttr noContent) "" +-- 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) "" +-- Left ... +-- >>> parseOnly (runTokenParser $ tag' anyName (attrValue "foo") noContent) "" +-- 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) "" +-- Left ... +-- >>> parseOnly (runTokenParser $ tag' anyName (hasAttr "foo" "bar") noContent) "" +-- Left ... +-- >>> parseOnly (runTokenParser $ tag' anyName (hasAttr "foo" "bar") noContent) "" +-- Right () +hasAttr :: QName -> Text -> AttrParser () +hasAttr name value = attrValue name >>= \value' -> guard (value == value') diff --git a/src/Data/XML/Parser/High/NameParser.hs b/src/Data/XML/Parser/High/NameParser.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Parser/High/NameParser.hs @@ -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) "" +-- 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) "" +-- Left ... +-- >>> parseOnly (runTokenParser $ tag' (anyNameExcept "foo") anyAttr anyContent) "" +-- Right () +anyNameExcept :: QName -> NameParser QName +anyNameExcept name = NameParser $ \name' -> do + guard $ name /= name' + return name' diff --git a/src/Data/XML/Parser/Low.hs b/src/Data/XML/Parser/Low.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Parser/Low.hs @@ -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 + +-- | +tokenWhitespace :: CharParsing m => m String +tokenWhitespace = some (satisfy isXmlSpace) where + isXmlSpace ' ' = True + isXmlSpace '\t' = True + isXmlSpace '\r' = True + isXmlSpace '\n' = True + isXmlSpace _ = False + +-- | +tokenEqual :: CharParsing m => Monad m => m () +tokenEqual = do + optional tokenWhitespace + char '=' + optional tokenWhitespace + return () + +-- | +-- +-- >>> 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) + +-- | @ m () +tokenEntityDeclarationOpen = void $ string ">> parseOnly tokenInstructionOpen " Monad m => m Text +tokenInstructionOpen = do + string "@ +tokenInstructionClose :: CharParsing m => m () +tokenInstructionClose = void $ string "?>" + +-- | @ +tokenCdataOpen :: CharParsing m => m () +tokenCdataOpen = void $ string "@ +-- +-- +tokenCdataClose :: CharParsing m => m () +tokenCdataClose = void $ string "]]>" + +-- | @@ +tokenCommentClose :: CharParsing m => m () +tokenCommentClose = void $ string "-->" + +-- | @ m () +tokenDoctypeOpen = void $ string " m () +tokenXmlDeclarationOpen = void $ string "@ +tokenXmlDeclarationClose :: CharParsing m => m () +tokenXmlDeclarationClose = void $ string "?>" + +-- | @/>@ +tokenEmptyElementTagClose :: CharParsing m => m () +tokenEmptyElementTagClose = void $ string "/>" + +-- | Return tag name. +-- +-- >>> parseOnly tokenStartTagOpen " Monad m => m QName +tokenStartTagOpen = char '<' *> tokenQualifiedName + +-- | Return tag name. +-- +-- >>> parseOnly tokenEndTagOpen " Monad m => m QName +tokenEndTagOpen = string " tokenQualifiedName + +-- | @>@ +tokenElementClose :: CharParsing m => m () +tokenElementClose = void $ char '>' + diff --git a/src/Data/XML/Parser/Low/Entity.hs b/src/Data/XML/Parser/Low/Entity.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Parser/Low/Entity.hs @@ -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 + + +-- | +decodePredefinedEntities :: EntityDecoder +decodePredefinedEntities = EntityDecoder $ \name -> + Map.lookup name predefinedEntities & maybe empty pure + +predefinedEntities :: Map Text Text +predefinedEntities = Map.fromList + [ ("lt", "<") + , ("gt", ">") + , ("amp", "&") + , ("quot", "\"") + , ("apos", "'") + ] + +-- | +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") + ] diff --git a/src/Data/XML/Parser/Low/Name.hs b/src/Data/XML/Parser/Low/Name.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Parser/Low/Name.hs @@ -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. +-- +-- +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 + +-- | +-- +-- >>> 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 + +-- | +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 + +-- | +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 + +-- | +-- +-- >>> 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 + +-- | +-- +-- >>> 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 diff --git a/src/Data/XML/Parser/Mid.hs b/src/Data/XML/Parser/Mid.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Parser/Mid.hs @@ -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. +-- +-- +data Instruction = Instruction Text Text + deriving (Eq, Ord, Read, Show) + +-- | +data XMLDeclaration = XMLDeclaration Text (Maybe Text) (Maybe Bool) + deriving (Eq, Ord, Read, Show) + +-- | +data StartTag = StartTag QName [Attribute] + deriving (Eq, Ord, Read, Show) + +-- | +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 + + +-- | +-- +-- >>> parseOnly (runTokenParser tokenDoctype) "" +-- Right (Doctype "greeting" (Just (SystemID "hello.dtd")) []) +-- >>> parseOnly (runTokenParser tokenDoctype) " ]>" +-- Right (Doctype "foo" Nothing [GeneralEntityDeclaration "x" [ContentReference (EntityRef "lt")]]) +tokenDoctype :: CharParsing m => Monad m => TokenParser m Doctype +tokenDoctype = TokenParser doctype + +-- | +-- +-- >>> parseOnly (runTokenParser tokenInstruction) "" +-- 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 + +-- | +-- +-- >>> parseOnly (runTokenParser tokenComment) "" +-- Right " declarations for & " +-- >>> parseOnly (runTokenParser tokenComment) "" +-- 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 + +-- | +-- +-- >>> parseOnly (runTokenParser tokenCdata) "Hello, world!]]>" +-- Right "Hello, world!" +tokenCdata :: CharParsing m => Monad m => TokenParser m Text +tokenCdata = TokenParser $ do + tokenCdataOpen + content <- manyTill anyChar $ try tokenCdataClose + return $ Text.pack content + +-- | +-- +-- >>> parseOnly (runTokenParser tokenXmlDeclaration) "" +-- 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 + +-- | +-- +-- >>> parseOnly (runTokenParser tokenStartTag) "" +-- Right (StartTag (QName {namePrefix = "", nameLocal = "termdef"}) [Attribute (QName {namePrefix = "", nameLocal = "id"}) [ContentText "dt-dog"],Attribute (QName {namePrefix = "", nameLocal = "term"}) [ContentText "dog"]]) +-- >>> parse (runTokenParser tokenStartTag) "2003-12-13T18:30:02Z" +-- Done "2003-12-13T18:30:02Z" (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 + +-- | +-- +-- >>> parseOnly (runTokenParser tokenEndTag) "" +-- Right (QName {namePrefix = "", nameLocal = "termdef"}) +tokenEndTag :: CharParsing m => Monad m => TokenParser m QName +tokenEndTag = TokenParser $ do + name <- tokenEndTagOpen + optional tokenWhitespace + tokenElementClose + return name + +-- | +-- +-- >>> parseOnly (runTokenParser tokenEmptyElementTag) "" +-- 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 + +-- | +-- +-- >>> 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 diff --git a/src/Data/XML/Parser/Mid/Attribute.hs b/src/Data/XML/Parser/Mid/Attribute.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Parser/Mid/Attribute.hs @@ -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 + +-- | +data Attribute = Attribute QName [Content] + deriving (Eq, Ord, Read, Show) + +-- | +-- +-- >>> 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 + + diff --git a/src/Data/XML/Parser/Mid/Doctype.hs b/src/Data/XML/Parser/Mid/Doctype.hs new file mode 100644 --- /dev/null +++ b/src/Data/XML/Parser/Mid/Doctype.hs @@ -0,0 +1,111 @@ +-- | Document type declaration parsers. +-- +-- +-- +-- 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 +-- +-- +data ExternalID = PublicID Text Text | SystemID Text + deriving (Eq, Ord, Read, Show) + +-- | +data GeneralEntityDeclaration = GeneralEntityDeclaration Text [Content] + deriving (Eq, Ord, Read, Show) + +-- | +data Doctype = Doctype Text (Maybe ExternalID) [GeneralEntityDeclaration] + deriving (Eq, Ord, Read, Show) + + +-- | +-- +-- >>> parseOnly generalEntityDeclaration "" +-- Right (GeneralEntityDeclaration "d" [ContentReference (CharRef '\r')]) +-- >>> parseOnly generalEntityDeclaration "" +-- Right (GeneralEntityDeclaration "da" [ContentReference (CharRef '\r'),ContentReference (CharRef '\n')]) +-- >>> parseOnly generalEntityDeclaration "" +-- 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 + +-- | +-- +-- >>> 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 + +-- | +-- +-- >>> parseOnly doctype "" +-- Right (Doctype "greeting" (Just (SystemID "hello.dtd")) []) +-- >>> parseOnly doctype " ]>" +-- 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) diff --git a/test/doc.hs b/test/doc.hs new file mode 100644 --- /dev/null +++ b/test/doc.hs @@ -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 diff --git a/test/feed.xml b/test/feed.xml new file mode 100644 --- /dev/null +++ b/test/feed.xml @@ -0,0 +1,17 @@ + + + <em>Example</em> Feed + + 2003-12-13T18:30:02Z + + John Doe + + urn:uuid:60a76c80-d399-11d9-b93C-0003939e0af6 + + Atom-Powered Robots Run Amok + + urn:uuid:1225c695-cfb8-4ebb-aaaa-80da344efa6a + 2003-12-13T18:30:02Z + Some text. + + diff --git a/test/feed.xml.high.golden b/test/feed.xml.high.golden new file mode 100644 --- /dev/null +++ b/test/feed.xml.high.golden @@ -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 "Example 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 "" + ] diff --git a/test/feed.xml.mid.golden b/test/feed.xml.mid.golden new file mode 100644 --- /dev/null +++ b/test/feed.xml.mid.golden @@ -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 "" ] + ] diff --git a/test/golden.hs b/test/golden.hs new file mode 100644 --- /dev/null +++ b/test/golden.hs @@ -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 diff --git a/test/unit.hs b/test/unit.hs new file mode 100644 --- /dev/null +++ b/test/unit.hs @@ -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