module TagSoup.Sample where
import Text.HTML.TagSoup
import Network.HTTP
import Data.Char
import Data.List
openItem :: String -> IO String
openItem x | "http://" `isPrefixOf` x = getResponseBody =<< simpleHTTP (getRequest x)
| otherwise = readFile x
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"
intersperseNotBroken :: a -> [a] -> [a]
intersperseNotBroken _ [] = []
intersperseNotBroken sep (x:xs) = x : is xs
where
is [] = []
is (y:ys) = sep : y : is ys
haskellHitCount :: IO ()
haskellHitCount = do
tags <- fmap parseTags $ openItem "http://haskell.org/haskellwiki/Haskell"
let count = fromFooter $ head $ sections (~== "<div class=printfooter>") tags
putStrLn $ "haskell.org has been hit " ++ show count ++ " times"
where
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
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 <- fmap parseTags $ openItem "http://research.microsoft.com/en-us/people/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] -> String
f = dequote . unwords . words . fromTagText . head . filter isTagText
dequote ('\"':xs) | last xs == '\"' = init xs
dequote x = x
ndmPapers :: IO ()
ndmPapers = do
tags <- fmap parseTags $ openItem "http://community.haskell.org/~ndm/downloads/"
let papers = map f $ sections (~== "<li class=paper>") tags
putStr $ unlines papers
where
f :: [Tag String] -> String
f xs = fromTagText (xs !! 2)
currentTime :: IO ()
currentTime = do
tags <- fmap parseTags $ openItem "http://www.timeanddate.com/worldclock/city.html?n=136"
let res = fromTagText (dropWhile (~/= "<strong id=ct>") tags !! 1)
putStrLn res
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 (~== "<h3>") tags
where
parseSect xs = (nam, packs)
where
nam = fromTagText $ xs !! 2
packs = map parsePackage $ partitions (~== "<li>") xs
parsePackage xs =
Package
(fromTagText $ xs !! 2)
(drop 2 $ dropWhile (/= ':') $ fromTagText $ xs !! 4)
(fromAttrib "href" $ xs !! 1)
rssCreators :: IO ()
rssCreators = do
tags <- fmap parseTags $ openItem "http://sequence.complete.org/node/feed"
putStrLn $ unlines $ map names $ partitions (~== "<dc:creator>") 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