7b06cfc · typeable/dom-parser

git.iko.soy/typeable/dom-parser

on master help sign in

WIP: refactoring

7b06cfcAlexey Uimanov10 years ago

dom-parser.cabal+3−1

compare with master

unifiedsplit

@@ -57,8 +57,10 @@ library

57 , xml-conduit

58 , xml-lens

59 exposed-modules: Text.XML.DOM.Parser

60− , Text.XML.DOM.Parser.Class

61 , Text.XML.DOM.Parser.Combinators

60 , Text.XML.DOM.Parser.Combinators

61+ , Text.XML.DOM.Parser.Common

62+ , Text.XML.DOM.Parser.FromAttribute

63+ , Text.XML.DOM.Parser.FromDom

62 , Text.XML.DOM.Parser.Types

64 , Text.XML.DOM.Parser.Types

64test-suite test

66test-suite test

src/Text/XML/DOM/Parser.hs+7−3

@@ -1,9 +1,13 @@

1module Text.XML.DOM.Parser

2− ( module Text.XML.DOM.Parser.Class

2+ ( module Text.XML.DOM.Parser.Combinators

3− , module Text.XML.DOM.Parser.Combinators

3+ , module Text.XML.DOM.Parser.Common

4+ , module Text.XML.DOM.Parser.FromAttribute

5+ , module Text.XML.DOM.Parser.FromDom

4 , module Text.XML.DOM.Parser.Types

6 , module Text.XML.DOM.Parser.Types

5 ) where

7 ) where

7−import Text.XML.DOM.Parser.Class

8import Text.XML.DOM.Parser.Combinators

9import Text.XML.DOM.Parser.Combinators

10+import Text.XML.DOM.Parser.Common

11+import Text.XML.DOM.Parser.FromAttribute

12+import Text.XML.DOM.Parser.FromDom

9import Text.XML.DOM.Parser.Types

13import Text.XML.DOM.Parser.Types

src/Text/XML/DOM/Parser/Combinators.hs+21−48

@@ -24,27 +24,25 @@ module Text.XML.DOM.Parser.Combinators

24 , checkCurrentName

25 -- * Parsing element's content

26 , parseContent

27− , readContent

28− , maybeReadContent

29 -- * Parsing attributes

27 -- * Parsing attributes

30 , parseAttribute

28 , parseAttribute

31 , parseAttributeMaybe

29 , parseAttributeMaybe

32 ) where

30 ) where

34−import Control.Lens

32+import Control.Lens

35−import Control.Monad.Except

33+import Control.Monad.Except

36−import Control.Monad.Reader

34+import Control.Monad.Reader

35+import Data.Foldable as F

36+import Data.List as L

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

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

38−import qualified Data.Map.Strict as M

38+import Data.Map.Strict as M

39−import Data.Monoid

39+import Data.Monoid

40−import Data.Text (Text)

41−import qualified Data.Text as T

40+import Data.Text as T

42−import Data.Traversable

41+import Data.Traversable

43−import Data.Typeable

42+import Text.XML

44−import Text.Read

45−import Text.XML

43+import Text.XML.DOM.Parser.Common

46−import Text.XML.DOM.Parser.Types

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

47−import Text.XML.Lens

45+import Text.XML.Lens

50-- | Generic function to traverse arbitrary inner cursors.

48-- | Generic function to traverse arbitrary inner cursors.

@@ -156,9 +154,9 @@ divePath path = magnify $ to modElems

156 where

154 where

157 modElems

155 modElems

158 = over pdElements (toListOf $ folded . diver)

156 = over pdElements (toListOf $ folded . diver)

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

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

160 diver :: Fold Element Element

158 diver :: Fold Element Element

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

159+ diver = F.foldr (.) id $ L.map toDive path

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

160 toDive n = nodes . folded . _Element . elMatchName n

163

161

164diveElem

162diveElem

@@ -190,7 +188,7 @@ ignoreEmpty

190 -> DomParserT Identity m (Maybe a)

188 -> DomParserT Identity m (Maybe a)

191ignoreEmpty = ignoreElem test

189ignoreEmpty = ignoreElem test

192 where

190 where

193− test e = null $ e ^. nodes

191+ test e = L.null $ e ^. nodes

194

192

195-- | If all current elements contains blank content, or contains nothing at all

193-- | If all current elements contains blank content, or contains nothing at all

196-- , then returns Nothing, else runs parser.

194-- , then returns Nothing, else runs parser.

@@ -204,7 +202,7 @@ ignoreBlank = ignoreElem test

204 let

202 let

205 elems = e ^.. nodes . folded . _Element

203 elems = e ^.. nodes . folded . _Element

206 cont = mconcat $ e ^.. nodes . folded . _Content

