diff --git a/HandsomeSoup.cabal b/HandsomeSoup.cabal --- a/HandsomeSoup.cabal +++ b/HandsomeSoup.cabal @@ -1,61 +1,60 @@ --- HandsomeSoup.cabal auto-generated by cabal init. For additional --- options, see --- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. --- The name of the package. -Name: HandsomeSoup - --- The package version. See the Haskell package versioning policy --- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for --- standards guiding when and how versions should be incremented. -Version: 0.3.2 - --- A short (one-line) description of the package. -Synopsis: Work with HTML more easily in HXT - --- A longer description of the package. -Description: See examples and full readme on the Github page: https:\/\/github.com\/egonSchiele\/HandsomeSoup - --- URL for the project homepage or repository. -Homepage: https://github.com/egonSchiele/HandsomeSoup - --- The license under which the package is released. -License: BSD3 - --- The file containing the license text. -License-file: LICENSE - --- The package author(s). -Author: Aditya Bhargava - --- An email address to which users can send suggestions, bug reports, --- and patches. -Maintainer: bluemangroupie@gmail.com - --- A copyright notice. --- Copyright: +Name: HandsomeSoup +Version: 0.3.3 +Synopsis: Work with HTML more easily in HXT +Description: See examples and full readme on the Github page: https:\/\/github.com\/egonSchiele\/HandsomeSoup +Homepage: https://github.com/egonSchiele/HandsomeSoup +License: BSD3 +License-file: LICENSE +Author: Aditya Bhargava +Maintainer: bluemangroupie@gmail.com +Category: Text +Build-type: Simple +Cabal-version: >=1.8 -Category: Text +Extra-source-files: README.markdown + , examples/*.hs +Data-files: tests/test.html +library + hs-source-dirs: src + Exposed-modules: Text.HandsomeSoup + , Text.CSS.Parser + Other-modules: Text.CSS.Utils + Build-depends: base >= 4.6 && < 5 + , transformers + , HTTP + , parsec + , containers + , mtl + , MaybeT + , hxt + , network >= 2.6 + , network-uri >= 2.6 + , hxt-http -Build-type: Simple +test-suite hspec + hs-source-dirs: tests + main-is: AllTests.hs + type: exitcode-stdio-1.0 + Other-modules: Paths_HandsomeSoup + Build-depends: base >= 4.6 && < 5 + -- currently uses HSpec.Monadic submodule, removed in 1.10.0 + , hspec < 1.10 + , HandsomeSoup + , hxt --- Extra files to be distributed with the package, such as examples or --- a README. -Extra-source-files: README.markdown +Flag buildExamples + description: Build examples + default: False --- Constraint on the version of Cabal needed to build this package. -Cabal-version: >=1.2 +executable handsomesoup + If flag(buildExamples) + Buildable: True + Else + Buildable: False + hs-source-dirs: examples + main-is: GoogleSearch.hs + Build-depends: base >= 4.6 && < 5 + , HandsomeSoup + , hxt -Library - -- Modules exported by the library. - Exposed-modules: Text.HandsomeSoup, Text.CSS.Parser - - -- Packages needed in order to build this package. - Build-depends: base < 5, transformers, HTTP, parsec, containers, mtl, MaybeT, hxt, network, hxt-http - - -- Modules not exported by this package. - Other-modules: Text.CSS.Utils - - -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. - -- Build-tools: - diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,6 +1,6 @@ # HandsomeSoup -Current Status: Usable. Please file bugs! +Current Status: Usable and stable. **Needs GHC 7.6**. Please file bugs! HandsomeSoup is the library I wish I had when I started parsing HTML in Haskell. @@ -16,8 +16,11 @@ [Nokogiri](http://nokogiri.org/), the HTML parser for Ruby, has an example showing how to scrape Google search results. This is easy in HandsomeSoup: + import Text.XML.HXT.Core + import Text.HandsomeSoup + main = do - doc <- fromUrl "http://www.google.com/search?q=egon+schiele" + let doc = fromUrl "http://www.google.com/search?q=egon+schiele" links <- runX $ doc >>> css "h3.r a" ! "href" mapM_ putStrLn links @@ -25,7 +28,7 @@ ### Easily parse an online page using `fromUrl` - doc <- fromUrl "http://example.com" + let doc = fromUrl "http://example.com" ### Or a local page using `parseHtml` diff --git a/Text/CSS/Parser.hs b/Text/CSS/Parser.hs deleted file mode 100644 --- a/Text/CSS/Parser.hs +++ /dev/null @@ -1,127 +0,0 @@ -module Text.CSS.Parser where - -import Text.Parsec -import qualified Data.Functor.Identity as I -import Data.List -import Data.Maybe -import Text.CSS.Utils --- if no tag name was given, sName will be set to '*' --- attrs are (attr name, attr value). --- if attr value is the empty string, we just check to --- make sure that the element has that attribute. --- --- if the attr value is prefixed with a '~', we treat --- that attribute as a list of words separated by a space --- and make sure that at least one of those words matches. --- --- if the attr value is prefixed with a `|`, the value must --- be exactly val or start with val immediately followed by a '-'. --- This is primarily intended to allow language subcode matches. --- Example: [lang|="en"] matches "en", "en-US", etc. --- From: http://www.w3.org/TR/CSS2/selector.html. -data Selector = Selector { sName :: String, sAttrs :: [(String,String)], spseudoSelectores :: [String] } | Space | ChildOf | FollowedBy deriving (Show) - --- pretty printers for debugging -pp Space = "" -pp ChildOf = "" -pp FollowedBy = "" -pp (Selector name attrs pseudo) = show name ++ ":" ++ showMap attrs ++ ", " ++ show pseudo - where showMap m = ("{" ++ (foldl (\acc (k,v) -> acc ++ (show k) ++ ":" ++ (show v) ++ ", ") "" m)) ++ "}" - -{- Some lexeme parsers -} -ident :: ParsecT [Char] u I.Identity String -ident = do c1 <- optionMaybe (char '-') - c2 <- nmstart - cs <- many nmchar - return $ concat [maybeToList c1, [c2], cs] - -nmstart = alphaNum <|> char '_' -nmchar = alphaNum <|> oneOf "_-" - -{- TYPE SELECTORS FOLLOW -} - --- | selects a tag name, like @ h1 @ -typeSelector :: ParsecT [Char] u I.Identity [Char] -typeSelector = many1 (alphaNum <|> oneOf "_-") - --- | universal selector, selects @ * @ -universalSelector :: ParsecT [Char] u I.Identity String -universalSelector = string "*" - -{- SECONDARY SELECTORS FOLLOW -} - --- | selects a pseudo-element or pseudo-class, like @ :link @, @ :first-child @ etc. -pseudoSelector :: ParsecT [Char] u I.Identity [Char] -pseudoSelector = char ':' >> many1 (alphaNum <|> oneOf "-()") - --- | class selector, selects @ .foo @ -classSelector :: ParsecT [Char] u I.Identity ([Char], [Char]) -classSelector = do - val <- char '.' >> ident - return ("class", '~':val) - --- | id selector, selects @ #foo @ -idSelector :: ParsecT [Char] u I.Identity ([Char], [Char]) -idSelector = do - val <- char '#' >> many1 nmchar - return ("id", val) - --- | selects attributes, like @ [id] @ (element must have id) or @ [id=foo] @ (element must have id foo). -attributeSelector :: ParsecT [Char] u I.Identity ([Char], [Char]) -attributeSelector = do - _contents <- between (char '[') (char ']') (many1 (alphaNum <|> oneOf "/-_|~=\"'.")) - -- remove quotes - let contents = filter (\c -> c /= '"' && c /= '\'') _contents - if "~=" `isInfixOf` contents - then return $ (\(a, b) -> (a, '~':b)) $ splitOn "~=" contents - else if "|=" `isInfixOf` contents - then return $ (\(a, b) -> (a, '|':b)) $ splitOn "|=" contents - else if '=' `elem` contents - then return $ splitOn "=" contents - else return (contents, "") - --- | selector for everything after the type except pseudoSelectores -secondarySelector = many1 (classSelector <|> idSelector <|> attributeSelector) - -{- COMBINATOR SELECTORS FOLLOW -} - -space_ = do - many1 $ string " " - return Space - -childOf = do - spaces >> string ">" >> spaces - return ChildOf - -followedBy = do - spaces >> string "+" >> spaces - return FollowedBy - -{- SIMPLE SELECTORS FOLLOW -} - --- | selects a tagname followed by one or more secondary selectors --- example: @ a.foo @, @ *#hello @, @ h1 @ etc -simpleSelectorTag :: ParsecT [Char] u I.Identity Selector -simpleSelectorTag = do - tagName <- typeSelector <|> universalSelector - attrs <- secondarySelector <|> return [] - pseudo <- many1 pseudoSelector <|> return [] - return $ Selector tagName attrs pseudo - --- | selects one or more secondary selectors --- and automatically prepends the universal selector to them. --- example: @ .foo @, @ #hello @ etc -simpleSelectorNoTag = do - attrs <- secondarySelector - pseudo <- many1 pseudoSelector <|> return [] - return $ Selector "*" attrs pseudo - --- | A simple selector is either a type selector or universal selector followed immediately by zero or more attribute selectors, ID selectors, or pseudo-classes, in any order. -simpleSelector :: ParsecT [Char] u I.Identity Selector -simpleSelector = simpleSelectorTag <|> simpleSelectorNoTag <|> try childOf <|> try followedBy <|> space_ - --- | One or more simple selectors separated by combinators. -selector :: ParsecT [Char] u I.Identity [[Selector]] -selector = many1 simpleSelector `sepBy` (spaces >> string "," >> spaces) - -css = parse selector "" diff --git a/Text/CSS/Utils.hs b/Text/CSS/Utils.hs deleted file mode 100644 --- a/Text/CSS/Utils.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Text.CSS.Utils where -import Data.List - --- like break, except don't keep the element you broke on. --- and it takes a list as the thing to break on. -splitOn a xs = _splitOn a "" xs - -_splitOn _ begin [] = (begin, []) -_splitOn a begin end@(x:xs) - | a `isPrefixOf` end = (begin, drop (length a) end) - | otherwise = _splitOn a (begin ++ [x]) xs - diff --git a/Text/HandsomeSoup.hs b/Text/HandsomeSoup.hs deleted file mode 100644 --- a/Text/HandsomeSoup.hs +++ /dev/null @@ -1,85 +0,0 @@ -module Text.HandsomeSoup (openUrl, fromUrl, parseHtml, (!), css) where - -import Text.XML.HXT.Core -import Network.HTTP -import Network.URI -import Data.Tree.NTree.TypeDefs -import Control.Monad.Maybe -import Control.Monad.Trans -import Data.Maybe -import Text.Parsec -import qualified Data.Map as M -import Data.Monoid (mconcat) -import qualified Data.Functor.Identity as I -import qualified Debug.Trace as D -import Data.List -import Control.Monad -import Text.CSS.Parser hiding (css) -import Text.XML.HXT.Arrow.ReadDocument -import Text.XML.HXT.HTTP - --- | Helper function for getting page content. Example: --- --- > contents <- runMaybeT $ openUrl "http://foo.com" -openUrl :: String -> MaybeT IO String -openUrl url = case parseURI url of - Nothing -> fail "couldn't parse url" - Just u -> liftIO (getResponseBody =<< simpleHTTP (mkRequest GET u)) - --- | Given a url, returns a document. Example: --- --- > doc = fromUrl "http://foo.com" --- > doc = fromUrl "tests/test.html" -fromUrl :: String -> IOSArrow XmlTree (NTree XNode) -fromUrl url = readDocument [withValidate no, - withInputEncoding isoLatin1, - withParseByMimeType yes, - withHTTP [], - withWarnings no] url - --- | Given a string, parses it and returns a document. Example: --- --- > doc = parseHtml "

