master..b5da244 · typeable/dom-parser

git.iko.soy/typeable/dom-parser

15 files changed+282−524

unifiedsplit

.travis.yml+5−7

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

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

55language: generic

7−env:

8− - STACK_YAML=stack.yaml

9− - STACK_YAML=ghc-802.yaml

10− - STACK_YAML=ghc-822.yaml

11− - STACK_YAML=ghc-841.yaml

12−

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

148cache:

159 directories:

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

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

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

2923

24+install:

25+# Build dependencies

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

27+

3028script:

3129# 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 @@

11# CHANGELOG

3−## HEAD

4−

5−## 3.2.0

6−

7−### Added

8−

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

10−* GHC 9 compatibility.

11−

12−### Removed

13−

14−* Old stackage files.

15−

16−## 3.1.0

17−

18−### Added

19−

20−* Additional builds with GHC 8.0.2 and 8.2.1

21−* Compatibility with GHC 8.4.1

22−

23−## 3.0.0

24−

25−* GHC 8 compatible release

26−

27−### Removed

28−

29−* `open-union` dependency

30−

31−## 2.0.0

32−

33−### Added

34−

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

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

37−* Class `FromAttribute` and some default instances

38−

39−### Changed

40−

41−* `DomTraversable` renamed to `Buildable`

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

43−* Documentation improved

44−

453## 1.0.0

46−

474* Added support for parsing attributes

485* Changed public interface for 'parseContent'

496* Added useful functions

507* Dropped unnecessary dependency from shakespeare

518

529## 0.1.0

53−

5410* 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 @@

11name: dom-parser

2−version: 3.2.0

2+version: 1.0.0

33synopsis: Simple monadic DOM parser

44license: MIT

55license-file: LICENSE

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

77maintainer: makeit@typeable.io

88category: XML

99build-type: Simple

10+extra-source-files: CHANGELOG.md

1011cabal-version: >=1.10

12+

13+extra-source-files: CHANGELOG.md

14+

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

1716

1817source-repository head

1918 type: git

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

4443 , TypeFamilies

4544 , TypeOperators

4645 , UndecidableInstances

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

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

4847 , case-insensitive

4948 , containers

5049 , lens

51− , mtl < 2.3 || > 2.3

50+ , mtl

51+ , open-union >= 0.2

5252 , scientific

53+ , semigroups

5354 , text

5455 , transformers

56+ , type-fun

5557 , xml-conduit

56− , xml-conduit-writer

5758 , xml-lens

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

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

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

6160 , Text.XML.DOM.Parser.Combinators

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

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

6362 , Text.XML.DOM.Parser.FromAttribute

6463 , Text.XML.DOM.Parser.FromDom

6564 , Text.XML.DOM.Parser.Types

66− , Text.XML.Soap

6765

6866test-suite test

6967 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 @@

11module Text.XML.DOM.Parser

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

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

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

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

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

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

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

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

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

97 ) where

108

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

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

139import Text.XML.DOM.Parser.Combinators

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

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

1511import Text.XML.DOM.Parser.FromAttribute

1612import Text.XML.DOM.Parser.FromDom

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

22 ( -- * Generic combinators to traverse descendants

33 traverseElems

44 , inFilteredTrav

5− -- * Using 'Buildable'

5+ -- * Using 'DomTraversable'

66 , inElemTrav

77 , inElem

88 , inElemAll

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

2222import Data.Foldable as F

2323import Data.List as L

2424import Data.List.NonEmpty (NonEmpty(..))

25+import Data.Monoid

2526import Data.Text as T

2627import Data.Traversable

2728import Text.XML

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

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

2930import Text.XML.DOM.Parser.Types

3031import Text.XML.Lens

3132

3233

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

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

3435traverseElems

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

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

3738 -- ^ 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

3940 -- to run parser in

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

4243 -> DomParserT g m (f a)

4344traverseElems trav parser = do

4445 pd <- ask

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

4849 newpd = ParserData

4950 { _pdElements = Identity e

5051 , _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

5254

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

55+-- | Takes function filtering

5456inFilteredTrav

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

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

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

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

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

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

60+ -- be appended to parser's state

6061 -> DomParserT Identity m a

6162 -> DomParserT g m (f a)

6263inFilteredTrav deeper = traverseElems trav

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

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

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

6970

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.

7471inElemTrav

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

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

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

7774 -> DomParserT Identity m a

7875 -> DomParserT g m (f a)

7976inElemTrav n = inFilteredTrav deeper

8077 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)

8379

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

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

8581inElem

8682 :: (Monad m, Foldable g)

87− => ElemMatcher

83+ => NameMatcher

8884 -> DomParserT Identity m a

8985 -> DomParserT g m a

9086inElem n = fmap runIdentity . inElemTrav n

9187

9288inElemAll

9389 :: (Monad m, Foldable g)

94− => ElemMatcher

90+ => NameMatcher

9591 -> DomParserT Identity m a

9692 -> DomParserT g m [a]

9793inElemAll = inElemTrav

9894

9995inElemMay

10096 :: (Monad m, Foldable g)

101− => ElemMatcher

97+ => NameMatcher

10298 -> DomParserT Identity m a

10399 -> DomParserT g m (Maybe a)

104100inElemMay = inElemTrav

105101

106102inElemNe

107103 :: (Monad m, Foldable g)

108− => ElemMatcher

104+ => NameMatcher

109105 -> DomParserT Identity m a

110106 -> DomParserT g m (NonEmpty a)

111107inElemNe = inElemTrav

112108

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

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

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

118114elements. Consider this code

119115

120116@

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

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

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

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

140131-}

