master..7b06cfc · typeable/dom-parser

git.iko.soy/typeable/dom-parser

on 7b06cfc help sign in

.travis.yml+5−7

since splitsnapshots

unifiedsplit

@@ -4,12 +4,6 @@ sudo: false

4# Do not choose a language; we provide our own build tools.

5language: generic

7−env:

8− - STACK_YAML=stack.yaml

9− - STACK_YAML=ghc-802.yaml

10− - STACK_YAML=ghc-822.yaml

11− - STACK_YAML=ghc-841.yaml

12−

13# Caching so the next build will be fast too.

7# Caching so the next build will be fast too.

14cache:

8cache:

15 directories:

9 directories:

@@ -27,6 +21,10 @@ before_install:

27- export PATH=$HOME/.local/bin:$PATH

21- export PATH=$HOME/.local/bin:$PATH

28- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'

22- travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'

24+install:

25+# Build dependencies

26+- stack --no-terminal --install-ghc build --only-dependencies

27+

30script:

28script:

31# Build the package, its tests, and its docs and run the tests

29# Build the package, its tests, and its docs and run the tests

32−- stack --no-terminal --install-ghc test --haddock --no-haddock-deps

30+- stack --no-terminal test --haddock --no-haddock-deps

CHANGELOG.md−44

@@ -1,54 +1,10 @@

1# CHANGELOG

3−## HEAD

4−

5−## 3.2.0

6−

7−### Added

8−

9−* Text.XML.Soap module with XmlEnvelope stuff in it.

10−* GHC 9 compatibility.

11−

12−### Removed

13−

14−* Old stackage files.

15−

16−## 3.1.0

17−

18−### Added

19−

20−* Additional builds with GHC 8.0.2 and 8.2.1

21−* Compatibility with GHC 8.4.1

22−

23−## 3.0.0

24−

25−* GHC 8 compatible release

26−

27−### Removed

28−

29−* `open-union` dependency

30−

31−## 2.0.0

32−

33−### Added

34−

35−* `NameMatcher` and `ElemMatcher` as more flexible mechanisms for

36− matching names and elements instead of just matching by name.

37−* Class `FromAttribute` and some default instances

38−

39−### Changed

40−

41−* `DomTraversable` renamed to `Buildable`

42−* Combinators use `NameMatcher` and `ElemMatcher`

43−* Documentation improved

44−

45## 1.0.0

3## 1.0.0

46−

47* Added support for parsing attributes

4* Added support for parsing attributes

48* Changed public interface for 'parseContent'

5* Changed public interface for 'parseContent'

49* Added useful functions

6* Added useful functions

50* Dropped unnecessary dependency from shakespeare

7* Dropped unnecessary dependency from shakespeare

52## 0.1.0

9## 0.1.0

53−

54* Public release

10* Public release

README.mddeleted−5

@@ -1,5 +0,0 @@

1−# dom-parser

2−

