diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +0.3.2.2 +======= + + * Supported `xml-conduit-1.4` and `lens-4.15` + 0.3.2.1 ======= diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ Copyright (c) 2013, Fumiaki Kinoshita -Copyright (c) 2014, Matvey Aksenov +Copyright (c) 2014-2016, Matvey Aksenov All rights reserved. diff --git a/example/books.hs b/example/books.hs new file mode 100644 --- /dev/null +++ b/example/books.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} +module Books where + +import Control.Applicative -- base +import Control.Lens -- lens +import Data.Text (Text) -- text +import Text.Xml.Lens -- xml-html-conduit-lens + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Text.Xml.Lens +-- >>> import qualified Data.Text.Lazy.IO as Text +-- >>> doc <- Text.readFile "example/books.xml" + +-- | Titles of the books in the "Textbooks" category +-- +-- >>> toListOf titles doc +-- ["Learn You a Haskell for Great Good!","Programming in Haskell","Real World Haskell"] +titles :: AsXmlDocument t => Traversal' t Text +titles = + xml...attributed (ix "category".only "Textbooks").node "title".text + +-- | Authors of the books longer then 500 pages +-- +-- >>> toListOf authors doc +-- ["Bryan O'Sullivan, Don Stewart, and John Goerzen","Benjamin C. Pierce"] +authors :: AsXmlDocument t => Traversal' t Text +authors = + xml...filtered (has (node "pages".text.filtered (> "500"))).node "author".text + +-- | Titles and authors of the books in the "Textbooks" category +-- +-- >>> toListOf titlesAndAuthors doc +-- [("Learn You a Haskell for Great Good!","Miran Lipovaca"),("Programming in Haskell","Graham Hutton"),("Real World Haskell","Bryan O'Sullivan, Don Stewart, and John Goerzen")] +titlesAndAuthors :: AsXmlDocument t => Fold t (Text, Text) +titlesAndAuthors = + xml...attributed (ix "category".only "Textbooks").runFold (liftA2 (,) (Fold title) (Fold author)) + where + title, author :: Fold Element Text + title = node "title".text + author = node "author".text + +-- | Title of the third book in the list +-- +-- >>> preview thirdTitle doc +-- Just "Programming in Haskell" +thirdTitle :: AsXmlDocument t => Fold t Text +thirdTitle = + xml.parts.ix 2.node "title".text + +-- | All tags in the document. +-- +-- >>> toListOf allTags doc +-- ["books","book","title","author","pages","price","book","title","author","pages","book","title","author","pages","book","title","author","pages","book","title","author","pages","book","title","author","pages","book","title","author"] +allTags :: AsXmlDocument t => Fold t Text +allTags = + xml.folding universe.name + +-- | Compute the length of the books list: +-- +-- >>> lengthOf allBooks doc +-- 7 +allBooks :: AsXmlDocument t => Traversal' t Element +allBooks = + xml.plate + +-- | Find the title of the first book in the "Joke" category: +-- +-- >>> preview titleOfFirstJokeBook doc +-- Just "Functional Ikamusume" +titleOfFirstJokeBook :: AsXmlDocument t => Traversal' t Text +titleOfFirstJokeBook = + xml...attributed (ix "category".only "Joke").node "title".text + +-- | Append the string " pages" to `` tags' content: +-- +-- >>> Text.putStr (appendPages doc) +-- +-- +-- Haskell 98 language and libraries: the Revised Report +-- Simon Peyton Jones +-- 272 pages +-- £45.00 +-- +-- +-- Learn You a Haskell for Great Good! +-- Miran Lipovaca +-- 360 pages +-- +-- +-- Programming in Haskell +-- Graham Hutton +-- 200 pages +-- +-- +-- Real World Haskell +-- Bryan O'Sullivan, Don Stewart, and John Goerzen +-- 700 pages +-- +-- +-- The Fun of Programming +-- Jeremy Gibbons and Oege de Moor +-- 288 pages +-- +-- +-- Types and Programming Languages +-- Benjamin C. Pierce +-- 645 pages +-- +-- +-- Functional Ikamusume +-- Team "Referential Transparent Sea Keepers" +-- +-- +appendPages :: AsXmlDocument t => t -> t +appendPages = + xml...node "pages".text <>~ " pages" diff --git a/example/queries.hs b/example/queries.hs deleted file mode 100644 --- a/example/queries.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Queries where - -import Control.Applicative -- base -import Control.Lens -- lens -import Data.Text (Text) -- text -import Text.Xml.Lens -- xml-html-conduit-lens - --- $setup --- >>> :set -XOverloadedStrings --- >>> import Text.Xml.Lens --- >>> import qualified Data.Text.Lazy.IO as Text --- >>> doc <- Text.readFile "example/books.xml" - --- | List titles of the books in "Textbooks" category: --- --- >>> doc ^.. listTitles --- ["Learn You a Haskell for Great Good!","Programming in Haskell","Real World Haskell"] -listTitles :: AsXmlDocument t => Traversal' t Text -listTitles = xml...attributed (ix "category".only "Textbooks").node "title".text - --- | List authors of the books longer then 500 pages: --- --- >>> doc ^.. listAuthors --- ["Bryan O'Sullivan, Don Stewart, and John Goerzen","Benjamin C. Pierce"] -listAuthors :: AsXmlDocument t => Traversal' t Text -listAuthors = xml...filtered (has (node "pages".text.filtered (> "500"))).node "author".text - --- | List titles and authors of the books in "Textbooks" category --- --- >>> doc ^.. listTitlesAndAuthors --- [("Learn You a Haskell for Great Good!","Miran Lipovaca"),("Programming in Haskell","Graham Hutton"),("Real World Haskell","Bryan O'Sullivan, Don Stewart, and John Goerzen")] -listTitlesAndAuthors :: AsXmlDocument t => Fold t (Text, Text) -listTitlesAndAuthors = xml...attributed (ix "category".only "Textbooks") - .runFold (liftA2 (,) (Fold (node "title".text)) (Fold (node "author".text))) - --- | Lists the title of the third book in the list --- --- >>> doc ^? listThirdTitle --- Just "Programming in Haskell" -listThirdTitle :: AsXmlDocument t => Fold t Text -listThirdTitle = xml.parts.ix 2.node "title".text - --- | List all tags from top to bottom: --- --- >>> doc ^.. listAllTags --- ["books","book","title","author","pages","price","book","title","author","pages","book","title","author","pages","book","title","author","pages","book","title","author","pages","book","title","author","pages","book","title","author"] -listAllTags :: AsXmlDocument t => Fold t Text -listAllTags = xml.folding universe.name - --- | Compute the length of the books list: --- --- >>> doc & countBooks --- 7 -countBooks :: AsXmlDocument t => t -> Int -countBooks = lengthOf (xml.plate) - --- | Find the title of the first book in "Joke" category: --- --- >>> doc ^? titleOfFirstJokeBook --- Just "Functional Ikamusume" -titleOfFirstJokeBook :: AsXmlDocument t => Traversal' t Text -titleOfFirstJokeBook = xml...attributed (ix "category".only "Joke").node "title".text - --- | Append the string " pages" to each `` tag contents: --- --- >>> doc & appendPages & Text.putStr --- --- --- Haskell 98 language and libraries: the Revised Report --- Simon Peyton Jones --- 272 pages --- £45.00 --- --- --- Learn You a Haskell for Great Good! --- Miran Lipovaca --- 360 pages --- --- --- Programming in Haskell --- Graham Hutton --- 200 pages --- --- --- Real World Haskell --- Bryan O'Sullivan, Don Stewart, and John Goerzen --- 700 pages --- --- --- The Fun of Programming --- Jeremy Gibbons and Oege de Moor --- 288 pages --- --- --- Types and Programming Languages --- Benjamin C. Pierce --- 645 pages --- --- --- Functional Ikamusume --- Team "Referential Transparent Sea Keepers" --- --- -appendPages :: AsXmlDocument t => t -> t -appendPages = xml...node "pages".text <>~ " pages" diff --git a/example/ridna-mova.hs b/example/ridna-mova.hs new file mode 100644 --- /dev/null +++ b/example/ridna-mova.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | The rendered version of the web-scraped articles +-- is available at +module Main (main) where + +import Control.Lens -- lens +import qualified Data.ByteString.Lazy as ByteString.Lazy -- bytestring +import Data.List.Lens (prefixed) -- lens +import Data.Monoid ((<>), Endo) -- base +import Data.Text (Text) -- text +import Data.Text.Lens (unpacked) -- lens +import qualified Data.Text as Text -- text +import qualified Data.Text.IO as Text -- text +import Data.Traversable (for) -- base +import qualified Network.HTTP.Conduit as Http -- http-conduit +import Text.Printf (printf) -- base +import Text.Xml.Lens -- xml-html-conduit-lens + + +-- | Scrap "Уроки державної мови" articles from the Web +-- +-- Minor spacing issues are possible. The pages aren't structured properly +-- level-1 headings are misinterpreted as level-2 headings. +-- +-- The output is a compilation of the articles in the Github Flavored Markdown format +main :: IO () +main = do + man <- Http.newManager Http.tlsManagerSettings + as <- for [2002, 2003, 2004] $ \roka -> do + req <- Http.parseUrl (url roka) + res <- Http.httpLbs req man + pure (articles (toListOf atoms (roundtrip (Http.responseBody res)))) + (mapM_.mapM_) (Text.putStrLn . renderArticle) as + where + -- Concatenate chunks of the "lazy" bytestring to work around a html-conduit bug + roundtrip = ByteString.Lazy.fromStrict . ByteString.Lazy.toStrict + +-- | Construct the page URL for the given year +url :: Int -> String +url = + printf "https://sites.google.com/site/mandrivnyjvolhv/ridna-vira/ridna-mova/boris-rogoza/%d" + +data Article = Article + { heading :: Text + , content :: [Text] + , table :: Table + } deriving (Show) + +type Table = [(Text, Text)] + +renderArticle :: Article -> Text +renderArticle Article { heading = h, content = c, table = t } = Text.intercalate "\n" $ + [h, Text.replicate (Text.length h) "-"] ++ map (<> "\n") c ++ [renderTable t | not (null t)] + +renderTable :: Table -> Text +renderTable xs = Text.unlines $ + ["Неправильно | Правильно", " :--------: | :-----: "] ++ map (uncurry (\a b -> a <> " | " <> b)) xs + +-- | Convert a stream of data (headings and paragraphs) to well-formed articles +articles :: [Atom] -> [Article] +articles = go Nothing + where + go mh xs = case span (isn't _Heading) xs of + (ys, Heading h' : zs) -> case mh of + Nothing -> go (Just h') zs + Just h -> Article { + heading = h + , content = toListOf (folded._Paragraph) ys + , table = view (folded._Table) ys + } : go (Just h') zs + (ys, []) -> case mh of + Nothing -> [] + Just h -> pure Article { + heading = h + , content = toListOf (folded._Paragraph) ys + , table = view (folded._Table) ys + } + (_, _) -> error "Impossible!" + + +data Atom = Heading Text | Paragraph Text | Table Table + +_Heading, _Paragraph :: Prism' Atom Text +_Table :: Prism' Atom Table +_Heading = prism' Heading (\x -> case x of Heading h -> Just h; _ -> Nothing) +_Paragraph = prism' Paragraph (\x -> case x of Paragraph t -> Just t; _ -> Nothing) +_Table = prism' Table (\x -> case x of Table l -> Just l; _ -> Nothing) + +-- | Combine headings, contents, and tables into the single 'Fold' +atoms :: AsHtmlDocument x => Getting (Endo [Atom]) x Atom +atoms = html.folding universe.(headings <> paragraphs <> tables) + +-- | Parse articles' headings +headings :: Fold Element Atom +headings = named (only "h2").filtered (has (node "a".attributed (ix "name".unpacked.prefixed "__RefHeading"))).accText Heading + +-- | Parse articles' contents +paragraphs :: Fold Element Atom +paragraphs = named (only "p").with "style" "margin-top:0.49cm;margin-bottom:0.49cm".accText Paragraph + +-- | Parse articles' tables +tables :: Fold Element Atom +tables = named (only "table").with "cellpadding" "0".with "cellspacing" "1".with "width" "564".plate.plate.partsOf (runFold ((,) <$> Fold (ix 0.node "p".text.to reassemble) <*> Fold (ix 1.node "p".text.to reassemble))).to Table + +with :: Applicative f => Name -> Text -> (Element -> f Element) -> Element -> f Element +with k v = attributed (ix k.only v) + +-- | Sanitize the HTML node text content +accText :: (Functor f, Contravariant f) => (Text -> a) -> (a -> f a) -> Element -> f Element +accText c = partsOf texts.to (c . Text.strip . Text.replace "\n" " " . mconcat) + +-- | Remove superfluous whitespace from the table rows +reassemble :: Text -> Text +reassemble = Text.unwords . Text.words diff --git a/example/yandex-weather.hs b/example/yandex-weather.hs new file mode 100644 --- /dev/null +++ b/example/yandex-weather.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Error (note) -- errors +import Control.Lens -- lens +import Data.Monoid (First) -- base +import Data.Text (Text) -- text +import qualified Data.Text as Text -- text +import qualified Data.Text.IO as Text -- text +import Network.HTTP.Conduit (simpleHttp) -- http-conduit +import System.Exit (die) -- base +import Text.Xml.Lens -- xml-html-conduit-lens + +{-# ANN module ("HLint: ignore Avoid lambda" :: String) #-} + + +main :: IO () +main = + either die Text.putStrLn . parseWeather =<< simpleHttp "http://pogoda.yandex.ru/zelenograd/" + +-- | Parse yandex response. The following errors are possible: +-- +-- * HTML served may be invalid +-- * HTML served may not have temperature and weather condition in it +parseWeather :: AsHtmlDocument t => t -> Either String Text +parseWeather raw = do + htmlDoc <- note "Invalid HTML, no weather for you!" $ + preview html raw + weather <- note "Valid but unparseable HTML, no weather for you!" $ + mapM (\l -> preview l htmlDoc) [temperature, condition.unicoded] + pure (Text.unwords weather) + +-- | Parse temperature from HTML document encoded as +-- +-- @ +--
$temperature
+-- @ +temperature :: Getting (First Text) Element Text +temperature = + folding universe.attributed (ix "class".only "current-weather__thermometer current-weather__thermometer_type_now").text + +-- | Parse weather condition from HTML document encoded as +-- +-- @ +--
$condition
+-- @ +condition :: Getting (First Text) Element Text +condition = + folding universe.attributed (ix "class".only "current-weather__comment").text + +-- | Get a nice unicode "picture" for a weather condition +unicoded :: Getting (First Text) Text Text +unicoded = to $ \case + "ясно" -> "☀" + "облачно" -> "☁" + "облачно с прояснениями" -> "☁" + "туман" -> "☁" + "дождь" -> "☂" + "гроза" -> "☂" + "снег" -> "☃" + "небольшой снег" -> "☃" + "метель" -> "☃" + _ -> "?" diff --git a/src/Text/Xml/Lens.hs b/src/Text/Xml/Lens.hs --- a/src/Text/Xml/Lens.hs +++ b/src/Text/Xml/Lens.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} @@ -60,7 +61,9 @@ , module Text.Xml.Lens.LowLevel ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative +#endif import Control.Exception (SomeException) import Control.Exception.Lens (exception) import Control.Lens @@ -192,12 +195,12 @@ -- -- -- -renderWith :: AsXmlDocument t => (RenderSettings -> RenderSettings) -> Fold Element t +renderWith :: (Functor f, Contravariant f, AsXmlDocument t) => (RenderSettings -> RenderSettings) -> LensLike' f Element t renderWith r = to (\e -> Document (Prologue [] Nothing []) e []) . re (_XmlDocumentWith id r) {-# INLINE renderWith #-} -- | Fold 'Element' into the XML document with the default rendering settings -render :: AsXmlDocument t => Fold Element t +render :: (Functor f, Contravariant f, AsXmlDocument t) => LensLike' f Element t render = renderWith id {-# INLINE render #-} diff --git a/test/Doctest.hs b/test/Doctest.hs --- a/test/Doctest.hs +++ b/test/Doctest.hs @@ -4,4 +4,4 @@ main :: IO () -main = doctest ["-isrc", "src/Text/Xml/Lens.hs", "example/queries.hs"] +main = doctest ["-isrc", "src/Text/Xml/Lens.hs", "example/books.hs", "example/namespaces.hs"] diff --git a/xml-html-conduit-lens.cabal b/xml-html-conduit-lens.cabal --- a/xml-html-conduit-lens.cabal +++ b/xml-html-conduit-lens.cabal @@ -1,5 +1,5 @@ name: xml-html-conduit-lens -version: 0.3.2.1 +version: 0.3.2.2 synopsis: Optics for xml-conduit and html-conduit description: Optics for xml-conduit and html-conduit homepage: https://github.com/supki/xml-html-conduit-lens#readme @@ -7,15 +7,17 @@ license-file: LICENSE author: Fumiaki Kinoshita, Matvey Aksenov maintainer: Matvey Aksenov -copyright: Copyright (C) 2013 Fumiaki Kinoshita, 2014 Matvey Aksenov +copyright: Copyright (C) 2013 Fumiaki Kinoshita, 2014-2016 Matvey Aksenov category: Control build-type: Simple cabal-version: >= 1.10 extra-source-files: README.md CHANGELOG.md - example/queries.hs + example/books.hs example/books.xml + example/ridna-mova.hs + example/yandex-weather.hs source-repository head type: git @@ -23,7 +25,7 @@ source-repository this type: git - tag: 0.3.2.1 + tag: 0.3.2.2 location: https://github.com/supki/xml-html-conduit-lens library @@ -34,8 +36,8 @@ , bytestring , lens >= 4.0.1 , containers >= 0.4.0 && < 0.6 - , text >= 0.11 && < 1.2 - , xml-conduit >= 1.1 && < 1.3 + , text >= 0.11 && < 1.3 + , xml-conduit >= 1.1 && < 1.5 , html-conduit >= 1.1 && < 1.3 hs-source-dirs: src @@ -64,7 +66,7 @@ , hspec , hspec-expectations-lens >= 0.3 , lens >= 4.0 - , xml-conduit >= 1.1 && < 1.3 + , xml-conduit >= 1.1 && < 1.4 , xml-html-conduit-lens other-modules: Text.Xml.LensSpec