7fb1685..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+11−10

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

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

66

67

67test-suite test

68test-suite test

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

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

1module Text.XML.DOM.Parser

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

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

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

3 , module Text.XML.DOM.Parser.Combinators

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

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

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

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

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

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

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

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

8 ) where

9 ) where

9

10

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

10import Text.XML.DOM.Parser.Buildable

12import Text.XML.DOM.Parser.Buildable

11import Text.XML.DOM.Parser.Combinators

13import Text.XML.DOM.Parser.Combinators

12import Text.XML.DOM.Parser.Content

14import Text.XML.DOM.Parser.Content

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

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

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

2+ ( parseAttribute

3+ , parseAttributeMaybe

4+ , getCurrentAttributes

5+ , getCurrentAttribute

6+ ) where

7+

8+import Control.Lens

9+import Data.Map.Strict as M

10+import Data.Text as T

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

12+import Text.XML.Lens

13+

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

15+--

16+-- @since 1.0.0

17+parseAttribute

18+ :: (Monad m)

19+ => NameMatcher

20+ -- ^ Attribute name

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

22+ -- ^ Attribute content parser

23+ -> DomParserT Identity m a

24+parseAttribute attrName parser =

25+ parseAttributeMaybe attrName parser >>= \case

26+ Nothing -> throwParserError $ PEAttributeNotFound attrName

27+ Just a -> return a

28+

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

30+-- not found.

31+--

32+-- @since 1.0.0

33+parseAttributeMaybe

34+ :: (Monad m)

35+ => NameMatcher

36+ -- ^ Attribute name

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

38+ -- ^ Attribute content parser

39+ -> DomParserT Identity m (Maybe a)

40+parseAttributeMaybe attrName parser =

41+ getCurrentAttribute attrName >>= \case

42+ Nothing -> return Nothing

43+ Just aval -> case parser aval of

44+ Left err -> throwParserError $ PEAttributeWrongFormat attrName err

45+ Right a -> return $ Just a

46+

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

48+--

49+-- @since 1.0.0

50+getCurrentAttributes

51+ :: (Monad m)

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

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

54+

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

56+--

57+-- @since 1.0.0

58+getCurrentAttribute

59+ :: (Monad m)

60+ => NameMatcher

61+ -> DomParserT Identity m (Maybe Text)

62+getCurrentAttribute attrName

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

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

src/Text/XML/DOM/Parser/Combinators.hs+13−5

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

@@ -68,9 +67,13 @@ 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− => ElemMatcher -- ^ 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

@@ -78,7 +81,7 @@ inElemTrav n = inFilteredTrav deeper

78 elemsFold = folded . nodes . folded . _Element . elMatch n

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

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

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

80

83

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

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

82inElem

85inElem

83 :: (Monad m, Foldable g)

86 :: (Monad m, Foldable g)

84 => ElemMatcher

87 => ElemMatcher

@@ -108,10 +111,10 @@ inElemNe

108inElemNe = inElemTrav

111inElemNe = inElemTrav

109

112

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

111−["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

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

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

114−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

115elements. Consider this code

118elements. Consider this code

116

119

117@

120@

@@ -129,6 +132,11 @@ which translates like: @a > b > c > fromDom@

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

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

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

131in 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.

132-}

140-}

133

141

134divePath

142divePath

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

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

1module Text.XML.DOM.Parser.Content

2− ( -- * Content readers

2+ (

3− readBool

3+ -- * Parsing element's content

4− , readChar

4+ parseContent

5− -- ** Reader constructors

6− , maybeReadContent

7− , readContent

8 -- * Getting current element's properties

5 -- * Getting current element's properties

9 , getCurrentName

6 , getCurrentName

10 , getCurrentContent

7 , getCurrentContent

11− , getCurrentAttributes

12− , getCurrentAttribute

13 , checkCurrentName

8 , checkCurrentName

14− -- * Parsing element's content

9+ -- * Internal

15− , parseContent

10+ , maybeReadContent

16− -- * Parsing attributes

11+ , readContent

17− , parseAttribute

12+ , readBool

18− , parseAttributeMaybe

13+ , readChar

19 ) where

14 ) where

20

15

21import Control.Lens

16import Control.Lens

22import Control.Monad

17import Control.Monad

23import Control.Monad.Except

18import Control.Monad.Except

24import Data.List as L

19import Data.List as L

25−import Data.Map.Strict as M

26import Data.Monoid

20import Data.Monoid

27import Data.Text as T

21import Data.Text as T

28import Data.Typeable

22import Data.Typeable

23+import Prelude as P

29import Text.Read

24import Text.Read

30import Text.XML.DOM.Parser.Types

25import Text.XML.DOM.Parser.Types

31import Text.XML.Lens

26import Text.XML.Lens

32

27

33

28

34−-- | @since 1.0.0

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

35−readBool :: Text -> Either Text Bool

30+-- consists of exactly ONE element.

