git.iko.soy/typeable/dom-parser
on master help sign in
14 files changed+362−206
since splitsnapshots
unifiedsplit
.travis.yml+7−5 CHANGELOG.md+44 README.md+5 dom-parser.cabal+11−10 ghc-963.yaml+7 src/Text/XML/DOM/Parser.hs+3−1 src/Text/XML/DOM/Parser/Attributes.hs+64 src/Text/XML/DOM/Parser/Combinators.hs+32−23 src/Text/XML/DOM/Parser/Content.hs+63−118 src/Text/XML/DOM/Parser/FromAttribute.hs+2 src/Text/XML/DOM/Parser/FromDom.hs+2−21 src/Text/XML/DOM/Parser/Types.hs+75−22 src/Text/XML/Soap.hs+46 stack.yaml+1−6
.travis.yml+7−5
@@ -4,6 +4,12 @@ sudo: false
44# Do not choose a language; we provide our own build tools.
55language: generic
66
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+
713# Caching so the next build will be fast too.
814cache:
915 directories:
@@ -21,10 +27,6 @@ before_install:
2127- export PATH=$HOME/.local/bin:$PATH
2228- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
2329
24−install:
25−# Build dependencies
26−- stack --no-terminal --install-ghc build --only-dependencies
27−
2830script:
2931# 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 @@
11# CHANGELOG
22
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+
345## 1.0.0
46+
447* Added support for parsing attributes
548* Changed public interface for 'parseContent'
649* Added useful functions
750* Dropped unnecessary dependency from shakespeare
851
952## 0.1.0
53+
1054* 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+11−10
@@ -1,5 +1,5 @@
11name: dom-parser
2−version: 1.0.0
2+version: 3.2.0
33synopsis: Simple monadic DOM parser
44license: MIT
55license-file: LICENSE
@@ -7,12 +7,13 @@ author: Typeable.io contributors
77maintainer: makeit@typeable.io
88category: XML
99build-type: Simple
10−extra-source-files: CHANGELOG.md
1110cabal-version: >=1.10
12−
13−extra-source-files: CHANGELOG.md
14−
1511homepage: 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
1617
1718source-repository head
1819 type: git
@@ -43,26 +44,26 @@ library
4344 , TypeFamilies
4445 , TypeOperators
4546 , UndecidableInstances
46− build-depends: base >= 4.7 && < 5
47+ build-depends: base >= 4.11 && < 5
4748 , case-insensitive
4849 , containers
4950 , lens
50− , mtl
51− , open-union >= 0.2
51+ , mtl < 2.3 || > 2.3
5252 , scientific
53− , semigroups
5453 , text
5554 , transformers
56− , type-fun
5755 , xml-conduit
56+ , xml-conduit-writer
5857 , xml-lens
5958 exposed-modules: Text.XML.DOM.Parser
59+ , Text.XML.DOM.Parser.Attributes
6060 , Text.XML.DOM.Parser.Buildable
6161 , Text.XML.DOM.Parser.Combinators
6262 , Text.XML.DOM.Parser.Content
6363 , Text.XML.DOM.Parser.FromAttribute
6464 , Text.XML.DOM.Parser.FromDom
6565 , Text.XML.DOM.Parser.Types
66+ , Text.XML.Soap
6667
6768test-suite test
6869 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+3−1
@@ -1,5 +1,6 @@
11module Text.XML.DOM.Parser
2− ( module Text.XML.DOM.Parser.Buildable
2+ ( module Text.XML.DOM.Parser.Attributes
3+ , module Text.XML.DOM.Parser.Buildable
34 , module Text.XML.DOM.Parser.Combinators
45 , module Text.XML.DOM.Parser.Content
56 , module Text.XML.DOM.Parser.FromAttribute
@@ -7,6 +8,7 @@ module Text.XML.DOM.Parser
78 , module Text.XML.DOM.Parser.Types
89 ) where
910
11+import Text.XML.DOM.Parser.Attributes
1012import Text.XML.DOM.Parser.Buildable
1113import Text.XML.DOM.Parser.Combinators
1214import Text.XML.DOM.Parser.Content
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/Combinators.hs+32−23
@@ -22,7 +22,6 @@ import Control.Monad.Reader
2222import Data.Foldable as F
2323import Data.List as L
2424import Data.List.NonEmpty (NonEmpty(..))
25−import Data.Monoid
2625import Data.Text as T
2726import Data.Traversable
2827import Text.XML
@@ -31,15 +30,15 @@ import Text.XML.DOM.Parser.Types
3130import Text.XML.Lens
3231
3332
34−-- | Generic function to traverse arbitrary inner cursors.
33+-- | Generic function to traverse arbitrary inner elements.
3534traverseElems
3635 :: (Monad m, Foldable g, Traversable f)
3736 => ([Element] -> DomParserT g m (f (DomPath, Element)))
3837 -- ^ Takes list of current elements and returns container with
39− -- pairs of subpath (relatively to current element) and element
38+ -- pairs of subpath (relatively to current elements) and element
4039 -- to run parser in
4140 -> DomParserT Identity m a
42− -- ^ Parser will be runned for each element found in traversable
41+ -- ^ Parser to run for each element found in traversable 'f'
4342 -> DomParserT g m (f a)
4443traverseElems trav parser = do
4544 pd <- ask
@@ -49,15 +48,15 @@ traverseElems trav parser = do
4948 newpd = ParserData
5049 { _pdElements = Identity e
5150 , _pdPath = pd ^. pdPath <> subpath }
52− -- type of reader has been changed, local won't work here
53− magnify (to $ const newpd) parser
51+ lift $ runReaderT parser newpd
5452
55−-- | Takes function filtering
53+-- | Traverses elements located in same path using filtering function
5654inFilteredTrav
5755 :: (Monad m, Foldable g, Buildable f)
5856 => ([Element] -> (DomPath, [Element]))
59− -- ^ Function returning some filtered elements with path suffixes which will
60− -- be appended to parser's state. The argument is a list of current elements.
57+ -- ^ Takes list of current elements and returns some descendants
58+ -- subset and path this descendants located at. Path is should be
59+ -- same for all descendants and required for error message
6160 -> DomParserT Identity m a
6261 -> DomParserT g m (f a)
6362inFilteredTrav deeper = traverseElems trav
@@ -68,49 +67,54 @@ inFilteredTrav deeper = traverseElems trav
6867 Nothing -> throwParserError $ PENotFound . (<> path)
6968 Just tr -> return $ fmap (path,) tr
7069
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.
7174inElemTrav
7275 :: (Monad m, Foldable g, Buildable f)
73− => NameMatcher -- ^ Name of tag to traverse in
76+ => ElemMatcher -- ^ Tag(s) matcher to traverse in
7477 -> DomParserT Identity m a
7578 -> DomParserT g m (f a)
7679inElemTrav n = inFilteredTrav deeper
7780 where
78− deeper = (DomPath [_nmShow n],) . toListOf (folded . nodes . folded . _Element . elMatchName n)
81+ elemsFold = folded . nodes . folded . _Element . elMatch n
82+ deeper = (DomPath [_emShow n],) . toListOf elemsFold
7983
80−-- | Runs parser inside first children element with given name
84+-- | Runs parser inside first children element matched by macher
8185inElem
8286 :: (Monad m, Foldable g)
83− => NameMatcher
87+ => ElemMatcher
8488 -> DomParserT Identity m a
8589 -> DomParserT g m a
8690inElem n = fmap runIdentity . inElemTrav n
8791
8892inElemAll
8993 :: (Monad m, Foldable g)
90− => NameMatcher
94+ => ElemMatcher
9195 -> DomParserT Identity m a
9296 -> DomParserT g m [a]
9397inElemAll = inElemTrav
9498
9599inElemMay
96100 :: (Monad m, Foldable g)
97− => NameMatcher
101+ => ElemMatcher
98102 -> DomParserT Identity m a
99103 -> DomParserT g m (Maybe a)
100104inElemMay = inElemTrav
101105
102106inElemNe
103107 :: (Monad m, Foldable g)
104− => NameMatcher
108+ => ElemMatcher
105109 -> DomParserT Identity m a
106110 -> DomParserT g m (NonEmpty a)
107111inElemNe = inElemTrav
108112
109113{- | Dive given parser's current tags set into the given path. The @divePath
110−["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
111115will not fail if occured tag "a" which does not contains tag "b". This
112116behaviour is desireable when you dont want to parse whole XML and just want
113−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
114118elements. Consider this code
115119
116120@
@@ -128,26 +132,31 @@ which translates like: @a > b > c > fromDom@
128132As you can see, inElem always takes first element and runs inner parser in this
129133single element, unlike 'divePath' which runs inner parser @in all@ descendants
130134in 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.
131140-}
132141
133142divePath
134143 :: forall m g a
135144 . (Monad m, Foldable g)
136− => [NameMatcher]
145+ => [ElemMatcher]
137146 -> DomParserT [] m a
138147 -> DomParserT g m a
139148divePath path = magnify $ to modElems
140149 where
141150 modElems
142151 = over pdElements (toListOf $ folded . diver)
143− . over pdPath (<> DomPath (L.map _nmShow path))
152+ . over pdPath (<> DomPath (L.map _emShow path))
144153 diver :: Fold Element Element
145154 diver = F.foldr (.) id $ L.map toDive path
146− toDive n = nodes . folded . _Element . elMatchName n
155+ toDive n = nodes . folded . _Element . elMatch n
147156
148157diveElem
149158 :: (Monad m, Foldable g)
150− => NameMatcher
159+ => ElemMatcher
151160 -> DomParserT [] m a
152161 -> DomParserT g m a
153162diveElem p = divePath [p]
@@ -188,6 +197,6 @@ ignoreBlank = ignoreElem test
188197 let
189198 elems = e ^.. nodes . folded . _Element
190199 cont = mconcat $ e ^.. nodes . folded . _Content
191− in if | not $ L.null elems -> False
200+ in if | not $ L.null elems -> False
192201 | T.null $ T.strip cont -> True
193202 | otherwise -> False
src/Text/XML/DOM/Parser/Content.hs+63−118
@@ -1,84 +1,44 @@
11module Text.XML.DOM.Parser.Content
2− ( -- * Content readers
3− readBool
4− , readChar
5− -- ** Reader constructors
6− , maybeReadContent
7− , readContent
2+ (
3+ -- * Parsing element's content
4+ parseContent
85 -- * Getting current element's properties
96 , getCurrentName
107 , getCurrentContent
11− , getCurrentAttributes
12− , getCurrentAttribute
138 , checkCurrentName
14− -- * Parsing element's content
15− , parseContent
16− -- * Parsing attributes
17− , parseAttribute
18− , parseAttributeMaybe
9+ -- * Internal
10+ , maybeReadContent
11+ , readContent
12+ , readBool
13+ , readChar
1914 ) where
2015
2116import Control.Lens
2217import Control.Monad
2318import Control.Monad.Except
2419import Data.List as L
25−import Data.Map.Strict as M
2620import Data.Monoid
2721import Data.Text as T
2822import Data.Typeable
23+import Prelude as P
2924import Text.Read
3025import Text.XML.DOM.Parser.Types
3126import Text.XML.Lens
3227
3328
34−-- | @since 1.0.0
35−readBool :: Text -> Either Text Bool
36−readBool t =
37− let
38− lowt = T.toLower $ T.strip t
39− tvals = ["y", "yes", "t", "true", "1"]
40− fvals = ["n", "no", "f", "false", "0"]
41− in if
42− | lowt `elem` tvals -> Right True
43− | lowt `elem` fvals -> Right False
44− | otherwise ->
45− Left $ "Could not read " <> t <> " as Bool"
46−
47−-- | Expects text to be single character
48−--
49−-- @since 1.0.0
50−readChar :: Text -> Either Text Char
51−readChar t = case T.unpack $ T.strip t of
52− [c] -> Right c
53− _ -> Left "Should have exactly one non-blank character"
54−
55−-- | If reader returns 'Nothing' then resulting function returns 'Left
56−-- "error message"'. 'Typeable' is used for generating usefull error
57−-- message.
58−--
59−-- @since 1.0.0
60−maybeReadContent
61− :: forall a
62− . (Typeable a)
63− => (Text -> Maybe a)
64− -- ^ Content or attribute reader
65− -> Text
66− -- ^ Content or attribute value
67− -> Either Text a
68−maybeReadContent f t = maybe (Left msg) Right $ f t
69− where
70− msg = "Not readable " <> n <> ": " <> t
71− n = T.pack $ show $ typeRep (Proxy :: Proxy a)
72−
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
7341
74−-- | Tries to read given text to value using 'Read'. Useful to use
75−-- with 'parseContent' and 'parseAttribute'. Content is stripped
76−-- before reading.
77−readContent
78− :: (Read a, Typeable a)
79− => Text
80− -> Either Text a
81−readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
8242
8343-- | Returns name of current element.
8444--
@@ -118,67 +78,52 @@ getCurrentContent = do
11878 | L.null conts -> Nothing
11979 | otherwise -> Just $ mconcat conts
12080
121−-- | Parses content inside current tag. It expects current element set
122−-- consists of exactly ONE element.
123−parseContent
124− :: (Monad m)
125− => (Text -> Either Text a)
126− -- ^ Content parser, return error msg if value is not parsed
127− -> DomParserT Identity m a
128−parseContent parse = getCurrentContent >>= \case
129− Nothing -> throwParserError PEContentNotFound
130− Just c -> case parse c of
131− Left e -> throwParserError $ PEWrongFormat e
132− Right a -> return a
133−
134−-- | Retuns map of attributes of current element
81+-- | If reader returns 'Nothing' then resulting function returns 'Left
82+-- "error message"'. 'Typeable' is used for generating usefull error
83+-- message.
13584--
13685-- @since 1.0.0
137−getCurrentAttributes
138− :: (Monad m)
139− => DomParserT Identity m (M.Map Name Text)
140−getCurrentAttributes = view $ pdElements . to runIdentity . attrs
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)
14198
142−-- | Returns element with given name or 'Nothing'
143−--
144−-- @since 1.0.0
145−getCurrentAttribute
146− :: (Monad m)
147− => NameMatcher
148− -> DomParserT Identity m (Maybe Text)
149−getCurrentAttribute attrName
150− = preview $ pdElements . to runIdentity . attrs . to M.toList
151− . traversed . filtered (views _1 (attrName ^. nmMatch)) . _2
15299
153−-- | Parses attribute with given name, throws error if attribute is not found.
154−--
155−-- @since 1.0.0
156−parseAttribute
157− :: (Monad m)
158− => NameMatcher
159− -- ^ Attribute name
160− -> (Text -> Either Text a)
161− -- ^ Attribute content parser
162− -> DomParserT Identity m a
163−parseAttribute attrName parser =
164− parseAttributeMaybe attrName parser >>= \case
165− Nothing -> throwParserError $ PEAttributeNotFound attrName
166− Just a -> return a
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
167108
168−-- | Parses attribute with given name. Returns Nothing if attribute is
169−-- not found.
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
170124--
171125-- @since 1.0.0
172−parseAttributeMaybe
173− :: (Monad m)
174− => NameMatcher
175− -- ^ Attribute name
176− -> (Text -> Either Text a)
177− -- ^ Attribute content parser
178− -> DomParserT Identity m (Maybe a)
179−parseAttributeMaybe attrName parser =
180− getCurrentAttribute attrName >>= \case
181− Nothing -> return Nothing
182− Just aval -> case parser aval of
183− Left err -> throwParserError $ PEAttributeWrongFormat attrName err
184− Right a -> return $ Just a
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+2
@@ -26,6 +26,8 @@ import Text.XML.DOM.Parser.Content
2626-- | Class of types which can be get from attribute value. Method
2727-- 'fromAttribute' is a convenient default parameter for
2828-- 'parseAttribute'
29+--
30+-- @since 2.0.0
2931class FromAttribute a where
3032 fromAttribute
3133 :: Text
src/Text/XML/DOM/Parser/FromDom.hs+2−21
@@ -4,7 +4,6 @@ module Text.XML.DOM.Parser.FromDom
44 , proxyFromDom
55 -- * Explicit methods for convenience
66 , elementFromDom
7− , unionFromDom
87 , textFromDom
98 , stringFromDom
109 , charFromDom
@@ -21,7 +20,6 @@ module Text.XML.DOM.Parser.FromDom
2120import Control.Applicative
2221import Control.Lens
2322import Data.Fixed
24−import Data.OpenUnion
2523import Data.Scientific
2624import Data.Text as T hiding (empty)
2725import Data.Typeable
@@ -29,7 +27,6 @@ import Data.Void
2927import Text.XML
3028import Text.XML.DOM.Parser.Content
3129import Text.XML.DOM.Parser.Types
32−import TypeFun.Data.List hiding (Union)
3330
3431proxyFromDom
3532 :: forall proxy m a
@@ -38,7 +35,8 @@ proxyFromDom
3835 -> DomParserT Identity m a
3936proxyFromDom _ = fromDom
4037
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'
4240class FromDom a where
4341 fromDom :: (Monad m) => DomParserT Identity m a
4442
@@ -115,23 +113,6 @@ instance FromDom Bool where
115113boolFromDom :: (Monad m) => DomParserT Identity m Bool
116114boolFromDom = parseContent readBool
117115
118−instance FromDom (Union '[]) where
119− fromDom = empty
120−
121−instance
122− ( Typeable a, FromDom a, FromDom (Union as)
123− , SubList as (a ': as) )
124− => FromDom (Union (a ': as)) where
125− -- fromDom :: forall m. (DomParserMonad m) => m a
126− fromDom = (liftUnion <$> (proxyFromDom (Proxy :: Proxy a)))
127− <|> (reUnion <$> (proxyFromDom (Proxy :: Proxy (Union as))))
128−
129−unionFromDom
130− :: (Monad m, FromDom (Union as))
131− => proxy as
132− -> DomParserT Identity m (Union as)
133−unionFromDom _ = fromDom
134−
135116instance FromDom Element where
136117 fromDom = elementFromDom
137118
src/Text/XML/DOM/Parser/Types.hs+75−22
@@ -1,12 +1,17 @@
11module Text.XML.DOM.Parser.Types
2− ( -- * Name matching
3− NameMatcher(..)
2+ (-- * Element matching
3+ ElemMatcher(..)
4+ , emMatch
5+ , emShow
6+ , matchElemName
7+ , elMatch
8+ -- * Name matching
9+ , NameMatcher(..)
410 , nmMatch
511 , nmShow
612 , matchName
713 , matchLocalName
814 , matchCILocalName
9− , elMatchName
1015 -- * Parser internals
1116 , DomPath(..)
1217 , ParserError(..)
@@ -37,20 +42,56 @@ import GHC.Generics (Generic)
3742import Text.XML
3843import Text.XML.Lens
3944
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+
4078-- | Arbitrary name matcher. Match name any way you want, but
4179-- considered to be used as comparator with some name with some rules
80+--
81+-- @since 2.0.0
4282data NameMatcher = NameMatcher
4383 { _nmMatch :: Name -> Bool
4484 -- ^ Name matching function, usually should be simple comparsion
4585 -- function takin in account only local name or other components
4686 -- of 'Name'
4787 , _nmShow :: Text
48− -- ^ How to show the name matcher, since there is no 'Read'
49− -- instance we can do it any way we want
88+ -- ^ Field for 'Show' instance and bulding usefull errors
5089 }
5190
52−makeLenses ''NameMatcher
53−
91+-- | Instance use 'matchCILocalName' as most general and liberal
92+-- matching strategy (while XML is often malformed).
93+--
94+-- @since 2.0.0
5495instance IsString NameMatcher where
5596 fromString = matchCILocalName . T.pack
5697
@@ -59,6 +100,8 @@ instance Show NameMatcher where
59100
60101-- | Makes matcher which matches only local part of name igoring
61102-- namespace and prefix. Local name matching is case sensitive.
103+--
104+-- @since 2.0.0
62105matchLocalName :: Text -> NameMatcher
63106matchLocalName tname = NameMatcher
64107 { _nmMatch = \n -> nameLocalName n == tname
@@ -68,25 +111,30 @@ matchLocalName tname = NameMatcher
68111-- | Makes matcher which matches only local part of name igoring
69112-- namespace and prefix. Local name matching is case insensitive. This
70113-- is the most common case.
114+--
115+-- @since 2.0.0
71116matchCILocalName :: Text -> NameMatcher
72117matchCILocalName tname = NameMatcher
73118 { _nmMatch = \n -> CI.mk (nameLocalName n) == CI.mk tname
74119 , _nmShow = tname
75120 }
76121
122+makeLenses ''NameMatcher
123+
77124-- | Makes matcher which match name by 'Eq' with given
125+--
126+-- @since 2.0.0
78127matchName :: Name -> NameMatcher
79128matchName n = NameMatcher
80129 { _nmMatch = (== n)
81130 , _nmShow = nameLocalName n
82131 }
83132
84−elMatchName :: NameMatcher -> Traversal' Element Element
85−elMatchName nm = filtered (views name $ nm ^. nmMatch)
86−
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.
87135newtype DomPath = DomPath
88136 { unDomPath :: [Text]
89− } deriving (Eq, Ord, Show, Monoid)
137+ } deriving (Eq, Ord, Show, Semigroup, Monoid)
90138
91139-- | DOM parser error description.
92140data ParserError
@@ -96,13 +144,17 @@ data ParserError
96144 -- ^ Path of element error occured in
97145 }
98146
99− -- | Tag contents has wrong format, (could not read text to value)
100− | PEWrongFormat
101− { _peDetails :: Text
102− , _pePath :: DomPath
147+ -- | Expected attribute but not found
148+ --
149+ -- @since 1.0.0
150+ | PEAttributeNotFound
151+ { _peAttributeName :: NameMatcher
152+ , _pePath :: DomPath
103153 }
104154
105155 -- | Could not parse attribute
156+ --
157+ -- @since 1.0.0
106158 | PEAttributeWrongFormat
107159 { _peAttributeName :: NameMatcher
108160 , _peDetails :: Text
@@ -114,10 +166,10 @@ data ParserError
114166 { _pePath :: DomPath
115167 }
116168
117− -- | Expected attribute but not found
118− | PEAttributeNotFound
119− { _peAttributeName :: NameMatcher
120− , _pePath :: DomPath
169+ -- | Tag contents has wrong format, (could not read text to value)
170+ | PEContentWrongFormat
171+ { _peDetails :: Text
172+ , _pePath :: DomPath
121173 }
122174
123175 -- | Some other error
@@ -132,15 +184,16 @@ instance Exception ParserError
132184
133185newtype ParserErrors = ParserErrors
134186 { unParserErrors :: [ParserError]
135− } deriving (Show, Monoid, Generic)
187+ } deriving (Show, Semigroup, Monoid, Generic)
136188
137189makePrisms ''ParserErrors
138190
139191instance Exception ParserErrors
140192
141193
142−{- | Parser scope parser runs in. Functor argument is usually @Identity@ or
143−@[]@.
194+{- | Parser scope.
195+
196+Functor argument is usually @Identity@ or @[]@.
144197
145198If functor is @Identity@ then parser expects exactly ONE current element. This
146199is common behavior for content parsers, or parsers expecting strict XML
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