hello!

" -parseHtml :: String -> IOSArrow XmlTree (NTree XNode) -parseHtml = readString [withParseHTML yes, withWarnings no] - --- | Shortcut for getting attributes. Example: --- --- > doc >>> css "a" ! "href" -(!) :: ArrowXml cat => cat a XmlTree -> String -> cat a String -(!) a str = a >>> getAttrValue str - --- | A css selector for getting elements from a document. Example: --- --- > doc >>> css "#menu li" -css :: ArrowXml a => [Char] -> a (NTree XNode) (NTree XNode) -css tag = case (parse selector "" tag) of - Left err -> D.trace (show err) this - Right x -> fromSelectors x - --- | Used internally. works on a selector (i.e a list of simple selectors) -fromSelectors sel@(s:selectors) = foldl (\acc selector -> acc <+> _fromSelectors selector) (_fromSelectors s) selectors - --- | Used internally. works on simple selectors and their combinators -_fromSelectors (s:selectors) = foldl (\acc selector -> make acc selector) (make this s) selectors - where - make acc sel@(Selector name attrs pseudo) - | name == "*" = acc >>> ((multi this >>> makeAttrs attrs) >>. makePseudos pseudo) - | otherwise = acc >>> ((multi $ hasName name >>> makeAttrs attrs) >>. makePseudos pseudo) - make acc Space = acc >>> getChildren - make acc ChildOf = acc >>> getChildren >>> processChildren none - makeAttrs (a:attrs) = foldl (\acc attr -> acc >>> makeAttr attr) (makeAttr a) attrs - makeAttrs [] = this - makeAttr (name, "") = hasAttr name - makeAttr (name, '~':value) = hasAttrValue name (elem value . words) - makeAttr (name, '|':value) = hasAttrValue name (headMatch value) - makeAttr (name, value) = hasAttrValue name (==value) - makePseudos (p:pseudos) = foldl (\acc pseudo -> acc >>> makePseudo pseudo) (makePseudo p) pseudos - makePseudos [] = id - makePseudo "first-child" = take 1 - --- | Used internally to match attribute selectors like @ [att|=val] @. --- From: http://www.w3.org/TR/CSS2/selector.html --- "Represents an element with the att attribute, its value either being exactly "val" or beginning with "val" immediately followed by '-'". -headMatch value attrValue = value == attrValue || value `isPrefixOf` attrValue - where first = head . words $ attrValue diff --git a/examples/GoogleSearch.hs b/examples/GoogleSearch.hs new file mode 100644 --- /dev/null +++ b/examples/GoogleSearch.hs @@ -0,0 +1,10 @@ +module Main where + +import Text.HandsomeSoup +import Text.XML.HXT.Core + +main :: IO () +main = do + let doc = fromUrl "http://www.google.com/search?q=egon+schiele" + links <- runX $ doc >>> css "h3.r a" ! "href" + mapM_ putStrLn links diff --git a/src/Text/CSS/Parser.hs b/src/Text/CSS/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/CSS/Parser.hs @@ -0,0 +1,127 @@ +module Text.CSS.Parser where + +import Text.Parsec +import qualified Data.Functor.Identity as I +import Data.List +import Data.Maybe +import Text.CSS.Utils +-- if no tag name was given, sName will be set to '*' +-- attrs are (attr name, attr value). +-- if attr value is the empty string, we just check to +-- make sure that the element has that attribute. +-- +-- if the attr value is prefixed with a '~', we treat +-- that attribute as a list of words separated by a space +-- and make sure that at least one of those words matches. +-- +-- if the attr value is prefixed with a `|`, the value must +-- be exactly val or start with val immediately followed by a '-'. +-- This is primarily intended to allow language subcode matches. +-- Example: [lang|="en"] matches "en", "en-US", etc. +-- From: http://www.w3.org/TR/CSS2/selector.html. +data Selector = Selector { sName :: String, sAttrs :: [(String,String)], spseudoSelectores :: [String] } | Space | ChildOf | FollowedBy deriving (Show) + +-- pretty printers for debugging +pp Space = "" +pp ChildOf = "" +pp FollowedBy = "" +pp (Selector name attrs pseudo) = show name ++ ":" ++ showMap attrs ++ ", " ++ show pseudo + where showMap m = ("{" ++ (foldl (\acc (k,v) -> acc ++ (show k) ++ ":" ++ (show v) ++ ", ") "" m)) ++ "}" + +{- Some lexeme parsers -} +ident :: ParsecT [Char] u I.Identity String +ident = do c1 <- optionMaybe (char '-') + c2 <- nmstart + cs <- many nmchar + return $ concat [maybeToList c1, [c2], cs] + +nmstart = alphaNum <|> char '_' +nmchar = alphaNum <|> oneOf "_-" + +{- TYPE SELECTORS FOLLOW -} + +-- | selects a tag name, like @ h1 @ +typeSelector :: ParsecT [Char] u I.Identity [Char] +typeSelector = many1 (alphaNum <|> oneOf "_-") + +-- | universal selector, selects @ * @ +universalSelector :: ParsecT [Char] u I.Identity String +universalSelector = string "*" + +{- SECONDARY SELECTORS FOLLOW -} + +-- | selects a pseudo-element or pseudo-class, like @ :link @, @ :first-child @ etc. +pseudoSelector :: ParsecT [Char] u I.Identity [Char] +pseudoSelector = char ':' >> many1 (alphaNum <|> oneOf "-()") + +-- | class selector, selects @ .foo @ +classSelector :: ParsecT [Char] u I.Identity ([Char], [Char]) +classSelector = do + val <- char '.' >> ident + return ("class", '~':val) + +-- | id selector, selects @ #foo @ +idSelector :: ParsecT [Char] u I.Identity ([Char], [Char]) +idSelector = do + val <- char '#' >> many1 nmchar + return ("id", val) + +-- | selects attributes, like @ [id] @ (element must have id) or @ [id=foo] @ (element must have id foo). +attributeSelector :: ParsecT [Char] u I.Identity ([Char], [Char]) +attributeSelector = do + _contents <- between (char '[') (char ']') (many1 (alphaNum <|> oneOf "/-_|~=\"'.")) + -- remove quotes + let contents = filter (\c -> c /= '"' && c /= '\'') _contents + if "~=" `isInfixOf` contents + then return $ (\(a, b) -> (a, '~':b)) $ splitOn "~=" contents + else if "|=" `isInfixOf` contents + then return $ (\(a, b) -> (a, '|':b)) $ splitOn "|=" contents + else if '=' `elem` contents + then return $ splitOn "=" contents + else return (contents, "") + +-- | selector for everything after the type except pseudoSelectores +secondarySelector = many1 (classSelector <|> idSelector <|> attributeSelector) + +{- COMBINATOR SELECTORS FOLLOW -} + +space_ = do + many1 $ string " " + return Space + +childOf = do + spaces >> string ">" >> spaces + return ChildOf + +followedBy = do + spaces >> string "+" >> spaces + return FollowedBy + +{- SIMPLE SELECTORS FOLLOW -} + +-- | selects a tagname followed by one or more secondary selectors +-- example: @ a.foo @, @ *#hello @, @ h1 @ etc +simpleSelectorTag :: ParsecT [Char] u I.Identity Selector +simpleSelectorTag = do + tagName <- typeSelector <|> universalSelector + attrs <- secondarySelector <|> return [] + pseudo <- many1 pseudoSelector <|> return [] + return $ Selector tagName attrs pseudo + +-- | selects one or more secondary selectors +-- and automatically prepends the universal selector to them. +-- example: @ .foo @, @ #hello @ etc +simpleSelectorNoTag = do + attrs <- secondarySelector + pseudo <- many1 pseudoSelector <|> return [] + return $ Selector "*" attrs pseudo + +-- | A simple selector is either a type selector or universal selector followed immediately by zero or more attribute selectors, ID selectors, or pseudo-classes, in any order. +simpleSelector :: ParsecT [Char] u I.Identity Selector +simpleSelector = simpleSelectorTag <|> simpleSelectorNoTag <|> try childOf <|> try followedBy <|> space_ + +-- | One or more simple selectors separated by combinators. +selector :: ParsecT [Char] u I.Identity [[Selector]] +selector = many1 simpleSelector `sepBy` (spaces >> string "," >> spaces) + +css = parse selector "" diff --git a/src/Text/CSS/Utils.hs b/src/Text/CSS/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Text/CSS/Utils.hs @@ -0,0 +1,12 @@ +module Text.CSS.Utils where +import Data.List + +-- like break, except don't keep the element you broke on. +-- and it takes a list as the thing to break on. +splitOn a xs = _splitOn a "" xs + +_splitOn _ begin [] = (begin, []) +_splitOn a begin end@(x:xs) + | a `isPrefixOf` end = (begin, drop (length a) end) + | otherwise = _splitOn a (begin ++ [x]) xs + diff --git a/src/Text/HandsomeSoup.hs b/src/Text/HandsomeSoup.hs new file mode 100644 --- /dev/null +++ b/src/Text/HandsomeSoup.hs @@ -0,0 +1,90 @@ +module Text.HandsomeSoup (openUrl, fromUrl, parseHtml, (!), css) where + +import Text.XML.HXT.Core +import Network.HTTP +import Network.URI +import Data.Tree.NTree.TypeDefs +import Control.Monad.Maybe +import Control.Monad.Trans +import Data.Maybe +import Text.Parsec +import qualified Data.Map as M +import Data.Monoid (mconcat) +import qualified Data.Functor.Identity as I +import qualified Debug.Trace as D +import Data.List +import Control.Monad +import Text.CSS.Parser hiding (css) +import Text.XML.HXT.Arrow.ReadDocument +import Text.XML.HXT.HTTP + +-- | Helper function for getting page content. Example: +-- +-- > contents <- runMaybeT $ openUrl "http://foo.com" +openUrl :: String -> MaybeT IO String +openUrl url = case parseURI url of + Nothing -> fail "couldn't parse url" + Just u -> liftIO (getResponseBody =<< simpleHTTP (mkRequest GET u)) + +-- | Given a url, returns a document. Example: +-- +-- > doc = fromUrl "http://foo.com" +-- > doc = fromUrl "tests/test.html" +fromUrl :: String -> IOSArrow b (NTree XNode) +fromUrl url = readDocument [withValidate no, + withInputEncoding isoLatin1, + withParseByMimeType yes, + withHTTP [], + withWarnings no] url + +-- | Given a string, parses it and returns a document. Example: +-- +-- > doc = parseHtml "

