diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Alp Mestanogullari + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alp Mestanogullari nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Text/Taggy/Lens.hs b/src/Text/Taggy/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Text/Taggy/Lens.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE LambdaCase, Rank2Types #-} + +module Text.Taggy.Lens ( + Node(..), + Element(..), + name, + attrs, + children, + htmlWith, + html, + HasElement(..), + content, + attr, + attributed, + named, + HasElements(..), + HasContent(..), + allNamed, + allAttributed +) where + +import Control.Lens (Lens', Prism', Traversal', Fold, prism', (<&>), preview, ix, at, has, filtered, traverse, Plated(..), to, universe) +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import Text.Taggy (Element(..), Node(..), Renderable(..), domify, taggyWith) +import qualified Data.Text.Lazy as Lazy (Text) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Control.Lens hiding (element, elements, children) +-- >>> import qualified Data.Text.Lazy as Lazy (Text) +-- >>> import Data.Monoid +-- >>> import Data.Text as T +-- >>> import Control.Monad (join) +-- >>> import Data.Maybe + +-- | HTML document parsing and rendering. +-- +-- >>> let markup = "My PageHello, world!" :: Lazy.Text +-- >>> markup ^? htmlWith False +-- Just (NodeElement (Element {eltName = "html", eltAttrs = fromList [], eltChildren = [NodeElement (Element {eltName = "head", eltAttrs = fromList [], eltChildren = [NodeElement (Element {eltName = "title", eltAttrs = fromList [], eltChildren = [NodeContent "My Page"]})]}),NodeElement (Element {eltName = "body", eltAttrs = fromList [], eltChildren = [NodeElement (Element {eltName = "blink", eltAttrs = fromList [], eltChildren = [NodeContent "Hello, world!"]})]})]})) +-- >>> (markup ^? htmlWith False) ^. _Just . re (htmlWith False) == markup +-- True +-- +-- The provided boolean specifies whether named entities should be +-- translated to unicode. For a less general version of this prism, +-- with translation by default, see 'html.' +-- +-- >>> (True, False) & both %~ \convert -> "♥" ^? htmlWith convert . element . contents +-- (Just "\9829",Just "♥") +-- +-- The parser produces a single node; if markup describes more than one element at +-- the top-level, all but the first are discarded. +-- +-- >>> (markup <> markup) ^? htmlWith False == markup ^? htmlWith False +-- True + +htmlWith :: Bool -> Prism' Lazy.Text Node +htmlWith convertEntities = prism' (renderWith convertEntities) parse + where parse = preview (ix 0) . domify . taggyWith convertEntities + +-- | Like 'htmlWith', but converts named entities by default. +-- +-- >>> let markup = "My PageHello, world!" :: Lazy.Text +-- >>> markup ^? htmlWith True == markup ^? html +-- True + +html :: Prism' Lazy.Text Node +html = htmlWith True + +-- | A lens into the name of a given DOM element. + +-- >>> markup ^? html . element . name +-- Just "html" +-- >>> markup & html . element . name .~ "sgml" +-- "My PageHello, world!" +-- >>> markup ^.. html . elements . name +-- ["head", "body"] + +name :: Lens' Element Text +name f el = f (eltName el) <&> \n -> el {eltName=n} + +-- | A lens into the attributes of a given DOM element. +-- +-- >>> let markup = "" :: Lazy.Text +-- >>> markup ^? html . element . attrs +-- Just fromList [("xmlns","http://www.w3.org/1999/xhtml")] +-- >>> markup ^? html . element . attrs . at "xmlns" & join +-- Just "http://www.w3.org/1999/xhtml" +-- >>> markup ^? html . element . attrs . at "style" & join +-- Nothing +-- >>> markup & html . element . attrs . at "xmlns" ?~ "http://www.w3.org/TR/html4/" +-- "" + +attrs :: Lens' Element (HashMap Text Text) +attrs f el = f (eltAttrs el) <&> \as -> el {eltAttrs=as} + +-- | Given an attribute name, a lens into its value for a given element. +-- +-- >>> let markup = "" :: Lazy.Text +-- >>> markup ^.. htmlWith False . elements . attr "class" . _Just +-- ["a","b"] + +attr :: Text -> Lens' Element (Maybe Text) +attr = fmap attrs . at + +-- | A traversal into attributes matching a provided property. +-- +-- >>> let markup = "" :: Lazy.Text +-- >>> markup ^.. htmlWith False . elements . attributed (ix "class" . only "a") . name +-- ["foo","bar"] + +attributed :: Fold (HashMap Text Text) a -> Traversal' Element Element +attributed prop = filtered . has $ attrs . prop + +-- | A lens into the child nodes, elements, or contents of a given DOM element. +-- +-- >>> let markup = "Your title goes here.Your content goes here." :: Lazy.Text +-- >>> markup ^? html . element . children . ix 0 +-- Just (NodeElement (Element {eltName = "title", eltAttrs = fromList [], eltChildren = [NodeContent "Your title goes here."]})) +-- >>> markup & html . element . children . ix 0 . element . children .~ [NodeContent "Lenses!"] +-- "Lenses!Your content goes here." + +children :: Lens' Element [Node] +children f el = f (eltChildren el) <&> \cs -> el {eltChildren = cs} + +-- | A traversal into elements with a name matching a provided property. +-- +-- >>> let markup = "barquxcorge" :: Lazy.Text +-- >>> markup ^.. htmlWith False . elements . named (to T.length . only 3) . name +-- ["foo","baz"] + +named :: Fold Text a -> Traversal' Element Element +named prop = filtered . has $ name . prop + +-- | Construct a node from an element, or attempt to extract an element from a node. +-- +-- >>> let markup = "My PageHello, world!" :: Lazy.Text +-- >>> markup ^? html . element +-- Just (Element {eltName = "html", eltAttrs = fromList [], eltChildren = [NodeElement (Element {eltName = "head", eltAttrs = fromList [], eltChildren = [NodeElement (Element {eltName = "title", eltAttrs = fromList [], eltChildren = [NodeContent "My Page"]})]}),NodeElement (Element {eltName = "body", eltAttrs = fromList [], eltChildren = [NodeElement (Element {eltName = "blink", eltAttrs = fromList [], eltChildren = [NodeContent "Hello, world!"]})]})]}) +-- >>> markup ^? html . element. re element == markup ^? html +-- True + +class HasElement a where + element :: Prism' a Element + +instance HasElement Node where + element = prism' NodeElement $ \case { NodeElement e -> Just e; _ -> Nothing } + +instance HasElement Element where -- Iso + element = prism' id (Just . id) + +-- | A traversal into the immediate children of an element that are also elements, directly or via a Node. +-- +-- >>> let markup = "" :: Lazy.Text +-- >>> markup ^.. html . element . elements . name +-- ["foo","bar","baz"] +-- >>> markup ^.. html . elements . element . name +-- ["foo","bar","baz"] + +class HasElements a where + elements :: Traversal' a Element + +instance HasElements Element where + elements = children . traverse . element + +instance HasElements Node where + elements = element . elements + +-- | Construct a node from text, or attempt to extract text from a node. +-- +-- >>> let markup = "bar" :: Lazy.Text +-- >>> markup ^? html . element . children . traverse . content +-- Just "bar" +-- >>> markup & html . element . children . traverse . content .~ "baz" +-- "baz" + +content :: Prism' Node Text +content = prism' NodeContent $ \case { NodeContent c -> Just c; _ -> Nothing } + +-- | A traversal into the immediate children of an element that are text content, directly or via a Node. +-- +-- >>> let markup = "barqux" :: Lazy.Text +-- >>> markup ^.. html . element . contents +-- ["bar","qux"] +-- >>> markup ^.. html . contents +-- ["bar","qux"] + +class HasContent a where + contents :: Traversal' a Text + +instance HasContent Element where + contents = children . traverse . content + +instance HasContent Node where + contents = element . contents + +-- | Plated instances are available for Element and Node, such that we can retrieve all of their transitive descendants. +-- +-- >>> let markup' = "foobarqux" :: Lazy.Text +-- >>> markup' ^.. html . to universe . traverse . content +-- ["foo","bar","qux"] + +instance Plated Node where + plate = element . children . traverse + +instance Plated Element where + plate = elements + +-- | A fold into all elements (current and descendants) who's name satisfy a provided property. +-- +-- >>> let markup' = "barbaz" :: Lazy.Text +-- >>> markup' ^.. html . allNamed (only "foo") . contents +-- ["bar","baz"] +-- >>> markup' ^.. html . allNamed (only "foo") . attributed (ix "class" . only "woah") . contents +-- ["bar"] + +allNamed :: HasElement a => Fold Text b -> Fold a Element +allNamed prop = element . to universe . traverse . named prop + +-- | A fold into all elements (current and descendants) who's attributes satisfy a provided property. +-- +-- >>> let markup' = "bar" :: Lazy.Text +-- >>> markup' ^.. html . allAttributed (folded . only "woah") . name +-- ["foo","qux","quux"] +-- >>> markup' ^.. html . allAttributed (folded . only "woah") . named (only "foo") . name +-- ["foo"] + +allAttributed :: HasElement a => Fold (HashMap Text Text) b -> Fold a Element +allAttributed prop = element . to universe . traverse . attributed prop diff --git a/taggy-lens.cabal b/taggy-lens.cabal new file mode 100644 --- /dev/null +++ b/taggy-lens.cabal @@ -0,0 +1,109 @@ +name: taggy-lens +version: 0.1 +synopsis: Lenses for the taggy html/xml parser +description: + Lenses, folds, traversals and prisms for + . + . + This greatly simplifies your life when dealing with + the ugly world of Real Life HTML. Here's an example + : it lists the date, author and package name of + all the /recent package uploads/ entries from the hackage page of the same name. + Note that it uses to /fetch/ the + Hackage page. + . + > {-# LANGUAGE OverloadedStrings #-} + > + > module Main (main) where + > + > import Control.Lens (to, only,(^?),ix, toListOf) + > import Data.ByteString.Lazy (ByteString) + > import Data.Text (Text) + > import Data.Text.Encoding.Error (lenientDecode) + > import Data.Text.Lazy.Encoding (decodeUtf8With) + > import Network.HTTP.Client (Response) + > import Network.Wreq (responseBody, get) + > import Text.Taggy (Node) + > import Text.Taggy.Lens (html, elements, children, contents,allNamed) + > + > data Upload = + > Upload Text -- ^ date + > Text -- ^ author + > Text -- ^ package name + > deriving (Show) + > + > table :: [Node] -> Maybe Upload + > table row = do + > date <- row ^? ix 0 . contents + > author <- row ^? ix 1 . contents + > package <- row ^? ix 2 . elements . contents + > return $ Upload date author package + > + > recentPackages :: Response ByteString -> [Maybe Upload] + > recentPackages = toListOf + > $ responseBody . to (decodeUtf8With lenientDecode) + > . html . allNamed (only "tr") . children . to table + > + > main :: IO () + > main = get "https://hackage.haskell.org/packages/recent" >>= print `fmap` recentPackages +homepage: http://github.com/alpmestan/taggy-lens +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari, Vikram Verma +maintainer: alpmestan@gmail.com +copyright: 2014 Alp Mestanogullari, Vikram Verma +category: Text, Web +build-type: Simple +cabal-version: >= 1.10 + +library + exposed-modules: + Text.Taggy.Lens + build-depends: + base >= 4.5 && < 5, + lens >= 4, + taggy >= 0.1, + text, + unordered-containers + hs-source-dirs: + src + default-language: + Haskell2010 + ghc-options: + -O2 -Wall -fno-warn-orphans + +test-suite spec + type: + exitcode-stdio-1.0 + hs-source-dirs: + src, + test + main-is: + Spec.hs + build-depends: + base >= 4.5 && < 5, + taggy, + text, + lens >= 4, + unordered-containers, + hspec + default-language: + Haskell2010 + ghc-options: + -O2 -Wall -fno-warn-orphans + +test-suite doctests + type: + exitcode-stdio-1.0 + hs-source-dirs: + test + main-is: + DocTest.hs + ghc-options: + -threaded + build-depends: + base >= 4.5 && < 5, + doctest + default-language: + Haskell2010 diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Test.DocTest (doctest) + +main :: IO () +main = doctest ["src/Text/Taggy/Lens.hs"] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}