+homepage: https://github.com/ndmitchell/tagsoup#readme
+bug-reports: https://github.com/ndmitchell/tagsoup/issues
+license: BSD3
+category: XML
+license-file: LICENSE
+build-type: Simple
+synopsis: Parsing and extracting information from (possibly malformed) HTML/XML documents
+tested-with: GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3
+description:
+ TagSoup is a library for parsing HTML/XML. It supports the HTML 5 specification,
+ and can be used to parse either well-formed XML, or unstructured and malformed HTML
+ from the web. The library also provides useful functions to extract information
+ from an HTML document, making it ideal for screen-scraping.
+ .
+ Users should start from the "Text.HTML.TagSoup" module.
+extra-doc-files:
+ CHANGES.txt
+ README.md
-Flag splitBase
- Description: Choose the new smaller, split-up base package.
+source-repository head
+ type: git
+ location: https://github.com/ndmitchell/tagsoup.git
-Library
- if flag(splitBase)
- build-depends: base >= 3, network, mtl, containers
- else
- build-depends: base < 3, network, mtl
+library
+ default-language: Haskell2010
+ build-depends: base == 4.*, containers, bytestring, text
+ hs-source-dirs: src
- GHC-Options: -Wall
- Exposed-modules:
+ exposed-modules:
Text.HTML.TagSoup
Text.HTML.TagSoup.Entity
Text.HTML.TagSoup.Match
+ Text.HTML.TagSoup.Tree
+ Text.StringLike
+ other-modules:
+ Text.HTML.TagSoup.Generated
+ Text.HTML.TagSoup.Implementation
+ Text.HTML.TagSoup.Manual
+ Text.HTML.TagSoup.Options
Text.HTML.TagSoup.Parser
Text.HTML.TagSoup.Render
- Text.HTML.TagSoup.Tree
+ Text.HTML.TagSoup.Specification
Text.HTML.TagSoup.Type
- Text.HTML.Download
-Executable tagsoup
- Main-Is: Main.hs
- GHC-Options: -Wall
- Other-Modules:
- Example.Example
- Example.Regress
+test-suite test-tagsoup
+ type: exitcode-stdio-1.0
+ default-language: Haskell2010
+ build-depends:
+ base == 4.*, bytestring,
+ QuickCheck >= 2.4,
+ deepseq >= 1.1,
+ tagsoup,
+ time, directory, process
+
+ main-is: Main.hs
+ hs-source-dirs: test
+ other-modules:
+ TagSoup.Benchmark
+ TagSoup.Sample
+ TagSoup.Test
diff --git a/tagsoup.htm b/tagsoup.htm
deleted file mode 100644
--- a/tagsoup.htm
+++ /dev/null
@@ -1,314 +0,0 @@
-
-
-
-
- Drinking TagSoup by Example
-
-
-
-
-Drinking TagSoup by Example
-
-
- by Neil Mitchell
-
-
-
- TagSoup is a library for extracting information out of unstructured HTML code, sometimes known as tag-soup. The HTML does not have to be well formed, or render properly within any particular framework. This library is for situations where the author of the HTML is not cooperating with the person trying to extract the information, but is also not trying to hide the information.
-
-
- This document gives two particular examples, and two more may be found in the Example file from the darcs repository. The examples we give are:
-
-
- - Obtaining the Hit Count from Haskell.org
- - Obtaining a list of Simon Peyton-Jones' latest papers
- - A brief overview of some other examples
-
-
- The intial version of this library was written in Javascript and has been used for various commercial projects involving screen scraping. In the examples general hints on screen scraping are included, learnt from bitter experience. It should be noted that if you depend on data which someone else may change at any given time, you may be in for a shock!
-
-
- This library was written without knowledge of the Java version of TagSoup. They have made a very different design decision: to ensure default attributes are present and to properly nest parsed tags. We do not do this - tags are merely a list devoid of nesting information.
-
-
-Acknowledgements
-
-
- Thanks to Mike Dodds for persuading me to write this up as a library. Thanks to many people for debugging and code contributions, including: Gleb Alexeev, Ketil Malde, Conrad Parker, Henning Thielemann.
-
-
-Version History
-
-0.4-0.6
-
-
- - Addition of Text.HTML.TagSoup.Tree and Text.HTML.TagSoup.Render. Both these modules need review, so if they are useful to you please do send suggestions and comments.
- - In Text.HTML.TagSoup.Parser, the Options type has been renamed to ParseOptions.
- - In Text.HTML.TagSoup.Parser, the options function has been renamed to parseOptions.
-
-
-Potential Bugs
-
-
- There are two things that may go wrong with these examples:
-
-
- -
- The Websites being scraped may change. There is nothing I can do about this, but if you suspect this is the case let me know, and I'll update the examples and tutorials. I have already done so once or twice, its only a few minutes work.
-
- -
- The openURL method may not work. This happens quite regularly, and depending on your server, proxies and direction of the wind, they may not work. The solution is to use wget to download the page locally, then use readFile instead. Hopefully a decent Haskell HTTP library will emerge, and that can be used instead.
-
-
-
-
-Haskell Hit Count
-
-
- Our goal is to develop a program that displays the Haskell.org hit count. This example covers all the basics in designing a basic web-scraping application.
-
-
-Finding the Page
-
-
- We first need to find where the information is displayed, and in what format. Taking a look at the front web page, when not logged in, you may notice that there is no hit count. However, looking at the source shows us:
-
-
-<div class="printfooter">
-<p>Retrieved from "<a href="http://www.haskell.org/haskellwiki/Haskell">
-http://www.haskell.org/haskellwiki/Haskell</a>"</p>
-
-<p>This page has been accessed 615,165 times.
-This page was last modified 15:44, 15 March 2007.
-Recent content is available under <a href="/haskellwiki/HaskellWiki:Copyrights"
-title="HaskellWiki:Copyrights">a simple permissive license</a>.</p>
-
-
- So we see that the hit count is available, but not shown. This leads us to rule 1:
-
-
- Rule 1:
- Scrape from what the page returns, not what a browser renders, or what view-source gives.
-
-
- Some web servers will serve different content depending on the user agent, some browsers will have scripting modify their displayed HTML, some pages will display differently depending on your cookies. Before you can start to figure out how to start scraping, first decide what the input to your program will be. There are three ways to get the page as it will appear to your program.
-
-
-Using Text.Html.Download
-
- Tagsoup provides a module Text.Html.Download, which contains openURL.
-
-
-import Text.HTML.Download
-
-main = do src <- openURL "http://haskell.org/haskellwiki/Haskell"
- writeFile "temp.htm" src
-
-
- Now open temp.htm, find the fragment of HTML containing the hit count, and examine it.
-
-
-Using the tagsoup Program
-
- Tagsoup installs both as a library and a program. The program contains all the examples mentioned on this page, along with a few other useful functions. In order to download a URL to a file:
-
-
-$ tagsoup grab http://haskell.org/haskellwiki/Haskell > temp.htm
-
-
-Using Network.HTTP
-
- An alternative fragment of text for reading in the original web page, using the network library, can be written as:
-
-
-import qualified Data.ByteString.Lazy.Char8 as BS
-import Network.HTTP (rspBody)
-import Network.HTTP.UserAgent as UA
-
-main :: IO ()
-main = do rsp <- UA.get "http://haskell.org/haskellwiki/Haskell"
- let src = BS.unpack $ rspBody rsp
- writeFile "temp.htm" src
-
-
-Finding the Information
-
-
- Now we examine both the fragment that contains our snippet of information, and the wider page. What does the fragment has that nothing else has? What algorithm would we use to obtain that particular element? How can we still return the element as the content changes? What if the design changes? But wait, before going any further:
-
-
- Rule 2:
- Do not be robust to design changes, do not even consider the possibility when writing the code.
-
-
- If the user changes their website, they will do so in unpredictable ways. They may move the page, they may put the information somewhere else, they may remove the information entirely. If you want something robust talk to the site owner, or buy the data from someone. If you try and think about design changes, you will complicate your design, and it still won't work. It is better to write an extraction method quickly, and happily rewrite it when things change.
-
-
- So now, lets consider the fragment from above. It is useful to find a tag which is unique just above your snippet - something with a nice "id" property, or a "class" - something which is unlikely to occur multiple times. In the above example, "printfooter" as the class seems perfect. We decide that to find the snippet, we will start at a "div" tag, with a "class" attribute with the value "printfooter".
-
-
-haskellHitCount = do
- tags <- liftM parseTags $ openURL "http://haskell.org/haskellwiki/Haskell"
- let count = fromFooter $ head $ sections (~== "<div class=printfooter>") tags
- putStrLn $ "haskell.org has been hit " ++ show count ++ " times"
-
-
- Now we start writing the code! The first thing to do is open the required URL, then we parse the code into a list of Tags. We then apply the sections function, which returns all the lists whose first element matches the query. We use the (~==) operator to construct the query - in this case asking for the "div" we mentioned earlier. This (~==) operator is very different from standard equality, it allows additional attributes to be present but does not match them. We write "<div class=printfooter>" as syntactic sugar for TagOpen "div" [("class","printfooter")]. If we just wanted any open tag with the given class we could have written (~== TagOpen "" [("class","printfooter")]) and this would have matched. Any empty strings in the second element of the match are considered as wildcards.
-
-
- Once we have a list of all matching prefixes, we take the head - assuming that only one will match. Then we apply fromFooter which needs to perform the traversal from the "printfooter" attribute onwards to the actual hit count data.
-
-
-Extracting the Information
-
-
- Now we have a stream starting at the right place, we generally mangle the code using standard list operators:
-
-
-fromFooter x = read (filter isDigit num) :: Int
- where
- num = ss !! (i - 1)
- Just i = findIndex (== "times.") ss
- ss = words s
- TagText s = sections (~== "<p>") x !! 1 !! 1
-
-
- This code finds s, the text inside the appropriate paragraph by knowing that its the second (!! 1) paragraph, and within that paragraph, its the second tag - the actual text. We then split up the text using words, find the message that comes after hit count, and read all the digits we can find - filtering out the comma. I'm pretty sure this could be done better using regular expressions, and I invite a reader to submit improved code. This code may seem slightly messy, and indeed it is - often that is the nature of extracting information from a tag soup.
-
-
- Rule 3:
- TagSoup is for extracting information where structure has been lost, use more structured information if it is available.
-
-
-
-Simon's Papers
-
-
- Our next very important task is to extract a list of all Simon Peyton Jones' recent research papers off his home page. The largest change to the previous example is that now we desire a list of papers, rather than just a single result.
-
-
- As before we first start by writing a simple program that downloads the appropriate page, and look for common patterns. This time we want to look for all patterns which occur every time a paper is mentioned, but no where else. The other difference from last time is that previous we grabbed an automatically generated piece of information - this time the information is entered in a more freeform way by a human.
-
-
- First we spot that the page helpfully has named anchors, there is a current work anchor, and after that is one for Haskell. We can extract all the information between them with a simple take/drop pair:
-
-
-takeWhile (~/= "<a name=haskell>") $
-drop 5 $ dropWhile (~/= "<a name=current>") tags
-
-
- This code drops until you get to the "current" section, then takes until you get to the "haskell" section, ensuring we only look at the important bit of the page. Next we want to find all hyperlinks within this section:
-
-
-map f $ sections (~== "<a>") $ ...
-
-
- Remember that the function to select all tags with name "a" could have been written as (~== TagOpen "a" []), or alternatively isTagOpenName "a". Afterwards we map each item with an f function. This function needs to take the tags starting just after the link, and find the text inside the link.
-
-
-f = dequote . unwords . words . fromTagText . head . filter isTagText
-
-
- Here the complexity of interfacing to human written markup comes through. Some of the links are in italic, some are not - the filter drops all those that are not, until we find a pure text node. The unwords . words deletes all multiple spaces, replaces tabs and newlines with spaces and trims the front and back - a neat trick when dealing with text which has spacing at the source code but not when displayed. The final thing to take account of is that some papers are given with quotes around the name, some are not - dequote will remove the quotes if they exist.
-
-
- For completeness, we now present the entire example:
-
-
-spjPapers :: IO ()
-spjPapers = do
- tags <- liftM parseTags $ openURL "http://research.microsoft.com/~simonpj/"
- let links = map f $ sections (~== "<a>") $
- takeWhile (~/= "<a name=haskell>") $
- drop 5 $ dropWhile (~/= "<a name=current>") tags
- putStr $ unlines links
- where
- f :: [Tag] -> String
- f = dequote . unwords . words . fromTagText . head . filter isTagText
-
- dequote ('\"':xs) | last xs == '\"' = init xs
- dequote x = x
-
-
-
-Other Examples
-
-
- Several more examples are given in the Example file, including obtaining the (short) list of papers from my site, getting the current time and a basic XML validator. All can be invoked using the tagsoup executable program. All use very much the same style as presented here - writing screen scrapers follow a standard pattern. We present the code from two for enjoyment only.
-
-
-My Papers
-
-
-ndmPapers :: IO ()
-ndmPapers = do
- tags <- liftM parseTags $ openURL "http://www-users.cs.york.ac.uk/~ndm/downloads/"
- let papers = map f $ sections (~== "<li class=paper>") tags
- putStr $ unlines papers
- where
- f :: [Tag] -> String
- f xs = fromTagText (xs !! 2)
-
-
-UK Time
-
-
-currentTime :: IO ()
-currentTime = do
- tags <- liftM parseTags $ openURL "http://www.timeanddate.com/worldclock/city.html?n=136"
- let time = fromTagText (dropWhile (~/= "<strong id=ct>") tags !! 1)
- putStrLn time
-
-
-
-
-
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/Main.hs
@@ -0,0 +1,64 @@
+
+module Main(main) where
+
+import System.Environment
+import TagSoup.Sample
+import TagSoup.Test
+import TagSoup.Benchmark
+import Data.Char(toLower)
+
+
+helpMsg :: IO ()
+helpMsg = putStr $ unlines $
+ ["TagSoup, (C) Neil Mitchell 2006-2009"
+ ,""
+ ," tagsoup arguments"
+ ,""
+ ," may either be a local file, or a http[s]:// page"
+ ,""
+ ] ++ map f res
+ where
+ width = maximum $ map (length . fst) res
+ res = map g actions
+
+ g (nam,msg,Left _) = (nam,msg)
+ g (nam,msg,Right _) = (nam ++ " ",msg)
+
+ f (lhs,rhs) = " " ++ lhs ++ replicate (4 + width - length lhs) ' ' ++ rhs
+
+
+actions :: [(String, String, Either (IO ()) (String -> IO ()))]
+actions = [("test","Run the test suite",Left test)
+ ,("grab","Grab a web page",Right grab)
+ ,("parse","Parse a web page",Right parse)
+ ,("bench","Benchmark the parsing",Left time)
+ ,("benchfile","Benchmark the parsing of a file",Right timefile)
+ ,("validate","Validate a page",Right validate)
+ ,("lastmodifieddate","Get the wiki.haskell.org last modified date",Left haskellLastModifiedDateTime)
+ ,("spj","Simon Peyton Jones' papers",Left spjPapers)
+ ,("ndm","Neil Mitchell's papers",Left ndmPapers)
+ ,("time","Current time",Left currentTime)
+ ,("google","Google Tech News",Left googleTechNews)
+ ,("sequence","Creators on sequence.complete.org",Left rssCreators)
+ ,("table","Parse a table",Left $ print parseTable)
+ ,("help","This help message",Left helpMsg)
+ ]
+
+main :: IO ()
+main = do
+ args <- getArgs
+ case (args, lookup (map toLower $ head args) $ map (\(a,_,c) -> (a,c)) actions) of
+ ([],_) -> do
+ putStrLn "No arguments specifying, defaulting to test"
+ helpMsg
+ putStrLn $ replicate 70 '-'
+ test
+ (x:_,Nothing) -> putStrLn ("Error: unknown command " ++ x) >> helpMsg
+ ([_],Just (Left a)) -> a
+ (x:xs,Just (Left a)) -> do
+ putStrLn $ "Warning: expected no arguments to " ++ x ++ " but got: " ++ unwords xs
+ a
+ ([_,y],Just (Right a)) -> a y
+ (x:xs,Just (Right _)) -> do
+ putStrLn $ "Error: expected exactly one argument to " ++ x ++ " but got: " ++ unwords xs
+ helpMsg
diff --git a/test/TagSoup/Benchmark.hs b/test/TagSoup/Benchmark.hs
new file mode 100644
--- /dev/null
+++ b/test/TagSoup/Benchmark.hs
@@ -0,0 +1,184 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- test file, so OK
+
+module TagSoup.Benchmark where
+
+import Text.HTML.TagSoup
+
+import Control.DeepSeq
+import Control.Monad
+import Data.List
+import Data.Maybe
+import System.IO.Unsafe(unsafeInterleaveIO)
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import Data.Time.Clock.POSIX(getPOSIXTime)
+
+conf = 0.95
+
+
+timefile :: FilePath -> IO ()
+timefile file = do
+ -- use LBS to be most representative of real life
+ lbs <- LBS.readFile file
+ let str = LBS.unpack lbs
+ bs = BS.concat $ LBS.toChunks lbs
+ () <- LBS.length lbs `seq` length str `seq` BS.length bs `seq` return ()
+ benchWith (const str, const bs, const lbs) $ benchStatic (toInteger $ LBS.length lbs)
+
+
+sample :: String
+sample = " is " ++
+ " and some just random & test ><"
+
+nsample = genericLength sample :: Integer
+
+time :: IO ()
+time = benchWith (str,bs,lbs) benchVariable
+ where
+ str = \i -> concat $ genericReplicate i sample
+ bs = let s = BS.pack sample in \i -> BS.concat (genericReplicate i s)
+ lbs = let s = LBS.pack sample in \i -> LBS.concat (genericReplicate i s)
+
+
+
+benchWith :: (Integer -> String, Integer -> BS.ByteString, Integer -> LBS.ByteString)
+ -> ((Integer -> ()) -> IO [String]) -> IO ()
+benchWith (str,bs,lbs) bench = do
+ putStrLn "Timing parseTags in characters/second"
+ let header = map (:[]) ["(" ++ show (round $ conf * 100) ++ "% confidence)","String","BS","LBS"]
+ rows <- mapM row $ replicateM 3 [False,True]
+ mapM_ (putStrLn . strict . grid) $ delay2 $ header : rows
+ where
+ row [a,b,c] = do
+ let header = intercalate "," [g a "pos", g b "warn", g c "merge"]
+ g b x = (if b then ' ' else '!') : x
+ f x = bench $ \i -> rnf $ parseTagsOptions parseOptions{optTagPosition=a,optTagWarning=b,optTagTextMerge=c} $ x i
+ c1 <- f str
+ c2 <- f bs
+ c3 <- f lbs
+ return [[header],c1,c2,c3]
+
+ strict = reverse . reverse
+
+
+---------------------------------------------------------------------
+-- BENCHMARK ON THE SAMPLE INPUT
+
+disp xs = showUnit (floor xbar) ++ " (~" ++ rng ++ "%)"
+ where xbar = mean xs
+ rng = if length xs <= 1 then "?" else show (ceiling $ (range conf xs) * 100 / xbar)
+
+cons x = fmap (x:)
+
+
+aimTime = 0.3 :: Double -- seconds to aim for
+minTime = 0.2 :: Double -- below this a test is considered invalid
+
+
+-- given a number of times to repeat sample, return a list of what
+-- to display
+benchVariable :: (Integer -> ()) -> IO [String]
+benchVariable op = cons "?" $ f 10 []
+ where
+ f i seen | length seen > 9 = cons (" " ++ disp seen) $ return []
+ | otherwise = unsafeInterleaveIO $ do
+ now <- timer $ op i
+ let cps = if now == 0 then 0 else fromInteger (i * nsample) / now
+ if now < minTime || (null seen && now < aimTime) then do
+ let factor = min 7 $ max 2 $ floor $ aimTime / now
+ cons ("? " ++ disp [cps]) $ f (i * factor) []
+ else
+ cons (show (9 - length seen) ++ " " ++ disp (cps:seen)) $ f i (cps:seen)
+
+
+
+benchStatic :: Integer -> (Integer -> ()) -> IO [String]
+benchStatic nsample op = cons "?" $ f []
+ where
+ f seen | length seen > 9 = cons (" " ++ disp seen) $ return []
+ | otherwise = unsafeInterleaveIO $ do
+ now <- timer $ op $ genericLength seen
+ let cps = if now == 0 then 0 else fromInteger nsample / now
+ cons (show (9 - length seen) ++ " " ++ disp (cps:seen)) $ f (cps:seen)
+
+
+---------------------------------------------------------------------
+-- UTILITY FUNCTIONS
+
+-- | Given a number, show it using a unit and decimal place
+showUnit :: Integer -> String
+showUnit x = num ++ unit
+ where
+ units = " KMGTPEZY"
+ (use,skip) = splitAt 3 $ show x
+
+ unit = [units !! ((length skip + 2) `div` 3)]
+
+ dot = ((length skip - 1) `mod` 3) + 1
+ num = a ++ ['.' | b /= ""] ++ b
+ where (a,b) = splitAt dot use
+
+
+-- copied from the criterion package
+getTime :: IO Double
+getTime = (fromRational . toRational) `fmap` getPOSIXTime
+
+timer :: () -> IO Double
+timer x = do
+ start <- getTime
+ () <- return x
+ end <- getTime
+ return $ end - start
+
+
+-- display a grid
+grid :: [[String]] -> String
+grid xs = unlines $ map (concat . zipWith f cols) xs
+ where cols = map (maximum . map length) $ transpose xs
+ f n x = x ++ replicate (n+1 - length x) ' '
+
+
+-- display a series of grids over time
+-- when a grid gets to [] keep its value at that
+-- when all grids get to [] return []
+delay2 :: [[[String]]] -> [[[String]]]
+delay2 xs = map (map head) xs : (if all (null . tail) (concat xs) then [] else delay2 $ map (map tl) xs)
+ where tl (x:xs) = if null xs then x:xs else xs
+
+
+---------------------------------------------------------------------
+-- INSTANCES
+
+instance NFData a => NFData (Tag a) where
+ rnf (TagOpen x y) = rnf x `seq` rnf y
+ rnf (TagClose x) = rnf x
+ rnf (TagText x) = rnf x
+ rnf (TagComment x) = rnf x
+ rnf (TagWarning x) = rnf x
+ rnf (TagPosition x y) = () -- both are already ! bound
+
+
+---------------------------------------------------------------------
+-- STATISTICS
+-- Provided by Emily Mitchell
+
+confNs = let (*) = (,) in
+ [0.95 * 1.96
+ ,0.90 * 1.644]
+
+size :: [Double] -> Double
+size = genericLength
+
+mean :: [Double] -> Double
+mean xs = sum xs / size xs
+
+stddev :: [Double] -> Double
+stddev xs = sqrt $ sum [sqr (x - xbar) | x <- xs] / size xs
+ where xbar = mean xs
+ sqr x = x * x
+
+-- given a sample, and a required confidence
+-- of the mean (i.e. 2.5% = 0.025)
+range ::Double -> [Double] -> Double
+range conf xs = conf2 * stddev xs / sqrt (size xs)
+ where conf2 = fromMaybe (error $ "Unknown confidence interval: " ++ show conf) $ lookup conf confNs
diff --git a/test/TagSoup/Sample.hs b/test/TagSoup/Sample.hs
new file mode 100644
--- /dev/null
+++ b/test/TagSoup/Sample.hs
@@ -0,0 +1,207 @@
+
+module TagSoup.Sample where
+
+import Text.HTML.TagSoup
+
+import Control.Exception
+import Control.Monad
+import Data.List
+import System.Process
+import System.Directory
+import System.Exit
+import System.IO
+import Data.Functor
+import Prelude
+
+
+openItem :: String -> IO String
+openItem url
+ | not $ "http://" `isPrefixOf` url || "https://" `isPrefixOf` url =
+ readFile url
+openItem url = bracket
+ (openTempFile "." "tagsoup.tmp")
+ (\(file,hndl) -> removeFile file)
+ $ \(file,hndl) -> do
+ hClose hndl
+ putStrLn $ "Downloading: " ++ url
+ res <- system $ "wget " ++ url ++ " -O " ++ file
+ when (res /= ExitSuccess) $ error $ "Failed to download using wget: " ++ url
+ src <- readFile file
+ length src `seq` return src
+
+
+grab :: String -> IO ()
+grab x = openItem x >>= putStr
+
+parse :: String -> IO ()
+parse x = openItem x >>= putStr . show2 . parseTags
+ where
+ show2 [] = "[]"
+ show2 xs = "[" ++ concat (intersperseNotBroken "\n," $ map show xs) ++ "\n]\n"
+
+
+-- the standard intersperse has a strictness bug which sucks!
+intersperseNotBroken :: a -> [a] -> [a]
+intersperseNotBroken _ [] = []
+intersperseNotBroken sep (x:xs) = x : is xs
+ where
+ is [] = []
+ is (y:ys) = sep : y : is ys
+
+
+{-
+ This page was last modified on 9 September 2013, at 22:38.
+-}
+haskellLastModifiedDateTime :: IO ()
+haskellLastModifiedDateTime = do
+ src <- openItem "http://wiki.haskell.org/Haskell"
+ let lastModifiedDateTime = fromFooter $ parseTags src
+ putStrLn $ "wiki.haskell.org was last modified on " ++ lastModifiedDateTime
+ where fromFooter = unwords . drop 6 . words . innerText . take 2 . dropWhile (~/= "")
+
+
+googleTechNews :: IO ()
+googleTechNews = do
+ tags <- fmap parseTags $ openItem "http://news.google.com/?ned=us&topic=t"
+ let links = [ ascii name ++ " <" ++ maybe "unknown" shortUrl (lookup "href" atts) ++ ">"
+ | TagOpen "h2" [("class","title")]:TagText spaces:TagOpen "a" atts:TagText name:_ <- tails tags]
+ putStr $ unlines links
+ where
+ shortUrl x | "http://" `isPrefixOf` x = shortUrl $ drop 7 x
+ | "www." `isPrefixOf` x = shortUrl $ drop 4 x
+ | otherwise = takeWhile (/= '/') x
+
+ ascii ('\226':'\128':'\147':xs) = '-' : ascii xs
+ ascii ('\194':'\163':xs) = "#GBP " ++ ascii xs
+ ascii (x:xs) = x : ascii xs
+ ascii [] = []
+
+
+spjPapers :: IO ()
+spjPapers = do
+ tags <- parseTags <$> openItem "http://research.microsoft.com/en-us/people/simonpj/"
+ let links = map f $ sections (~== "") $
+ takeWhile (~/= "") $
+ drop 5 $ dropWhile (~/= "") tags
+ putStr $ unlines links
+ where
+ f :: [Tag String] -> String
+ f = dequote . unwords . words . fromTagText . head . filter isTagText
+
+ dequote ('\"':xs) | last xs == '\"' = init xs
+ dequote x = x
+
+
+ndmPapers :: IO ()
+ndmPapers = do
+ tags <- parseTags <$> openItem "http://community.haskell.org/~ndm/downloads/"
+ let papers = map f $ sections (~== "") tags
+ putStr $ unlines papers
+ where
+ f :: [Tag String] -> String
+ f xs = fromTagText (xs !! 2)
+
+
+currentTime :: IO ()
+currentTime = do
+ tags <- parseTags <$> openItem "http://www.timeanddate.com/worldclock/uk/london"
+ let time = fromTagText (dropWhile (~/= "") tags !! 1)
+ putStrLn time
+
+
+
+type Section = String
+data Package = Package {name :: String, desc :: String, href :: String}
+ deriving Show
+
+hackage :: IO [(Section,[Package])]
+hackage = do
+ tags <- fmap parseTags $ openItem "http://hackage.haskell.org/packages/archive/pkg-list.html"
+ return $ map parseSect $ partitions (~== "") tags
+ where
+ parseSect xs = (nam, packs)
+ where
+ nam = fromTagText $ xs !! 2
+ packs = map parsePackage $ partitions (~== "
") xs
+
+ parsePackage xs =
+ Package
+ (fromTagText $ xs !! 2)
+ (drop 2 $ dropWhile (/= ':') $ fromTagText $ xs !! 4)
+ (fromAttrib "href" $ xs !! 1)
+
+-- rssCreators Example: prints names of story contributors on
+-- sequence.complete.org. This content is RSS (not HTML), and the selected
+-- tag uses a different XML namespace "dc:creator".
+rssCreators :: IO ()
+rssCreators = do
+ tags <- fmap parseTags $ openItem "http://sequence.complete.org/node/feed"
+ putStrLn $ unlines $ map names $ partitions (~== "") tags
+ where names xs = fromTagText $ xs !! 1
+
+
+validate :: String -> IO ()
+validate x = putStr . unlines . g . f . parseTagsOptions opts =<< openItem x
+ where
+ opts = parseOptions{optTagPosition=True, optTagWarning=True}
+
+ f :: [Tag String] -> [String]
+ f (TagPosition row col:TagWarning warn:rest) =
+ ("Warning (" ++ show row ++ "," ++ show col ++ "): " ++ warn) : f rest
+ f (TagWarning warn:rest) =
+ ("Warning (?,?): " ++ warn) : f rest
+ f (_:rest) = f rest
+ f [] = []
+
+ g xs = xs ++ [if n == 0 then "Success, no warnings"
+ else "Failed, " ++ show n ++ " warning" ++ ['s'|n>1]]
+ where n = length xs
+
+-- | Parse a table
+parseTable:: [[[String]]]
+parseTable = do
+ let tags = parseTags tableExample
+ parseRow :: [Tag String] -> [String]
+ parseRow = map (innerText . takeWhile (~/="")) . sections (~== "")
+ dd = map (parseRow . takeWhile (~/= "")) . sections (~== " | ") $ tags
+ return dd
+ where
+ -- | Example from https://www.w3schools.com/html/html_tables.asp
+ tableExample =
+ " \n\
+ \ \n\
+ \ | Company | \n\
+ \ Contact | \n\
+ \ Country | \n\
+ \
\n\
+ \ \n\
+ \ | Alfreds Futterkiste | \n\
+ \ Maria Anders | \n\
+ \ Germany | \n\
+ \
\n\
+ \ \n\
+ \ | Centro comercial Moctezuma | \n\
+ \ Francisco Chang | \n\
+ \ Mexico | \n\
+ \
\n\
+ \ \n\
+ \ | Ernst Handel | \n\
+ \ Roland Mendel | \n\
+ \ Austria | \n\
+ \
\n\
+ \ \n\
+ \ | Island Trading | \n\
+ \ Helen Bennett | \n\
+ \ UK | \n\
+ \
\n\
+ \ \n\
+ \ | Laughing Bacchus Winecellars | \n\
+ \ Yoshi Tannamuri | \n\
+ \ Canada | \n\
+ \
\n\
+ \ \n\
+ \ | Magazzini Alimentari Riuniti | \n\
+ \ Giovanni Rovelli | \n\
+ \ Italy | \n\
+ \
\n\
+ \
"
diff --git a/test/TagSoup/Test.hs b/test/TagSoup/Test.hs
new file mode 100644
--- /dev/null
+++ b/test/TagSoup/Test.hs
@@ -0,0 +1,263 @@
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+
+module TagSoup.Test(test) where
+
+import Text.HTML.TagSoup
+import Text.HTML.TagSoup.Entity
+import Text.HTML.TagSoup.Match
+
+import Control.Monad
+import Data.List
+import Test.QuickCheck(Arbitrary(..), Testable(..), quickCheckWithResult, stdArgs,
+ Args(..), listOf, elements, Result(..))
+
+-- * The Test Monad
+
+type Test a = IO a
+
+pass :: Test ()
+pass = return ()
+
+runTest :: Test () -> IO ()
+runTest x = x >> putStrLn "All tests passed"
+
+(===) :: (Show a, Eq a) => a -> a -> IO ()
+a === b = if a == b then pass else fail $ "Does not equal: " ++ show a ++ " =/= " ++ show b
+
+check :: Testable prop => prop -> IO ()
+check prop = do
+ res <- quickCheckWithResult stdArgs{maxSuccess=1000} prop
+ case res of
+ Success{} -> pass
+ _ -> fail "Property failed"
+
+newtype HTML = HTML String deriving Show
+instance Arbitrary HTML where
+ arbitrary = fmap (HTML . concat) $ listOf $ elements frags
+ where frags = map (:[]) " \n!-#&;xy01[]?'\"" ++ ["CDATA","amp","gt","lt"]
+ shrink (HTML x) = map HTML $ zipWith (++) (inits x) (tail $ tails x)
+
+
+-- * The Main section
+
+test :: IO ()
+test = runTest $ do
+ warnTests
+ parseTests
+ optionsTests
+ renderTests
+ combiTests
+ positionTests
+ entityTests
+ lazyTags == lazyTags `seq` pass
+ matchCombinators
+
+
+{- |
+This routine tests the laziness of the TagSoup parser.
+For each critical part of the parser we provide a test input
+with a token of infinite size.
+Then the output must be infinite too.
+If the laziness is broken, then the output will stop early.
+We collect the thousandth character of the output of each test case.
+If computation of the list stops somewhere,
+you have found a laziness stopper.
+-}
+
+
+lazyTags :: [Char]
+lazyTags = map ((!!1000) . show . parseTags)
+ [cycle "Rhabarber"
+ ,repeat '&'
+ ,"<"++cycle "html"
+ ,"" === [TagOpen "!DOCTYPE" [("TEST","")]]
+ parseTags "" === [TagOpen "test" [("\"foo",""),("bar\"","")]]
+ parseTags "" === [TagOpen "test" [("baz",""),("\"foo\"","")]]
+ parseTags "" === [TagOpen "test" [("'foo",""),("bar'","")]]
+ parseTags "" === [TagOpen "test" [("bar",""),("'","")], TagClose "test"]
+ parseTags "" === [TagOpen "test2" [("a",""),("b","")]]
+ parseTags "" === [TagOpen "test2" [("''","")]]
+ parseTags "" === [TagClose "test"]
+ parseTags "" === [TagOpen "test" [], TagClose "test"]
+ parseTags "" === [TagOpen "test1" [("a","b")]]
+ parseTags "hello & world" === [TagText "hello & world"]
+ parseTags "hello @ world" === [TagText "hello @ world"]
+ parseTags "hello @ world" === [TagText "hello @ world"]
+ parseTags "hello @ world" === [TagText "hello @ world"]
+ parseTags "hello &haskell; world" === [TagText "hello &haskell; world"]
+ parseTags "hello \n\t world" === [TagText "hello \n\t world"]
+ parseTags "" === [TagOpen "a" [("href","http://www.google.com")]]
+ parseTags "" === [TagOpen "foo" [("bar","bar6baz")]]
+ parseTags "" === [TagOpen "foo" [("bar","bar&baz")]]
+ parseTags "hey &how are you" === [TagText "hey &how are you"]
+ parseTags "hey &how; are you" === [TagText "hey &how; are you"]
+ parseTags "hey & are you" === [TagText "hey & are you"]
+ parseTags "hey & are you" === [TagText "hey & are you"]
+
+ -- real cases reported by users
+ parseTags "↖x≧̸" === [TagText ['\x2196','x','\x2267','\x0338']]
+ parseTags "test � test" === [TagText "test ? test"]
+
+ parseTags "" === [TagOpen "a" [("href","series.php?view=single&ID=72710")]]
+
+ parseTags "" ===
+ [TagOpen "!DOCTYPE" [("HTML",""),("PUBLIC",""),("","-//W3C//DTD HTML 4.01//EN"),("","http://www.w3.org/TR/html4/strict.dtd")]]
+
+ parseTags "" === [TagOpen "script" [], TagText " if (x if (x if (x" === [TagOpen "SCRIPT" [("language","foo")], TagText " if (x" === [TagOpen "script" [], TagClose "script", TagOpen "test" []]
+
+ -- some escapes require trailing semicolons, see #28 and #27.
+ parseTags "one ∣ two" === [TagText "one \8739 two"]
+ parseTags "one &mid two" === [TagText "one &mid two"]
+ parseTags "one µ two" === [TagText "one \181 two"]
+ parseTags "one µ two" === [TagText "one \181 two"]
+
+optionsTests :: Test ()
+optionsTests = check $ \(HTML x) -> all (f x) $ replicateM 3 [False,True]
+ where
+ f str [pos,warn,merge] =
+ bool "merge" (not merge || adjacentTagText tags) &&
+ bool "warn" (warn || all (not . isTagWarning) tags) &&
+ bool "pos" (if pos then alternatePos tags else all (not . isTagPosition) tags)
+ where tags = parseTagsOptions parseOptions{optTagPosition=pos,optTagWarning=warn,optTagTextMerge=merge} str
+ bool x b = b || error ("optionsTests failed with " ++ x ++ " on " ++ show (pos,warn,merge,str,tags))
+
+ -- optTagTextMerge implies no adjacent TagText cells
+ -- and none separated by only warnings or positions
+ adjacentTagText = g True -- can the next be a tag text
+ where g i (x:xs) | isTagText x = i && g False xs
+ | isTagPosition x || isTagWarning x = g i xs
+ | otherwise = g True xs
+ g i [] = True
+
+ -- optTagPosition implies every element must be followed
+ -- by a position node, no two position nodes must be adjacent
+ -- and all positions must be increasing
+ alternatePos (TagPosition l1 c1 : x : TagPosition l2 c2 : xs)
+ | (l1,c1) <= (l2,c2) && not (isTagPosition x) = alternatePos $ TagPosition l2 c2 : xs
+ alternatePos [TagPosition l1 c1, x] | not $ isTagPosition x = True
+ alternatePos [] = True
+ alternatePos _ = False
+
+
+renderTests :: Test ()
+renderTests = do
+ let rp = renderTags . parseTags
+ rp "" === ""
+ rp "
" === "
"
+ rp "" === ""
+ rp "hello & world" === "hello & world"
+ rp "" === ""
+ rp "" === ""
+ rp "" === ""
+ rp "" === ""
+ rp "" === ""
+ rp "" === ""
+ rp "" === ""
+ escapeHTML "this is a &\" '" === "this is a &" <test> '"
+ check $ \(HTML x) -> let y = rp x in rp y == (y :: String)
+
+
+entityTests :: Test ()
+entityTests = do
+ lookupNumericEntity "65" === Just "A"
+ lookupNumericEntity "x41" === Just "A"
+ lookupNumericEntity "x4E" === Just "N"
+ lookupNumericEntity "x4e" === Just "N"
+ lookupNumericEntity "X4e" === Just "N"
+ lookupNumericEntity "Haskell" === Nothing
+ lookupNumericEntity "" === Nothing
+ lookupNumericEntity "89439085908539082" === Nothing
+ lookupNamedEntity "amp" === Just "&"
+ lookupNamedEntity "haskell" === Nothing
+ escapeXML "hello world" === "hello world"
+ escapeXML "hello & world" === "hello & world"
+
+
+combiTests :: Test ()
+combiTests = do
+ (TagText "test" ~== TagText "" ) === True
+ (TagText "test" ~== TagText "test") === True
+ (TagText "test" ~== TagText "soup") === False
+ (TagText "test" ~== "test") === True
+ (TagOpen "test" [] ~== "") === True
+ (TagOpen "test" [] ~== "") === False
+ (TagOpen "test" [] ~/= "") === True
+ (TagComment "foo" ~== "") === True
+ (TagComment "bar" ~== "") === True
+
+
+positionTests :: Test ()
+positionTests = do
+ let p = parseTagsOptions parseOptions{optTagPosition=True,optTagWarning=False}
+ p "&" === [TagPosition 1 1,TagOpen "a" [],TagPosition 1 4,TagText "&",TagPosition 1 5,TagClose "a"]
+ p "&#z" === [TagPosition 1 1,TagOpen "a" [],TagPosition 1 4,TagText "&#z"]
+ p "&xz" === [TagPosition 1 1,TagOpen "a" [],TagPosition 1 4,TagText "&xz"]
+ p "&" === [TagPosition 1 1,TagOpen "a" [],TagPosition 1 4,TagText "&"]
+ p "&1" === [TagPosition 1 1,TagOpen "a" [],TagPosition 1 4,TagText "&1"]
+ p "&" === [TagPosition 1 1,TagOpen "a" [],TagPosition 1 4,TagText "&"]
+ p "bar
" === [TagPosition 1 1,TagOpen "div" [],TagPosition 1 6,TagComment "foo",TagPosition 1 16,TagText "bar",TagPosition 1 19,TagClose "div"]
+ p "" === [TagPosition 1 1,TagOpen "div" [],TagPosition 1 6,TagOpen "?foo<" [("div","")]]
+ p "
" === [TagPosition 1 1,TagOpen "div" [],TagPosition 1 6,TagText "" === [TagPosition 1 1,TagOpen "div" [],TagPosition 1 6,TagComment "" === [TagPosition 1 10,TagText "x"]
+ p "" === [TagPosition 1 1,TagOpen "!html" []]
+
+
+warnTests :: Test ()
+warnTests = do
+ let p = parseTagsOptions parseOptions{optTagPosition=True,optTagWarning=True}
+ wt x = [(msg,c) | TagWarning msg:TagPosition _ c:_ <- tails $ p x]
+ wt "neil &foo bar" === [("Unknown entity: foo",6)]