git.iko.soy/typeable/dom-parser
on master help sign in
swap
82e2fef51 ahead, 0 behind
.travis.ymlnew file+32
since splitsnapshots
unifiedsplit
@@ -0,0 +1,32 @@
1+# Use new container infrastructure to enable caching
2+sudo: false
3+
4+# Do not choose a language; we provide our own build tools.
5+language: generic
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.
14+cache:
15+ directories:
16+ - $HOME/.stack
17+
18+# Ensure necessary system libraries are present
19+addons:
20+ apt:
21+ packages:
22+ - libgmp-dev
23+
24+before_install:
25+# Download and unpack the stack executable
26+- mkdir -p ~/.local/bin
27+- 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'
29+
30+script:
31+# Build the package, its tests, and its docs and run the tests
32+- stack --no-terminal --install-ghc test --haddock --no-haddock-deps
CHANGELOG.md+50
@@ -1,4 +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+
45+## 1.0.0
46+
47+* Added support for parsing attributes
48+* Changed public interface for 'parseContent'
49+* Added useful functions
50+* Dropped unnecessary dependency from shakespeare
51+
3## 0.1.0
52## 0.1.0
53+
4* 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+23−9
@@ -1,5 +1,5 @@
1name: dom-parser
1name: dom-parser
2−version: 0.1.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,8 +7,17 @@ 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
11+homepage: 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+
18+source-repository head
19+ type: git
20+ location: git@github.com:typeable/dom-parser.git
12
21
13library
22library
14 hs-source-dirs: src
23 hs-source-dirs: src
@@ -35,21 +44,26 @@ library
35 , TypeFamilies
44 , TypeFamilies
36 , TypeOperators
45 , TypeOperators
37 , UndecidableInstances
46 , UndecidableInstances
38− build-depends: base >= 4.7 && < 5
47+ build-depends: base >= 4.11 && < 5
48+ , case-insensitive
49+ , containers
39 , lens
50 , lens
40− , mtl
51+ , mtl < 2.3 || > 2.3
41− , open-union
52+ , scientific
42− , semigroups
43− , shakespeare
44 , text
53 , text
45 , transformers
54 , transformers
46− , type-fun
47 , xml-conduit
55 , xml-conduit
56+ , xml-conduit-writer
48 , xml-lens
57 , xml-lens
49 exposed-modules: Text.XML.DOM.Parser
58 exposed-modules: Text.XML.DOM.Parser
50− , Text.XML.DOM.Parser.Class
59+ , Text.XML.DOM.Parser.Attributes
60+ , Text.XML.DOM.Parser.Buildable
51 , Text.XML.DOM.Parser.Combinators
61 , Text.XML.DOM.Parser.Combinators
62+ , Text.XML.DOM.Parser.Content
63+ , Text.XML.DOM.Parser.FromAttribute
64+ , Text.XML.DOM.Parser.FromDom
52 , Text.XML.DOM.Parser.Types
65 , Text.XML.DOM.Parser.Types
66+ , Text.XML.Soap
53
67
54test-suite test
68test-suite test
55 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+10−2
@@ -1,9 +1,17 @@
1module Text.XML.DOM.Parser
1module Text.XML.DOM.Parser
2− ( module Text.XML.DOM.Parser.Class
2+ ( module Text.XML.DOM.Parser.Attributes
3+ , module Text.XML.DOM.Parser.Buildable
3 , module Text.XML.DOM.Parser.Combinators
4 , 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
4 , module Text.XML.DOM.Parser.Types
8 , module Text.XML.DOM.Parser.Types
5 ) where
9 ) where
6
10
7−import Text.XML.DOM.Parser.Class
11+import Text.XML.DOM.Parser.Attributes
12+import Text.XML.DOM.Parser.Buildable
8import Text.XML.DOM.Parser.Combinators
13import 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
9import 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+61−98
@@ -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,105 +15,106 @@ module Text.XML.DOM.Parser.Combinators
15 , ignoreElem
15 , ignoreElem
16 , ignoreEmpty
16 , ignoreEmpty
17 , ignoreBlank
17 , ignoreBlank
18− -- * Checking current element properties
19− , checkCurrentName
20− -- * Parsing arbitrary content
21− , parseContent
22− , readContent
23 ) where
18 ) where
24
19
25−import Control.Lens
20+import Control.Lens
26−import Control.Monad.Except
27−import Control.Monad.Reader
21+import Control.Monad.Reader
28−import Data.List.NonEmpty (NonEmpty(..))
22+import Data.Foldable as F
29−import Data.Monoid
23+import Data.List as L
30−import Data.Text (Text)
24+import Data.List.NonEmpty (NonEmpty(..))
31−import qualified Data.Text as T
25+import Data.Text as T
32−import Data.Traversable
26+import Data.Traversable
33−import Data.Typeable
27+import Text.XML
34−import Text.Read
28+import Text.XML.DOM.Parser.Buildable
35−import Text.Shakespeare.Text (st)
36−import Text.XML
37−import Text.XML.DOM.Parser.Types
29+import Text.XML.DOM.Parser.Types
38−import Text.XML.Lens
30+import Text.XML.Lens
39−
31+
40−
32+
41−-- | Generic function to traverse arbitrary inner cursors.
33+-- | Generic function to traverse arbitrary inner elements.
42traverseElems
34traverseElems
43 :: (Monad m, Foldable g, Traversable f)
35 :: (Monad m, Foldable g, Traversable f)
44− => ([Element] -> DomParserT g m (f ([Text], Element)))
36+ => ([Element] -> DomParserT g m (f (DomPath, Element)))
37+ -- ^ Takes list of current elements and returns container with
45− -- ^ Takes set of current elements and
38+ -- pairs of subpath (relatively to current elements) and element
39+ -- to run parser in
46 -> DomParserT Identity m a
40 -> DomParserT Identity m a
47− -- ^ Parser will be runned for each element found in traversable
41+ -- ^ Parser to run for each element found in traversable 'f'
48 -> DomParserT g m (f a)
42 -> DomParserT g m (f a)
49traverseElems trav parser = do
43traverseElems trav parser = do
50 pd <- ask
44 pd <- ask
51 inner <- trav $ pd ^.. pdElements . folded
45 inner <- trav $ pd ^.. pdElements . folded
52 for inner $ \(subpath, e) -> do
46 for inner $ \(subpath, e) -> do
47+ let
53− let newpd = ParserData
48+ newpd = ParserData
54− { _pdElements = Identity e
49+ { _pdElements = Identity e
55− , _pdPath = pd ^. pdPath <> subpath }
50+ , _pdPath = pd ^. pdPath <> subpath }
56− magnify (to $ const newpd) parser
51+ lift $ runReaderT parser newpd
57
52
58−-- | Takes function filtering
53+-- | Traverses elements located in same path using filtering function
59inFilteredTrav
54inFilteredTrav
60− :: (Monad m, Foldable g, DomTraversable f)
55+ :: (Monad m, Foldable g, Buildable f)
61− => ([Element] -> ([Text], [Element]))
56+ => ([Element] -> (DomPath, [Element]))
62− -- ^ Function returning some filtered elements with path suffixes which will
57+ -- ^ Takes list of current elements and returns some descendants
63− -- 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
64 -> DomParserT Identity m a
60 -> DomParserT Identity m a
65 -> DomParserT g m (f a)
61 -> DomParserT g m (f a)
66inFilteredTrav deeper = traverseElems trav
62inFilteredTrav deeper = traverseElems trav
67 where
63 where
68 trav e = do
64 trav e = do
69 let (path, elems) = deeper e
65 let (path, elems) = deeper e
70− case buildDomTraversable elems of
66+ case build elems of
71 Nothing -> throwParserError $ PENotFound . (<> path)
67 Nothing -> throwParserError $ PENotFound . (<> path)
72 Just tr -> return $ fmap (path,) tr
68 Just tr -> return $ fmap (path,) tr
73
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.
74inElemTrav
74inElemTrav
75− :: (Monad m, Foldable g, DomTraversable f)
75+ :: (Monad m, Foldable g, Buildable f)
76− => Text
76+ => ElemMatcher -- ^ Tag(s) matcher to traverse in
77 -> DomParserT Identity m a
77 -> DomParserT Identity m a
78 -> DomParserT g m (f a)
78 -> DomParserT g m (f a)
79inElemTrav n = inFilteredTrav deeper
79inElemTrav n = inFilteredTrav deeper
80 where
80 where
81− deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)
81+ elemsFold = folded . nodes . folded . _Element . elMatch n
82+ deeper = (DomPath [_emShow n],) . toListOf elemsFold
82
83
83−-- | Runs parser inside first children element with given name
84+-- | Runs parser inside first children element matched by macher
84inElem
85inElem
85 :: (Monad m, Foldable g)
86 :: (Monad m, Foldable g)
86− => Text
87+ => ElemMatcher
87 -> DomParserT Identity m a
88 -> DomParserT Identity m a
88 -> DomParserT g m a
89 -> DomParserT g m a
89inElem n = fmap runIdentity . inElemTrav n
90inElem n = fmap runIdentity . inElemTrav n
90
91
91inElemAll
92inElemAll
92 :: (Monad m, Foldable g)
93 :: (Monad m, Foldable g)
93− => Text
94+ => ElemMatcher
94 -> DomParserT Identity m a
95 -> DomParserT Identity m a
95 -> DomParserT g m [a]
96 -> DomParserT g m [a]
96inElemAll = inElemTrav
97inElemAll = inElemTrav
97
98
98inElemMay
99inElemMay
99 :: (Monad m, Foldable g)
100 :: (Monad m, Foldable g)
100− => Text
101+ => ElemMatcher
101 -> DomParserT Identity m a
102 -> DomParserT Identity m a
102 -> DomParserT g m (Maybe a)
103 -> DomParserT g m (Maybe a)
103inElemMay = inElemTrav
104inElemMay = inElemTrav
104
105
105inElemNe
106inElemNe
106 :: (Monad m, Foldable g)
107 :: (Monad m, Foldable g)
107− => Text
108+ => ElemMatcher
108 -> DomParserT Identity m a
109 -> DomParserT Identity m a
109 -> DomParserT g m (NonEmpty a)
110 -> DomParserT g m (NonEmpty a)
110inElemNe = inElemTrav
111inElemNe = inElemTrav
111
112
112{- | 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
113−["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
114will 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
115behaviour 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
116−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
117elements. Consider this code
118elements. Consider this code
118
119
119@
120@
@@ -131,26 +132,31 @@ which translates like: @a > b > c > fromDom@
131As 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
132single element, unlike 'divePath' which runs inner parser @in all@ descendants
133single element, unlike 'divePath' which runs inner parser @in all@ descendants
133in 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.
134-}
140-}
135
141
136divePath
142divePath
137 :: forall m g a
143 :: forall m g a
138 . (Monad m, Foldable g)
144 . (Monad m, Foldable g)
139− => [Text]
145+ => [ElemMatcher]
140 -> DomParserT [] m a
146 -> DomParserT [] m a
141 -> DomParserT g m a
147 -> DomParserT g m a
142divePath path = magnify $ to modElems
148divePath path = magnify $ to modElems
143 where
149 where
144 modElems
150 modElems
145 = over pdElements (toListOf $ folded . diver)
151 = over pdElements (toListOf $ folded . diver)
146− . over pdPath (<> path)
152+ . over pdPath (<> DomPath (L.map _emShow path))
147 diver :: Fold Element Element
153 diver :: Fold Element Element
148− diver = foldr (.) id $ map toDive path
154+ diver = F.foldr (.) id $ L.map toDive path
149− toDive n = nodes . folded . _Element . ell n
155+ toDive n = nodes . folded . _Element . elMatch n
150
156
151diveElem
157diveElem
152 :: (Monad m, Foldable g)
158 :: (Monad m, Foldable g)
153− => Text
159+ => ElemMatcher
154 -> DomParserT [] m a
160 -> DomParserT [] m a
155 -> DomParserT g m a
161 -> DomParserT g m a
156diveElem p = divePath [p]
162diveElem p = divePath [p]
@@ -160,7 +166,7 @@ ignoreElem
160 :: (Monad m)
166 :: (Monad m)
161 => (Element -> Bool)
167 => (Element -> Bool)
162 -- ^ Predicate checking that we must ignore some current tag. If returns
168 -- ^ Predicate checking that we must ignore some current tag. If returns
163− -- true then parser will not be runned and combinator just returns Nothing.
169+ -- 'True' then parser will not be runned and combinator just returns Nothing.
164 -> DomParserT Identity m a
170 -> DomParserT Identity m a
165 -> DomParserT Identity m (Maybe a)
171 -> DomParserT Identity m (Maybe a)
166ignoreElem test parser = do
172ignoreElem test parser = do
@@ -168,7 +174,7 @@ ignoreElem test parser = do
168 if ign then pure Nothing else Just <$> parser
174 if ign then pure Nothing else Just <$> parser
169
175
170-- | If current element has no children nodes does not run parser and returns
176-- | If current element has no children nodes does not run parser and returns
171−-- Nothing. Otherwise runs parser inside current element. Usefull when you got
177+-- Nothing. Otherwise runs parser inside current element. Useful when you got
172-- XML with strange empty elements which must be just ignored, but `inElem` runs
178-- XML with strange empty elements which must be just ignored, but `inElem` runs
173-- parser inside of this elements which causes to parser error.
179-- parser inside of this elements which causes to parser error.
174ignoreEmpty
180ignoreEmpty
@@ -177,7 +183,7 @@ ignoreEmpty
177 -> DomParserT Identity m (Maybe a)
183 -> DomParserT Identity m (Maybe a)
178ignoreEmpty = ignoreElem test
184ignoreEmpty = ignoreElem test
179 where
185 where
180− test e = null $ e ^. nodes
186+ test e = L.null $ e ^. nodes
181
187
182-- | If all current elements contains blank content, or contains nothing at all
188-- | If all current elements contains blank content, or contains nothing at all
183-- , then returns Nothing, else runs parser.
189-- , then returns Nothing, else runs parser.
@@ -191,49 +197,6 @@ ignoreBlank = ignoreElem test
191 let
197 let
192 elems = e ^.. nodes . folded . _Element
198 elems = e ^.. nodes . folded . _Element
193 cont = mconcat $ e ^.. nodes . folded . _Content
199 cont = mconcat $ e ^.. nodes . folded . _Content
194− in if | not $ null elems -> False
200+ in if | not $ L.null elems -> False
195 | T.null $ T.strip cont -> True
201 | T.null $ T.strip cont -> True
196 | otherwise -> False
202 | otherwise -> False
197−
198−-- | If name of current tag differs from first argument throws 'PENotFound' with
199−-- tag name replaced in last path's segment. Usefull for checking root
200−-- document's element name.
201−checkCurrentName
202− :: (Monad m)
203− => Text
204− -> DomParserT Identity m ()
205−checkCurrentName n = do
206− cn <- view $ pdElements . to runIdentity . localName
207− unless (cn == n) $ do
208− p <- view pdPath
209− let pinit = if null p then [] else init p
210− throwError $ ParserErrors [PENotFound $ pinit ++ [n]]
211− return ()
212−
213−-- | Parses content inside current tag. It expects current element set consists
214−-- of exactly ONE element. Throws error if current elements set contains
215−-- multiple of them.
216−parseContent
217− :: (Monad m)
218− => (Text -> DomParserT Identity m a)
219− -> DomParserT Identity m a
220−parseContent parse = do
221− e <- view $ pdElements . to runIdentity
222− let
223− nds = e ^. nodes
224− els = nds ^.. folded . _Element
225− conts = nds ^.. folded . _Content
226− when (not $ null els) $ throwParserError PEContentNotFound
227− when (null conts) $ throwParserError PEContentNotFound
228− parse $ mconcat conts
229−
230−readContent
231− :: forall m g a
232− . (Read a, Typeable a, Monad m)
233− => Text
234− -> DomParserT g m a
235−readContent t = case readMaybe $ T.unpack t of
236− Nothing -> throwParserError $ PEWrongFormat [st|Not readable #{n}: #{t}|]
237− Just a -> pure a
238− where
239− n = show $ typeRep (Proxy :: Proxy a)
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.hsnew file+112
@@ -0,0 +1,112 @@
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/Class.hs → src/Text/XML/DOM/Parser/FromDom.hsrenamed+56−80
@@ -1,10 +1,9 @@
1−module Text.XML.DOM.Parser.Class
1+module Text.XML.DOM.Parser.FromDom
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
8 , textFromDom
7 , textFromDom
9 , stringFromDom
8 , stringFromDom
10 , charFromDom
9 , charFromDom
@@ -15,21 +14,19 @@ module Text.XML.DOM.Parser.Class
15 , boolFromDom
14 , boolFromDom
16 , unitFromDom
15 , unitFromDom
17 , voidFromDom
16 , voidFromDom
17+ , scientificFromDom
18 ) where
18 ) where
19
19
20−import Control.Applicative
20+import Control.Applicative
21−import Control.Lens
21+import Control.Lens
22−import Data.Fixed
22+import Data.Fixed
23−import Data.OpenUnion
23+import Data.Scientific
24−import Data.Text (Text)
25−import qualified Data.Text as T
24+import Data.Text as T hiding (empty)
26−import Data.Typeable
25+import Data.Typeable
27−import Data.Void
26+import Data.Void
28−import Text.Shakespeare.Text (st)
29−import Text.XML
27+import Text.XML
30−import Text.XML.DOM.Parser.Combinators
28+import Text.XML.DOM.Parser.Content
31−import Text.XML.DOM.Parser.Types
29+import Text.XML.DOM.Parser.Types
32−import TypeFun.Data.List hiding (Union)
33
30
34proxyFromDom
31proxyFromDom
35 :: forall proxy m a
32 :: forall proxy m a
@@ -38,107 +35,86 @@ proxyFromDom
38 -> DomParserT Identity m a
35 -> DomParserT Identity m a
39proxyFromDom _ = fromDom
36proxyFromDom _ = fromDom
40
37
41−-- | 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'
42class FromDom a where
40class FromDom a where
43 fromDom :: (Monad m) => DomParserT Identity m a
41 fromDom :: (Monad m) => DomParserT Identity m a
44
42
45instance FromDom () where
43instance FromDom () where
46 fromDom = unitFromDom
44 fromDom = unitFromDom
47
45
46+-- | Always successfully parses any DOM to @()@
47+unitFromDom :: (Monad m) => DomParserT Identity m ()
48+unitFromDom = pure ()
49+
48instance FromDom Void where
50instance FromDom Void where
49 fromDom = voidFromDom
51 fromDom = voidFromDom
50
52
53+-- | Never parses successfully. It is just 'empty'
54+voidFromDom :: (Monad m) => DomParserT Identity m Void
55+voidFromDom = empty
56+
51instance FromDom Text where
57instance FromDom Text where
52 fromDom = textFromDom
58 fromDom = textFromDom
53
59
60+textFromDom :: (Monad m) => DomParserT Identity m Text
61+textFromDom = parseContent Right
62+
54instance FromDom String where
63instance FromDom String where
55 fromDom = stringFromDom
64 fromDom = stringFromDom
56
65
66+stringFromDom :: (Monad m) => DomParserT Identity m String
67+stringFromDom = parseContent $ Right . T.unpack
68+
57instance FromDom Char where
69instance FromDom Char where
58 fromDom = charFromDom
70 fromDom = charFromDom
59
71
72+charFromDom :: (Monad m) => DomParserT Identity m Char
73+charFromDom = parseContent readChar
74+
60instance FromDom Int where
75instance FromDom Int where
61 fromDom = intFromDom
76 fromDom = intFromDom
62
77
78+intFromDom :: (Monad m) => DomParserT Identity m Int
79+intFromDom = parseContent readContent
80+
63instance FromDom Integer where
81instance FromDom Integer where
64 fromDom = integerFromDom
82 fromDom = integerFromDom
65
83
84+integerFromDom :: (Monad m) => DomParserT Identity m Integer
85+integerFromDom = parseContent readContent
86+
66instance FromDom Double where
87instance FromDom Double where
67 fromDom = doubleFromDom
88 fromDom = doubleFromDom
68
89
90+doubleFromDom :: (Monad m) => DomParserT Identity m Double
91+doubleFromDom = parseContent readContent
92+
69instance (HasResolution a, Typeable a) => FromDom (Fixed a) where
93instance (HasResolution a, Typeable a) => FromDom (Fixed a) where
70 fromDom = fixedFromDom
94 fromDom = fixedFromDom
71
95
96+fixedFromDom
97+ :: (Monad m, Typeable a, HasResolution a)
98+ => DomParserT Identity m (Fixed a)
99+fixedFromDom = parseContent readContent
100+
101+instance FromDom Scientific where
102+ fromDom = scientificFromDom
103+
104+scientificFromDom :: Monad m => DomParserT Identity m Scientific
105+scientificFromDom = parseContent readContent
106+
72instance FromDom Bool where
107instance FromDom Bool where
73 fromDom = boolFromDom
108 fromDom = boolFromDom
74
109
75−instance FromDom (Union '[]) where
110+-- | Expects content to be y, yes, t, true or 1 for True Values n, no,
76− fromDom = empty
111+-- f, false or 0 for False. Case is not significant, blank characters
77−
112+-- are striped.
78−instance ( Typeable a, FromDom a, FromDom (Union as)
113+boolFromDom :: (Monad m) => DomParserT Identity m Bool
79− , SubList as (a ': as) )
114+boolFromDom = parseContent readBool
80− => FromDom (Union (a ': as)) where
81− -- fromDom :: forall m. (DomParserMonad m) => m a
82− fromDom = (liftUnion <$> (proxyFromDom (Proxy :: Proxy a)))
83− <|> (reUnion <$> (proxyFromDom (Proxy :: Proxy (Union as))))
84
115
85instance FromDom Element where
116instance FromDom Element where
86 fromDom = elementFromDom
117 fromDom = elementFromDom
87
118
88elementFromDom :: (Monad m) => DomParserT Identity m Element
119elementFromDom :: (Monad m) => DomParserT Identity m Element
89elementFromDom = view $ pdElements . to runIdentity
120elementFromDom = view $ pdElements . to runIdentity
90−
91−unionFromDom
92− :: (Monad m, FromDom (Union as))
93− => proxy as
94− -> DomParserT Identity m (Union as)
95−unionFromDom _ = fromDom
96−
97−textFromDom :: (Monad m) => DomParserT Identity m Text
98−textFromDom = parseContent pure
99−
100−stringFromDom :: (Monad m) => DomParserT Identity m String
101−stringFromDom = parseContent $ pure . T.unpack
102−
103−charFromDom :: (Monad m) => DomParserT Identity m Char
104−charFromDom = parseContent $ \t -> case T.unpack $ T.strip t of
105− [c] -> pure c
106− _ -> throwParserError $ PEWrongFormat
107− "Should have exactly one non-blank character"
108−
109−intFromDom :: (Monad m) => DomParserT Identity m Int
110−intFromDom = parseContent readContent
111−
112−integerFromDom :: (Monad m) => DomParserT Identity m Integer
113−integerFromDom = parseContent readContent
114−
115−doubleFromDom :: (Monad m) => DomParserT Identity m Double
116−doubleFromDom = parseContent readContent
117−
118−fixedFromDom
119− :: (Monad m, Typeable a, HasResolution a)
120− => DomParserT Identity m (Fixed a)
121−fixedFromDom = parseContent readContent
122−
123−-- | Expects content to be y, yes, t, true or 1 for True value. n, no,
124−-- f, false or 0 for False value. Case is not significant, blank
125−-- characters are striped.
126−boolFromDom :: (Monad m) => DomParserT Identity m Bool
127−boolFromDom = parseContent $ \t ->
128− let
129− lowt = T.toLower $ T.strip t
130− tvals = ["y", "yes", "t", "true", "1"]
131− fvals = ["n", "no", "f", "false", "0"]
132− in if | lowt `elem` tvals -> return True
133− | lowt `elem` fvals -> return False
134− | otherwise ->
135− let msg = [st|Could not read "#{t}" as Bool|]
136− in throwParserError $ PEWrongFormat msg
137−
138−-- | Always successfully parses any DOM to @()@
139−unitFromDom :: (Monad m) => DomParserT Identity m ()
140−unitFromDom = pure ()
141−
142−-- | Never parses successfully. It is just 'mzero'
143−voidFromDom :: (Monad m) => DomParserT Identity m Void
144−voidFromDom = empty
src/Text/XML/DOM/Parser/Types.hs+159−60
@@ -1,59 +1,182 @@
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
2− ( -- * Parser internals
15+ -- * Parser internals
16+ , DomPath(..)
3− ParserError(..)
17+ , ParserError(..)
4 , pePath
18 , pePath
5 , peDetails
19 , peDetails
20+ , peAttributeName
6 , ParserErrors(..)
21 , ParserErrors(..)
7 , _ParserErrors
22 , _ParserErrors
8 , ParserData(..)
23 , ParserData(..)
9 , pdElements
24 , pdElements
10 , pdPath
25 , pdPath
11− -- * Parser type
12 , DomParserT
26 , DomParserT
13 , DomParser
27 , DomParser
14 , runDomParserT
28 , runDomParserT
15 , runDomParser
29 , runDomParser
16 -- * Auxiliary
30 -- * Auxiliary
17− , DomTraversable(..)
18 , throwParserError
31 , throwParserError
19− , throwWrongFormat
20 ) where
32 ) where
21
33
22−import Control.Exception
34+import Control.Exception
23−import Control.Lens
35+import Control.Lens
24−import Control.Monad.Except
36+import Control.Monad.Except
25−import Control.Monad.Reader
37+import Control.Monad.Reader
26−import Data.List.NonEmpty (NonEmpty(..))
38+import Data.CaseInsensitive as CI
27−import qualified Data.List.NonEmpty as NE
28−import Data.Maybe
39+import Data.String
29−import Data.Text (Text)
40+import Data.Text as T
30−import GHC.Generics (Generic)
41+import GHC.Generics (Generic)
31−import Text.XML
42+import Text.XML
32−import Text.XML.Lens
43+import Text.XML.Lens
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+
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)
33
138
34-- | DOM parser error description.
139-- | DOM parser error description.
35data ParserError
140data ParserError
36 -- | Tag not found which should be.
141 -- | Tag not found which should be.
37 = PENotFound
142 = PENotFound
38− { _pePath :: [Text]
143+ { _pePath :: DomPath
144+ -- ^ Path of element error occured in
39 }
145 }
40
146
41− -- | Tag contents has wrong format, (could not read text to value)
147+ -- | Expected attribute but not found
42− | PEWrongFormat
148+ --
149+ -- @since 1.0.0
150+ | PEAttributeNotFound
151+ { _peAttributeName :: NameMatcher
152+ , _pePath :: DomPath
153+ }
154+
155+ -- | Could not parse attribute
156+ --
157+ -- @since 1.0.0
158+ | PEAttributeWrongFormat
159+ { _peAttributeName :: NameMatcher
43− { _peDetails :: Text
160+ , _peDetails :: Text
44− , _pePath :: [Text] -- ^ path of element
161+ , _pePath :: DomPath
45 }
162 }
46
163
47 -- | Node should have text content, but it does not.
164 -- | Node should have text content, but it does not.
48 | PEContentNotFound
165 | PEContentNotFound
49− { _pePath :: [Text]
166+ { _pePath :: DomPath
167+ }
168+
169+ -- | Tag contents has wrong format, (could not read text to value)
170+ | PEContentWrongFormat
171+ { _peDetails :: Text
172+ , _pePath :: DomPath
50 }
173 }
51
174
52 -- | Some other error
175 -- | Some other error
53 | PEOther
176 | PEOther
54 { _peDetails :: Text
177 { _peDetails :: Text
55− , _pePath :: [Text]
178+ , _pePath :: DomPath
56− } deriving (Eq, Ord, Show, Generic)
179+ } deriving (Show, Generic)
57
180
58makeLenses ''ParserError
181makeLenses ''ParserError
59
182
@@ -61,15 +184,16 @@ instance Exception ParserError
61
184
62newtype ParserErrors = ParserErrors
185newtype ParserErrors = ParserErrors
63 { unParserErrors :: [ParserError]
186 { unParserErrors :: [ParserError]
64− } deriving (Ord, Eq, Show, Monoid, Generic)
187+ } deriving (Show, Semigroup, Monoid, Generic)
65
188
66makePrisms ''ParserErrors
189makePrisms ''ParserErrors
67
190
68instance Exception ParserErrors
191instance Exception ParserErrors
69
192
70
193
194+{- | Parser scope.
195+
71−{- | Parser scope parser runs in. Functor argument is usually @Identity@ or
196+Functor argument is usually @Identity@ or @[]@.
72−@[]@.
73
197
74If functor is @Identity@ then parser expects exactly ONE current element. This
198If functor is @Identity@ then parser expects exactly ONE current element. This
75is common behavior for content parsers, or parsers expecting strict XML
199is common behavior for content parsers, or parsers expecting strict XML
@@ -86,7 +210,7 @@ data ParserData f = ParserData
86 { _pdElements :: f Element
210 { _pdElements :: f Element
87 -- ^ Current element(s). Functor is intended to be either @Identity@ or
211 -- ^ Current element(s). Functor is intended to be either @Identity@ or
88 -- @[]@
212 -- @[]@
89− , _pdPath :: [Text]
213+ , _pdPath :: DomPath
90 -- ^ Path for error reporting
214 -- ^ Path for error reporting
91 }
215 }
92
216
@@ -102,10 +226,11 @@ runDomParserT
102 -> DomParserT Identity m a
226 -> DomParserT Identity m a
103 -> m (Either ParserErrors a)
227 -> m (Either ParserErrors a)
104runDomParserT doc par =
228runDomParserT doc par =
229+ let
105− let pd = ParserData
230+ pd = ParserData
106− { _pdElements = doc ^. root . to pure
231+ { _pdElements = doc ^. root . to pure
107− , _pdPath = [doc ^. root . localName]
232+ , _pdPath = DomPath [doc ^. root . name . to nameLocalName]
108− }
233+ }
109 in runExceptT $ runReaderT par pd
234 in runExceptT $ runReaderT par pd
110
235
111runDomParser
236runDomParser
@@ -114,36 +239,10 @@ runDomParser
114 -> Either ParserErrors a
239 -> Either ParserErrors a
115runDomParser doc par = runIdentity $ runDomParserT doc par
240runDomParser doc par = runIdentity $ runDomParserT doc par
116
241
117−-- | Class of traversable functors which may be constructed from list. Or may
118−-- not.
119−class Traversable f => DomTraversable f where
120− -- | If method return Nothing this means we can not build traversable from
121− -- given list. In this case combinator should fail traversing.
122− buildDomTraversable :: [a] -> Maybe (f a)
123−
124−instance DomTraversable Identity where
125− buildDomTraversable = fmap Identity . listToMaybe
126−
127−instance DomTraversable [] where
128− buildDomTraversable = Just
129−
130−instance DomTraversable Maybe where
131− buildDomTraversable = Just . listToMaybe
132−
133−instance DomTraversable NonEmpty where
134− buildDomTraversable = NE.nonEmpty
135−
136throwParserError
242throwParserError
137 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
243 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
138− => ([Text] -> ParserError)
244+ => (DomPath -> ParserError)
139 -> m a
245 -> m a
140throwParserError mkerr = do
246throwParserError mkerr = do
141 path <- view pdPath
247 path <- view pdPath
142− throwError $ ParserErrors [mkerr path]
248+ throwError $ ParserErrors $ [mkerr path]
143−
144−-- | Throw 'PEWrongFormat' as very common case
145−throwWrongFormat
146− :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
147− => Text
148− -> m a
149−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-5.18
@@ -0,0 +1 @@
1+ghc-963.yaml
test/Main.hs+96−29
@@ -27,8 +27,15 @@ testStructureFromDom = do
27 tsBools <- inElemNe "bool" boolFromDom
27 tsBools <- inElemNe "bool" boolFromDom
28 return TestStructure{..}
28 return TestStructure{..}
29
29
30+testStructureAttributes :: (Monad m) => DomParserT Identity m TestStructure
31+testStructureAttributes = do
32+ name <- getCurrentName
33+ int <- parseAttribute "int" readContent
34+ bool <- parseAttribute "bool" readBool
30−instance FromDom TestStructure where
35+ return $ TestStructure
31− fromDom = testStructureFromDom
36+ { tsName = nameLocalName name
37+ , tsInts = [int]
38+ , tsBools = pure bool }
32
39
33docStruct :: Document
40docStruct :: Document
34docStruct = parseText_ def [lt|
41docStruct = parseText_ def [lt|
@@ -41,6 +48,13 @@ docStruct = parseText_ def [lt|
41</root>
48</root>
42|]
49|]
43
50
51+docAttrStruct :: Document
52+docAttrStruct = parseText_ def [lt|
53+<?xml version="1.0" encoding="utf-8"?>
54+<structure int="10" bool="t">
55+</structure>
56+|]
57+
44docNone :: Document
58docNone :: Document
45docNone = parseText_ def [lt|
59docNone = parseText_ def [lt|
46<?xml version="1.0" encoding="utf-8"?>
60<?xml version="1.0" encoding="utf-8"?>
@@ -48,8 +62,26 @@ docNone = parseText_ def [lt|
48</root>
62</root>
49|]
63|]
50
64
65+docSimpleAttr :: Document
66+docSimpleAttr = parseText_ def [lt|
67+<?xml version="1.0" encoding="utf-8"?>
68+<root>
69+<a attr="content"/>
70+</root>
71+|]
72+
73+docMultipleAttr :: Document
74+docMultipleAttr = parseText_ def [lt|
75+<?xml version="1.0" encoding="utf-8"?>
76+<root>
77+<a attr="content1"/>
78+<a attr="content2"/>
79+<a attr="content3"/>
80+</root>
81+|]
82+
51−docEmpty :: Document
83+docSingleEmpty :: Document
52−docEmpty = parseText_ def [lt|
84+docSingleEmpty = parseText_ def [lt|
53<?xml version="1.0" encoding="utf-8"?>
85<?xml version="1.0" encoding="utf-8"?>
54<root>
86<root>
55 <a/>
87 <a/>
@@ -124,7 +156,7 @@ specParser
124 :: String -- ^ Name of spec
156 :: String -- ^ Name of spec
125 -> Document -- ^ Document to parse
157 -> Document -- ^ Document to parse
126 -> (a -> Maybe String) -- ^ Value checker, Nothing if all ok
158 -> (a -> Maybe String) -- ^ Value checker, Nothing if all ok
127− -> DomParser Identity a -- ^ Parser itself
159+ -> DomParser Identity a -- ^ Parser itself
128 -> Spec
160 -> Spec
129specParser name doc check parser = it name $ do
161specParser name doc check parser = it name $ do
130 result <- either throwIO return $ runDomParser doc parser
162 result <- either throwIO return $ runDomParser doc parser
@@ -134,9 +166,9 @@ specParser name doc check parser = it name $ do
134
166
135specParserEq
167specParserEq
136 :: (Eq a, Show a)
168 :: (Eq a, Show a)
137− => String -- ^ Name of spec
169+ => String -- ^ Name of spec
138− -> Document -- ^ Document to parse
170+ -> Document -- ^ Document to parse
139− -> a -- ^ Value parser should return
171+ -> a -- ^ Value parser should return
140 -> DomParser Identity a -- ^ Parser itself
172 -> DomParser Identity a -- ^ Parser itself
141 -> Spec
173 -> Spec
142specParserEq name doc a parser = specParser name doc check parser
174specParserEq name doc a parser = specParser name doc check parser
@@ -161,7 +193,7 @@ specParserFailedPath
161 :: (Show a)
193 :: (Show a)
162 => String -- ^ Name of spec
194 => String -- ^ Name of spec
163 -> Document
195 -> Document
164− -> [Text] -- ^ Expteced path in error
196+ -> DomPath -- ^ Expteced path in error
165 -> DomParser Identity a
197 -> DomParser Identity a
166 -> Spec
198 -> Spec
167specParserFailedPath name doc path parser = it name $ example $ do
199specParserFailedPath name doc path parser = it name $ example $ do
@@ -176,13 +208,37 @@ specParserFailedPath name doc path parser = it name $ example $ do
176combinationsSpec :: Spec
208combinationsSpec :: Spec
177combinationsSpec = do
209combinationsSpec = do
178 describe "inElem" $ do
210 describe "inElem" $ do
179− let parser = inElem "a" textFromDom
180 describe "succeeds" $ do
211 describe "succeeds" $ do
212+ describe "simple" $ do
213+ let parser = inElem "a" textFromDom
181− specParserEq "docSimple" docSimple "content" parser
214+ specParserEq "docSimple" docSimple "content" parser
182− specParserEq "docMultiple" docMultiple "content1" parser
215+ specParserEq "docMultiple" docMultiple "content1" parser
216+ describe "deep" $ do
217+ let parser = inElem "a" $ inElem "b" textFromDom
218+ specParserEq "docDeep" docDeep "content" parser
219+ specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser
220+ specParserEq "docDeepWithContent" docDeepWithContent "content" parser
183 describe "fails" $ do
221 describe "fails" $ do
222+ describe "simple" $ do
223+ let parser = inElem "a" textFromDom
184− specParserFailed "docNone" docNone parser
224+ specParserFailed "docNone" docNone parser
185− specParserFailed "docEmpty" docEmpty parser
225+ specParserFailed "docSingleEmpty" docSingleEmpty parser
226+ describe "deep" $ do
227+ let parser = inElem "a" $ inElem "b" textFromDom
228+ specParserFailedPath "docDeepMultiple2" docDeepMultiple2
229+ (DomPath ["root", "a", "b"]) parser
230+ -- should fail here because first tag "a" does not contains
231+ -- tag "b" which is expected by parser @inElem "b"@
232+
233+ describe "parseAttribute" $ do
234+ describe "succeeds" $ do
235+ specParserEq "docSimpleAttr" docSimpleAttr "content"
236+ $ inElem "a" $ parseAttribute "attr" Right
237+ let res = ["content1", "content2", "content3"]
238+ specParserEq "docMultipleAttr" docMultipleAttr res
239+ $ inElemAll "a" $ parseAttribute "attr" Right
240+ describe "fails" $ do
241+ specParserFailed "docNone" docNone $ parseAttribute "attr" Right
186
242
187 describe "inElemAll" $ do
243 describe "inElemAll" $ do
188 let parser = inElemAll "a" textFromDom
244 let parser = inElemAll "a" textFromDom
@@ -192,7 +248,7 @@ combinationsSpec = do
192 specParserEq "docMultiple" docMultiple
248 specParserEq "docMultiple" docMultiple
193 ["content1", "content2", "content3"] parser
249 ["content1", "content2", "content3"] parser
194 describe "fails" $ do
250 describe "fails" $ do
195− specParserFailed "docEmpty" docEmpty parser
251+ specParserFailed "docSingleEmpty" docSingleEmpty parser
196
252
197 describe "inElemMay" $ do
253 describe "inElemMay" $ do
198 let parser = inElemMay "a" textFromDom
254 let parser = inElemMay "a" textFromDom
@@ -201,7 +257,7 @@ combinationsSpec = do
201 specParserEq "docSimple" docSimple (Just "content") parser
257 specParserEq "docSimple" docSimple (Just "content") parser
202 specParserEq "docMultiple" docMultiple (Just "content1") parser
258 specParserEq "docMultiple" docMultiple (Just "content1") parser
203 describe "fails" $ do
259 describe "fails" $ do
204− specParserFailed "docEmpty" docEmpty parser
260+ specParserFailed "docSingleEmpty" docSingleEmpty parser
205
261
206 describe "inElemNe" $ do
262 describe "inElemNe" $ do
207 let parser = inElemNe "a" textFromDom
263 let parser = inElemNe "a" textFromDom
@@ -211,7 +267,7 @@ combinationsSpec = do
211 (NE.fromList ["content1", "content2", "content3"]) parser
267 (NE.fromList ["content1", "content2", "content3"]) parser
212 describe "fails" $ do
268 describe "fails" $ do
213 specParserFailed "docNone" docNone parser
269 specParserFailed "docNone" docNone parser
214− specParserFailed "docEmpty" docEmpty parser
270+ specParserFailed "docSingleEmpty" docSingleEmpty parser
215
271
216 describe "diveElem" $ do
272 describe "diveElem" $ do
217 describe "single element" $ do
273 describe "single element" $ do
@@ -220,7 +276,7 @@ combinationsSpec = do
220 specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser
276 specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser
221 specParserEq "docDeepMultiple2" docDeepMultiple2 "content1" parser
277 specParserEq "docDeepMultiple2" docDeepMultiple2 "content1" parser
222 describe "fails" $ do
278 describe "fails" $ do
223− specParserFailedPath "docSimple" docSimple ["root", "a", "b"] parser
279+ specParserFailedPath "docSimple" docSimple (DomPath ["root", "a", "b"]) parser
224 describe "multiple elements" $ do
280 describe "multiple elements" $ do
225 let
281 let
226 parser = diveElem "a" $ inElemAll "b" textFromDom
282 parser = diveElem "a" $ inElemAll "b" textFromDom
@@ -234,7 +290,7 @@ combinationsSpec = do
234 describe "mandatory element" $ do
290 describe "mandatory element" $ do
235 let parser = inElem "a" $ ignoreEmpty textFromDom
291 let parser = inElem "a" $ ignoreEmpty textFromDom
236 describe "succeeds" $ do
292 describe "succeeds" $ do
237− specParserEq "docEmpty" docEmpty Nothing parser
293+ specParserEq "docSingleEmpty" docSingleEmpty Nothing parser
238 specParserEq "docSimple" docSimple (Just "content") parser
294 specParserEq "docSimple" docSimple (Just "content") parser
239 specParserEq "docMultiple" docMultiple (Just "content1") parser
295 specParserEq "docMultiple" docMultiple (Just "content1") parser
240 describe "fails" $ do
296 describe "fails" $ do
@@ -243,7 +299,7 @@ combinationsSpec = do
243 let parser = fmap join $ inElemMay "a" $ ignoreEmpty textFromDom
299 let parser = fmap join $ inElemMay "a" $ ignoreEmpty textFromDom
244 describe "succeeds" $ do
300 describe "succeeds" $ do
245 specParserEq "docNone" docNone Nothing parser
301 specParserEq "docNone" docNone Nothing parser
246− specParserEq "docEmpty" docEmpty Nothing parser
302+ specParserEq "docSingleEmpty" docSingleEmpty Nothing parser
247 specParserEq "docSimple" docSimple (Just "content") parser
303 specParserEq "docSimple" docSimple (Just "content") parser
248 specParserEq "docMultiple" docMultiple (Just "content1") parser
304 specParserEq "docMultiple" docMultiple (Just "content1") parser
249
305
@@ -255,9 +311,9 @@ combinationsSpec = do
255 inElem "a" $ do
311 inElem "a" $ do
256 checkCurrentName "a"
312 checkCurrentName "a"
257 describe "fails" $ do
313 describe "fails" $ do
258− specParserFailedPath "root element" docSimple ["toor"] $ do
314+ specParserFailedPath "root element" docSimple (DomPath ["toor"]) $ do
259 checkCurrentName "toor"
315 checkCurrentName "toor"
260− specParserFailedPath "inner element" docSimple ["root", "b"] $ do
316+ specParserFailedPath "inner element" docSimple (DomPath ["root", "b"]) $ do
261 inElem "a" $ checkCurrentName "b"
317 inElem "a" $ checkCurrentName "b"
262
318
263contentSpec :: Spec
319contentSpec :: Spec
@@ -271,14 +327,25 @@ contentSpec = do
271structSpec :: Spec
327structSpec :: Spec
272structSpec = do
328structSpec = do
273 describe "succeeds" $ do
329 describe "succeeds" $ do
274− let
330+ describe "dom structure" $ do
331+ let
275− result = TestStructure
332+ result = TestStructure
276− { tsName = "name"
333+ { tsName = "name"
277− , tsInts = [1,2]
334+ , tsInts = [1,2]
278− , tsBools = pure True }
335+ , tsBools = pure True }
279− specParserEq "docStruct" docStruct result fromDom
336+ specParserEq "docStruct" docStruct result testStructureFromDom
337+ describe "attribute structure" $ do
338+ let
339+ result = TestStructure
340+ { tsName = "structure"
341+ , tsInts = [10]
342+ , tsBools = pure True }
343+ specParserEq "docAttrStruct" docAttrStruct result testStructureAttributes
280 describe "fails" $ do
344 describe "fails" $ do
345+ describe "dom structure" $ do
281− specParserFailed "docSimple" docSimple testStructureFromDom
346+ specParserFailed "docSimple" docSimple testStructureFromDom
347+ describe "attr structure" $ do
348+ specParserFailed "docNone" docNone testStructureAttributes
282
349
283main :: IO ()
350main :: IO ()
284main = hspec $ do
351main = hspec $ do