xml-html-conduit-lens 0.3.2.1 → 0.3.2.2

raw patch · 9 files changed

+316/−117 lines, 9 filesdep ~xml-conduitPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: xml-conduit

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• LICENSE +1/−1
• example/books.hs +117/−0
• example/queries.hs +0/−106
• example/ridna-mova.hs +114/−0
• example/yandex-weather.hs +64/−0
• src/Text/Xml/Lens.hs +5/−2
• test/Doctest.hs +1/−1
• xml-html-conduit-lens.cabal +9/−7

@@ -1,3 +1,8 @@+0.3.2.2+=======++  * Supported `xml-conduit-1.4` and `lens-4.15`+ 0.3.2.1 ======= 

@@ -1,5 +1,5 @@ Copyright (c) 2013, Fumiaki Kinoshita-Copyright (c) 2014, Matvey Aksenov+Copyright (c) 2014-2016, Matvey Aksenov  All rights reserved. 

@@ -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 `<pages>` tags' content:+--+-- >>>  Text.putStr (appendPages doc)+-- <?xml version="1.0" encoding="UTF-8"?><books>+-- <book category="Language and library definition">+--     <title>Haskell 98 language and libraries: the Revised Report</title>+--     <author year="2003">Simon Peyton Jones</author>+--     <pages>272 pages</pages>+--     <price>£45.00</price>+-- </book>+-- <book category="Textbooks">+--     <title>Learn You a Haskell for Great Good!</title>+--     <author year="2011">Miran Lipovaca</author>+--     <pages>360 pages</pages>+-- </book>+-- <book category="Textbooks">+--     <title>Programming in Haskell</title>+--     <author year="2007">Graham Hutton</author>+--     <pages>200 pages</pages>+-- </book>+-- <book category="Textbooks">+--     <title>Real World Haskell</title>+--     <author year="2008">Bryan O'Sullivan, Don Stewart, and John Goerzen</author>+--     <pages>700 pages</pages>+-- </book>+-- <book category="TextBooks">+--     <title>The Fun of Programming</title>+--     <author year="2002">Jeremy Gibbons and Oege de Moor</author>+--     <pages>288 pages</pages>+-- </book>+-- <book category="Foundations">+--     <title>Types and Programming Languages</title>+--     <author year="2002">Benjamin C. Pierce</author>+--     <pages>645 pages</pages>+-- </book>+-- <book category="Joke">+--     <title>Functional Ikamusume</title>+--     <author>Team "Referential Transparent Sea Keepers"</author>+-- </book>+-- </books>+appendPages :: AsXmlDocument t => t -> t+appendPages =+  xml...node "pages".text <>~ " pages"

@@ -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 `<pages>` tag contents:------ >>> doc & appendPages & Text.putStr--- <?xml version="1.0" encoding="UTF-8"?><books>--- <book category="Language and library definition">---     <title>Haskell 98 language and libraries: the Revised Report</title>---     <author year="2003">Simon Peyton Jones</author>---     <pages>272 pages</pages>---     <price>£45.00</price>--- </book>--- <book category="Textbooks">---     <title>Learn You a Haskell for Great Good!</title>---     <author year="2011">Miran Lipovaca</author>---     <pages>360 pages</pages>--- </book>--- <book category="Textbooks">---     <title>Programming in Haskell</title>---     <author year="2007">Graham Hutton</author>---     <pages>200 pages</pages>--- </book>--- <book category="Textbooks">---     <title>Real World Haskell</title>---     <author year="2008">Bryan O'Sullivan, Don Stewart, and John Goerzen</author>---     <pages>700 pages</pages>--- </book>--- <book category="TextBooks">---     <title>The Fun of Programming</title>---     <author year="2002">Jeremy Gibbons and Oege de Moor</author>---     <pages>288 pages</pages>--- </book>--- <book category="Foundations">---     <title>Types and Programming Languages</title>---     <author year="2002">Benjamin C. Pierce</author>---     <pages>645 pages</pages>--- </book>--- <book category="Joke">---     <title>Functional Ikamusume</title>---     <author>Team "Referential Transparent Sea Keepers"</author>--- </book>--- </books>-appendPages :: AsXmlDocument t => t -> t-appendPages = xml...node "pages".text <>~ " pages"

@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings #-}+-- | The rendered version of the web-scraped articles+-- is available at <https://budueba.com/lessons.html>+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

@@ -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+--+-- @+-- <div class="current-weather__thermometer current-weather__thermometer_type_now">$temperature</div>+-- @+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+--+-- @+-- <div class="current-weather__comment">$condition</div>+-- @+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+  "ясно"                   -> "☀"+  "облачно"                -> "☁"+  "облачно с прояснениями" -> "☁"+  "туман"                  -> "☁"+  "дождь"                  -> "☂"+  "гроза"                  -> "☂"+  "снег"                   -> "☃"+  "небольшой снег"         -> "☃"+  "метель"                 -> "☃"+  _                        -> "?"

@@ -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 @@ --     <child2/> --     <child3/> -- </root>-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 #-} 

@@ -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"]

@@ -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 <matvey.aksenov@gmail.com>-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