b5da244...master · typeable/dom-parser

.travis.yml+7−5

since splitsnapshots

unifiedsplit

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

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

5language: 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+

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

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

8cache:

14cache:

9 directories:

15 directories:

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

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

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

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

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

23

29

24−install:

25−# Build dependencies

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

27−

28script:

30script:

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

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

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

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

CHANGELOG.md+44

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

1# CHANGELOG

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+

3## 1.0.0

45## 1.0.0

46+

4* Added support for parsing attributes

47* Added support for parsing attributes

5* Changed public interface for 'parseContent'

48* Changed public interface for 'parseContent'

6* Added useful functions

49* Added useful functions

7* Dropped unnecessary dependency from shakespeare

50* Dropped unnecessary dependency from shakespeare

8

51

9## 0.1.0

52## 0.1.0

53+

10* Public release

54* Public release

README.mdnew file+5

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

1+# dom-parser

2+

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

4+

5+Simple monadic DOM parser

dom-parser.cabal+13−11

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

1name: dom-parser

2−version: 1.0.0

2+version: 3.2.0

3synopsis: Simple monadic DOM parser

4license: MIT

5license-file: LICENSE

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

7maintainer: makeit@typeable.io

8category: XML

9build-type: Simple

10−extra-source-files: CHANGELOG.md

11cabal-version: >=1.10

10cabal-version: >=1.10

12−

13−extra-source-files: CHANGELOG.md

14−

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

11homepage: 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

16

17

17source-repository head

18source-repository head

18 type: git

19 type: git

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

43 , TypeFamilies

44 , TypeFamilies

44 , TypeOperators

45 , TypeOperators

45 , UndecidableInstances

46 , UndecidableInstances

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

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

47 , case-insensitive

48 , case-insensitive

48 , containers

49 , containers

49 , lens

50 , lens

50− , mtl

51+ , mtl < 2.3 || > 2.3

51− , open-union >= 0.2

52 , scientific

53− , semigroups

54 , text

53 , text

55 , transformers

54 , transformers

56− , type-fun

57 , xml-conduit

55 , xml-conduit

56+ , xml-conduit-writer

58 , xml-lens

57 , xml-lens

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

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

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

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

60 , Text.XML.DOM.Parser.Combinators

61 , Text.XML.DOM.Parser.Combinators

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

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

62 , Text.XML.DOM.Parser.FromAttribute

63 , Text.XML.DOM.Parser.FromAttribute

63 , Text.XML.DOM.Parser.FromDom

64 , Text.XML.DOM.Parser.FromDom

64 , Text.XML.DOM.Parser.Types

65 , Text.XML.DOM.Parser.Types

66+ , Text.XML.Soap

65

67

66test-suite test

68test-suite test

67 type: exitcode-stdio-1.0

69 type: exitcode-stdio-1.0

ghc-963.yamlnew file+7

@@ -0,0 +1,7 @@

1+resolver: lts-22.6

2+

3+extra-deps:

4+ - xml-conduit-writer-0.1.1.5

5+

6+nix:

7+ packages: [zlib]

src/Text/XML/DOM/Parser.hs+7−3

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

1module Text.XML.DOM.Parser

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

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

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

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

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

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

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

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

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

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

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

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

7 ) where

9 ) where

8

10

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

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

9import Text.XML.DOM.Parser.Combinators

13import Text.XML.DOM.Parser.Combinators

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

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

11import Text.XML.DOM.Parser.FromAttribute

15import Text.XML.DOM.Parser.FromAttribute

12import Text.XML.DOM.Parser.FromDom

16import Text.XML.DOM.Parser.FromDom

13import Text.XML.DOM.Parser.Types

17import Text.XML.DOM.Parser.Types

src/Text/XML/DOM/Parser/Attributes.hsnew file+64

@@ -0,0 +1,64 @@

1+module Text.XML.DOM.Parser.Attributes

2+ ( parseAttribute

3+ , parseAttributeMaybe

4+ , getCurrentAttributes

5+ , getCurrentAttribute

6+ ) where

7+

8+import Control.Lens

9+import Data.Map.Strict as M

10+import Data.Text as T

11+import Text.XML.DOM.Parser.Types

12+import Text.XML.Lens

13+

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

15+--

16+-- @since 1.0.0

17+parseAttribute

18+ :: (Monad m)

19+ => NameMatcher

