git.iko.soy/typeable/dom-parser
on master help sign in
Upd: add support for parsing attributes
commitf7ff3702e718482ea6e1586c9c9cfc41d43f91df authorAleksey Uimanov <s9gf4ult@gmail.com> dateWed 21 Dec 2016, 22:33 (10 years ago) parent2f27a00
5 files changed+220−70
compare with master
unifiedsplit
dom-parser.cabal+2−2 src/Text/XML/DOM/Parser/Class.hs+18−12 src/Text/XML/DOM/Parser/Combinators.hs+89−29 src/Text/XML/DOM/Parser/Types.hs+23−6 test/Main.hs+88−21
dom-parser.cabal+2−2
@@ -1,5 +1,5 @@
11name: dom-parser
2−version: 0.1.0
2+version: 1.0.0
33synopsis: Simple monadic DOM parser
44license: MIT
55license-file: LICENSE
@@ -36,11 +36,11 @@ library
3636 , TypeOperators
3737 , UndecidableInstances
3838 build-depends: base >= 4.7 && < 5
39+ , containers
3940 , lens
4041 , mtl
4142 , open-union
4243 , semigroups
43− , shakespeare
4444 , text
4545 , transformers
4646 , type-fun
src/Text/XML/DOM/Parser/Class.hs+18−12
@@ -8,11 +8,13 @@ module Text.XML.DOM.Parser.Class
88 , textFromDom
99 , stringFromDom
1010 , charFromDom
11+ , readChar
1112 , intFromDom
1213 , integerFromDom
1314 , doubleFromDom
1415 , fixedFromDom
1516 , boolFromDom
17+ , readBool
1618 , unitFromDom
1719 , voidFromDom
1820 ) where
@@ -20,12 +22,12 @@ module Text.XML.DOM.Parser.Class
2022import Control.Applicative
2123import Control.Lens
2224import Data.Fixed
25+import Data.Monoid
2326import Data.OpenUnion
2427import Data.Text (Text)
2528import qualified Data.Text as T
2629import Data.Typeable
2730import Data.Void
28−import Text.Shakespeare.Text (st)
2931import Text.XML
3032import Text.XML.DOM.Parser.Combinators
3133import Text.XML.DOM.Parser.Types
@@ -95,16 +97,18 @@ unionFromDom
9597unionFromDom _ = fromDom
9698
9799textFromDom :: (Monad m) => DomParserT Identity m Text
98−textFromDom = parseContent pure
100+textFromDom = parseContent Right
99101
100102stringFromDom :: (Monad m) => DomParserT Identity m String
101−stringFromDom = parseContent $ pure . T.unpack
103+stringFromDom = parseContent $ Right . T.unpack
102104
103105charFromDom :: (Monad m) => DomParserT Identity m Char
104−charFromDom = parseContent $ \t -> case T.unpack $ T.strip t of
105− [c] -> pure c
106− _ -> throwParserError $ PEWrongFormat
107− "Should have exactly one non-blank character"
106+charFromDom = parseContent readChar
107+
108+readChar :: Text -> Either Text Char
109+readChar t = case T.unpack $ T.strip t of
110+ [c] -> Right c
111+ _ -> Left "Should have exactly one non-blank character"
108112
109113intFromDom :: (Monad m) => DomParserT Identity m Int
110114intFromDom = parseContent readContent
@@ -124,16 +128,18 @@ fixedFromDom = parseContent readContent
124128-- f, false or 0 for False value. Case is not significant, blank
125129-- characters are striped.
126130boolFromDom :: (Monad m) => DomParserT Identity m Bool
127−boolFromDom = parseContent $ \t ->
131+boolFromDom = parseContent readBool
132+
133+readBool :: Text -> Either Text Bool
134+readBool t =
128135 let
129136 lowt = T.toLower $ T.strip t
130137 tvals = ["y", "yes", "t", "true", "1"]
131138 fvals = ["n", "no", "f", "false", "0"]
132− in if | lowt `elem` tvals -> return True
133− | lowt `elem` fvals -> return False
139+ in if | lowt `elem` tvals -> Right True
140+ | lowt `elem` fvals -> Right False
134141 | otherwise ->
135− let msg = [st|Could not read "#{t}" as Bool|]
136− in throwParserError $ PEWrongFormat msg
142+ Left $ "Could not read " <> t <> " as Bool"
137143
138144-- | Always successfully parses any DOM to @()@
139145unitFromDom :: (Monad m) => DomParserT Identity m ()
src/Text/XML/DOM/Parser/Combinators.hs+89−29
@@ -15,24 +15,32 @@ module Text.XML.DOM.Parser.Combinators
1515 , ignoreElem
1616 , ignoreEmpty
1717 , ignoreBlank
18− -- * Checking current element properties
18+ -- * Getting current element's properties
19+ , getCurrentName
20+ , getCurrentContent
21+ , getCurrentAttributes
22+ , getCurrentAttribute
23+ -- * Current element's checks
1924 , checkCurrentName
20− -- * Parsing arbitrary content
25+ -- * Parsing element's content
2126 , parseContent
2227 , readContent
28+ , maybeReadContent
29+ -- * Parsing attributes
30+ , parseAttribute
2331 ) where
2432
2533import Control.Lens
2634import Control.Monad.Except
2735import Control.Monad.Reader
2836import Data.List.NonEmpty (NonEmpty(..))
37+import qualified Data.Map.Strict as M
2938import Data.Monoid
3039import Data.Text (Text)
3140import qualified Data.Text as T
3241import Data.Traversable
3342import Data.Typeable
3443import Text.Read
35−import Text.Shakespeare.Text (st)
3644import Text.XML
3745import Text.XML.DOM.Parser.Types
3846import Text.XML.Lens
@@ -41,8 +49,10 @@ import Text.XML.Lens
4149-- | Generic function to traverse arbitrary inner cursors.
4250traverseElems
4351 :: (Monad m, Foldable g, Traversable f)
44− => ([Element] -> DomParserT g m (f ([Text], Element)))
45− -- ^ Takes set of current elements and
52+ => ([Element] -> DomParserT g m (f (DomPath, Element)))
53+ -- ^ Takes list of current elements and returns container with
54+ -- pairs of subpath (relatively to current element) and element
55+ -- to run parser in
4656 -> DomParserT Identity m a
4757 -- ^ Parser will be runned for each element found in traversable
4858 -> DomParserT g m (f a)
@@ -53,12 +63,13 @@ traverseElems trav parser = do
5363 let newpd = ParserData
5464 { _pdElements = Identity e
5565 , _pdPath = pd ^. pdPath <> subpath }
56− magnify (to $ const newpd) parser
66+ magnify (to $ const newpd) parser -- type of reader is changed, so
67+ -- local does not work
5768
5869-- | Takes function filtering
5970inFilteredTrav
6071 :: (Monad m, Foldable g, DomTraversable f)
61− => ([Element] -> ([Text], [Element]))
72+ => ([Element] -> (DomPath, [Element]))
6273 -- ^ Function returning some filtered elements with path suffixes which will
6374 -- be appended to parser's state
6475 -> DomParserT Identity m a
@@ -160,7 +171,7 @@ ignoreElem
160171 :: (Monad m)
161172 => (Element -> Bool)
162173 -- ^ Predicate checking that we must ignore some current tag. If returns
163− -- true then parser will not be runned and combinator just returns Nothing.
174+ -- 'True' then parser will not be runned and combinator just returns Nothing.
164175 -> DomParserT Identity m a
165176 -> DomParserT Identity m (Maybe a)
166177ignoreElem test parser = do
@@ -195,6 +206,10 @@ ignoreBlank = ignoreElem test
195206 | T.null $ T.strip cont -> True
196207 | otherwise -> False
197208
209+-- | Returns name of current element.
210+getCurrentName :: (Monad m) => DomParserT Identity m Text
211+getCurrentName = view $ pdElements . to runIdentity . localName
212+
198213-- | If name of current tag differs from first argument throws 'PENotFound' with
199214-- tag name replaced in last path's segment. Usefull for checking root
200215-- document's element name.
@@ -203,37 +218,82 @@ checkCurrentName
203218 => Text
204219 -> DomParserT Identity m ()
205220checkCurrentName n = do
206− cn <- view $ pdElements . to runIdentity . localName
221+ cn <- getCurrentName
207222 unless (cn == n) $ do
208223 p <- view pdPath
209224 let pinit = if null p then [] else init p
210225 throwError $ ParserErrors [PENotFound $ pinit ++ [n]]
211226 return ()
212227
213−-- | Parses content inside current tag. It expects current element set consists
214−-- of exactly ONE element. Throws error if current elements set contains
215−-- multiple of them.
216−parseContent
217− :: (Monad m)
218− => (Text -> DomParserT Identity m a)
219− -> DomParserT Identity m a
220−parseContent parse = do
221− e <- view $ pdElements . to runIdentity
228+-- | Get current content. If current element contains no content or
229+-- have inner elements then Nothing returned
230+getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)
231+getCurrentContent = do
232+ nds <- view $ pdElements . to runIdentity . nodes
222233 let
223− nds = e ^. nodes
234+ els :: [Element]
224235 els = nds ^.. folded . _Element
236+ conts :: [Text]
225237 conts = nds ^.. folded . _Content
226− when (not $ null els) $ throwParserError PEContentNotFound
227− when (null conts) $ throwParserError PEContentNotFound
228− parse $ mconcat conts
238+ return $ if
239+ | not $ null els -> Nothing
240+ | null conts -> Nothing
241+ | otherwise -> Just $ mconcat conts
242+
243+-- | Parses content inside current tag. It expects current element set
244+-- consists of exactly ONE element. If current element does not
245+-- contains content or have other elements as childs then throws error
246+parseContent
247+ :: (Monad m)
248+ => (Text -> Either Text a)
249+ -- ^ Content parser, return error msg if value is not parsed
250+ -> DomParserT Identity m a
251+parseContent parse = getCurrentContent >>= \case
252+ Nothing -> throwParserError PEContentNotFound
253+ Just c -> case parse c of
254+ Left e -> throwParserError $ PEWrongFormat e
255+ Right a -> return a
256+
257+maybeReadContent
258+ :: forall a
259+ . (Typeable a)
260+ => (Text -> Maybe a)
261+ -- ^ Content or attribute reader
262+ -> Text
263+ -- ^ Content or attribute value
264+ -> Either Text a
265+maybeReadContent f t = maybe (Left msg) Right $ f t
266+ where
267+ msg = "Not readable " <> n <> ": " <> t
268+ n = T.pack $ show $ typeRep (Proxy :: Proxy a)
229269
270+-- | Tries to read given text to value using 'Read'. Usefull to use
271+-- with 'parseContent' and 'parseAttribute'
230272readContent
231− :: forall m g a
232− . (Read a, Typeable a, Monad m)
273+ :: (Read a, Typeable a)
233274 => Text
234− -> DomParserT g m a
235−readContent t = case readMaybe $ T.unpack t of
236− Nothing -> throwParserError $ PEWrongFormat [st|Not readable #{n}: #{t}|]
237− Just a -> pure a
275+ -> Either Text a
276+readContent = maybeReadContent $ readMaybe . T.unpack . T.strip
277+
278+getCurrentAttributes :: (Monad m) => DomParserT Identity m (M.Map Name Text)
279+getCurrentAttributes = view $ pdElements . to runIdentity . attrs
280+
281+getCurrentAttribute :: (Monad m) => Text -> DomParserT Identity m (Maybe Text)
282+getCurrentAttribute attrName'
283+ = preview $ pdElements . to runIdentity . attr attrName
238284 where
239− n = show $ typeRep (Proxy :: Proxy a)
285+ attrName = Name attrName' Nothing Nothing
286+
287+-- | Parses attribute with given name, throws error if attribute is not found.
288+parseAttribute
289+ :: (Monad m)
290+ => Text
291+ -- ^ Attribute name
292+ -> (Text -> Either Text a)
293+ -- ^ Attribute content parser
294+ -> DomParserT Identity m a
295+parseAttribute attrName parser = getCurrentAttribute attrName >>= \case
296+ Nothing -> throwParserError $ PEAttributeNotFound attrName
297+ Just aval -> case parser aval of
298+ Left err -> throwParserError $ PEAttributeWrongFormat attrName err
299+ Right a -> return a
src/Text/XML/DOM/Parser/Types.hs+23−6
@@ -1,8 +1,10 @@
11module Text.XML.DOM.Parser.Types
22 ( -- * Parser internals
3− ParserError(..)
3+ DomPath
4+ , ParserError(..)
45 , pePath
56 , peDetails
7+ , peAttributeName
68 , ParserErrors(..)
79 , _ParserErrors
810 , ParserData(..)
@@ -31,28 +33,43 @@ import GHC.Generics (Generic)
3133import Text.XML
3234import Text.XML.Lens
3335
36+type DomPath = [Text]
37+
3438-- | DOM parser error description.
3539data ParserError
3640 -- | Tag not found which should be.
3741 = PENotFound
38− { _pePath :: [Text]
42+ { _pePath :: DomPath
3943 }
4044
4145 -- | Tag contents has wrong format, (could not read text to value)
4246 | PEWrongFormat
4347 { _peDetails :: Text
44− , _pePath :: [Text] -- ^ path of element
48+ , _pePath :: DomPath -- ^ path of element
49+ }
50+
51+ -- | Could not parse attribute
52+ | PEAttributeWrongFormat
53+ { _peAttributeName :: Text
54+ , _peDetails :: Text
55+ , _pePath :: DomPath
4556 }
4657
4758 -- | Node should have text content, but it does not.
4859 | PEContentNotFound
49− { _pePath :: [Text]
60+ { _pePath :: DomPath
61+ }
62+
63+ -- | Expected attribute but not found
64+ | PEAttributeNotFound
65+ { _peAttributeName :: Text
66+ , _pePath :: DomPath
5067 }
5168
5269 -- | Some other error
5370 | PEOther
5471 { _peDetails :: Text
55− , _pePath :: [Text]
72+ , _pePath :: DomPath
5673 } deriving (Eq, Ord, Show, Generic)
5774
5875makeLenses ''ParserError
@@ -86,7 +103,7 @@ data ParserData f = ParserData
86103 { _pdElements :: f Element
87104 -- ^ Current element(s). Functor is intended to be either @Identity@ or
88105 -- @[]@
89− , _pdPath :: [Text]
106+ , _pdPath :: DomPath
90107 -- ^ Path for error reporting
91108 }
92109
test/Main.hs+88−21
@@ -27,8 +27,15 @@ testStructureFromDom = do
2727 tsBools <- inElemNe "bool" boolFromDom
2828 return TestStructure{..}
2929
30−instance FromDom TestStructure where
31− fromDom = testStructureFromDom
30+testStructureAttributes :: (Monad m) => DomParserT Identity m TestStructure
31+testStructureAttributes = do
32+ name <- getCurrentName
33+ int <- parseAttribute "int" readContent
34+ bool <- parseAttribute "bool" readBool
35+ return $ TestStructure
36+ { tsName = name
37+ , tsInts = [int]
38+ , tsBools = pure bool }
3239
3340docStruct :: Document
3441docStruct = parseText_ def [lt|
@@ -41,6 +48,13 @@ docStruct = parseText_ def [lt|
4148</root>
4249|]
4350
51+docAttrStruct :: Document
52+docAttrStruct = parseText_ def [lt|
53+<?xml version="1.0" encoding="utf-8"?>
54+<structure int="10" bool="t">
55+</structure>
56+|]
57+
4458docNone :: Document
4559docNone = parseText_ def [lt|
4660<?xml version="1.0" encoding="utf-8"?>
@@ -48,8 +62,26 @@ docNone = parseText_ def [lt|
4862</root>
4963|]
5064
51−docEmpty :: Document
52−docEmpty = parseText_ def [lt|
65+docSimpleAttr :: Document
66+docSimpleAttr = parseText_ def [lt|
67+<?xml version="1.0" encoding="utf-8"?>
68+<root>
69+<a attr="content"/>
70+</root>
71+|]
72+
73+docMultipleAttr :: Document
74+docMultipleAttr = parseText_ def [lt|
75+<?xml version="1.0" encoding="utf-8"?>
76+<root>
77+<a attr="content1"/>
78+<a attr="content2"/>
79+<a attr="content3"/>
80+</root>
81+|]
82+
83+docSingleEmpty :: Document
84+docSingleEmpty = parseText_ def [lt|
5385<?xml version="1.0" encoding="utf-8"?>
5486<root>
5587 <a/>
@@ -176,13 +208,37 @@ specParserFailedPath name doc path parser = it name $ example $ do
176208combinationsSpec :: Spec
177209combinationsSpec = do
178210 describe "inElem" $ do
179− let parser = inElem "a" textFromDom
180211 describe "succeeds" $ do
181− specParserEq "docSimple" docSimple "content" parser
182− specParserEq "docMultiple" docMultiple "content1" parser
212+ describe "simple" $ do
213+ let parser = inElem "a" textFromDom
214+ specParserEq "docSimple" docSimple "content" parser
215+ specParserEq "docMultiple" docMultiple "content1" parser
216+ describe "deep" $ do
217+ let parser = inElem "a" $ inElem "b" textFromDom
218+ specParserEq "docDeep" docDeep "content" parser
219+ specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser
220+ specParserEq "docDeepWithContent" docDeepWithContent "content" parser
183221 describe "fails" $ do
184− specParserFailed "docNone" docNone parser
185− specParserFailed "docEmpty" docEmpty parser
222+ describe "simple" $ do
223+ let parser = inElem "a" textFromDom
224+ specParserFailed "docNone" docNone parser
225+ specParserFailed "docSingleEmpty" docSingleEmpty parser
226+ describe "deep" $ do
227+ let parser = inElem "a" $ inElem "b" textFromDom
228+ specParserFailedPath "docDeepMultiple2" docDeepMultiple2
229+ ["root", "a", "b"] parser
230+ -- should fail here because first tag "a" does not contains
231+ -- tag "b" which is expected by parser @inElem "b"@
232+
233+ describe "parseAttribute" $ do
234+ describe "succeeds" $ do
235+ specParserEq "docSimpleAttr" docSimpleAttr "content"
236+ $ inElem "a" $ parseAttribute "attr" Right
237+ let res = ["content1", "content2", "content3"]
238+ specParserEq "docMultipleAttr" docMultipleAttr res
239+ $ inElemAll "a" $ parseAttribute "attr" Right
240+ describe "fails" $ do
241+ specParserFailed "docNone" docNone $ parseAttribute "attr" Right
186242
187243 describe "inElemAll" $ do
188244 let parser = inElemAll "a" textFromDom
@@ -192,7 +248,7 @@ combinationsSpec = do
192248 specParserEq "docMultiple" docMultiple
193249 ["content1", "content2", "content3"] parser
194250 describe "fails" $ do
195− specParserFailed "docEmpty" docEmpty parser
251+ specParserFailed "docSingleEmpty" docSingleEmpty parser
196252
197253 describe "inElemMay" $ do
198254 let parser = inElemMay "a" textFromDom
@@ -201,7 +257,7 @@ combinationsSpec = do
201257 specParserEq "docSimple" docSimple (Just "content") parser
202258 specParserEq "docMultiple" docMultiple (Just "content1") parser
203259 describe "fails" $ do
204− specParserFailed "docEmpty" docEmpty parser
260+ specParserFailed "docSingleEmpty" docSingleEmpty parser
205261
206262 describe "inElemNe" $ do
207263 let parser = inElemNe "a" textFromDom
@@ -211,7 +267,7 @@ combinationsSpec = do
211267 (NE.fromList ["content1", "content2", "content3"]) parser
212268 describe "fails" $ do
213269 specParserFailed "docNone" docNone parser
214− specParserFailed "docEmpty" docEmpty parser
270+ specParserFailed "docSingleEmpty" docSingleEmpty parser
215271
216272 describe "diveElem" $ do
217273 describe "single element" $ do
@@ -234,7 +290,7 @@ combinationsSpec = do
234290 describe "mandatory element" $ do
235291 let parser = inElem "a" $ ignoreEmpty textFromDom
236292 describe "succeeds" $ do
237− specParserEq "docEmpty" docEmpty Nothing parser
293+ specParserEq "docSingleEmpty" docSingleEmpty Nothing parser
238294 specParserEq "docSimple" docSimple (Just "content") parser
239295 specParserEq "docMultiple" docMultiple (Just "content1") parser
240296 describe "fails" $ do
@@ -243,7 +299,7 @@ combinationsSpec = do
243299 let parser = fmap join $ inElemMay "a" $ ignoreEmpty textFromDom
244300 describe "succeeds" $ do
245301 specParserEq "docNone" docNone Nothing parser
246− specParserEq "docEmpty" docEmpty Nothing parser
302+ specParserEq "docSingleEmpty" docSingleEmpty Nothing parser
247303 specParserEq "docSimple" docSimple (Just "content") parser
248304 specParserEq "docMultiple" docMultiple (Just "content1") parser
249305
@@ -271,14 +327,25 @@ contentSpec = do
271327structSpec :: Spec
272328structSpec = do
273329 describe "succeeds" $ do
274− let
275− result = TestStructure
276− { tsName = "name"
277− , tsInts = [1,2]
278− , tsBools = pure True }
279− specParserEq "docStruct" docStruct result fromDom
330+ describe "dom structure" $ do
331+ let
332+ result = TestStructure
333+ { tsName = "name"
334+ , tsInts = [1,2]
335+ , tsBools = pure True }
336+ specParserEq "docStruct" docStruct result testStructureFromDom
337+ describe "attribute structure" $ do
338+ let
339+ result = TestStructure
340+ { tsName = "structure"
341+ , tsInts = [10]
342+ , tsBools = pure True }
343+ specParserEq "docAttrStruct" docAttrStruct result testStructureAttributes
280344 describe "fails" $ do
281− specParserFailed "docSimple" docSimple testStructureFromDom
345+ describe "dom structure" $ do
346+ specParserFailed "docSimple" docSimple testStructureFromDom
347+ describe "attr structure" $ do
348+ specParserFailed "docNone" docNone testStructureAttributes
282349
283350main :: IO ()
284351main = hspec $ do