Lens.hs

{-# 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 = "<html><head><title>My Page</title></head><body><blink>Hello, world!</blink></body></html>" :: 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 -> "<span>&hearts;</span>" ^? htmlWith convert . element . contents
-- (Just "\9829",Just "&hearts;")
--
-- 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 = "<html><head><title>My Page</title></head><body><blink>Hello, world!</blink></body></html>" :: 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"
-- "<sgml><head><title>My Page</title></head><body><blink>Hello, world!</blink></body></sgml>"
-- >>> 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 = "<html xmlns=\"http://www.w3.org/1999/xhtml\"><head></head><body></body></html>" :: 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/"
-- "<html xmlns=\"http://www.w3.org/TR/html4/\"><head></head><body></body></html>"

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 = "<html><foo class=\"a\"></foo><bar class=\"b\"></bar></html>" :: 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 = "<html><foo class=\"a\"></foo><bar class=\"a\"></bar></html>" :: 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 = "<html><title>Your title goes here.</title><body>Your content goes here.</body></html>" :: 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!"]
-- "<html><title>Lenses!</title><body>Your content goes here.</body></html>"

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 = "<html><foo>bar</foo><baz>qux</baz><quux>corge</quux></html>" :: 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 = "<html><head><title>My Page</title></head><body><blink>Hello, world!</blink></body></html>" :: 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 = "<html><foo></foo><bar></bar><baz></baz></html>" :: 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 = "<foo>bar</foo>" :: Lazy.Text
-- >>> markup ^? html . element . children . traverse . content
-- Just "bar"
-- >>> markup & html . element . children . traverse . content .~ "baz"
-- "<foo>baz</foo>"

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 = "<html><foo></foo>bar<baz></baz>qux</html>" :: 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' = "<html><foo>foo</foo>bar<baz></baz>qux</html>" :: 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' = "<html><foo class=\"woah\">bar<qux><foo>baz</foo></qux></foo></html>" :: 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' = "<html><foo class=\"woah\">bar<qux class=\"woah\"></qux></foo><quux class=\"woah\"></quux></html>" :: 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