master..350b2eb · typeable/dom-parser

.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

6

7−env:

8− - STACK_YAML=stack.yaml

9− - STACK_YAML=ghc-802.yaml

10− - STACK_YAML=ghc-822.yaml

11− - STACK_YAML=ghc-841.yaml

12−

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

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'

29

23

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

2

3−## HEAD

4−

5−## 3.2.0

6−

7−### Added

8−

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

10−* GHC 9 compatibility.

11−

12−### Removed

13−

14−* Old stackage files.

15−

16−## 3.1.0

17−

18−### Added

19−

20−* Additional builds with GHC 8.0.2 and 8.2.1

21−* Compatibility with GHC 8.4.1

22−

23−## 3.0.0

24−

25−* GHC 8 compatible release

26−

27−### Removed

28−

29−* `open-union` dependency

30−

31−## 2.0.0

32−

33−### Added

34−

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

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

37−* Class `FromAttribute` and some default instances

38−

39−### Changed

40−

41−* `DomTraversable` renamed to `Buildable`

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

43−* Documentation improved

44−

45## 1.0.0

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

51

8

52## 0.1.0

9## 0.1.0

53−

54* Public release

10* Public release

README.mddeleted−5

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

1−# dom-parser

2−

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

4−

5−Simple monadic DOM parser

dom-parser.cabal+11−13

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

1name: dom-parser

2−version: 3.2.0

2+version: 1.0.0

3synopsis: Simple monadic DOM parser

4license: MIT

5license-file: LICENSE

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

7maintainer: makeit@typeable.io

8category: XML

9build-type: Simple

10+extra-source-files: CHANGELOG.md

10cabal-version: >=1.10

11cabal-version: >=1.10

12+

13+extra-source-files: CHANGELOG.md

14+

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

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

12−tested-with: GHC == 9.2.7

13− , GHC == 9.4.8

14− , GHC == 9.6.3

15−extra-source-files: CHANGELOG.md

16− , README.md

17

16

18source-repository head

17source-repository head

19 type: git

18 type: git

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

44 , TypeFamilies

43 , TypeFamilies

45 , TypeOperators

44 , TypeOperators

46 , UndecidableInstances

45 , UndecidableInstances

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

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

48 , case-insensitive

47 , case-insensitive

49 , containers

48 , containers

50 , lens

49 , lens

51− , mtl < 2.3 || > 2.3

50+ , mtl

51+ , open-union >= 0.2

52 , scientific

53+ , semigroups

53 , text

54 , text

54 , transformers

55 , transformers

56+ , type-fun

55 , xml-conduit

57 , xml-conduit

56− , xml-conduit-writer

57 , xml-lens

58 , xml-lens

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

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

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

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

61 , Text.XML.DOM.Parser.Combinators

60 , Text.XML.DOM.Parser.Combinators

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

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

63 , Text.XML.DOM.Parser.FromAttribute

62 , Text.XML.DOM.Parser.FromAttribute

64 , Text.XML.DOM.Parser.FromDom

63 , Text.XML.DOM.Parser.FromDom

65 , Text.XML.DOM.Parser.Types

64 , Text.XML.DOM.Parser.Types

66− , Text.XML.Soap

67

65

68test-suite test

66test-suite test

69 type: exitcode-stdio-1.0

67 type: exitcode-stdio-1.0

ghc-963.yamldeleted−7

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

1−resolver: lts-22.6

2−

3−extra-deps:

4− - xml-conduit-writer-0.1.1.5

5−

6−nix:

7− packages: [zlib]

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

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

1module Text.XML.DOM.Parser

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

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

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

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

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

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

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

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

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

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

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

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

9 ) where

7 ) where

10

8

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

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

13import Text.XML.DOM.Parser.Combinators

9import Text.XML.DOM.Parser.Combinators

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

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

15import Text.XML.DOM.Parser.FromAttribute

11import Text.XML.DOM.Parser.FromAttribute

16import Text.XML.DOM.Parser.FromDom