141132

142133divePath

143134 :: forall m g a

144135 . (Monad m, Foldable g)

145− => [ElemMatcher]

136+ => [NameMatcher]

146137 -> DomParserT [] m a

147138 -> DomParserT g m a

148139divePath path = magnify $ to modElems

149140 where

150141 modElems

151142 = over pdElements (toListOf $ folded . diver)

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

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

153144 diver :: Fold Element Element

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

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

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

156147

157148diveElem

158149 :: (Monad m, Foldable g)

159− => ElemMatcher

150+ => NameMatcher

160151 -> DomParserT [] m a

161152 -> DomParserT g m a

162153diveElem p = divePath [p]

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

197188 let

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

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

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

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

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

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

2− (

3− -- * Parsing element's content

4− parseContent

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

2+ ( -- * Buildable

3+ Buildable(..)

4+ -- * Content readers

5+ , readBool

6+ , readChar

7+ -- ** Reader constructors

8+ , maybeReadContent

9+ , readContent

510 -- * Getting current element's properties

611 , getCurrentName

712 , getCurrentContent

13+ , getCurrentAttributes

14+ , getCurrentAttribute

815 , checkCurrentName

9− -- * Internal

10− , maybeReadContent

11− , readContent

12− , readBool

13− , readChar

16+ -- * Parsing element's content

17+ , parseContent

18+ -- * Parsing attributes

19+ , parseAttribute

20+ , parseAttributeMaybe

1421 ) where

1522

1623import Control.Lens

1724import Control.Monad

1825import Control.Monad.Except

1926import Data.List as L

27+import Data.List.NonEmpty as NE

28+import Data.Map.Strict as M

29+import Data.Maybe

2030import Data.Monoid

2131import Data.Text as T

2232import Data.Typeable

23−import Prelude as P

2433import Text.Read

2534import Text.XML.DOM.Parser.Types

2635import Text.XML.Lens

2736

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)

2844

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

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"

4177

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

42103

43104-- | Returns name of current element.

44105--

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

78139 | L.null conts -> Nothing

79140 | otherwise -> Just $ mconcat conts

80141

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

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

83−-- message.

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

143+-- consists of exactly ONE element.

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

84156--

85157-- @since 1.0.0

86−maybeReadContent

87− :: forall a

88− . (Typeable a)

89− => (Text -> Maybe a)

90− -- ^ Content or attribute reader

91− -> Text

92− -- ^ Content or attribute value

93− -> Either Text a

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

95− where

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

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

98−

99−

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

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

102−-- before reading.

103−readContent

104− :: (Read a, Typeable a)

105− => Text

106− -> Either Text a

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

158+getCurrentAttributes

159+ :: (Monad m)

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

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

108162

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

109173

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"

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

175+--

176+-- @since 1.0.0

177+parseAttribute

178+ :: (Monad m)

179+ => NameMatcher

180+ -- ^ Attribute name

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

182+ -- ^ Attribute content parser

183+ -> DomParserT Identity m a

184+parseAttribute attrName parser =

185+ parseAttributeMaybe attrName parser >>= \case

186+ Nothing -> throwParserError $ PEAttributeNotFound attrName