204 cont = mconcat $ e ^.. nodes . folded . _Content

207− in if | not $ null elems -> False

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

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

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

209 | otherwise -> False

207 | otherwise -> False

210

208

@@ -225,7 +223,7 @@ checkCurrentName n = do

225 cn <- getCurrentName

223 cn <- getCurrentName

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

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

227 p <- view pdPath

225 p <- view pdPath

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

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

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

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

230 return ()

228 return ()

231

229

@@ -242,8 +240,8 @@ getCurrentContent = do

242 conts :: [Text]

240 conts :: [Text]

243 conts = nds ^.. folded . _Content

241 conts = nds ^.. folded . _Content

244 return $ if

242 return $ if

245− | not $ null els -> Nothing

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

246− | null conts -> Nothing

244+ | L.null conts -> Nothing

247 | otherwise -> Just $ mconcat conts

245 | otherwise -> Just $ mconcat conts

248

246

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

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

@@ -260,31 +258,6 @@ parseContent parse = getCurrentContent >>= \case

260 Left e -> throwParserError $ PEWrongFormat e

258 Left e -> throwParserError $ PEWrongFormat e

261 Right a -> return a

259 Right a -> return a

262

260

263−-- | If reader returns 'Nothing' then resulting function returns 'Left

264−-- "error message"'

265−--

266−-- @since 1.0.0

267−maybeReadContent

268− :: forall a

269− . (Typeable a)

270− => (Text -> Maybe a)

271− -- ^ Content or attribute reader

272− -> Text

273− -- ^ Content or attribute value

274− -> Either Text a

275−maybeReadContent f t = maybe (Left msg) Right $ f t

276− where

277− msg = "Not readable " <> n <> ": " <> t

278− n = T.pack $ show $ typeRep (Proxy :: Proxy a)

279−

280−-- | Tries to read given text to value using 'Read'. Useful to use

281−-- with 'parseContent' and 'parseAttribute'

282−readContent

283− :: (Read a, Typeable a)

284− => Text

285− -> Either Text a

286−readContent = maybeReadContent $ readMaybe . T.unpack . T.strip

287−

288-- | Retuns map of attributes of current element

261-- | Retuns map of attributes of current element

289--

262--

290-- @since 1.0.0

263-- @since 1.0.0

src/Text/XML/DOM/Parser/Common.hsnew file+54

@@ -0,0 +1,54 @@

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

3+import Data.Monoid

4+import Data.Text as T

5+import Data.Typeable

6+import Text.Read

9+-- | @since 1.0.0

10+readBool :: Text -> Either Text Bool

11+readBool t =

12+ let

13+ lowt = T.toLower $ T.strip t

14+ tvals = ["y", "yes", "t", "true", "1"]

15+ fvals = ["n", "no", "f", "false", "0"]

16+ in if

17+ | lowt `elem` tvals -> Right True

18+ | lowt `elem` fvals -> Right False

19+ | otherwise ->

20+ Left $ "Could not read " <> t <> " as Bool"

21+

22+-- | Expects text to be single character

23+--

24+-- @since 1.0.0

25+readChar :: Text -> Either Text Char

26+readChar t = case T.unpack $ T.strip t of

27+ [c] -> Right c

28+ _ -> Left "Should have exactly one non-blank character"

29+

30+-- | If reader returns 'Nothing' then resulting function returns 'Left

31+-- "error message"'

32+--

33+-- @since 1.0.0

34+maybeReadContent

35+ :: forall a

36+ . (Typeable a)

37+ => (Text -> Maybe a)

38+ -- ^ Content or attribute reader

39+ -> Text

40+ -- ^ Content or attribute value

41+ -> Either Text a

42+maybeReadContent f t = maybe (Left msg) Right $ f t

43+ where

44+ msg = "Not readable " <> n <> ": " <> t

45+ n = T.pack $ show $ typeRep (Proxy :: Proxy a)

46+

47+

48+-- | Tries to read given text to value using 'Read'. Useful to use

49+-- with 'parseContent' and 'parseAttribute'

50+readContent

51+ :: (Read a, Typeable a)

52+ => Text

53+ -> Either Text a

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

src/Text/XML/DOM/Parser/FromAttribute.hsnew file+38

@@ -0,0 +1,38 @@

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

2+ ( -- * FromAttribute

3+ FromAttribute(..)

4+ ) where

6+import Data.Fixed

7+import Data.Scientific

8+import Data.Text as T

9+import Data.Typeable

10+import Text.XML.DOM.Parser.Common

11+

12+class FromAttribute a where

13+ fromAttribute

14+ :: Text

15+ -- ^ Attribute contents to parse

16+ -> Either Text a

17+ -- ^ Either error message or result

18+