12import Text.XML.DOM.Parser.FromDom

17import Text.XML.DOM.Parser.Types

13import Text.XML.DOM.Parser.Types

src/Text/XML/DOM/Parser/Attributes.hsdeleted−64

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

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

2− ( parseAttribute

3− , parseAttributeMaybe

4− , getCurrentAttributes

5− , getCurrentAttribute

6− ) where

7−

8−import Control.Lens

9−import Data.Map.Strict as M

10−import Data.Text as T

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

12−import Text.XML.Lens

13−

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

15−--

16−-- @since 1.0.0

17−parseAttribute

18− :: (Monad m)

19− => NameMatcher

20− -- ^ Attribute name

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

22− -- ^ Attribute content parser

23− -> DomParserT Identity m a

24−parseAttribute attrName parser =

25− parseAttributeMaybe attrName parser >>= \case

26− Nothing -> throwParserError $ PEAttributeNotFound attrName

27− Just a -> return a

28−

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

30−-- not found.

31−--

32−-- @since 1.0.0

33−parseAttributeMaybe

34− :: (Monad m)

35− => NameMatcher

36− -- ^ Attribute name

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

38− -- ^ Attribute content parser

39− -> DomParserT Identity m (Maybe a)

40−parseAttributeMaybe attrName parser =

41− getCurrentAttribute attrName >>= \case

42− Nothing -> return Nothing

43− Just aval -> case parser aval of

44− Left err -> throwParserError $ PEAttributeWrongFormat attrName err

45− Right a -> return $ Just a

46−

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

48−--

49−-- @since 1.0.0

50−getCurrentAttributes

51− :: (Monad m)

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

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

54−

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

56−--

57−-- @since 1.0.0

58−getCurrentAttribute

59− :: (Monad m)

60− => NameMatcher

61− -> DomParserT Identity m (Maybe Text)

62−getCurrentAttribute attrName

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

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

src/Text/XML/DOM/Parser/Buildable.hsdeleted−26

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

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

2− ( Buildable(..)

3− ) where

4−

5−import Data.Functor.Identity

6−import Data.List.NonEmpty as NE

7−import Data.Maybe

8−

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

10−class Traversable f => Buildable f where

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

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

13− -- fail traversing.

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

15−

16−instance Buildable Identity where

17− build = fmap Identity . listToMaybe

18−

19−instance Buildable [] where

20− build = Just

21−

22−instance Buildable Maybe where

23− build = Just . listToMaybe

24−

25−instance Buildable NonEmpty where

26− build = NE.nonEmpty

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

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

2 ( -- * Generic combinators to traverse descendants

3 traverseElems

4 , inFilteredTrav

5− -- * Using 'Buildable'

5+ -- * Using 'DomTraversable'

6 , inElemTrav

7 , inElem

8 , inElemAll

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

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

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

29import Text.XML.DOM.Parser.Types

30import Text.XML.DOM.Parser.Types

30import Text.XML.Lens

31import Text.XML.Lens

31

32

33

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

52

54

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

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

69

70

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)

83

79

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

91

87

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

98

94

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 → src/Text/XML/DOM/Parser/Common.hsrenamed+139−64

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

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

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

2− (

2+ ( -- * Buildable

3− -- * Parsing element's content

3+ Buildable(..)

4− parseContent

4+ -- * Content readers

5+ , readBool

6+ , readChar

7+ -- ** Reader constructors

8+ , maybeReadContent

9+ , readContent

5 -- * Getting current element's properties

10 -- * Getting current element's properties

6 , getCurrentName

11 , getCurrentName

7 , getCurrentContent

12 , getCurrentContent

13+ , getCurrentAttributes

14+ , getCurrentAttribute

8 , checkCurrentName

15 , checkCurrentName

9− -- * Internal

16+ -- * Parsing element's content

10− , maybeReadContent

17+ , parseContent

11− , readContent

18+ -- * Parsing attributes

12− , readBool

19+ , parseAttribute

13− , readChar

20+ , parseAttributeMaybe

14 ) where

21 ) where