20+ -- ^ Attribute name

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

22+ -- ^ Attribute content parser

23+ -> DomParserT Identity m a

24+parseAttribute attrName parser =

25+ parseAttributeMaybe attrName parser >>= \case

26+ Nothing -> throwParserError $ PEAttributeNotFound attrName

27+ Just a -> return a

28+

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

30+-- not found.

31+--

32+-- @since 1.0.0

33+parseAttributeMaybe

34+ :: (Monad m)

35+ => NameMatcher

36+ -- ^ Attribute name

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

38+ -- ^ Attribute content parser

39+ -> DomParserT Identity m (Maybe a)

40+parseAttributeMaybe attrName parser =

41+ getCurrentAttribute attrName >>= \case

42+ Nothing -> return Nothing

43+ Just aval -> case parser aval of

44+ Left err -> throwParserError $ PEAttributeWrongFormat attrName err

45+ Right a -> return $ Just a

46+

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

48+--

49+-- @since 1.0.0

50+getCurrentAttributes

51+ :: (Monad m)

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

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

54+

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

56+--

57+-- @since 1.0.0

58+getCurrentAttribute

59+ :: (Monad m)

60+ => NameMatcher

61+ -> DomParserT Identity m (Maybe Text)

62+getCurrentAttribute attrName

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

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

src/Text/XML/DOM/Parser/Buildable.hsnew file+26

@@ -0,0 +1,26 @@

1+module Text.XML.DOM.Parser.Buildable

2+ ( Buildable(..)

3+ ) where

4+

5+import Data.Functor.Identity

6+import Data.List.NonEmpty as NE

7+import Data.Maybe

8+

9+-- | Class of traversable functors which may be constructed from list

10+class Traversable f => Buildable f where

11+ -- | If method return Nothing this means we can not build

12+ -- traversable from given list. In this case 'inFilteredTrav' should

13+ -- fail traversing.

14+ build :: [a] -> Maybe (f a)

15+

16+instance Buildable Identity where

17+ build = fmap Identity . listToMaybe

18+

19+instance Buildable [] where

20+ build = Just

21+

22+instance Buildable Maybe where

23+ build = Just . listToMaybe

24+

25+instance Buildable NonEmpty where

26+ build = NE.nonEmpty

src/Text/XML/DOM/Parser/Combinators.hs+34−25

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

