0016d46 · typeable/dom-parser

git.iko.soy/typeable/dom-parser

Upd: use `NameMatcher` for name matching

commit0016d46f9457bc51739b27197f64a2ce1f33752c authorAlexey Uimanov <s9gf4ult@gmail.com> dateTue 3 Jan 2017, 22:49 (10 years ago) parent7aa37c9

3 files changed+91−32

compare with master

unifiedsplit

dom-parser.cabal+1 src/Text/XML/DOM/Parser/Combinators.hs+26−20 src/Text/XML/DOM/Parser/Types.hs+64−12

dom-parser.cabal+1

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

4444 , TypeOperators

4545 , UndecidableInstances

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

47+ , case-insensitive

4748 , containers

4849 , lens

4950 , mtl

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

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

8686

8787inElemTrav

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

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

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

9090 -> DomParserT Identity m a

9191 -> DomParserT g m (f a)

9292inElemTrav n = inFilteredTrav deeper

9393 where

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

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

9595

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

9797inElem

9898 :: (Monad m, Foldable g)

99− => Name

99+ => NameMatcher

100100 -> DomParserT Identity m a

101101 -> DomParserT g m a

102102inElem n = fmap runIdentity . inElemTrav n

103103

104104inElemAll

105105 :: (Monad m, Foldable g)

106− => Name

106+ => NameMatcher

107107 -> DomParserT Identity m a

108108 -> DomParserT g m [a]

109109inElemAll = inElemTrav

110110

111111inElemMay

112112 :: (Monad m, Foldable g)

113− => Name

113+ => NameMatcher

114114 -> DomParserT Identity m a

115115 -> DomParserT g m (Maybe a)

116116inElemMay = inElemTrav

117117

118118inElemNe

119119 :: (Monad m, Foldable g)

120− => Name

120+ => NameMatcher

121121 -> DomParserT Identity m a

122122 -> DomParserT g m (NonEmpty a)

123123inElemNe = inElemTrav

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

149149divePath

150150 :: forall m g a

151151 . (Monad m, Foldable g)

152− => DomPath

152+ => [NameMatcher]

153153 -> DomParserT [] m a

154154 -> DomParserT g m a

155155divePath path = magnify $ to modElems

156156 where

157157 modElems

158158 = over pdElements (toListOf $ folded . diver)

159− . over pdPath (<> path)

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

160160 diver :: Fold Element Element

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

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

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

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

163163

164164diveElem

165165 :: (Monad m, Foldable g)

166− => Name

166+ => NameMatcher

167167 -> DomParserT [] m a

168168 -> DomParserT g m a

169−diveElem p = divePath $ DomPath [p]

169+diveElem p = divePath [p]

170170

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

172172ignoreElem

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

219219-- document's element name.

220220checkCurrentName

221221 :: (Monad m)

222− => Name

222+ => NameMatcher

223223 -> DomParserT Identity m ()

224224checkCurrentName n = do

225225 cn <- getCurrentName

226− unless (cn == n) $ do

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

227227 p <- view pdPath

228228 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]]

230230 return ()

231231

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

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

288288-- | Retuns map of attributes of current element

289289--

290290-- @since 1.0.0

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

291+getCurrentAttributes

292+ :: (Monad m)

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

292294getCurrentAttributes = view $ pdElements . to runIdentity . attrs

293295

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

295297--

296298-- @since 1.0.0

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

299+getCurrentAttribute

300+ :: (Monad m)

301+ => NameMatcher

302+ -> DomParserT Identity m (Maybe Text)

298303getCurrentAttribute 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

300306

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

302308--

303309-- @since 1.0.0

304310parseAttribute

305311 :: (Monad m)

306− => Name

312+ => NameMatcher

307313 -- ^ Attribute name

308314 -> (Text -> Either Text a)

309315 -- ^ Attribute content parser

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

318324-- @since 1.0.0

319325parseAttributeMaybe

320326 :: (Monad m)

321− => Name

327+ => NameMatcher

322328 -- ^ Attribute name

323329 -> (Text -> Either Text a)

324330 -- ^ Attribute content parser

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

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

11module Text.XML.DOM.Parser.Types

2− ( -- * Parser internals

3− DomPath(..)

2+ ( -- * Local name

3+ NameMatcher(..)

4+ , nmMatch

5+ , nmShow

6+ , matchName

7+ , matchLocalName

8+ , matchCILocalName

9+ , elMatchName

10+ -- * Parser internals

11+ , DomPath(..)

412 , ParserError(..)

513 , pePath

614 , peDetails

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

2533import Control.Lens

2634import Control.Monad.Except

2735import Control.Monad.Reader

36+import Data.CaseInsensitive as CI

2837import Data.List.NonEmpty as NE

2938import Data.Maybe

30−import Data.Text (Text)

39+import Data.String

40+import Data.Text as T

3141import GHC.Generics (Generic)

3242import Text.XML

3343import Text.XML.Lens

3444

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+

3586newtype DomPath = DomPath

36− { unDomPath :: [Name]

87+ { unDomPath :: [Text]

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

3889

3990-- | DOM parser error description.

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

51102

52103 -- | Could not parse attribute

53104 | PEAttributeWrongFormat

54− { _peAttributeName :: Name

105+ { _peAttributeName :: NameMatcher

55106 , _peDetails :: Text

56107 , _pePath :: DomPath

57108 }

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

63114

64115 -- | Expected attribute but not found

65116 | PEAttributeNotFound

66− { _peAttributeName :: Name

117+ { _peAttributeName :: NameMatcher

67118 , _pePath :: DomPath

68119 }

69120

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

71122 | PEOther

72123 { _peDetails :: Text

73124 , _pePath :: DomPath

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

125+ } deriving (Show, Generic)

75126

76127makeLenses ''ParserError

77128

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

79130

80131newtype ParserErrors = ParserErrors

81132 { unParserErrors :: [ParserError]

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

133+ } deriving (Show, Monoid, Generic)

83134

84135makePrisms ''ParserErrors

85136

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

120171 -> DomParserT Identity m a

121172 -> m (Either ParserErrors a)

122173runDomParserT doc par =

123− let pd = ParserData

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

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

126− }

174+ let

175+ pd = ParserData

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

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

178+ }

127179 in runExceptT $ runReaderT par pd

128180

129181runDomParser