15

22

16import Control.Lens

23import Control.Lens

17import Control.Monad

24import Control.Monad

18import Control.Monad.Except

25import Control.Monad.Except

19import Data.List as L

26import Data.List as L

27+import Data.List.NonEmpty as NE

28+import Data.Map.Strict as M

29+import Data.Maybe

20import Data.Monoid

30import Data.Monoid

21import Data.Text as T

31import Data.Text as T

22import Data.Typeable

32import Data.Typeable

23−import Prelude as P

24import Text.Read

33import Text.Read

25import Text.XML.DOM.Parser.Types

34import Text.XML.DOM.Parser.Types

26import Text.XML.Lens

35import Text.XML.Lens

27

36

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)

28

44

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

45+instance Buildable Identity where

30−-- consists of exactly ONE element.

46+ build = fmap Identity . listToMaybe

31−parseContent

47+

32− :: (Monad m)

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

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

58+readBool :: Text -> Either Text Bool

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

59+readBool t =

35− -> DomParserT Identity m a

60+ let

36−parseContent parse = getCurrentContent >>= \case

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

37− Nothing -> throwParserError PEContentNotFound

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

38− Just c -> case parse c of

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

39− Left e -> throwParserError $ PEContentWrongFormat e

64+ in if

40− Right a -> return a

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"

41

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+

95+

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

42

103

43-- | Returns name of current element.

104-- | Returns name of current element.

44--

105--

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

78 | L.null conts -> Nothing

139 | L.null conts -> Nothing

79 | otherwise -> Just $ mconcat conts

140 | otherwise -> Just $ mconcat conts

80

141

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

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

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

143+-- consists of exactly ONE element.

83−-- message.

144+parseContent

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

84--

156--

85-- @since 1.0.0

157-- @since 1.0.0

86−maybeReadContent

158+getCurrentAttributes

87− :: forall a

159+ :: (Monad m)

88− . (Typeable a)

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

89− => (Text -> Maybe a)

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

162

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

109

173

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

175+--

110−-- | @since 1.0.0

176+-- @since 1.0.0

177+parseAttribute

178+ :: (Monad m)

179+ => NameMatcher

180+ -- ^ Attribute name

111−readBool :: Text -> Either Text Bool

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

112−readBool t =

182+ -- ^ Attribute content parser

113− let

183+ -> DomParserT Identity m a

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

184+parseAttribute attrName parser =

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

185+ parseAttributeMaybe attrName parser >>= \case

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

186+ Nothing -> throwParserError $ PEAttributeNotFound attrName

117− in if

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

188

123−-- | Expects text to be single character

189+-- | Parses attribute with given name.

124--

190--

125-- @since 1.0.0

191-- @since 1.0.0

192+parseAttributeMaybe

193+ :: (Monad m)

194+ => NameMatcher

195+ -- ^ Attribute name

126−readChar :: Text -> Either Text Char

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

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

197+ -- ^ Attribute content parser

128− [c] -> Right c

198+ -> DomParserT Identity m (Maybe a)

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

199+parseAttributeMaybe attrName parser =

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+1−6

@@ -21,13 +21,8 @@ import Data.Scientific

21import Data.Text as T

22import Data.Typeable

23import Data.Void

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

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

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

31class FromAttribute a where

26class FromAttribute a where

32 fromAttribute

27 fromAttribute

33 :: Text

28 :: Text

src/Text/XML/DOM/Parser/FromDom.hs+22−3

@@ -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,13 +21,15 @@ 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

26import Data.Void

28import Data.Void

27import Text.XML

29import Text.XML

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

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

29import Text.XML.DOM.Parser.Types

31import Text.XML.DOM.Parser.Types

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

30

33

31proxyFromDom

34proxyFromDom

32 :: forall proxy m a

35 :: forall proxy m a

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

35 -> DomParserT Identity m a

38 -> DomParserT Identity m a

