git.iko.soy/typeable/dom-parser
on master help sign in
Public release 0.1.0
f32ff9eDenis Redozubov
CHANGELOG.mdnew file+4
compare with master
unifiedsplit
@@ -0,0 +1,4 @@
1+# CHANGELOG
2+
3+## 0.1.0
4+* Public release
LICENSEnew file+20
@@ -0,0 +1,20 @@
1+Copyright (c) 2016 Typeable.io contributors
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be included
12+in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
dom-parser.cabalnew file+78
@@ -0,0 +1,78 @@
1+name: dom-parser
2+version: 0.1.0
3+synopsis: Simple monadic DOM parser
4+license: MIT
5+license-file: LICENSE
6+author: Typeable.io contributors
7+maintainer: makeit@typeable.io
8+category: XML
9+build-type: Simple
10+extra-source-files: CHANGELOG.md
11+cabal-version: >=1.10
12+
13+library
14+ hs-source-dirs: src
15+ default-language: Haskell2010
16+ ghc-options: -Wall
17+ default-extensions: ConstraintKinds
18+ , DataKinds
19+ , DeriveGeneric
20+ , FlexibleContexts
21+ , FlexibleInstances
22+ , FunctionalDependencies
23+ , GADTs
24+ , GeneralizedNewtypeDeriving
25+ , InstanceSigs
26+ , LambdaCase
27+ , MultiParamTypeClasses
28+ , MultiWayIf
29+ , OverloadedStrings
30+ , QuasiQuotes
31+ , RankNTypes
32+ , ScopedTypeVariables
33+ , TemplateHaskell
34+ , TupleSections
35+ , TypeFamilies
36+ , TypeOperators
37+ , UndecidableInstances
38+ build-depends: base >= 4.7 && < 5
39+ , lens
40+ , mtl
41+ , open-union
42+ , semigroups
43+ , shakespeare
44+ , text
45+ , transformers
46+ , type-fun
47+ , xml-conduit
48+ , xml-lens
49+ exposed-modules: Text.XML.DOM.Parser
50+ , Text.XML.DOM.Parser.Class
51+ , Text.XML.DOM.Parser.Combinators
52+ , Text.XML.DOM.Parser.Types
53+
54+test-suite test
55+ type: exitcode-stdio-1.0
56+ hs-source-dirs: test
57+ main-is: Main.hs
58+ default-language: Haskell2010
59+ default-extensions: DeriveGeneric
60+ , FlexibleContexts
61+ , FlexibleInstances
62+ , LambdaCase
63+ , MultiParamTypeClasses
64+ , OverloadedStrings
65+ , QuasiQuotes
66+ , RecordWildCards
67+ , ScopedTypeVariables
68+ , TemplateHaskell
69+ , TypeFamilies
70+ build-depends: base
71+ , data-default
72+ , dom-parser
73+ , hspec
74+ , lens
75+ , semigroups
76+ , shakespeare
77+ , text
78+ , xml-conduit
src/Text/XML/DOM/Parser.hsnew file+9
@@ -0,0 +1,9 @@
1+module Text.XML.DOM.Parser
2+ ( module Text.XML.DOM.Parser.Class
3+ , module Text.XML.DOM.Parser.Combinators
4+ , module Text.XML.DOM.Parser.Types
5+ ) where
6+
7+import Text.XML.DOM.Parser.Class
8+import Text.XML.DOM.Parser.Combinators
9+import Text.XML.DOM.Parser.Types
src/Text/XML/DOM/Parser/Class.hsnew file+144
@@ -0,0 +1,144 @@
1+module Text.XML.DOM.Parser.Class
2+ ( -- * FromDom
3+ FromDom(..)
4+ , proxyFromDom
5+ -- * Explicit methods for convenience
6+ , elementFromDom
7+ , unionFromDom
8+ , textFromDom
9+ , stringFromDom
10+ , charFromDom
11+ , intFromDom
12+ , integerFromDom
13+ , doubleFromDom
14+ , fixedFromDom
15+ , boolFromDom
16+ , unitFromDom
17+ , voidFromDom
18+ ) where
19+
20+import Control.Applicative
21+import Control.Lens
22+import Data.Fixed
23+import Data.OpenUnion
24+import Data.Text (Text)
25+import qualified Data.Text as T
26+import Data.Typeable
27+import Data.Void
28+import Text.Shakespeare.Text (st)
29+import Text.XML
30+import Text.XML.DOM.Parser.Combinators
31+import Text.XML.DOM.Parser.Types
32+import TypeFun.Data.List hiding (Union)
33+
34+proxyFromDom
35+ :: forall proxy m a
36+ . (FromDom a, Monad m)
37+ => proxy a
38+ -> DomParserT Identity m a
39+proxyFromDom _ = fromDom
40+
41+-- | Class of types which can be parsed from single XML element.
42+class FromDom a where
43+ fromDom :: (Monad m) => DomParserT Identity m a
44+
45+instance FromDom () where
46+ fromDom = unitFromDom
47+
48+instance FromDom Void where
49+ fromDom = voidFromDom
50+
51+instance FromDom Text where
52+ fromDom = textFromDom
53+
54+instance FromDom String where
55+ fromDom = stringFromDom
56+
57+instance FromDom Char where
58+ fromDom = charFromDom
59+
60+instance FromDom Int where
61+ fromDom = intFromDom
62+
63+instance FromDom Integer where
64+ fromDom = integerFromDom
65+
66+instance FromDom Double where
67+ fromDom = doubleFromDom
68+
69+instance (HasResolution a, Typeable a) => FromDom (Fixed a) where
70+ fromDom = fixedFromDom
71+
72+instance FromDom Bool where
73+ fromDom = boolFromDom
74+
75+instance FromDom (Union '[]) where
76+ fromDom = empty
77+
78+instance ( Typeable a, FromDom a, FromDom (Union as)
79+ , SubList as (a ': as) )
80+ => FromDom (Union (a ': as)) where
81+ -- fromDom :: forall m. (DomParserMonad m) => m a
82+ fromDom = (liftUnion <$> (proxyFromDom (Proxy :: Proxy a)))
83+ <|> (reUnion <$> (proxyFromDom (Proxy :: Proxy (Union as))))
84+
85+instance FromDom Element where
86+ fromDom = elementFromDom
87+
88+elementFromDom :: (Monad m) => DomParserT Identity m Element
89+elementFromDom = view $ pdElements . to runIdentity
90+
91+unionFromDom
92+ :: (Monad m, FromDom (Union as))
93+ => proxy as
94+ -> DomParserT Identity m (Union as)
95+unionFromDom _ = fromDom
96+
97+textFromDom :: (Monad m) => DomParserT Identity m Text
98+textFromDom = parseContent pure
99+
100+stringFromDom :: (Monad m) => DomParserT Identity m String
101+stringFromDom = parseContent $ pure . T.unpack
102+
103+charFromDom :: (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"
108+
109+intFromDom :: (Monad m) => DomParserT Identity m Int
110+intFromDom = parseContent readContent
111+
112+integerFromDom :: (Monad m) => DomParserT Identity m Integer
113+integerFromDom = parseContent readContent
114+
115+doubleFromDom :: (Monad m) => DomParserT Identity m Double
116+doubleFromDom = parseContent readContent
117+
118+fixedFromDom
119+ :: (Monad m, Typeable a, HasResolution a)
120+ => DomParserT Identity m (Fixed a)
121+fixedFromDom = parseContent readContent
122+
123+-- | Expects content to be y, yes, t, true or 1 for True value. n, no,
124+-- f, false or 0 for False value. Case is not significant, blank
125+-- characters are striped.
126+boolFromDom :: (Monad m) => DomParserT Identity m Bool
127+boolFromDom = parseContent $ \t ->
128+ let
129+ lowt = T.toLower $ T.strip t
130+ tvals = ["y", "yes", "t", "true", "1"]
131+ fvals = ["n", "no", "f", "false", "0"]
132+ in if | lowt `elem` tvals -> return True
133+ | lowt `elem` fvals -> return False
134+ | otherwise ->
135+ let msg = [st|Could not read "#{t}" as Bool|]
136+ in throwParserError $ PEWrongFormat msg
137+
138+-- | Always successfully parses any DOM to @()@
139+unitFromDom :: (Monad m) => DomParserT Identity m ()
140+unitFromDom = pure ()
141+
142+-- | Never parses successfully. It is just 'mzero'
143+voidFromDom :: (Monad m) => DomParserT Identity m Void
144+voidFromDom = empty
src/Text/XML/DOM/Parser/Combinators.hsnew file+239
@@ -0,0 +1,239 @@
1+module Text.XML.DOM.Parser.Combinators
2+ ( -- * Generic combinators to traverse descendants
3+ traverseElems
4+ , inFilteredTrav
5+ -- * Using 'DomTraversable'
6+ , inElemTrav
7+ , inElem
8+ , inElemAll
9+ , inElemMay
10+ , inElemNe
11+ -- * Dive combinators
12+ , divePath
13+ , diveElem
14+ -- * Explicit ignoring elements
15+ , ignoreElem
16+ , ignoreEmpty
17+ , ignoreBlank
18+ -- * Checking current element properties
19+ , checkCurrentName
20+ -- * Parsing arbitrary content
21+ , parseContent
22+ , readContent
23+ ) where
24+
25+import Control.Lens
26+import Control.Monad.Except
27+import Control.Monad.Reader
28+import Data.List.NonEmpty (NonEmpty(..))
29+import Data.Monoid
30+import Data.Text (Text)
31+import qualified Data.Text as T
32+import Data.Traversable
33+import Data.Typeable
34+import Text.Read
35+import Text.Shakespeare.Text (st)
36+import Text.XML
37+import Text.XML.DOM.Parser.Types
38+import Text.XML.Lens
39+
40+
41+-- | Generic function to traverse arbitrary inner cursors.
42+traverseElems
43+ :: (Monad m, Foldable g, Traversable f)
44+ => ([Element] -> DomParserT g m (f ([Text], Element)))
45+ -- ^ Takes set of current elements and
46+ -> DomParserT Identity m a
47+ -- ^ Parser will be runned for each element found in traversable
48+ -> DomParserT g m (f a)
49+traverseElems trav parser = do
50+ pd <- ask
51+ inner <- trav $ pd ^.. pdElements . folded
52+ for inner $ \(subpath, e) -> do
53+ let newpd = ParserData
54+ { _pdElements = Identity e
55+ , _pdPath = pd ^. pdPath <> subpath }
56+ magnify (to $ const newpd) parser
57+
58+-- | Takes function filtering
59+inFilteredTrav
60+ :: (Monad m, Foldable g, DomTraversable f)
61+ => ([Element] -> ([Text], [Element]))
62+ -- ^ Function returning some filtered elements with path suffixes which will
63+ -- be appended to parser's state
64+ -> DomParserT Identity m a
65+ -> DomParserT g m (f a)
66+inFilteredTrav deeper = traverseElems trav
67+ where
68+ trav e = do
69+ let (path, elems) = deeper e
70+ case buildDomTraversable elems of
71+ Nothing -> throwParserError $ PENotFound . (<> path)
72+ Just tr -> return $ fmap (path,) tr
73+
74+inElemTrav
75+ :: (Monad m, Foldable g, DomTraversable f)
76+ => Text
77+ -> DomParserT Identity m a
78+ -> DomParserT g m (f a)
79+inElemTrav n = inFilteredTrav deeper
80+ where
81+ deeper = ([n],) . toListOf (folded . nodes . folded . _Element . ell n)
82+
83+-- | Runs parser inside first children element with given name
84+inElem
85+ :: (Monad m, Foldable g)
86+ => Text
87+ -> DomParserT Identity m a
88+ -> DomParserT g m a
89+inElem n = fmap runIdentity . inElemTrav n
90+
91+inElemAll
92+ :: (Monad m, Foldable g)
93+ => Text
94+ -> DomParserT Identity m a
95+ -> DomParserT g m [a]
96+inElemAll = inElemTrav
97+
98+inElemMay
99+ :: (Monad m, Foldable g)
100+ => Text
101+ -> DomParserT Identity m a
102+ -> DomParserT g m (Maybe a)
103+inElemMay = inElemTrav
104+
105+inElemNe
106+ :: (Monad m, Foldable g)
107+ => Text
108+ -> DomParserT Identity m a
109+ -> DomParserT g m (NonEmpty a)
110+inElemNe = inElemTrav
111+
112+{- | Dive given parser's current tags set into the given path. The @divePath
113+["a", "b"]@ differs from @inElem "a" . inElem "b"@. Namely the first variant
114+will not fail if occured tag "a" which does not contains tag "b". This
115+behaviour is desireable when you dont want to parse whole XML and just want
116+to pull tags in some path. The other difference is in traversing inner
117+elements. Consider this code
118+
119+@
120+inElem "a" $ inElem "b" $ inElemAll "c" fromDom
121+@
122+
123+which translates to pseudo-CSS query like: @a:nth(1) > b:nth(1) > c > fromDom@
124+
125+@
126+divePath ["a", "b"] $ inElemAll "c" fromDom
127+@
128+
129+which translates like: @a > b > c > fromDom@
130+
131+As you can see, inElem always takes first element and runs inner parser in this
132+single element, unlike 'divePath' which runs inner parser @in all@ descendants
133+in given path.
134+-}
135+
136+divePath
137+ :: forall m g a
138+ . (Monad m, Foldable g)
139+ => [Text]
140+ -> DomParserT [] m a
141+ -> DomParserT g m a
142+divePath path = magnify $ to modElems
143+ where
144+ modElems
145+ = over pdElements (toListOf $ folded . diver)
146+ . over pdPath (<> path)
147+ diver :: Fold Element Element
148+ diver = foldr (.) id $ map toDive path
149+ toDive n = nodes . folded . _Element . ell n
150+
151+diveElem
152+ :: (Monad m, Foldable g)
153+ => Text
154+ -> DomParserT [] m a
155+ -> DomParserT g m a
156+diveElem p = divePath [p]
157+
158+-- | Ignore arbitrary current element if it conforms to predicate.
159+ignoreElem
160+ :: (Monad m)
161+ => (Element -> Bool)
162+ -- ^ Predicate checking that we must ignore some current tag. If returns
163+ -- true then parser will not be runned and combinator just returns Nothing.
164+ -> DomParserT Identity m a
165+ -> DomParserT Identity m (Maybe a)
166+ignoreElem test parser = do
167+ ign <- view $ pdElements . to (test . runIdentity)
168+ if ign then pure Nothing else Just <$> parser
169+
170+-- | If current element has no children nodes does not run parser and returns
171+-- Nothing. Otherwise runs parser inside current element. Usefull when you got
172+-- XML with strange empty elements which must be just ignored, but `inElem` runs
173+-- parser inside of this elements which causes to parser error.
174+ignoreEmpty
175+ :: (Monad m)
176+ => DomParserT Identity m a
177+ -> DomParserT Identity m (Maybe a)
178+ignoreEmpty = ignoreElem test
179+ where
180+ test e = null $ e ^. nodes
181+
182+-- | If all current elements contains blank content, or contains nothing at all
183+-- , then returns Nothing, else runs parser.
184+ignoreBlank
185+ :: (Monad m)
186+ => DomParserT Identity m a
187+ -> DomParserT Identity m (Maybe a)
188+ignoreBlank = ignoreElem test
189+ where
190+ test e =
191+ let
192+ elems = e ^.. nodes . folded . _Element
193+ cont = mconcat $ e ^.. nodes . folded . _Content
194+ in if | not $ null elems -> False
195+ | T.null $ T.strip cont -> True
196+ | otherwise -> False
197+
198+-- | If name of current tag differs from first argument throws 'PENotFound' with
199+-- tag name replaced in last path's segment. Usefull for checking root
200+-- document's element name.
201+checkCurrentName
202+ :: (Monad m)
203+ => Text
204+ -> DomParserT Identity m ()
205+checkCurrentName n = do
206+ cn <- view $ pdElements . to runIdentity . localName
207+ unless (cn == n) $ do
208+ p <- view pdPath
209+ let pinit = if null p then [] else init p
210+ throwError $ ParserErrors [PENotFound $ pinit ++ [n]]
211+ return ()
212+
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
222+ let
223+ nds = e ^. nodes
224+ els = nds ^.. folded . _Element
225+ conts = nds ^.. folded . _Content
226+ when (not $ null els) $ throwParserError PEContentNotFound
227+ when (null conts) $ throwParserError PEContentNotFound
228+ parse $ mconcat conts
229+
230+readContent
231+ :: forall m g a
232+ . (Read a, Typeable a, Monad m)
233+ => 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
238+ where
239+ n = show $ typeRep (Proxy :: Proxy a)
src/Text/XML/DOM/Parser/Types.hsnew file+149
@@ -0,0 +1,149 @@
1+module Text.XML.DOM.Parser.Types
2+ ( -- * Parser internals
3+ ParserError(..)
4+ , pePath
5+ , peDetails
6+ , ParserErrors(..)
7+ , _ParserErrors
8+ , ParserData(..)
9+ , pdElements
10+ , pdPath
11+ -- * Parser type
12+ , DomParserT
13+ , DomParser
14+ , runDomParserT
15+ , runDomParser
16+ -- * Auxiliary
17+ , DomTraversable(..)
18+ , throwParserError
19+ , throwWrongFormat
20+ ) where
21+
22+import Control.Exception
23+import Control.Lens
24+import Control.Monad.Except
25+import Control.Monad.Reader
26+import Data.List.NonEmpty (NonEmpty(..))
27+import qualified Data.List.NonEmpty as NE
28+import Data.Maybe
29+import Data.Text (Text)
30+import GHC.Generics (Generic)
31+import Text.XML
32+import Text.XML.Lens
33+
34+-- | DOM parser error description.
35+data ParserError
36+ -- | Tag not found which should be.
37+ = PENotFound
38+ { _pePath :: [Text]
39+ }
40+
41+ -- | Tag contents has wrong format, (could not read text to value)
42+ | PEWrongFormat
43+ { _peDetails :: Text
44+ , _pePath :: [Text] -- ^ path of element
45+ }
46+
47+ -- | Node should have text content, but it does not.
48+ | PEContentNotFound
49+ { _pePath :: [Text]
50+ }
51+
52+ -- | Some other error
53+ | PEOther
54+ { _peDetails :: Text
55+ , _pePath :: [Text]
56+ } deriving (Eq, Ord, Show, Generic)
57+
58+makeLenses ''ParserError
59+
60+instance Exception ParserError
61+
62+newtype ParserErrors = ParserErrors
63+ { unParserErrors :: [ParserError]
64+ } deriving (Ord, Eq, Show, Monoid, Generic)
65+
66+makePrisms ''ParserErrors
67+
68+instance Exception ParserErrors
69+
70+
71+{- | Parser scope parser runs in. Functor argument is usually @Identity@ or
72+@[]@.
73+
74+If functor is @Identity@ then parser expects exactly ONE current element. This
75+is common behavior for content parsers, or parsers expecting strict XML
76+structure.
77+
78+If functor is @[]@ then parser expects arbitrary current elements count. This is
79+the case when you use combinators 'divePath' or 'diveElem' (posible other
80+variants of similar combinators). This kind of combinators performs search for
81+elements somewhere in descendants and result have arbitrary length in common
82+case.
83+-}
84+
85+data ParserData f = ParserData
86+ { _pdElements :: f Element
87+ -- ^ Current element(s). Functor is intended to be either @Identity@ or
88+ -- @[]@
89+ , _pdPath :: [Text]
90+ -- ^ Path for error reporting
91+ }
92+
93+makeLenses ''ParserData
94+
95+type DomParserT f m = ReaderT (ParserData f) (ExceptT ParserErrors m)
96+type DomParser f = DomParserT f Identity
97+
98+-- | Run parser on root element of Document.
99+runDomParserT
100+ :: (Monad m)
101+ => Document
102+ -> DomParserT Identity m a
103+ -> m (Either ParserErrors a)
104+runDomParserT doc par =
105+ let pd = ParserData
106+ { _pdElements = doc ^. root . to pure
107+ , _pdPath = [doc ^. root . localName]
108+ }
109+ in runExceptT $ runReaderT par pd
110+
111+runDomParser
112+ :: Document
113+ -> DomParser Identity a
114+ -> Either ParserErrors a
115+runDomParser doc par = runIdentity $ runDomParserT doc par
116+
117+-- | Class of traversable functors which may be constructed from list. Or may
118+-- not.
119+class Traversable f => DomTraversable f where
120+ -- | If method return Nothing this means we can not build traversable from
121+ -- given list. In this case combinator should fail traversing.
122+ buildDomTraversable :: [a] -> Maybe (f a)
123+
124+instance DomTraversable Identity where
125+ buildDomTraversable = fmap Identity . listToMaybe
126+
127+instance DomTraversable [] where
128+ buildDomTraversable = Just
129+
130+instance DomTraversable Maybe where
131+ buildDomTraversable = Just . listToMaybe
132+
133+instance DomTraversable NonEmpty where
134+ buildDomTraversable = NE.nonEmpty
135+
136+throwParserError
137+ :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
138+ => ([Text] -> ParserError)
139+ -> m a
140+throwParserError mkerr = do
141+ path <- view pdPath
142+ throwError $ ParserErrors [mkerr path]
143+
144+-- | Throw 'PEWrongFormat' as very common case
145+throwWrongFormat
146+ :: (MonadError ParserErrors m, MonadReader (ParserData f) m)
147+ => Text
148+ -> m a
149+throwWrongFormat err = throwParserError $ PEWrongFormat err
test/Main.hsnew file+290
@@ -0,0 +1,290 @@
1+module Main where
2+
3+import Control.Exception
4+import Control.Lens
5+import Control.Monad
6+import Data.Default
7+import Data.List.NonEmpty (NonEmpty(..))
8+import qualified Data.List.NonEmpty as NE
9+import Data.Monoid
10+import Data.Text (Text)
11+import Test.Hspec
12+import Text.Shakespeare.Text (lt)
13+import Text.XML
14+import Text.XML.DOM.Parser
15+
16+
17+data TestStructure = TestStructure
18+ { tsName :: Text
19+ , tsInts :: [Int]
20+ , tsBools :: NonEmpty Bool
21+ } deriving (Eq, Show)
22+
23+testStructureFromDom :: (Monad m) => DomParserT Identity m TestStructure
24+testStructureFromDom = do
25+ tsName <- inElem "name" fromDom
26+ tsInts <- inElemAll "int" intFromDom
27+ tsBools <- inElemNe "bool" boolFromDom
28+ return TestStructure{..}
29+
30+instance FromDom TestStructure where
31+ fromDom = testStructureFromDom
32+
33+docStruct :: Document
34+docStruct = parseText_ def [lt|
35+<?xml version="1.0" encoding="utf-8"?>
36+<root>
37+ <name>name</name>
38+ <int>1</int>
39+ <int>2</int>
40+ <bool>t</bool>
41+</root>
42+|]
43+
44+docNone :: Document
45+docNone = parseText_ def [lt|
46+<?xml version="1.0" encoding="utf-8"?>
47+<root>
48+</root>
49+|]
50+
51+docEmpty :: Document
52+docEmpty = parseText_ def [lt|
53+<?xml version="1.0" encoding="utf-8"?>
54+<root>
55+ <a/>
56+</root>
57+|]
58+
59+docSimple :: Document
60+docSimple = parseText_ def [lt|
61+<?xml version="1.0" encoding="utf-8"?>
62+<root>
63+ <a>content</a>
64+</root>
65+|]
66+
67+docMultiple :: Document
68+docMultiple = parseText_ def [lt|
69+<?xml version="1.0" encoding="utf-8"?>
70+<root>
71+ <a>content1</a>
72+ <a>content2</a>
73+ <a>content3</a>
74+</root>
75+|]
76+
77+docDeep :: Document
78+docDeep = parseText_ def [lt|
79+<?xml version="1.0" encoding="utf-8"?>
80+<root>
81+ <a><b>content</b></a>
82+</root>
83+|]
84+
85+docDeepWithContent :: Document
86+docDeepWithContent = parseText_ def [lt|
87+<?xml version="1.0" encoding="utf-8"?>
88+<root>
89+ <a>content<b>content</b>content</a>
90+</root>
91+|]
92+
93+docDeepMultiple1 :: Document
94+docDeepMultiple1 = parseText_ def [lt|
95+<?xml version="1.0" encoding="utf-8"?>
96+<root>
97+ <a>
98+ <b>content1</b>
99+ <b>content2</b>
100+ </a>
101+ <a>
102+ <b>content3</b>
103+ </a>
104+ <a/>
105+</root>
106+|]
107+
108+docDeepMultiple2 :: Document
109+docDeepMultiple2 = parseText_ def [lt|
110+<?xml version="1.0" encoding="utf-8"?>
111+<root>
112+ <a/>
113+ <a>
114+ <b>content1</b>
115+ </a>
116+ <a>
117+ <b>content2</b>
118+ <b>content3</b>
119+ </a>
120+</root>
121+|]
122+
123+specParser
124+ :: String -- ^ Name of spec
125+ -> Document -- ^ Document to parse
126+ -> (a -> Maybe String) -- ^ Value checker, Nothing if all ok
127+ -> DomParser Identity a -- ^ Parser itself
128+ -> Spec
129+specParser name doc check parser = it name $ do
130+ result <- either throwIO return $ runDomParser doc parser
131+ case check result of
132+ Nothing -> return ()
133+ Just e -> throwIO $ ErrorCall e
134+
135+specParserEq
136+ :: (Eq a, Show a)
137+ => String -- ^ Name of spec
138+ -> Document -- ^ Document to parse
139+ -> a -- ^ Value parser should return
140+ -> DomParser Identity a -- ^ Parser itself
141+ -> Spec
142+specParserEq name doc a parser = specParser name doc check parser
143+ where
144+ check x | x == a = Nothing
145+ | otherwise = Just $ "should be " ++ show a
146+ ++ " but got " ++ show x
147+
148+specParserFailed
149+ :: (Show a)
150+ => String
151+ -> Document
152+ -> DomParser Identity a
153+ -> Spec
154+specParserFailed name doc parser = it name $ example $ do
155+ let result = runDomParser doc parser
156+ case result of
157+ Right a -> fail $ "Expected parser to fail, but returned" ++ (show a)
158+ Left _ -> return ()
159+
160+specParserFailedPath
161+ :: (Show a)
162+ => String -- ^ Name of spec
163+ -> Document
164+ -> [Text] -- ^ Expteced path in error
165+ -> DomParser Identity a
166+ -> Spec
167+specParserFailedPath name doc path parser = it name $ example $ do
168+ let result = runDomParser doc parser
169+ case result of
170+ Right a -> fail $ "Expected parser to fail, but returned" ++ (show a)
171+ Left (ParserErrors errs) -> case errs ^? folded . pePath of
172+ Nothing -> fail $ "Parser failed, but got no errors to analyze path"
173+ Just p | p == path -> return ()
174+ | otherwise -> fail $ "Path is not exptected: " <> show p
175+
176+combinationsSpec :: Spec
177+combinationsSpec = do
178+ describe "inElem" $ do
179+ let parser = inElem "a" textFromDom
180+ describe "succeeds" $ do
181+ specParserEq "docSimple" docSimple "content" parser
182+ specParserEq "docMultiple" docMultiple "content1" parser
183+ describe "fails" $ do
184+ specParserFailed "docNone" docNone parser
185+ specParserFailed "docEmpty" docEmpty parser
186+
187+ describe "inElemAll" $ do
188+ let parser = inElemAll "a" textFromDom
189+ describe "succeeds" $ do
190+ specParserEq "docNone" docNone [] parser
191+ specParserEq "docSimple" docSimple ["content"] parser
192+ specParserEq "docMultiple" docMultiple
193+ ["content1", "content2", "content3"] parser
194+ describe "fails" $ do
195+ specParserFailed "docEmpty" docEmpty parser
196+
197+ describe "inElemMay" $ do
198+ let parser = inElemMay "a" textFromDom
199+ describe "succeeds" $ do
200+ specParserEq "docNone" docNone Nothing parser
201+ specParserEq "docSimple" docSimple (Just "content") parser
202+ specParserEq "docMultiple" docMultiple (Just "content1") parser
203+ describe "fails" $ do
204+ specParserFailed "docEmpty" docEmpty parser
205+
206+ describe "inElemNe" $ do
207+ let parser = inElemNe "a" textFromDom
208+ describe "succeeds" $ do
209+ specParserEq "docSimple" docSimple (pure "content") parser
210+ specParserEq "docMultiple" docMultiple
211+ (NE.fromList ["content1", "content2", "content3"]) parser
212+ describe "fails" $ do
213+ specParserFailed "docNone" docNone parser
214+ specParserFailed "docEmpty" docEmpty parser
215+
216+ describe "diveElem" $ do
217+ describe "single element" $ do
218+ let parser = diveElem "a" $ inElem "b" textFromDom
219+ describe "succeeds" $ do
220+ specParserEq "docDeepMultiple1" docDeepMultiple1 "content1" parser
221+ specParserEq "docDeepMultiple2" docDeepMultiple2 "content1" parser
222+ describe "fails" $ do
223+ specParserFailedPath "docSimple" docSimple ["root", "a", "b"] parser
224+ describe "multiple elements" $ do
225+ let
226+ parser = diveElem "a" $ inElemAll "b" textFromDom
227+ result = ["content1", "content2", "content3"]
228+ describe "succeeds" $ do
229+ specParserEq "docDeepMultiple1" docDeepMultiple1 result parser
230+ specParserEq "docDeepMultiple2" docDeepMultiple2 result parser
231+ specParserEq "docSimple" docSimple [] parser
232+
233+ describe "ignoreEmpty" $ do
234+ describe "mandatory element" $ do
235+ let parser = inElem "a" $ ignoreEmpty textFromDom
236+ describe "succeeds" $ do
237+ specParserEq "docEmpty" docEmpty Nothing parser
238+ specParserEq "docSimple" docSimple (Just "content") parser
239+ specParserEq "docMultiple" docMultiple (Just "content1") parser
240+ describe "fails" $ do
241+ specParserFailed "docNone" docNone parser
242+ describe "optional element" $ do
243+ let parser = fmap join $ inElemMay "a" $ ignoreEmpty textFromDom
244+ describe "succeeds" $ do
245+ specParserEq "docNone" docNone Nothing parser
246+ specParserEq "docEmpty" docEmpty Nothing parser
247+ specParserEq "docSimple" docSimple (Just "content") parser
248+ specParserEq "docMultiple" docMultiple (Just "content1") parser
249+
250+ describe "checkCurrentName" $ do
251+ describe "succeeded" $ do
252+ specParserEq "root element" docSimple () $ do
253+ checkCurrentName "root"
254+ specParserEq "inner element" docSimple () $ do
255+ inElem "a" $ do
256+ checkCurrentName "a"
257+ describe "fails" $ do
258+ specParserFailedPath "root element" docSimple ["toor"] $ do
259+ checkCurrentName "toor"
260+ specParserFailedPath "inner element" docSimple ["root", "b"] $ do
261+ inElem "a" $ checkCurrentName "b"
262+
263+contentSpec :: Spec
264+contentSpec = do
265+ describe "fails if inner element found" $ do
266+ specParserFailed "docDeep" docDeep $ do
267+ inElem "a" $ textFromDom
268+ specParserFailed "docDeepWithContent" docDeepWithContent $ do
269+ inElem "a" $ textFromDom
270+
271+structSpec :: Spec
272+structSpec = do
273+ 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
280+ describe "fails" $ do
281+ specParserFailed "docSimple" docSimple testStructureFromDom
282+
283+main :: IO ()
284+main = hspec $ do
285+ describe "combinators" $ do
286+ combinationsSpec
287+ describe "content parsing" $ do
288+ contentSpec
289+ describe "expected struct" $ do
290+ structSpec