0016d46 · typeable/dom-parser

git.iko.soy/typeable/dom-parser

on master help sign in

Upd: use `NameMatcher` for name matching

0016d46Alexey Uimanov10 years ago

dom-parser.cabal+1

compare with master

unifiedsplit

@@ -44,6 +44,7 @@ library

44 , TypeOperators

45 , UndecidableInstances

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

47+ , case-insensitive

47 , containers

48 , containers

48 , lens

49 , lens

49 , mtl

50 , mtl

src/Text/XML/DOM/Parser/Combinators.hs+26−20

@@ -86,38 +86,38 @@ inFilteredTrav deeper = traverseElems trav

87inElemTrav

88 :: (Monad m, Foldable g, DomTraversable f)

89− => Name -- ^ Name of tag to traverse in

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

90 -> DomParserT Identity m a

91 -> DomParserT g m (f a)

92inElemTrav n = inFilteredTrav deeper

93 where

94− deeper = (DomPath [n],) . toListOf (folded . nodes . folded . _Element . el n)

94+ deeper = (DomPath [_nmShow n],) . toListOf (folded . nodes . folded . _Element . elMatchName n)

96-- | Runs parser inside first children element with given name

97inElem

98 :: (Monad m, Foldable g)

99− => Name

99+ => NameMatcher

100 -> DomParserT Identity m a

101 -> DomParserT g m a

102inElem n = fmap runIdentity . inElemTrav n

103

104inElemAll

105 :: (Monad m, Foldable g)

106− => Name

106+ => NameMatcher

107 -> DomParserT Identity m a

108 -> DomParserT g m [a]

109inElemAll = inElemTrav

110

111inElemMay

112 :: (Monad m, Foldable g)

113− => Name

113+ => NameMatcher

114 -> DomParserT Identity m a

115 -> DomParserT g m (Maybe a)

116inElemMay = inElemTrav

117

118inElemNe

119 :: (Monad m, Foldable g)

120− => Name

120+ => NameMatcher

121 -> DomParserT Identity m a

122 -> DomParserT g m (NonEmpty a)

123inElemNe = inElemTrav

@@ -149,24 +149,24 @@ in given path.

149divePath

150 :: forall m g a

151 . (Monad m, Foldable g)

152− => DomPath

152+ => [NameMatcher]

153 -> DomParserT [] m a

154 -> DomParserT g m a

155divePath path = magnify $ to modElems

156 where

157 modElems

158 = over pdElements (toListOf $ folded . diver)

159− . over pdPath (<> path)

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

160 diver :: Fold Element Element

161− diver = foldr (.) id $ map toDive $ unDomPath path

161+ diver = foldr (.) id $ map toDive path

162− toDive n = nodes . folded . _Element . el n

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

163

164diveElem

165 :: (Monad m, Foldable g)

166− => Name

166+ => NameMatcher

167 -> DomParserT [] m a

168 -> DomParserT g m a

169−diveElem p = divePath $ DomPath [p]

169+diveElem p = divePath [p]

170

171-- | Ignore arbitrary current element if it conforms to predicate.

172ignoreElem

@@ -219,14 +219,14 @@ getCurrentName = view $ pdElements . to runIdentity . name

219-- document's element name.

220checkCurrentName

221 :: (Monad m)

222− => Name

222+ => NameMatcher

223 -> DomParserT Identity m ()

224checkCurrentName n = do

225 cn <- getCurrentName

226− unless (cn == n) $ do

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

227 p <- view pdPath

228 let pinit = if null (unDomPath p) then [] else init $ unDomPath p

229− throwError $ ParserErrors [PENotFound $ DomPath $ pinit ++ [n]]

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

230 return ()

231

232-- | Get current content. If current element contains no content or

@@ -288,22 +288,28 @@ readContent = maybeReadContent $ readMaybe . T.unpack . T.strip

288-- | Retuns map of attributes of current element

289--

290-- @since 1.0.0

291+getCurrentAttributes

292+ :: (Monad m)

291−getCurrentAttributes :: (Monad m) => DomParserT Identity m (M.Map Name Text)

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

292getCurrentAttributes = view $ pdElements . to runIdentity . attrs

294getCurrentAttributes = view $ pdElements . to runIdentity . attrs

293

295

294-- | Returns element with given name or 'Nothing'

296-- | Returns element with given name or 'Nothing'

295--

297--

296-- @since 1.0.0

298-- @since 1.0.0

299+getCurrentAttribute

300+ :: (Monad m)

301+ => NameMatcher

297−getCurrentAttribute :: (Monad m) => Name -> DomParserT Identity m (Maybe Text)

302+ -> DomParserT Identity m (Maybe Text)

298getCurrentAttribute attrName

303getCurrentAttribute attrName

299− = preview $ pdElements . to runIdentity . attr attrName

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

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

300

306

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

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

302--

308--

303-- @since 1.0.0

309-- @since 1.0.0

304parseAttribute

310parseAttribute

305 :: (Monad m)

311 :: (Monad m)

306− => Name

312+ => NameMatcher

307 -- ^ Attribute name

313 -- ^ Attribute name

308 -> (Text -> Either Text a)

314 -> (Text -> Either Text a)

309 -- ^ Attribute content parser

315 -- ^ Attribute content parser

@@ -318,7 +324,7 @@ parseAttribute attrName parser =

318-- @since 1.0.0

324-- @since 1.0.0

319parseAttributeMaybe

325parseAttributeMaybe

320 :: (Monad m)

326 :: (Monad m)

321− => Name

327+ => NameMatcher