36−readBool t =

31+parseContent

37− let

32+ :: (Monad m)

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

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

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

41− in if

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

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

44− | otherwise ->

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

46−

47−-- | Expects text to be single character

48−--

49−-- @since 1.0.0

50−readChar :: Text -> Either Text Char

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

52− [c] -> Right c

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

54−

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

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

57−-- message.

58−--

59−-- @since 1.0.0

60−maybeReadContent

61− :: forall a

62− . (Typeable a)

63− => (Text -> Maybe a)

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

64− -- ^ Content or attribute reader

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

65− -> Text

35+ -> DomParserT Identity m a

66− -- ^ Content or attribute value

36+parseContent parse = getCurrentContent >>= \case

67− -> Either Text a

37+ Nothing -> throwParserError PEContentNotFound

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

38+ Just c -> case parse c of

69− where

39+ Left e -> throwParserError $ PEContentWrongFormat e

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

40+ Right a -> return a

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

72−

73

41

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

82

42

83-- | Returns name of current element.

43-- | Returns name of current element.

84--

44--

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

118 | L.null conts -> Nothing

78 | L.null conts -> Nothing

119 | otherwise -> Just $ mconcat conts

79 | otherwise -> Just $ mconcat conts

120

80

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

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

122−-- consists of exactly ONE element.

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

123−parseContent

83+-- message.

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

135--

84--

136-- @since 1.0.0

85-- @since 1.0.0

137−getCurrentAttributes

86+maybeReadContent

138− :: (Monad m)

87+ :: forall a

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

88+ . (Typeable a)

140−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)

141

98

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

152

99

153−-- | 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

154−--

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

155−-- @since 1.0.0

102+-- before reading.

156−parseAttribute

103+readContent

157− :: (Monad m)

104+ :: (Read a, Typeable a)

158− => NameMatcher

105+ => Text

159− -- ^ Attribute name

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

106+ -> Either Text a

161− -- ^ Attribute content parser

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

162− -> DomParserT Identity m a

163−parseAttribute attrName parser =

164− parseAttributeMaybe attrName parser >>= \case

165− Nothing -> throwParserError $ PEAttributeNotFound attrName

166− Just a -> return a

167

108

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

109+

169−-- not found.

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

170--

124--

171-- @since 1.0.0

125-- @since 1.0.0

172−parseAttributeMaybe

173− :: (Monad m)

174− => NameMatcher

175− -- ^ Attribute name

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

126+readChar :: Text -> Either Text Char

177− -- ^ Attribute content parser

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

178− -> DomParserT Identity m (Maybe a)

128+ [c] -> Right c

179−parseAttributeMaybe attrName parser =

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

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

29class FromAttribute a where

31class FromAttribute a where

30 fromAttribute

32 fromAttribute

31 :: Text

33 :: Text

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

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

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

21import Control.Applicative

20import Control.Applicative

22import Control.Lens

21import Control.Lens

23import Data.Fixed

22import Data.Fixed

24−import Data.OpenUnion

25import Data.Scientific

23import Data.Scientific

26import Data.Text as T hiding (empty)

24import Data.Text as T hiding (empty)

27import Data.Typeable

25import Data.Typeable

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

29import Text.XML

27import Text.XML

30import Text.XML.DOM.Parser.Content

28import Text.XML.DOM.Parser.Content

31import Text.XML.DOM.Parser.Types

29import Text.XML.DOM.Parser.Types

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

33

30

34proxyFromDom

31proxyFromDom

35 :: forall proxy m a

32 :: forall proxy m a

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

38 -> DomParserT Identity m a

35 -> DomParserT Identity m a

39proxyFromDom _ = fromDom

36proxyFromDom _ = fromDom

40

37

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

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

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

42class FromDom a where

40class FromDom a where

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

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

44

42

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

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

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

116boolFromDom = parseContent readBool

114boolFromDom = parseContent readBool

117

115

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−

135instance FromDom Element where

116instance FromDom Element where

136 fromDom = elementFromDom

117 fromDom = elementFromDom

137

118

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

@@ -1,17 +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− -- * Element matching

10− , ElemMatcher(..)

11− , emMatch

12− , emShow

13− , matchElemName

14− , elMatch

15 -- * Parser internals

16 , DomPath(..)

17 , ParserError(..)

@@ -43,13 +43,17 @@ import Text.XML

43import Text.XML.Lens

44

45-- | Arbitrary element matcher

46+--

47+-- @since 2.0.0

46data ElemMatcher = ElemMatcher

48data ElemMatcher = ElemMatcher

47 { _emMatch :: Element -> Bool

49 { _emMatch :: Element -> Bool

48 , _emShow :: Text

50 , _emShow :: Text

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

49 }

52 }

50

53

51makeLenses ''ElemMatcher

54makeLenses ''ElemMatcher

52

55

56+-- | Instance using instance of 'NameMatcher'

53instance IsString ElemMatcher where