19+instance FromAttribute () where

20+ fromAttribute _ = Right ()

21+

22+instance FromAttribute Text where

23+ fromAttribute = Right

24+

25+instance FromAttribute Char where

26+ fromAttribute = readChar

27+

28+instance FromAttribute Int where

29+ fromAttribute = readContent

30+

31+instance FromAttribute Integer where

32+ fromAttribute = readContent

33+

34+instance (Typeable a, HasResolution a) => FromAttribute (Fixed a) where

35+ fromAttribute = readContent

36+

37+instance FromAttribute Scientific where

38+ fromAttribute = readContent

src/Text/XML/DOM/Parser/Class.hs → src/Text/XML/DOM/Parser/FromDom.hsrenamed+2−52

@@ -1,4 +1,4 @@

1−module Text.XML.DOM.Parser.Class

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

2 ( -- * FromDom

3 FromDom(..)

4 , proxyFromDom

@@ -18,8 +18,6 @@ module Text.XML.DOM.Parser.Class

18 , unitFromDom

19 , voidFromDom

20 , scientificFromDom

21− -- * FromAttribute

22− , FromAttribute(..)

23 ) where

21 ) where

25import Control.Applicative

23import Control.Applicative

@@ -33,6 +31,7 @@ import Data.Typeable

33import Data.Void

31import Data.Void

34import Text.XML

32import Text.XML

35import Text.XML.DOM.Parser.Combinators

33import Text.XML.DOM.Parser.Combinators

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

36import Text.XML.DOM.Parser.Types

35import Text.XML.DOM.Parser.Types

37import TypeFun.Data.List hiding (Union)

36import TypeFun.Data.List hiding (Union)

@@ -112,14 +111,6 @@ stringFromDom = parseContent $ Right . T.unpack

112charFromDom :: (Monad m) => DomParserT Identity m Char

111charFromDom :: (Monad m) => DomParserT Identity m Char

113charFromDom = parseContent readChar

112charFromDom = parseContent readChar

114

113

115−-- | Expects text to be single character

116−--

117−-- @since 1.0.0

118−readChar :: Text -> Either Text Char

119−readChar t = case T.unpack $ T.strip t of

120− [c] -> Right c

121− _ -> Left "Should have exactly one non-blank character"

122−

123intFromDom :: (Monad m) => DomParserT Identity m Int

114intFromDom :: (Monad m) => DomParserT Identity m Int

124intFromDom = parseContent readContent

115intFromDom = parseContent readContent

125

116

@@ -143,19 +134,6 @@ scientificFromDom = parseContent readContent

143boolFromDom :: (Monad m) => DomParserT Identity m Bool

134boolFromDom :: (Monad m) => DomParserT Identity m Bool

144boolFromDom = parseContent readBool

135boolFromDom = parseContent readBool

145

136

146−-- | @since 1.0.0

147−readBool :: Text -> Either Text Bool

148−readBool t =

149− let

150− lowt = T.toLower $ T.strip t

151− tvals = ["y", "yes", "t", "true", "1"]

152− fvals = ["n", "no", "f", "false", "0"]

153− in if

154− | lowt `elem` tvals -> Right True

155− | lowt `elem` fvals -> Right False

156− | otherwise ->

157− Left $ "Could not read " <> t <> " as Bool"

158−

159-- | Always successfully parses any DOM to @()@

137-- | Always successfully parses any DOM to @()@

160unitFromDom :: (Monad m) => DomParserT Identity m ()

138unitFromDom :: (Monad m) => DomParserT Identity m ()

161unitFromDom = pure ()

139unitFromDom = pure ()

@@ -163,31 +141,3 @@ unitFromDom = pure ()

163-- | Never parses successfully. It is just 'mzero'

141-- | Never parses successfully. It is just 'mzero'

164voidFromDom :: (Monad m) => DomParserT Identity m Void

142voidFromDom :: (Monad m) => DomParserT Identity m Void

165voidFromDom = empty

143voidFromDom = empty

166−

167−class FromAttribute a where

168− fromAttribute

169− :: Text

170− -- ^ Attribute contents to parse

171− -> Either Text a

172− -- ^ Either error message or result

173−

174−instance FromAttribute () where

175− fromAttribute _ = Right ()

176−

177−instance FromAttribute Text where

178− fromAttribute = Right

179−

180−instance FromAttribute Char where

181− fromAttribute = readChar

182−

183−instance FromAttribute Int where

184− fromAttribute = readContent

185−

186−instance FromAttribute Integer where

187− fromAttribute = readContent

188−

189−instance (Typeable a, HasResolution a) => FromAttribute (Fixed a) where

190− fromAttribute = readContent

191−

192−instance FromAttribute Scientific where

193− fromAttribute = readContent