3−[![Build Status](https://travis-ci.org/typeable/dom-parser.svg?branch=master)](https://travis-ci.org/typeable/dom-parser)

4−

5−Simple monadic DOM parser

dom-parser.cabal+11−13

@@ -1,5 +1,5 @@

1name: dom-parser

2−version: 3.2.0

2+version: 1.0.0

3synopsis: Simple monadic DOM parser

4license: MIT

5license-file: LICENSE

@@ -7,13 +7,12 @@ author: Typeable.io contributors

7maintainer: makeit@typeable.io

8category: XML

9build-type: Simple

10+extra-source-files: CHANGELOG.md

10cabal-version: >=1.10

11cabal-version: >=1.10

12+

13+extra-source-files: CHANGELOG.md

14+

11homepage: https://github.com/typeable/dom-parser

15homepage: https://github.com/typeable/dom-parser

12−tested-with: GHC == 9.2.7

13− , GHC == 9.4.8

14− , GHC == 9.6.3

15−extra-source-files: CHANGELOG.md

16− , README.md

18source-repository head

17source-repository head

19 type: git

18 type: git

@@ -44,26 +43,25 @@ library

44 , TypeFamilies

43 , TypeFamilies

45 , TypeOperators

44 , TypeOperators

46 , UndecidableInstances

45 , UndecidableInstances

47− build-depends: base >= 4.11 && < 5

46+ build-depends: base >= 4.7 && < 5

48 , case-insensitive

47 , case-insensitive

49 , containers

48 , containers

50 , lens

49 , lens

51− , mtl < 2.3 || > 2.3

50+ , mtl

51+ , open-union >= 0.2

52 , scientific

53+ , semigroups

53 , text

54 , text

54 , transformers

55 , transformers

56+ , type-fun

55 , xml-conduit

57 , xml-conduit

56− , xml-conduit-writer

57 , xml-lens

58 , xml-lens

58 exposed-modules: Text.XML.DOM.Parser

59 exposed-modules: Text.XML.DOM.Parser

59− , Text.XML.DOM.Parser.Attributes

60− , Text.XML.DOM.Parser.Buildable

61 , Text.XML.DOM.Parser.Combinators

60 , Text.XML.DOM.Parser.Combinators

62− , Text.XML.DOM.Parser.Content

61+ , Text.XML.DOM.Parser.Common

63 , Text.XML.DOM.Parser.FromAttribute

62 , Text.XML.DOM.Parser.FromAttribute

64 , Text.XML.DOM.Parser.FromDom

63 , Text.XML.DOM.Parser.FromDom

65 , Text.XML.DOM.Parser.Types

64 , Text.XML.DOM.Parser.Types

66− , Text.XML.Soap

68test-suite test

66test-suite test

69 type: exitcode-stdio-1.0

67 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+3−7

@@ -1,17 +1,13 @@

1module Text.XML.DOM.Parser

2− ( module Text.XML.DOM.Parser.Attributes

2+ ( module Text.XML.DOM.Parser.Combinators

3− , module Text.XML.DOM.Parser.Buildable

4− , module Text.XML.DOM.Parser.Combinators

5− , module Text.XML.DOM.Parser.Content

3+ , module Text.XML.DOM.Parser.Common

6 , module Text.XML.DOM.Parser.FromAttribute

4 , module Text.XML.DOM.Parser.FromAttribute

7 , module Text.XML.DOM.Parser.FromDom

5 , module Text.XML.DOM.Parser.FromDom

8 , module Text.XML.DOM.Parser.Types

6 , module Text.XML.DOM.Parser.Types

9 ) where

7 ) where

11−import Text.XML.DOM.Parser.Attributes

12−import Text.XML.DOM.Parser.Buildable

13import Text.XML.DOM.Parser.Combinators

9import Text.XML.DOM.Parser.Combinators

14−import Text.XML.DOM.Parser.Content

10+import Text.XML.DOM.Parser.Common

15import Text.XML.DOM.Parser.FromAttribute

11import Text.XML.DOM.Parser.FromAttribute

16import Text.XML.DOM.Parser.FromDom

12import Text.XML.DOM.Parser.FromDom

17import Text.XML.DOM.Parser.Types

13import 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/Combinators.hs+145−37

@@ -2,7 +2,7 @@ module Text.XML.DOM.Parser.Combinators

2 ( -- * Generic combinators to traverse descendants

3 traverseElems

4 , inFilteredTrav

5− -- * Using 'Buildable'

5+ -- * Using 'DomTraversable'

6 , inElemTrav

7 , inElem

8 , inElemAll

@@ -15,30 +15,45 @@ module Text.XML.DOM.Parser.Combinators

15 , ignoreElem

16 , ignoreEmpty

17 , ignoreBlank

18+ -- * Getting current element's properties

19+ , getCurrentName

20+ , getCurrentContent

21+ , getCurrentAttributes

22+ , getCurrentAttribute

23+ -- * Current element's checks

24+ , checkCurrentName

25+ -- * Parsing element's content

26+ , parseContent

27+ -- * Parsing attributes

28+ , parseAttribute

29+ , parseAttributeMaybe

18 ) where

30 ) where

20import Control.Lens

32import Control.Lens

33+import Control.Monad.Except

21import Control.Monad.Reader

34import Control.Monad.Reader

22import Data.Foldable as F

35import Data.Foldable as F

23import Data.List as L

36import Data.List as L

24import Data.List.NonEmpty (NonEmpty(..))

37import Data.List.NonEmpty (NonEmpty(..))

38+import Data.Map.Strict as M

39+import Data.Monoid

25import Data.Text as T

40import Data.Text as T

26import Data.Traversable

41import Data.Traversable

27import Text.XML

42import Text.XML

28−import Text.XML.DOM.Parser.Buildable

43+import Text.XML.DOM.Parser.Common

29import Text.XML.DOM.Parser.Types

44import Text.XML.DOM.Parser.Types

30import Text.XML.Lens

45import Text.XML.Lens

33−-- | Generic function to traverse arbitrary inner elements.

48+-- | Generic function to traverse arbitrary inner cursors.

34traverseElems

49traverseElems

35 :: (Monad m, Foldable g, Traversable f)

50 :: (Monad m, Foldable g, Traversable f)

36 => ([Element] -> DomParserT g m (f (DomPath, Element)))

51 => ([Element] -> DomParserT g m (f (DomPath, Element)))

37 -- ^ Takes list of current elements and returns container with

52 -- ^ Takes list of current elements and returns container with

38− -- pairs of subpath (relatively to current elements) and element

53+ -- pairs of subpath (relatively to current element) and element

39 -- to run parser in

54 -- to run parser in

40 -> DomParserT Identity m a

55 -> DomParserT Identity m a

41− -- ^ Parser to run for each element found in traversable 'f'

56+ -- ^ Parser will be runned for each element found in traversable

42 -> DomParserT g m (f a)

57 -> DomParserT g m (f a)

43traverseElems trav parser = do

58traverseElems trav parser = do

44 pd <- ask

59 pd <- ask

@@ -48,73 +63,68 @@ traverseElems trav parser = do

48 newpd = ParserData

63 newpd = ParserData

49 { _pdElements = Identity e

64 { _pdElements = Identity e

50 , _pdPath = pd ^. pdPath <> subpath }

65 , _pdPath = pd ^. pdPath <> subpath }

51− lift $ runReaderT parser newpd

66+ -- type of reader has been changed, local won't work here

67+ magnify (to $ const newpd) parser

53−-- | Traverses elements located in same path using filtering function

69+-- | Takes function filtering

54inFilteredTrav

70inFilteredTrav

55− :: (Monad m, Foldable g, Buildable f)

71+ :: (Monad m, Foldable g, DomTraversable f)

56 => ([Element] -> (DomPath, [Element]))

72 => ([Element] -> (DomPath, [Element]))

57− -- ^ Takes list of current elements and returns some descendants

73+ -- ^ Function returning some filtered elements with path suffixes which will

58− -- subset and path this descendants located at. Path is should be

74+ -- be appended to parser's state

59− -- same for all descendants and required for error message

60 -> DomParserT Identity m a

75 -> DomParserT Identity m a

61 -> DomParserT g m (f a)

76 -> DomParserT g m (f a)

62inFilteredTrav deeper = traverseElems trav

77inFilteredTrav deeper = traverseElems trav

63 where

78 where

64 trav e = do

79 trav e = do

65 let (path, elems) = deeper e

80 let (path, elems) = deeper e

66− case build elems of

81+ case buildDomTraversable elems of

67 Nothing -> throwParserError $ PENotFound . (<> path)

82 Nothing -> throwParserError $ PENotFound . (<> path)

68 Just tr -> return $ fmap (path,) tr

83 Just tr -> return $ fmap (path,) tr

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

85inElemTrav

75− :: (Monad m, Foldable g, Buildable f)

86+ :: (Monad m, Foldable g, DomTraversable f)

76− => ElemMatcher -- ^ Tag(s) matcher to traverse in

87+ => NameMatcher -- ^ Name of tag to traverse in

77 -> DomParserT Identity m a

88 -> DomParserT Identity m a

78 -> DomParserT g m (f a)

89 -> DomParserT g m (f a)

79inElemTrav n = inFilteredTrav deeper

90inElemTrav n = inFilteredTrav deeper

80 where

91 where

81− elemsFold = folded . nodes . folded . _Element . elMatch n

82− deeper = (DomPath [_emShow n],) . toListOf elemsFold

92+ deeper = (DomPath [_nmShow n],) . toListOf (folded . nodes . folded . _Element . elMatchName n)

84−-- | Runs parser inside first children element matched by macher

94+-- | Runs parser inside first children element with given name

85inElem

95inElem

86 :: (Monad m, Foldable g)

96 :: (Monad m, Foldable g)

87− => ElemMatcher

97+ => NameMatcher

88 -> DomParserT Identity m a

98 -> DomParserT Identity m a

89 -> DomParserT g m a

99 -> DomParserT g m a

90inElem n = fmap runIdentity . inElemTrav n

100inElem n = fmap runIdentity . inElemTrav n

101

92inElemAll

102inElemAll

93 :: (Monad m, Foldable g)

103 :: (Monad m, Foldable g)

94− => ElemMatcher

104+ => NameMatcher

95 -> DomParserT Identity m a

105 -> DomParserT Identity m a

96 -> DomParserT g m [a]

106 -> DomParserT g m [a]

97inElemAll = inElemTrav

107inElemAll = inElemTrav

108

99inElemMay

109inElemMay

100 :: (Monad m, Foldable g)

110 :: (Monad m, Foldable g)

101− => ElemMatcher

111+ => NameMatcher

102 -> DomParserT Identity m a

112 -> DomParserT Identity m a

103 -> DomParserT g m (Maybe a)

113 -> DomParserT g m (Maybe a)

104inElemMay = inElemTrav

114inElemMay = inElemTrav

105

115

106inElemNe

116inElemNe

107 :: (Monad m, Foldable g)

117 :: (Monad m, Foldable g)

108− => ElemMatcher

118+ => NameMatcher

109 -> DomParserT Identity m a

119 -> DomParserT Identity m a

110 -> DomParserT g m (NonEmpty a)

120 -> DomParserT g m (NonEmpty a)

111inElemNe = inElemTrav

121inElemNe = inElemTrav

112

122

113{- | Dive given parser's current tags set into the given path. The @divePath

123{- | 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

124+["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

125will 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

126behaviour 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

127+to pull tags in some path. The other difference is in traversing inner

118elements. Consider this code

128elements. Consider this code

119

129

120@

130@

@@ -132,31 +142,26 @@ which translates like: @a > b > c > fromDom@

132As you can see, inElem always takes first element and runs inner parser in this

142As 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

143single element, unlike 'divePath' which runs inner parser @in all@ descendants

134in given path.

144in 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-}

145-}

141

146

142divePath

147divePath

143 :: forall m g a

148 :: forall m g a

144 . (Monad m, Foldable g)

149 . (Monad m, Foldable g)

145− => [ElemMatcher]

150+ => [NameMatcher]

146 -> DomParserT [] m a

151 -> DomParserT [] m a

147 -> DomParserT g m a

152 -> DomParserT g m a

148divePath path = magnify $ to modElems

153divePath path = magnify $ to modElems

149 where

154 where

150 modElems

155 modElems

151 = over pdElements (toListOf $ folded . diver)

156 = over pdElements (toListOf $ folded . diver)

152− . over pdPath (<> DomPath (L.map _emShow path))

157+ . over pdPath (<> DomPath (L.map _nmShow path))

153 diver :: Fold Element Element

158 diver :: Fold Element Element

154 diver = F.foldr (.) id $ L.map toDive path

159 diver = F.foldr (.) id $ L.map toDive path

155− toDive n = nodes . folded . _Element . elMatch n

160+ toDive n = nodes . folded . _Element . elMatchName n

156

161

157diveElem

162diveElem

158 :: (Monad m, Foldable g)

163 :: (Monad m, Foldable g)

159− => ElemMatcher

164+ => NameMatcher

160 -> DomParserT [] m a

165 -> DomParserT [] m a

161 -> DomParserT g m a

166 -> DomParserT g m a

162diveElem p = divePath [p]

167diveElem p = divePath [p]

@@ -197,6 +202,109 @@ ignoreBlank = ignoreElem test

197 let

202 let

198 elems = e ^.. nodes . folded . _Element

203 elems = e ^.. nodes . folded . _Element

199 cont = mconcat $ e ^.. nodes . folded . _Content

204 cont = mconcat $ e ^.. nodes . folded . _Content

200− in if | not $ L.null elems -> False

205+ in if | not $ L.null elems -> False

201 | T.null $ T.strip cont -> True

206 | T.null $ T.strip cont -> True

202 | otherwise -> False

207 | otherwise -> False

208+

209+-- | Returns name of current element.

210+--

211+-- @since 1.0.0

212+getCurrentName :: (Monad m) => DomParserT Identity m Name

213+getCurrentName = view $ pdElements . to runIdentity . name

214+

215+-- | If name of current tag differs from first argument throws 'PENotFound' with

216+-- tag name replaced in last path's segment. Useful for checking root

217+-- document's element name.

218+checkCurrentName

219+ :: (Monad m)

220+ => NameMatcher

221+ -> DomParserT Identity m ()

222+checkCurrentName n = do

223+ cn <- getCurrentName

224+ unless ((n ^. nmMatch) cn) $ do

225+ p <- view pdPath

226+ let pinit = if L.null (unDomPath p) then [] else L.init $ unDomPath p

227+ throwError $ ParserErrors [PENotFound $ DomPath $ pinit ++ [_nmShow n]]

228+ return ()

229+

230+-- | Get current content. If current element contains no content or

231+-- have inner elements then Nothing returned

232+--

233+-- @since 1.0.0

234+getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)

235+getCurrentContent = do

236+ nds <- view $ pdElements . to runIdentity . nodes

237+ let

238+ els :: [Element]

239+ els = nds ^.. folded . _Element

240+ conts :: [Text]

241+ conts = nds ^.. folded . _Content

242+ return $ if

243+ | not $ L.null els -> Nothing

244+ | L.null conts -> Nothing

245+ | otherwise -> Just $ mconcat conts

246+

247+-- | Parses content inside current tag. It expects current element set

248+-- consists of exactly ONE element. If current element does not

249+-- contains content or have other elements as childs then throws error

250+parseContent

251+ :: (Monad m)

252+ => (Text -> Either Text a)

253+ -- ^ Content parser, return error msg if value is not parsed

254+ -> DomParserT Identity m a

255+parseContent parse = getCurrentContent >>= \case

256+ Nothing -> throwParserError PEContentNotFound

257+ Just c -> case parse c of

258+ Left e -> throwParserError $ PEWrongFormat e

259+ Right a -> return a

260+

261+-- | Retuns map of attributes of current element

262+--

263+-- @since 1.0.0

264+getCurrentAttributes

265+ :: (Monad m)

266+ => DomParserT Identity m (M.Map Name Text)

267+getCurrentAttributes = view $ pdElements . to runIdentity . attrs

268+

269+-- | Returns element with given name or 'Nothing'

270+--

271+-- @since 1.0.0

272+getCurrentAttribute

273+ :: (Monad m)

274+ => NameMatcher

275+ -> DomParserT Identity m (Maybe Text)

276+getCurrentAttribute attrName

277+ = preview $ pdElements . to runIdentity . attrs . to M.toList

278+ . traversed . filtered (views _1 (attrName ^. nmMatch)) . _2

279+

280+-- | Parses attribute with given name, throws error if attribute is not found.

281+--

282+-- @since 1.0.0

283+parseAttribute

284+ :: (Monad m)

285+ => NameMatcher

286+ -- ^ Attribute name

287+ -> (Text -> Either Text a)

288+ -- ^ Attribute content parser

289+ -> DomParserT Identity m a

290+parseAttribute attrName parser =

291+ parseAttributeMaybe attrName parser >>= \case

292+ Nothing -> throwParserError $ PEAttributeNotFound attrName

293+ Just a -> return a

294+

295+-- | Parses attribute with given name.

296+--

297+-- @since 1.0.0

298+parseAttributeMaybe

299+ :: (Monad m)

300+ => NameMatcher

301+ -- ^ Attribute name

302+ -> (Text -> Either Text a)

303+ -- ^ Attribute content parser

304+ -> DomParserT Identity m (Maybe a)

305+parseAttributeMaybe attrName parser =

306+ getCurrentAttribute attrName >>= \case

307+ Nothing -> return Nothing

308+ Just aval -> case parser aval of

309+ Left err -> throwParserError $ PEAttributeWrongFormat attrName err

310+ Right a -> return $ Just a

src/Text/XML/DOM/Parser/Common.hsnew file+54

@@ -0,0 +1,54 @@

1+module Text.XML.DOM.Parser.Common where

3+import Data.Monoid

4+import Data.Text as T

5+import Data.Typeable

6+import Text.Read

9+-- | @since 1.0.0

10+readBool :: Text -> Either Text Bool

11+readBool t =

12+ let

13+ lowt = T.toLower $ T.strip t

14+ tvals = ["y", "yes", "t", "true", "1"]

15+ fvals = ["n", "no", "f", "false", "0"]

16+ in if

17+ | lowt `elem` tvals -> Right True

18+ | lowt `elem` fvals -> Right False

19+ | otherwise ->

20+ Left $ "Could not read " <> t <> " as Bool"

21+

22+-- | Expects text to be single character

23+--

24+-- @since 1.0.0

25+readChar :: Text -> Either Text Char

26+readChar t = case T.unpack $ T.strip t of

27+ [c] -> Right c

28+ _ -> Left "Should have exactly one non-blank character"

29+

30+-- | If reader returns 'Nothing' then resulting function returns 'Left

31+-- "error message"'

32+--

33+-- @since 1.0.0

34+maybeReadContent

35+ :: forall a

36+ . (Typeable a)

37+ => (Text -> Maybe a)

38+ -- ^ Content or attribute reader

39+ -> Text

40+ -- ^ Content or attribute value

41+ -> Either Text a

42+maybeReadContent f t = maybe (Left msg) Right $ f t

43+ where

44+ msg = "Not readable " <> n <> ": " <> t

45+ n = T.pack $ show $ typeRep (Proxy :: Proxy a)

46+

47+

48+-- | Tries to read given text to value using 'Read'. Useful to use

49+-- with 'parseContent' and 'parseAttribute'

50+readContent

51+ :: (Read a, Typeable a)

52+ => Text

53+ -> Either Text a

54+readContent = maybeReadContent $ readMaybe . T.unpack . T.strip

src/Text/XML/DOM/Parser/Content.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.hs+8−82

@@ -1,33 +1,14 @@

1module 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

4 ) where

