b5da244 · typeable/dom-parser

git.iko.soy/typeable/dom-parser

on master help sign in

Upd: refactoring done

b5da244Alexey Uimanov10 years ago

src/Text/XML/DOM/Parser/Combinators.hs+3−120

compare with master

unifiedsplit

@@ -15,27 +15,13 @@ module Text.XML.DOM.Parser.Combinators

15 , ignoreElem

16 , ignoreEmpty

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− -- * Parsing attributes

28− , parseAttribute

29− , parseAttributeMaybe

30 ) where

18 ) where

32import Control.Lens

20import Control.Lens

33−import Control.Monad.Except

34import Control.Monad.Reader

21import Control.Monad.Reader

35import Data.Foldable as F

22import Data.Foldable as F

36import Data.List as L

23import Data.List as L

37import Data.List.NonEmpty (NonEmpty(..))

24import Data.List.NonEmpty (NonEmpty(..))

38−import Data.Map.Strict as M

39import Data.Monoid

25import Data.Monoid

40import Data.Text as T

26import Data.Text as T

41import Data.Traversable

27import Data.Traversable

@@ -68,7 +54,7 @@ traverseElems trav parser = do

69-- | Takes function filtering

55-- | Takes function filtering

70inFilteredTrav

56inFilteredTrav

71− :: (Monad m, Foldable g, DomTraversable f)

57+ :: (Monad m, Foldable g, Buildable f)

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

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

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

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

74 -- be appended to parser's state

60 -- be appended to parser's state

@@ -78,12 +64,12 @@ inFilteredTrav 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

85inElemTrav

71inElemTrav

86− :: (Monad m, Foldable g, DomTraversable f)

72+ :: (Monad m, Foldable g, Buildable f)

87 => NameMatcher -- ^ Name of tag to traverse in

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

88 -> DomParserT Identity m a

74 -> DomParserT Identity m a

89 -> DomParserT g m (f a)

75 -> DomParserT g m (f a)

@@ -205,106 +191,3 @@ ignoreBlank = ignoreElem test

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

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

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

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

207 | otherwise -> False

193 | otherwise -> False

208−

209−-- | Returns name of current element.

210−--

211−-- @since 1.0.0

212−getCurrentName :: (Monad m) => DomParserT Identity m Name

213−getCurrentName = view $ pdElements . to runIdentity . name

214−

215−-- | If name of current tag differs from first argument throws 'PENotFound' with

216−-- tag name replaced in last path's segment. Useful for checking root

217−-- document's element name.

218−checkCurrentName

219− :: (Monad m)

220− => NameMatcher

221− -> DomParserT Identity m ()

222−checkCurrentName n = do

223− cn <- getCurrentName

224− unless ((n ^. nmMatch) cn) $ do

225− p <- view pdPath

226− let pinit = if L.null (unDomPath p) then [] else L.init $ unDomPath p

