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