19import Data.Fixed

6import Data.Fixed

20import Data.Scientific

7import Data.Scientific

21import Data.Text as T

8import Data.Text as T

22import Data.Typeable

9import Data.Typeable

23−import Data.Void

24−import Text.XML.DOM.Parser.Content

10+import Text.XML.DOM.Parser.Common

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

31class FromAttribute a where

12class FromAttribute a where

32 fromAttribute

13 fromAttribute

33 :: Text

14 :: Text

@@ -35,78 +16,23 @@ class FromAttribute a where

35 -> Either Text a

16 -> Either Text a

36 -- ^ Either error message or result

17 -- ^ Either error message or result

38−proxyFromAttribute

39− :: FromAttribute a

40− => Proxy a

41− -> Text

42− -> Either Text a

43−proxyFromAttribute _ = fromAttribute

44−

45instance FromAttribute () where

19instance FromAttribute () where

46− fromAttribute = unitFromAttribute

20+ fromAttribute _ = Right ()

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"

57instance FromAttribute Text where

22instance FromAttribute Text where

58− fromAttribute = textFromAttribute

23+ fromAttribute = Right

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

69instance FromAttribute Char where

25instance FromAttribute Char where

70− fromAttribute = charFromAttribute

26+ fromAttribute = readChar

71−

