diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changes + +## 0.1.0.0 + +Initial version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Text/CSS3/Selectors/Parser.hs b/src/Text/CSS3/Selectors/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/CSS3/Selectors/Parser.hs @@ -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 + +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)) diff --git a/src/Text/CSS3/Selectors/Syntax.hs b/src/Text/CSS3/Selectors/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Text/CSS3/Selectors/Syntax.hs @@ -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 . +-} +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') diff --git a/src/Text/HTML/TagSoup/Selection.hs b/src/Text/HTML/TagSoup/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/TagSoup/Selection.hs @@ -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 diff --git a/src/Text/HTML/TagSoup/Tree/Selection.hs b/src/Text/HTML/TagSoup/Tree/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/TagSoup/Tree/Selection.hs @@ -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 diff --git a/src/Text/HTML/TagSoup/Tree/Util.hs b/src/Text/HTML/TagSoup/Tree/Util.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/TagSoup/Tree/Util.hs @@ -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 ) + (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 diff --git a/src/Text/HTML/TagSoup/Tree/Zipper.hs b/src/Text/HTML/TagSoup/Tree/Zipper.hs new file mode 100644 --- /dev/null +++ b/src/Text/HTML/TagSoup/Tree/Zipper.hs @@ -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)) diff --git a/src/Text/StringLike/Matchable.hs b/src/Text/StringLike/Matchable.hs new file mode 100644 --- /dev/null +++ b/src/Text/StringLike/Matchable.hs @@ -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' diff --git a/tagsoup-selection.cabal b/tagsoup-selection.cabal new file mode 100644 --- /dev/null +++ b/tagsoup-selection.cabal @@ -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 +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