polysoup (empty) → 0.1.0
raw patch · 4 files changed
+456/−0 lines, 4 filesdep +basedep +polyparsedep +tagsoupsetup-changed
Dependencies added: base, polyparse, tagsoup
Files
- LICENSE +26/−0
- Setup.lhs +4/−0
- Text/XML/PolySoup.hs +396/−0
- polysoup.cabal +30/−0
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2012, IPI PAN+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ Text/XML/PolySoup.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE TupleSections #-}++module Text.XML.PolySoup+(+ -- * Types+ XmlParser+, TagParser+, TagPred++-- * Tag predicates+, satisfyPred+, true+, getTag+, isTagOpen+, isTagClose+, isTagOpenName+, isTagText+, tagOpenName+, tagText+, tag+, hasAttr+, getAttr+, maybeAttr++-- * XML parsing combinators+, ignore+, ignoreAny+, ignoreText+, ignoreTag+, ignoreAnyM+, cut+, findAll+, findIgnore+, findFirst+, text+, join+, joinP+, joinR+, joinL+, (>^>)+, (<^>)+, (^>)+, (<^)++-- * XPath-like combinators+, (>/>)+, (</>)+, (/>)+, (</)+, (//>)+, (<#>)+, (#>)+, (##>)++-- * Parsing+, parseTags+, tagsParseXml+, parseXml+, elemTags+, collTags++-- * Utilities+, many_+, escapeXml++, module Text.ParserCombinators.Poly.Lazy+) where++import Data.Monoid+import Control.Applicative+import Data.Char (isSpace)+import Control.Monad (guard)+import Data.Maybe (catMaybes, isJust, fromJust)+import qualified Text.HTML.TagSoup as Tag+import Text.StringLike+import Text.ParserCombinators.Poly.Lazy++-- | A tag predicate checks if the tag (HTML element) satisfies some+-- properties and extracts attribute values. You can compose tag predicates+-- using Applicative and Alternative operators: '*>', '<*', '<|>' etc.+newtype TagPred s a = TagPred (Tag.Tag s -> Maybe a)++instance Functor (TagPred s) where + fmap f (TagPred g) = TagPred $ fmap (fmap f) g++instance Applicative (TagPred s) where + pure = TagPred . const . Just+ TagPred f <*> TagPred p = TagPred $ \t -> f t <*> p t++instance Alternative (TagPred s) where + empty = TagPred $ \_ -> Nothing+ TagPred p <|> TagPred p' = TagPred $ \t -> p t <|> p' t++-- | True predicate which returns the tag itself. +getTag :: TagPred s (Tag.Tag s)+getTag = TagPred Just++fromBool :: Bool -> Maybe ()+fromBool True = Just ()+fromBool False = Nothing++-- | Predicate which is always satisfied.+true :: TagPred s ()+true = pure ()++-- | Check if the HTML element is an open tag.+isTagOpen :: TagPred s ()+isTagOpen = TagPred (fromBool . Tag.isTagOpen)++-- | Check if the HTML element is a closing tag.+isTagClose :: TagPred s ()+isTagClose = TagPred (fromBool . Tag.isTagClose)++-- | Check if the tag is an open tag and matches the given name.+isTagOpenName :: Eq s => s -> TagPred s ()+isTagOpenName nm = TagPred (fromBool . Tag.isTagOpenName nm)++-- | Check if the tag is a closing tag and matches the given name.+isTagCloseName :: Eq s => s -> TagPred s ()+isTagCloseName nm = TagPred (fromBool . Tag.isTagCloseName nm)++-- | A shorthand for isTagOpenName.+tag :: Eq s => s -> TagPred s ()+tag = isTagOpenName++-- | Get name of the open tag.+tagOpenName :: TagPred s s+tagOpenName =+ isTagOpen *> TagPred getIt+ where+ getIt (Tag.TagOpen name _) = Just name+ getIt _ = Nothing++-- | Test if the tag is a text node.+isTagText :: TagPred s ()+isTagText = TagPred (fromBool . Tag.isTagText)++-- | Get text content of the tag.+tagText :: TagPred s s+tagText = TagPred Tag.maybeTagText ++-- | Get attribute value from the open tag or Nothing if+-- the attribute is not present. It is an alternative+-- for Tag.fromAttrib.+fromAttrib :: (Show str, Eq str, StringLike str)+ => str -> Tag.Tag str -> Maybe str+fromAttrib att (Tag.TagOpen _ atts) = lookup att atts+fromAttrib _ x = error ("(" ++ show x ++ ") is not a TagOpen")++-- | Check if the tag has the given attribute with the given value.+hasAttr :: (Show s, Eq s, StringLike s) => s -> s -> TagPred s ()+hasAttr name x =+ isTagOpen *> TagPred checkIt + where+ checkIt t = do+ y <- fromAttrib name t+ guard (x == y)++-- | Get attribute value from the open tag.+getAttr :: (Show s, Eq s, StringLike s) => s -> TagPred s s+getAttr name = isTagOpen *> TagPred (fromAttrib name)++-- | Get attribute value from the open tag or Nothing, if the+-- attribute is not present.+maybeAttr :: (Show s, Eq s, StringLike s) => s -> TagPred s (Maybe s)+maybeAttr name = isTagOpen *> TagPred (Just . fromAttrib name)++-- TODO: distinguish XmlParser+-- and TagParser types using newtype?++-- | XML forest parser with result type a. +type XmlParser s a = Parser (Tag.Tag s) a+type TagParser s a = Parser (Tag.Tag s) a++-- | Many combinator which ignores parsing results.+many_ :: Alternative f => f a -> f ()+many_ v = many_v+ where+ many_v = some_v <|> pure ()+ some_v = v *> many_v++-- | Make a tag parser from the tag predicate.+satisfyPred :: TagPred s a -> TagParser s a+satisfyPred (TagPred t) =+ let q = isJust . t+ in fromJust . t <$> satisfy q++-- | Ignore any number of XML elements on the current level.+ignore :: Eq s => XmlParser s ()+ignore = many_ ignoreAny++-- | Ignore XML tree or text element. +ignoreAny :: Eq s => XmlParser s ()+ignoreAny = ignoreText <|> ignoreTag++-- | Ignore text element. +ignoreText :: XmlParser s ()+ignoreText = satisfyPred isTagText++-- | Ignore XML tree. +ignoreTag :: Eq s => XmlParser s ()+ignoreTag = do+ name <- satisfyPred tagOpenName+ name `seq` many_ ignoreAny *> satisfyPred (isTagCloseName name)++-- | Version of the ignoreAny function with a monoid result type.+ignoreAnyM :: (Eq s, Monoid m) => XmlParser s m+ignoreAnyM = const mempty <$> ignoreAny++-- | Parse text element and retrieve its content.+text :: Eq s => XmlParser s s+text = satisfyPred tagText++-- | Parse XML element using the given tag predicate and ignore+-- contents of the element.+cut :: Eq s => TagPred s a -> XmlParser s a+cut p = p </ ignoreAny++-- | Parse a list of XML elements and collect all values+-- retrieved with a given parser.+findAll :: Eq s => XmlParser s a -> XmlParser s [a]+findAll q =+ let q' = Just <$> q <|> Nothing <$ ignoreAny+ in catMaybes <$> many q'++-- | Find fist XML element accepted by the given parser.+-- TODO: Change type to XmlParser s (Maybe a)?+findFirst :: Eq s => XmlParser s a -> XmlParser s a+findFirst q = q <|> ignoreAny *> findFirst q++-- | Find first XML element accepted be the given parser and+-- ignore the rest of elements in the collection.+findIgnore :: Eq s => XmlParser s a -> XmlParser s (Maybe a)+findIgnore q = findAll q >>= \xs -> return $ case xs of+ (x:_) -> Just x+ [] -> Nothing++-- | Combine the tag parser with the XML parser which will be used+-- to parse contents of the tag element.+join :: Eq s => TagPred s a -> (a -> XmlParser s b) -> XmlParser s b+join p q = do+ (x, name) <- satisfyPred ((,) <$> p <*> tagOpenName)+ name `seq` x `seq` q x <* satisfyPred (isTagCloseName name)++-- | Combine the tag parser with the XML parser which will be used+-- to parse contents of the tag element. Parsing results will be+-- returned in a form of a pair.+joinP :: Eq s => TagPred s a -> XmlParser s b -> XmlParser s (a, b)+joinP p q = join p $ \x -> (x,) <$> q++-- | Combine the tag parser with the XML parser which will be used+-- to parse contents of the tag element. Only results of the+-- XML parser will be returned.+joinR :: Eq s => TagPred s a -> XmlParser s b -> XmlParser s b+joinR p q = snd <$> joinP p q++-- | Combine the tag parser with the XML parser which will be used+-- to parse contents of the tag element. Only results of the+-- tag parser will be returned.+joinL :: Eq s => TagPred s a -> XmlParser s b -> XmlParser s a+joinL p q = fst <$> joinP p q++-- | Infix version of the join combinators.+(>^>) :: Eq s => TagPred s a -> (a -> XmlParser s b) -> XmlParser s b+(>^>) = join+infixr 2 >^>++-- | Infix version of the joinP combinators.+(<^>) :: Eq s => TagPred s a -> XmlParser s b -> XmlParser s (a, b)+(<^>) = joinP+infixr 2 <^>++-- | Infix version of the joinR combinators.+(^>) :: Eq s => TagPred s a -> XmlParser s b -> XmlParser s b+(^>) = joinR+infixr 2 ^>++-- | Infix version of the joinL combinators.+(<^) :: Eq s => TagPred s a -> XmlParser s b -> XmlParser s a+(<^) = joinL+infixr 2 <^+++-- | Combine the tag parser with the XML parser. The XML parser will+-- be called multiple times for tag children elements.+(</>) :: Eq s => TagPred s a -> XmlParser s b -> XmlParser s (a, [b])+(</>) p q =+ joinP p (catMaybes <$> many qMaybe)+ where+ qMaybe = Just <$> q+ <|> const Nothing <$> ignoreAny+infixr 2 </>++-- | Combine the tag parser with the XML parser. The XML parser can depend+-- on the value of tag parser and will be called multiple times for tag children+-- elements.+(>/>) :: Eq s => TagPred s a -> (a -> XmlParser s b) -> XmlParser s [b]+(>/>) p q =+ p `join` \x -> (catMaybes <$> many (qMaybe x))+ where+ qMaybe x = Just <$> q x+ <|> const Nothing <$> ignoreAny+infixr 2 >/>++-- | Combine the tag parser with the XML parser. The XML parser will+-- be called multiple times for tag children elements. Only results+-- of XML parsing will be returned.+(/>) :: Eq s => TagPred s a -> XmlParser s b -> XmlParser s [b]+(/>) p q = snd <$> (p </> q) -- joinR p (many $ q <|> ignoreAnyM)+infixr 2 />++-- | Combine the tag parser with the XML parser. The XML parser will+-- be called multiple times for tag children elements. Only results+-- of the tag parser will be returned.+(</) :: Eq s => TagPred s a -> XmlParser s b -> XmlParser s a+(</) p q = fst <$> (p </> q) -- joinL p (many_ $ q <|> ignoreAnyM)+infixr 2 </++-- | Similar to '/>' combinator but runs the XML parser for all+-- descendant XML elements, not only for its children. +(//>) :: Eq s => TagPred s a -> TagParser s b -> TagParser s [b]+(//>) p q =+ concat <$> joinR p (many qList)+ where+ qList = pure <$> q+ <|> (true //> q)+ <|> ignoreAnyM+infixr 2 //>++-- | Combinators with results concatenation.++-- | Similar to '</>' combinator but additionaly concatenates XML+-- parser results.+(<#>) :: (Eq s, Monoid m) => TagPred s a -> XmlParser s m -> XmlParser s (a, m)+(<#>) p q =+ let mc (x, xs) = (x, mconcat xs)+ in mc <$> (p </> q)+infixr 2 <#>++-- | Similar to '/>' combinator but additionaly concatenates XML+-- parser results.+(#>) :: (Eq s, Monoid m) => TagPred s a -> XmlParser s m -> XmlParser s m+(#>) p q = mconcat <$> (p /> q)+infixr 2 #>++-- | Similar to '//>' combinator but additionaly concatenates XML+-- parser results.+(##>) :: (Eq s, Monoid m) => TagPred s a -> TagParser s m -> TagParser s m+(##>) p q = mconcat <$> (p //> q)+infixr 2 ##>++relevant :: StringLike s => Tag.Tag s -> Bool+relevant (Tag.TagOpen name _)+ | name == fromString "?xml" = False+ | otherwise = True+relevant (Tag.TagClose _) = True+relevant (Tag.TagText s) = not $ null $ trim $ toString s+relevant _ = False++trim :: String -> String+trim = f . f where f = reverse . dropWhile isSpace++-- | Parser the given string to the list of tags.+parseTags :: StringLike s => s -> [Tag.Tag s]+parseTags = filter relevant . Tag.parseTags++-- | Parser the given tag list with the given XML parser.+tagsParseXml :: StringLike s => XmlParser s b -> [Tag.Tag s] -> b+tagsParseXml p = fst . runParser p++-- | Parser the given string with the given XML parser.+parseXml :: StringLike s => XmlParser s b -> s -> b+parseXml p = tagsParseXml p . parseTags++-- | Collect all tags of the parsed XML element.+elemTags :: Eq s => XmlParser s [Tag.Tag s]+elemTags = trueElemTags <|> (:[]) <$> textTag++trueElemTags :: Eq s => XmlParser s [Tag.Tag s]+trueElemTags = do+ (beg, name) <- satisfyPred ((,) <$> getTag <*> tagOpenName)+ inside <- beg `seq` name `seq` collTags+ end <- satisfyPred (getTag <* isTagCloseName name)+ return (beg : inside ++ [end])++-- | Return the underlying text element.+textTag :: XmlParser s (Tag.Tag s)+textTag = fst <$> satisfyPred ((,) <$> getTag <*> isTagText)++-- | Retrieve tags related to a collection of XML elements.+collTags :: Eq s => XmlParser s [Tag.Tag s]+collTags = concat <$> many elemTags++-- | Escape XML string.+escapeXml :: StringLike str => str -> str+escapeXml = Tag.escapeHTML
+ polysoup.cabal view
@@ -0,0 +1,30 @@+name: polysoup+version: 0.1.0+synopsis: Online XML parsing with polyparse and tagsoup+description:+ The library provides combinators for lazy, incremental XML parsing.+license: BSD3+license-file: LICENSE+cabal-version: >= 1.6+copyright: Copyright (c) 2012 IPI PAN+author: Jakub Waszczuk+maintainer: waszczuk.kuba@gmail.com+stability: experimental+category: XML+homepage: https://github.com/kawu/polysoup+build-type: Simple++library+ build-depends:+ base >= 4 && < 5+ , tagsoup+ , polyparse++ exposed-modules:+ Text.XML.PolySoup++ ghc-options: -Wall++source-repository head+ type: git+ location: git://github.com/kawu/polysoup.git