72−charFromAttribute :: Text -> Either Text Char

73−charFromAttribute = readChar

75instance FromAttribute Int where

28instance FromAttribute Int where

76− fromAttribute = intFromAttribute

29+ fromAttribute = readContent

77−

78−intFromAttribute :: Text -> Either Text Int

79−intFromAttribute = readContent

81instance FromAttribute Integer where

31instance FromAttribute Integer where

82− fromAttribute = integerFromAttribute

32+ fromAttribute = readContent

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

93instance (Typeable a, HasResolution a) => FromAttribute (Fixed a) where

34instance (Typeable a, HasResolution a) => FromAttribute (Fixed a) where

94− fromAttribute = fixedFromAttribute

35+ fromAttribute = readContent

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

108instance FromAttribute Scientific where

37instance FromAttribute Scientific where

109− fromAttribute = scientificFromAttribute

38+ fromAttribute = readContent

110−

111−scientificFromAttribute :: Text -> Either Text Scientific

112−scientificFromAttribute = readContent

src/Text/XML/DOM/Parser/FromDom.hs+65−42

@@ -4,14 +4,17 @@ module Text.XML.DOM.Parser.FromDom

4 , proxyFromDom

5 -- * Explicit methods for convenience

6 , elementFromDom

7+ , unionFromDom

