git.iko.soy/typeable/dom-parser
on master help sign in
Merge branch 'release/2.0.0' into production
2cbf2acAleksey Uimanov
.travis.ymlnew file+30
compare with master
unifiedsplit
@@ -0,0 +1,30 @@
1+# Use new container infrastructure to enable caching
2+sudo: false
3+
4+# Do not choose a language; we provide our own build tools.
5+language: generic
6+
7+# Caching so the next build will be fast too.
8+cache:
9+ directories:
10+ - $HOME/.stack
11+
12+# Ensure necessary system libraries are present
13+addons:
14+ apt:
15+ packages:
16+ - libgmp-dev
17+
18+before_install:
19+# Download and unpack the stack executable
20+- mkdir -p ~/.local/bin
21+- 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'
23+
24+install:
25+# Build dependencies
26+- stack --no-terminal --install-ghc build --only-dependencies
27+
28+script:
29+# Build the package, its tests, and its docs and run the tests
30+- stack --no-terminal test --haddock --no-haddock-deps
CHANGELOG.md+17−1
@@ -1,10 +1,26 @@
1# CHANGELOG
1# CHANGELOG
2
2
3+## 2.0.0
4+
5+### Added
6+
7+* `NameMatcher` and `ElemMatcher` as more flexible mechanisms for
8+ matching names and elements instead of just matching by name.
9+* Class `FromAttribute` and some default instances
10+
11+### Changed
12+
13+* `DomTraversable` renamed to `Buildable`
14+* Combinators use `NameMatcher` and `ElemMatcher`
15+* Documentation improved
16+
3## 1.0.0
17## 1.0.0
18+
4* Added support for parsing attributes
19* Added support for parsing attributes
5* Changed public interface for 'parseContent'
20* Changed public interface for 'parseContent'
6−* Added usefull functions
21+* Added useful functions
7* Dropped unnecessary dependency from shakespeare
22* Dropped unnecessary dependency from shakespeare
8
23
9## 0.1.0
24## 0.1.0
25+
10* Public release
26* Public release
dom-parser.cabal+9−3
@@ -1,5 +1,5 @@
1name: dom-parser
1name: dom-parser
2−version: 1.0.0
2+version: 2.0.0
3synopsis: Simple monadic DOM parser
3synopsis: Simple monadic DOM parser
4license: MIT
4license: MIT
5license-file: LICENSE
5license-file: LICENSE
@@ -44,10 +44,12 @@ library
44 , TypeOperators
44 , TypeOperators
45 , UndecidableInstances
45 , UndecidableInstances
46 build-depends: base >= 4.7 && < 5
46 build-depends: base >= 4.7 && < 5
47+ , case-insensitive
47 , containers
48 , containers
48 , lens
49 , lens
49 , mtl
50 , mtl
50− , open-union
51+ , open-union >= 0.2
52+ , scientific
51 , semigroups
53 , semigroups
52 , text
54 , text
53 , transformers
55 , transformers
@@ -55,8 +57,12 @@ library
55 , xml-conduit
57 , xml-conduit
56 , xml-lens
58 , xml-lens
57 exposed-modules: Text.XML.DOM.Parser
59 exposed-modules: Text.XML.DOM.Parser
58− , Text.XML.DOM.Parser.Class
60+ , Text.XML.DOM.Parser.Attributes
61+ , Text.XML.DOM.Parser.Buildable
59 , Text.XML.DOM.Parser.Combinators
62 , Text.XML.DOM.Parser.Combinators
63+ , Text.XML.DOM.Parser.Content
64+ , Text.XML.DOM.Parser.FromAttribute
65+ , Text.XML.DOM.Parser.FromDom
60 , Text.XML.DOM.Parser.Types
66 , Text.XML.DOM.Parser.Types
61
67
62test-suite test
68test-suite test
src/Text/XML/DOM/Parser.hs+10−2
@@ -1,9 +1,17 @@
1module Text.XML.DOM.Parser
1module Text.XML.DOM.Parser
2− ( module Text.XML.DOM.Parser.Class
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
5+ , module Text.XML.DOM.Parser.Content
6+ , module Text.XML.DOM.Parser.FromAttribute
7+ , module Text.XML.DOM.Parser.FromDom
4 , module Text.XML.DOM.Parser.Types
8 , module Text.XML.DOM.Parser.Types
5 ) where
9 ) where
6
10
7−import Text.XML.DOM.Parser.Class
11+import Text.XML.DOM.Parser.Attributes
12+import Text.XML.DOM.Parser.Buildable
8import Text.XML.DOM.Parser.Combinators
13import Text.XML.DOM.Parser.Combinators
14+import Text.XML.DOM.Parser.Content
15+import Text.XML.DOM.Parser.FromAttribute
16+import Text.XML.DOM.Parser.FromDom
9import Text.XML.DOM.Parser.Types
17import Text.XML.DOM.Parser.Types
src/Text/XML/DOM/Parser/Attributes.hsnew file+64
@@ -0,0 +1,64 @@
1+module Text.XML.DOM.Parser.Attributes
2+ ( parseAttribute
3+ , parseAttributeMaybe
4+ , getCurrentAttributes
5+ , getCurrentAttribute
6+ ) where
7+
8+import Control.Lens
9+import Data.Map.Strict as M
10+import Data.Text as T
11+import Text.XML.DOM.Parser.Types
12+import Text.XML.Lens
13+
14+-- | Parses attribute with given name, throws error if attribute is not found.
15+--
16+-- @since 1.0.0
17+parseAttribute
18+ :: (Monad m)
19+ => NameMatcher
20+ -- ^ Attribute name
21+ -> (Text -> Either Text a)
22+ -- ^ Attribute content parser
23+ -> DomParserT Identity m a
24+parseAttribute attrName parser =
25+ parseAttributeMaybe attrName parser >>= \case
26+ Nothing -> throwParserError $ PEAttributeNotFound attrName
27+ Just a -> return a
28+
29+-- | Parses attribute with given name. Returns Nothing if attribute is
30+-- not found.
31+--
32+-- @since 1.0.0
33+parseAttributeMaybe
34+ :: (Monad m)
35+ => NameMatcher
36+ -- ^ Attribute name
37+ -> (Text -> Either Text a)
38+ -- ^ Attribute content parser
39+ -> DomParserT Identity m (Maybe a)
40+parseAttributeMaybe attrName parser =
41+ getCurrentAttribute attrName >>= \case
42+ Nothing -> return Nothing
43+ Just aval -> case parser aval of
44+ Left err -> throwParserError $ PEAttributeWrongFormat attrName err
45+ Right a -> return $ Just a
46+
47+-- | Retuns map of attributes of current element
48+--
49+-- @since 1.0.0
50+getCurrentAttributes
51+ :: (Monad m)
52+ => DomParserT Identity m (M.Map Name Text)
53+getCurrentAttributes = view $ pdElements . to runIdentity . attrs
54+
55+-- | Returns element with given name or 'Nothing'
56+--
57+-- @since 1.0.0
58+getCurrentAttribute
59+ :: (Monad m)
60+ => NameMatcher
61+ -> DomParserT Identity m (Maybe Text)
62+getCurrentAttribute attrName
63+ = preview $ pdElements . to runIdentity . attrs . to M.toList
64+ . traversed . filtered (views _1 (attrName ^. nmMatch)) . _2
src/Text/XML/DOM/Parser/Buildable.hsnew file+26
@@ -0,0 +1,26 @@
1+module Text.XML.DOM.Parser.Buildable
2+ ( Buildable(..)
3+ ) where
4+
5+import Data.Functor.Identity
6+import Data.List.NonEmpty as NE
7+import Data.Maybe
8+
9+-- | Class of traversable functors which may be constructed from list
10+class Traversable f => Buildable f where
11+ -- | If method return Nothing this means we can not build
12+ -- traversable from given list. In this case 'inFilteredTrav' should
13+ -- fail traversing.
14+ build :: [a] -> Maybe (f a)
15+
16+instance Buildable Identity where
17+ build = fmap Identity . listToMaybe
18+
19+instance Buildable [] where
20+ build = Just
21+
22+instance Buildable Maybe where
23+ build = Just . listToMaybe
24+
25+instance Buildable NonEmpty where
26+ build = NE.nonEmpty
src/Text/XML/DOM/Parser/Combinators.hs+57−169
@@ -2,7 +2,7 @@ module Text.XML.DOM.Parser.Combinators
2 ( -- * Generic combinators to traverse descendants
2 ( -- * Generic combinators to traverse descendants
3 traverseElems
3 traverseElems
4 , inFilteredTrav
4 , inFilteredTrav
5− -- * Using 'DomTraversable'
5+ -- * Using 'Buildable'
6 , inElemTrav
6 , inElemTrav
7 , inElem
7 , inElem
8 , inElemAll
8 , inElemAll
@@ -15,116 +15,107 @@ module Text.XML.DOM.Parser.Combinators
15 , ignoreElem
15 , ignoreElem
16 , ignoreEmpty
16 , ignoreEmpty
17 , ignoreBlank
17 , ignoreBlank
18− -- * Getting current element's properties
19− , getCurrentName
20− , getCurrentContent
21− , getCurrentAttributes
22− , getCurrentAttribute
23− -- * Current element's checks
24− , checkCurrentName
25− -- * Parsing element's content
26− , parseContent
27− , readContent
28− , maybeReadContent
29− -- * Parsing attributes
30− , parseAttribute
31 ) where
18 ) where
32
19
33−import Control.Lens
20+import Control.Lens
34−import Control.Monad.Except
35−import Control.Monad.Reader
21+import Control.Monad.Reader
22+import Data.Foldable as F
23+import Data.List as L
36−import Data.List.NonEmpty (NonEmpty(..))
24+import Data.List.NonEmpty (NonEmpty(..))
37−import qualified Data.Map.Strict as M
38−import Data.Monoid
25+import Data.Monoid
39−import Data.Text (Text)
40−import qualified Data.Text as T
26+import Data.Text as T
41−import Data.Traversable
27+import Data.Traversable
42−import Data.Typeable
28+import Text.XML
43−import Text.Read
44−import Text.XML
29+import Text.XML.DOM.Parser.Buildable
45−import Text.XML.DOM.Parser.Types
30+import Text.XML.DOM.Parser.Types
46−import Text.XML.Lens
31+import Text.XML.Lens
47−
32+
48−
33+
49−-- | Generic function to traverse arbitrary inner cursors.
34+-- | Generic function to traverse arbitrary inner elements.
50traverseElems
35traverseElems
51 :: (Monad m, Foldable g, Traversable f)
36 :: (Monad m, Foldable g, Traversable f)
52 => ([Element] -> DomParserT g m (f (DomPath, Element)))
37 => ([Element] -> DomParserT g m (f (DomPath, Element)))
53 -- ^ Takes list of current elements and returns container with
38 -- ^ Takes list of current elements and returns container with
54− -- pairs of subpath (relatively to current element) and element
39+ -- pairs of subpath (relatively to current elements) and element
55 -- to run parser in
40 -- to run parser in
56 -> DomParserT Identity m a
41 -> DomParserT Identity m a
57− -- ^ Parser will be runned for each element found in traversable
42+ -- ^ Parser to run for each element found in traversable 'f'
58 -> DomParserT g m (f a)
43 -> DomParserT g m (f a)
59traverseElems trav parser = do
44traverseElems trav parser = do
60 pd <- ask
45 pd <- ask
61 inner <- trav $ pd ^.. pdElements . folded
46 inner <- trav $ pd ^.. pdElements . folded
62 for inner $ \(subpath, e) -> do
47 for inner $ \(subpath, e) -> do
48+ let
63− let newpd = ParserData
49+ newpd = ParserData
64− { _pdElements = Identity e
50+ { _pdElements = Identity e
65− , _pdPath = pd ^. pdPath <> subpath }
51+ , _pdPath = pd ^. pdPath <> subpath }
66− magnify (to $ const newpd) parser -- type of reader is changed, so
52+ lift $ runReaderT parser newpd
67− -- local does not work
68
53
69−-- | Takes function filtering
54+-- | Traverses elements located in same path using filtering function
70inFilteredTrav
55inFilteredTrav
71− :: (Monad m, Foldable g, DomTraversable f)
56+ :: (Monad m, Foldable g, Buildable f)
72 => ([Element] -> (DomPath, [Element]))
57 => ([Element] -> (DomPath, [Element]))
73− -- ^ Function returning some filtered elements with path suffixes which will
58+ -- ^ Takes list of current elements and returns some descendants
74− -- be appended to parser's state
59+ -- subset and path this descendants located at. Path is should be
60+ -- same for all descendants and required for error message
75 -> DomParserT Identity m a
61 -> DomParserT Identity m a
76 -> DomParserT g m (f a)
62 -> DomParserT g m (f a)
77inFilteredTrav deeper = traverseElems trav
63inFilteredTrav deeper = traverseElems trav
78 where
64 where
79 trav e = do
65 trav e = do
80 let (path, elems) = deeper e
66 let (path, elems) = deeper e
81− case buildDomTraversable elems of
67+ case build elems of
82 Nothing -> throwParserError $ PENotFound . (<> path)
68 Nothing -> throwParserError $ PENotFound . (<> path)
83 Just tr -> return $ fmap (path,) tr
69 Just tr -> return $ fmap (path,) tr
84
70
71+-- | Runs parser arbitrary times, depending on 'Buildable' instance of
72+-- 'f'. For example if 'f' becomes 'NonEmpty' then 'inElemTrav' finds
73+-- @one or more@ elements matched by given 'ElemMatcher' and run
74+-- parser in each found element, then returns @NonEmpty a@ of results.
85inElemTrav
75inElemTrav
86− :: (Monad m, Foldable g, DomTraversable f)
76+ :: (Monad m, Foldable g, Buildable f)
87− => Text
77+ => ElemMatcher -- ^ Tag(s) matcher to traverse in
88 -> DomParserT Identity m a
78 -> DomParserT Identity m a
89 -> DomParserT g m (f a)
79 -> DomParserT g m (f a)
90inElemTrav n = inFilteredTrav deeper
80inElemTrav n = inFilteredTrav deeper
91 where
81 where
92− deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)
82+ elemsFold = folded . nodes . folded . _Element . elMatch n
83+ deeper = (DomPath [_emShow n],) . toListOf elemsFold
93
84
94−-- | Runs parser inside first children element with given name
85+-- | Runs parser inside first children element matched by macher
95inElem
86inElem
96 :: (Monad m, Foldable g)
87 :: (Monad m, Foldable g)
97− => Text
88+ => ElemMatcher
98 -> DomParserT Identity m a
89 -> DomParserT Identity m a
99 -> DomParserT g m a
90 -> DomParserT g m a
100inElem n = fmap runIdentity . inElemTrav n
91inElem n = fmap runIdentity . inElemTrav n
101
92
102inElemAll
93inElemAll
103 :: (Monad m, Foldable g)
94 :: (Monad m, Foldable g)
104− => Text
95+ => ElemMatcher
105 -> DomParserT Identity m a
96 -> DomParserT Identity m a
106 -> DomParserT g m [a]
97 -> DomParserT g m [a]
107inElemAll = inElemTrav
98inElemAll = inElemTrav
108
99
109inElemMay
100inElemMay
110 :: (Monad m, Foldable g)
101 :: (Monad m, Foldable g)
111− => Text
102+ => ElemMatcher
112 -> DomParserT Identity m a
103 -> DomParserT Identity m a
113 -> DomParserT g m (Maybe a)
104 -> DomParserT g m (Maybe a)
114inElemMay = inElemTrav
105inElemMay = inElemTrav
115
106
116inElemNe
107inElemNe
117 :: (Monad m, Foldable g)
108 :: (Monad m, Foldable g)
118− => Text
109+ => ElemMatcher
119 -> DomParserT Identity m a
110 -> DomParserT Identity m a
120 -> DomParserT g m (NonEmpty a)
111 -> DomParserT g m (NonEmpty a)
121inElemNe = inElemTrav
112inElemNe = inElemTrav
122
113
123{- | Dive given parser's current tags set into the given path. The @divePath
114{- | Dive given parser's current tags set into the given path. The @divePath
124−["a", "b"]@ differs from @inElem "a" . inElem "b"@. Namely the first variant
115+["a", "b"]@ differs from @inElem "a" $ inElem "b"@. Namely the first variant
125will not fail if occured tag "a" which does not contains tag "b". This
116will not fail if occured tag "a" which does not contains tag "b". This
126behaviour is desireable when you dont want to parse whole XML and just want
117behaviour is desireable when you dont want to parse whole XML and just want
127−to pull tags in some path. The other difference is in traversing inner
118+to pull tags located in some path. The other difference is in traversing inner
128elements. Consider this code
119elements. Consider this code
129
120
130@
121@
@@ -142,26 +133,31 @@ which translates like: @a > b > c > fromDom@
142As you can see, inElem always takes first element and runs inner parser in this
133As you can see, inElem always takes first element and runs inner parser in this
143single element, unlike 'divePath' which runs inner parser @in all@ descendants
134single element, unlike 'divePath' which runs inner parser @in all@ descendants
144in given path.
135in given path.
136+
137+Note also that 'divePath' takes parser parameterized by @[]@ not by
138+'Identity'. This because when you dive using some path you will get a
139+list of found elements and all these elements will be @current@ for
140+parser.
145-}
141-}
146
142
147divePath
143divePath
148 :: forall m g a
144 :: forall m g a
149 . (Monad m, Foldable g)
145 . (Monad m, Foldable g)
150− => [Text]
146+ => [ElemMatcher]
151 -> DomParserT [] m a
147 -> DomParserT [] m a
152 -> DomParserT g m a
148 -> DomParserT g m a
153divePath path = magnify $ to modElems
149divePath path = magnify $ to modElems
154 where
150 where
155 modElems
151 modElems
156 = over pdElements (toListOf $ folded . diver)
152 = over pdElements (toListOf $ folded . diver)
157− . over pdPath (<> path)
153+ . over pdPath (<> DomPath (L.map _emShow path))
158 diver :: Fold Element Element
154 diver :: Fold Element Element
159− diver = foldr (.) id $ map toDive path
155+ diver = F.foldr (.) id $ L.map toDive path
160− toDive n = nodes . folded . _Element . ell n
156+ toDive n = nodes . folded . _Element . elMatch n
161
157
162diveElem
158diveElem
163 :: (Monad m, Foldable g)
159 :: (Monad m, Foldable g)
164− => Text
160+ => ElemMatcher
165 -> DomParserT [] m a
161 -> DomParserT [] m a
166 -> DomParserT g m a
162 -> DomParserT g m a
167diveElem p = divePath [p]
163diveElem p = divePath [p]
@@ -179,7 +175,7 @@ ignoreElem test parser = do
179 if ign then pure Nothing else Just <$> parser
175 if ign then pure Nothing else Just <$> parser
180
176
181-- | If current element has no children nodes does not run parser and returns
177-- | If current element has no children nodes does not run parser and returns
182−-- Nothing. Otherwise runs parser inside current element. Usefull when you got
178+-- Nothing. Otherwise runs parser inside current element. Useful when you got
183-- XML with strange empty elements which must be just ignored, but `inElem` runs
179-- XML with strange empty elements which must be just ignored, but `inElem` runs
184-- parser inside of this elements which causes to parser error.
180-- parser inside of this elements which causes to parser error.
185ignoreEmpty
181ignoreEmpty
@@ -188,7 +184,7 @@ ignoreEmpty
188 -> DomParserT Identity m (Maybe a)
184 -> DomParserT Identity m (Maybe a)
189ignoreEmpty = ignoreElem test
185ignoreEmpty = ignoreElem test
190 where
186 where
191− test e = null $ e ^. nodes
187+ test e = L.null $ e ^. nodes
192
188
193-- | If all current elements contains blank content, or contains nothing at all
189-- | If all current elements contains blank content, or contains nothing at all
194-- , then returns Nothing, else runs parser.
190-- , then returns Nothing, else runs parser.
@@ -202,114 +198,6 @@ ignoreBlank = ignoreElem test
202 let
198 let
203 elems = e ^.. nodes . folded . _Element
199 elems = e ^.. nodes . folded . _Element
204 cont = mconcat $ e ^.. nodes . folded . _Content
200 cont = mconcat $ e ^.. nodes . folded . _Content
205− in if | not $ null elems -> False
201+ in if | not $ L.null elems -> False
206 | T.null $ T.strip cont -> True
202 | T.null $ T.strip cont -> True
207 | otherwise -> False
203 | otherwise -> False
208−
209−-- | Returns name of current element.
210−--
211−-- @since 1.0.0
212−getCurrentName :: (Monad m) => DomParserT Identity m Text
213−getCurrentName = view $ pdElements . to runIdentity . localName
214−
215−-- | If name of current tag differs from first argument throws 'PENotFound' with
216−-- tag name replaced in last path's segment. Usefull for checking root
217−-- document's element name.
218−checkCurrentName
219− :: (Monad m)
220− => Text
221− -> DomParserT Identity m ()
222−checkCurrentName n = do
223− cn <- getCurrentName
224− unless (cn == n) $ do
225− p <- view pdPath
226− let pinit = if null p then [] else init p
227− throwError $ ParserErrors [PENotFound $ pinit ++ [n]]
228− return ()
229−
230−-- | Get current content. If current element contains no content or
231−-- have inner elements then Nothing returned
232−--
233−-- @since 1.0.0
234−getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)
235−getCurrentContent = do
236− nds <- view $ pdElements . to runIdentity . nodes
237− let
238− els :: [Element]
239− els = nds ^.. folded . _Element
240− conts :: [Text]
241− conts = nds ^.. folded . _Content
242− return $ if
243− | not $ null els -> Nothing
244− | null conts -> Nothing
245− | otherwise -> Just $ mconcat conts
246−
247−-- | Parses content inside current tag. It expects current element set
248−-- consists of exactly ONE element. If current element does not
249−-- contains content or have other elements as childs then throws error
250−parseContent
251− :: (Monad m)
252− => (Text -> Either Text a)
253− -- ^ Content parser, return error msg if value is not parsed
254− -> DomParserT Identity m a
255−parseContent parse = getCurrentContent >>= \case
256− Nothing -> throwParserError PEContentNotFound
257− Just c -> case parse c of
258− Left e -> throwParserError $ PEWrongFormat e
259− Right a -> return a
260−
261−-- | If reader returns 'Nothing' then resulting function returns 'Left
262−-- "error message"'
263−--
264−-- @since 1.0.0
265−maybeReadContent
266− :: forall a
267− . (Typeable a)
268− => (Text -> Maybe a)
269− -- ^ Content or attribute reader
270− -> Text
271− -- ^ Content or attribute value
272− -> Either Text a
273−maybeReadContent f t = maybe (Left msg) Right $ f t
274− where
275− msg = "Not readable " <> n <> ": " <> t
276− n = T.pack $ show $ typeRep (Proxy :: Proxy a)
277−
278−-- | Tries to read given text to value using 'Read'. Usefull to use
279−-- with 'parseContent' and 'parseAttribute'
280−readContent
281− :: (Read a, Typeable a)
282− => Text
283− -> Either Text a
284−readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
285−
286−-- | Retuns map of attributes of current element
287−--
288−-- @since 1.0.0
289−getCurrentAttributes :: (Monad m) => DomParserT Identity m (M.Map Name Text)
290−getCurrentAttributes = view $ pdElements . to runIdentity . attrs
291−
292−-- | Returns element with given name or 'Nothing'
293−--
294−-- @since 1.0.0
295−getCurrentAttribute :: (Monad m) => Text -> DomParserT Identity m (Maybe Text)
296−getCurrentAttribute attrName'
297− = preview $ pdElements . to runIdentity . attr attrName
298− where
299− attrName = Name attrName' Nothing Nothing
300−
301−-- | Parses attribute with given name, throws error if attribute is not found.
302−--
303−-- @since 1.0.0
304−parseAttribute
305− :: (Monad m)
306− => Text
307− -- ^ Attribute name
308− -> (Text -> Either Text a)
309− -- ^ Attribute content parser
310− -> DomParserT Identity m a
311−parseAttribute attrName parser = getCurrentAttribute attrName >>= \case
312− Nothing -> throwParserError $ PEAttributeNotFound attrName
313− Just aval -> case parser aval of
314− Left err -> throwParserError $ PEAttributeWrongFormat attrName err
315− Right a -> return a
src/Text/XML/DOM/Parser/Content.hsnew file+128
@@ -0,0 +1,128 @@
1+module Text.XML.DOM.Parser.Content
2+ (
3+ -- * Parsing element's content
4+ parseContent
5+ -- * Getting current element's properties
6+ , getCurrentName
7+ , getCurrentContent
8+ , checkCurrentName
9+ -- * Internal
10+ , maybeReadContent
11+ , readContent
12+ , readBool
13+ , readChar
14+ ) where
15+
16+import Control.Lens
17+import Control.Monad
18+import Control.Monad.Except
19+import Data.List as L
20+import Data.Monoid
21+import Data.Text as T
22+import Data.Typeable
23+import Text.Read
24+import Text.XML.DOM.Parser.Types
25+import Text.XML.Lens
26+
27+
28+-- | Parses content inside current tag. It expects current element set
29+-- consists of exactly ONE element.
30+parseContent
31+ :: (Monad m)
32+ => (Text -> Either Text a)
33+ -- ^ Content parser, return error msg if value is not parsed
34+ -> DomParserT Identity m a
35+parseContent parse = getCurrentContent >>= \case
36+ Nothing -> throwParserError PEContentNotFound
37+ Just c -> case parse c of
38+ Left e -> throwParserError $ PEContentWrongFormat e
39+ Right a -> return a
40+
41+
42+-- | Returns name of current element.
43+--
44+-- @since 1.0.0
45+getCurrentName :: (Monad m) => DomParserT Identity m Name
46+getCurrentName = view $ pdElements . to runIdentity . name
47+
48+-- | If name of current tag differs from first argument throws 'PENotFound' with
49+-- tag name replaced in last path's segment. Useful for checking root
50+-- document's element name.
51+checkCurrentName
52+ :: (Monad m)
53+ => NameMatcher
54+ -> DomParserT Identity m ()
55+checkCurrentName n = do
56+ cn <- getCurrentName
57+ unless ((n ^. nmMatch) cn) $ do
58+ p <- view pdPath
59+ let pinit = if L.null (unDomPath p) then [] else L.init $ unDomPath p
60+ throwError $ ParserErrors [PENotFound $ DomPath $ pinit ++ [_nmShow n]]
61+ return ()
62+
63+-- | Get current content. If current element contains no content or
64+-- have inner elements then Nothing returned
65+--
66+-- @since 1.0.0
67+getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)
68+getCurrentContent = do
69+ nds <- view $ pdElements . to runIdentity . nodes
70+ let
71+ els :: [Element]
72+ els = nds ^.. folded . _Element
73+ conts :: [Text]
74+ conts = nds ^.. folded . _Content
75+ return $ if
76+ | not $ L.null els -> Nothing
77+ | L.null conts -> Nothing
78+ | otherwise -> Just $ mconcat conts
79+
80+-- | If reader returns 'Nothing' then resulting function returns 'Left
81+-- "error message"'. 'Typeable' is used for generating usefull error
82+-- message.
83+--
84+-- @since 1.0.0
85+maybeReadContent
86+ :: forall a
87+ . (Typeable a)
88+ => (Text -> Maybe a)
89+ -- ^ Content or attribute reader
90+ -> Text
91+ -- ^ Content or attribute value
92+ -> Either Text a
93+maybeReadContent f t = maybe (Left msg) Right $ f t
94+ where
95+ msg = "Not readable " <> n <> ": " <> t
96+ n = T.pack $ show $ typeRep (Proxy :: Proxy a)
97+
98+
99+-- | Tries to read given text to value using 'Read'. Useful to use
100+-- with 'parseContent' and 'parseAttribute'. Content is stripped
101+-- before reading.
102+readContent
103+ :: (Read a, Typeable a)
104+ => Text
105+ -> Either Text a
106+readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
107+
108+
109+-- | @since 1.0.0
110+readBool :: Text -> Either Text Bool
111+readBool t =
112+ let
113+ lowt = T.toLower $ T.strip t
114+ tvals = ["y", "yes", "t", "true", "1"]
115+ fvals = ["n", "no", "f", "false", "0"]
116+ in if
117+ | lowt `elem` tvals -> Right True
118+ | lowt `elem` fvals -> Right False
119+ | otherwise ->
120+ Left $ "Could not read " <> t <> " as Bool"
121+
122+-- | Expects text to be single character
123+--
124+-- @since 1.0.0
125+readChar :: Text -> Either Text Char
126+readChar t = case T.unpack $ T.strip t of
127+ [c] -> Right c
128+ _ -> Left "Should have exactly one non-blank character"
src/Text/XML/DOM/Parser/FromAttribute.hsnew file+112
@@ -0,0 +1,112 @@
1+module Text.XML.DOM.Parser.FromAttribute
2+ ( -- * FromAttribute
3+ FromAttribute(..)
4+ , proxyFromAttribute
5+ -- * Explicit methods
6+ , textFromAttribute
7+ , stringFromAttribute
8+ , charFromAttribute
9+ , intFromAttribute
10+ , integerFromAttribute
11+ , doubleFromAttribute
12+ , fixedFromAttribute
13+ , boolFromAttribute
14+ , unitFromAttribute
15+ , voidFromAttribute
16+ , scientificFromAttribute
17+ ) where
18+
19+import Data.Fixed
20+import Data.Scientific
21+import Data.Text as T
22+import Data.Typeable
23+import Data.Void
24+import Text.XML.DOM.Parser.Content
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
31+class FromAttribute a where
32+ fromAttribute
33+ :: Text
34+ -- ^ Attribute contents to parse
35+ -> Either Text a
36+ -- ^ Either error message or result
37+
38+proxyFromAttribute
39+ :: FromAttribute a
40+ => Proxy a
41+ -> Text
42+ -> Either Text a
43+proxyFromAttribute _ = fromAttribute
44+
45+instance 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"
56+
57+instance 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
68+
69+instance FromAttribute Char where
70+ fromAttribute = charFromAttribute
71+
72+charFromAttribute :: Text -> Either Text Char
73+charFromAttribute = readChar
74+
75+instance FromAttribute Int where
76+ fromAttribute = intFromAttribute
77+
78+intFromAttribute :: Text -> Either Text Int
79+intFromAttribute = readContent
80+
81+instance 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
92+
93+instance (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
107+
108+instance FromAttribute Scientific where
109+ fromAttribute = scientificFromAttribute
110+
111+scientificFromAttribute :: Text -> Either Text Scientific
112+scientificFromAttribute = readContent
src/Text/XML/DOM/Parser/Class.hs → src/Text/XML/DOM/Parser/FromDom.hsrenamed+68−82
@@ -1,4 +1,4 @@
1−module Text.XML.DOM.Parser.Class
1+module Text.XML.DOM.Parser.FromDom
2 ( -- * FromDom
2 ( -- * FromDom
3 FromDom(..)
3 FromDom(..)
4 , proxyFromDom
4 , proxyFromDom
@@ -8,30 +8,28 @@ module Text.XML.DOM.Parser.Class
8 , textFromDom
8 , textFromDom
9 , stringFromDom
9 , stringFromDom
10 , charFromDom
10 , charFromDom
11− , readChar
12 , intFromDom
11 , intFromDom
13 , integerFromDom
12 , integerFromDom
14 , doubleFromDom
13 , doubleFromDom
15 , fixedFromDom
14 , fixedFromDom
16 , boolFromDom
15 , boolFromDom
17− , readBool
18 , unitFromDom
16 , unitFromDom
19 , voidFromDom
17 , voidFromDom
18+ , scientificFromDom
20 ) where
19 ) where
21
20
22−import Control.Applicative
21+import Control.Applicative
23−import Control.Lens
22+import Control.Lens
24−import Data.Fixed
23+import Data.Fixed
25−import Data.Monoid
26−import Data.OpenUnion
24+import Data.OpenUnion
27−import Data.Text (Text)
25+import Data.Scientific
28−import qualified Data.Text as T
26+import Data.Text as T hiding (empty)
29−import Data.Typeable
27+import Data.Typeable
30−import Data.Void
28+import Data.Void
31−import Text.XML
29+import Text.XML
32−import Text.XML.DOM.Parser.Combinators
30+import Text.XML.DOM.Parser.Content
33−import Text.XML.DOM.Parser.Types
31+import Text.XML.DOM.Parser.Types
34−import TypeFun.Data.List hiding (Union)
32+import TypeFun.Data.List hiding (Union)
35
33
36proxyFromDom
34proxyFromDom
37 :: forall proxy m a
35 :: forall proxy m a
@@ -40,55 +38,94 @@ proxyFromDom
40 -> DomParserT Identity m a
38 -> DomParserT Identity m a
41proxyFromDom _ = fromDom
39proxyFromDom _ = fromDom
42
40
43−-- | Class of types which can be parsed from single XML element.
41+-- | Class of types which can be parsed from single XML element. The
42+-- method 'fromDom' is convenient default to use with 'inElem'
44class FromDom a where
43class FromDom a where
45 fromDom :: (Monad m) => DomParserT Identity m a
44 fromDom :: (Monad m) => DomParserT Identity m a
46
45
47instance FromDom () where
46instance FromDom () where
48 fromDom = unitFromDom
47 fromDom = unitFromDom
49
48
49+-- | Always successfully parses any DOM to @()@
50+unitFromDom :: (Monad m) => DomParserT Identity m ()
51+unitFromDom = pure ()
52+
50instance FromDom Void where
53instance FromDom Void where
51 fromDom = voidFromDom
54 fromDom = voidFromDom
52
55
56+-- | Never parses successfully. It is just 'empty'
57+voidFromDom :: (Monad m) => DomParserT Identity m Void
58+voidFromDom = empty
59+
53instance FromDom Text where
60instance FromDom Text where
54 fromDom = textFromDom
61 fromDom = textFromDom
55
62
63+textFromDom :: (Monad m) => DomParserT Identity m Text
64+textFromDom = parseContent Right
65+
56instance FromDom String where
66instance FromDom String where
57 fromDom = stringFromDom
67 fromDom = stringFromDom
58
68
69+stringFromDom :: (Monad m) => DomParserT Identity m String
70+stringFromDom = parseContent $ Right . T.unpack
71+
59instance FromDom Char where
72instance FromDom Char where
60 fromDom = charFromDom
73 fromDom = charFromDom
61
74
75+charFromDom :: (Monad m) => DomParserT Identity m Char
76+charFromDom = parseContent readChar
77+
62instance FromDom Int where
78instance FromDom Int where
63 fromDom = intFromDom
79 fromDom = intFromDom
64
80
81+intFromDom :: (Monad m) => DomParserT Identity m Int
82+intFromDom = parseContent readContent
83+
65instance FromDom Integer where
84instance FromDom Integer where
66 fromDom = integerFromDom
85 fromDom = integerFromDom
67
86
87+integerFromDom :: (Monad m) => DomParserT Identity m Integer
88+integerFromDom = parseContent readContent
89+
68instance FromDom Double where
90instance FromDom Double where
69 fromDom = doubleFromDom
91 fromDom = doubleFromDom
70
92
93+doubleFromDom :: (Monad m) => DomParserT Identity m Double
94+doubleFromDom = parseContent readContent
95+
71instance (HasResolution a, Typeable a) => FromDom (Fixed a) where
96instance (HasResolution a, Typeable a) => FromDom (Fixed a) where
72 fromDom = fixedFromDom
97 fromDom = fixedFromDom
73
98
99+fixedFromDom
100+ :: (Monad m, Typeable a, HasResolution a)
101+ => DomParserT Identity m (Fixed a)
102+fixedFromDom = parseContent readContent
103+
104+instance FromDom Scientific where
105+ fromDom = scientificFromDom
106+
107+scientificFromDom :: Monad m => DomParserT Identity m Scientific
108+scientificFromDom = parseContent readContent
109+
74instance FromDom Bool where
110instance FromDom Bool where
75 fromDom = boolFromDom
111 fromDom = boolFromDom
76
112
113+-- | Expects content to be y, yes, t, true or 1 for True Values n, no,
114+-- f, false or 0 for False. Case is not significant, blank characters
115+-- are striped.
116+boolFromDom :: (Monad m) => DomParserT Identity m Bool
117+boolFromDom = parseContent readBool
118+
77instance FromDom (Union '[]) where
119instance FromDom (Union '[]) where
78 fromDom = empty
120 fromDom = empty
79
121
122+instance
80−instance ( Typeable a, FromDom a, FromDom (Union as)
123+ ( Typeable a, FromDom a, FromDom (Union as)
81− , SubList as (a ': as) )
124+ , SubList as (a ': as) )
82− => FromDom (Union (a ': as)) where
125+ => FromDom (Union (a ': as)) where
83 -- fromDom :: forall m. (DomParserMonad m) => m a
126 -- fromDom :: forall m. (DomParserMonad m) => m a
84 fromDom = (liftUnion <$> (proxyFromDom (Proxy :: Proxy a)))
127 fromDom = (liftUnion <$> (proxyFromDom (Proxy :: Proxy a)))
85− <|> (reUnion <$> (proxyFromDom (Proxy :: Proxy (Union as))))
128+ <|> (reUnion <$> (proxyFromDom (Proxy :: Proxy (Union as))))
86−
87−instance FromDom Element where
88− fromDom = elementFromDom
89−
90−elementFromDom :: (Monad m) => DomParserT Identity m Element
91−elementFromDom = view $ pdElements . to runIdentity
92
129
93unionFromDom
130unionFromDom
94 :: (Monad m, FromDom (Union as))
131 :: (Monad m, FromDom (Union as))
@@ -96,59 +133,8 @@ unionFromDom
96 -> DomParserT Identity m (Union as)
133 -> DomParserT Identity m (Union as)
97unionFromDom _ = fromDom
134unionFromDom _ = fromDom
98
135
99−textFromDom :: (Monad m) => DomParserT Identity m Text
136+instance FromDom Element where
100−textFromDom = parseContent Right
137+ fromDom = elementFromDom
101−
102−stringFromDom :: (Monad m) => DomParserT Identity m String
103−stringFromDom = parseContent $ Right . T.unpack
104−
105−charFromDom :: (Monad m) => DomParserT Identity m Char
106−charFromDom = parseContent readChar
107−
108−-- | Expects text to be single character
109−--
110−-- @since 1.0.0
111−readChar :: Text -> Either Text Char
112−readChar t = case T.unpack $ T.strip t of
113− [c] -> Right c
114− _ -> Left "Should have exactly one non-blank character"
115−
116−intFromDom :: (Monad m) => DomParserT Identity m Int
117−intFromDom = parseContent readContent
118−
119−integerFromDom :: (Monad m) => DomParserT Identity m Integer
120−integerFromDom = parseContent readContent
121−
122−doubleFromDom :: (Monad m) => DomParserT Identity m Double
123−doubleFromDom = parseContent readContent
124−
125−fixedFromDom
126− :: (Monad m, Typeable a, HasResolution a)
127− => DomParserT Identity m (Fixed a)
128−fixedFromDom = parseContent readContent
129−
130−-- | Expects content to be y, yes, t, true or 1 for True value. n, no,
131−-- f, false or 0 for False value. Case is not significant, blank
132−-- characters are striped.
133−boolFromDom :: (Monad m) => DomParserT Identity m Bool
134−boolFromDom = parseContent readBool
135−
136−-- | @since 1.0.0
137−readBool :: Text -> Either Text Bool
138−readBool t =
139− let
140− lowt = T.toLower $ T.strip t
141− tvals = ["y", "yes", "t", "true", "1"]
142− fvals = ["n", "no", "f", "false", "0"]
143− in if | lowt `elem` tvals -> Right True
144− | lowt `elem` fvals -> Right False
145− | otherwise ->
146− Left $ "Could not read " <> t <> " as Bool"
147−
148−-- | Always successfully parses any DOM to @()@
149−unitFromDom :: (Monad m) => DomParserT Identity m ()
150−unitFromDom = pure ()
151
138
152−-- | Never parses successfully. It is just 'mzero'
153−voidFromDom :: (Monad m) => DomParserT Identity m Void
139+elementFromDom :: (Monad m) => DomParserT Identity m Element
154−voidFromDom = empty
140+elementFromDom = view $ pdElements . to runIdentity
src/Text/XML/DOM/Parser/Types.hs+145−63
@@ -1,6 +1,19 @@
1module Text.XML.DOM.Parser.Types
1module Text.XML.DOM.Parser.Types
2+ (-- * Element matching
3+ ElemMatcher(..)
4+ , emMatch
5+ , emShow
6+ , matchElemName
7+ , elMatch
8+ -- * Name matching
9+ , NameMatcher(..)
10+ , nmMatch
11+ , nmShow
12+ , matchName
13+ , matchLocalName
14+ , matchCILocalName
2− ( -- * Parser internals
15+ -- * Parser internals
3− DomPath
16+ , DomPath(..)
4 , ParserError(..)
17 , ParserError(..)
5 , pePath
18 , pePath
6 , peDetails
19 , peDetails
@@ -10,47 +23,140 @@ module Text.XML.DOM.Parser.Types
10 , ParserData(..)
23 , ParserData(..)
11 , pdElements
24 , pdElements
12 , pdPath
25 , pdPath
13− -- * Parser type
14 , DomParserT
26 , DomParserT
15 , DomParser
27 , DomParser
16 , runDomParserT
28 , runDomParserT
17 , runDomParser
29 , runDomParser
18 -- * Auxiliary
30 -- * Auxiliary
19− , DomTraversable(..)
20 , throwParserError
31 , throwParserError
21− , throwWrongFormat
22 ) where
32 ) where
23
33
24−import Control.Exception
34+import Control.Exception
25−import Control.Lens
35+import Control.Lens
26−import Control.Monad.Except
36+import Control.Monad.Except
27−import Control.Monad.Reader
37+import Control.Monad.Reader
28−import Data.List.NonEmpty (NonEmpty(..))
38+import Data.CaseInsensitive as CI
29−import qualified Data.List.NonEmpty as NE
30−import Data.Maybe
39+import Data.String
31−import Data.Text (Text)
40+import Data.Text as T
32−import GHC.Generics (Generic)
41+import GHC.Generics (Generic)
33−import Text.XML
42+import Text.XML
34−import Text.XML.Lens
43+import Text.XML.Lens
35−
44+
36−type DomPath = [Text]
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
79+-- considered to be used as comparator with some name with some rules
80+--
81+-- @since 2.0.0
82+data NameMatcher = NameMatcher
83+ { _nmMatch :: Name -> Bool
84+ -- ^ Name matching function, usually should be simple comparsion
85+ -- function takin in account only local name or other components
86+ -- of 'Name'
87+ , _nmShow :: Text
88+ -- ^ Field for 'Show' instance and bulding usefull errors
89+ }
90+
91+makeLenses ''NameMatcher
92+
93+-- | Instance use 'matchCILocalName' as most general and liberal
94+-- matching strategy (while XML is often malformed).
95+--
96+-- @since 2.0.0
97+instance IsString NameMatcher where
98+ fromString = matchCILocalName . T.pack
99+
100+instance Show NameMatcher where
101+ show = T.unpack . _nmShow
102+
103+-- | Makes matcher which matches only local part of name igoring
104+-- namespace and prefix. Local name matching is case sensitive.
105+--
106+-- @since 2.0.0
107+matchLocalName :: Text -> NameMatcher
108+matchLocalName tname = NameMatcher
109+ { _nmMatch = \n -> nameLocalName n == tname
110+ , _nmShow = tname
111+ }
112+
113+-- | Makes matcher which matches only local part of name igoring
114+-- namespace and prefix. Local name matching is case insensitive. This
115+-- is the most common case.
116+--
117+-- @since 2.0.0
118+matchCILocalName :: Text -> NameMatcher
119+matchCILocalName tname = NameMatcher
120+ { _nmMatch = \n -> CI.mk (nameLocalName n) == CI.mk tname
121+ , _nmShow = tname
122+ }
123+
124+-- | Makes matcher which match name by 'Eq' with given
125+--
126+-- @since 2.0.0
127+matchName :: Name -> NameMatcher
128+matchName n = NameMatcher
129+ { _nmMatch = (== n)
130+ , _nmShow = nameLocalName n
131+ }
132+
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.
135+newtype DomPath = DomPath
136+ { unDomPath :: [Text]
137+ } deriving (Eq, Ord, Show, Monoid)
37
138
38-- | DOM parser error description.
139-- | DOM parser error description.
39data ParserError
140data ParserError
40 -- | Tag not found which should be.
141 -- | Tag not found which should be.
41 = PENotFound
142 = PENotFound
42 { _pePath :: DomPath
143 { _pePath :: DomPath
144+ -- ^ Path of element error occured in
43 }
145 }
44
146
45− -- | Tag contents has wrong format, (could not read text to value)
147+ -- | Expected attribute but not found
46− | PEWrongFormat
148+ --
47− { _peDetails :: Text
149+ -- @since 1.0.0
150+ | PEAttributeNotFound
151+ { _peAttributeName :: NameMatcher
48− , _pePath :: DomPath -- ^ path of element
152+ , _pePath :: DomPath
49 }
153 }
50
154
51 -- | Could not parse attribute
155 -- | Could not parse attribute
156+ --
157+ -- @since 1.0.0
52 | PEAttributeWrongFormat
158 | PEAttributeWrongFormat
53− { _peAttributeName :: Text
159+ { _peAttributeName :: NameMatcher
54 , _peDetails :: Text
160 , _peDetails :: Text
55 , _pePath :: DomPath
161 , _pePath :: DomPath
56 }
162 }
@@ -60,17 +166,17 @@ data ParserError
60 { _pePath :: DomPath
166 { _pePath :: DomPath
61 }
167 }
62
168
63− -- | Expected attribute but not found
169+ -- | Tag contents has wrong format, (could not read text to value)
64− | PEAttributeNotFound
170+ | PEContentWrongFormat
65− { _peAttributeName :: Text
171+ { _peDetails :: Text
66− , _pePath :: DomPath
172+ , _pePath :: DomPath
67 }
173 }
68
174
69 -- | Some other error
175 -- | Some other error
70 | PEOther
176 | PEOther
71 { _peDetails :: Text
177 { _peDetails :: Text
72 , _pePath :: DomPath
178 , _pePath :: DomPath
73− } deriving (Eq, Ord, Show, Generic)
179+ } deriving (Show, Generic)
74
180
75makeLenses ''ParserError
181makeLenses ''ParserError
76
182
@@ -78,15 +184,16 @@ instance Exception ParserError
78
184
79newtype ParserErrors = ParserErrors
185newtype ParserErrors = ParserErrors
80 { unParserErrors :: [ParserError]
186 { unParserErrors :: [ParserError]
81− } deriving (Ord, Eq, Show, Monoid, Generic)
187+ } deriving (Show, Monoid, Generic)
82
188
83makePrisms ''ParserErrors
189makePrisms ''ParserErrors
84
190
85instance Exception ParserErrors
191instance Exception ParserErrors
86
192
87
193
194+{- | Parser scope.
195+
88−{- | Parser scope parser runs in. Functor argument is usually @Identity@ or
196+Functor argument is usually @Identity@ or @[]@.
89−@[]@.
90
197
91If functor is @Identity@ then parser expects exactly ONE current element. This
198If functor is @Identity@ then parser expects exactly ONE current element. This
92is common behavior for content parsers, or parsers expecting strict XML
199is common behavior for content parsers, or parsers expecting strict XML
@@ -119,10 +226,11 @@ runDomParserT
119 -> DomParserT Identity m a
226 -> DomParserT Identity m a
120 -> m (Either ParserErrors a)
227 -> m (Either ParserErrors a)
121runDomParserT doc par =
228runDomParserT doc par =
229+ let
122− let pd = ParserData
230+ pd = ParserData
123− { _pdElements = doc ^. root . to pure
231+ { _pdElements = doc ^. root . to pure
124− , _pdPath = [doc ^. root . localName]
232+ , _pdPath = DomPath [doc ^. root . name . to nameLocalName]
125− }
233+ }
126 in runExceptT $ runReaderT par pd
234 in runExceptT $ runReaderT par pd
127
235
128runDomParser
236runDomParser
@@ -131,36 +239,10 @@ runDomParser
131 -> Either ParserErrors a
239 -> Either ParserErrors a
132runDomParser doc par = runIdentity $ runDomParserT doc par
240runDomParser doc par = runIdentity $ runDomParserT doc par
133
241
134−-- | Class of traversable functors which may be constructed from list. Or may
135−-- not.
136−class Traversable f => DomTraversable f where
137− -- | If method return Nothing this means we can not build traversable from
138− -- given list. In this case combinator should fail traversing.
139− buildDomTraversable :: [a] -> Maybe (f a)
140−
141−instance DomTraversable Identity where
142− buildDomTraversable = fmap Identity . listToMaybe
143−
144−instance DomTraversable [] where
145− buildDomTraversable = Just
146−
147−instance DomTraversable Maybe where
148− buildDomTraversable = Just . listToMaybe
149−
150−instance DomTraversable NonEmpty where
151− buildDomTraversable = NE.nonEmpty
152−
153throwParserError
242throwParserError
154 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
243 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
155− => ([Text] -> ParserError)
244+ => (DomPath -> ParserError)
156 -> m a
245 -> m a
157throwParserError mkerr = do
246throwParserError mkerr = do
158 path <- view pdPath
247 path <- view pdPath
159− throwError $ ParserErrors [mkerr path]
248+ throwError $ ParserErrors $ [mkerr path]
160−
161−-- | Throw 'PEWrongFormat' as very common case
162−throwWrongFormat
163− :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
164− => Text
165− -> m a
166−throwWrongFormat err = throwParserError $ PEWrongFormat err
stack.yaml+1−1
@@ -3,4 +3,4 @@ packages:
3extra-deps:
3extra-deps:
4 - open-union-0.2.0.0
4 - open-union-0.2.0.0
5 - type-fun-0.1.1
5 - type-fun-0.1.1
6−resolver: lts-5.18
6+resolver: lts-6.25
test/Main.hs+10−10
@@ -33,7 +33,7 @@ testStructureAttributes = do
33 int <- parseAttribute "int" readContent
33 int <- parseAttribute "int" readContent
34 bool <- parseAttribute "bool" readBool
34 bool <- parseAttribute "bool" readBool
35 return $ TestStructure
35 return $ TestStructure
36− { tsName = name
36+ { tsName = nameLocalName name
37 , tsInts = [int]
37 , tsInts = [int]
38 , tsBools = pure bool }
38 , tsBools = pure bool }
39
39
@@ -156,7 +156,7 @@ specParser
156 :: String -- ^ Name of spec
156 :: String -- ^ Name of spec
157 -> Document -- ^ Document to parse
157 -> Document -- ^ Document to parse
158 -> (a -> Maybe String) -- ^ Value checker, Nothing if all ok
158 -> (a -> Maybe String) -- ^ Value checker, Nothing if all ok
159− -> DomParser Identity a -- ^ Parser itself
159+ -> DomParser Identity a -- ^ Parser itself
160 -> Spec
160 -> Spec
161specParser name doc check parser = it name $ do
161specParser name doc check parser = it name $ do
162 result <- either throwIO return $ runDomParser doc parser
162 result <- either throwIO return $ runDomParser doc parser
@@ -166,9 +166,9 @@ specParser name doc check parser = it name $ do
166
166
167specParserEq
167specParserEq
168 :: (Eq a, Show a)
168 :: (Eq a, Show a)
169− => String -- ^ Name of spec
169+ => String -- ^ Name of spec
170− -> Document -- ^ Document to parse
170+ -> Document -- ^ Document to parse
171− -> a -- ^ Value parser should return
171+ -> a -- ^ Value parser should return
172 -> DomParser Identity a -- ^ Parser itself
172 -> DomParser Identity a -- ^ Parser itself
173 -> Spec
173 -> Spec
174specParserEq name doc a parser = specParser name doc check parser
174specParserEq name doc a parser = specParser name doc check parser
@@ -193,7 +193,7 @@ specParserFailedPath
193 :: (Show a)
193 :: (Show a)
194 => String -- ^ Name of spec
194 => String -- ^ Name of spec
195 -> Document
195 -> Document
196− -> [Text] -- ^ Expteced path in error
196+ -> DomPath -- ^ Expteced path in error
197 -> DomParser Identity a
197 -> DomParser Identity a
198 -> Spec
198 -> Spec
199specParserFailedPath name doc path parser = it name $ example $ do
199specParserFailedPath name doc path parser = it name $ example $ do
@@ -226,7 +226,7 @@ combinationsSpec = do
226 describe "deep" $ do
226 describe "deep" $ do
227 let parser = inElem "a" $ inElem "b" textFromDom
227 let parser = inElem "a" $ inElem "b" textFromDom
228 specParserFailedPath "docDeepMultiple2" docDeepMultiple2
228 specParserFailedPath "docDeepMultiple2" docDeepMultiple2
229− ["root", "a", "b"] parser
229+ (DomPath ["root", "a", "b"]) parser
230 -- should fail here because first tag "a" does not contains
230 -- should fail here because first tag "a" does not contains
231 -- tag "b" which is expected by parser @inElem "b"@
231 -- tag "b" which is expected by parser @inElem "b"@
232
232
@@ -276,7 +276,7 @@ combinationsSpec = do
276 specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser
276 specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser
277 specParserEq "docDeepMultiple2" docDeepMultiple2 "content1" parser
277 specParserEq "docDeepMultiple2" docDeepMultiple2 "content1" parser
278 describe "fails" $ do
278 describe "fails" $ do
279− specParserFailedPath "docSimple" docSimple ["root", "a", "b"] parser
279+ specParserFailedPath "docSimple" docSimple (DomPath ["root", "a", "b"]) parser
280 describe "multiple elements" $ do
280 describe "multiple elements" $ do
281 let
281 let
282 parser = diveElem "a" $ inElemAll "b" textFromDom
282 parser = diveElem "a" $ inElemAll "b" textFromDom
@@ -311,9 +311,9 @@ combinationsSpec = do
311 inElem "a" $ do
311 inElem "a" $ do
312 checkCurrentName "a"
312 checkCurrentName "a"
313 describe "fails" $ do
313 describe "fails" $ do
314− specParserFailedPath "root element" docSimple ["toor"] $ do
314+ specParserFailedPath "root element" docSimple (DomPath ["toor"]) $ do
315 checkCurrentName "toor"
315 checkCurrentName "toor"
316− specParserFailedPath "inner element" docSimple ["root", "b"] $ do
316+ specParserFailedPath "inner element" docSimple (DomPath ["root", "b"]) $ do
317 inElem "a" $ checkCurrentName "b"
317 inElem "a" $ checkCurrentName "b"
318
318
319contentSpec :: Spec
319contentSpec :: Spec