2 ( -- * Generic combinators to traverse descendants

3 traverseElems

4 , inFilteredTrav

5− -- * Using 'DomTraversable'

5+ -- * Using 'Buildable'

6 , inElemTrav

7 , inElem

8 , inElemAll

@@ -22,24 +22,23 @@ import Control.Monad.Reader

22import Data.Foldable as F

23import Data.List as L

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

25−import Data.Monoid

26import Data.Text as T

25import Data.Text as T

27import Data.Traversable

26import Data.Traversable

28import Text.XML

27import Text.XML

29−import Text.XML.DOM.Parser.Common

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

30import Text.XML.DOM.Parser.Types

29import Text.XML.DOM.Parser.Types

31import Text.XML.Lens

30import Text.XML.Lens

32

31

33

32

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

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

35traverseElems

34traverseElems

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

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

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

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

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

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

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

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

40 -- to run parser in

39 -- to run parser in

41 -> DomParserT Identity m a

40 -> DomParserT Identity m a

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

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

43 -> DomParserT g m (f a)

42 -> DomParserT g m (f a)

44traverseElems trav parser = do

43traverseElems trav parser = do

45 pd <- ask

44 pd <- ask

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

49 newpd = ParserData

48 newpd = ParserData

50 { _pdElements = Identity e

49 { _pdElements = Identity e

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

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

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

51+ lift $ runReaderT parser newpd

53− magnify (to $ const newpd) parser

54

52

55−-- | Takes function filtering

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

56inFilteredTrav

54inFilteredTrav

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

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

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

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

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

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

60− -- be appended to parser's state

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

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

61 -> DomParserT Identity m a

60 -> DomParserT Identity m a

62 -> DomParserT g m (f a)

61 -> DomParserT g m (f a)

63inFilteredTrav deeper = traverseElems trav

62inFilteredTrav deeper = traverseElems trav

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

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

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

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

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

70

69

70+-- | Runs parser arbitrary times, depending on 'Buildable' instance of

71+-- 'f'. For example if 'f' becomes 'NonEmpty' then 'inElemTrav' finds

72+-- @one or more@ elements matched by given 'ElemMatcher' and run

73+-- parser in each found element, then returns @NonEmpty a@ of results.

71inElemTrav

74inElemTrav

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

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

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

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

74 -> DomParserT Identity m a

77 -> DomParserT Identity m a

75 -> DomParserT g m (f a)

78 -> DomParserT g m (f a)

76inElemTrav n = inFilteredTrav deeper

79inElemTrav n = inFilteredTrav deeper

77 where

80 where

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

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

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

79

83

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

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

81inElem

85inElem

82 :: (Monad m, Foldable g)

86 :: (Monad m, Foldable g)

83− => NameMatcher

87+ => ElemMatcher

84 -> DomParserT Identity m a

88 -> DomParserT Identity m a

85 -> DomParserT g m a

89 -> DomParserT g m a

86inElem n = fmap runIdentity . inElemTrav n

90inElem n = fmap runIdentity . inElemTrav n

87

91

88inElemAll

92inElemAll

89 :: (Monad m, Foldable g)

93 :: (Monad m, Foldable g)

90− => NameMatcher

94+ => ElemMatcher

91 -> DomParserT Identity m a

95 -> DomParserT Identity m a

92 -> DomParserT g m [a]

96 -> DomParserT g m [a]

93inElemAll = inElemTrav

97inElemAll = inElemTrav

94

98

95inElemMay

99inElemMay

96 :: (Monad m, Foldable g)

100 :: (Monad m, Foldable g)

97− => NameMatcher

101+ => ElemMatcher

98 -> DomParserT Identity m a

102 -> DomParserT Identity m a

99 -> DomParserT g m (Maybe a)

103 -> DomParserT g m (Maybe a)

100inElemMay = inElemTrav

104inElemMay = inElemTrav

101

105

102inElemNe

106inElemNe

103 :: (Monad m, Foldable g)

107 :: (Monad m, Foldable g)

104− => NameMatcher

108+ => ElemMatcher

105 -> DomParserT Identity m a

109 -> DomParserT Identity m a

106 -> DomParserT g m (NonEmpty a)

110 -> DomParserT g m (NonEmpty a)

107inElemNe = inElemTrav

111inElemNe = inElemTrav

108

112

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

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

110−["a", "b"]@ differs from @inElem "a" . inElem "b"@. Namely the first variant

114+["a", "b"]@ differs from @inElem "a" $ inElem "b"@. Namely the first variant

111will not fail if occured tag "a" which does not contains tag "b". This

115will not fail if occured tag "a" which does not contains tag "b". This

112behaviour is desireable when you dont want to parse whole XML and just want

116behaviour is desireable when you dont want to parse whole XML and just want

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

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

114elements. Consider this code

118elements. Consider this code

115

119

116@

120@

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

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

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

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

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

130in given path.

134in given path.

135+

136+Note also that 'divePath' takes parser parameterized by @[]@ not by

137+'Identity'. This because when you dive using some path you will get a

138+list of found elements and all these elements will be @current@ for

139+parser.

131-}

140-}

132

141

133divePath

142divePath

134 :: forall m g a

143 :: forall m g a

135 . (Monad m, Foldable g)

144 . (Monad m, Foldable g)

136− => [NameMatcher]

145+ => [ElemMatcher]

137 -> DomParserT [] m a

146 -> DomParserT [] m a

138 -> DomParserT g m a

147 -> DomParserT g m a

139divePath path = magnify $ to modElems

148divePath path = magnify $ to modElems

140 where

149 where

141 modElems

150 modElems

142 = over pdElements (toListOf $ folded . diver)

151 = over pdElements (toListOf $ folded . diver)

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

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

144 diver :: Fold Element Element

153 diver :: Fold Element Element

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

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

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

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

147

156

148diveElem

157diveElem

149 :: (Monad m, Foldable g)

158 :: (Monad m, Foldable g)

150− => NameMatcher

159+ => ElemMatcher

151 -> DomParserT [] m a

160 -> DomParserT [] m a

152 -> DomParserT g m a

161 -> DomParserT g m a

153diveElem p = divePath [p]

162diveElem p = divePath [p]

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

188 let

197 let

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

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

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

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

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

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

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

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

193 | otherwise -> False

202 | otherwise -> False

src/Text/XML/DOM/Parser/Common.hs → src/Text/XML/DOM/Parser/Content.hsrenamed+64−139

@@ -1,105 +1,44 @@

1−module Text.XML.DOM.Parser.Common

1+module Text.XML.DOM.Parser.Content

2− ( -- * Buildable

2+ (

3− Buildable(..)

3+ -- * Parsing element's content

4− -- * Content readers

4+ parseContent

5− , readBool

6− , readChar

7− -- ** Reader constructors

8− , maybeReadContent

9− , readContent

10 -- * Getting current element's properties

5 -- * Getting current element's properties

11 , getCurrentName

6 , getCurrentName

12 , getCurrentContent

7 , getCurrentContent

13− , getCurrentAttributes

14− , getCurrentAttribute

15 , checkCurrentName

8 , checkCurrentName

16− -- * Parsing element's content

9+ -- * Internal

17− , parseContent

10+ , maybeReadContent

18− -- * Parsing attributes

11+ , readContent

19− , parseAttribute

12+ , readBool

20− , parseAttributeMaybe

13+ , readChar

21 ) where

14 ) where

22

15

23import Control.Lens

16import Control.Lens

24import Control.Monad

17import Control.Monad

25import Control.Monad.Except

18import Control.Monad.Except

26import Data.List as L

19import Data.List as L

27−import Data.List.NonEmpty as NE

28−import Data.Map.Strict as M

29−import Data.Maybe

30import Data.Monoid

20import Data.Monoid

31import Data.Text as T

21import Data.Text as T

32import Data.Typeable

22import Data.Typeable

23+import Prelude as P

33import Text.Read

24import Text.Read

34import Text.XML.DOM.Parser.Types

25import Text.XML.DOM.Parser.Types

35import Text.XML.Lens

26import Text.XML.Lens

36

27

37−-- | Class of traversable functors which may be constructed from list. Or may

38−-- not.

39−class Traversable f => Buildable f where

40− -- | If method return Nothing this means we can not build

41− -- traversable from given list. In this case 'inFilteredTrav' should

42− -- fail traversing.

43− build :: [a] -> Maybe (f a)

44−

45−instance Buildable Identity where

46− build = fmap Identity . listToMaybe

47−

48−instance Buildable [] where

49− build = Just

50−

51−instance Buildable Maybe where

52− build = Just . listToMaybe

53−

54−instance Buildable NonEmpty where

55− build = NE.nonEmpty

56−

57−-- | @since 1.0.0

58−readBool :: Text -> Either Text Bool

59−readBool t =

60− let

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

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

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

64− in if

65− | lowt `elem` tvals -> Right True

66− | lowt `elem` fvals -> Right False

67− | otherwise ->

68− Left $ "Could not read " <> t <> " as Bool"

69−

70−-- | Expects text to be single character

71−--

72−-- @since 1.0.0

73−readChar :: Text -> Either Text Char

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

75− [c] -> Right c

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

77−

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

79−-- "error message"'

80−--

81−-- @since 1.0.0

82−maybeReadContent

83− :: forall a

84− . (Typeable a)

85− => (Text -> Maybe a)

86− -- ^ Content or attribute reader

87− -> Text

88− -- ^ Content or attribute value

89− -> Either Text a

90−maybeReadContent f t = maybe (Left msg) Right $ f t

91− where

92− msg = "Not readable " <> n <> ": " <> t

93− n = T.pack $ show $ typeRep (Proxy :: Proxy a)

94

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

95

41

96−-- | Tries to read given text to value using 'Read'. Useful to use

97−-- with 'parseContent' and 'parseAttribute'

98−readContent

99− :: (Read a, Typeable a)

100− => Text

101− -> Either Text a

102−readContent = maybeReadContent $ readMaybe . T.unpack . T.strip

103

42

104-- | Returns name of current element.

43-- | Returns name of current element.

105--

44--

@@ -139,66 +78,52 @@ getCurrentContent = do

139 | L.null conts -> Nothing

78 | L.null conts -> Nothing

140 | otherwise -> Just $ mconcat conts

79 | otherwise -> Just $ mconcat conts

141

80

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

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

143−-- consists of exactly ONE element.

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

144−parseContent

83+-- message.

145− :: (Monad m)

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

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

148− -> DomParserT Identity m a

149−parseContent parse = getCurrentContent >>= \case

150− Nothing -> throwParserError PEContentNotFound

151− Just c -> case parse c of

152− Left e -> throwParserError $ PEWrongFormat e

153− Right a -> return a

154−

155−-- | Retuns map of attributes of current element

156--

84--

157-- @since 1.0.0

85-- @since 1.0.0

158−getCurrentAttributes

86+maybeReadContent

159− :: (Monad m)

87+ :: forall a

160− => DomParserT Identity m (M.Map Name Text)

88+ . (Typeable a)

161−getCurrentAttributes = view $ pdElements . to runIdentity . attrs

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)