7 , textFromDom

8 , textFromDom

8 , stringFromDom

9 , stringFromDom

9 , charFromDom

10 , charFromDom

11+ , readChar

10 , intFromDom

12 , intFromDom

11 , integerFromDom

13 , integerFromDom

12 , doubleFromDom

14 , doubleFromDom

13 , fixedFromDom

15 , fixedFromDom

14 , boolFromDom

16 , boolFromDom

17+ , readBool

15 , unitFromDom

18 , unitFromDom

16 , voidFromDom

19 , voidFromDom

17 , scientificFromDom

20 , scientificFromDom

@@ -20,13 +23,17 @@ module Text.XML.DOM.Parser.FromDom

20import Control.Applicative

23import Control.Applicative

21import Control.Lens

24import Control.Lens

22import Data.Fixed

25import Data.Fixed

26+import Data.Monoid

27+import Data.OpenUnion

23import Data.Scientific

28import Data.Scientific

24import Data.Text as T hiding (empty)

29import Data.Text as T hiding (empty)

25import Data.Typeable

30import Data.Typeable

26import Data.Void

31import Data.Void

27import Text.XML

32import Text.XML

28−import Text.XML.DOM.Parser.Content

33+import Text.XML.DOM.Parser.Combinators

34+import Text.XML.DOM.Parser.Common

29import Text.XML.DOM.Parser.Types

35import Text.XML.DOM.Parser.Types

36+import TypeFun.Data.List hiding (Union)

31proxyFromDom

38proxyFromDom

32 :: forall proxy m a

39 :: forall proxy m a

@@ -35,86 +42,102 @@ proxyFromDom

35 -> DomParserT Identity m a

42 -> DomParserT Identity m a

36proxyFromDom _ = fromDom

43proxyFromDom _ = fromDom

38−-- | Class of types which can be parsed from single XML element. The

45+-- | 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

46class FromDom a where

41 fromDom :: (Monad m) => DomParserT Identity m a

47 fromDom :: (Monad m) => DomParserT Identity m a

43instance FromDom () where

49instance FromDom () where

44 fromDom = unitFromDom

50 fromDom = unitFromDom

46−-- | Always successfully parses any DOM to @()@

47−unitFromDom :: (Monad m) => DomParserT Identity m ()

48−unitFromDom = pure ()

49−

50instance FromDom Void where

52instance FromDom Void where

51 fromDom = voidFromDom

53 fromDom = voidFromDom

53−-- | Never parses successfully. It is just 'empty'

54−voidFromDom :: (Monad m) => DomParserT Identity m Void

55−voidFromDom = empty

56−

57instance FromDom Text where

55instance FromDom Text where

58 fromDom = textFromDom

56 fromDom = textFromDom