187+ Just a -> return a

122188

123−-- | Expects text to be single character

189+-- | Parses attribute with given name.

124190--

125191-- @since 1.0.0

126−readChar :: Text -> Either Text Char

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

128− [c] -> Right c

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

192+parseAttributeMaybe

193+ :: (Monad m)

194+ => NameMatcher

195+ -- ^ Attribute name

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

197+ -- ^ Attribute content parser

198+ -> DomParserT Identity m (Maybe a)

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+8−82

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

11module Text.XML.DOM.Parser.FromAttribute

22 ( -- * FromAttribute

33 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

174 ) where

185

196import Data.Fixed

207import Data.Scientific

218import Data.Text as T

229import Data.Typeable

23−import Data.Void

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

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

2511

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

3112class FromAttribute a where

3213 fromAttribute

3314 :: Text

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

3516 -> Either Text a

3617 -- ^ Either error message or result

3718

38−proxyFromAttribute

39− :: FromAttribute a

40− => Proxy a

41− -> Text

42− -> Either Text a

43−proxyFromAttribute _ = fromAttribute

44−

4519instance FromAttribute () where

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"

20+ fromAttribute _ = Right ()

5621

5722instance FromAttribute Text where

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

23+ fromAttribute = Right

6824

6925instance FromAttribute Char where

70− fromAttribute = charFromAttribute

71−

72−charFromAttribute :: Text -> Either Text Char

73−charFromAttribute = readChar

26+ fromAttribute = readChar

7427

7528instance FromAttribute Int where

76− fromAttribute = intFromAttribute

77−

78−intFromAttribute :: Text -> Either Text Int

79−intFromAttribute = readContent

29+ fromAttribute = readContent

8030

8131instance FromAttribute Integer where

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

32+ fromAttribute = readContent

9233

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

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

35+ fromAttribute = readContent

10736

10837instance FromAttribute Scientific where

109− fromAttribute = scientificFromAttribute

110−

111−scientificFromAttribute :: Text -> Either Text Scientific

112−scientificFromAttribute = readContent

38+ fromAttribute = readContent

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

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

44 , proxyFromDom

55 -- * Explicit methods for convenience

66 , elementFromDom

7+ , unionFromDom

78 , textFromDom

89 , stringFromDom

910 , charFromDom

11+ , readChar

1012 , intFromDom

1113 , integerFromDom

1214 , doubleFromDom

1315 , fixedFromDom

1416 , boolFromDom

17+ , readBool

1518 , unitFromDom

1619 , voidFromDom

1720 , scientificFromDom

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

2023import Control.Applicative

2124import Control.Lens

2225import Data.Fixed

26+import Data.OpenUnion

2327import Data.Scientific

2428import Data.Text as T hiding (empty)

2529import Data.Typeable

2630import Data.Void

2731import Text.XML

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

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

2933import Text.XML.DOM.Parser.Types

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

3035

3136proxyFromDom

3237 :: forall proxy m a

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

3540 -> DomParserT Identity m a

3641proxyFromDom _ = fromDom

3742

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

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

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

4044class FromDom a where

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

4246

4347instance FromDom () where

4448 fromDom = unitFromDom

4549

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

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

48−unitFromDom = pure ()

49−

5050instance FromDom Void where

5151 fromDom = voidFromDom

5252

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

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

55−voidFromDom = empty

56−

5753instance FromDom Text where

5854 fromDom = textFromDom

5955

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

61−textFromDom = parseContent Right

62−

6356instance FromDom String where

6457 fromDom = stringFromDom

6558

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

67−stringFromDom = parseContent $ Right . T.unpack

68−

6959instance FromDom Char where

7060 fromDom = charFromDom

7161

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

73−charFromDom = parseContent readChar

74−

7562instance FromDom Int where

7663 fromDom = intFromDom

7764

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

79−intFromDom = parseContent readContent

80−

8165instance FromDom Integer where

8266 fromDom = integerFromDom

8367

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

85−integerFromDom = parseContent readContent

86−

8768instance FromDom Double where

8869 fromDom = doubleFromDom

8970

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

91−doubleFromDom = parseContent readContent

92−

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

9472 fromDom = fixedFromDom

9573

96−fixedFromDom

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

98− => DomParserT Identity m (Fixed a)

99−fixedFromDom = parseContent readContent

100−

10174instance FromDom Scientific where

10275 fromDom = scientificFromDom

10376

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

