master..467a733 · typeable/dom-parser

git.iko.soy/typeable/dom-parser

on 467a733 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+10−11

@@ -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,26 @@ 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

62 , Text.XML.DOM.Parser.Content

63 , Text.XML.DOM.Parser.FromAttribute

64 , Text.XML.DOM.Parser.FromDom

65 , Text.XML.DOM.Parser.Types

66− , Text.XML.Soap

68test-suite test

67test-suite test

69 type: exitcode-stdio-1.0

68 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+1−3

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

1module Text.XML.DOM.Parser

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

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

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

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

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

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

@@ -8,7 +7,6 @@ module Text.XML.DOM.Parser

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

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

9 ) where

8 ) where

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

12import Text.XML.DOM.Parser.Buildable

10import Text.XML.DOM.Parser.Buildable

13import Text.XML.DOM.Parser.Combinators

11import Text.XML.DOM.Parser.Combinators

14import Text.XML.DOM.Parser.Content

12import Text.XML.DOM.Parser.Content

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/Combinators.hs+23−32

@@ -22,6 +22,7 @@ import Control.Monad.Reader

22import Data.Foldable as F

23import Data.List as L

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

25+import Data.Monoid

25import Data.Text as T

26import Data.Text as T

26import Data.Traversable

27import Data.Traversable

27import Text.XML

28import Text.XML

@@ -30,15 +31,15 @@ import Text.XML.DOM.Parser.Types

30import Text.XML.Lens

31import Text.XML.Lens

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

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

34traverseElems

35traverseElems

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

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

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

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

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

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

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

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

39 -- to run parser in

40 -- to run parser in

40 -> DomParserT Identity m a

41 -> DomParserT Identity m a

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

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

42 -> DomParserT g m (f a)

43 -> DomParserT g m (f a)

43traverseElems trav parser = do

44traverseElems trav parser = do

44 pd <- ask

45 pd <- ask

@@ -48,15 +49,15 @@ traverseElems trav parser = do

48 newpd = ParserData

49 newpd = ParserData