60−textFromDom :: (Monad m) => DomParserT Identity m Text

61−textFromDom = parseContent Right

62−

63instance FromDom String where

58instance FromDom String where

64 fromDom = stringFromDom

59 fromDom = stringFromDom

66−stringFromDom :: (Monad m) => DomParserT Identity m String

67−stringFromDom = parseContent $ Right . T.unpack

68−

69instance FromDom Char where

61instance FromDom Char where

70 fromDom = charFromDom

62 fromDom = charFromDom

72−charFromDom :: (Monad m) => DomParserT Identity m Char

73−charFromDom = parseContent readChar

74−

75instance FromDom Int where

64instance FromDom Int where

76 fromDom = intFromDom

65 fromDom = intFromDom

78−intFromDom :: (Monad m) => DomParserT Identity m Int

79−intFromDom = parseContent readContent

80−

81instance FromDom Integer where

67instance FromDom Integer where

82 fromDom = integerFromDom

68 fromDom = integerFromDom

84−integerFromDom :: (Monad m) => DomParserT Identity m Integer

85−integerFromDom = parseContent readContent

86−

87instance FromDom Double where

70instance FromDom Double where

88 fromDom = doubleFromDom

71 fromDom = doubleFromDom

90−doubleFromDom :: (Monad m) => DomParserT Identity m Double

91−doubleFromDom = parseContent readContent

92−

93instance (HasResolution a, Typeable a) => FromDom (Fixed a) where

73instance (HasResolution a, Typeable a) => FromDom (Fixed a) where

94 fromDom = fixedFromDom

74 fromDom = fixedFromDom

96−fixedFromDom

97− :: (Monad m, Typeable a, HasResolution a)

98− => DomParserT Identity m (Fixed a)

99−fixedFromDom = parseContent readContent

100−

101instance FromDom Scientific where

76instance FromDom Scientific where

102 fromDom = scientificFromDom

77 fromDom = scientificFromDom

103

104−scientificFromDom :: Monad m => DomParserT Identity m Scientific

105−scientificFromDom = parseContent readContent

106−

107instance FromDom Bool where

79instance FromDom Bool where

108 fromDom = boolFromDom

80 fromDom = boolFromDom

109

110−-- | Expects content to be y, yes, t, true or 1 for True Values n, no,

