git.iko.soy/typeable/dom-parser
on 8d2bb39 help sign in
82e2fef
swap
0 ahead, 41 behind
.travis.yml+5−7
since splitsnapshots
unifiedsplit
@@ -4,12 +4,6 @@ sudo: false
4# Do not choose a language; we provide our own build tools.
4# Do not choose a language; we provide our own build tools.
5language: generic
5language: generic
6
6
7−env:
8− - STACK_YAML=stack.yaml
9− - STACK_YAML=ghc-802.yaml
10− - STACK_YAML=ghc-822.yaml
11− - STACK_YAML=ghc-841.yaml
12−
13# Caching so the next build will be fast too.
7# Caching so the next build will be fast too.
14cache:
8cache:
15 directories:
9 directories:
@@ -27,6 +21,10 @@ before_install:
27- export PATH=$HOME/.local/bin:$PATH
21- export PATH=$HOME/.local/bin:$PATH
28- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
22- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
29
23
24+install:
25+# Build dependencies
26+- stack --no-terminal --install-ghc build --only-dependencies
27+
30script:
28script:
31# Build the package, its tests, and its docs and run the tests
29# Build the package, its tests, and its docs and run the tests
32−- stack --no-terminal --install-ghc test --haddock --no-haddock-deps
30+- stack --no-terminal test --haddock --no-haddock-deps
CHANGELOG.md−44
@@ -1,54 +1,10 @@
1# CHANGELOG
1# CHANGELOG
2
2
3−## HEAD
4−
5−## 3.2.0
6−
7−### Added
8−
9−* Text.XML.Soap module with XmlEnvelope stuff in it.
10−* GHC 9 compatibility.
11−
12−### Removed
13−
14−* Old stackage files.
15−
16−## 3.1.0
17−
18−### Added
19−
20−* Additional builds with GHC 8.0.2 and 8.2.1
21−* Compatibility with GHC 8.4.1
22−
23−## 3.0.0
24−
25−* GHC 8 compatible release
26−
27−### Removed
28−
29−* `open-union` dependency
30−
31−## 2.0.0
32−
33−### Added
34−
35−* `NameMatcher` and `ElemMatcher` as more flexible mechanisms for
36− matching names and elements instead of just matching by name.
37−* Class `FromAttribute` and some default instances
38−
39−### Changed
40−
41−* `DomTraversable` renamed to `Buildable`
42−* Combinators use `NameMatcher` and `ElemMatcher`
43−* Documentation improved
44−
45## 1.0.0
3## 1.0.0
46−
47* Added support for parsing attributes
4* Added support for parsing attributes
48* Changed public interface for 'parseContent'
5* Changed public interface for 'parseContent'
49* Added useful functions
6* Added useful functions
50* Dropped unnecessary dependency from shakespeare
7* Dropped unnecessary dependency from shakespeare
51
8
52## 0.1.0
9## 0.1.0
53−
54* Public release
10* Public release
README.mddeleted−5
@@ -1,5 +0,0 @@
1−# dom-parser
2−
3−[![Build Status](https://travis-ci.org/typeable/dom-parser.svg?branch=master)](https://travis-ci.org/typeable/dom-parser)
4−
5−Simple monadic DOM parser
dom-parser.cabal+11−16
@@ -1,5 +1,5 @@
1name: dom-parser
1name: dom-parser
2−version: 3.2.0
2+version: 1.0.0
3synopsis: Simple monadic DOM parser
3synopsis: Simple monadic DOM parser
4license: MIT
4license: MIT
5license-file: LICENSE
5license-file: LICENSE
@@ -7,13 +7,12 @@ author: Typeable.io contributors
7maintainer: makeit@typeable.io
7maintainer: makeit@typeable.io
8category: XML
8category: XML
9build-type: Simple
9build-type: Simple
10+extra-source-files: CHANGELOG.md
10cabal-version: >=1.10
11cabal-version: >=1.10
12+
13+extra-source-files: CHANGELOG.md
14+
11homepage: https://github.com/typeable/dom-parser
15homepage: https://github.com/typeable/dom-parser
12−tested-with: GHC == 9.2.7
13− , GHC == 9.4.8
14− , GHC == 9.6.3
15−extra-source-files: CHANGELOG.md
16− , README.md
17
16
18source-repository head
17source-repository head
19 type: git
18 type: git
@@ -44,26 +43,22 @@ library
44 , TypeFamilies
43 , TypeFamilies
45 , TypeOperators
44 , TypeOperators
46 , UndecidableInstances
45 , UndecidableInstances
47− build-depends: base >= 4.11 && < 5
46+ build-depends: base >= 4.7 && < 5
48− , case-insensitive
49 , containers
47 , containers
50 , lens
48 , lens
51− , mtl < 2.3 || > 2.3
49+ , mtl
50+ , open-union >= 0.2
52 , scientific
51 , scientific
52+ , semigroups
53 , text
53 , text
54 , transformers
54 , transformers
55+ , type-fun
55 , xml-conduit
56 , xml-conduit
56− , xml-conduit-writer
57 , xml-lens
57 , xml-lens
58 exposed-modules: Text.XML.DOM.Parser
58 exposed-modules: Text.XML.DOM.Parser
59− , Text.XML.DOM.Parser.Attributes
59+ , Text.XML.DOM.Parser.Class
60− , Text.XML.DOM.Parser.Buildable
61 , Text.XML.DOM.Parser.Combinators
60 , Text.XML.DOM.Parser.Combinators
62− , Text.XML.DOM.Parser.Content
63− , Text.XML.DOM.Parser.FromAttribute
64− , Text.XML.DOM.Parser.FromDom
65 , Text.XML.DOM.Parser.Types
61 , Text.XML.DOM.Parser.Types
66− , Text.XML.Soap
67
62
68test-suite test
63test-suite test
69 type: exitcode-stdio-1.0
64 type: exitcode-stdio-1.0
ghc-963.yamldeleted−7
@@ -1,7 +0,0 @@
1−resolver: lts-22.6
2−
3−extra-deps:
4− - xml-conduit-writer-0.1.1.5
5−
6−nix:
7− packages: [zlib]
src/Text/XML/DOM/Parser.hs+2−10
@@ -1,17 +1,9 @@
1module Text.XML.DOM.Parser
1module Text.XML.DOM.Parser
2− ( module Text.XML.DOM.Parser.Attributes
2+ ( module Text.XML.DOM.Parser.Class
3− , module Text.XML.DOM.Parser.Buildable
4 , module Text.XML.DOM.Parser.Combinators
3 , module Text.XML.DOM.Parser.Combinators
5− , module Text.XML.DOM.Parser.Content
6− , module Text.XML.DOM.Parser.FromAttribute
7− , module Text.XML.DOM.Parser.FromDom
8 , module Text.XML.DOM.Parser.Types
4 , module Text.XML.DOM.Parser.Types
9 ) where
5 ) where
10
6
11−import Text.XML.DOM.Parser.Attributes
7+import Text.XML.DOM.Parser.Class
12−import Text.XML.DOM.Parser.Buildable
13import Text.XML.DOM.Parser.Combinators
8import Text.XML.DOM.Parser.Combinators
14−import Text.XML.DOM.Parser.Content
15−import Text.XML.DOM.Parser.FromAttribute
16−import Text.XML.DOM.Parser.FromDom
17import Text.XML.DOM.Parser.Types
9import Text.XML.DOM.Parser.Types
src/Text/XML/DOM/Parser/Attributes.hsdeleted−64
@@ -1,64 +0,0 @@
1−module Text.XML.DOM.Parser.Attributes
2− ( parseAttribute
3− , parseAttributeMaybe
4− , getCurrentAttributes
5− , getCurrentAttribute
6− ) where
7−
8−import Control.Lens
9−import Data.Map.Strict as M
10−import Data.Text as T
11−import Text.XML.DOM.Parser.Types
12−import Text.XML.Lens
13−
14−-- | Parses attribute with given name, throws error if attribute is not found.
15−--
16−-- @since 1.0.0
17−parseAttribute
18− :: (Monad m)
19− => NameMatcher
20− -- ^ Attribute name
21− -> (Text -> Either Text a)
22− -- ^ Attribute content parser
23− -> DomParserT Identity m a
24−parseAttribute attrName parser =
25− parseAttributeMaybe attrName parser >>= \case
26− Nothing -> throwParserError $ PEAttributeNotFound attrName
27− Just a -> return a
28−
29−-- | Parses attribute with given name. Returns Nothing if attribute is
30−-- not found.
31−--
32−-- @since 1.0.0
33−parseAttributeMaybe
34− :: (Monad m)
35− => NameMatcher
36− -- ^ Attribute name
37− -> (Text -> Either Text a)
38− -- ^ Attribute content parser
39− -> DomParserT Identity m (Maybe a)
40−parseAttributeMaybe attrName parser =
41− getCurrentAttribute attrName >>= \case
42− Nothing -> return Nothing
43− Just aval -> case parser aval of
44− Left err -> throwParserError $ PEAttributeWrongFormat attrName err
45− Right a -> return $ Just a
46−
47−-- | Retuns map of attributes of current element
48−--
49−-- @since 1.0.0
50−getCurrentAttributes
51− :: (Monad m)
52− => DomParserT Identity m (M.Map Name Text)
53−getCurrentAttributes = view $ pdElements . to runIdentity . attrs
54−
55−-- | Returns element with given name or 'Nothing'
56−--
57−-- @since 1.0.0
58−getCurrentAttribute
59− :: (Monad m)
60− => NameMatcher
61− -> DomParserT Identity m (Maybe Text)
62−getCurrentAttribute attrName
63− = preview $ pdElements . to runIdentity . attrs . to M.toList
64− . traversed . filtered (views _1 (attrName ^. nmMatch)) . _2
src/Text/XML/DOM/Parser/Buildable.hsdeleted−26
@@ -1,26 +0,0 @@
1−module Text.XML.DOM.Parser.Buildable
2− ( Buildable(..)
3− ) where
4−
5−import Data.Functor.Identity
6−import Data.List.NonEmpty as NE
7−import Data.Maybe
8−
9−-- | Class of traversable functors which may be constructed from list
10−class Traversable f => Buildable f where
11− -- | If method return Nothing this means we can not build
12− -- traversable from given list. In this case 'inFilteredTrav' should
13− -- fail traversing.
14− build :: [a] -> Maybe (f a)
15−
16−instance Buildable Identity where
17− build = fmap Identity . listToMaybe
18−
19−instance Buildable [] where
20− build = Just
21−
22−instance Buildable Maybe where
23− build = Just . listToMaybe
24−
25−instance Buildable NonEmpty where
26− build = NE.nonEmpty
src/Text/XML/DOM/Parser/FromDom.hs → src/Text/XML/DOM/Parser/Class.hsrenamed+111−42
@@ -1,32 +1,40 @@
1−module Text.XML.DOM.Parser.FromDom
1+module Text.XML.DOM.Parser.Class
2 ( -- * FromDom
2 ( -- * FromDom
3 FromDom(..)
3 FromDom(..)
4 , proxyFromDom
4 , proxyFromDom
5 -- * Explicit methods for convenience
5 -- * Explicit methods for convenience
6 , elementFromDom
6 , elementFromDom
7+ , unionFromDom
7 , textFromDom
8 , textFromDom
8 , stringFromDom
9 , stringFromDom
9 , charFromDom
10 , charFromDom
11+ , readChar
10 , intFromDom
12 , intFromDom
11 , integerFromDom
13 , integerFromDom
12 , doubleFromDom
14 , doubleFromDom
13 , fixedFromDom
15 , fixedFromDom
14 , boolFromDom
16 , boolFromDom
17+ , readBool
15 , unitFromDom
18 , unitFromDom
16 , voidFromDom
19 , voidFromDom
17 , scientificFromDom
20 , scientificFromDom
21+ -- * FromAttribute
22+ , FromAttribute(..)
18 ) where
23 ) where
19
24
20import Control.Applicative
25import Control.Applicative
21import Control.Lens
26import Control.Lens
22import Data.Fixed
27import Data.Fixed
28+import Data.Monoid
29+import Data.OpenUnion
23import Data.Scientific
30import Data.Scientific
24import Data.Text as T hiding (empty)
31import Data.Text as T hiding (empty)
25import Data.Typeable
32import Data.Typeable
26import Data.Void
33import Data.Void
27import Text.XML
34import Text.XML
28−import Text.XML.DOM.Parser.Content
35+import Text.XML.DOM.Parser.Combinators
29import Text.XML.DOM.Parser.Types
36import Text.XML.DOM.Parser.Types
37+import TypeFun.Data.List hiding (Union)
30
38
31proxyFromDom
39proxyFromDom
32 :: forall proxy m a
40 :: forall proxy m a
@@ -35,86 +43,147 @@ proxyFromDom
35 -> DomParserT Identity m a
43 -> DomParserT Identity m a
36proxyFromDom _ = fromDom
44proxyFromDom _ = fromDom
37
45
38−-- | Class of types which can be parsed from single XML element. The
46+-- | Class of types which can be parsed from single XML element.
39−-- method 'fromDom' is convenient default to use with 'inElem'
40class FromDom a where
47class FromDom a where
41 fromDom :: (Monad m) => DomParserT Identity m a
48 fromDom :: (Monad m) => DomParserT Identity m a
42
49
43instance FromDom () where
50instance FromDom () where
44 fromDom = unitFromDom
51 fromDom = unitFromDom
45
52
46−-- | Always successfully parses any DOM to @()@
47−unitFromDom :: (Monad m) => DomParserT Identity m ()
48−unitFromDom = pure ()
49−
50instance FromDom Void where
53instance FromDom Void where
51 fromDom = voidFromDom
54 fromDom = voidFromDom
52
55
53−-- | Never parses successfully. It is just 'empty'
54−voidFromDom :: (Monad m) => DomParserT Identity m Void
55−voidFromDom = empty
56−
57instance FromDom Text where
56instance FromDom Text where
58 fromDom = textFromDom
57 fromDom = textFromDom
59
58
60−textFromDom :: (Monad m) => DomParserT Identity m Text
61−textFromDom = parseContent Right
62−
63instance FromDom String where
59instance FromDom String where
64 fromDom = stringFromDom
60 fromDom = stringFromDom
65
61
66−stringFromDom :: (Monad m) => DomParserT Identity m String
67−stringFromDom = parseContent $ Right . T.unpack
68−
69instance FromDom Char where
62instance FromDom Char where
70 fromDom = charFromDom
63 fromDom = charFromDom
71
64
65+instance FromDom Int where
66+ fromDom = intFromDom
67+
68+instance FromDom Integer where
69+ fromDom = integerFromDom
70+
71+instance FromDom Double where
72+ fromDom = doubleFromDom
73+
74+instance (HasResolution a, Typeable a) => FromDom (Fixed a) where
75+ fromDom = fixedFromDom
76+
77+instance FromDom Scientific where
78+ fromDom = scientificFromDom
79+
80+instance FromDom Bool where
81+ fromDom = boolFromDom
82+
83+instance FromDom (Union '[]) where
84+ fromDom = empty
85+
86+instance
87+ ( Typeable a, FromDom a, FromDom (Union as)
88+ , SubList as (a ': as) )
89+ => FromDom (Union (a ': as)) where
90+ -- fromDom :: forall m. (DomParserMonad m) => m a
91+ fromDom = (liftUnion <$> (proxyFromDom (Proxy :: Proxy a)))
92+ <|> (reUnion <$> (proxyFromDom (Proxy :: Proxy (Union as))))
93+
94+instance FromDom Element where
95+ fromDom = elementFromDom
96+
97+elementFromDom :: (Monad m) => DomParserT Identity m Element
98+elementFromDom = view $ pdElements . to runIdentity
99+
100+unionFromDom
101+ :: (Monad m, FromDom (Union as))
102+ => proxy as
103+ -> DomParserT Identity m (Union as)
104+unionFromDom _ = fromDom
105+
106+textFromDom :: (Monad m) => DomParserT Identity m Text
107+textFromDom = parseContent Right
108+
109+stringFromDom :: (Monad m) => DomParserT Identity m String
110+stringFromDom = parseContent $ Right . T.unpack
111+
72charFromDom :: (Monad m) => DomParserT Identity m Char
112charFromDom :: (Monad m) => DomParserT Identity m Char
73charFromDom = parseContent readChar
113charFromDom = parseContent readChar
74
114
75−instance FromDom Int where
115+-- | Expects text to be single character
76− fromDom = intFromDom
116+--
117+-- @since 1.0.0
118+readChar :: Text -> Either Text Char
119+readChar t = case T.unpack $ T.strip t of
120+ [c] -> Right c
121+ _ -> Left "Should have exactly one non-blank character"
77
122
78intFromDom :: (Monad m) => DomParserT Identity m Int
123intFromDom :: (Monad m) => DomParserT Identity m Int
79intFromDom = parseContent readContent
124intFromDom = parseContent readContent
80
125
81−instance FromDom Integer where
82− fromDom = integerFromDom
83−
84integerFromDom :: (Monad m) => DomParserT Identity m Integer
126integerFromDom :: (Monad m) => DomParserT Identity m Integer
85integerFromDom = parseContent readContent
127integerFromDom = parseContent readContent
86
128
87−instance FromDom Double where
88− fromDom = doubleFromDom
89−
90doubleFromDom :: (Monad m) => DomParserT Identity m Double
129doubleFromDom :: (Monad m) => DomParserT Identity m Double
91doubleFromDom = parseContent readContent
130doubleFromDom = parseContent readContent
92
131
93−instance (HasResolution a, Typeable a) => FromDom (Fixed a) where
94− fromDom = fixedFromDom
95−
96fixedFromDom
132fixedFromDom
97 :: (Monad m, Typeable a, HasResolution a)
133 :: (Monad m, Typeable a, HasResolution a)
98 => DomParserT Identity m (Fixed a)
134 => DomParserT Identity m (Fixed a)
99fixedFromDom = parseContent readContent
135fixedFromDom = parseContent readContent
100
136
101−instance FromDom Scientific where
102− fromDom = scientificFromDom
103−
104scientificFromDom :: Monad m => DomParserT Identity m Scientific
137scientificFromDom :: Monad m => DomParserT Identity m Scientific
105scientificFromDom = parseContent readContent
138scientificFromDom = parseContent readContent
106
139
107−instance FromDom Bool where
108− fromDom = boolFromDom
109−
110−-- | Expects content to be y, yes, t, true or 1 for True Values n, no,
140+-- | Expects content to be y, yes, t, true or 1 for True value. n, no,
111−-- f, false or 0 for False. Case is not significant, blank characters
141+-- f, false or 0 for False value. Case is not significant, blank
112−-- are striped.
142+-- characters are striped.
113boolFromDom :: (Monad m) => DomParserT Identity m Bool
143boolFromDom :: (Monad m) => DomParserT Identity m Bool
114boolFromDom = parseContent readBool
144boolFromDom = parseContent readBool
115
145
116−instance FromDom Element where
146+-- | @since 1.0.0
117− fromDom = elementFromDom
147+readBool :: Text -> Either Text Bool
148+readBool t =
149+ let
150+ lowt = T.toLower $ T.strip t
151+ tvals = ["y", "yes", "t", "true", "1"]
152+ fvals = ["n", "no", "f", "false", "0"]
153+ in if
154+ | lowt `elem` tvals -> Right True
155+ | lowt `elem` fvals -> Right False
156+ | otherwise ->
157+ Left $ "Could not read " <> t <> " as Bool"
118
158
159+-- | Always successfully parses any DOM to @()@
119−elementFromDom :: (Monad m) => DomParserT Identity m Element
160+unitFromDom :: (Monad m) => DomParserT Identity m ()
120−elementFromDom = view $ pdElements . to runIdentity
161+unitFromDom = pure ()
162+
163+-- | Never parses successfully. It is just 'mzero'
164+voidFromDom :: (Monad m) => DomParserT Identity m Void
165+voidFromDom = empty
166+
167+class FromAttribute a where
168+ fromAttribute :: Text -> Either Text a
169+
170+instance FromAttribute () where
171+ fromAttribute _ = Right ()
172+
173+instance FromAttribute Text where
174+ fromAttribute = Right
175+
176+instance FromAttribute Char where
177+ fromAttribute = readChar
178+
179+instance FromAttribute Int where
180+ fromAttribute = readContent
181+
182+instance FromAttribute Integer where
183+ fromAttribute = readContent
184+
185+instance (Typeable a, HasResolution a) => FromAttribute (Fixed a) where
186+ fromAttribute = readContent
187+
188+instance FromAttribute Scientific where
189+ fromAttribute = readContent
src/Text/XML/DOM/Parser/Combinators.hs+180−49
@@ -2,7 +2,7 @@ module Text.XML.DOM.Parser.Combinators
2 ( -- * Generic combinators to traverse descendants
2 ( -- * Generic combinators to traverse descendants
3 traverseElems
3 traverseElems
4 , inFilteredTrav
4 , inFilteredTrav
5− -- * Using 'Buildable'
5+ -- * Using 'DomTraversable'
6 , inElemTrav
6 , inElemTrav
7 , inElem
7 , inElem
8 , inElemAll
8 , inElemAll
@@ -15,30 +15,47 @@ module Text.XML.DOM.Parser.Combinators
15 , ignoreElem
15 , ignoreElem
16 , ignoreEmpty
16 , ignoreEmpty
17 , ignoreBlank
17 , ignoreBlank
18+ -- * Getting current element's properties
19+ , getCurrentName
20+ , getCurrentContent
21+ , getCurrentAttributes
22+ , getCurrentAttribute
23+ -- * Current element's checks
24+ , checkCurrentName
25+ -- * Parsing element's content
26+ , parseContent
27+ , readContent
28+ , maybeReadContent
29+ -- * Parsing attributes
30+ , parseAttribute
31+ , parseAttributeMaybe
18 ) where
32 ) where
19
33
20−import Control.Lens
34+import Control.Lens
35+import Control.Monad.Except
21−import Control.Monad.Reader
36+import Control.Monad.Reader
22−import Data.Foldable as F
37+import Data.List.NonEmpty (NonEmpty(..))
23−import Data.List as L
38+import qualified Data.Map.Strict as M
24−import Data.List.NonEmpty (NonEmpty(..))
39+import Data.Monoid
40+import Data.Text (Text)
25−import Data.Text as T
41+import qualified Data.Text as T
26−import Data.Traversable
42+import Data.Traversable
27−import Text.XML
43+import Data.Typeable
44+import Text.Read
28−import Text.XML.DOM.Parser.Buildable
45+import Text.XML
29−import Text.XML.DOM.Parser.Types
46+import Text.XML.DOM.Parser.Types
30−import Text.XML.Lens
47+import Text.XML.Lens
31
48
32
49
33−-- | Generic function to traverse arbitrary inner elements.
50+-- | Generic function to traverse arbitrary inner cursors.
34traverseElems
51traverseElems
35 :: (Monad m, Foldable g, Traversable f)
52 :: (Monad m, Foldable g, Traversable f)
36 => ([Element] -> DomParserT g m (f (DomPath, Element)))
53 => ([Element] -> DomParserT g m (f (DomPath, Element)))
37 -- ^ Takes list of current elements and returns container with
54 -- ^ Takes list of current elements and returns container with
38− -- pairs of subpath (relatively to current elements) and element
55+ -- pairs of subpath (relatively to current element) and element
39 -- to run parser in
56 -- to run parser in
40 -> DomParserT Identity m a
57 -> DomParserT Identity m a
41− -- ^ Parser to run for each element found in traversable 'f'
58+ -- ^ Parser will be runned for each element found in traversable
42 -> DomParserT g m (f a)
59 -> DomParserT g m (f a)
43traverseElems trav parser = do
60traverseElems trav parser = do
44 pd <- ask
61 pd <- ask
@@ -48,73 +65,68 @@ traverseElems trav parser = do
48 newpd = ParserData
65 newpd = ParserData
49 { _pdElements = Identity e
66 { _pdElements = Identity e
50 , _pdPath = pd ^. pdPath <> subpath }
67 , _pdPath = pd ^. pdPath <> subpath }
51− lift $ runReaderT parser newpd
68+ -- type of reader has been changed, local won't work here
69+ magnify (to $ const newpd) parser
52
70
53−-- | Traverses elements located in same path using filtering function
71+-- | Takes function filtering
54inFilteredTrav
72inFilteredTrav
55− :: (Monad m, Foldable g, Buildable f)
73+ :: (Monad m, Foldable g, DomTraversable f)
56 => ([Element] -> (DomPath, [Element]))
74 => ([Element] -> (DomPath, [Element]))
57− -- ^ Takes list of current elements and returns some descendants
75+ -- ^ Function returning some filtered elements with path suffixes which will
58− -- subset and path this descendants located at. Path is should be
76+ -- be appended to parser's state
59− -- same for all descendants and required for error message
60 -> DomParserT Identity m a
77 -> DomParserT Identity m a
61 -> DomParserT g m (f a)
78 -> DomParserT g m (f a)
62inFilteredTrav deeper = traverseElems trav
79inFilteredTrav deeper = traverseElems trav
63 where
80 where
64 trav e = do
81 trav e = do
65 let (path, elems) = deeper e
82 let (path, elems) = deeper e
66− case build elems of
83+ case buildDomTraversable elems of
67 Nothing -> throwParserError $ PENotFound . (<> path)
84 Nothing -> throwParserError $ PENotFound . (<> path)
68 Just tr -> return $ fmap (path,) tr
85 Just tr -> return $ fmap (path,) tr
69
86
70−-- | Runs parser arbitrary times, depending on 'Buildable' instance of
71−-- 'f'. For example if 'f' becomes 'NonEmpty' then 'inElemTrav' finds
72−-- @one or more@ elements matched by given 'ElemMatcher' and run
73−-- parser in each found element, then returns @NonEmpty a@ of results.
74inElemTrav
87inElemTrav
75− :: (Monad m, Foldable g, Buildable f)
88+ :: (Monad m, Foldable g, DomTraversable f)
76− => ElemMatcher -- ^ Tag(s) matcher to traverse in
89+ => Text
77 -> DomParserT Identity m a
90 -> DomParserT Identity m a
78 -> DomParserT g m (f a)
91 -> DomParserT g m (f a)
79inElemTrav n = inFilteredTrav deeper
92inElemTrav n = inFilteredTrav deeper
80 where
93 where
81− elemsFold = folded . nodes . folded . _Element . elMatch n
94+ deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)
82− deeper = (DomPath [_emShow n],) . toListOf elemsFold
83
95
84−-- | Runs parser inside first children element matched by macher
96+-- | Runs parser inside first children element with given name
85inElem
97inElem
86 :: (Monad m, Foldable g)
98 :: (Monad m, Foldable g)
87− => ElemMatcher
99+ => Text
88 -> DomParserT Identity m a
100 -> DomParserT Identity m a
89 -> DomParserT g m a
101 -> DomParserT g m a
90inElem n = fmap runIdentity . inElemTrav n
102inElem n = fmap runIdentity . inElemTrav n
91
103
92inElemAll
104inElemAll
93 :: (Monad m, Foldable g)
105 :: (Monad m, Foldable g)
94− => ElemMatcher
106+ => Text
95 -> DomParserT Identity m a
107 -> DomParserT Identity m a
96 -> DomParserT g m [a]
108 -> DomParserT g m [a]
97inElemAll = inElemTrav
109inElemAll = inElemTrav
98
110
99inElemMay
111inElemMay
100 :: (Monad m, Foldable g)
112 :: (Monad m, Foldable g)
101− => ElemMatcher
113+ => Text
102 -> DomParserT Identity m a
114 -> DomParserT Identity m a
103 -> DomParserT g m (Maybe a)
115 -> DomParserT g m (Maybe a)
104inElemMay = inElemTrav
116inElemMay = inElemTrav
105
117
106inElemNe
118inElemNe
107 :: (Monad m, Foldable g)
119 :: (Monad m, Foldable g)
108− => ElemMatcher
120+ => Text
109 -> DomParserT Identity m a
121 -> DomParserT Identity m a
110 -> DomParserT g m (NonEmpty a)
122 -> DomParserT g m (NonEmpty a)
111inElemNe = inElemTrav
123inElemNe = inElemTrav
112
124
113{- | Dive given parser's current tags set into the given path. The @divePath
125{- | Dive given parser's current tags set into the given path. The @divePath
114−["a", "b"]@ differs from @inElem "a" $ inElem "b"@. Namely the first variant
126+["a", "b"]@ differs from @inElem "a" . inElem "b"@. Namely the first variant
115will not fail if occured tag "a" which does not contains tag "b". This
127will not fail if occured tag "a" which does not contains tag "b". This
116behaviour is desireable when you dont want to parse whole XML and just want
128behaviour is desireable when you dont want to parse whole XML and just want
117−to pull tags located in some path. The other difference is in traversing inner
129+to pull tags in some path. The other difference is in traversing inner
118elements. Consider this code
130elements. Consider this code
119
131
120@
132@
@@ -132,31 +144,26 @@ which translates like: @a > b > c > fromDom@
132As you can see, inElem always takes first element and runs inner parser in this
144As you can see, inElem always takes first element and runs inner parser in this
133single element, unlike 'divePath' which runs inner parser @in all@ descendants
145single element, unlike 'divePath' which runs inner parser @in all@ descendants
134in given path.
146in given path.
135−
136−Note also that 'divePath' takes parser parameterized by @[]@ not by
137−'Identity'. This because when you dive using some path you will get a
138−list of found elements and all these elements will be @current@ for
139−parser.
140-}
147-}
141
148
142divePath
149divePath
143 :: forall m g a
150 :: forall m g a
144 . (Monad m, Foldable g)
151 . (Monad m, Foldable g)
145− => [ElemMatcher]
152+ => [Text]
146 -> DomParserT [] m a
153 -> DomParserT [] m a
147 -> DomParserT g m a
154 -> DomParserT g m a
148divePath path = magnify $ to modElems
155divePath path = magnify $ to modElems
149 where
156 where
150 modElems
157 modElems
151 = over pdElements (toListOf $ folded . diver)
158 = over pdElements (toListOf $ folded . diver)
152− . over pdPath (<> DomPath (L.map _emShow path))
159+ . over pdPath (<> path)
153 diver :: Fold Element Element
160 diver :: Fold Element Element
154− diver = F.foldr (.) id $ L.map toDive path
161+ diver = foldr (.) id $ map toDive path
155− toDive n = nodes . folded . _Element . elMatch n
162+ toDive n = nodes . folded . _Element . ell n
156
163
157diveElem
164diveElem
158 :: (Monad m, Foldable g)
165 :: (Monad m, Foldable g)
159− => ElemMatcher
166+ => Text
160 -> DomParserT [] m a
167 -> DomParserT [] m a
161 -> DomParserT g m a
168 -> DomParserT g m a
162diveElem p = divePath [p]
169diveElem p = divePath [p]
@@ -183,7 +190,7 @@ ignoreEmpty
183 -> DomParserT Identity m (Maybe a)
190 -> DomParserT Identity m (Maybe a)
184ignoreEmpty = ignoreElem test
191ignoreEmpty = ignoreElem test
185 where
192 where
186− test e = L.null $ e ^. nodes
193+ test e = null $ e ^. nodes
187
194
188-- | If all current elements contains blank content, or contains nothing at all
195-- | If all current elements contains blank content, or contains nothing at all
189-- , then returns Nothing, else runs parser.
196-- , then returns Nothing, else runs parser.
@@ -197,6 +204,130 @@ ignoreBlank = ignoreElem test
197 let
204 let
198 elems = e ^.. nodes . folded . _Element
205 elems = e ^.. nodes . folded . _Element
199 cont = mconcat $ e ^.. nodes . folded . _Content
206 cont = mconcat $ e ^.. nodes . folded . _Content
200− in if | not $ L.null elems -> False
207+ in if | not $ null elems -> False
201 | T.null $ T.strip cont -> True
208 | T.null $ T.strip cont -> True
202 | otherwise -> False
209 | otherwise -> False
210+
211+-- | Returns name of current element.
212+--
213+-- @since 1.0.0
214+getCurrentName :: (Monad m) => DomParserT Identity m Text
215+getCurrentName = view $ pdElements . to runIdentity . localName
216+
217+-- | If name of current tag differs from first argument throws 'PENotFound' with
218+-- tag name replaced in last path's segment. Useful for checking root
219+-- document's element name.
220+checkCurrentName
221+ :: (Monad m)
222+ => Text
223+ -> DomParserT Identity m ()
224+checkCurrentName n = do
225+ cn <- getCurrentName
226+ unless (cn == n) $ do
227+ p <- view pdPath
228+ let pinit = if null p then [] else init p
229+ throwError $ ParserErrors [PENotFound $ pinit ++ [n]]
230+ return ()
231+
232+-- | Get current content. If current element contains no content or
233+-- have inner elements then Nothing returned
234+--
235+-- @since 1.0.0
236+getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)
237+getCurrentContent = do
238+ nds <- view $ pdElements . to runIdentity . nodes
239+ let
240+ els :: [Element]
241+ els = nds ^.. folded . _Element
242+ conts :: [Text]
243+ conts = nds ^.. folded . _Content
244+ return $ if
245+ | not $ null els -> Nothing
246+ | null conts -> Nothing
247+ | otherwise -> Just $ mconcat conts
248+
249+-- | Parses content inside current tag. It expects current element set
250+-- consists of exactly ONE element. If current element does not
251+-- contains content or have other elements as childs then throws error
252+parseContent
253+ :: (Monad m)
254+ => (Text -> Either Text a)
255+ -- ^ Content parser, return error msg if value is not parsed
256+ -> DomParserT Identity m a
257+parseContent parse = getCurrentContent >>= \case
258+ Nothing -> throwParserError PEContentNotFound
259+ Just c -> case parse c of
260+ Left e -> throwParserError $ PEWrongFormat e
261+ Right a -> return a
262+
263+-- | If reader returns 'Nothing' then resulting function returns 'Left
264+-- "error message"'
265+--
266+-- @since 1.0.0
267+maybeReadContent
268+ :: forall a
269+ . (Typeable a)
270+ => (Text -> Maybe a)
271+ -- ^ Content or attribute reader
272+ -> Text
273+ -- ^ Content or attribute value
274+ -> Either Text a
275+maybeReadContent f t = maybe (Left msg) Right $ f t
276+ where
277+ msg = "Not readable " <> n <> ": " <> t
278+ n = T.pack $ show $ typeRep (Proxy :: Proxy a)
279+
280+-- | Tries to read given text to value using 'Read'. Useful to use
281+-- with 'parseContent' and 'parseAttribute'
282+readContent
283+ :: (Read a, Typeable a)
284+ => Text
285+ -> Either Text a
286+readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
287+
288+-- | Retuns map of attributes of current element
289+--
290+-- @since 1.0.0
291+getCurrentAttributes :: (Monad m) => DomParserT Identity m (M.Map Name Text)
292+getCurrentAttributes = view $ pdElements . to runIdentity . attrs
293+
294+-- | Returns element with given name or 'Nothing'
295+--
296+-- @since 1.0.0
297+getCurrentAttribute :: (Monad m) => Text -> DomParserT Identity m (Maybe Text)
298+getCurrentAttribute attrName'
299+ = preview $ pdElements . to runIdentity . attr attrName
300+ where
301+ attrName = Name attrName' Nothing Nothing
302+
303+-- | Parses attribute with given name, throws error if attribute is not found.
304+--
305+-- @since 1.0.0
306+parseAttribute
307+ :: (Monad m)
308+ => Text
309+ -- ^ Attribute name
310+ -> (Text -> Either Text a)
311+ -- ^ Attribute content parser
312+ -> DomParserT Identity m a
313+parseAttribute attrName parser =
314+ parseAttributeMaybe attrName parser >>= \case
315+ Nothing -> throwParserError $ PEAttributeNotFound attrName
316+ Just a -> return a
317+
318+-- | Parses attribute with given name.
319+--
320+-- @since 1.0.0
321+parseAttributeMaybe
322+ :: (Monad m)
323+ => Text
324+ -- ^ Attribute name
325+ -> (Text -> Either Text a)
326+ -- ^ Attribute content parser
327+ -> DomParserT Identity m (Maybe a)
328+parseAttributeMaybe attrName parser =
329+ getCurrentAttribute attrName >>= \case
330+ Nothing -> return Nothing
331+ Just aval -> case parser aval of
332+ Left err -> throwParserError $ PEAttributeWrongFormat attrName err
333+ Right a -> return $ Just a
src/Text/XML/DOM/Parser/Content.hsdeleted−129
@@ -1,129 +0,0 @@
1−module Text.XML.DOM.Parser.Content
2− (
3− -- * Parsing element's content
4− parseContent
5− -- * Getting current element's properties
6− , getCurrentName
7− , getCurrentContent
8− , checkCurrentName
9− -- * Internal
10− , maybeReadContent
11− , readContent
12− , readBool
13− , readChar
14− ) where
15−
16−import Control.Lens
17−import Control.Monad
18−import Control.Monad.Except
19−import Data.List as L
20−import Data.Monoid
21−import Data.Text as T
22−import Data.Typeable
23−import Prelude as P
24−import Text.Read
25−import Text.XML.DOM.Parser.Types
26−import Text.XML.Lens
27−
28−
29−-- | Parses content inside current tag. It expects current element set
30−-- consists of exactly ONE element.
31−parseContent
32− :: (Monad m)
33− => (Text -> Either Text a)
34− -- ^ Content parser, return error msg if value is not parsed
35− -> DomParserT Identity m a
36−parseContent parse = getCurrentContent >>= \case
37− Nothing -> throwParserError PEContentNotFound
38− Just c -> case parse c of
39− Left e -> throwParserError $ PEContentWrongFormat e
40− Right a -> return a
41−
42−
43−-- | Returns name of current element.
44−--
45−-- @since 1.0.0
46−getCurrentName :: (Monad m) => DomParserT Identity m Name
47−getCurrentName = view $ pdElements . to runIdentity . name
48−
49−-- | If name of current tag differs from first argument throws 'PENotFound' with
50−-- tag name replaced in last path's segment. Useful for checking root
51−-- document's element name.
52−checkCurrentName
53− :: (Monad m)
54− => NameMatcher
55− -> DomParserT Identity m ()
56−checkCurrentName n = do
57− cn <- getCurrentName
58− unless ((n ^. nmMatch) cn) $ do
59− p <- view pdPath
60− let pinit = if L.null (unDomPath p) then [] else L.init $ unDomPath p
61− throwError $ ParserErrors [PENotFound $ DomPath $ pinit ++ [_nmShow n]]
62− return ()
63−
64−-- | Get current content. If current element contains no content or
65−-- have inner elements then Nothing returned
66−--
67−-- @since 1.0.0
68−getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)
69−getCurrentContent = do
70− nds <- view $ pdElements . to runIdentity . nodes
71− let
72− els :: [Element]
73− els = nds ^.. folded . _Element
74− conts :: [Text]
75− conts = nds ^.. folded . _Content
76− return $ if
77− | not $ L.null els -> Nothing
78− | L.null conts -> Nothing
79− | otherwise -> Just $ mconcat conts
80−
81−-- | If reader returns 'Nothing' then resulting function returns 'Left
82−-- "error message"'. 'Typeable' is used for generating usefull error
83−-- message.
84−--
85−-- @since 1.0.0
86−maybeReadContent
87− :: forall a
88− . (Typeable a)
89− => (Text -> Maybe a)
90− -- ^ Content or attribute reader
91− -> Text
92− -- ^ Content or attribute value
93− -> Either Text a
94−maybeReadContent f t = maybe (Left msg) Right $ f t
95− where
96− msg = "Not readable " <> n <> ": " <> t
97− n = T.pack $ P.show $ typeRep (Proxy :: Proxy a)
98−
99−
100−-- | Tries to read given text to value using 'Read'. Useful to use
101−-- with 'parseContent' and 'parseAttribute'. Content is stripped
102−-- before reading.
103−readContent
104− :: (Read a, Typeable a)
105− => Text
106− -> Either Text a
107−readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
108−
109−
110−-- | @since 1.0.0
111−readBool :: Text -> Either Text Bool
112−readBool t =
113− let
114− lowt = T.toLower $ T.strip t
115− tvals = ["y", "yes", "t", "true", "1"]
116− fvals = ["n", "no", "f", "false", "0"]
117− in if
118− | lowt `L.elem` tvals -> Right True
119− | lowt `L.elem` fvals -> Right False
120− | otherwise ->
121− Left $ "Could not read " <> t <> " as Bool"
122−
123−-- | Expects text to be single character
124−--
125−-- @since 1.0.0
126−readChar :: Text -> Either Text Char
127−readChar t = case T.unpack $ T.strip t of
128− [c] -> Right c
129− _ -> Left "Should have exactly one non-blank character"
src/Text/XML/DOM/Parser/FromAttribute.hsdeleted−112
@@ -1,112 +0,0 @@
1−module Text.XML.DOM.Parser.FromAttribute
2− ( -- * FromAttribute
3− FromAttribute(..)
4− , proxyFromAttribute
5− -- * Explicit methods
6− , textFromAttribute
7− , stringFromAttribute
8− , charFromAttribute
9− , intFromAttribute
10− , integerFromAttribute
11− , doubleFromAttribute
12− , fixedFromAttribute
13− , boolFromAttribute
14− , unitFromAttribute
15− , voidFromAttribute
16− , scientificFromAttribute
17− ) where
18−
19−import Data.Fixed
20−import Data.Scientific
21−import Data.Text as T
22−import Data.Typeable
23−import Data.Void
24−import Text.XML.DOM.Parser.Content
25−
26−-- | Class of types which can be get from attribute value. Method
27−-- 'fromAttribute' is a convenient default parameter for
28−-- 'parseAttribute'
29−--
30−-- @since 2.0.0
31−class FromAttribute a where
32− fromAttribute
33− :: Text
34− -- ^ Attribute contents to parse
35− -> Either Text a
36− -- ^ Either error message or result
37−
38−proxyFromAttribute
39− :: FromAttribute a
40− => Proxy a
41− -> Text
42− -> Either Text a
43−proxyFromAttribute _ = fromAttribute
44−
45−instance FromAttribute () where
46− fromAttribute = unitFromAttribute
47−
48−unitFromAttribute :: Text -> Either Text ()
49−unitFromAttribute _ = Right ()
50−
51−instance FromAttribute Void where
52− fromAttribute = voidFromAttribute
53−
54−voidFromAttribute :: Text -> Either Text Void
55−voidFromAttribute _ = Left "Void has been parsed"
56−
57−instance FromAttribute Text where
58− fromAttribute = textFromAttribute
59−
60−textFromAttribute :: Text -> Either Text Text
61−textFromAttribute = Right
62−
63−instance FromAttribute String where
64− fromAttribute = stringFromAttribute
65−
66−stringFromAttribute :: Text -> Either Text String
67−stringFromAttribute = Right . T.unpack
68−
69−instance FromAttribute Char where
70− fromAttribute = charFromAttribute
71−
72−charFromAttribute :: Text -> Either Text Char
73−charFromAttribute = readChar
74−
75−instance FromAttribute Int where
76− fromAttribute = intFromAttribute
77−
78−intFromAttribute :: Text -> Either Text Int
79−intFromAttribute = readContent
80−
81−instance FromAttribute Integer where
82− fromAttribute = integerFromAttribute
83−
84−integerFromAttribute :: Text -> Either Text Integer
85−integerFromAttribute = readContent
86−
87−instance FromAttribute Double where
88− fromAttribute = doubleFromAttribute
89−
90−doubleFromAttribute :: Text -> Either Text Double
91−doubleFromAttribute = readContent
92−
93−instance (Typeable a, HasResolution a) => FromAttribute (Fixed a) where
94− fromAttribute = fixedFromAttribute
95−
96−fixedFromAttribute
97− :: (HasResolution a, Typeable a)
98− => Text
99− -> Either Text (Fixed a)
100−fixedFromAttribute = readContent
101−
102−instance FromAttribute Bool where
103− fromAttribute = boolFromAttribute
104−
105−boolFromAttribute :: Text -> Either Text Bool
106−boolFromAttribute = readBool
107−
108−instance FromAttribute Scientific where
109− fromAttribute = scientificFromAttribute
110−
111−scientificFromAttribute :: Text -> Either Text Scientific
112−scientificFromAttribute = readContent
src/Text/XML/DOM/Parser/Types.hs+63−145
@@ -1,19 +1,6 @@
1module Text.XML.DOM.Parser.Types
1module Text.XML.DOM.Parser.Types
2− (-- * Element matching
3− ElemMatcher(..)
4− , emMatch
5− , emShow
6− , matchElemName
7− , elMatch
8− -- * Name matching
9− , NameMatcher(..)
10− , nmMatch
11− , nmShow
12− , matchName
13− , matchLocalName
14− , matchCILocalName
15− -- * Parser internals
2+ ( -- * Parser internals
16− , DomPath(..)
3+ DomPath
17 , ParserError(..)
4 , ParserError(..)
18 , pePath
5 , pePath
19 , peDetails
6 , peDetails
@@ -23,140 +10,47 @@ module Text.XML.DOM.Parser.Types
23 , ParserData(..)
10 , ParserData(..)
24 , pdElements
11 , pdElements
25 , pdPath
12 , pdPath
13+ -- * Parser type
26 , DomParserT
14 , DomParserT
27 , DomParser
15 , DomParser
28 , runDomParserT
16 , runDomParserT
29 , runDomParser
17 , runDomParser
30 -- * Auxiliary
18 -- * Auxiliary
19+ , DomTraversable(..)
31 , throwParserError
20 , throwParserError
21+ , throwWrongFormat
32 ) where
22 ) where
33
23
34−import Control.Exception
24+import Control.Exception
35−import Control.Lens
25+import Control.Lens
36−import Control.Monad.Except
26+import Control.Monad.Except
37−import Control.Monad.Reader
27+import Control.Monad.Reader
38−import Data.CaseInsensitive as CI
28+import Data.List.NonEmpty (NonEmpty(..))
29+import qualified Data.List.NonEmpty as NE
39−import Data.String
30+import Data.Maybe
40−import Data.Text as T
31+import Data.Text (Text)
41−import GHC.Generics (Generic)
32+import GHC.Generics (Generic)
42−import Text.XML
33+import Text.XML
43−import Text.XML.Lens
34+import Text.XML.Lens
44−
35+
45−-- | Arbitrary element matcher
36+type DomPath = [Text]
46−--
47−-- @since 2.0.0
48−data ElemMatcher = ElemMatcher
49− { _emMatch :: Element -> Bool
50− , _emShow :: Text
51− -- ^ Field for 'Show' instance and bulding usefull errors
52− }
53−
54−makeLenses ''ElemMatcher
55−
56−-- | Instance using instance of 'NameMatcher'
57−instance IsString ElemMatcher where
58− fromString = matchElemName . fromString
59−
60−instance Show ElemMatcher where
61− show = T.unpack . _emShow
62−
63−-- | Match element by name
64−--
65−-- @since 2.0.0
66−matchElemName :: NameMatcher -> ElemMatcher
67−matchElemName (NameMatcher matchName showName) = ElemMatcher
68− { _emMatch = views name matchName
69− , _emShow = showName
70− }
71−
72−-- | Match over elements
73−--
74−-- @since 2.0.0
75−elMatch :: ElemMatcher -> Traversal' Element Element
76−elMatch (ElemMatcher match _) = filtered match
77−
78−-- | Arbitrary name matcher. Match name any way you want, but
79−-- considered to be used as comparator with some name with some rules
80−--
81−-- @since 2.0.0
82−data NameMatcher = NameMatcher
83− { _nmMatch :: Name -> Bool
84− -- ^ Name matching function, usually should be simple comparsion
85− -- function takin in account only local name or other components
86− -- of 'Name'
87− , _nmShow :: Text
88− -- ^ Field for 'Show' instance and bulding usefull errors
89− }
90−
91−-- | Instance use 'matchCILocalName' as most general and liberal
92−-- matching strategy (while XML is often malformed).
93−--
94−-- @since 2.0.0
95−instance IsString NameMatcher where
96− fromString = matchCILocalName . T.pack
97−
98−instance Show NameMatcher where
99− show = T.unpack . _nmShow
100−
101−-- | Makes matcher which matches only local part of name igoring
102−-- namespace and prefix. Local name matching is case sensitive.
103−--
104−-- @since 2.0.0
105−matchLocalName :: Text -> NameMatcher
106−matchLocalName tname = NameMatcher
107− { _nmMatch = \n -> nameLocalName n == tname
108− , _nmShow = tname
109− }
110−
111−-- | Makes matcher which matches only local part of name igoring
112−-- namespace and prefix. Local name matching is case insensitive. This
113−-- is the most common case.
114−--
115−-- @since 2.0.0
116−matchCILocalName :: Text -> NameMatcher
117−matchCILocalName tname = NameMatcher
118− { _nmMatch = \n -> CI.mk (nameLocalName n) == CI.mk tname
119− , _nmShow = tname
120− }
121−
122−makeLenses ''NameMatcher
123−
124−-- | Makes matcher which match name by 'Eq' with given
125−--
126−-- @since 2.0.0
127−matchName :: Name -> NameMatcher
128−matchName n = NameMatcher
129− { _nmMatch = (== n)
130− , _nmShow = nameLocalName n
131− }
132−
133−-- | Path some element should be found at. Path starts from the root
134−-- element of the document. Errors are much more usefull with path.
135−newtype DomPath = DomPath
136− { unDomPath :: [Text]
137− } deriving (Eq, Ord, Show, Semigroup, Monoid)
138
37
139-- | DOM parser error description.
38-- | DOM parser error description.
140data ParserError
39data ParserError
141 -- | Tag not found which should be.
40 -- | Tag not found which should be.
142 = PENotFound
41 = PENotFound
143 { _pePath :: DomPath
42 { _pePath :: DomPath
144− -- ^ Path of element error occured in
145 }
43 }
146
44
147− -- | Expected attribute but not found
45+ -- | Tag contents has wrong format, (could not read text to value)
148− --
46+ | PEWrongFormat
149− -- @since 1.0.0
47+ { _peDetails :: Text
150− | PEAttributeNotFound
151− { _peAttributeName :: NameMatcher
152− , _pePath :: DomPath
48+ , _pePath :: DomPath -- ^ path of element
153 }
49 }
154
50
155 -- | Could not parse attribute
51 -- | Could not parse attribute
156− --
157− -- @since 1.0.0
158 | PEAttributeWrongFormat
52 | PEAttributeWrongFormat
159− { _peAttributeName :: NameMatcher
53+ { _peAttributeName :: Text
160 , _peDetails :: Text
54 , _peDetails :: Text
161 , _pePath :: DomPath
55 , _pePath :: DomPath
162 }
56 }
@@ -166,17 +60,17 @@ data ParserError
166 { _pePath :: DomPath
60 { _pePath :: DomPath
167 }
61 }
168
62
169− -- | Tag contents has wrong format, (could not read text to value)
63+ -- | Expected attribute but not found
170− | PEContentWrongFormat
64+ | PEAttributeNotFound
171− { _peDetails :: Text
65+ { _peAttributeName :: Text
172− , _pePath :: DomPath
66+ , _pePath :: DomPath
173 }
67 }
174
68
175 -- | Some other error
69 -- | Some other error
176 | PEOther
70 | PEOther
177 { _peDetails :: Text
71 { _peDetails :: Text
178 , _pePath :: DomPath
72 , _pePath :: DomPath
179− } deriving (Show, Generic)
73+ } deriving (Eq, Ord, Show, Generic)
180
74
181makeLenses ''ParserError
75makeLenses ''ParserError
182
76
@@ -184,16 +78,15 @@ instance Exception ParserError
184
78
185newtype ParserErrors = ParserErrors
79newtype ParserErrors = ParserErrors
186 { unParserErrors :: [ParserError]
80 { unParserErrors :: [ParserError]
187− } deriving (Show, Semigroup, Monoid, Generic)
81+ } deriving (Ord, Eq, Show, Monoid, Generic)
188
82
189makePrisms ''ParserErrors
83makePrisms ''ParserErrors
190
84
191instance Exception ParserErrors
85instance Exception ParserErrors
192
86
193
87
194−{- | Parser scope.
195−
196−Functor argument is usually @Identity@ or @[]@.
88+{- | Parser scope parser runs in. Functor argument is usually @Identity@ or
89+@[]@.
197
90
198If functor is @Identity@ then parser expects exactly ONE current element. This
91If functor is @Identity@ then parser expects exactly ONE current element. This
199is common behavior for content parsers, or parsers expecting strict XML
92is common behavior for content parsers, or parsers expecting strict XML
@@ -226,11 +119,10 @@ runDomParserT
226 -> DomParserT Identity m a
119 -> DomParserT Identity m a
227 -> m (Either ParserErrors a)
120 -> m (Either ParserErrors a)
228runDomParserT doc par =
121runDomParserT doc par =
229− let
230− pd = ParserData
122+ let pd = ParserData
231− { _pdElements = doc ^. root . to pure
123+ { _pdElements = doc ^. root . to pure
232− , _pdPath = DomPath [doc ^. root . name . to nameLocalName]
124+ , _pdPath = [doc ^. root . localName]
233− }
125+ }
234 in runExceptT $ runReaderT par pd
126 in runExceptT $ runReaderT par pd
235
127
236runDomParser
128runDomParser
@@ -239,10 +131,36 @@ runDomParser
239 -> Either ParserErrors a
131 -> Either ParserErrors a
240runDomParser doc par = runIdentity $ runDomParserT doc par
132runDomParser doc par = runIdentity $ runDomParserT doc par
241
133
134+-- | Class of traversable functors which may be constructed from list. Or may
135+-- not.
136+class Traversable f => DomTraversable f where
137+ -- | If method return Nothing this means we can not build traversable from
138+ -- given list. In this case combinator should fail traversing.
139+ buildDomTraversable :: [a] -> Maybe (f a)
140+
141+instance DomTraversable Identity where
142+ buildDomTraversable = fmap Identity . listToMaybe
143+
144+instance DomTraversable [] where
145+ buildDomTraversable = Just
146+
147+instance DomTraversable Maybe where
148+ buildDomTraversable = Just . listToMaybe
149+
150+instance DomTraversable NonEmpty where
151+ buildDomTraversable = NE.nonEmpty
152+
242throwParserError
153throwParserError
243 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
154 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
244− => (DomPath -> ParserError)
155+ => ([Text] -> ParserError)
245 -> m a
156 -> m a
246throwParserError mkerr = do
157throwParserError mkerr = do
247 path <- view pdPath
158 path <- view pdPath
248− throwError $ ParserErrors $ [mkerr path]
159+ throwError $ ParserErrors [mkerr path]
160+
161+-- | Throw 'PEWrongFormat' as very common case
162+throwWrongFormat
163+ :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
164+ => Text
165+ -> m a
166+throwWrongFormat err = throwParserError $ PEWrongFormat err
src/Text/XML/Soap.hsdeleted−46
@@ -1,46 +0,0 @@
1−module Text.XML.Soap where
2−
3−import Control.Lens
4−import Data.String
5−import Text.XML
6−import Text.XML.DOM.Parser
7−import Text.XML.Writer
8−
9−data XmlEnvelope h b = XmlEnvelope
10− { _xeHeader :: !(Maybe h)
11− , _xeBody :: !(Maybe b)
12− } deriving (Eq, Show)
13−
14−makeLenses ''XmlEnvelope
15−
16−xmlEnvelopeToDocument :: (ToXML h, ToXML b) => XmlEnvelope h b -> Document
17−xmlEnvelopeToDocument xe = doc
18− where
19− sname n = fromString $ "{http://schemas.xmlsoap.org/soap/envelope/}" <> n
20− doc =
21− Document
22− { documentPrologue = Prologue [] Nothing []
23− , documentRoot =
24− Element
25− { elementName = sname "Envelope"
26− , elementAttributes = mempty
27− , elementNodes = [NodeElement header, NodeElement body]
28− }
29− , documentEpilogue = []
30− }
31− header =
32− Element
33− { elementName = sname "Header"
34− , elementAttributes = mempty
35− , elementNodes = render . toXML $ xe ^. xeHeader
36− }
37− body =
38− Element
39− { elementName = sname "Body"
40− , elementAttributes = mempty
41− , elementNodes = render . toXML $ xe ^. xeBody
42− }
43−
44−instance (FromDom h, FromDom b) => FromDom (XmlEnvelope h b) where
45− fromDom = XmlEnvelope <$> inElemMay "Header" fromDom
46− <*> inElemMay "Body" fromDom
stack.yamlmode 120000 → 100644+6−1
@@ -1 +0,0 @@
1−ghc-963.yaml
@@ -0,0 +1,6 @@
1+packages:
2+ - .
3+extra-deps:
4+ - open-union-0.2.0.0
5+ - type-fun-0.1.1
6+resolver: lts-6.25
test/Main.hs+6−6
@@ -33,7 +33,7 @@ testStructureAttributes = do
33 int <- parseAttribute "int" readContent
33 int <- parseAttribute "int" readContent
34 bool <- parseAttribute "bool" readBool
34 bool <- parseAttribute "bool" readBool
35 return $ TestStructure
35 return $ TestStructure
36− { tsName = nameLocalName name
36+ { tsName = name
37 , tsInts = [int]
37 , tsInts = [int]
38 , tsBools = pure bool }
38 , tsBools = pure bool }
39
39
@@ -193,7 +193,7 @@ specParserFailedPath
193 :: (Show a)
193 :: (Show a)
194 => String -- ^ Name of spec
194 => String -- ^ Name of spec
195 -> Document
195 -> Document
196− -> DomPath -- ^ Expteced path in error
196+ -> [Text] -- ^ Expteced path in error
197 -> DomParser Identity a
197 -> DomParser Identity a
198 -> Spec
198 -> Spec
199specParserFailedPath name doc path parser = it name $ example $ do
199specParserFailedPath name doc path parser = it name $ example $ do
@@ -226,7 +226,7 @@ combinationsSpec = do
226 describe "deep" $ do
226 describe "deep" $ do
227 let parser = inElem "a" $ inElem "b" textFromDom
227 let parser = inElem "a" $ inElem "b" textFromDom
228 specParserFailedPath "docDeepMultiple2" docDeepMultiple2
228 specParserFailedPath "docDeepMultiple2" docDeepMultiple2
229− (DomPath ["root", "a", "b"]) parser
229+ ["root", "a", "b"] parser
230 -- should fail here because first tag "a" does not contains
230 -- should fail here because first tag "a" does not contains
231 -- tag "b" which is expected by parser @inElem "b"@
231 -- tag "b" which is expected by parser @inElem "b"@
232
232
@@ -276,7 +276,7 @@ combinationsSpec = do
276 specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser
276 specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser
277 specParserEq "docDeepMultiple2" docDeepMultiple2 "content1" parser
277 specParserEq "docDeepMultiple2" docDeepMultiple2 "content1" parser
278 describe "fails" $ do
278 describe "fails" $ do
279− specParserFailedPath "docSimple" docSimple (DomPath ["root", "a", "b"]) parser
279+ specParserFailedPath "docSimple" docSimple ["root", "a", "b"] parser
280 describe "multiple elements" $ do
280 describe "multiple elements" $ do
281 let
281 let
282 parser = diveElem "a" $ inElemAll "b" textFromDom
282 parser = diveElem "a" $ inElemAll "b" textFromDom
@@ -311,9 +311,9 @@ combinationsSpec = do
311 inElem "a" $ do
311 inElem "a" $ do
312 checkCurrentName "a"
312 checkCurrentName "a"
313 describe "fails" $ do
313 describe "fails" $ do
314− specParserFailedPath "root element" docSimple (DomPath ["toor"]) $ do
314+ specParserFailedPath "root element" docSimple ["toor"] $ do
315 checkCurrentName "toor"
315 checkCurrentName "toor"
316− specParserFailedPath "inner element" docSimple (DomPath ["root", "b"]) $ do
316+ specParserFailedPath "inner element" docSimple ["root", "b"] $ do
317 inElem "a" $ checkCurrentName "b"
317 inElem "a" $ checkCurrentName "b"
318
318
319contentSpec :: Spec
319contentSpec :: Spec