162

98

163−-- | Returns element with given name or 'Nothing'

164−--

165−-- @since 1.0.0

166−getCurrentAttribute

167− :: (Monad m)

168− => NameMatcher

169− -> DomParserT Identity m (Maybe Text)

170−getCurrentAttribute attrName

171− = preview $ pdElements . to runIdentity . attrs . to M.toList

172− . traversed . filtered (views _1 (attrName ^. nmMatch)) . _2

173

99

174−-- | Parses attribute with given name, throws error if attribute is not found.

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

175−--

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

176−-- @since 1.0.0

102+-- before reading.

177−parseAttribute

103+readContent

178− :: (Monad m)

104+ :: (Read a, Typeable a)

179− => NameMatcher

105+ => Text

180− -- ^ Attribute name

181− -> (Text -> Either Text a)

106+ -> Either Text a

182− -- ^ Attribute content parser

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

183− -> DomParserT Identity m a

184−parseAttribute attrName parser =

185− parseAttributeMaybe attrName parser >>= \case

186− Nothing -> throwParserError $ PEAttributeNotFound attrName

187− Just a -> return a

188

108

189−-- | Parses attribute with given name.

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

190--

124--

191-- @since 1.0.0

125-- @since 1.0.0

192−parseAttributeMaybe

193− :: (Monad m)