36proxyFromDom _ = fromDom

39proxyFromDom _ = fromDom

37

40

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

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

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

40class FromDom a where

42class FromDom a where

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

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

42

44

@@ -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−82

@@ -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,119 +37,65 @@ import GHC.Generics (Generic)

42import Text.XML

37import Text.XML

43import Text.XML.Lens

38import Text.XML.Lens

44

39

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 }

90

51

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

97

56

98instance Show NameMatcher where

57instance Show NameMatcher where

99 show = T.unpack . _nmShow

58 show = T.unpack . _nmShow

100

59

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

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

103−--

104−-- @since 2.0.0

105matchLocalName :: Text -> NameMatcher

60matchLocalName :: Text -> NameMatcher

106matchLocalName tname = NameMatcher

61matchLocalName tname = NameMatcher

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

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

108 , _nmShow = tname

63 , _nmShow = tname

109 }

64 }

110

65

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

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

113−-- is the most common case.

114−--

115−-- @since 2.0.0

116matchCILocalName :: Text -> NameMatcher

66matchCILocalName :: Text -> NameMatcher

117matchCILocalName tname = NameMatcher

67matchCILocalName tname = NameMatcher

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

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

119 , _nmShow = tname

69 , _nmShow = tname

120 }

70 }

121

71

122−makeLenses ''NameMatcher

123−

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

125−--

126−-- @since 2.0.0

127matchName :: Name -> NameMatcher

72matchName :: Name -> NameMatcher

128matchName n = NameMatcher

73matchName n = NameMatcher

129 { _nmMatch = (== n)

74 { _nmMatch = (== n)

130 , _nmShow = nameLocalName n

75 , _nmShow = nameLocalName n

131 }

76 }

132

77

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

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

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

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

80+

135newtype DomPath = DomPath

81newtype DomPath = DomPath

136 { unDomPath :: [Text]

82 { unDomPath :: [Text]

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

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

138

84

139-- | DOM parser error description.

85-- | DOM parser error description.

140data ParserError

86data ParserError

141 -- | Tag not found which should be.

87 -- | Tag not found which should be.

142 = PENotFound

88 = PENotFound

143 { _pePath :: DomPath

89 { _pePath :: DomPath

144− -- ^ Path of element error occured in

145 }

90 }

146

91

147− -- | Expected attribute but not found

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

148− --

93+ | PEWrongFormat

149− -- @since 1.0.0

94+ { _peDetails :: Text

150− | PEAttributeNotFound

151− { _peAttributeName :: NameMatcher

152− , _pePath :: DomPath

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

153 }

96 }

154

97

155 -- | Could not parse attribute

98 -- | Could not parse attribute

156− --

157− -- @since 1.0.0

158 | PEAttributeWrongFormat

99 | PEAttributeWrongFormat

159 { _peAttributeName :: NameMatcher

100 { _peAttributeName :: NameMatcher

160 , _peDetails :: Text

101 , _peDetails :: Text

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

166 { _pePath :: DomPath

107 { _pePath :: DomPath

167 }

108 }

168

109

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

110+ -- | Expected attribute but not found

170− | PEContentWrongFormat

111+ | PEAttributeNotFound

171− { _peDetails :: Text

112+ { _peAttributeName :: NameMatcher

172− , _pePath :: DomPath

113+ , _pePath :: DomPath

173 }

114 }

174

115

175 -- | Some other error

116 -- | Some other error

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

184

125

185newtype ParserErrors = ParserErrors

126newtype ParserErrors = ParserErrors

186 { unParserErrors :: [ParserError]

127 { unParserErrors :: [ParserError]

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

128+ } deriving (Show, Monoid, Generic)

188

129

189makePrisms ''ParserErrors

130makePrisms ''ParserErrors

190

131

191instance Exception ParserErrors

132instance Exception ParserErrors

192

133

193

134

194−{- | Parser scope.

195−

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

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

136+@[]@.

197

137

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

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

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

139is 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