105−scientificFromDom = parseContent readContent

106−

10777instance FromDom Bool where

10878 fromDom = boolFromDom

10979

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

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

112−-- are striped.

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

114−boolFromDom = parseContent readBool

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

11590

11691instance FromDom Element where

11792 fromDom = elementFromDom

11893

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

12095elementFromDom = 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+

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

104+textFromDom = parseContent Right

105+

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

107+stringFromDom = parseContent $ Right . T.unpack

108+

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

110+charFromDom = parseContent readChar

111+

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

113+intFromDom = parseContent readContent

114+

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

116+integerFromDom = parseContent readContent

117+

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

119+doubleFromDom = parseContent readContent

120+

121+fixedFromDom

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

123+ => DomParserT Identity m (Fixed a)

124+fixedFromDom = parseContent readContent

125+

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

127+scientificFromDom = parseContent readContent

128+

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

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

131+-- characters are striped.

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

133+boolFromDom = parseContent readBool

134+

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

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

137+unitFromDom = pure ()

138+

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

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

141+voidFromDom = empty

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

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

11module Text.XML.DOM.Parser.Types

2− (-- * Element matching

3− ElemMatcher(..)

4− , emMatch

5− , emShow

6− , matchElemName

7− , elMatch

8− -- * Name matching

9− , NameMatcher(..)

2+ ( -- * Name matching

3+ NameMatcher(..)

104 , nmMatch

115 , nmShow

126 , matchName

137 , matchLocalName

148 , matchCILocalName

9+ , elMatchName

1510 -- * Parser internals

1611 , DomPath(..)

1712 , ParserError(..)

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

4237import Text.XML

4338import Text.XML.Lens

4439

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−

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

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

80−--

81−-- @since 2.0.0

8242data NameMatcher = NameMatcher

8343 { _nmMatch :: Name -> Bool

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

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

8646 -- of 'Name'

8747 , _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

8950 }

9051

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

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

93−--

94−-- @since 2.0.0

52+makeLenses ''NameMatcher

53+

9554instance IsString NameMatcher where

9655 fromString = matchCILocalName . T.pack

9756

9857instance Show NameMatcher where

9958 show = T.unpack . _nmShow

10059

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

10560matchLocalName :: Text -> NameMatcher

10661matchLocalName tname = NameMatcher

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

10863 , _nmShow = tname

10964 }

11065

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

11666matchCILocalName :: Text -> NameMatcher

11767matchCILocalName tname = NameMatcher

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

11969 , _nmShow = tname

12070 }

12171

122−makeLenses ''NameMatcher

123−

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

125−--

126−-- @since 2.0.0

12772matchName :: Name -> NameMatcher

12873matchName n = NameMatcher

12974 { _nmMatch = (== n)

13075 , _nmShow = nameLocalName n

13176 }

13277

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

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

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

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

80+

13581newtype DomPath = DomPath

13682 { unDomPath :: [Text]

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

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

13884

13985-- | DOM parser error description.

14086data ParserError

14187 -- | Tag not found which should be.

14288 = PENotFound

14389 { _pePath :: DomPath

144− -- ^ Path of element error occured in

14590 }

14691

147− -- | Expected attribute but not found

148− --

149− -- @since 1.0.0

150− | PEAttributeNotFound

151− { _peAttributeName :: NameMatcher

152− , _pePath :: DomPath

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

93+ | PEWrongFormat

94+ { _peDetails :: Text

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

15396 }

15497

15598 -- | Could not parse attribute

156− --

157− -- @since 1.0.0

15899 | PEAttributeWrongFormat

159100 { _peAttributeName :: NameMatcher

160101 , _peDetails :: Text

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

166107 { _pePath :: DomPath

167108 }

168109

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

170− | PEContentWrongFormat

171− { _peDetails :: Text

172− , _pePath :: DomPath

110+ -- | Expected attribute but not found

111+ | PEAttributeNotFound

112+ { _peAttributeName :: NameMatcher

113+ , _pePath :: DomPath

173114 }

174115

175116 -- | Some other error

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

184125

185126newtype ParserErrors = ParserErrors

186127 { unParserErrors :: [ParserError]

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

128+ } deriving (Show, Monoid, Generic)

188129

189130makePrisms ''ParserErrors

190131

191132instance Exception ParserErrors

192133

193134

194−{- | Parser scope.

195−

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

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

136+@[]@.

197137

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

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