322 -- ^ Attribute name

328 -- ^ Attribute name

323 -> (Text -> Either Text a)

329 -> (Text -> Either Text a)

324 -- ^ Attribute content parser

330 -- ^ Attribute content parser

src/Text/XML/DOM/Parser/Types.hs+64−12

@@ -1,6 +1,14 @@

1module Text.XML.DOM.Parser.Types

2+ ( -- * Local name

3+ NameMatcher(..)

4+ , nmMatch

5+ , nmShow

6+ , matchName

7+ , matchLocalName

8+ , matchCILocalName

9+ , elMatchName

2− ( -- * Parser internals

10+ -- * Parser internals

3− DomPath(..)

11+ , DomPath(..)

4 , ParserError(..)

12 , ParserError(..)

5 , pePath

13 , pePath

6 , peDetails

14 , peDetails

@@ -25,15 +33,58 @@ import Control.Exception

25import Control.Lens

33import Control.Lens

26import Control.Monad.Except

34import Control.Monad.Except

27import Control.Monad.Reader

35import Control.Monad.Reader

36+import Data.CaseInsensitive as CI

28import Data.List.NonEmpty as NE

37import Data.List.NonEmpty as NE

29import Data.Maybe

38import Data.Maybe

30−import Data.Text (Text)

39+import Data.String

40+import Data.Text as T

31import GHC.Generics (Generic)

41import GHC.Generics (Generic)

32import Text.XML

42import Text.XML

33import Text.XML.Lens

43import Text.XML.Lens

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

46+-- considered to be used as comparator with some name with some rules

47+data NameMatcher = NameMatcher

48+ { _nmMatch :: Name -> Bool

49+ -- ^ Name matching function, usually should be simple comparsion

50+ -- function takin in account only local name or other components

51+ -- of 'Name'

52+ , _nmShow :: Text

53+ -- ^ How to show the name matcher, since there is no 'Read'

54+ -- instance we can do it any way we want

55+ }

56+

57+makeLenses ''NameMatcher

58+

59+instance IsString NameMatcher where

60+ fromString = matchCILocalName . T.pack

61+

62+instance Show NameMatcher where

63+ show = T.unpack . _nmShow

64+

65+matchLocalName :: Text -> NameMatcher

66+matchLocalName tname = NameMatcher

67+ { _nmMatch = \n -> nameLocalName n == tname

68+ , _nmShow = tname

69+ }

70+

71+matchCILocalName :: Text -> NameMatcher

72+matchCILocalName tname = NameMatcher

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

74+ , _nmShow = tname

75+ }

76+

77+matchName :: Name -> NameMatcher

78+matchName n = NameMatcher

79+ { _nmMatch = (== n)

80+ , _nmShow = nameLocalName n

81+ }

82+

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

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

85+

35newtype DomPath = DomPath

86newtype DomPath = DomPath

36− { unDomPath :: [Name]

87+ { unDomPath :: [Text]

37 } deriving (Eq, Ord, Show, Monoid)

88 } deriving (Eq, Ord, Show, Monoid)

39-- | DOM parser error description.

90-- | DOM parser error description.

@@ -51,7 +102,7 @@ data ParserError

102

52 -- | Could not parse attribute

103 -- | Could not parse attribute

53 | PEAttributeWrongFormat

104 | PEAttributeWrongFormat

54− { _peAttributeName :: Name

105+ { _peAttributeName :: NameMatcher

55 , _peDetails :: Text

106 , _peDetails :: Text

56 , _pePath :: DomPath

107 , _pePath :: DomPath

57 }

108 }

@@ -63,7 +114,7 @@ data ParserError

114

64 -- | Expected attribute but not found

115 -- | Expected attribute but not found

65 | PEAttributeNotFound

116 | PEAttributeNotFound

66− { _peAttributeName :: Name

117+ { _peAttributeName :: NameMatcher

67 , _pePath :: DomPath

118 , _pePath :: DomPath

68 }

119 }

120

@@ -71,7 +122,7 @@ data ParserError

71 | PEOther

122 | PEOther

72 { _peDetails :: Text

123 { _peDetails :: Text

73 , _pePath :: DomPath

124 , _pePath :: DomPath

74− } deriving (Eq, Ord, Show, Generic)

125+ } deriving (Show, Generic)

126

76makeLenses ''ParserError

127makeLenses ''ParserError

128

@@ -79,7 +130,7 @@ instance Exception ParserError

130

80newtype ParserErrors = ParserErrors

131newtype ParserErrors = ParserErrors

81 { unParserErrors :: [ParserError]

132 { unParserErrors :: [ParserError]

82− } deriving (Ord, Eq, Show, Monoid, Generic)

133+ } deriving (Show, Monoid, Generic)

134

84makePrisms ''ParserErrors

135makePrisms ''ParserErrors

136

@@ -120,10 +171,11 @@ runDomParserT

120 -> DomParserT Identity m a

171 -> DomParserT Identity m a

121 -> m (Either ParserErrors a)

172 -> m (Either ParserErrors a)

122runDomParserT doc par =

173runDomParserT doc par =

174+ let

123− let pd = ParserData

175+ pd = ParserData

124− { _pdElements = doc ^. root . to pure

176+ { _pdElements = doc ^. root . to pure

125− , _pdPath = DomPath [doc ^. root . name]

177+ , _pdPath = DomPath [doc ^. root . name . to nameLocalName]

126− }

178+ }

127 in runExceptT $ runReaderT par pd

179 in runExceptT $ runReaderT par pd

128

180

129runDomParser

181runDomParser