49 { _pdElements = Identity e

50 { _pdElements = Identity e

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

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

51− lift $ runReaderT parser newpd

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

53+ magnify (to $ const newpd) parser

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

55+-- | Takes function filtering

54inFilteredTrav

56inFilteredTrav

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

57 :: (Monad m, Foldable g, Buildable f)

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

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

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

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

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

60+ -- be appended to parser's state. The argument is a list of current elements.

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

60 -> DomParserT Identity m a

61 -> DomParserT Identity m a

61 -> DomParserT g m (f a)

62 -> DomParserT g m (f a)

62inFilteredTrav deeper = traverseElems trav

63inFilteredTrav deeper = traverseElems trav

@@ -67,54 +68,49 @@ inFilteredTrav deeper = traverseElems trav

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

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

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

69 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

71inElemTrav

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

72 :: (Monad m, Foldable g, Buildable f)

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

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

77 -> DomParserT Identity m a

74 -> DomParserT Identity m a

78 -> DomParserT g m (f a)

75 -> DomParserT g m (f a)

79inElemTrav n = inFilteredTrav deeper

76inElemTrav n = inFilteredTrav deeper

80 where

77 where

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

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

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

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

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

85inElem

81inElem

86 :: (Monad m, Foldable g)

82 :: (Monad m, Foldable g)

87− => ElemMatcher

83+ => NameMatcher

88 -> DomParserT Identity m a

84 -> DomParserT Identity m a

89 -> DomParserT g m a

85 -> DomParserT g m a

90inElem n = fmap runIdentity . inElemTrav n

86inElem n = fmap runIdentity . inElemTrav n

92inElemAll

88inElemAll

93 :: (Monad m, Foldable g)

89 :: (Monad m, Foldable g)

94− => ElemMatcher

90+ => NameMatcher

95 -> DomParserT Identity m a

91 -> DomParserT Identity m a

96 -> DomParserT g m [a]

92 -> DomParserT g m [a]

97inElemAll = inElemTrav

93inElemAll = inElemTrav

99inElemMay

95inElemMay

100 :: (Monad m, Foldable g)

96 :: (Monad m, Foldable g)

101− => ElemMatcher

97+ => NameMatcher

102 -> DomParserT Identity m a

98 -> DomParserT Identity m a

103 -> DomParserT g m (Maybe a)

99 -> DomParserT g m (Maybe a)

104inElemMay = inElemTrav

100inElemMay = inElemTrav

105

101

106inElemNe

102inElemNe

107 :: (Monad m, Foldable g)

103 :: (Monad m, Foldable g)

108− => ElemMatcher

104+ => NameMatcher

109 -> DomParserT Identity m a

105 -> DomParserT Identity m a

110 -> DomParserT g m (NonEmpty a)

106 -> DomParserT g m (NonEmpty a)

111inElemNe = inElemTrav

107inElemNe = inElemTrav

112

108

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

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

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

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

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

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

118elements. Consider this code

114elements. Consider this code

119

115

120@

116@

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

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

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

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

134in given path.

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

131-}

141

132

142divePath

133divePath

143 :: forall m g a

134 :: forall m g a

144 . (Monad m, Foldable g)

135 . (Monad m, Foldable g)

145− => [ElemMatcher]

136+ => [NameMatcher]

146 -> DomParserT [] m a

137 -> DomParserT [] m a

147 -> DomParserT g m a

138 -> DomParserT g m a

148divePath path = magnify $ to modElems

139divePath path = magnify $ to modElems

149 where

140 where

150 modElems

141 modElems

151 = over pdElements (toListOf $ folded . diver)

142 = over pdElements (toListOf $ folded . diver)

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

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

153 diver :: Fold Element Element

144 diver :: Fold Element Element

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

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

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

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

156

147

157diveElem

148diveElem

158 :: (Monad m, Foldable g)

149 :: (Monad m, Foldable g)

159− => ElemMatcher

150+ => NameMatcher

160 -> DomParserT [] m a

151 -> DomParserT [] m a

161 -> DomParserT g m a

152 -> DomParserT g m a

162diveElem p = divePath [p]

153diveElem p = divePath [p]

@@ -197,6 +188,6 @@ ignoreBlank = ignoreElem test

197 let

188 let

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

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

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

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

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

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

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

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

202 | otherwise -> False

193 | otherwise -> False

src/Text/XML/DOM/Parser/Content.hs+118−63

@@ -1,44 +1,84 @@

1module Text.XML.DOM.Parser.Content

2− (

2+ ( -- * Content readers

3− -- * Parsing element's content

3+ readBool

4− parseContent

4+ , readChar

5+ -- ** Reader constructors

6+ , maybeReadContent

7+ , readContent

5 -- * Getting current element's properties

8 -- * Getting current element's properties

6 , getCurrentName

9 , getCurrentName

7 , getCurrentContent

10 , getCurrentContent

11+ , getCurrentAttributes

12+ , getCurrentAttribute

8 , checkCurrentName

13 , checkCurrentName

9− -- * Internal

14+ -- * Parsing element's content

10− , maybeReadContent

15+ , parseContent

11− , readContent

16+ -- * Parsing attributes

12− , readBool

17+ , parseAttribute

13− , readChar

18+ , parseAttributeMaybe

14 ) where

19 ) where

16import Control.Lens

21import Control.Lens

17import Control.Monad

22import Control.Monad

18import Control.Monad.Except

23import Control.Monad.Except

19import Data.List as L

24import Data.List as L

25+import Data.Map.Strict as M

20import Data.Monoid

26import Data.Monoid

21import Data.Text as T

27import Data.Text as T

22import Data.Typeable

28import Data.Typeable

23−import Prelude as P

24import Text.Read

29import Text.Read

25import Text.XML.DOM.Parser.Types

30import Text.XML.DOM.Parser.Types

26import Text.XML.Lens

31import Text.XML.Lens

29−-- | Parses content inside current tag. It expects current element set

34+-- | @since 1.0.0

30−-- consists of exactly ONE element.

31−parseContent

32− :: (Monad m)

33− => (Text -> Either Text a)

35+readBool :: Text -> Either Text Bool

34− -- ^ Content parser, return error msg if value is not parsed

36+readBool t =

35− -> DomParserT Identity m a

37+ let

36−parseContent parse = getCurrentContent >>= \case

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

37− Nothing -> throwParserError PEContentNotFound

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

38− Just c -> case parse c of

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

39− Left e -> throwParserError $ PEContentWrongFormat e

41+ in if

40− Right a -> return a

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

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

44+ | otherwise ->

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

47+-- | Expects text to be single character

48+--

49+-- @since 1.0.0

50+readChar :: Text -> Either Text Char

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

52+ [c] -> Right c

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

54+

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

56+-- "error message"'. 'Typeable' is used for generating usefull error

57+-- message.

58+--

59+-- @since 1.0.0

60+maybeReadContent

61+ :: forall a

62+ . (Typeable a)

63+ => (Text -> Maybe a)

64+ -- ^ Content or attribute reader

65+ -> Text

66+ -- ^ Content or attribute value

67+ -> Either Text a

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

69+ where

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

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

72+

73+

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

75+-- with 'parseContent' and 'parseAttribute'. Content is stripped

76+-- before reading.

77+readContent

78+ :: (Read a, Typeable a)

79+ => Text

80+ -> Either Text a

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

43-- | Returns name of current element.

83-- | Returns name of current element.

44--

84--

@@ -78,52 +118,67 @@ getCurrentContent = do

78 | L.null conts -> Nothing

118 | L.null conts -> Nothing

79 | otherwise -> Just $ mconcat conts

119 | otherwise -> Just $ mconcat conts

120

81−-- | If reader returns 'Nothing' then resulting function returns 'Left

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

82−-- "error message"'. 'Typeable' is used for generating usefull error

122+-- consists of exactly ONE element.

83−-- message.

123+parseContent

124+ :: (Monad m)

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

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

127+ -> DomParserT Identity m a

128+parseContent parse = getCurrentContent >>= \case

129+ Nothing -> throwParserError PEContentNotFound

130+ Just c -> case parse c of

131+ Left e -> throwParserError $ PEWrongFormat e

132+ Right a -> return a

133+

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

84--

135--

85-- @since 1.0.0

136-- @since 1.0.0

86−maybeReadContent

137+getCurrentAttributes

87− :: forall a

138+ :: (Monad m)

88− . (Typeable a)

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

89− => (Text -> Maybe a)

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

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

141

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

143+--

144+-- @since 1.0.0

145+getCurrentAttribute

146+ :: (Monad m)

147+ => NameMatcher

148+ -> DomParserT Identity m (Maybe Text)

149+getCurrentAttribute attrName

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

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

109

152

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

154+--

110−-- | @since 1.0.0

155+-- @since 1.0.0

156+parseAttribute

157+ :: (Monad m)

158+ => NameMatcher

159+ -- ^ Attribute name

111−readBool :: Text -> Either Text Bool

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

112−readBool t =

161+ -- ^ Attribute content parser

113− let

162+ -> DomParserT Identity m a

114− lowt = T.toLower $ T.strip t

163+parseAttribute attrName parser =

115− tvals = ["y", "yes", "t", "true", "1"]

164+ parseAttributeMaybe attrName parser >>= \case

116− fvals = ["n", "no", "f", "false", "0"]

165+ Nothing -> throwParserError $ PEAttributeNotFound attrName

117− in if

166+ Just a -> return a

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

167

123−-- | Expects text to be single character

168+-- | Parses attribute with given name. Returns Nothing if attribute is

169+-- not found.

124--

170--

125-- @since 1.0.0

171-- @since 1.0.0

172+parseAttributeMaybe

173+ :: (Monad m)

174+ => NameMatcher

175+ -- ^ Attribute name

126−readChar :: Text -> Either Text Char

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

127−readChar t = case T.unpack $ T.strip t of

177+ -- ^ Attribute content parser

128− [c] -> Right c

178+ -> DomParserT Identity m (Maybe a)

129− _ -> Left "Should have exactly one non-blank character"

179+parseAttributeMaybe attrName parser =

180+ getCurrentAttribute attrName >>= \case

181+ Nothing -> return Nothing

182+ Just aval -> case parser aval of

183+ Left err -> throwParserError $ PEAttributeWrongFormat attrName err

184+ Right a -> return $ Just a

src/Text/XML/DOM/Parser/FromAttribute.hs−2

@@ -26,8 +26,6 @@ import Text.XML.DOM.Parser.Content

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

29class FromAttribute a where

32 fromAttribute

30 fromAttribute

33 :: Text

31 :: Text

src/Text/XML/DOM/Parser/FromDom.hs+21−2

@@ -4,6 +4,7 @@ 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

@@ -20,6 +21,7 @@ module Text.XML.DOM.Parser.FromDom

20import Control.Applicative

21import Control.Applicative

21import Control.Lens

22import Control.Lens

22import Data.Fixed

23import Data.Fixed

24+import Data.OpenUnion

23import Data.Scientific

25import Data.Scientific

24import Data.Text as T hiding (empty)

26import Data.Text as T hiding (empty)

25import Data.Typeable

27import Data.Typeable

@@ -27,6 +29,7 @@ import Data.Void

27import Text.XML

29import Text.XML

28import Text.XML.DOM.Parser.Content

30import Text.XML.DOM.Parser.Content

29import Text.XML.DOM.Parser.Types

31import Text.XML.DOM.Parser.Types

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

31proxyFromDom

34proxyFromDom

32 :: forall proxy m a

35 :: forall proxy m a

@@ -35,8 +38,7 @@ proxyFromDom

35 -> DomParserT Identity m a

38 -> DomParserT Identity m a

36proxyFromDom _ = fromDom

39proxyFromDom _ = fromDom

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

@@ -113,6 +115,23 @@ instance FromDom Bool where

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

115boolFromDom :: (Monad m) => DomParserT Identity m Bool

114boolFromDom = parseContent readBool

116boolFromDom = parseContent readBool

115

117

118+instance FromDom (Union '[]) where

119+ fromDom = empty

120+

121+instance

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

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

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

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

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

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

128+

129+unionFromDom

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

131+ => proxy as

132+ -> DomParserT Identity m (Union as)

133+unionFromDom _ = fromDom

134+

116instance FromDom Element where

135instance FromDom Element where

117 fromDom = elementFromDom

136 fromDom = elementFromDom

118

137

src/Text/XML/DOM/Parser/Types.hs+22−75

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

1module Text.XML.DOM.Parser.Types

2− (-- * Element matching

3− ElemMatcher(..)

4− , emMatch

5− , emShow

6− , matchElemName

7− , elMatch

8− -- * Name matching

2+ ( -- * 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(..)

@@ -42,56 +37,20 @@ import GHC.Generics (Generic)

42import Text.XML

37import Text.XML

43import Text.XML.Lens

38import 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

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

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

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

80−--

81−-- @since 2.0.0

82data NameMatcher = NameMatcher

42data NameMatcher = NameMatcher

83 { _nmMatch :: Name -> Bool

43 { _nmMatch :: Name -> Bool

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

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

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

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

86 -- of 'Name'

46 -- of 'Name'

87 , _nmShow :: Text

47 , _nmShow :: Text

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

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

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

89 }

50 }

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

52+makeLenses ''NameMatcher

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

53+

93−--

94−-- @since 2.0.0

95instance IsString NameMatcher where

54instance IsString NameMatcher where

96 fromString = matchCILocalName . T.pack

55 fromString = matchCILocalName . T.pack

@@ -100,8 +59,6 @@ instance Show NameMatcher where

100

101-- | Makes matcher which matches only local part of name igoring

60-- | Makes matcher which matches only local part of name igoring

102-- namespace and prefix. Local name matching is case sensitive.

61-- namespace and prefix. Local name matching is case sensitive.

103−--

104−-- @since 2.0.0

105matchLocalName :: Text -> NameMatcher

62matchLocalName :: Text -> NameMatcher

106matchLocalName tname = NameMatcher

63matchLocalName tname = NameMatcher

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

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

@@ -111,30 +68,25 @@ matchLocalName tname = NameMatcher

111-- | Makes matcher which matches only local part of name igoring

68-- | Makes matcher which matches only local part of name igoring

112-- namespace and prefix. Local name matching is case insensitive. This

69-- namespace and prefix. Local name matching is case insensitive. This

113-- is the most common case.

70-- 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

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

125−--

126−-- @since 2.0.0

127matchName :: Name -> NameMatcher

78matchName :: Name -> NameMatcher

128matchName n = NameMatcher

79matchName n = NameMatcher

129 { _nmMatch = (== n)

80 { _nmMatch = (== n)

130 , _nmShow = nameLocalName n

81 , _nmShow = nameLocalName n

131 }

82 }

132

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

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

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

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

86+

135newtype DomPath = DomPath

87newtype DomPath = DomPath

136 { unDomPath :: [Text]

88 { unDomPath :: [Text]

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

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

138

139-- | DOM parser error description.

91-- | DOM parser error description.

140data ParserError

92data ParserError

@@ -144,17 +96,13 @@ data ParserError

144 -- ^ Path of element error occured in

96 -- ^ Path of element error occured in

145 }

97 }

146

147− -- | Expected attribute but not found

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

148− --

100+ | PEWrongFormat

149− -- @since 1.0.0

101+ { _peDetails :: Text

150− | PEAttributeNotFound

151− { _peAttributeName :: NameMatcher

152− , _pePath :: DomPath

102+ , _pePath :: DomPath

153 }

103 }

154

104

155 -- | Could not parse attribute

105 -- | Could not parse attribute

156− --

157− -- @since 1.0.0

158 | PEAttributeWrongFormat

106 | PEAttributeWrongFormat

159 { _peAttributeName :: NameMatcher

107 { _peAttributeName :: NameMatcher

160 , _peDetails :: Text

108 , _peDetails :: Text

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

166 { _pePath :: DomPath

114 { _pePath :: DomPath

167 }

115 }

168

116

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

117+ -- | Expected attribute but not found

170− | PEContentWrongFormat

118+ | PEAttributeNotFound

171− { _peDetails :: Text

119+ { _peAttributeName :: NameMatcher

172− , _pePath :: DomPath

120+ , _pePath :: DomPath

173 }

121 }

174

122

175 -- | Some other error

123 -- | Some other error

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

184

132

185newtype ParserErrors = ParserErrors

133newtype ParserErrors = ParserErrors

186 { unParserErrors :: [ParserError]

134 { unParserErrors :: [ParserError]

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

135+ } deriving (Show, Monoid, Generic)

188

136

189makePrisms ''ParserErrors

137makePrisms ''ParserErrors

190

138

191instance Exception ParserErrors

139instance Exception ParserErrors

192

140

193

141

194−{- | Parser scope.

195−

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

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

143+@[]@.

197

144

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

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

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

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

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