227− throwError $ ParserErrors [PENotFound $ DomPath $ pinit ++ [_nmShow 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 $ L.null els -> Nothing

244− | L.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−-- | Retuns map of attributes of current element

262−--

263−-- @since 1.0.0

264−getCurrentAttributes

265− :: (Monad m)

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

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

268−

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

270−--

271−-- @since 1.0.0

272−getCurrentAttribute

273− :: (Monad m)

274− => NameMatcher

275− -> DomParserT Identity m (Maybe Text)

276−getCurrentAttribute attrName

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

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

279−

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

281−--

282−-- @since 1.0.0

283−parseAttribute

284− :: (Monad m)

285− => NameMatcher

286− -- ^ Attribute name

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

288− -- ^ Attribute content parser

289− -> DomParserT Identity m a

290−parseAttribute attrName parser =

291− parseAttributeMaybe attrName parser >>= \case

292− Nothing -> throwParserError $ PEAttributeNotFound attrName

293− Just a -> return a

294−

295−-- | Parses attribute with given name.

296−--

297−-- @since 1.0.0

298−parseAttributeMaybe

299− :: (Monad m)

300− => NameMatcher

301− -- ^ Attribute name

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

303− -- ^ Attribute content parser

304− -> DomParserT Identity m (Maybe a)

305−parseAttributeMaybe attrName parser =

306− getCurrentAttribute attrName >>= \case

307− Nothing -> return Nothing

308− Just aval -> case parser aval of

309− Left err -> throwParserError $ PEAttributeWrongFormat attrName err

310− Right a -> return $ Just a

src/Text/XML/DOM/Parser/Common.hs+151−1

@@ -1,10 +1,58 @@

1−module Text.XML.DOM.Parser.Common where

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

2+ ( -- * Buildable

3+ Buildable(..)

4+ -- * Content readers

5+ , readBool

6+ , readChar

7+ -- ** Reader constructors

8+ , maybeReadContent

9+ , readContent

10+ -- * Getting current element's properties

11+ , getCurrentName

12+ , getCurrentContent

13+ , getCurrentAttributes

14+ , getCurrentAttribute

15+ , checkCurrentName

16+ -- * Parsing element's content

17+ , parseContent

18+ -- * Parsing attributes

19+ , parseAttribute

20+ , parseAttributeMaybe

21+ ) where

23+import Control.Lens

24+import Control.Monad

25+import Control.Monad.Except

26+import Data.List as L

27+import Data.List.NonEmpty as NE

28+import Data.Map.Strict as M

29+import Data.Maybe

3import Data.Monoid

30import Data.Monoid

4import Data.Text as T

31import Data.Text as T

5import Data.Typeable

32import Data.Typeable

6import Text.Read

33import Text.Read

34+import Text.XML.DOM.Parser.Types

35+import Text.XML.Lens

37+-- | Class of traversable functors which may be constructed from list. Or may

38+-- not.

39+class Traversable f => Buildable f where

40+ -- | If method return Nothing this means we can not build

41+ -- traversable from given list. In this case 'inFilteredTrav' should

42+ -- fail traversing.

43+ build :: [a] -> Maybe (f a)

44+

45+instance Buildable Identity where

46+ build = fmap Identity . listToMaybe

47+

48+instance Buildable [] where

49+ build = Just

50+

51+instance Buildable Maybe where

52+ build = Just . listToMaybe

53+

54+instance Buildable NonEmpty where

55+ build = NE.nonEmpty

9-- | @since 1.0.0

57-- | @since 1.0.0

10readBool :: Text -> Either Text Bool

58readBool :: Text -> Either Text Bool

@@ -52,3 +100,105 @@ readContent

52 => Text

100 => Text

53 -> Either Text a

101 -> Either Text a

54readContent = maybeReadContent $ readMaybe . T.unpack . T.strip

102readContent = maybeReadContent $ readMaybe . T.unpack . T.strip

103+

104+-- | Returns name of current element.

105+--

106+-- @since 1.0.0

107+getCurrentName :: (Monad m) => DomParserT Identity m Name

108+getCurrentName = view $ pdElements . to runIdentity . name

109+

110+-- | If name of current tag differs from first argument throws 'PENotFound' with

111+-- tag name replaced in last path's segment. Useful for checking root

112+-- document's element name.

113+checkCurrentName

114+ :: (Monad m)

115+ => NameMatcher

116+ -> DomParserT Identity m ()

117+checkCurrentName n = do

118+ cn <- getCurrentName

119+ unless ((n ^. nmMatch) cn) $ do

120+ p <- view pdPath

121+ let pinit = if L.null (unDomPath p) then [] else L.init $ unDomPath p

122+ throwError $ ParserErrors [PENotFound $ DomPath $ pinit ++ [_nmShow n]]

123+ return ()

124+

125+-- | Get current content. If current element contains no content or

126+-- have inner elements then Nothing returned

127+--

128+-- @since 1.0.0

129+getCurrentContent :: (Monad m) => DomParserT Identity m (Maybe Text)

130+getCurrentContent = do

131+ nds <- view $ pdElements . to runIdentity . nodes

132+ let

133+ els :: [Element]

134+ els = nds ^.. folded . _Element

135+ conts :: [Text]

136+ conts = nds ^.. folded . _Content

137+ return $ if

138+ | not $ L.null els -> Nothing

139+ | L.null conts -> Nothing

140+ | otherwise -> Just $ mconcat conts

141+

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

143+-- consists of exactly ONE element.

144+parseContent

145+ :: (Monad m)

146+ => (Text -> Either Text a)

147+ -- ^ Content parser, return error msg if value is not parsed

148+ -> DomParserT Identity m a

149+parseContent parse = getCurrentContent >>= \case

150+ Nothing -> throwParserError PEContentNotFound

151+ Just c -> case parse c of

152+ Left e -> throwParserError $ PEWrongFormat e

153+ Right a -> return a

154+

155+-- | Retuns map of attributes of current element

156+--

157+-- @since 1.0.0

158+getCurrentAttributes

159+ :: (Monad m)

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

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

162+

163+-- | Returns element with given name or 'Nothing'

164+--

165+-- @since 1.0.0

166+getCurrentAttribute

167+ :: (Monad m)

168+ => NameMatcher

169+ -> DomParserT Identity m (Maybe Text)

170+getCurrentAttribute attrName

171+ = preview $ pdElements . to runIdentity . attrs . to M.toList

172+ . traversed . filtered (views _1 (attrName ^. nmMatch)) . _2

173+

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

175+--

176+-- @since 1.0.0

177+parseAttribute

178+ :: (Monad m)

179+ => NameMatcher

180+ -- ^ Attribute name

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

182+ -- ^ Attribute content parser

183+ -> DomParserT Identity m a

184+parseAttribute attrName parser =

185+ parseAttributeMaybe attrName parser >>= \case

186+ Nothing -> throwParserError $ PEAttributeNotFound attrName

187+ Just a -> return a

188+

189+-- | Parses attribute with given name.

190+--

191+-- @since 1.0.0

192+parseAttributeMaybe

193+ :: (Monad m)

194+ => NameMatcher

195+ -- ^ Attribute name

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

197+ -- ^ Attribute content parser

198+ -> DomParserT Identity m (Maybe a)

199+parseAttributeMaybe attrName parser =

200+ getCurrentAttribute attrName >>= \case

201+ Nothing -> return Nothing

202+ Just aval -> case parser aval of

203+ Left err -> throwParserError $ PEAttributeWrongFormat attrName err

204+ Right a -> return $ Just a

src/Text/XML/DOM/Parser/FromDom.hs−2

@@ -23,14 +23,12 @@ module Text.XML.DOM.Parser.FromDom

23import Control.Applicative

24import Control.Lens

25import Data.Fixed

26−import Data.Monoid

27import Data.OpenUnion

26import Data.OpenUnion

28import Data.Scientific

27import Data.Scientific

29import Data.Text as T hiding (empty)

28import Data.Text as T hiding (empty)

30import Data.Typeable

29import Data.Typeable

31import Data.Void

30import Data.Void

32import Text.XML

31import Text.XML

33−import Text.XML.DOM.Parser.Combinators

34import Text.XML.DOM.Parser.Common

32import Text.XML.DOM.Parser.Common

35import Text.XML.DOM.Parser.Types

33import Text.XML.DOM.Parser.Types

36import TypeFun.Data.List hiding (Union)

34import TypeFun.Data.List hiding (Union)

src/Text/XML/DOM/Parser/Types.hs+1−32

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

1module Text.XML.DOM.Parser.Types

2− ( -- * Local name

2+ ( -- * Name matching

3 NameMatcher(..)

4 , nmMatch

5 , nmShow

@@ -18,15 +18,12 @@ module Text.XML.DOM.Parser.Types

18 , ParserData(..)

19 , pdElements

20 , pdPath

21− -- * Parser type

22 , DomParserT

21 , DomParserT

23 , DomParser

22 , DomParser

24 , runDomParserT

23 , runDomParserT

25 , runDomParser

24 , runDomParser

26 -- * Auxiliary

25 -- * Auxiliary

27− , DomTraversable(..)

28 , throwParserError

26 , throwParserError

29− , throwWrongFormat

30 ) where

27 ) where

32import Control.Exception

29import Control.Exception

@@ -34,8 +31,6 @@ import Control.Lens

34import Control.Monad.Except

31import Control.Monad.Except

35import Control.Monad.Reader

32import Control.Monad.Reader

36import Data.CaseInsensitive as CI

33import Data.CaseInsensitive as CI

37−import Data.List.NonEmpty as NE

38−import Data.Maybe

39import Data.String

34import Data.String

40import Data.Text as T

35import Data.Text as T

41import GHC.Generics (Generic)

36import GHC.Generics (Generic)

@@ -184,25 +179,6 @@ runDomParser

184 -> Either ParserErrors a

179 -> Either ParserErrors a

185runDomParser doc par = runIdentity $ runDomParserT doc par

180runDomParser doc par = runIdentity $ runDomParserT doc par

186

181

187−-- | Class of traversable functors which may be constructed from list. Or may

188−-- not.

189−class Traversable f => DomTraversable f where

190− -- | If method return Nothing this means we can not build traversable from

191− -- given list. In this case combinator should fail traversing.

192− buildDomTraversable :: [a] -> Maybe (f a)

193−

194−instance DomTraversable Identity where

195− buildDomTraversable = fmap Identity . listToMaybe

196−

197−instance DomTraversable [] where

198− buildDomTraversable = Just

199−

200−instance DomTraversable Maybe where

201− buildDomTraversable = Just . listToMaybe

202−

203−instance DomTraversable NonEmpty where

204− buildDomTraversable = NE.nonEmpty

205−

206throwParserError

182throwParserError

207 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)

183 :: (MonadError ParserErrors m, MonadReader (ParserData f) m)

208 => (DomPath -> ParserError)

184 => (DomPath -> ParserError)

@@ -210,10 +186,3 @@ throwParserError

210throwParserError mkerr = do

186throwParserError mkerr = do

211 path <- view pdPath

187 path <- view pdPath

212 throwError $ ParserErrors $ [mkerr path]

188 throwError $ ParserErrors $ [mkerr path]

213−

214−-- | Throw 'PEWrongFormat' as very common case

215−throwWrongFormat

216− :: (MonadError ParserErrors m, MonadReader (ParserData f) m)

217− => Text

218− -> m a

219−throwWrongFormat err = throwParserError $ PEWrongFormat err