194− => NameMatcher

195− -- ^ Attribute name

196− -> (Text -> Either Text a)

126+readChar :: Text -> Either Text Char

197− -- ^ Attribute content parser

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

198− -> DomParserT Identity m (Maybe a)

128+ [c] -> Right c

199−parseAttributeMaybe attrName parser =

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

200− getCurrentAttribute attrName >>= \case

201− Nothing -> return Nothing

202− Just aval -> case parser aval of

203− Left err -> throwParserError $ PEAttributeWrongFormat attrName err

204− Right a -> return $ Just a

src/Text/XML/DOM/Parser/FromAttribute.hs+82−8

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

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

4 ) where

17 ) where

5

18

6import Data.Fixed

19import Data.Fixed

7import Data.Scientific

20import Data.Scientific

8import Data.Text as T

21import Data.Text as T

9import Data.Typeable

22import Data.Typeable

23+import Data.Void

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

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

11

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

12class FromAttribute a where

31class FromAttribute a where

13 fromAttribute

32 fromAttribute

14 :: Text

33 :: Text

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

16 -> Either Text a

35 -> Either Text a

17 -- ^ Either error message or result

36 -- ^ Either error message or result

18

37

38+proxyFromAttribute

39+ :: FromAttribute a

40+ => Proxy a

41+ -> Text

42+ -> Either Text a

43+proxyFromAttribute _ = fromAttribute

44+

19instance FromAttribute () where

45instance FromAttribute () where

20− fromAttribute _ = Right ()

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"

21

56

22instance FromAttribute Text where

57instance FromAttribute Text where

23− fromAttribute = Right

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

24

68

25instance FromAttribute Char where

69instance FromAttribute Char where

26− fromAttribute = readChar

70+ fromAttribute = charFromAttribute

71+

72+charFromAttribute :: Text -> Either Text Char

73+charFromAttribute = readChar

27

74

28instance FromAttribute Int where

75instance FromAttribute Int where

29− fromAttribute = readContent

76+ fromAttribute = intFromAttribute

77+

78+intFromAttribute :: Text -> Either Text Int

79+intFromAttribute = readContent

30

80

31instance FromAttribute Integer where

81instance FromAttribute Integer where

32− fromAttribute = readContent

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

33

92

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

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

35− fromAttribute = readContent

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

36

107

37instance FromAttribute Scientific where

108instance FromAttribute Scientific where

38− fromAttribute = readContent

109+ fromAttribute = scientificFromAttribute

110+

111+scientificFromAttribute :: Text -> Either Text Scientific