hello!

" +parseHtml :: String -> IOSArrow b (NTree XNode) +parseHtml = readString [withParseHTML yes, withWarnings no] + +-- | Shortcut for getting attributes. Example: +-- +-- > doc >>> css "a" ! "href" +(!) :: ArrowXml cat => cat a XmlTree -> String -> cat a String +(!) a str = a >>> getAttrValue str + +-- | A css selector for getting elements from a document. Example: +-- +-- > doc >>> css "#menu li" +css :: ArrowXml a => [Char] -> a (NTree XNode) (NTree XNode) +css tag = case (parse selector "" tag) of + Left err -> D.trace (show err) this + Right x -> fromSelectors x + +-- | Used internally. works on a selector (i.e a list of simple selectors) +fromSelectors sel@(s:selectors) = foldl (\acc selector -> acc <+> _fromSelectors selector) (_fromSelectors s) selectors + +-- | Used internally. works on simple selectors and their combinators +_fromSelectors (s:selectors) = foldl (\acc selector -> make acc selector) (make this s) selectors + where + make acc sel@(Selector name attrs pseudo) + | name == "*" = acc >>> ((multi this >>> makeAttrs attrs) >>. makePseudos pseudo) + | otherwise = acc >>> ((multi $ hasName name >>> makeAttrs attrs) >>. makePseudos pseudo) + make acc Space = acc >>> getChildren + make acc ChildOf = acc >>> getChildren >>> processChildren none + makeAttrs (a:attrs) = foldl (\acc attr -> acc >>> makeAttr attr) (makeAttr a) attrs + makeAttrs [] = this + makeAttr (name, "") = hasAttr name + makeAttr (name, '~':value) = hasAttrValue name (elem value . words) + makeAttr (name, '|':value) = hasAttrValue name (headMatch value) + makeAttr (name, value) = hasAttrValue name (==value) + makePseudos (p:pseudos) = foldl (\acc pseudo -> acc >>> makePseudo pseudo) (makePseudo p) pseudos + makePseudos [] = id + makePseudo selector + | selector == "first-child" = take 1 + | nthSelector selector = take 1 . drop (n - 1) + where nthSelector selector = take 10 selector == "nth-child(" + getN selector = read $ (takeWhile (/= ')') . drop 10) selector :: Int + n = getN selector + +-- | Used internally to match attribute selectors like @ [att|=val] @. +-- From: http://www.w3.org/TR/CSS2/selector.html +-- "Represents an element with the att attribute, its value either being exactly "val" or beginning with "val" immediately followed by '-'". +headMatch value attrValue = value == attrValue || value `isPrefixOf` attrValue + where first = head . words $ attrValue diff --git a/tests/AllTests.hs b/tests/AllTests.hs new file mode 100644 --- /dev/null +++ b/tests/AllTests.hs @@ -0,0 +1,75 @@ +module Main where + +import Text.HandsomeSoup +import Text.XML.HXT.Core +import System.IO.Unsafe +import Paths_HandsomeSoup + +import Test.Hspec.Monadic + +-- mk :: (Show a, Eq a, ArrowXml b) => String -> b (T.NTree XNode) (T.NTree XNode) -> a -> Test +run action = unsafePerformIO $ do + testFile <- getDataFileName "tests/test.html" + {- runX $ (fromUrl "tests/test.html") >>> action -} + runX $ (fromUrl testFile) >>> action + +main :: IO () +main = hspec $ do + describe "tests" $ do + it "should get all links" $ + run (css "a" >>> getName) == ["a", "a", "a"] + + it "should get every element" $ + run (css "*" >>> getName) == ["/","html","head","title","body","h1","b","p","strong","a","strong","a","a","p","div","p"] + + it "should get descendents" $ + run (css "p strong" >>> getName) == ["strong", "strong"] + + it "should get children (negative test)" $ + run (css "p > strong" >>> getName) == ["strong"] + + it "should get children" $ + run (css "a > strong" >>> getName) == ["strong"] + + it ":first-child pseudo-element" $ + run (css "a:first-child" >>> getName) == ["a"] + + describe "attribute selector" $ do + it "no value" $ + run (css "p[class]" >>> getName) == ["p"] + + it "exact value" $ + run (css "a[class=sister]" >>> getName) == ["a", "a"] + + it "inexact value" $ + run (css "a[class~=sister]" >>> getName) == ["a", "a", "a"] + + it "using |" $ + run (css "[lang|='en']" >>> getName) == ["html"] + + it "underscore in attribute selector should work" $ + run (css "div[class=curr_lang]" >>> getName) == ["div"] + + it "dash in attribute selector should work" $ + run (css "p[data-original=test]" >>> getName) == ["p"] + + it "class selector" $ + run (css "a.sister" >>> getName) == ["a", "a", "a"] + + it "class selector #2" $ + run (css ".sister" >>> getName) == ["a", "a", "a"] + + it "id selector" $ + run (css "a#link1" >>> getName) == ["a"] + + it "both class and id selectors" $ + run (css "a.sister#link1" >>> getName) == ["a"] + + it "should ignore extra spaces" $ + run (css "html body" >>> getName) == ["body"] + + it "should handle multiple elements" $ + run (css "a, p" >>> getName) == ["a","a","a","p","p","p"] + + it "should get grandchildren only" $ + run (css "p * strong" >>> getName) == ["strong"] diff --git a/tests/test.html b/tests/test.html new file mode 100644 --- /dev/null +++ b/tests/test.html @@ -0,0 +1,20 @@ +The Dormouse's story + +

The Dormouse's story

+ +

Once upon a time there were three little sisters; and their names were + test + Elsie, +Lacie and +Tillie; +and they lived at the bottom of a well.

+ +

foo

+ +
+

+Inside a div. +

+
+ +