diff --git a/library/XmlParser/AstParser.hs b/library/XmlParser/AstParser.hs --- a/library/XmlParser/AstParser.hs +++ b/library/XmlParser/AstParser.hs @@ -41,12 +41,12 @@ import qualified Data.List as List import qualified Text.Builder as Tb import qualified Text.XML as Xml +import qualified XmlParser.Attoparsec as Attoparsec import qualified XmlParser.ElementDestructionState as ElementDestructionState import qualified XmlParser.NameMap as NameMap import qualified XmlParser.NamespaceRegistry as NamespaceRegistry import qualified XmlParser.NodeConsumerState as NodeConsumerState import XmlParser.Prelude -import qualified XmlParser.XmlSchemaAttoparsec as XmlSchemaAttoparsec -- | -- Parse an \"xml-conduit\" element AST. @@ -243,7 +243,7 @@ case runByName nameMap (\element (Element run) -> fmap fst (run deeperNreg element ElementDestructionState.new)) of OkByNameResult _ res -> Right (res, state) NotFoundByNameResult unfoundNames -> - let availNames = NameMap.extractNames nameMap + let availNames = nub $ NameMap.extractNames nameMap in Left (NoneOfChildrenFoundByNameElementError unfoundNames availNames) FailedDeeperByNameResult ns name err -> Left (ChildByNameElementError ns name err) @@ -259,7 +259,7 @@ (nameMap, state) -> case runByName nameMap (\content (Content parseContent) -> parseContent (\ns -> NamespaceRegistry.lookup ns nreg) content) of OkByNameResult _ res -> Right (res, state) NotFoundByNameResult unfoundNames -> - let availNames = NameMap.extractNames nameMap + let availNames = nub $ NameMap.extractNames nameMap in Left (NoneOfAttributesFoundByNameElementError unfoundNames availNames) FailedDeeperByNameResult ns name err -> Left (AttributeByNameElementError ns name err) @@ -413,13 +413,13 @@ -- - https://en.wikipedia.org/wiki/QName qNameContent :: Content (Maybe Text, Text) qNameContent = - Content $ \lookup content -> case Attoparsec.parseOnly XmlSchemaAttoparsec.qName content of + Content $ \lookup content -> case Attoparsec.parseStripped Attoparsec.qName content of Right (ns, name) -> case ns of Just ns -> case lookup ns of Just uri -> Right (Just uri, name) Nothing -> Left (Just (NamespaceNotFoundContentError ns)) Nothing -> Right (Nothing, name) - Left err -> Left (Just (ParsingContentError (fromString err))) + Left err -> Left (Just (ParsingContentError err)) -- * ByName diff --git a/library/XmlParser/Attoparsec.hs b/library/XmlParser/Attoparsec.hs new file mode 100644 --- /dev/null +++ b/library/XmlParser/Attoparsec.hs @@ -0,0 +1,80 @@ +module XmlParser.Attoparsec where + +import Data.Attoparsec.Text +import qualified Data.Text as Text +import XmlParser.Prelude hiding (takeWhile) + +parseStripped :: Parser a -> Text -> Either Text a +parseStripped p = first fromString . parseOnly (stripped p) + where + stripped :: Parser a -> Parser a + stripped p = skipSpace *> p <* skipSpace <* endOfInput + +qName :: Parser (Maybe Text, Text) +qName = + {- + Ref (from https://en.wikipedia.org/wiki/QName): + + QName ::= PrefixedName | UnprefixedName + PrefixedName ::= Prefix ':' LocalPart + UnprefixedName ::= LocalPart + Prefix ::= NCName + LocalPart ::= NCName + -} + do + a <- ncName + asum + [ do + char ':' + b <- ncName + return (Just a, b), + return (Nothing, a) + ] + +{-# NOINLINE ncName #-} +ncName :: Parser Text +ncName = + {- + Ref (from https://en.wikipedia.org/wiki/QName): + + NCName ::= Name - (Char* ':' Char*) (* An XML Name, minus the ":" *) + Name ::= NameStartChar (NameChar)* + NameStartChar ::= ":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6] | [#xD8-#xF6] + | [#xF8-#x2FF] | [#x370-#x37D] | [#x37F-#x1FFF] + | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] + | [#x3001-#xD7FF] | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] + | [#x10000-#xEFFFF] + NameChar ::= NameStartChar | "-" | "." | [0-9] + | #xB7 | [#x0300-#x036F] | [#x203F-#x2040] + Char ::= (* any Unicode char, excluding surrogate blocks FFFE and FFFF. *) + #x9 | #xA | #xD | [#x20-#xD7FF] + | [#xE000-#xFFFD] | [#x10000-#x10FFFF] + -} + do + a <- satisfy nameStartCharPredicate + b <- takeWhile nameCharPredicate + return (Text.cons a b) + where + nameStartCharPredicate x = + x >= 'A' && x <= 'Z' + || x == '_' + || x >= 'a' && x <= 'z' + || x >= '\xC0' && x <= '\xD6' + || x >= '\xD8' && x <= '\xF6' + || x >= '\xF8' && x <= '\x2FF' + || x >= '\x370' && x <= '\x37D' + || x >= '\x37F' && x <= '\x1FFF' + || x >= '\x200C' && x <= '\x200D' + || x >= '\x2070' && x <= '\x218F' + || x >= '\x2C00' && x <= '\x2FEF' + || x >= '\x3001' && x <= '\xD7FF' + || x >= '\xF900' && x <= '\xFDCF' + || x >= '\xFDF0' && x <= '\xFFFD' + || x >= '\x10000' && x <= '\xEFFFF' + nameCharPredicate x = + x == '-' || x == '.' + || x >= '0' && x <= '9' + || x == '\xB7' + || x >= '\x0300' && x <= '\x036F' + || x >= '\x203F' && x <= '\x2040' + || nameStartCharPredicate x diff --git a/library/XmlParser/NamespaceRegistry.hs b/library/XmlParser/NamespaceRegistry.hs --- a/library/XmlParser/NamespaceRegistry.hs +++ b/library/XmlParser/NamespaceRegistry.hs @@ -13,8 +13,8 @@ import qualified Data.HashMap.Strict as HashMap import qualified Data.Map.Strict as Map import qualified Text.XML as Xml +import qualified XmlParser.Attoparsec as Attoparsec import XmlParser.Prelude hiding (insert, lookup) -import qualified XmlParser.XmlSchemaAttoparsec as XmlSchemaAttoparsec data NamespaceRegistry = NamespaceRegistry @@ -43,7 +43,7 @@ Just uri -> Just (Just uri, localName) Nothing -> Nothing Nothing -> - case Attoparsec.parseOnly XmlSchemaAttoparsec.qName localName of + case Attoparsec.parseOnly Attoparsec.qName localName of Right (ns, localName) -> case ns of Just ns -> case HashMap.lookup ns map of Just uri -> Just (Just uri, localName) @@ -66,7 +66,7 @@ interpretAttribute (Xml.Name localName namespace prefix) uri = case namespace of Nothing -> case prefix of - Nothing -> case Attoparsec.parseOnly XmlSchemaAttoparsec.qName localName of + Nothing -> case Attoparsec.parseOnly Attoparsec.qName localName of Right (Just "xmlns", name) -> insert name uri Right (Nothing, "xmlns") -> setDefault uri _ -> id diff --git a/library/XmlParser/XmlSchemaAttoparsec.hs b/library/XmlParser/XmlSchemaAttoparsec.hs deleted file mode 100644 --- a/library/XmlParser/XmlSchemaAttoparsec.hs +++ /dev/null @@ -1,74 +0,0 @@ -module XmlParser.XmlSchemaAttoparsec where - -import Data.Attoparsec.Text -import qualified Data.Text as Text -import XmlParser.Prelude hiding (takeWhile) - -qName :: Parser (Maybe Text, Text) -qName = - {- - Ref (from https://en.wikipedia.org/wiki/QName): - - QName ::= PrefixedName | UnprefixedName - PrefixedName ::= Prefix ':' LocalPart - UnprefixedName ::= LocalPart - Prefix ::= NCName - LocalPart ::= NCName - -} - do - a <- ncName - asum - [ do - char ':' - b <- ncName - return (Just a, b), - return (Nothing, a) - ] - -{-# NOINLINE ncName #-} -ncName :: Parser Text -ncName = - {- - Ref (from https://en.wikipedia.org/wiki/QName): - - NCName ::= Name - (Char* ':' Char*) (* An XML Name, minus the ":" *) - Name ::= NameStartChar (NameChar)* - NameStartChar ::= ":" | [A-Z] | "_" | [a-z] | [#xC0-#xD6] | [#xD8-#xF6] - | [#xF8-#x2FF] | [#x370-#x37D] | [#x37F-#x1FFF] - | [#x200C-#x200D] | [#x2070-#x218F] | [#x2C00-#x2FEF] - | [#x3001-#xD7FF] | [#xF900-#xFDCF] | [#xFDF0-#xFFFD] - | [#x10000-#xEFFFF] - NameChar ::= NameStartChar | "-" | "." | [0-9] - | #xB7 | [#x0300-#x036F] | [#x203F-#x2040] - Char ::= (* any Unicode char, excluding surrogate blocks FFFE and FFFF. *) - #x9 | #xA | #xD | [#x20-#xD7FF] - | [#xE000-#xFFFD] | [#x10000-#x10FFFF] - -} - do - a <- satisfy nameStartCharPredicate - b <- takeWhile nameCharPredicate - return (Text.cons a b) - where - nameStartCharPredicate x = - x >= 'A' && x <= 'Z' - || x == '_' - || x >= 'a' && x <= 'z' - || x >= '\xC0' && x <= '\xD6' - || x >= '\xD8' && x <= '\xF6' - || x >= '\xF8' && x <= '\x2FF' - || x >= '\x370' && x <= '\x37D' - || x >= '\x37F' && x <= '\x1FFF' - || x >= '\x200C' && x <= '\x200D' - || x >= '\x2070' && x <= '\x218F' - || x >= '\x2C00' && x <= '\x2FEF' - || x >= '\x3001' && x <= '\xD7FF' - || x >= '\xF900' && x <= '\xFDCF' - || x >= '\xFDF0' && x <= '\xFFFD' - || x >= '\x10000' && x <= '\xEFFFF' - nameCharPredicate x = - x == '-' || x == '.' - || x >= '0' && x <= '9' - || x == '\xB7' - || x >= '\x0300' && x <= '\x036F' - || x >= '\x203F' && x <= '\x2040' - || nameStartCharPredicate x diff --git a/xml-parser.cabal b/xml-parser.cabal --- a/xml-parser.cabal +++ b/xml-parser.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: xml-parser -version: 0.1 +version: 0.1.0.1 synopsis: XML parser with informative error-reporting and simple API homepage: https://github.com/nikita-volkov/xml-parser bug-reports: https://github.com/nikita-volkov/xml-parser/issues @@ -25,6 +25,7 @@ XmlParser other-modules: XmlParser.AstParser + XmlParser.Attoparsec XmlParser.ElementDestructionState XmlParser.NameMap XmlParser.NamespaceRegistry @@ -32,7 +33,6 @@ XmlParser.TupleHashMap XmlParser.Prelude XmlParser.XmlConduitWrapper - XmlParser.XmlSchemaAttoparsec build-depends: attoparsec >=0.13 && <0.15, base >=4.11 && <5,