112+scientificFromAttribute = readContent

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

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

4 , proxyFromDom

5 -- * Explicit methods for convenience

6 , elementFromDom

7− , unionFromDom

8 , textFromDom

7 , textFromDom

9 , stringFromDom

8 , stringFromDom

10 , charFromDom

9 , charFromDom

11− , readChar

12 , intFromDom

10 , intFromDom

13 , integerFromDom

11 , integerFromDom

14 , doubleFromDom

12 , doubleFromDom

15 , fixedFromDom

13 , fixedFromDom

16 , boolFromDom

14 , boolFromDom

17− , readBool

18 , unitFromDom

15 , unitFromDom

19 , voidFromDom

16 , voidFromDom

20 , scientificFromDom

17 , scientificFromDom

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

23import Control.Applicative

20import Control.Applicative

24import Control.Lens

21import Control.Lens

25import Data.Fixed

22import Data.Fixed

26−import Data.OpenUnion

27import Data.Scientific

23import Data.Scientific

28import Data.Text as T hiding (empty)

24import Data.Text as T hiding (empty)

29import Data.Typeable

25import Data.Typeable

30import Data.Void

26import Data.Void

31import Text.XML

27import Text.XML

32−import Text.XML.DOM.Parser.Common

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

33import Text.XML.DOM.Parser.Types

29import Text.XML.DOM.Parser.Types

34−import TypeFun.Data.List hiding (Union)

35

30

36proxyFromDom

31proxyFromDom

37 :: forall proxy m a

32 :: forall proxy m a

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

40 -> DomParserT Identity m a

35 -> DomParserT Identity m a

41proxyFromDom _ = fromDom

36proxyFromDom _ = fromDom

42

37

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

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

39+-- method 'fromDom' is convenient default to use with 'inElem'

44class FromDom a where

40class FromDom a where

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

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

46

42

47instance FromDom () where

43instance FromDom () where

48 fromDom = unitFromDom

44 fromDom = unitFromDom

49

45

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

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

48+unitFromDom = pure ()

49+

50instance FromDom Void where

51 fromDom = voidFromDom

52

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

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

55+voidFromDom = empty

56+

53instance FromDom Text where

57instance FromDom Text where

54 fromDom = textFromDom

58 fromDom = textFromDom

55

59

56−instance FromDom String where

57− fromDom = stringFromDom

58−

59−instance FromDom Char where

60− fromDom = charFromDom

61−

62−instance FromDom Int where

63− fromDom = intFromDom

64−

65−instance FromDom Integer where

66− fromDom = integerFromDom

67−

68−instance FromDom Double where

69− fromDom = doubleFromDom

70−

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

72− fromDom = fixedFromDom

73−

74−instance FromDom Scientific where

75− fromDom = scientificFromDom

76−

77−instance FromDom Bool where

78− fromDom = boolFromDom

79−

