tagsoup-selection (empty) → 0.1.0.0
raw patch · 11 files changed
+993/−0 lines, 11 filesdep +basedep +containersdep +parsecsetup-changed
Dependencies added: base, containers, parsec, tagsoup
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- src/Text/CSS3/Selectors/Parser.hs +278/−0
- src/Text/CSS3/Selectors/Syntax.hs +115/−0
- src/Text/HTML/TagSoup/Selection.hs +20/−0
- src/Text/HTML/TagSoup/Tree/Selection.hs +132/−0
- src/Text/HTML/TagSoup/Tree/Util.hs +170/−0
- src/Text/HTML/TagSoup/Tree/Zipper.hs +146/−0
- src/Text/StringLike/Matchable.hs +54/−0
- tagsoup-selection.cabal +41/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changes++## 0.1.0.0++Initial version
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2016, Siracusa++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.++ * Neither the name of Siracusa nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++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.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Text/CSS3/Selectors/Parser.hs view
@@ -0,0 +1,278 @@+{- |+ Parser functions for CSS3 selectors.+-}+module Text.CSS3.Selectors.Parser (+ -- * Parsing Functions+ parseSelectorGroup,+ parseSelector,+ sel,++ -- * CSS Selector Parsers+ selectorGroup,+ selector,+ simpleSelectorSequence,+ headSimpleSelector,+ tailSimpleSelector,+ attributeSelector,+ attributeOperator,+ combinator,+ pseudoClass,+ pseudoClassParameter,++ -- * Lexical Syntax Parsers+ whitespace,+ identifier,+ name,+ nameStartLetter,+ nameCharLetter+) where+++import Control.Applicative+import Control.Monad++import Data.Char+import Data.Maybe++import Numeric++import Text.CSS3.Selectors.Syntax+import Text.Parsec hiding ((<|>), optional, newline, many, Empty)+import qualified Text.Parsec as Parsec ((<|>), optional, newline, many)+import Text.Parsec.String+++{-+ * http://www.w3.org/TR/selectors/+ * http://www.w3.org/TR/css-syntax-3/+-}++{-+Selector ::= SimpleSelectorSequence [PseudoElement]+ | SimpleSelectorSequence Combinator Selector+SimpleSelectorSequence ::= (TypeSelector | UniversalSelector)+ (AttributeSelector | ClassSelector | IDSelector | PseudoClass)*+ | (AttributeSelector | ClassSelector | IDSelector | PseudoClass)++SimpleSelector ::= (TypeSelector | UniversalSelector | AttributeSelector | ClassSelector | IDSelector | PseudoClass)+Combinator ::= [WhiteSpace] (' ' | '>' | '+' | '~') [WhiteSpace]+WhiteSpace ::= ' ' | '\t' | '\n' | '\r' | '\f'+Group ::= Selector | Selector [WhiteSpace] ',' [WhiteSpace] Group++TypeSelector ::= identifier+UniversalSelector ::= '*'+AttributeSelector ::= '[' Attribute ']'+ | '[' Attribute AttributeOperator AttributeValue ']'+Attribute ::= identifier | String+AttributeOperator ::= '=' | '~=' | '|=' | '^=' | '$=' | '*='++IDSelector ::= '#' identifier+ClassSelector ::= '.' AttributeValue+PseudoClass ::= ':' (StructuralPseudoClass | 'not(' SimpleSelector ')')+StructuralPseudoClass ::= 'root'+ | 'nth-child' PseudoClassParameter+ | 'nth-last-child' PseudoClassParameter+ | 'nth-of-type' PseudoClassParameter+ | 'nth-last-of-type' PseudoClassParameter+ | 'first-child'+ | 'last-child'+ | 'first-of-type'+ | 'last-of-type'+ | 'only-child'+ | 'only-of-type'+ | 'empty'+-}+++-- * Parsing Functions++-- | Tries to parse a selector group.+parseSelectorGroup :: String -> Either ParseError SelectorGroup+parseSelectorGroup = parse (selectorGroup <* eof) ""++-- | Tries to parse a single selector.+parseSelector :: String -> Either ParseError Selector+parseSelector = parse (selector <* eof) ""+++-- | Parses a single selector and fails with an error if the string cannot be parsed correctly.+-- This function is intended for testing purposes only.+sel :: String -> Selector+sel = either (error . show) id . parse (selector <* eof) ""+++-- * CSS Selector Parsers++selectorGroup :: Parser SelectorGroup+selectorGroup = SelectorGroup <$> selector+ <*> many (many whitespace *> char ',' *> many whitespace *> selector)+++selector :: Parser Selector+selector = Selector <$> simpleSelectorSequence+ <*> optional (try $ (,) <$> combinator <*> selector)+++simpleSelectorSequence :: Parser SimpleSelectorSequence+simpleSelectorSequence = SimpleSelectorSequence <$> headSimpleSelector <*> many tailSimpleSelector+ <|> SimpleSelectorSequence UniversalSelector <$> many1 tailSimpleSelector+++headSimpleSelector :: Parser HeadSimpleSelector+headSimpleSelector = TypeSelector <$> identifier+ <|> UniversalSelector <$ char '*'+++tailSimpleSelector :: Parser TailSimpleSelector+tailSimpleSelector = attributeSelector+ <|> ClassSelector <$> (char '.' *> identifier)+ <|> IDSelector <$> (char '#' *> name)+ <|> PseudoClass <$> (char ':' *> pseudoClass)++attributeSelector :: Parser TailSimpleSelector+attributeSelector = AttributeSelector+ <$> (char '[' *> many whitespace *> identifier <* many whitespace)+ <*> optional ((,) <$> attributeOperator <* many whitespace+ <*> (identifier <|> quotedString) <* many whitespace)+ <* char ']'++attributeOperator :: Parser AttributeOperator+attributeOperator = ExactMatch <$ string "="+ <|> IncludesMatch <$ string "~="+ <|> DashMatch <$ string "|="+ <|> PrefixMatch <$ string "^="+ <|> SuffixMatch <$ string "$="+ <|> InfixMatch <$ string "*="+++combinator :: Parser Combinator+combinator = try (Child <$ (many whitespace *> char '>' <* many whitespace))+ <|> try (AdjacentSibling <$ (many whitespace *> char '+' <* many whitespace))+ <|> try (GeneralSibling <$ (many whitespace *> char '~' <* many whitespace))+ <|> Descendant <$ many1 whitespace+++pseudoClass :: Parser PseudoClass+pseudoClass = Root <$ try (string "root")+ <|> NthChild <$> (try (string "nth-child") *> parameter pseudoClassParameter)+ <|> NthLastChild <$> (try (string "nth-last-child") *> parameter pseudoClassParameter)+ <|> NthOfType <$> (try (string "nth-of-type") *> parameter pseudoClassParameter)+ <|> NthLastOfType <$> (try (string "nth-last-of-type") *> parameter pseudoClassParameter)+ <|> FirstChild <$ try (string "first-child")+ <|> LastChild <$ try (string "last-child")+ <|> FirstOfType <$ try (string "first-of-type")+ <|> LastOfType <$ try (string "last-of-type")+ <|> OnlyChild <$ try (string "only-child")+ <|> OnlyOfType <$ try (string "only-of-type")+ <|> Empty <$ try (string "empty")+ <|> Not <$> (try kwNot *> parameter (Left <$> headSimpleSelector+ <|> Right <$> tailSimpleSelector))+ where parameter p = char '(' *> many whitespace *> p <* many whitespace <* char ')'++{-+nth : S* [ ['-'|'+']? INTEGER? {N} [ S* ['-'|'+'] S* INTEGER ]?+ | ['-'|'+']? INTEGER+ | {O}{D}{D}+ | {E}{V}{E}{N} ] S*+-}+pseudoClassParameter :: Parser PseudoClassParameter+pseudoClassParameter = PseudoClassParameter <$> (try $ option id sign <*> option 1 integer <* oneOf "nN")+ <*> (option 0 $ many whitespace *> sign <* many whitespace <*> integer)+ <|> PseudoClassParameter 0 <$> (option id sign <*> integer)+ <|> PseudoClassParameter 2 1 <$ kwOdd+ <|> PseudoClassParameter 2 0 <$ kwEven++++-- * Lexical Syntax Parsers+-- According to <https://www.w3.org/TR/css3-selectors/#w3cselgrammar>++sign :: Parser (Integer -> Integer)+sign = negate <$ char '-' <|> id <$ char '+'++-- integer = [0-9]++integer :: Parser Integer+integer = foldl (\a c -> 10*a + toInteger (ord c) - 48) 0 <$> many1 digit++-- num [0-9]+|[0-9]*\.[0-9]++++-- identifier = [-]?{nameStartLetter}{nameCharLetter}*+identifier :: Parser String+identifier = (\d c cs -> (maybe id (:) d) $ c : cs)+ <$> optional (char '-') <*> nameStartLetter <*> many nameCharLetter++-- name = {nameCharLetter}++name :: Parser String+name = many1 nameCharLetter++-- nameStartLetter = [_a-z]|{nonAsciiLetter}|{escapedLetter}+nameStartLetter :: Parser Char+nameStartLetter = asciiLetter <|> char '_' <|> nonAsciiLetter <|> escapedLetter++-- nameCharLetter = [_a-z0-9-]|{nonAsciiLetter}|{escapedLetter}+nameCharLetter :: Parser Char+nameCharLetter = char '_' <|> asciiLetter <|> digit <|> char '-' <|> nonAsciiLetter <|> escapedLetter++-- asciiLatter = [_a-z]+asciiLetter :: Parser Char+asciiLetter = satisfy $ \c -> c >= 'a' && c <= 'z' || c >='A' && c <= 'Z'++-- nonAsciiLetter = [\240-\377] -- CSS 2.1+-- nonAsciiLetter = [^\0-\177] -- CSS 3+nonAsciiLetter :: Parser Char+nonAsciiLetter = satisfy (\c -> ord c > 127)++-- unicodeLetter = \\[0-9a-f]{1,6}(\r\n|[ \n\r\t\f])?+unicodeLetter :: Parser Char+unicodeLetter = char '\\' *> (chr . fst . head . readHex <$> countFromTo 1 6 (satisfy isHexDigit))+ <* optional (try (string "\r\n") <|> pure <$> whitespace)++-- escapedLetter = {unicode}|\\[^\n\r\f0-9a-f]+escapedLetter :: Parser Char+escapedLetter = try unicodeLetter+ <|> char '\\' *> satisfy (\c -> not (isHexDigit c) && c `notElem` "\n\r\f")+++{-+quotedString = {string1}|{string2}+string1 = \"([^\n\r\f\\"]|\\{newline}|{nonAsciiLetter}|{escapedLetter})*\"+string2 = \'([^\n\r\f\\']|\\{newline}|{nonAsciiLetter}|{escapedLetter})*\'+-}+quotedString :: Parser String+quotedString = char '\"' *> (concat <$> many (stringChar '\"')) <* char '\"'+ <|> char '\'' *> (concat <$> many (stringChar '\'')) <* char '\''+ where+ stringChar :: Char -> Parser String+ stringChar delim = pure <$> satisfy (`notElem` (delim : "\n\r\f\\"))+ <|> try (char '\\' *> newline)+-- <|> pure <$> nonAsciiLetter -- Can this ever be reached?+ <|> pure <$> escapedLetter++-- newline = \n|\r\n|\r|\f+newline :: Parser String+newline = try (string "\r\n") <|> pure <$> oneOf "\n\r\f"++-- whitespace = [ \t\r\n\f]*+whitespace :: Parser Char+whitespace = oneOf " \t\n\r\f"++{-+D d|\\0{0,4}(44|64)(\r\n|[ \t\r\n\f])?+E e|\\0{0,4}(45|65)(\r\n|[ \t\r\n\f])?+N n|\\0{0,4}(4e|6e)(\r\n|[ \t\r\n\f])?|\\n+O o|\\0{0,4}(4f|6f)(\r\n|[ \t\r\n\f])?|\\o+T t|\\0{0,4}(54|74)(\r\n|[ \t\r\n\f])?|\\t+V v|\\0{0,4}(58|78)(\r\n|[ \t\r\n\f])?|\\v+-}+kwNot, kwOdd, kwEven :: Parser String+kwNot = sequence [oneOf "nN", oneOf "oO", oneOf "tT"]+kwOdd = sequence [oneOf "oO", oneOf "dD", oneOf "dD"]+kwEven = sequence [oneOf "eE", oneOf "vV", oneOf "eE", oneOf "nN"]+++-- * Utility Parsers++countFromTo :: Stream s m t => Int -> Int -> ParsecT s u m a -> ParsecT s u m [a]+countFromTo n m p+ | m < n = pure []+ | otherwise = (++) <$> count n p <*> (catMaybes <$> replicateM (m - n) (optional p))
+ src/Text/CSS3/Selectors/Syntax.hs view
@@ -0,0 +1,115 @@+{- |+ Syntax of CSS3 selectors.+-}+module Text.CSS3.Selectors.Syntax (+ SelectorGroup (..),+ Selector (..),++ SimpleSelectorSequence (..),+ HeadSimpleSelector (..),+ TailSimpleSelector (..),+ Combinator (..),+ AttributeOperator (..),+ PseudoClass (..),+ PseudoClassParameter (..),++ Specificity (..),+ specificity+) where+++import Data.List++++-- * Syntax of CSS3 Selectors++-- | > sel [, sel ...]+data SelectorGroup = SelectorGroup Selector [Selector]+ deriving (Show, Read, Eq)++data Selector = Selector SimpleSelectorSequence (Maybe (Combinator, Selector))+ deriving (Show, Read, Eq)++data SimpleSelectorSequence = SimpleSelectorSequence HeadSimpleSelector [TailSimpleSelector]+ deriving (Show, Read, Eq)++data HeadSimpleSelector = TypeSelector String -- ^ > type+ | UniversalSelector -- ^ > *+ deriving (Show, Read, Eq)++data TailSimpleSelector = AttributeSelector String (Maybe (AttributeOperator, String))+ -- ^ @[attr]@ or @[attr=value]@+ | ClassSelector String -- ^ > .class+ | IDSelector String -- ^ > #id+ | PseudoClass PseudoClass -- ^ > :pseudo-class+ deriving (Show, Read, Eq)++data Combinator = Descendant -- ^ > E F+ | Child -- ^ > E > F + | AdjacentSibling -- ^ > E + F+ | GeneralSibling -- ^ > E ~ F+ deriving (Show, Read, Eq)++data AttributeOperator = ExactMatch -- ^ > A = V+ | IncludesMatch -- ^ > A ~= V+ | DashMatch -- ^ > A |= V+ | PrefixMatch -- ^ > A ^= V+ | SuffixMatch -- ^ > A $= V+ | InfixMatch -- ^ > A *= V+ deriving (Show, Read, Eq)++data PseudoClass = Root+ | NthChild PseudoClassParameter+ | NthLastChild PseudoClassParameter+ | NthOfType PseudoClassParameter+ | NthLastOfType PseudoClassParameter+ | FirstChild+ | LastChild+ | FirstOfType+ | LastOfType+ | OnlyChild+ | OnlyOfType+ | Empty+ | Not (Either HeadSimpleSelector TailSimpleSelector)+ -- ^ Note: According to the specs, @:not@ pseudo-classes may not be nested.+ -- The syntax doesn't reflect that.+ deriving (Show, Read, Eq)++data PseudoClassParameter = PseudoClassParameter Integer Integer+ deriving (Show, Read, Eq)+++-- * Specificity of Selectors++{- |+ The specificity of a selector with its components decreasing in significance from left to+ right. The components in @Specificity a b c@ denote++ * @a@: the number of ID selectors,++ * @b@: the number of class selectors, attribute selectors and pseudo-classes (not+ counting the @:not@ pseudo-class itself), and++ * @c@: the number of type selectors and pseudo-elements++ as described in <http://www.w3.org/TR/selectors/#specificity>.+-}+data Specificity = Specificity !Int !Int !Int deriving (Show, Read, Eq, Ord)++-- | Returns the specificity for a selector.+specificity :: Selector -> Specificity+specificity (Selector (SimpleSelectorSequence hSel tSels) mbComb) =+ maybe spec ((spec .+) . specificity . snd) mbComb+ where+ spec = foldl1' (.+) $ hSpec hSel : map tSpec tSels+ hSpec h = case h of+ TypeSelector _ -> Specificity 0 0 1+ UniversalSelector -> Specificity 0 0 0+ tSpec t = case t of+ AttributeSelector _ _ -> Specificity 0 1 0+ ClassSelector _ -> Specificity 0 1 0+ IDSelector _ -> Specificity 1 0 0+ PseudoClass (Not eSel) -> either hSpec tSpec eSel+ PseudoClass _ -> Specificity 0 1 0+ (.+) (Specificity a b c) (Specificity a' b' c') = Specificity (a + a') (b + b') (c + c')
+ src/Text/HTML/TagSoup/Selection.hs view
@@ -0,0 +1,20 @@+{- |+ This module re-exports most of the modules and functions for selecting subtrees from+ TagSoup's 'TagTree' type.+-}+module Text.HTML.TagSoup.Selection (+ module Text.CSS3.Selectors.Syntax,+ parseSelectorGroup,+ parseSelector,++ module Text.HTML.TagSoup.Tree.Selection,+ module Text.HTML.TagSoup.Tree.Util,+ module Text.HTML.TagSoup.Tree.Zipper +) where++import Text.CSS3.Selectors.Parser (parseSelectorGroup, parseSelector)+import Text.CSS3.Selectors.Syntax++import Text.HTML.TagSoup.Tree.Selection+import Text.HTML.TagSoup.Tree.Util+import Text.HTML.TagSoup.Tree.Zipper
+ src/Text/HTML/TagSoup/Tree/Selection.hs view
@@ -0,0 +1,132 @@+{- |+ Selecting subtrees from TagSoup 'TagTree's.+-}+module Text.HTML.TagSoup.Tree.Selection (+ selectGroup,+ select,+ selectAll,++ canMatch,++ matchesWith+) where+++import Control.Applicative+import Control.Category ((>>>))++import Data.Maybe++import Text.CSS3.Selectors.Syntax++import Text.HTML.TagSoup+import Text.HTML.TagSoup.Tree+import Text.HTML.TagSoup.Tree.Util+import Text.HTML.TagSoup.Tree.Zipper++import Text.StringLike+import Text.StringLike.Matchable+++{- |+ Traverses a tree, collecting all subtree positions for which at least one matches on the+ given selector group. If at least one subtree matches, a list of the same length as the+ number of selectors in the given selector group is added to the result list. In order,+ a 'Nothing' indicates no match and 'Just' a match for the corresponding selector.+-}+selectGroup :: Matchable str => SelectorGroup -> TagTree str -> [[Maybe (TagTreePos str)]]+selectGroup (SelectorGroup sel sels) = map (\(pos, bs) -> map (\b -> if b then Just pos else Nothing) bs)+ . filter (or . snd) . selectAll (sel : sels)++-- | Traverses a tree, collecting all subtree positions which match on the given selector.+select :: Matchable str => Selector -> TagTree str -> [TagTreePos str]+select sel = map fst . filter (head . snd) . selectAll [sel]++{- |+ Traverses a tree, collecting all traversed positions in order. For each position all+ selectors are tried to be matched with the node at the current position and the information+ about whether a match is possible is added to the result list.+-}+selectAll :: Matchable str => [Selector] -> TagTree str -> [(TagTreePos str, [Bool])]+selectAll sels = traverseTree (\pos -> [(pos, map (`canMatch` pos) sels)]) . fromTagTree++-- | Checks if a selector can be matched with the node at the given position.+canMatch :: Matchable str => Selector -> TagTreePos str -> Bool+canMatch sel = (&&) <$> simpleSelSeqPred s <*> matches ss (map combPosList cs)+ where+ (s : ss, cs) = chain sel++ combPosList :: Combinator -> TagTreePos str -> [TagTreePos str]+ combPosList c = case c of+ Descendant -> iteratePos parent+ Child -> take 1 . iteratePos parent+ AdjacentSibling -> take 1 . iteratePos prevSibling+ GeneralSibling -> iteratePos prevSibling++ matches :: Matchable str => [SimpleSelectorSequence] -> [TagTreePos str -> [TagTreePos str]] -> TagTreePos str -> Bool+ matches ss cfs = foldr (\(s, cf) rest -> any ((&&) <$> simpleSelSeqPred s <*> rest) . cf) (const True) (zip ss cfs)+++chain :: Selector -> ([SimpleSelectorSequence], [Combinator])+chain sel = let (seqs, combs) = chain' sel in (reverse seqs, reverse combs)+ where+ chain' (Selector seq mbComb) = case mbComb of+ Nothing -> (seq : [], [])+ Just (comb, seq') -> let (seqs, combs) = chain' seq'+ in (seq : seqs, comb : combs)+++simpleSelSeqPred :: Matchable str => SimpleSelectorSequence -> TagTreePos str -> Bool+simpleSelSeqPred (SimpleSelectorSequence head tails) = foldr1 (liftA2 (&&)) $ hFilter head : map tFilter tails+ where+ hFilter :: Matchable str => HeadSimpleSelector -> TagTreePos str -> Bool+ hFilter sel = case sel of+ TypeSelector n -> content >>> hasTagBranchName (fromString n)+ UniversalSelector -> content >>> isTagBranch++ tFilter :: Matchable str => TailSimpleSelector -> TagTreePos str -> Bool+ tFilter sel = case sel of+ AttributeSelector a Nothing -> content >>> hasTagBranchAttr (fromString a)+ AttributeSelector a (Just (op, v)) -> content >>> findTagBranchAttr (fromString a)+ >>> maybe False (matchesWith op $ fromString v)+ ClassSelector v -> content >>> findTagBranchAttr (fromString "class")+ >>> maybe False (matchesWith IncludesMatch $ fromString v)+ IDSelector v -> content >>> findTagBranchAttr (fromString "id")+ >>> maybe False (matchesWith ExactMatch $ fromString v)+ PseudoClass p -> pseudo p++ pseudo :: Matchable str => PseudoClass -> TagTreePos str -> Bool+ pseudo p = case p of+ Root -> parents >>> null++ -- pattern: a*n+b; counting starts at one; a==0 => match b-th; n always >= 0; only a*n+b >= 0 count+ NthChild p -> error "simpleSelSeqPred: nth-child not implemented yet"+ NthLastChild p -> error "simpleSelSeqPred: nth-last-child not implemented yet"+ NthOfType p -> error "simpleSelSeqPred: nth-of-type not implemented yet"+ NthLastOfType p -> error "simpleSelSeqPred: nth-last-of-type not implemented yet"++ FirstChild -> (&&) <$> (parents >>> not . null) <*> (before >>> null)+ LastChild -> (&&) <$> (parents >>> not . null) <*> (after >>> null)+ FirstOfType -> \pos -> let name = tagBranchName $ content pos+ in (&&) <$> (parents >>> not . null)+ <*> (before >>> all (not . hasTagBranchName name)) $ pos+ LastOfType -> \pos -> let name = tagBranchName $ content pos+ in (&&) <$> (parents >>> not . null)+ <*> (after >>> all (not . hasTagBranchName name)) $ pos+ OnlyChild -> (&&) <$> pseudo FirstChild <*> pseudo LastChild+ OnlyOfType -> (&&) <$> pseudo FirstOfType <*> pseudo LastOfType+ Empty -> content >>> children >>> null+ Not (Right (PseudoClass (Not _))) -> error "simpleSelSeqPred: nested :not pseudo classes"+ Not (Left sel) -> not . hFilter sel+ Not (Right sel) -> not . tFilter sel+++-- | Checks if two string-like values match under the given attribute operator.+matchesWith :: Matchable str => AttributeOperator -> str -> str -> Bool+matchesWith op = case op of+ ExactMatch -> matchesExactly+ IncludesMatch -> matchesWordOf+ DashMatch -> \v s -> v `matchesExactly` s || (v `append` fromChar '-') `matchesPrefixOf` s+ PrefixMatch -> matchesPrefixOf+ SuffixMatch -> matchesSuffixOf+ InfixMatch -> matchesInfixOf
+ src/Text/HTML/TagSoup/Tree/Util.hs view
@@ -0,0 +1,170 @@+{- |+ Utility functions for TagSoup's 'TagTree'.+-}+module Text.HTML.TagSoup.Tree.Util (+ children,+ descendants,++ withTagTree,+ isTagBranch,+ isTagLeaf,++ tagBranchName,+ tagBranchAttrs,+ tagBranchTrees,++ fromTagLeaf,++ maybeTagBranchName,+ maybeTagBranchAttrs,+ maybeTagBranchTrees,+ maybeTagLeafTag,++ hasTagBranchName,+ hasTagBranchAttr,+ findTagBranchAttr,++ tagTree',+ htmlRoot+) where+++import Control.Applicative++import Data.Char+import Data.Maybe+import Data.List++import Text.HTML.TagSoup+import Text.HTML.TagSoup.Tree++import Text.StringLike++++-- | Returns all immediate children of a 'TagTree'.+children :: TagTree str -> [TagTree str]+children t = case t of+ TagBranch _ _ ts -> ts+ TagLeaf _ -> []++-- | Returns all immediate children, the children of these children etc. for a 'TagTree'.+descendants :: TagTree str -> [TagTree str]+descendants t = case t of+ TagBranch _ _ ts -> concatMap (\t -> t : descendants t) ts+ TagLeaf _ -> []+++-- | Case analysis for 'TagTree' values.+withTagTree :: (str -> [Attribute str] -> [TagTree str] -> a) -> (Tag str -> a) -> TagTree str -> a+withTagTree fBr fLf t = case t of+ TagBranch n as ts -> fBr n as ts+ TagLeaf t -> fLf t++-- | Checks if the given tree is a 'TagBranch'.+isTagBranch :: TagTree str -> Bool+isTagBranch = withTagTree (\_ _ _ -> True) (const False)++-- | Checks if the given tree is a 'TagLeaf'.+isTagLeaf :: TagTree str -> Bool+isTagLeaf = withTagTree (\_ _ _ -> False) (const True)+++-- | Returns the element name of a 'TagBranch', or an error if the tree is a 'TagLeaf'.+tagBranchName :: TagTree str -> str+tagBranchName t = case t of+ TagBranch n _ _ -> n+ TagLeaf _ -> error "tagBranchName: TagLeaf"++-- | Returns the attribute list of a 'TagBranch', or an error if the tree is a 'TagLeaf'.+tagBranchAttrs :: TagTree str -> [Attribute str]+tagBranchAttrs t = case t of+ TagBranch _ as _ -> as+ TagLeaf _ -> error "tagBranchAttrs: TagLeaf"++-- | Returns the subtrees of a 'TagBranch', or an error if the tree is a 'TagLeaf'.+tagBranchTrees :: TagTree str -> [TagTree str]+tagBranchTrees t = case t of+ TagBranch _ _ ts -> ts+ TagLeaf _ -> error "tagBranchTrees: TagLeaf"+++-- | Returns the inner 'Tag' value if the tree is a 'TagLeaf', or an error otherwise.+fromTagLeaf :: TagTree str -> Tag str+fromTagLeaf = withTagTree (\_ _ _ -> error "fromTagLeaf: TagBranch") id+++maybeTagBranchName :: TagTree str -> Maybe str+maybeTagBranchName = withTagTree (\n _ _ -> Just n) (const Nothing)++maybeTagBranchAttrs :: TagTree str -> Maybe [Attribute str]+maybeTagBranchAttrs = withTagTree (\_ as _ -> Just as) (const Nothing)++maybeTagBranchTrees :: TagTree str -> Maybe [TagTree str]+maybeTagBranchTrees = withTagTree (\_ _ ts -> Just ts) (const Nothing)++maybeTagLeafTag :: TagTree str -> Maybe (Tag str)+maybeTagLeafTag = withTagTree (\_ _ _ -> Nothing) Just+++hasTagBranchName :: Eq str => str -> TagTree str -> Bool+hasTagBranchName n = withTagTree (\n' _ _ -> n == n') (const False)++hasTagBranchAttr :: Eq str => str -> TagTree str -> Bool+hasTagBranchAttr = fmap isJust . findTagBranchAttr++findTagBranchAttr :: Eq str => str -> TagTree str -> Maybe str+findTagBranchAttr a = withTagTree (\_ as _ -> lookup a as) (const Nothing)+++{- |+ An alternative 'tagTree' version. The original version sometimes yields unsatisfying results+ if the tag soup includes several spurious opening or closing tags. This version tries harder+ to balance them properly.+-}+tagTree' :: StringLike str => [Tag str] -> [TagTree str]+tagTree' tags = (pre ++) . finish . foldl' (flip step) ([], [[]]) $ post+ where+ -- DOCTYPE cleanup (see <http://www.w3.org/TR/html-markup/documents.html#conformant-documents>)+ (pre, post) = case break ((||) <$> isTagOpen <*> isTagClose) tags of+ (pre, o@(TagOpen n _) : post)+ | toString n == "!DOCTYPE" -> (map TagLeaf $ pre ++ [o], post)+ _ -> ([], tags)++finish :: StringLike str => ([Tag str], [[TagTree str]]) -> [TagTree str]+finish (os, tss) = case (os, tss) of+ ([], [out]) -> reverse out+ (TagOpen no as : os', ts : ts' : tss') -> finish (os', (TagBranch no as (reverse ts) : ts') : tss')+ _ -> error ": mismatching number of opening tags and subtrees"+++step :: StringLike str => Tag str -> ([Tag str], [[TagTree str]]) -> ([Tag str], [[TagTree str]])+step tag (os, tss) = case tag of+ TagOpen _ _ -> (tag : os, [] : tss)+ TagClose nc -> case os of+ -- If last opened tag matches, remove it and add branch to last context+ TagOpen no as : os'+ | no == nc -> push os' (tail tss) $ TagBranch no as $ reverse $ head tss++ -- If previous opened matches, add spurious opened to context and close branch+ o@(TagOpen no as) : TagOpen no' as' : os'+ | no' == nc -> let ts : ts' : tss' = tss+ in push os' tss' $ TagBranch no' as' $ reverse $ ts ++ TagLeaf o : ts'++ -- Otherwise treat as spurious closed+ _ -> push os tss $ TagLeaf tag+ _ -> push os tss $ TagLeaf tag+ where+ push os (ts : tss) t = (os, (t : ts) : tss)+ push _ _ _ = error "push: empty context stack"+++{- |+ Tries to find the @html@ branch in a 'TagTree'. If no branch with that name exists, a new+ @html@ branch is returned with the input trees as its immediate children.+-}+htmlRoot :: [TagTree String] -> TagTree String+htmlRoot tags = case break isTagBranch tags of+ (_, t@(TagBranch n _ _) : _)+ | map toLower (toString n) == "html" -> t+ _ -> TagBranch "html" [] tags
+ src/Text/HTML/TagSoup/Tree/Zipper.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE CPP #-}++{- |+ A zipper for TagSoup 'TagTree's.+-}+module Text.HTML.TagSoup.Tree.Zipper (+ TagTreePos (..),+ fromTagTree,++ root,+ parent,+ firstChild,+ lastChild,+ prevSibling,+ nextSibling,++ iteratePos,++ traverseTree,+ traverseTreeBF+) where+++import Control.Applicative+import Control.Monad++import Data.List+import Data.Monoid+import Data.Sequence (Seq, (|>), (<|), ViewL (..), viewl)+import qualified Data.Sequence as Seq++import Text.HTML.TagSoup+import Text.HTML.TagSoup.Tree++++#if MIN_VERSION_base(4,5,0)+#else+infixr 6 <>+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+#endif++++data TagTreePos str = TagTreePos {+ content :: TagTree str,+ before :: [TagTree str],+ after :: [TagTree str],+ parents :: [([TagTree str], str, [Attribute str], [TagTree str])]+ } deriving (Show)+++fromTagTree :: TagTree str -> TagTreePos str+fromTagTree t = TagTreePos t [] [] []+++root :: TagTreePos str -> TagTreePos str+root pos = last (pos : iteratePos parent pos)+++parent :: TagTreePos str -> Maybe (TagTreePos str)+parent pos = case pos of+ TagTreePos _ _ _ [] -> Nothing+ TagTreePos t lcs rcs ((ls, n, as, rs):ps) -> Just TagTreePos {+ content = TagBranch n as $ reverse lcs ++ [t] ++ rcs,+ before = ls,+ after = rs,+ parents = ps+ }+++firstChild :: TagTreePos str -> Maybe (TagTreePos str)+firstChild pos@(TagTreePos t lcs rcs ps) = case t of+ TagLeaf _ -> Nothing+ TagBranch n as [] -> Nothing+ TagBranch n as (t:ts) -> Just TagTreePos {+ content = t,+ before = [],+ after = ts,+ parents = (lcs, n, as, rcs) : ps+ }+++lastChild :: TagTreePos str -> Maybe (TagTreePos str)+lastChild pos@(TagTreePos t lcs rcs ps) = case t of+ TagLeaf _ -> Nothing+ TagBranch n as [] -> Nothing+ TagBranch n as ts -> let (t : ts') = reverse ts in Just TagTreePos {+ content = t,+ before = ts',+ after = [],+ parents = (lcs, n, as, rcs) : ps+ }+++prevSibling :: TagTreePos str -> Maybe (TagTreePos str)+prevSibling pos@(TagTreePos t lcs rcs ps) = case lcs of+ [] -> Nothing+ l : ls -> Just TagTreePos {+ content = l,+ before = ls,+ after = t : rcs,+ parents = ps+ }+++nextSibling :: TagTreePos str -> Maybe (TagTreePos str)+nextSibling pos@(TagTreePos t lcs rcs ps) = case rcs of+ [] -> Nothing+ r : rs -> Just TagTreePos {+ content = r,+ before = t : lcs,+ after = rs,+ parents = ps+ }++{- |+ @iteratePos iter pos@ applies @iter@ to @pos@ until 'Nothing' is returned, collecting all+ new positions in the result list.+-}+iteratePos :: (TagTreePos str -> Maybe (TagTreePos str)) -> TagTreePos str -> [TagTreePos str]+iteratePos iter = unfoldr $ (join (,) <$>) . iter+++{- |+ @traverseTree f pos@ performs a depth-first traversal of a tree. The starting position is+ @pos@, and the result is obtained from the values produced by applying @f@ to each visited+ node. Note that this function will also traverse parent nodes if the position isn't+ indicating the root of the tree.+-}+traverseTree :: Monoid m => (TagTreePos str -> m) -> TagTreePos str -> m+traverseTree f pos =+ f pos <> maybe mempty (traverseTree f) (firstChild pos <|> nextSibling pos <|> nextParent pos)+ where+ nextParent = parent >=> (\pos -> nextSibling pos <|> nextParent pos)+++-- | Like 'traverseTree', but performs a breadth-first traversal.+traverseTreeBF :: Monoid m => (TagTreePos str -> m) -> TagTreePos str -> m+traverseTreeBF f = traverse . Seq.singleton+ where+ toSeq = maybe Seq.empty Seq.singleton+ traverse cs = case viewl cs of+ EmptyL -> mempty+ pos :< ps -> f pos <> traverse (toSeq (nextSibling pos) <> ps <> toSeq (firstChild pos))
+ src/Text/StringLike/Matchable.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TypeSynonymInstances #-}+module Text.StringLike.Matchable (+ Matchable (..),++ checkNull+) where++import Data.List+import Text.StringLike+++{- |+ An extention of string-like types for sub-string matching at various postions.+-}+class StringLike str => Matchable str where++ -- | Checks if two strings match exactly. This should by equal to '(==)' for most types.+ matchesExactly :: str -> str -> Bool+ matchesExactly = (==)++ -- | Checks if the first string is a prefix of of the second. If the first string is empty, the+ -- result is always 'False'.+ matchesPrefixOf :: str -> str -> Bool++ -- | Checks if the first string is an infix of the second, i.e. if the first string appears+ -- somewhere in the second. If the first string is empty, the result is always 'False'.+ matchesInfixOf :: str -> str -> Bool++ -- | Checks if the first string is a suffix of the second. If the first string is empty, the+ -- result is always 'False'.+ matchesSuffixOf :: str -> str -> Bool++ -- | Checks if the first string matches any of the whitespace-separated substrings in the second+ -- string exactly. If the first string is empty, the result is always 'False'.+ matchesWordOf :: str -> str -> Bool+++instance Matchable String where+ matchesPrefixOf = checkNull null isPrefixOf+ matchesInfixOf = checkNull null isInfixOf+ matchesSuffixOf = checkNull null isSuffixOf+ matchesWordOf = \s -> any (`matchesExactly` s) . splitOn (`elem` " \t\n\r")+++-- | @checkNull null comp s1 s2@ returns 'False' if either @null s1 == True@ or @comp s1 s2 == False@,+-- and returns 'True' otherwise.+checkNull :: (s -> Bool) -> (s -> s -> Bool) -> (s -> s -> Bool)+checkNull null comp s1 s2 = not (null s1) && comp s1 s2+++splitOn :: (Char -> Bool) -> String -> [String]+splitOn pred s = case break pred $ dropWhile pred s of+ ("", "") -> []+ (w, s') -> w : splitOn pred s'
+ tagsoup-selection.cabal view
@@ -0,0 +1,41 @@+Name: tagsoup-selection+Version: 0.1.0.0+Synopsis: Selecting subtrees from TagSoup's TagTrees using CSS selectors+Description: This package provides functions for parsing CSS3 selectors, a zipper for+ TagSoup's TagTree type, and functions for easily selecting subtrees from+ tag trees, e.g. by using CSS selectors.++Category: Text++License: BSD3+License-File: LICENSE++Author: siracusa+Maintainer: siracusa <pvnsrc@gmail.com>+Copyright: (c) 2016 siracusa++Stability: experimental++Build-Type: Simple+Cabal-Version: >= 1.8++Extra-source-files: CHANGELOG.md++Library+ Hs-Source-Dirs: src+ Exposed-Modules: Text.CSS3.Selectors.Parser,+ Text.CSS3.Selectors.Syntax,+ Text.HTML.TagSoup.Selection,+ Text.HTML.TagSoup.Tree.Selection,+ Text.HTML.TagSoup.Tree.Util,+ Text.HTML.TagSoup.Tree.Zipper,+ Text.StringLike.Matchable+ + Build-Depends: base >= 4.2 && < 5,+ containers >= 0.3 && < 0.6,+ parsec >= 3.1.3 && < 3.2,+ tagsoup >= 0.13.3 && < 0.14++Source-Repository head+ Type: git+ Location: https://github.com/pavonia/tagsoup-selection.git