packages feed

polysoup 0.2.2 → 0.6.4

raw patch · 8 files changed

Files

− README.md 
polysoup.cabal view
@@ -1,40 +1,47 @@-cabal-version: 1.12+name:               polysoup+version:            0.6.4+synopsis:           Online XML parsing with polyparse and tagsoup+description:+    The library provides combinators for lazy, incremental XML parsing.+    Parsing results are generated lazily and the input is read on demand.+    .+    It is built on top of the tagsoup library, which is responsible for+    preliminary tokenization of an XML input, and the polyparse library,+    which provides primitives for lazy and incremental parsing.+    .+    To use the library import the "Text.XML.PolySoup" module. --- This file has been generated from package.yaml by hpack version 0.31.1.------ see: https://github.com/sol/hpack------ hash: e27b16d88897e222959501e9a60289ec0aeba14c6cfa00570177857baff12b83+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 -name:           polysoup-version:        0.2.2-synopsis:       Online XML parsing with polyparse and tagsoup-description:    Please see the README on GitHub at <https://github.com/kawu/polysoup#readme>-category:       XML-homepage:       https://github.com/kawu/polysoup#readme-bug-reports:    https://github.com/kawu/polysoup/issues-author:         Jakub Waszczuk-maintainer:     waszczuk.kuba@gmail.com-copyright:      2012-2019 IPI PAN, Jakub Waszczuk-license:        BSD3-license-file:   LICENSE-build-type:     Simple-extra-source-files:-    README.md+library+    hs-source-dirs: src -source-repository head-  type: git-  location: https://github.com/kawu/polysoup+    build-depends:+        base            >= 4        && < 5+      , containers      >= 0.4      && < 0.7+      , tagsoup         >= 0.13.4   && < 0.15+      , polyparse       >= 1.9      && < 1.14+      , deepseq         >= 1.3      && < 1.5 -library-  exposed-modules:-      Text.XML.PolySoup-  other-modules:-      Paths_polysoup-  hs-source-dirs:-      src-  build-depends:-      base >=4.7 && <5-    , polyparse >=1.9 && <1.14-    , tagsoup >=0.13 && <0.15-  default-language: Haskell2010+    exposed-modules:+        Text.XML.PolySoup+      , Text.XML.PolySoup.XmlTree+      , Text.XML.PolySoup.Predicate+      , Text.XML.PolySoup.Parser+      , Text.XML.PolySoup.Tag+      , Text.XML.PolySoup.Combine++    ghc-options: -Wall++source-repository head+    type: git+    location: git://github.com/kawu/polysoup.git
src/Text/XML/PolySoup.hs view
@@ -1,404 +1,50 @@ {-# LANGUAGE TupleSections #-} -module Text.XML.PolySoup-(- -- * Types-  XmlParser-, TagParser-, TagPred --- * Tag predicates-, satisfyPred-, true-, getTag-, isTagOpen-, isTagOpenName-, isTagClose-, isTagCloseName-, isTagText-, isTagComment-, tagOpenName-, tagText-, tag-, hasAttr-, getAttr-, maybeAttr+-- | The module re-exports individual submodules of the library. --- * 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+module Text.XML.PolySoup+( module Text.XML.PolySoup.XmlTree+-- $xmltree+, module Text.XML.PolySoup.Predicate+-- $predicate+, module Text.XML.PolySoup.Parser+-- $parser+, module Text.XML.PolySoup.Tag+-- $tag+, module Text.XML.PolySoup.Combine+-- $combine ) 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)---- | Test if the tag is a text node.-isTagComment :: TagPred s ()-isTagComment =-    let isComm (Tag.TagComment {}) = True; isComm _ = False-    in  TagPred (fromBool . isComm)---- | 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 <^+import            Text.XML.PolySoup.XmlTree+import            Text.XML.PolySoup.Predicate+import            Text.XML.PolySoup.Parser+import            Text.XML.PolySoup.Tag+import            Text.XML.PolySoup.Combine  --- | 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+{- $xmltree+Defines XML tree and provides XML parsing and printing utilities, which can+be used to transform between a tagsoup representation of an XML and its tree+representation. -} -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])+{- $predicate+Defines a generic predicate type, which is subsequently used to implement a+simple XML tag parser and an XML tree parser. -} --- | Return the underlying text element.-textTag :: XmlParser s (Tag.Tag s)-textTag = fst <$> satisfyPred ((,) <$> getTag <*> isTagText)+{- $parser+Defines a generic parser which can be used, in particular, to parse XML+forests.  The main characteristic of the parser is that it can be used in+a sequential (sub-trees are processed in order) and a selective (subtrees+are process regardless of their position) way. -} --- | Retrieve tags related to a collection of XML elements.-collTags :: Eq s => XmlParser s [Tag.Tag s]-collTags = concat <$> many elemTags+{- $tag+Provides basic tag-level predicates. -} --- | Escape XML string.-escapeXml :: StringLike str => str -> str-escapeXml = Tag.escapeHTML+{- $combine+Provides many parsing combinators.  In particular, it provides a family+of combinators which can be used for simple traversals of an XML tree.+Different kinds of combinators can be interleaved to construct a+composite parser. -}
+ src/Text/XML/PolySoup/Combine.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE TupleSections #-}+++-- | The module provides some common XML tree parsing combinators.+-- There are two main groups of combinators: XPath-like combinators+-- and tag/forest combinators.  Use combinators from the first group+-- if possible, since they are generally easier too use and generate+-- results in a lazy manner.+--+-- The second class contains more powerful combinators which can be used+-- to parse the contents of an XML node in a generic way.  Note, that+-- combinators from the two groups can be interleaved -- you can use+-- a forest parser to construct a tree predicate, but you can also use+-- a tree predicate as an elementary forest parser (see the+-- "Text.XML.PolySoup.Parser" module).+++module Text.XML.PolySoup.Combine+(+-- * Predicate conversion+  node++-- * XPath-like combinators+, (>/>)+, (</>)+, (/>)+, (//>)++-- * Tag/forest parsing combinators+, join+, joinP+, joinL+, joinR+, (>^>)+, (<^>)+, (^>)+, (<^)+) where+++import           Control.Applicative+import           Data.Tree+import           Text.HTML.TagSoup (Tag)++import           Text.XML.PolySoup.XmlTree+import           Text.XML.PolySoup.Predicate+import           Text.XML.PolySoup.Parser+++---------------------------------------------------------------------+-- Predicate conversion+---------------------------------------------------------------------+++-- TODO: Consider using the Query typeclass and add the comment+-- below to the `node` function.+-- Note, that in most cases you won't need this function, you+-- can make use of the `Query` typeclass.++-- | Make a tree-level predicate from a tag-level predicate.+node :: Q (Tag s) a -> Q (XmlTree s) a+node (Q p) = Q $ \(Node t _) -> p t+++---------------------------------------------------------------------+-- XPath+---------------------------------------------------------------------+++-- | Combine a tag predicate with an XML predicate.  The XML predicate can+-- depend on the value of tag parser and will be called multiple times for+-- tag children elements.+(>/>) :: Q (Tag s) a -> (a -> Q (XmlTree s) b) -> Q (XmlTree s) [b]+(>/>) (Q p) q = Q $ \(Node t ts) -> case p t of+    Just v  ->+        let q' = q v+        in  Just [w | Just w <- runQ q' <$> ts]+    Nothing -> Nothing+infixr 2 >/>+++-- | Combine the tag parser with the XML parser.  The XML parser will+-- be called multiple times for tag children elements.+(</>) :: Q (Tag s) a -> Q (XmlTree s) b -> Q (XmlTree s) (a, [b])+(</>) (Q p) q = Q $ \(Node t ts) -> case p t of+    Just v  -> Just (v, [w | Just w <- runQ q <$> ts])+    Nothing -> Nothing+infixr 2 </>+++-- | Combine the tag parser with the XML parser.  The XML parser will+-- be called multiple times for tag children elements.+(/>) :: Q (Tag s) a -> Q (XmlTree s) b -> Q (XmlTree s) [b]+(/>) p q = p >/> const q+infixr 2 />+++-- | Similar to '/>' combinator but runs the XML parser for all+-- descendant XML elements, not only for its children.+(//>) :: Q (Tag s) a -> Q (XmlTree s) b -> Q (XmlTree s) [b]+(//>) (Q p) q = Q $ \(Node t ts) -> case p t of+    Just _  -> Just $ concatMap g ts+    Nothing -> Nothing+  where+    g t = case runQ q t of+        Nothing -> unJust $ runQ (true //> q) t+        Just w  -> [w]+infixr 2 //>+++---------------------------------------------------------------------+-- Tree predicate `combine` forest parser+---------------------------------------------------------------------+++-- | Combine the tag predicate with the forest parser which will be used+-- to parse contents of the tag element.+join :: Q (Tag s) a -> (a -> P (XmlTree s) b) -> Q (XmlTree s) b+join (Q p) q = Q $ \(Node t ts) -> flip evalP ts . q =<< p t+++-- | Combine the tag predicate with the forest parser which will be used+-- to parse contents of the tag element.+joinP :: Q (Tag s) a -> P (XmlTree s) b -> Q (XmlTree s) (a, b)+joinP p q = join p $ \x -> (x,) <$> q+++-- | Combine the tag predicate with the orest parser which will be used+-- to parse contents of the tag element.  Only results of the forest parser+-- will be returned.+joinR :: Q (Tag s) a -> P (XmlTree s) b -> Q (XmlTree s) b+joinR p q = snd <$> joinP p q+++-- | Combine the tag predicate with the orest parser which will be used+-- to parse contents of the tag element.  Only results of the tag predicate+-- will be returned (the contents have to be successfully parsed, though).+joinL :: Q (Tag s) a -> P (XmlTree s) b -> Q (XmlTree s) a+joinL p q = fst <$> joinP p q+++-- | Infix version of the join combinators.+(>^>) :: Q (Tag s) a -> (a -> P (XmlTree s) b) -> Q (XmlTree s) b+(>^>) = join+infixr 2 >^>+++-- | Infix version of the joinP combinators.+(<^>) :: Q (Tag s) a -> P (XmlTree s) b -> Q (XmlTree s) (a, b)+(<^>) = joinP+infixr 2 <^>+++-- | Infix version of the joinR combinators.+(^>) :: Q (Tag s) a -> P (XmlTree s) b -> Q (XmlTree s) b+(^>) = joinR+infixr 2 ^>+++-- | Infix version of the joinL combinators.+(<^) :: Q (Tag s) a -> P (XmlTree s) b -> Q (XmlTree s) a+(<^) = joinL+infixr 2 <^+++---------------------------------------------------------------------+-- Misc+---------------------------------------------------------------------+++unJust :: Maybe [a] -> [a]+unJust (Just xs) = xs+unJust Nothing   = []
+ src/Text/XML/PolySoup/Parser.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE TupleSections #-}+++-- | The module defines a generic parser which can be used, in particular,+-- to parse XML forests.  The main characteristic of the parser is that it+-- can be used in a sequential (sub-trees are processed in order) and a+-- selective (subtrees are process regardless of their position) way.+++module Text.XML.PolySoup.Parser+(+-- * Core+  P (..)+, evalP++-- * Parsing+-- ** Selective+-- , find+, first+, every+, every'+-- ** Sequential+, pop+-- ** Peek+, peek+, spy+-- ** Utilities+, many_+) where+++import           Control.Applicative+import qualified Control.Arrow as Arr+import           Data.Maybe (catMaybes)++import           Text.XML.PolySoup.Predicate+++-- | An XML forest parser.+newtype P a b = P { runP :: [a] -> Maybe (b, [a]) }++instance Functor (P a) where+    fmap f (P p) = P $ fmap (fmap $ Arr.first f) p++instance Applicative (P a) where+    pure x = P $ Just . (x,)+    P p <*> P q = P $ \t0 -> do+        (f, t1) <- p t0+        (x, t2) <- q t1  +        return (f x, t2)++instance Alternative (P a) where+    empty = P $ \_ -> Nothing+    P p <|> P q = P $ \t -> p t <|> q t++instance Monad (P a) where+    return = pure+    P p >>= f = P $ \t0 -> do+        (x, t1) <- p t0+        runP (f x) t1+++-- | Evaluate parser on the given XML forest.+evalP :: P a b -> [a] -> Maybe b+evalP p = fmap fst . runP p+++---------------------------------------------------------------------+-- Selective parsers+---------------------------------------------------------------------+++-- -- | A synonym to `first`.+-- find :: Q a b -> P a b+-- find = first+++-- | Find the first tree satisfying the given predicate.+first :: Q a b -> P a b+first (Q p) = P $ go [] where+    go acc (t:ts) = case p t of+        Just v  -> Just (v, reverse acc ++ ts)+        Nothing -> go (t:acc) ts+    go _ [] = Nothing+++-- | Select every tree satisfying the given predicate.+every :: Q a b -> P a [b]+every (Q p) =+    P $ prep . foldl upd ([], [])+  where+    prep (x, y) = Just (reverse x, reverse y)+    upd (vs, acc) t = case p t of+        Just v  -> (v:vs, acc)+        Nothing -> (vs, t:acc)+++-- | A lazy version of `every` which "forgets" non-matching subtrees+-- along the way.+every' :: Q a b -> P a [b]+every' (Q p) =+    let prep xs = Just (xs, [])+    in  P $ prep . catMaybes . map p+++---------------------------------------------------------------------+-- Sequential parsers+---------------------------------------------------------------------+++-- | Check, if the first tree satisfies the given predicate.+pop :: Q a b -> P a b+pop (Q p) = P $ \tts -> case tts of+    (t:ts)  -> (,ts) <$> p t+    []      -> Nothing+++---------------------------------------------------------------------+-- Peek+---------------------------------------------------------------------+++-- | Like `pop`, but doesn't consume the tree.+peek :: Q a b -> P a b+peek (Q p) = P $ \tts -> case tts of+    (t:_)   -> (,tts) <$> p t+    []      -> Nothing+++-- | Like `first`, but doesn't consume the tree.+spy :: Q a b -> P a b+spy (Q p) = P $ \tts ->+    let go (t:ts) = case p t of+            Just v  -> Just (v, tts)+            Nothing -> go ts+        go [] = Nothing+    in  go tts+++---------------------------------------------------------------------+-- Utilities+---------------------------------------------------------------------+++-- | 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
+ src/Text/XML/PolySoup/Predicate.hs view
@@ -0,0 +1,55 @@+-- | A generic extracting predicate.+++module Text.XML.PolySoup.Predicate+( Q (..)+, true+, satisfy+) where+++import           Control.Applicative+++-- | A predicate checks if the given element satisfies some properties+-- and extracts its attribute values.  You can compose predicates using+-- Functor, Applicative and Alternative operators: '*>', '<*', '<|>' etc.+-- Note, that it doesn't really have sense to use function like `many`+-- or `some`, since the extracting predicate doesn't consume any input.+newtype Q a b = Q { runQ :: (a -> Maybe b) }++instance Functor (Q a) where+    fmap f (Q g) = Q $ fmap (fmap f) g++instance Applicative (Q a) where  +    pure = Q . const . Just+    Q f <*> Q p = Q $ \x -> f x <*> p x++instance Alternative (Q a) where+    empty = Q $ \_ -> Nothing+    Q p <|> Q p' = Q $ \x -> p x <|> p' x++-- Is there really sense in defining the Monad instance here?+-- Order of operations doesn't mean anything here, I suppose?+-- Well, it has influence on when the extraction stops when+-- one of the predicates is not satisfied. +--+-- On the other hand, it may be better if it's obvious that a+-- monadic code means parsing here.+-- instance Monad (Q a) where+--     return = pure+--     Q p >>= f = Q $ \x -> do+--         y <- p x+--         runQ (f y) x+++-- | Predicate which is always satisfied.+true :: Q a a+true = Q Just+++-- | Check if the given predicate is satisfied.+satisfy :: (a -> Bool) -> Q a a+satisfy p = Q $ \t -> if p t+    then Just t+    else Nothing
+ src/Text/XML/PolySoup/Tag.hs view
@@ -0,0 +1,160 @@+-- | The module provides tag-level predicates.+++module Text.XML.PolySoup.Tag+(+-- * Tag queries+  getName+, getText+, getAttr+, getAtts++-- * Extraction predicates+, name+, text+, attr+, atts++-- * Tag predicates+, innerTag+, leafTag+, textTag+, commentTag+, warningTag+, positionTag+, named+, hasAttr+, hasAttrVal+) where+++import           Prelude hiding (any)+import           Control.Monad ((<=<))+import           Data.Maybe (isJust)+import           Text.HTML.TagSoup++import           Text.XML.PolySoup.Predicate+++---------------------------------------------------------------------+-- Tag queries+---------------------------------------------------------------------+++-- | Get name of the tag.+getName :: Tag s -> Maybe s+getName t = case t of+    TagOpen x _     -> Just x+    TagClose x      -> Just x+    TagText x       -> Just x+    TagComment x    -> Just x+    TagWarning x    -> Just x+    TagPosition _ _ -> Nothing+++-- | Get contents of the text node.+-- A synonym for `maybeTagText`.+getText :: Tag s -> Maybe s+getText = maybeTagText+++-- | Get the list of the attributes.+getAtts :: Tag s -> Maybe [(s, s)]+getAtts (TagOpen _ x)   = Just x+getAtts _               = Nothing+++-- | Get value of the attribute.+getAttr :: Eq s => s -> Tag s -> Maybe s+getAttr x = lookup x <=< getAtts+++---------------------------------------------------------------------+-- Core predicates+---------------------------------------------------------------------+++-- | Internal node (i.e., an opening tag).+innerTag :: Q (Tag s) (Tag s)+innerTag = satisfy isTagOpen+++-- | Leaf node (everything but an opening tag).+leafTag :: Q (Tag s) (Tag s)+leafTag = satisfy $ not . isTagOpen+++-- | A text node.+textTag :: Q (Tag s) (Tag s)+textTag = satisfy isTagText+++-- | A comment node.+commentTag :: Q (Tag s) (Tag s)+commentTag = satisfy isTagComment+++-- | A warning node.+warningTag :: Q (Tag s) (Tag s)+warningTag = satisfy isTagWarning+++-- | A position node.+positionTag :: Q (Tag s) (Tag s)+positionTag = satisfy isTagPosition+++-- | Does it have a given name?+named :: Eq s => s -> Q (Tag s) (Tag s)+named x = satisfy $ justSatisfy (==x) . getName+++-- | Does it have a given attribute?+hasAttr :: Eq s => s -> Q (Tag s) (Tag s)+hasAttr x = satisfy $ isJust . getAttr x+++-- | Does it have a given attribute with a given value?+hasAttrVal :: Eq s => s -> s -> Q (Tag s) (Tag s)+hasAttrVal x y = satisfy $ justSatisfy (==y) . getAttr x+++---------------------------------------------------------------------+-- Convenience predicates+---------------------------------------------------------------------+++-- | Extract the tag name.+name :: Q (Tag s) s+name = Q getName+++-- | Extract textual contents of the text node.+text :: Q (Tag s) s+text = Q getText+++-- | Extract the attribute value.+attr :: Eq s => s -> Q (Tag s) s+attr = Q . getAttr+++-- | Extract the attribute value.+atts :: Q (Tag s) [(s, s)]+atts = Q getAtts+++---------------------------------------------------------------------+-- Misc+---------------------------------------------------------------------+++-- | Is it a `Just` value and does it satisfy the given property?+justSatisfy :: (a -> Bool) -> Maybe a -> Bool+justSatisfy = maybe False+++-- -- | Test if a tag is a comment.+-- isTagComment :: Tag s -> Bool+-- isTagComment (TagComment _) = True+-- isTagComment _ = False
+ src/Text/XML/PolySoup/XmlTree.hs view
@@ -0,0 +1,129 @@+-- | XML as a tree of XML tags. +--+-- The module provides an `XmlTree` data type, which can be used to represent+-- a parsed XML file.  The `XmlTree` structure can be generated lazily by using+-- the `parseTree` (or `parseForest`) function on any string-like input+-- supported by the tagsoup library.+--+-- Note, that the parsing functions do not validate correctness of the input+-- XML data.+++module Text.XML.PolySoup.XmlTree+(+-- * XML Tree+  XmlTree+, XmlForest+-- ** Parsing+, parseTree+, parseForest+-- ** Rendering+, renderTree+, renderForest+) where+++import           Control.DeepSeq (NFData, deepseq)+import           Data.Tree+import           Text.StringLike+import qualified Text.HTML.TagSoup as S+import           Text.ParserCombinators.Poly.Lazy+++---------------------------------------------------------------------+-- Types+---------------------------------------------------------------------+++-- | A lazy XML parser.+type XmlParser s a = Parser (S.Tag s) a+++-- | A parsed XML tree.  Closing tags are not preserved.+type XmlTree s = Tree (S.Tag s)++-- data XmlTree s = Node+--     { rootLabel :: S.Tag s+--     , subForest :: Forest a }+--     deriving (Show, Eq, Ord)+++-- | A parsed XML forest.  Closing tags are not preserved.+type XmlForest s = [XmlTree s]+++---------------------------------------------------------------------+-- Parsing XML+---------------------------------------------------------------------+++-- | Parse XML tree from a list of tags.+parseTree :: (NFData s, StringLike s) => [S.Tag s] -> XmlTree s+parseTree = fst . runParser xmlTreeP+++-- | Parse XML forest from a list of tags.  Note, that if the XML file+-- has additional headers, the `parseForest` function has to be used to+-- parse it correctly.+parseForest :: (NFData s, StringLike s) => [S.Tag s] -> XmlForest s+parseForest = fst . runParser (many xmlTreeP)+++-- | A parser from tags to an XML tree.+xmlTreeP :: (NFData s, StringLike s) => XmlParser s (XmlTree s)+xmlTreeP = leafP <|> nodeP+-- xmlTreeP = nodeP <|> leafP+++-- | Internal node parser.+nodeP :: (NFData s, StringLike s) => XmlParser s (XmlTree s)+nodeP = do+    x <- satisfy S.isTagOpen+    x `tagOpenSeq` Node x <$> many xmlTreeP+        <* satisfy (S.isTagCloseName $ tagName x)+  where+    tagName (S.TagOpen x _) = x+    tagName _ = error "tagName: not an open tag"+    -- Without `deepseq` even the simple `renderForest . parseForest` leads+    -- to a memory leak.  Tested multiple times w.r.t. tagsoup-0.13.1.+    tagOpenSeq (S.TagOpen x xs) = deepseq (x, xs)+    tagOpenSeq _ = id+++-- | Leaf node parser.+leafP :: (NFData s, StringLike s) => XmlParser s (XmlTree s)+leafP = fmap+    (flip Node [])+--     (satisfy $ \x -> not (S.isTagOpen x || S.isTagClose x))+    (satisfy $ \x -> not (isTagOpen x || S.isTagClose x))+  where+    isTagOpen (S.TagOpen xs _) = case uncons xs of+        -- Headers (e.g. <?xml ...> and <!CDATA ...>) do not have+        -- corresponding closing tags, therefore have to be treated+        -- as leaves.+        Just (x, _) -> x /= '!' && x /= '?'+        Nothing     -> True+    isTagOpen _ = False+    ++---------------------------------------------------------------------+-- Rendering XML+---------------------------------------------------------------------+++-- | Render XML tree tags.+renderTree :: XmlTree s -> [S.Tag s]+renderTree (Node v xs) = if S.isTagOpen v+    then v : renderForest xs ++ [endFrom v]+    else [v]+++-- | Render XML forest tags.+renderForest :: XmlForest s -> [S.Tag s]+renderForest = concatMap renderTree+++-- | Make closing tag from the opening tag.+endFrom :: S.Tag s -> S.Tag s+endFrom (S.TagOpen x _) = S.TagClose x+endFrom _               = error "endFrom: not an opening tag"