git.iko.soy/typeable/dom-parser
on f32ff9e help sign in
82e2fef
swap
0 ahead, 52 behind
.gitignoredeleted−2
since splitsnapshots
unifiedsplit
@@ -1,2 +0,0 @@
1−TAGS
2−.stack-work
.travis.ymldeleted−32
@@ -1,32 +0,0 @@
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,54 +1,4 @@
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−
52## 0.1.0
3## 0.1.0
53−
54* Public release
4* Public release
README.mddeleted−5
@@ -1,5 +0,0 @@
1−# dom-parser
2−
3−[![Build Status](https://travis-ci.org/typeable/dom-parser.svg?branch=master)](https://travis-ci.org/typeable/dom-parser)
4−
5−Simple monadic DOM parser
dom-parser.cabal+9−23
@@ -1,5 +1,5 @@
1name: dom-parser
1name: dom-parser
2−version: 3.2.0
2+version: 0.1.0
3synopsis: Simple monadic DOM parser
3synopsis: Simple monadic DOM parser
4license: MIT
4license: MIT
5license-file: LICENSE
5license-file: LICENSE
@@ -7,17 +7,8 @@ author: Typeable.io contributors
7maintainer: makeit@typeable.io
7maintainer: makeit@typeable.io
8category: XML
8category: XML
9build-type: Simple
9build-type: Simple
10−cabal-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
15extra-source-files: CHANGELOG.md
10extra-source-files: CHANGELOG.md
16− , README.md
11+cabal-version: >=1.10
17−
18−source-repository head
19− type: git
20− location: git@github.com:typeable/dom-parser.git
21
12
22library
13library
23 hs-source-dirs: src
14 hs-source-dirs: src
@@ -44,26 +35,21 @@ library
44 , TypeFamilies
35 , TypeFamilies
45 , TypeOperators
36 , TypeOperators
46 , UndecidableInstances
37 , UndecidableInstances
47− build-depends: base >= 4.11 && < 5
38+ build-depends: base >= 4.7 && < 5
48− , case-insensitive
49− , containers
50 , lens
39 , lens
51− , mtl < 2.3 || > 2.3
40+ , mtl
52− , scientific
41+ , open-union
42+ , semigroups
43+ , shakespeare
53 , text
44 , text
54 , transformers
45 , transformers
46+ , type-fun
55 , xml-conduit
47 , xml-conduit
56− , xml-conduit-writer
57 , xml-lens
48 , xml-lens
58 exposed-modules: Text.XML.DOM.Parser
49 exposed-modules: Text.XML.DOM.Parser
59− , Text.XML.DOM.Parser.Attributes
50+ , Text.XML.DOM.Parser.Class
60− , Text.XML.DOM.Parser.Buildable
61 , Text.XML.DOM.Parser.Combinators
51 , Text.XML.DOM.Parser.Combinators
62− , Text.XML.DOM.Parser.Content
63− , Text.XML.DOM.Parser.FromAttribute
64− , Text.XML.DOM.Parser.FromDom
65 , Text.XML.DOM.Parser.Types
52 , Text.XML.DOM.Parser.Types
66− , Text.XML.Soap
67
53
68test-suite test
54test-suite test
69 type: exitcode-stdio-1.0
55 type: exitcode-stdio-1.0
ghc-963.yamldeleted−7
@@ -1,7 +0,0 @@
1−resolver: lts-22.6
2−
3−extra-deps:
4− - xml-conduit-writer-0.1.1.5
5−
6−nix:
7− packages: [zlib]
src/Text/XML/DOM/Parser.hs+2−10
@@ -1,17 +1,9 @@
1module Text.XML.DOM.Parser
1module Text.XML.DOM.Parser
2− ( module Text.XML.DOM.Parser.Attributes
2+ ( module Text.XML.DOM.Parser.Class
3− , module Text.XML.DOM.Parser.Buildable
4 , module Text.XML.DOM.Parser.Combinators
3 , module Text.XML.DOM.Parser.Combinators
5− , module Text.XML.DOM.Parser.Content
6− , module Text.XML.DOM.Parser.FromAttribute
7− , module Text.XML.DOM.Parser.FromDom
8 , module Text.XML.DOM.Parser.Types
4 , module Text.XML.DOM.Parser.Types
9 ) where
5 ) where
10
6
11−import Text.XML.DOM.Parser.Attributes
7+import Text.XML.DOM.Parser.Class
12−import Text.XML.DOM.Parser.Buildable
13import Text.XML.DOM.Parser.Combinators
8import Text.XML.DOM.Parser.Combinators
14−import Text.XML.DOM.Parser.Content
15−import Text.XML.DOM.Parser.FromAttribute
16−import Text.XML.DOM.Parser.FromDom
17import Text.XML.DOM.Parser.Types
9import Text.XML.DOM.Parser.Types
src/Text/XML/DOM/Parser/Attributes.hsdeleted−64
@@ -1,64 +0,0 @@
1−module Text.XML.DOM.Parser.Attributes
2− ( parseAttribute
3− , parseAttributeMaybe
4− , getCurrentAttributes
5− , getCurrentAttribute
6− ) where
7−
8−import Control.Lens
9−import Data.Map.Strict as M
10−import Data.Text as T
11−import Text.XML.DOM.Parser.Types
12−import Text.XML.Lens
13−
14−-- | Parses attribute with given name, throws error if attribute is not found.
15−--
16−-- @since 1.0.0
17−parseAttribute
18− :: (Monad m)
19− => NameMatcher
20− -- ^ Attribute name
21− -> (Text -> Either Text a)
22− -- ^ Attribute content parser
23− -> DomParserT Identity m a
24−parseAttribute attrName parser =
25− parseAttributeMaybe attrName parser >>= \case
26− Nothing -> throwParserError $ PEAttributeNotFound attrName
27− Just a -> return a
28−
29−-- | Parses attribute with given name. Returns Nothing if attribute is
30−-- not found.
31−--
32−-- @since 1.0.0
33−parseAttributeMaybe
34− :: (Monad m)
35− => NameMatcher
36− -- ^ Attribute name
37− -> (Text -> Either Text a)
38− -- ^ Attribute content parser
39− -> DomParserT Identity m (Maybe a)
40−parseAttributeMaybe attrName parser =
41− getCurrentAttribute attrName >>= \case
42− Nothing -> return Nothing
43− Just aval -> case parser aval of
44− Left err -> throwParserError $ PEAttributeWrongFormat attrName err
45− Right a -> return $ Just a
46−
47−-- | Retuns map of attributes of current element
48−--
49−-- @since 1.0.0
50−getCurrentAttributes
51− :: (Monad m)
52− => DomParserT Identity m (M.Map Name Text)
53−getCurrentAttributes = view $ pdElements . to runIdentity . attrs
54−
55−-- | Returns element with given name or 'Nothing'
56−--
57−-- @since 1.0.0
58−getCurrentAttribute
59− :: (Monad m)
60− => NameMatcher
61− -> DomParserT Identity m (Maybe Text)
62−getCurrentAttribute attrName
63− = preview $ pdElements . to runIdentity . attrs . to M.toList
64− . traversed . filtered (views _1 (attrName ^. nmMatch)) . _2
src/Text/XML/DOM/Parser/Buildable.hsdeleted−26
@@ -1,26 +0,0 @@
1−module Text.XML.DOM.Parser.Buildable
2− ( Buildable(..)
3− ) where
4−
5−import Data.Functor.Identity
6−import Data.List.NonEmpty as NE
7−import Data.Maybe
8−
9−-- | Class of traversable functors which may be constructed from list
10−class Traversable f => Buildable f where
11− -- | If method return Nothing this means we can not build
12− -- traversable from given list. In this case 'inFilteredTrav' should
13− -- fail traversing.
14− build :: [a] -> Maybe (f a)
15−
16−instance Buildable Identity where
17− build = fmap Identity . listToMaybe
18−
19−instance Buildable [] where
20− build = Just
21−
22−instance Buildable Maybe where
23− build = Just . listToMaybe
24−
25−instance Buildable NonEmpty where
26− build = NE.nonEmpty
src/Text/XML/DOM/Parser/FromDom.hs → src/Text/XML/DOM/Parser/Class.hsrenamed+80−56
@@ -1,9 +1,10 @@
1−module Text.XML.DOM.Parser.FromDom
1+module Text.XML.DOM.Parser.Class
2 ( -- * FromDom
2 ( -- * FromDom
3 FromDom(..)
3 FromDom(..)
4 , proxyFromDom
4 , proxyFromDom
5 -- * Explicit methods for convenience
5 -- * Explicit methods for convenience
6 , elementFromDom
6 , elementFromDom
7+ , unionFromDom
7 , textFromDom
8 , textFromDom
8 , stringFromDom
9 , stringFromDom
9 , charFromDom
10 , charFromDom
@@ -14,19 +15,21 @@ module Text.XML.DOM.Parser.FromDom
14 , boolFromDom
15 , boolFromDom
15 , unitFromDom
16 , unitFromDom
16 , voidFromDom
17 , 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.Scientific
23+import Data.OpenUnion
24+import Data.Text (Text)
24−import Data.Text as T hiding (empty)
25+import qualified Data.Text as T
25−import Data.Typeable
26+import Data.Typeable
26−import Data.Void
27+import Data.Void
28+import Text.Shakespeare.Text (st)
27−import Text.XML
29+import Text.XML
28−import Text.XML.DOM.Parser.Content
30+import Text.XML.DOM.Parser.Combinators
29−import Text.XML.DOM.Parser.Types
31+import Text.XML.DOM.Parser.Types
32+import TypeFun.Data.List hiding (Union)
30
33
31proxyFromDom
34proxyFromDom
32 :: forall proxy m a
35 :: forall proxy m a
@@ -35,86 +38,107 @@ proxyFromDom
35 -> DomParserT Identity m a
38 -> DomParserT Identity m a
36proxyFromDom _ = fromDom
39proxyFromDom _ = fromDom
37
40
38−-- | Class of types which can be parsed from single XML element. The
41+-- | Class of types which can be parsed from single XML element.
39−-- method 'fromDom' is convenient default to use with 'inElem'
40class FromDom a where
42class FromDom a where
41 fromDom :: (Monad m) => DomParserT Identity m a
43 fromDom :: (Monad m) => DomParserT Identity m a
42
44
43instance FromDom () where
45instance FromDom () where
44 fromDom = unitFromDom
46 fromDom = unitFromDom
45
47
46−-- | Always successfully parses any DOM to @()@
47−unitFromDom :: (Monad m) => DomParserT Identity m ()
48−unitFromDom = pure ()
49−
50instance FromDom Void where
48instance FromDom Void where
51 fromDom = voidFromDom
49 fromDom = voidFromDom
52
50
53−-- | Never parses successfully. It is just 'empty'
54−voidFromDom :: (Monad m) => DomParserT Identity m Void
55−voidFromDom = empty
56−
57instance FromDom Text where
51instance FromDom Text where
58 fromDom = textFromDom
52 fromDom = textFromDom
59
53
60−textFromDom :: (Monad m) => DomParserT Identity m Text
61−textFromDom = parseContent Right
62−
63instance FromDom String where
54instance FromDom String where
64 fromDom = stringFromDom
55 fromDom = stringFromDom
65
56
66−stringFromDom :: (Monad m) => DomParserT Identity m String
67−stringFromDom = parseContent $ Right . T.unpack
68−
69instance FromDom Char where
57instance FromDom Char where
70 fromDom = charFromDom
58 fromDom = charFromDom
71
59
72−charFromDom :: (Monad m) => DomParserT Identity m Char
73−charFromDom = parseContent readChar
74−
75instance FromDom Int where
60instance FromDom Int where
76 fromDom = intFromDom
61 fromDom = intFromDom
77
62
78−intFromDom :: (Monad m) => DomParserT Identity m Int
79−intFromDom = parseContent readContent
80−
81instance FromDom Integer where
63instance FromDom Integer where
82 fromDom = integerFromDom
64 fromDom = integerFromDom
83
65
84−integerFromDom :: (Monad m) => DomParserT Identity m Integer
85−integerFromDom = parseContent readContent
86−
87instance FromDom Double where
66instance FromDom Double where
88 fromDom = doubleFromDom
67 fromDom = doubleFromDom
89
68
90−doubleFromDom :: (Monad m) => DomParserT Identity m Double
91−doubleFromDom = parseContent readContent
92−
93instance (HasResolution a, Typeable a) => FromDom (Fixed a) where
69instance (HasResolution a, Typeable a) => FromDom (Fixed a) where
94 fromDom = fixedFromDom
70 fromDom = fixedFromDom
95
71
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−
107instance FromDom Bool where
72instance FromDom Bool where
108 fromDom = boolFromDom
73 fromDom = boolFromDom
109
74
110−-- | Expects content to be y, yes, t, true or 1 for True Values n, no,
75+instance FromDom (Union '[]) where
111−-- f, false or 0 for False. Case is not significant, blank characters
76+ fromDom = empty
112−-- are striped.
77+
113−boolFromDom :: (Monad m) => DomParserT Identity m Bool
78+instance ( Typeable a, FromDom a, FromDom (Union as)
114−boolFromDom = parseContent readBool
79+ , SubList as (a ': as) )
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))))
115
84
116instance FromDom Element where
85instance FromDom Element where
117 fromDom = elementFromDom
86 fromDom = elementFromDom
118
87
119elementFromDom :: (Monad m) => DomParserT Identity m Element
88elementFromDom :: (Monad m) => DomParserT Identity m Element
120elementFromDom = view $ pdElements . to runIdentity
89elementFromDom = 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/Combinators.hs+98−61
@@ -2,7 +2,7 @@ module Text.XML.DOM.Parser.Combinators
2 ( -- * Generic combinators to traverse descendants
2 ( -- * Generic combinators to traverse descendants
3 traverseElems
3 traverseElems
4 , inFilteredTrav
4 , inFilteredTrav
5− -- * Using 'Buildable'
5+ -- * Using 'DomTraversable'
6 , inElemTrav
6 , inElemTrav
7 , inElem
7 , inElem
8 , inElemAll
8 , inElemAll
@@ -15,106 +15,105 @@ 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
18 ) where
23 ) where
19
24
20−import Control.Lens
25+import Control.Lens
26+import Control.Monad.Except
21−import Control.Monad.Reader
27+import Control.Monad.Reader
22−import Data.Foldable as F
28+import Data.List.NonEmpty (NonEmpty(..))
23−import Data.List as L
29+import Data.Monoid
24−import Data.List.NonEmpty (NonEmpty(..))
30+import Data.Text (Text)
25−import Data.Text as T
31+import qualified Data.Text as T
26−import Data.Traversable
32+import Data.Traversable
27−import Text.XML
33+import Data.Typeable
28−import Text.XML.DOM.Parser.Buildable
34+import Text.Read
35+import Text.Shakespeare.Text (st)
36+import Text.XML
29−import Text.XML.DOM.Parser.Types
37+import Text.XML.DOM.Parser.Types
30−import Text.XML.Lens
38+import Text.XML.Lens
31−
39+
32−
40+
33−-- | Generic function to traverse arbitrary inner elements.
41+-- | Generic function to traverse arbitrary inner cursors.
34traverseElems
42traverseElems
35 :: (Monad m, Foldable g, Traversable f)
43 :: (Monad m, Foldable g, Traversable f)
36− => ([Element] -> DomParserT g m (f (DomPath, Element)))
44+ => ([Element] -> DomParserT g m (f ([Text], Element)))
37− -- ^ Takes list of current elements and returns container with
38− -- pairs of subpath (relatively to current elements) and element
45+ -- ^ Takes set of current elements and
39− -- to run parser in
40 -> DomParserT Identity m a
46 -> DomParserT Identity m a
41− -- ^ Parser to run for each element found in traversable 'f'
47+ -- ^ Parser will be runned for each element found in traversable
42 -> DomParserT g m (f a)
48 -> DomParserT g m (f a)
43traverseElems trav parser = do
49traverseElems trav parser = do
44 pd <- ask
50 pd <- ask
45 inner <- trav $ pd ^.. pdElements . folded
51 inner <- trav $ pd ^.. pdElements . folded
46 for inner $ \(subpath, e) -> do
52 for inner $ \(subpath, e) -> do
47− let
48− newpd = ParserData
53+ let newpd = ParserData
49− { _pdElements = Identity e
54+ { _pdElements = Identity e
50− , _pdPath = pd ^. pdPath <> subpath }
55+ , _pdPath = pd ^. pdPath <> subpath }
51− lift $ runReaderT parser newpd
56+ magnify (to $ const newpd) parser
52
57
53−-- | Traverses elements located in same path using filtering function
58+-- | Takes function filtering
54inFilteredTrav
59inFilteredTrav
55− :: (Monad m, Foldable g, Buildable f)
60+ :: (Monad m, Foldable g, DomTraversable f)
56− => ([Element] -> (DomPath, [Element]))
61+ => ([Element] -> ([Text], [Element]))
57− -- ^ Takes list of current elements and returns some descendants
62+ -- ^ Function returning some filtered elements with path suffixes which will
58− -- subset and path this descendants located at. Path is should be
63+ -- be appended to parser's state
59− -- same for all descendants and required for error message
60 -> DomParserT Identity m a
64 -> DomParserT Identity m a
61 -> DomParserT g m (f a)
65 -> DomParserT g m (f a)
62inFilteredTrav deeper = traverseElems trav
66inFilteredTrav deeper = traverseElems trav
63 where
67 where
64 trav e = do
68 trav e = do
65 let (path, elems) = deeper e
69 let (path, elems) = deeper e
66− case build elems of
70+ case buildDomTraversable elems of
67 Nothing -> throwParserError $ PENotFound . (<> path)
71 Nothing -> throwParserError $ PENotFound . (<> path)
68 Just tr -> return $ fmap (path,) tr
72 Just tr -> return $ fmap (path,) tr
69
73
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, Buildable f)
75+ :: (Monad m, Foldable g, DomTraversable f)
76− => ElemMatcher -- ^ Tag(s) matcher to traverse in
76+ => Text
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− elemsFold = folded . nodes . folded . _Element . elMatch n
81+ deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)
82− deeper = (DomPath [_emShow n],) . toListOf elemsFold
83
82
84−-- | Runs parser inside first children element matched by macher
83+-- | Runs parser inside first children element with given name
85inElem
84inElem
86 :: (Monad m, Foldable g)
85 :: (Monad m, Foldable g)
87− => ElemMatcher
86+ => Text
88 -> DomParserT Identity m a
87 -> DomParserT Identity m a
89 -> DomParserT g m a
88 -> DomParserT g m a
90inElem n = fmap runIdentity . inElemTrav n
89inElem n = fmap runIdentity . inElemTrav n
91
90
92inElemAll
91inElemAll
93 :: (Monad m, Foldable g)
92 :: (Monad m, Foldable g)
94− => ElemMatcher
93+ => Text
95 -> DomParserT Identity m a
94 -> DomParserT Identity m a
96 -> DomParserT g m [a]
95 -> DomParserT g m [a]
97inElemAll = inElemTrav
96inElemAll = inElemTrav
98
97
99inElemMay
98inElemMay
100 :: (Monad m, Foldable g)
99 :: (Monad m, Foldable g)
101− => ElemMatcher
100+ => Text
102 -> DomParserT Identity m a
101 -> DomParserT Identity m a
103 -> DomParserT g m (Maybe a)
102 -> DomParserT g m (Maybe a)
104inElemMay = inElemTrav
103inElemMay = inElemTrav
105
104
106inElemNe
105inElemNe
107 :: (Monad m, Foldable g)
106 :: (Monad m, Foldable g)
108− => ElemMatcher
107+ => Text
109 -> DomParserT Identity m a
108 -> DomParserT Identity m a
110 -> DomParserT g m (NonEmpty a)
109 -> DomParserT g m (NonEmpty a)
111inElemNe = inElemTrav
110inElemNe = inElemTrav
112
111
113{- | Dive given parser's current tags set into the given path. The @divePath
112{- | Dive given parser's current tags set into the given path. The @divePath
114−["a", "b"]@ differs from @inElem "a" $ inElem "b"@. Namely the first variant
113+["a", "b"]@ differs from @inElem "a" . inElem "b"@. Namely the first variant
115will not fail if occured tag "a" which does not contains tag "b". This
114will not fail if occured tag "a" which does not contains tag "b". This
116behaviour is desireable when you dont want to parse whole XML and just want
115behaviour is desireable when you dont want to parse whole XML and just want
117−to pull tags located in some path. The other difference is in traversing inner
116+to pull tags in some path. The other difference is in traversing inner
118elements. Consider this code
117elements. Consider this code
119
118
120@
119@
@@ -132,31 +131,26 @@ which translates like: @a > b > c > fromDom@
132As you can see, inElem always takes first element and runs inner parser in this
131As you can see, inElem always takes first element and runs inner parser in this
133single element, unlike 'divePath' which runs inner parser @in all@ descendants
132single element, unlike 'divePath' which runs inner parser @in all@ descendants
134in given path.
133in given path.
135−
136−Note also that 'divePath' takes parser parameterized by @[]@ not by
137−'Identity'. This because when you dive using some path you will get a
138−list of found elements and all these elements will be @current@ for
139−parser.
140-}
134-}
141
135
142divePath
136divePath
143 :: forall m g a
137 :: forall m g a
144 . (Monad m, Foldable g)
138 . (Monad m, Foldable g)
145− => [ElemMatcher]
139+ => [Text]
146 -> DomParserT [] m a
140 -> DomParserT [] m a
147 -> DomParserT g m a
141 -> DomParserT g m a
148divePath path = magnify $ to modElems
142divePath path = magnify $ to modElems
149 where
143 where
150 modElems
144 modElems
151 = over pdElements (toListOf $ folded . diver)
145 = over pdElements (toListOf $ folded . diver)
152− . over pdPath (<> DomPath (L.map _emShow path))
146+ . over pdPath (<> path)
153 diver :: Fold Element Element
147 diver :: Fold Element Element
154− diver = F.foldr (.) id $ L.map toDive path
148+ diver = foldr (.) id $ map toDive path
155− toDive n = nodes . folded . _Element . elMatch n
149+ toDive n = nodes . folded . _Element . ell n
156
150
157diveElem
151diveElem
158 :: (Monad m, Foldable g)
152 :: (Monad m, Foldable g)
159− => ElemMatcher
153+ => Text
160 -> DomParserT [] m a
154 -> DomParserT [] m a
161 -> DomParserT g m a
155 -> DomParserT g m a
162diveElem p = divePath [p]
156diveElem p = divePath [p]
@@ -166,7 +160,7 @@ ignoreElem
166 :: (Monad m)
160 :: (Monad m)
167 => (Element -> Bool)
161 => (Element -> Bool)
168 -- ^ Predicate checking that we must ignore some current tag. If returns
162 -- ^ Predicate checking that we must ignore some current tag. If returns
169− -- 'True' then parser will not be runned and combinator just returns Nothing.
163+ -- true then parser will not be runned and combinator just returns Nothing.
170 -> DomParserT Identity m a
164 -> DomParserT Identity m a
171 -> DomParserT Identity m (Maybe a)
165 -> DomParserT Identity m (Maybe a)
172ignoreElem test parser = do
166ignoreElem test parser = do
@@ -174,7 +168,7 @@ ignoreElem test parser = do
174 if ign then pure Nothing else Just <$> parser
168 if ign then pure Nothing else Just <$> parser
175
169
176-- | If current element has no children nodes does not run parser and returns
170-- | If current element has no children nodes does not run parser and returns
177−-- Nothing. Otherwise runs parser inside current element. Useful when you got
171+-- Nothing. Otherwise runs parser inside current element. Usefull when you got
178-- XML with strange empty elements which must be just ignored, but `inElem` runs
172-- XML with strange empty elements which must be just ignored, but `inElem` runs
179-- parser inside of this elements which causes to parser error.
173-- parser inside of this elements which causes to parser error.
180ignoreEmpty
174ignoreEmpty
@@ -183,7 +177,7 @@ ignoreEmpty
183 -> DomParserT Identity m (Maybe a)
177 -> DomParserT Identity m (Maybe a)
184ignoreEmpty = ignoreElem test
178ignoreEmpty = ignoreElem test
185 where
179 where
186− test e = L.null $ e ^. nodes
180+ test e = null $ e ^. nodes
187
181
188-- | If all current elements contains blank content, or contains nothing at all
182-- | If all current elements contains blank content, or contains nothing at all
189-- , then returns Nothing, else runs parser.
183-- , then returns Nothing, else runs parser.
@@ -197,6 +191,49 @@ ignoreBlank = ignoreElem test
197 let
191 let
198 elems = e ^.. nodes . folded . _Element
192 elems = e ^.. nodes . folded . _Element
199 cont = mconcat $ e ^.. nodes . folded . _Content
193 cont = mconcat $ e ^.. nodes . folded . _Content
200− in if | not $ L.null elems -> False
194+ in if | not $ null elems -> False
201 | T.null $ T.strip cont -> True
195 | T.null $ T.strip cont -> True
202 | otherwise -> False
196 | 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.hsdeleted−129
@@ -1,129 +0,0 @@
1−module Text.XML.DOM.Parser.Content
2− (
3− -- * Parsing element's content
4− parseContent
5− -- * Getting current element's properties
6− , getCurrentName
7− , getCurrentContent
8− , checkCurrentName
9− -- * Internal
10− , maybeReadContent
11− , readContent
12− , readBool
13− , readChar
14− ) where
15−
16−import Control.Lens
17−import Control.Monad
18−import Control.Monad.Except
19−import Data.List as L
20−import Data.Monoid
21−import Data.Text as T
22−import Data.Typeable
23−import Prelude as P
24−import Text.Read
25−import Text.XML.DOM.Parser.Types
26−import Text.XML.Lens
27−
28−
29−-- | Parses content inside current tag. It expects current element set
30−-- consists of exactly ONE element.
31−parseContent
32− :: (Monad m)
33− => (Text -> Either Text a)
34− -- ^ Content parser, return error msg if value is not parsed
35− -> DomParserT Identity m a
36−parseContent parse = getCurrentContent >>= \case
37− Nothing -> throwParserError PEContentNotFound
38− Just c -> case parse c of
39− Left e -> throwParserError $ PEContentWrongFormat e
40− Right a -> return a
41−
42−
43−-- | Returns name of current element.
44−--
45−-- @since 1.0.0
46−getCurrentName :: (Monad m) => DomParserT Identity m Name
47−getCurrentName = view $ pdElements . to runIdentity . name
48−
49−-- | If name of current tag differs from first argument throws 'PENotFound' with
50−-- tag name replaced in last path's segment. Useful for checking root
51−-- document's element name.
52−checkCurrentName
53− :: (Monad m)
54− => NameMatcher
55− -> DomParserT Identity m ()
56−checkCurrentName n = do
57− cn <- getCurrentName
58− unless ((n ^. nmMatch) cn) $ do
59− p <- view pdPath
60− let pinit = if L.null (unDomPath p) then [] else L.init $ unDomPath p
61− throwError $ ParserErrors [PENotFound $ DomPath $ pinit ++ [_nmShow n]]
62− return ()
63−
64−-- | Get current content. If current element contains no content or
65−-- have inner elements then Nothing returned
66−--
67−-- @since 1.0.0
68−getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)
69−getCurrentContent = do
70− nds <- view $ pdElements . to runIdentity . nodes
71− let
72− els :: [Element]
73− els = nds ^.. folded . _Element
74− conts :: [Text]
75− conts = nds ^.. folded . _Content
76− return $ if
77− | not $ L.null els -> Nothing
78− | L.null conts -> Nothing
79− | otherwise -> Just $ mconcat conts
80−
81−-- | If reader returns 'Nothing' then resulting function returns 'Left
82−-- "error message"'. 'Typeable' is used for generating usefull error
83−-- message.
84−--
85−-- @since 1.0.0
86−maybeReadContent
87− :: forall a
88− . (Typeable a)
89− => (Text -> Maybe a)
90− -- ^ Content or attribute reader
91− -> Text
92− -- ^ Content or attribute value
93− -> Either Text a
94−maybeReadContent f t = maybe (Left msg) Right $ f t
95− where
96− msg = "Not readable " <> n <> ": " <> t
97− n = T.pack $ P.show $ typeRep (Proxy :: Proxy a)
98−
99−
100−-- | Tries to read given text to value using 'Read'. Useful to use
101−-- with 'parseContent' and 'parseAttribute'. Content is stripped
102−-- before reading.
103−readContent
104− :: (Read a, Typeable a)
105− => Text
106− -> Either Text a
107−readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
108−
109−
110−-- | @since 1.0.0
111−readBool :: Text -> Either Text Bool
112−readBool t =
113− let
114− lowt = T.toLower $ T.strip t
115− tvals = ["y", "yes", "t", "true", "1"]
116− fvals = ["n", "no", "f", "false", "0"]
117− in if
118− | lowt `L.elem` tvals -> Right True
119− | lowt `L.elem` fvals -> Right False
120− | otherwise ->
121− Left $ "Could not read " <> t <> " as Bool"
122−
123−-- | Expects text to be single character
124−--
125−-- @since 1.0.0
126−readChar :: Text -> Either Text Char
127−readChar t = case T.unpack $ T.strip t of
128− [c] -> Right c
129− _ -> Left "Should have exactly one non-blank character"
src/Text/XML/DOM/Parser/FromAttribute.hsdeleted−112
@@ -1,112 +0,0 @@
1−module Text.XML.DOM.Parser.FromAttribute
2− ( -- * FromAttribute
3− FromAttribute(..)
4− , proxyFromAttribute
5− -- * Explicit methods
6− , textFromAttribute
7− , stringFromAttribute
8− , charFromAttribute
9− , intFromAttribute
10− , integerFromAttribute
11− , doubleFromAttribute
12− , fixedFromAttribute
13− , boolFromAttribute
14− , unitFromAttribute
15− , voidFromAttribute
16− , scientificFromAttribute
17− ) where
18−
19−import Data.Fixed
20−import Data.Scientific
21−import Data.Text as T
22−import Data.Typeable
23−import Data.Void
24−import Text.XML.DOM.Parser.Content
25−
26−-- | Class of types which can be get from attribute value. Method
27−-- 'fromAttribute' is a convenient default parameter for
28−-- 'parseAttribute'
29−--
30−-- @since 2.0.0
31−class FromAttribute a where
32− fromAttribute
33− :: Text
34− -- ^ Attribute contents to parse
35− -> Either Text a
36− -- ^ Either error message or result
37−
38−proxyFromAttribute
39− :: FromAttribute a
40− => Proxy a
41− -> Text
42− -> Either Text a
43−proxyFromAttribute _ = fromAttribute
44−
45−instance FromAttribute () where
46− fromAttribute = unitFromAttribute
47−
48−unitFromAttribute :: Text -> Either Text ()
49−unitFromAttribute _ = Right ()
50−
51−instance FromAttribute Void where
52− fromAttribute = voidFromAttribute
53−
54−voidFromAttribute :: Text -> Either Text Void
55−voidFromAttribute _ = Left "Void has been parsed"
56−
57−instance FromAttribute Text where
58− fromAttribute = textFromAttribute
59−
60−textFromAttribute :: Text -> Either Text Text
61−textFromAttribute = Right
62−
63−instance FromAttribute String where
64− fromAttribute = stringFromAttribute
65−
66−stringFromAttribute :: Text -> Either Text String
67−stringFromAttribute = Right . T.unpack
68−
69−instance FromAttribute Char where
70− fromAttribute = charFromAttribute
71−
72−charFromAttribute :: Text -> Either Text Char
73−charFromAttribute = readChar
74−
75−instance FromAttribute Int where
76− fromAttribute = intFromAttribute
77−
78−intFromAttribute :: Text -> Either Text Int
79−intFromAttribute = readContent
80−
81−instance FromAttribute Integer where
82− fromAttribute = integerFromAttribute
83−
84−integerFromAttribute :: Text -> Either Text Integer
85−integerFromAttribute = readContent
86−
87−instance FromAttribute Double where
88− fromAttribute = doubleFromAttribute
89−
90−doubleFromAttribute :: Text -> Either Text Double
91−doubleFromAttribute = readContent
92−
93−instance (Typeable a, HasResolution a) => FromAttribute (Fixed a) where
94− fromAttribute = fixedFromAttribute
95−
96−fixedFromAttribute
97− :: (HasResolution a, Typeable a)
98− => Text
99− -> Either Text (Fixed a)
100−fixedFromAttribute = readContent
101−
102−instance FromAttribute Bool where
103− fromAttribute = boolFromAttribute
104−
105−boolFromAttribute :: Text -> Either Text Bool
106−boolFromAttribute = readBool
107−
108−instance FromAttribute Scientific where
109− fromAttribute = scientificFromAttribute
110−
111−scientificFromAttribute :: Text -> Either Text Scientific
112−scientificFromAttribute = readContent
src/Text/XML/DOM/Parser/Types.hs+60−159
@@ -1,182 +1,59 @@
1module Text.XML.DOM.Parser.Types
1module Text.XML.DOM.Parser.Types
2− (-- * Element matching
3− ElemMatcher(..)
4− , emMatch
5− , emShow
6− , matchElemName
7− , elMatch
8− -- * Name matching
9− , NameMatcher(..)
10− , nmMatch
11− , nmShow
12− , matchName
13− , matchLocalName
14− , matchCILocalName
15− -- * Parser internals
2+ ( -- * Parser internals
16− , DomPath(..)
17− , ParserError(..)
3+ ParserError(..)
18 , pePath
4 , pePath
19 , peDetails
5 , peDetails
20− , peAttributeName
21 , ParserErrors(..)
6 , ParserErrors(..)
22 , _ParserErrors
7 , _ParserErrors
23 , ParserData(..)
8 , ParserData(..)
24 , pdElements
9 , pdElements
25 , pdPath
10 , pdPath
11+ -- * Parser type
26 , DomParserT
12 , DomParserT
27 , DomParser
13 , DomParser
28 , runDomParserT
14 , runDomParserT
29 , runDomParser
15 , runDomParser
30 -- * Auxiliary
16 -- * Auxiliary
17+ , DomTraversable(..)
31 , throwParserError
18 , throwParserError
19+ , throwWrongFormat
32 ) where
20 ) where
33
21
34−import Control.Exception
22+import Control.Exception
35−import Control.Lens
23+import Control.Lens
36−import Control.Monad.Except
24+import Control.Monad.Except
37−import Control.Monad.Reader
25+import Control.Monad.Reader
38−import Data.CaseInsensitive as CI
26+import Data.List.NonEmpty (NonEmpty(..))
27+import qualified Data.List.NonEmpty as NE
39−import Data.String
28+import Data.Maybe
40−import Data.Text as T
29+import Data.Text (Text)
41−import GHC.Generics (Generic)
30+import GHC.Generics (Generic)
42−import Text.XML
31+import Text.XML
43−import Text.XML.Lens
32+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)
138
33
139-- | DOM parser error description.
34-- | DOM parser error description.
140data ParserError
35data ParserError
141 -- | Tag not found which should be.
36 -- | Tag not found which should be.
142 = PENotFound
37 = PENotFound
143− { _pePath :: DomPath
38+ { _pePath :: [Text]
144− -- ^ Path of element error occured in
145 }
39 }
146
40
147− -- | Expected attribute but not found
41+ -- | Tag contents has wrong format, (could not read text to value)
148− --
42+ | PEWrongFormat
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
160− , _peDetails :: Text
43+ { _peDetails :: Text
161− , _pePath :: DomPath
44+ , _pePath :: [Text] -- ^ path of element
162 }
45 }
163
46
164 -- | Node should have text content, but it does not.
47 -- | Node should have text content, but it does not.
165 | PEContentNotFound
48 | PEContentNotFound
166− { _pePath :: DomPath
49+ { _pePath :: [Text]
167− }
168−
169− -- | Tag contents has wrong format, (could not read text to value)
170− | PEContentWrongFormat
171− { _peDetails :: Text
172− , _pePath :: DomPath
173 }
50 }
174
51
175 -- | Some other error
52 -- | Some other error
176 | PEOther
53 | PEOther
177 { _peDetails :: Text
54 { _peDetails :: Text
178− , _pePath :: DomPath
55+ , _pePath :: [Text]
179− } deriving (Show, Generic)
56+ } deriving (Eq, Ord, Show, Generic)
180
57
181makeLenses ''ParserError
58makeLenses ''ParserError
182
59
@@ -184,16 +61,15 @@ instance Exception ParserError
184
61
185newtype ParserErrors = ParserErrors
62newtype ParserErrors = ParserErrors
186 { unParserErrors :: [ParserError]
63 { unParserErrors :: [ParserError]
187− } deriving (Show, Semigroup, Monoid, Generic)
64+ } deriving (Ord, Eq, Show, Monoid, Generic)
188
65
189makePrisms ''ParserErrors
66makePrisms ''ParserErrors
190
67
191instance Exception ParserErrors
68instance Exception ParserErrors
192
69
193
70
194−{- | Parser scope.
195−
196−Functor argument is usually @Identity@ or @[]@.
71+{- | Parser scope parser runs in. Functor argument is usually @Identity@ or
72+@[]@.
197
73
198If functor is @Identity@ then parser expects exactly ONE current element. This
74If functor is @Identity@ then parser expects exactly ONE current element. This
199is common behavior for content parsers, or parsers expecting strict XML
75is common behavior for content parsers, or parsers expecting strict XML
@@ -210,7 +86,7 @@ data ParserData f = ParserData
210 { _pdElements :: f Element
86 { _pdElements :: f Element
211 -- ^ Current element(s). Functor is intended to be either @Identity@ or
87 -- ^ Current element(s). Functor is intended to be either @Identity@ or
212 -- @[]@
88 -- @[]@
213− , _pdPath :: DomPath
89+ , _pdPath :: [Text]
214 -- ^ Path for error reporting
90 -- ^ Path for error reporting
215 }
91 }
216
92
@@ -226,11 +102,10 @@ runDomParserT
226 -> DomParserT Identity m a
102 -> DomParserT Identity m a
227 -> m (Either ParserErrors a)
103 -> m (Either ParserErrors a)
228runDomParserT doc par =
104runDomParserT doc par =
229− let
230− pd = ParserData
105+ let pd = ParserData
231− { _pdElements = doc ^. root . to pure
106+ { _pdElements = doc ^. root . to pure
232− , _pdPath = DomPath [doc ^. root . name . to nameLocalName]
107+ , _pdPath = [doc ^. root . localName]
233− }
108+ }
234 in runExceptT $ runReaderT par pd
109 in runExceptT $ runReaderT par pd
235
110
236runDomParser
111runDomParser
@@ -239,10 +114,36 @@ runDomParser
239 -> Either ParserErrors a
114 -> Either ParserErrors a
240runDomParser doc par = runIdentity $ runDomParserT doc par
115runDomParser doc par = runIdentity $ runDomParserT doc par
241
116
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+
242throwParserError
136throwParserError
243 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
137 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
244− => (DomPath -> ParserError)
138+ => ([Text] -> ParserError)
245 -> m a
139 -> m a
246throwParserError mkerr = do
140throwParserError mkerr = do
247 path <- view pdPath
141 path <- view pdPath
248− throwError $ ParserErrors $ [mkerr path]
142+ 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.hsdeleted−46
@@ -1,46 +0,0 @@
1−module Text.XML.Soap where
2−
3−import Control.Lens
4−import Data.String
5−import Text.XML
6−import Text.XML.DOM.Parser
7−import Text.XML.Writer
8−
9−data XmlEnvelope h b = XmlEnvelope
10− { _xeHeader :: !(Maybe h)
11− , _xeBody :: !(Maybe b)
12− } deriving (Eq, Show)
13−
14−makeLenses ''XmlEnvelope
15−
16−xmlEnvelopeToDocument :: (ToXML h, ToXML b) => XmlEnvelope h b -> Document
17−xmlEnvelopeToDocument xe = doc
18− where
19− sname n = fromString $ "{http://schemas.xmlsoap.org/soap/envelope/}" <> n
20− doc =
21− Document
22− { documentPrologue = Prologue [] Nothing []
23− , documentRoot =
24− Element
25− { elementName = sname "Envelope"
26− , elementAttributes = mempty
27− , elementNodes = [NodeElement header, NodeElement body]
28− }
29− , documentEpilogue = []
30− }
31− header =
32− Element
33− { elementName = sname "Header"
34− , elementAttributes = mempty
35− , elementNodes = render . toXML $ xe ^. xeHeader
36− }
37− body =
38− Element
39− { elementName = sname "Body"
40− , elementAttributes = mempty
41− , elementNodes = render . toXML $ xe ^. xeBody
42− }
43−
44−instance (FromDom h, FromDom b) => FromDom (XmlEnvelope h b) where
45− fromDom = XmlEnvelope <$> inElemMay "Header" fromDom
46− <*> inElemMay "Body" fromDom
stack.yamldeleted−1
@@ -1 +0,0 @@
1−ghc-963.yaml
test/Main.hs+29−96
@@ -27,15 +27,8 @@ 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
30+instance FromDom TestStructure where
31−testStructureAttributes = do
31+ fromDom = testStructureFromDom
32− name <- getCurrentName
33− int <- parseAttribute "int" readContent
34− bool <- parseAttribute "bool" readBool
35− return $ TestStructure
36− { tsName = nameLocalName name
37− , tsInts = [int]
38− , tsBools = pure bool }
39
32
40docStruct :: Document
33docStruct :: Document
41docStruct = parseText_ def [lt|
34docStruct = parseText_ def [lt|
@@ -48,13 +41,6 @@ docStruct = parseText_ def [lt|
48</root>
41</root>
49|]
42|]
50
43
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−
58docNone :: Document
44docNone :: Document
59docNone = parseText_ def [lt|
45docNone = parseText_ def [lt|
60<?xml version="1.0" encoding="utf-8"?>
46<?xml version="1.0" encoding="utf-8"?>
@@ -62,26 +48,8 @@ docNone = parseText_ def [lt|
62</root>
48</root>
63|]
49|]
64
50
65−docSimpleAttr :: Document
51+docEmpty :: 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−
83−docSingleEmpty :: Document
84−docSingleEmpty = parseText_ def [lt|
52+docEmpty = parseText_ def [lt|
85<?xml version="1.0" encoding="utf-8"?>
53<?xml version="1.0" encoding="utf-8"?>
86<root>
54<root>
87 <a/>
55 <a/>
@@ -156,7 +124,7 @@ specParser
156 :: String -- ^ Name of spec
124 :: String -- ^ Name of spec
157 -> Document -- ^ Document to parse
125 -> Document -- ^ Document to parse
158 -> (a -> Maybe String) -- ^ Value checker, Nothing if all ok
126 -> (a -> Maybe String) -- ^ Value checker, Nothing if all ok
159− -> DomParser Identity a -- ^ Parser itself
127+ -> DomParser Identity a -- ^ Parser itself
160 -> Spec
128 -> Spec
161specParser name doc check parser = it name $ do
129specParser name doc check parser = it name $ do
162 result <- either throwIO return $ runDomParser doc parser
130 result <- either throwIO return $ runDomParser doc parser
@@ -166,9 +134,9 @@ specParser name doc check parser = it name $ do
166
134
167specParserEq
135specParserEq
168 :: (Eq a, Show a)
136 :: (Eq a, Show a)
169− => String -- ^ Name of spec
137+ => String -- ^ Name of spec
170− -> Document -- ^ Document to parse
138+ -> Document -- ^ Document to parse
171− -> a -- ^ Value parser should return
139+ -> a -- ^ Value parser should return
172 -> DomParser Identity a -- ^ Parser itself
140 -> DomParser Identity a -- ^ Parser itself
173 -> Spec
141 -> Spec
174specParserEq name doc a parser = specParser name doc check parser
142specParserEq name doc a parser = specParser name doc check parser
@@ -193,7 +161,7 @@ specParserFailedPath
193 :: (Show a)
161 :: (Show a)
194 => String -- ^ Name of spec
162 => String -- ^ Name of spec
195 -> Document
163 -> Document
196− -> DomPath -- ^ Expteced path in error
164+ -> [Text] -- ^ Expteced path in error
197 -> DomParser Identity a
165 -> DomParser Identity a
198 -> Spec
166 -> Spec
199specParserFailedPath name doc path parser = it name $ example $ do
167specParserFailedPath name doc path parser = it name $ example $ do
@@ -208,37 +176,13 @@ specParserFailedPath name doc path parser = it name $ example $ do
208combinationsSpec :: Spec
176combinationsSpec :: Spec
209combinationsSpec = do
177combinationsSpec = do
210 describe "inElem" $ do
178 describe "inElem" $ do
179+ let parser = inElem "a" textFromDom
211 describe "succeeds" $ do
180 describe "succeeds" $ do
212− describe "simple" $ do
213− let parser = inElem "a" textFromDom
214− specParserEq "docSimple" docSimple "content" parser
181+ specParserEq "docSimple" docSimple "content" parser
215− specParserEq "docMultiple" docMultiple "content1" parser
182+ 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
221− describe "fails" $ do
222− describe "simple" $ do
223− let parser = inElem "a" textFromDom
224− specParserFailed "docNone" docNone 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
183 describe "fails" $ do
241− specParserFailed "docNone" docNone $ parseAttribute "attr" Right
184+ specParserFailed "docNone" docNone parser
185+ specParserFailed "docEmpty" docEmpty parser
242
186
243 describe "inElemAll" $ do
187 describe "inElemAll" $ do
244 let parser = inElemAll "a" textFromDom
188 let parser = inElemAll "a" textFromDom
@@ -248,7 +192,7 @@ combinationsSpec = do
248 specParserEq "docMultiple" docMultiple
192 specParserEq "docMultiple" docMultiple
249 ["content1", "content2", "content3"] parser
193 ["content1", "content2", "content3"] parser
250 describe "fails" $ do
194 describe "fails" $ do
251− specParserFailed "docSingleEmpty" docSingleEmpty parser
195+ specParserFailed "docEmpty" docEmpty parser
252
196
253 describe "inElemMay" $ do
197 describe "inElemMay" $ do
254 let parser = inElemMay "a" textFromDom
198 let parser = inElemMay "a" textFromDom
@@ -257,7 +201,7 @@ combinationsSpec = do
257 specParserEq "docSimple" docSimple (Just "content") parser
201 specParserEq "docSimple" docSimple (Just "content") parser
258 specParserEq "docMultiple" docMultiple (Just "content1") parser
202 specParserEq "docMultiple" docMultiple (Just "content1") parser
259 describe "fails" $ do
203 describe "fails" $ do
260− specParserFailed "docSingleEmpty" docSingleEmpty parser
204+ specParserFailed "docEmpty" docEmpty parser
261
205
262 describe "inElemNe" $ do
206 describe "inElemNe" $ do
263 let parser = inElemNe "a" textFromDom
207 let parser = inElemNe "a" textFromDom
@@ -267,7 +211,7 @@ combinationsSpec = do
267 (NE.fromList ["content1", "content2", "content3"]) parser
211 (NE.fromList ["content1", "content2", "content3"]) parser
268 describe "fails" $ do
212 describe "fails" $ do
269 specParserFailed "docNone" docNone parser
213 specParserFailed "docNone" docNone parser
270− specParserFailed "docSingleEmpty" docSingleEmpty parser
214+ specParserFailed "docEmpty" docEmpty parser
271
215
272 describe "diveElem" $ do
216 describe "diveElem" $ do
273 describe "single element" $ do
217 describe "single element" $ do
@@ -276,7 +220,7 @@ combinationsSpec = do
276 specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser
220 specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser
277 specParserEq "docDeepMultiple2" docDeepMultiple2 "content1" parser
221 specParserEq "docDeepMultiple2" docDeepMultiple2 "content1" parser
278 describe "fails" $ do
222 describe "fails" $ do
279− specParserFailedPath "docSimple" docSimple (DomPath ["root", "a", "b"]) parser
223+ specParserFailedPath "docSimple" docSimple ["root", "a", "b"] parser
280 describe "multiple elements" $ do
224 describe "multiple elements" $ do
281 let
225 let
282 parser = diveElem "a" $ inElemAll "b" textFromDom
226 parser = diveElem "a" $ inElemAll "b" textFromDom
@@ -290,7 +234,7 @@ combinationsSpec = do
290 describe "mandatory element" $ do
234 describe "mandatory element" $ do
291 let parser = inElem "a" $ ignoreEmpty textFromDom
235 let parser = inElem "a" $ ignoreEmpty textFromDom
292 describe "succeeds" $ do
236 describe "succeeds" $ do
293− specParserEq "docSingleEmpty" docSingleEmpty Nothing parser
237+ specParserEq "docEmpty" docEmpty Nothing parser
294 specParserEq "docSimple" docSimple (Just "content") parser
238 specParserEq "docSimple" docSimple (Just "content") parser
295 specParserEq "docMultiple" docMultiple (Just "content1") parser
239 specParserEq "docMultiple" docMultiple (Just "content1") parser
296 describe "fails" $ do
240 describe "fails" $ do
@@ -299,7 +243,7 @@ combinationsSpec = do
299 let parser = fmap join $ inElemMay "a" $ ignoreEmpty textFromDom
243 let parser = fmap join $ inElemMay "a" $ ignoreEmpty textFromDom
300 describe "succeeds" $ do
244 describe "succeeds" $ do
301 specParserEq "docNone" docNone Nothing parser
245 specParserEq "docNone" docNone Nothing parser
302− specParserEq "docSingleEmpty" docSingleEmpty Nothing parser
246+ specParserEq "docEmpty" docEmpty Nothing parser
303 specParserEq "docSimple" docSimple (Just "content") parser
247 specParserEq "docSimple" docSimple (Just "content") parser
304 specParserEq "docMultiple" docMultiple (Just "content1") parser
248 specParserEq "docMultiple" docMultiple (Just "content1") parser
305
249
@@ -311,9 +255,9 @@ combinationsSpec = do
311 inElem "a" $ do
255 inElem "a" $ do
312 checkCurrentName "a"
256 checkCurrentName "a"
313 describe "fails" $ do
257 describe "fails" $ do
314− specParserFailedPath "root element" docSimple (DomPath ["toor"]) $ do
258+ specParserFailedPath "root element" docSimple ["toor"] $ do
315 checkCurrentName "toor"
259 checkCurrentName "toor"
316− specParserFailedPath "inner element" docSimple (DomPath ["root", "b"]) $ do
260+ specParserFailedPath "inner element" docSimple ["root", "b"] $ do
317 inElem "a" $ checkCurrentName "b"
261 inElem "a" $ checkCurrentName "b"
318
262
319contentSpec :: Spec
263contentSpec :: Spec
@@ -327,25 +271,14 @@ contentSpec = do
327structSpec :: Spec
271structSpec :: Spec
328structSpec = do
272structSpec = do
329 describe "succeeds" $ do
273 describe "succeeds" $ do
330− describe "dom structure" $ do
274+ let
331− let
332− result = TestStructure
275+ result = TestStructure
333− { tsName = "name"
276+ { tsName = "name"
334− , tsInts = [1,2]
277+ , tsInts = [1,2]
335− , tsBools = pure True }
278+ , tsBools = pure True }
336− specParserEq "docStruct" docStruct result testStructureFromDom
279+ specParserEq "docStruct" docStruct result fromDom
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
344 describe "fails" $ do
280 describe "fails" $ do
345− describe "dom structure" $ do
346− specParserFailed "docSimple" docSimple testStructureFromDom
281+ specParserFailed "docSimple" docSimple testStructureFromDom
347− describe "attr structure" $ do
348− specParserFailed "docNone" docNone testStructureAttributes
349
282
350main :: IO ()
283main :: IO ()
351main = hspec $ do
284main = hspec $ do