82+instance FromDom (Union '[]) where

111−-- f, false or 0 for False. Case is not significant, blank characters

83+ fromDom = empty

112−-- are striped.

84+

113−boolFromDom :: (Monad m) => DomParserT Identity m Bool

85+instance

114−boolFromDom = parseContent readBool

86+ ( Typeable a, FromDom a, FromDom (Union as)

87+ , SubList as (a ': as) )

88+ => FromDom (Union (a ': as)) where

89+ -- fromDom :: forall m. (DomParserMonad m) => m a

90+ fromDom = (liftUnion <$> (proxyFromDom (Proxy :: Proxy a)))

91+ <|> (reUnion <$> (proxyFromDom (Proxy :: Proxy (Union as))))

115

116instance FromDom Element where

93instance FromDom Element where

117 fromDom = elementFromDom

94 fromDom = elementFromDom

118

119elementFromDom :: (Monad m) => DomParserT Identity m Element

96elementFromDom :: (Monad m) => DomParserT Identity m Element

120elementFromDom = view $ pdElements . to runIdentity

97elementFromDom = view $ pdElements . to runIdentity

98+

99+unionFromDom

100+ :: (Monad m, FromDom (Union as))

101+ => proxy as

102+ -> DomParserT Identity m (Union as)

103+unionFromDom _ = fromDom

104+

105+textFromDom :: (Monad m) => DomParserT Identity m Text

106+textFromDom = parseContent Right

107+

108+stringFromDom :: (Monad m) => DomParserT Identity m String

109+stringFromDom = parseContent $ Right . T.unpack

110+

111+charFromDom :: (Monad m) => DomParserT Identity m Char

112+charFromDom = parseContent readChar

113+

114+intFromDom :: (Monad m) => DomParserT Identity m Int

115+intFromDom = parseContent readContent

116+

117+integerFromDom :: (Monad m) => DomParserT Identity m Integer

118+integerFromDom = parseContent readContent

119+

120+doubleFromDom :: (Monad m) => DomParserT Identity m Double

121+doubleFromDom = parseContent readContent

122+

123+fixedFromDom

124+ :: (Monad m, Typeable a, HasResolution a)

125+ => DomParserT Identity m (Fixed a)

126+fixedFromDom = parseContent readContent

127+

128+scientificFromDom :: Monad m => DomParserT Identity m Scientific

129+scientificFromDom = parseContent readContent

130+

131+-- | Expects content to be y, yes, t, true or 1 for True value. n, no,

132+-- f, false or 0 for False value. Case is not significant, blank

133+-- characters are striped.

134+boolFromDom :: (Monad m) => DomParserT Identity m Bool

135+boolFromDom = parseContent readBool

136+

137+-- | Always successfully parses any DOM to @()@

138+unitFromDom :: (Monad m) => DomParserT Identity m ()

139+unitFromDom = pure ()

140+

141+-- | Never parses successfully. It is just 'mzero'

142+voidFromDom :: (Monad m) => DomParserT Identity m Void

143+voidFromDom = empty

src/Text/XML/DOM/Parser/Types.hs+53−82

@@ -1,17 +1,12 @@

1module Text.XML.DOM.Parser.Types

2− (-- * Element matching

2+ ( -- * Local name

3− ElemMatcher(..)

4− , emMatch

5− , emShow

6− , matchElemName

7− , elMatch

8− -- * Name matching

9− , NameMatcher(..)

3+ NameMatcher(..)

10 , nmMatch

4 , nmMatch

11 , nmShow

5 , nmShow

12 , matchName

6 , matchName

13 , matchLocalName

7 , matchLocalName

14 , matchCILocalName

8 , matchCILocalName

9+ , elMatchName

15 -- * Parser internals

10 -- * Parser internals

16 , DomPath(..)

11 , DomPath(..)

17 , ParserError(..)

12 , ParserError(..)

@@ -23,12 +18,15 @@ module Text.XML.DOM.Parser.Types

23 , ParserData(..)

18 , ParserData(..)

24 , pdElements

19 , pdElements

25 , pdPath

20 , pdPath

21+ -- * Parser type

26 , DomParserT

22 , DomParserT

27 , DomParser

23 , DomParser

28 , runDomParserT

24 , runDomParserT

29 , runDomParser

25 , runDomParser

30 -- * Auxiliary

26 -- * Auxiliary

27+ , DomTraversable(..)

31 , throwParserError

28 , throwParserError

29+ , throwWrongFormat

32 ) where

30 ) where

34import Control.Exception

32import Control.Exception

@@ -36,125 +34,73 @@ import Control.Lens

36import Control.Monad.Except

34import Control.Monad.Except

37import Control.Monad.Reader

35import Control.Monad.Reader

38import Data.CaseInsensitive as CI

36import Data.CaseInsensitive as CI

37+import Data.List.NonEmpty as NE

38+import Data.Maybe

39import Data.String

40import Data.Text as T

41import GHC.Generics (Generic)

42import Text.XML

43import Text.XML.Lens

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

45-- | Arbitrary name matcher. Match name any way you want, but

79-- considered to be used as comparator with some name with some rules

46-- considered to be used as comparator with some name with some rules

80−--

81−-- @since 2.0.0

82data NameMatcher = NameMatcher

47data NameMatcher = NameMatcher

83 { _nmMatch :: Name -> Bool

48 { _nmMatch :: Name -> Bool

84 -- ^ Name matching function, usually should be simple comparsion

49 -- ^ Name matching function, usually should be simple comparsion

85 -- function takin in account only local name or other components

50 -- function takin in account only local name or other components

86 -- of 'Name'

51 -- of 'Name'

87 , _nmShow :: Text

52 , _nmShow :: Text

88− -- ^ Field for 'Show' instance and bulding usefull errors

53+ -- ^ How to show the name matcher, since there is no 'Read'

54+ -- instance we can do it any way we want

89 }

55 }

91−-- | Instance use 'matchCILocalName' as most general and liberal

57+makeLenses ''NameMatcher

92−-- matching strategy (while XML is often malformed).

58+

93−--

94−-- @since 2.0.0

95instance IsString NameMatcher where

59instance IsString NameMatcher where

96 fromString = matchCILocalName . T.pack

60 fromString = matchCILocalName . T.pack

98instance Show NameMatcher where

62instance Show NameMatcher where

99 show = T.unpack . _nmShow

63 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

105matchLocalName :: Text -> NameMatcher

65matchLocalName :: Text -> NameMatcher

106matchLocalName tname = NameMatcher

66matchLocalName tname = NameMatcher

107 { _nmMatch = \n -> nameLocalName n == tname

67 { _nmMatch = \n -> nameLocalName n == tname

108 , _nmShow = tname

68 , _nmShow = tname

109 }

69 }

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

116matchCILocalName :: Text -> NameMatcher

71matchCILocalName :: Text -> NameMatcher

117matchCILocalName tname = NameMatcher

72matchCILocalName tname = NameMatcher

118 { _nmMatch = \n -> CI.mk (nameLocalName n) == CI.mk tname

73 { _nmMatch = \n -> CI.mk (nameLocalName n) == CI.mk tname

119 , _nmShow = tname

74 , _nmShow = tname

120 }

75 }

121

122−makeLenses ''NameMatcher

123−

124−-- | Makes matcher which match name by 'Eq' with given

125−--

126−-- @since 2.0.0

127matchName :: Name -> NameMatcher

77matchName :: Name -> NameMatcher

128matchName n = NameMatcher

78matchName n = NameMatcher

129 { _nmMatch = (== n)

79 { _nmMatch = (== n)

130 , _nmShow = nameLocalName n

80 , _nmShow = nameLocalName n

131 }

81 }

132

133−-- | Path some element should be found at. Path starts from the root

83+elMatchName :: NameMatcher -> Traversal' Element Element

134−-- element of the document. Errors are much more usefull with path.

84+elMatchName nm = filtered (views name $ nm ^. nmMatch)

85+

135newtype DomPath = DomPath

86newtype DomPath = DomPath

136 { unDomPath :: [Text]

87 { unDomPath :: [Text]

137− } deriving (Eq, Ord, Show, Semigroup, Monoid)

88+ } deriving (Eq, Ord, Show, Monoid)

138

139-- | DOM parser error description.

90-- | DOM parser error description.

140data ParserError

91data ParserError

141 -- | Tag not found which should be.

92 -- | Tag not found which should be.

142 = PENotFound

93 = PENotFound

143 { _pePath :: DomPath

94 { _pePath :: DomPath

144− -- ^ Path of element error occured in

145 }

95 }

146

147− -- | Expected attribute but not found

97+ -- | Tag contents has wrong format, (could not read text to value)

148− --

98+ | PEWrongFormat

149− -- @since 1.0.0

99+ { _peDetails :: Text

150− | PEAttributeNotFound

151− { _peAttributeName :: NameMatcher

152− , _pePath :: DomPath

100+ , _pePath :: DomPath -- ^ path of element

153 }

101 }

154

102

155 -- | Could not parse attribute

103 -- | Could not parse attribute

156− --

157− -- @since 1.0.0

158 | PEAttributeWrongFormat

104 | PEAttributeWrongFormat

159 { _peAttributeName :: NameMatcher

105 { _peAttributeName :: NameMatcher

160 , _peDetails :: Text

106 , _peDetails :: Text

@@ -166,10 +112,10 @@ data ParserError

166 { _pePath :: DomPath

112 { _pePath :: DomPath

167 }

113 }

168

114

169− -- | Tag contents has wrong format, (could not read text to value)

115+ -- | Expected attribute but not found

170− | PEContentWrongFormat

116+ | PEAttributeNotFound

171− { _peDetails :: Text

117+ { _peAttributeName :: NameMatcher

172− , _pePath :: DomPath

118+ , _pePath :: DomPath

173 }

119 }

174

120

175 -- | Some other error

121 -- | Some other error

@@ -184,16 +130,15 @@ instance Exception ParserError

184

130

185newtype ParserErrors = ParserErrors

131newtype ParserErrors = ParserErrors

186 { unParserErrors :: [ParserError]

132 { unParserErrors :: [ParserError]

187− } deriving (Show, Semigroup, Monoid, Generic)

133+ } deriving (Show, Monoid, Generic)

188

134

189makePrisms ''ParserErrors

135makePrisms ''ParserErrors

190

136

191instance Exception ParserErrors

137instance Exception ParserErrors

192

138

193

139

194−{- | Parser scope.

195−

196−Functor argument is usually @Identity@ or @[]@.

140+{- | Parser scope parser runs in. Functor argument is usually @Identity@ or

141+@[]@.

197

142

198If functor is @Identity@ then parser expects exactly ONE current element. This

143If functor is @Identity@ then parser expects exactly ONE current element. This

199is common behavior for content parsers, or parsers expecting strict XML

144is common behavior for content parsers, or parsers expecting strict XML

@@ -239,6 +184,25 @@ runDomParser

239 -> Either ParserErrors a

184 -> Either ParserErrors a

240runDomParser doc par = runIdentity $ runDomParserT doc par

185runDomParser doc par = runIdentity $ runDomParserT doc par

241

186

187+-- | Class of traversable functors which may be constructed from list. Or may

188+-- not.

189+class Traversable f => DomTraversable f where

190+ -- | If method return Nothing this means we can not build traversable from

191+ -- given list. In this case combinator should fail traversing.

192+ buildDomTraversable :: [a] -> Maybe (f a)

193+

194+instance DomTraversable Identity where

195+ buildDomTraversable = fmap Identity . listToMaybe

196+

197+instance DomTraversable [] where

198+ buildDomTraversable = Just

199+

200+instance DomTraversable Maybe where

201+ buildDomTraversable = Just . listToMaybe

202+

203+instance DomTraversable NonEmpty where

204+ buildDomTraversable = NE.nonEmpty

205+

242throwParserError

206throwParserError

243 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)

207 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)

244 => (DomPath -> ParserError)

208 => (DomPath -> ParserError)

@@ -246,3 +210,10 @@ throwParserError

246throwParserError mkerr = do

210throwParserError mkerr = do

247 path <- view pdPath

211 path <- view pdPath

248 throwError $ ParserErrors $ [mkerr path]

212 throwError $ ParserErrors $ [mkerr path]

213+

214+-- | Throw 'PEWrongFormat' as very common case

215+throwWrongFormat

216+ :: (MonadError ParserErrors m, MonadReader (ParserData f) m)

217+ => Text

218+ -> m a

219+throwWrongFormat err = throwParserError $ PEWrongFormat err

src/Text/XML/Soap.hsdeleted−46

@@ -1,46 +0,0 @@

1−module Text.XML.Soap where

2−

3−import Control.Lens

4−import Data.String

5−import Text.XML

6−import Text.XML.DOM.Parser

7−import Text.XML.Writer

8−

9−data XmlEnvelope h b = XmlEnvelope

10− { _xeHeader :: !(Maybe h)

11− , _xeBody :: !(Maybe b)

12− } deriving (Eq, Show)

13−

14−makeLenses ''XmlEnvelope

15−

16−xmlEnvelopeToDocument :: (ToXML h, ToXML b) => XmlEnvelope h b -> Document

17−xmlEnvelopeToDocument xe = doc

18− where

19− sname n = fromString $ "{http://schemas.xmlsoap.org/soap/envelope/}" <> n

20− doc =

21− Document

22− { documentPrologue = Prologue [] Nothing []

23− , documentRoot =

24− Element

25− { elementName = sname "Envelope"

26− , elementAttributes = mempty

27− , elementNodes = [NodeElement header, NodeElement body]

28− }

29− , documentEpilogue = []

30− }

31− header =

32− Element

33− { elementName = sname "Header"

34− , elementAttributes = mempty

35− , elementNodes = render . toXML $ xe ^. xeHeader

36− }

37− body =

38− Element

39− { elementName = sname "Body"

40− , elementAttributes = mempty

41− , elementNodes = render . toXML $ xe ^. xeBody

42− }

43−

44−instance (FromDom h, FromDom b) => FromDom (XmlEnvelope h b) where

45− fromDom = XmlEnvelope <$> inElemMay "Header" fromDom

46− <*> inElemMay "Body" fromDom

stack.yamlmode 120000 → 100644+6−1

@@ -1 +0,0 @@

1−ghc-963.yaml

@@ -0,0 +1,6 @@

1+packages:

2+ - .

3+extra-deps:

4+ - open-union-0.2.0.0

5+ - type-fun-0.1.1

6+resolver: lts-6.25