57instance IsString ElemMatcher where

54 fromString = matchElemName . fromString

58 fromString = matchElemName . fromString

55

59

@@ -57,29 +61,37 @@ instance Show ElemMatcher where

57 show = T.unpack . _emShow

61 show = T.unpack . _emShow

58

62

59-- | Match element by name

63-- | Match element by name

64+--

65+-- @since 2.0.0

60matchElemName :: NameMatcher -> ElemMatcher

66matchElemName :: NameMatcher -> ElemMatcher

61matchElemName (NameMatcher matchName showName) = ElemMatcher

67matchElemName (NameMatcher matchName showName) = ElemMatcher

62 { _emMatch = views name matchName

68 { _emMatch = views name matchName

63 , _emShow = showName

69 , _emShow = showName

64 }

70 }

65

71

72+-- | Match over elements

73+--

74+-- @since 2.0.0

66elMatch :: ElemMatcher -> Traversal' Element Element

75elMatch :: ElemMatcher -> Traversal' Element Element

67elMatch (ElemMatcher match _) = filtered match

76elMatch (ElemMatcher match _) = filtered match

68

77

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

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

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

71data NameMatcher = NameMatcher

82data NameMatcher = NameMatcher

72 { _nmMatch :: Name -> Bool

83 { _nmMatch :: Name -> Bool

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

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

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

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

75 -- of 'Name'

86 -- of 'Name'

76 , _nmShow :: Text

87 , _nmShow :: Text

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

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

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

79 }

89 }

80

90

81−makeLenses ''NameMatcher

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

82−

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

93+--

94+-- @since 2.0.0

83instance IsString NameMatcher where

95instance IsString NameMatcher where

84 fromString = matchCILocalName . T.pack

96 fromString = matchCILocalName . T.pack

85

97

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

88

100

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

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

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

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

103+--

104+-- @since 2.0.0

91matchLocalName :: Text -> NameMatcher

105matchLocalName :: Text -> NameMatcher

92matchLocalName tname = NameMatcher

106matchLocalName tname = NameMatcher

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

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

@@ -97,13 +111,19 @@ matchLocalName tname = NameMatcher

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

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

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

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

99-- is the most common case.

113-- is the most common case.

114+--

115+-- @since 2.0.0

100matchCILocalName :: Text -> NameMatcher

116matchCILocalName :: Text -> NameMatcher

101matchCILocalName tname = NameMatcher

117matchCILocalName tname = NameMatcher

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

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

103 , _nmShow = tname

119 , _nmShow = tname

104 }

120 }

105

121

122+makeLenses ''NameMatcher

123+

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

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

125+--

126+-- @since 2.0.0

107matchName :: Name -> NameMatcher

127matchName :: Name -> NameMatcher

108matchName n = NameMatcher

128matchName n = NameMatcher

109 { _nmMatch = (== n)

129 { _nmMatch = (== n)

@@ -114,7 +134,7 @@ matchName n = NameMatcher

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

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

115newtype DomPath = DomPath

135newtype DomPath = DomPath

116 { unDomPath :: [Text]

136 { unDomPath :: [Text]

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

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

118

138

119-- | DOM parser error description.

139-- | DOM parser error description.

120data ParserError

140data ParserError

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

124 -- ^ Path of element error occured in

144 -- ^ Path of element error occured in

125 }

145 }

126

146

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

147+ -- | Expected attribute but not found

128− | PEWrongFormat

148+ --

129− { _peDetails :: Text

149+ -- @since 1.0.0

150+ | PEAttributeNotFound

151+ { _peAttributeName :: NameMatcher

130− , _pePath :: DomPath

152+ , _pePath :: DomPath

131 }

153 }

132

154

133 -- | Could not parse attribute

155 -- | Could not parse attribute

156+ --

157+ -- @since 1.0.0

134 | PEAttributeWrongFormat

158 | PEAttributeWrongFormat

135 { _peAttributeName :: NameMatcher

159 { _peAttributeName :: NameMatcher

136 , _peDetails :: Text

160 , _peDetails :: Text

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

142 { _pePath :: DomPath

166 { _pePath :: DomPath

143 }

167 }

144

168

145− -- | Expected attribute but not found

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

146− | PEAttributeNotFound

170+ | PEContentWrongFormat

147− { _peAttributeName :: NameMatcher

171+ { _peDetails :: Text

148− , _pePath :: DomPath

172+ , _pePath :: DomPath

149 }

173 }

150

174

151 -- | Some other error

175 -- | Some other error

@@ -160,7 +184,7 @@ instance Exception ParserError

160

184

161newtype ParserErrors = ParserErrors

185newtype ParserErrors = ParserErrors

162 { unParserErrors :: [ParserError]

186 { unParserErrors :: [ParserError]

163− } deriving (Show, Monoid, Generic)

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

164

188

165makePrisms ''ParserErrors

189makePrisms ''ParserErrors

166

190

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