diff --git a/library/XmlParser.hs b/library/XmlParser.hs --- a/library/XmlParser.hs +++ b/library/XmlParser.hs @@ -58,8 +58,8 @@ -- Parse XML file. parseFile :: AstParser.Element a -> FilePath -> IO (Either Text a) parseFile astParser path = - fmap (>>= parseDocumentAst astParser) $ - XmlConduitWrapper.parseFile path + fmap (>>= parseDocumentAst astParser) + $ XmlConduitWrapper.parseFile path parseDocumentAst :: AstParser.Element a -> XmlConduit.Document -> Either Text a parseDocumentAst astParser = diff --git a/library/XmlParser/AstParser.hs b/library/XmlParser/AstParser.hs --- a/library/XmlParser/AstParser.hs +++ b/library/XmlParser/AstParser.hs @@ -39,8 +39,9 @@ import qualified Data.Attoparsec.Text as Attoparsec import qualified Data.HashMap.Strict as HashMap import qualified Data.List as List -import qualified Text.Builder as Tb import qualified Text.XML as Xml +import TextBuilder (TextBuilder) +import qualified TextBuilder import qualified XmlParser.Attoparsec as Attoparsec import qualified XmlParser.ElementDestructionState as ElementDestructionState import qualified XmlParser.NameMap as NameMap @@ -60,18 +61,18 @@ renderElementError :: ElementError -> Text renderElementError = - Tb.run . (\(a, b) -> "/" <> Tb.intercalate "/" (reverse a) <> ": " <> b) . simplifyElementError + TextBuilder.toText . (\(a, b) -> "/" <> TextBuilder.intercalate "/" (reverse a) <> ": " <> b) . simplifyElementError -simplifyElementError :: ElementError -> ([Tb.Builder], Tb.Builder) +simplifyElementError :: ElementError -> ([TextBuilder], TextBuilder) simplifyElementError = elementError [] where sortedList renderer = - mappend "[" . flip mappend "]" . Tb.intercalate ", " . fmap renderer . sort + mappend "[" . flip mappend "]" . TextBuilder.intercalate ", " . fmap renderer . sort name a b = case a of - Just _ -> Tb.text b - Nothing -> Tb.text b + Just _ -> TextBuilder.text b + Nothing -> TextBuilder.text b elementError collectedPath = \case NoneOfChildrenFoundByNameElementError a b -> ( collectedPath, @@ -83,19 +84,20 @@ ChildByNameElementError a b c -> elementError (name a b : collectedPath) c ChildAtOffsetElementError a b -> - nodeError (Tb.decimal a : collectedPath) b + nodeError (TextBuilder.decimal a : collectedPath) b AttributeByNameElementError a b c -> (("@" <> name a b) : collectedPath, maybeContentError c) NoneOfAttributesFoundByNameElementError a b -> ( collectedPath, - "Found none of the following attributes: " <> sortedList (uncurry name) a + "Found none of the following attributes: " + <> sortedList (uncurry name) a <> ". The following are available: " <> sortedList (uncurry name) b ) NameElementError a -> - (collectedPath, Tb.text a) + (collectedPath, TextBuilder.text a) UserElementError a -> - (collectedPath, Tb.text a) + (collectedPath, TextBuilder.text a) nodeError collectedPath = \case UnexpectedNodeTypeNodeError a b -> ( collectedPath, @@ -115,15 +117,15 @@ maybeContentError = maybe "Empty alternative" contentError contentError = \case UserContentError a -> - Tb.text a + TextBuilder.text a ParsingContentError a -> - Tb.text a + TextBuilder.text a NamespaceNotFoundContentError a -> - "Namespace not found: " <> Tb.text a + "Namespace not found: " <> TextBuilder.text a UnexpectedValueContentError a -> - "Unexpected value: " <> Tb.text a + "Unexpected value: " <> TextBuilder.text a EnumContentError a b -> - "Unexpected value: " <> Tb.text b <> ". Expecting one of the following: " <> sortedList Tb.text a + "Unexpected value: " <> TextBuilder.text b <> ". Expecting one of the following: " <> sortedList TextBuilder.text a -- | -- Error in the context of an element. @@ -135,37 +137,37 @@ Text (Maybe ContentError) | NoneOfAttributesFoundByNameElementError + -- | Not found. [(Maybe Text, Text)] - -- ^ Not found. + -- | Out of. [(Maybe Text, Text)] - -- ^ Out of. | NoneOfChildrenFoundByNameElementError + -- | Not found. [(Maybe Text, Text)] - -- ^ Not found. + -- | Out of. [(Maybe Text, Text)] - -- ^ Out of. | ChildByNameElementError + -- | Namespace. (Maybe Text) - -- ^ Namespace. + -- | Name. Text - -- ^ Name. + -- | Reason. Not 'NodeError' because only element nodes can be looked up by name. ElementError - -- ^ Reason. Not 'NodeError' because only element nodes can be looked up by name. | ChildAtOffsetElementError + -- | Offset. Int - -- ^ Offset. + -- | Reason. NodeError - -- ^ Reason. | NameElementError Text | -- | Error raised by the user of this library. UserElementError Text data NodeError = UnexpectedNodeTypeNodeError + -- | Expected. NodeType - -- ^ Expected. + -- | Actual. NodeType - -- ^ Actual. | NotAvailableNodeError | ElementNodeError ElementError | TextNodeError (Maybe ContentError) @@ -175,10 +177,10 @@ | NamespaceNotFoundContentError Text | UnexpectedValueContentError Text | EnumContentError + -- | List of expected values. [Text] - -- ^ List of expected values. + -- | Actual value Text - -- ^ Actual value | UserContentError Text data NodeType diff --git a/library/XmlParser/Attoparsec.hs b/library/XmlParser/Attoparsec.hs --- a/library/XmlParser/Attoparsec.hs +++ b/library/XmlParser/Attoparsec.hs @@ -56,25 +56,30 @@ 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' + or + [ 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 + or + [ x == '-', + x == '.', + x >= '0' && x <= '9', + x == '\xB7', + x >= '\x0300' && x <= '\x036F', + x >= '\x203F' && x <= '\x2040', + nameStartCharPredicate x + ] diff --git a/library/XmlParser/ElementDestructionState.hs b/library/XmlParser/ElementDestructionState.hs --- a/library/XmlParser/ElementDestructionState.hs +++ b/library/XmlParser/ElementDestructionState.hs @@ -19,10 +19,10 @@ -- You can use this as a parameter to a reader monad. data ElementDestructionContext = ElementDestructionContext + -- | Namespace registry as seen from the context of this node. NamespaceRegistry.NamespaceRegistry - -- ^ Namespace registry as seen from the context of this node. + -- | The node that we're in the context of. Xml.Element - -- ^ The node that we're in the context of. -- | -- Used for the state of a parser in the context of specifically element node. @@ -32,10 +32,10 @@ -- You can use this as a parameter to the state monad. data ElementDestructionState = ElementDestructionState + -- | Cached attribute by name lookup map. (Maybe (NameMap.NameMap Text)) - -- ^ Cached attribute by name lookup map. + -- | Cached child element by name lookup map. (Maybe (NameMap.NameMap Xml.Element)) - -- ^ Cached child element by name lookup map. new :: ElementDestructionState new = ElementDestructionState Nothing Nothing diff --git a/library/XmlParser/NameMap.hs b/library/XmlParser/NameMap.hs --- a/library/XmlParser/NameMap.hs +++ b/library/XmlParser/NameMap.hs @@ -18,10 +18,10 @@ data NameMap a = NameMap + -- | Namespaced (TupleHashMap.TupleHashMap Text Text [a]) - -- ^ Namespaced + -- | Unnamespaced (HashMap Text [a]) - -- ^ Unnamespaced fromNodes :: NamespaceRegistry.NamespaceRegistry -> [Xml.Node] -> NameMap Xml.Element fromNodes nreg = diff --git a/library/XmlParser/NodeConsumerState.hs b/library/XmlParser/NodeConsumerState.hs --- a/library/XmlParser/NodeConsumerState.hs +++ b/library/XmlParser/NodeConsumerState.hs @@ -15,12 +15,12 @@ data NodeConsumerState = NodeConsumerState + -- | Nodes. [Xml.Node] - -- ^ Nodes. + -- | Offset. Int - -- ^ Offset. + -- | Namespace registry. NamespaceRegistry.NamespaceRegistry - -- ^ Namespace registry. new :: [Xml.Node] -> NamespaceRegistry.NamespaceRegistry -> NodeConsumerState new nodes nsReg = NodeConsumerState nodes 0 nsReg diff --git a/library/XmlParser/Prelude.hs b/library/XmlParser/Prelude.hs --- a/library/XmlParser/Prelude.hs +++ b/library/XmlParser/Prelude.hs @@ -34,7 +34,7 @@ import Data.Fixed as Exports import Data.Foldable as Exports hiding (toList) import Data.Function as Exports hiding (id, (.)) -import Data.Functor as Exports +import Data.Functor as Exports hiding (unzip) import Data.Functor.Compose as Exports import Data.Functor.Identity as Exports import Data.HashMap.Strict as Exports (HashMap) @@ -79,12 +79,10 @@ import System.Mem as Exports import System.Mem.StableName as Exports import System.Timeout as Exports -import Text.ParserCombinators.ReadP as Exports (ReadP, readP_to_S, readS_to_P) -import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readP_to_Prec, readPrec_to_P, readPrec_to_S, readS_to_Prec) import Text.Printf as Exports (hPrintf, printf) import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) -tryMapping :: Exception e => (e -> e') -> IO a -> IO (Either e' a) +tryMapping :: (Exception e) => (e -> e') -> IO a -> IO (Either e' a) tryMapping f action = catch (fmap Right action) (pure . Left . f) diff --git a/library/XmlParser/XmlConduitWrapper.hs b/library/XmlParser/XmlConduitWrapper.hs --- a/library/XmlParser/XmlConduitWrapper.hs +++ b/library/XmlParser/XmlConduitWrapper.hs @@ -34,11 +34,11 @@ renderError :: SomeException -> Text renderError e | Just e <- fromException @XmlConduit.XMLException e = - fromString (show e) + fromString (show e) | Just e <- fromException @XmlConduit.InvalidEventStream e = - fromString (show e) + fromString (show e) | Just (XmlConduit.UnresolvedEntityException e) <- fromException @XmlConduit.UnresolvedEntityException e = - "Unresolved entities: " <> Text.intercalate "," (toList e) + "Unresolved entities: " <> Text.intercalate "," (toList e) | otherwise = - -- FIXME: Find other cases and do something more user-friendly about them - fromString (show e) + -- FIXME: Find other cases and do something more user-friendly about them + fromString (show e) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,10 +11,11 @@ import qualified XmlParser as Xp import Prelude hiding (assert) +main :: IO () main = - defaultMain $ - testGroup "All tests" $ - [ testProperty "ByName/many" $ do + defaultMain + $ testGroup "All tests" + $ [ testProperty "ByName/many" $ do bContents <- fmap (fromString . show) <$> listOf (chooseInt (0, 99)) xml <- @@ -22,8 +23,9 @@ Xc.Element name [] . pure . Xc.NodeContent root = Xc.Element "a" [] . fmap (Xc.NodeElement) - in fmap (documentByteString . elementDocument . root . join) $ - forM bContents $ \bContent -> do + in fmap (documentByteString . elementDocument . root . join) + $ forM bContents + $ \bContent -> do prefix <- oneof [ pure [], @@ -50,13 +52,13 @@ in assertEqual "" (Right (Just "abc-uri", "d")) (Xp.parseByteString parser input), testGroup "Regressions" - [ testCase "Empty string content parsing" $ - let input = "" :: ByteString - parser = Xp.children $ Xp.contentNode $ Xp.textContent - in assertEqual - "" - (Right "") - (Xp.parseByteString parser input) + [ testCase "Empty string content parsing" + $ let input = "" :: ByteString + parser = Xp.children $ Xp.contentNode $ Xp.textContent + in assertEqual + "" + (Right "") + (Xp.parseByteString parser input) ] ] 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.1.1 +version: 0.1.1.2 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 @@ -9,18 +9,74 @@ copyright: (c) 2021 Nikita Volkov license: MIT license-file: LICENSE -build-type: Simple source-repository head type: git - location: git://github.com/nikita-volkov/xml-parser.git + location: https://github.com/nikita-volkov/xml-parser +common base + default-language: Haskell2010 + default-extensions: + ApplicativeDo + Arrows + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + EmptyDataDecls + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + LambdaCase + LiberalTypeSynonyms + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + NoMonomorphismRestriction + OverloadedStrings + PatternGuards + QuasiQuotes + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilies + TypeOperators + +common executable + import: base + ghc-options: + -O2 + -threaded + -with-rtsopts=-N + -rtsopts + -funbox-strict-fields + +common test + import: base + ghc-options: + -threaded + -with-rtsopts=-N + library + import: base hs-source-dirs: library - default-extensions: BangPatterns, BinaryLiterals, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, DerivingVia, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedSums, UnboxedTuples, ViewPatterns - default-language: Haskell2010 exposed-modules: XmlParser + other-modules: XmlParser.AstParser XmlParser.Attoparsec @@ -28,31 +84,29 @@ XmlParser.NameMap XmlParser.NamespaceRegistry XmlParser.NodeConsumerState - XmlParser.TupleHashMap XmlParser.Prelude + XmlParser.TupleHashMap XmlParser.XmlConduitWrapper + build-depends: attoparsec >=0.13 && <0.15, base >=4.11 && <5, - bytestring >=0.10 && <0.12, - containers ^>=0.6, + bytestring >=0.10 && <0.14, + containers >=0.6 && <0.9, hashable >=1.2 && <2, text >=1.2.4 && <3, - text-builder >=0.6.6.2 && <0.7, - transformers ^>=0.5, + text-builder >=1 && <1.1, + transformers >=0.5 && <0.8, unordered-containers ^>=0.2.14, - xml-conduit ^>=1.9.1.1, + xml-conduit >=1.9.1.1 && <1.11, test-suite test + import: test type: exitcode-stdio-1.0 hs-source-dirs: test - default-extensions: BangPatterns, BinaryLiterals, BlockArguments, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, DerivingVia, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedSums, UnboxedTuples, ViewPatterns - default-language: Haskell2010 main-is: Main.hs other-modules: build-depends: - attoparsec >=0.13 && <0.15, - QuickCheck >=2.8.1 && <3, quickcheck-instances >=0.3.11 && <0.4, rerebase >=1.6.1 && <2, tasty >=0.12 && <2,