80−instance FromDom (Union '[]) where

81− fromDom = empty

82−

83−instance

84− ( Typeable a, FromDom a, FromDom (Union as)

85− , SubList as (a ': as) )

86− => FromDom (Union (a ': as)) where

87− -- fromDom :: forall m. (DomParserMonad m) => m a

88− fromDom = (liftUnion <$> (proxyFromDom (Proxy :: Proxy a)))

89− <|> (reUnion <$> (proxyFromDom (Proxy :: Proxy (Union as))))

90−

91−instance FromDom Element where

92− fromDom = elementFromDom

93−

94−elementFromDom :: (Monad m) => DomParserT Identity m Element

95−elementFromDom = view $ pdElements . to runIdentity

96−

97−unionFromDom

98− :: (Monad m, FromDom (Union as))

99− => proxy as

100− -> DomParserT Identity m (Union as)

101−unionFromDom _ = fromDom

102−

103textFromDom :: (Monad m) => DomParserT Identity m Text

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

104textFromDom = parseContent Right

61textFromDom = parseContent Right

105

62

63+instance FromDom String where

64+ fromDom = stringFromDom

65+

106stringFromDom :: (Monad m) => DomParserT Identity m String

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

107stringFromDom = parseContent $ Right . T.unpack

67stringFromDom = parseContent $ Right . T.unpack

108

68

69+instance FromDom Char where

70+ fromDom = charFromDom

71+

109charFromDom :: (Monad m) => DomParserT Identity m Char

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

110charFromDom = parseContent readChar

73charFromDom = parseContent readChar

111

74

75+instance FromDom Int where

76+ fromDom = intFromDom

77+

112intFromDom :: (Monad m) => DomParserT Identity m Int

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

113intFromDom = parseContent readContent

79intFromDom = parseContent readContent

114

80

81+instance FromDom Integer where

82+ fromDom = integerFromDom

83+

115integerFromDom :: (Monad m) => DomParserT Identity m Integer

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

116integerFromDom = parseContent readContent

85integerFromDom = parseContent readContent

117

86

87+instance FromDom Double where

88+ fromDom = doubleFromDom

89+

118doubleFromDom :: (Monad m) => DomParserT Identity m Double

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

119doubleFromDom = parseContent readContent

91doubleFromDom = parseContent readContent

120

92

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

94+ fromDom = fixedFromDom

95+

121fixedFromDom

96fixedFromDom

122 :: (Monad m, Typeable a, HasResolution a)

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

123 => DomParserT Identity m (Fixed a)

98 => DomParserT Identity m (Fixed a)

124fixedFromDom = parseContent readContent

99fixedFromDom = parseContent readContent

125

100

101+instance FromDom Scientific where

102+ fromDom = scientificFromDom

103+

126scientificFromDom :: Monad m => DomParserT Identity m Scientific

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

127scientificFromDom = parseContent readContent

105scientificFromDom = parseContent readContent

128

106

107+instance FromDom Bool where

108+ fromDom = boolFromDom

109+

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

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

130−-- f, false or 0 for False value. Case is not significant, blank

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

131−-- characters are striped.

112+-- are striped.

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

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

133boolFromDom = parseContent readBool

114boolFromDom = parseContent readBool

134

115

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

116+instance FromDom Element where

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

117+ fromDom = elementFromDom

137−unitFromDom = pure ()

138

118

139−-- | Never parses successfully. It is just 'mzero'

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

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

141−voidFromDom = empty

120+elementFromDom = view $ pdElements . to runIdentity

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

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

1module Text.XML.DOM.Parser.Types

2+ (-- * Element matching

3+ ElemMatcher(..)

4+ , emMatch

5+ , emShow

6+ , matchElemName

7+ , elMatch

2− ( -- * Name matching

8+ -- * Name matching

3− NameMatcher(..)

9+ , NameMatcher(..)

4 , nmMatch

10 , nmMatch

5 , nmShow

11 , nmShow

6 , matchName

12 , matchName

7 , matchLocalName

13 , matchLocalName

8 , matchCILocalName

14 , matchCILocalName

9− , elMatchName

10 -- * Parser internals

15 -- * Parser internals

11 , DomPath(..)

16 , DomPath(..)

12 , ParserError(..)

17 , ParserError(..)

@@ -37,65 +42,119 @@ import GHC.Generics (Generic)

37import Text.XML

42import Text.XML

38import Text.XML.Lens

43import Text.XML.Lens

39

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+

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

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

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

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

80+--

81+-- @since 2.0.0

42data NameMatcher = NameMatcher

82data NameMatcher = NameMatcher

43 { _nmMatch :: Name -> Bool

83 { _nmMatch :: Name -> Bool

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

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

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

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

46 -- of 'Name'

86 -- of 'Name'

47 , _nmShow :: Text

87 , _nmShow :: Text

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

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

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

50 }

89 }

51

90

52−makeLenses ''NameMatcher

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

53−

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

93+--

94+-- @since 2.0.0

54instance IsString NameMatcher where

95instance IsString NameMatcher where

55 fromString = matchCILocalName . T.pack

96 fromString = matchCILocalName . T.pack

56

97

57instance Show NameMatcher where

98instance Show NameMatcher where

58 show = T.unpack . _nmShow

99 show = T.unpack . _nmShow

59

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

60matchLocalName :: Text -> NameMatcher

105matchLocalName :: Text -> NameMatcher

61matchLocalName tname = NameMatcher

106matchLocalName tname = NameMatcher

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

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

63 , _nmShow = tname

108 , _nmShow = tname

64 }

109 }

65

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

66matchCILocalName :: Text -> NameMatcher

116matchCILocalName :: Text -> NameMatcher

67matchCILocalName tname = NameMatcher

117matchCILocalName tname = NameMatcher

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

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

69 , _nmShow = tname

119 , _nmShow = tname

70 }

120 }

71

121

122+makeLenses ''NameMatcher

123+

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

125+--

126+-- @since 2.0.0

72matchName :: Name -> NameMatcher

127matchName :: Name -> NameMatcher

73matchName n = NameMatcher

128matchName n = NameMatcher

74 { _nmMatch = (== n)

129 { _nmMatch = (== n)

75 , _nmShow = nameLocalName n

130 , _nmShow = nameLocalName n

76 }

131 }

77

132

78−elMatchName :: NameMatcher -> Traversal' Element Element

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

79−elMatchName nm = filtered (views name $ nm ^. nmMatch)

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

80−

81newtype DomPath = DomPath

135newtype DomPath = DomPath

82 { unDomPath :: [Text]

136 { unDomPath :: [Text]

83− } deriving (Eq, Ord, Show, Monoid)

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

84

138

85-- | DOM parser error description.

139-- | DOM parser error description.

86data ParserError

140data ParserError

87 -- | Tag not found which should be.

141 -- | Tag not found which should be.

88 = PENotFound

142 = PENotFound

89 { _pePath :: DomPath

143 { _pePath :: DomPath

144+ -- ^ Path of element error occured in

90 }

145 }

91

146

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

147+ -- | Expected attribute but not found

93− | PEWrongFormat

148+ --

94− { _peDetails :: Text

149+ -- @since 1.0.0

150+ | PEAttributeNotFound

151+ { _peAttributeName :: NameMatcher

95− , _pePath :: DomPath -- ^ path of element

152+ , _pePath :: DomPath

96 }

153 }

97

154

98 -- | Could not parse attribute

155 -- | Could not parse attribute

156+ --

157+ -- @since 1.0.0

99 | PEAttributeWrongFormat

158 | PEAttributeWrongFormat

100 { _peAttributeName :: NameMatcher

159 { _peAttributeName :: NameMatcher

101 , _peDetails :: Text

160 , _peDetails :: Text

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

107 { _pePath :: DomPath

166 { _pePath :: DomPath

108 }

167 }

109

168

110− -- | Expected attribute but not found

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

111− | PEAttributeNotFound

170+ | PEContentWrongFormat

112− { _peAttributeName :: NameMatcher

171+ { _peDetails :: Text

113− , _pePath :: DomPath

172+ , _pePath :: DomPath

114 }

173 }

115

174

116 -- | Some other error

175 -- | Some other error

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

125

184

126newtype ParserErrors = ParserErrors

185newtype ParserErrors = ParserErrors

127 { unParserErrors :: [ParserError]

186 { unParserErrors :: [ParserError]

128− } deriving (Show, Monoid, Generic)

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

129

188

130makePrisms ''ParserErrors

189makePrisms ''ParserErrors

131

190

132instance Exception ParserErrors

191instance Exception ParserErrors

133

192

134

193

194+{- | Parser scope.

195+

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

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

136−@[]@.

137

197

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

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

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

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

src/Text/XML/Soap.hsnew file+46

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

1+module Text.XML.Soap where

2+

3+import Control.Lens

4+import Data.String

5+import Text.XML

6+import Text.XML.DOM.Parser

7+import Text.XML.Writer

8+

9+data XmlEnvelope h b = XmlEnvelope

10+ { _xeHeader :: !(Maybe h)

11+ , _xeBody :: !(Maybe b)

12+ } deriving (Eq, Show)

13+

14+makeLenses ''XmlEnvelope

15+

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

17+xmlEnvelopeToDocument xe = doc

18+ where

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

20+ doc =

21+ Document

22+ { documentPrologue = Prologue [] Nothing []

23+ , documentRoot =

24+ Element

25+ { elementName = sname "Envelope"

26+ , elementAttributes = mempty

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

28+ }

29+ , documentEpilogue = []

30+ }

31+ header =

32+ Element

33+ { elementName = sname "Header"

34+ , elementAttributes = mempty

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

36+ }

37+ body =

38+ Element

39+ { elementName = sname "Body"

40+ , elementAttributes = mempty

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

42+ }

43+

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

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

46+ <*> inElemMay "Body" fromDom

stack.yamlmode 100644 → 120000+1−6

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

1−packages:

2− - .

3−extra-deps:

4− - open-union-0.2.0.0

5− - type-fun-0.1.1

6−resolver: lts-6.25

@@ -0,0 +1 @@

1+ghc-963.yaml