{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Optics for xml-conduit and html-conduit
module Text.Xml.Lens
  ( -- * Document
    Document
  , xml
  , html
  , root
  , renderWith
  , render
  , Prologue
  , prolog
  , epilog
  , AsXmlDocument(..)
  , ParseSettings
  , RenderSettings
  , _XmlDocument
  , AsHtmlDocument(..)
    -- * Doctype
  , Doctype
  , doctype
  , beforeDoctype
  , afterDoctype
    -- * Element
  , Element
  , ixOf
  , node
  , named
  , attrs
  , attr
  , attributed
  , text
  , texts
  , HasComments(..)
  , HasInstructions(..)
    -- * Name
  , Name
  , name
  , namespace
  , prefix
  , HasName(..)
    -- * Instruction
  , Instruction
  , target
  , data_
    -- * exceptions
  , UnresolvedEntityException
  , XMLException
  , _MissingRootElement
  , _ContentAfterRoot
  , _InvalidInlineDoctype
  , _MissingEndElement
  , _UnterminatedInlineDoctype
  , AsUnresolvedEntityException(..)
  , AsXMLException(..)
  , AsInvalidEventStream(..)
  , module Text.Xml.Lens.LowLevel
  ) where

import           Control.Applicative
import           Control.Exception (SomeException)
import           Control.Exception.Lens (exception)
import           Control.Lens
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Lazy as TL
import           Data.Text (Text)
import           Data.Map (Map)
import           Text.XML
  ( ParseSettings, RenderSettings
  , Document(Document), Doctype, Prologue(Prologue)
  , Node(..), Element, Instruction, Name, Miscellaneous(..)
  , XMLException(..), UnresolvedEntityException(..)
  , parseLBS, parseText, renderLBS, renderText, def
  )
import           Text.XML.Stream.Parse (EventPos)
import           Text.XML.Unresolved (InvalidEventStream(..))
import qualified Text.HTML.DOM as Html

import           Text.Xml.Lens.LowLevel

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import           Data.List.Lens (prefixed)
-- >>> import           Data.Text.Lens (unpacked)
-- >>> import qualified Data.Text as Text
-- >>> import qualified Text.XML as XML

-- | XML document parsing and rendering overloading
--
-- This is a general version; for parsing/rendering with the
-- default options see '_XmlDocument'
class AsXmlDocument t where
  _XmlDocumentWith
    :: (ParseSettings -> ParseSettings) -> (RenderSettings -> RenderSettings) -> Prism' t Document

instance AsXmlDocument Document where
  _XmlDocumentWith _ _ = id
  {-# INLINE _XmlDocumentWith #-}

instance AsXmlDocument BL.ByteString where
  _XmlDocumentWith p r = prism' (renderLBS (r def)) (either (const Nothing) Just . parseLBS (p def))
  {-# INLINE _XmlDocumentWith #-}

instance AsXmlDocument TL.Text where
  _XmlDocumentWith p r = prism' (renderText (r def)) (either (const Nothing) Just . parseText (p def))
  {-# INLINE _XmlDocumentWith #-}

-- | XML document parsing and rendering with the default settings
_XmlDocument :: AsXmlDocument t => Prism' t Document
_XmlDocument = _XmlDocumentWith def def
{-# INLINE _XmlDocument #-}

-- | HTML document parsing overloading
class AsHtmlDocument t where
  _HtmlDocument :: Fold t Document

instance AsHtmlDocument Document where
  _HtmlDocument = id
  {-# INLINE _HtmlDocument #-}

instance AsHtmlDocument BL.ByteString where
  _HtmlDocument = to Html.parseLBS
  {-# INLINE _HtmlDocument #-}

-- | A Traversal into XML document root node
--
-- >>> ("<foo/>" :: TL.Text) ^? xml.name
-- Just "foo"
--
-- >>> ("<foo><bar/><baz/></foo>" :: TL.Text) ^? xml.name
-- Just "foo"
--
-- >>> ("<foo/>" :: TL.Text) & xml.name .~ "boo"
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><boo/>"
xml :: AsXmlDocument t => Traversal' t Element
xml = _XmlDocument . documentRoot
{-# INLINE xml #-}

-- | A Fold into HTML document root node
--
-- Not every parseable HTML document is a valid XML document:
--
-- >>> let quasiXml = "<html><br><br></html>" :: BL.ByteString
--
-- >>> quasiXml ^.. html...name
-- ["br","br"]
--
-- >>> quasiXml ^? xml...name
-- Nothing
html :: AsHtmlDocument t => Fold t Element
html = _HtmlDocument . documentRoot
{-# INLINE html #-}

-- | An alias for 'xml'
root :: AsXmlDocument t => Traversal' t Element
root = xml
{-# INLINE root #-}

-- | A Traversal into XML prolog
prolog :: AsXmlDocument t => Traversal' t Prologue
prolog = _XmlDocument . documentPrologue
{-# INLINE prolog #-}

-- | Fold 'Element' into the XML document
--
-- Convenience function mostly useful because @xml-conduit@ does not
-- provide handy method to convert 'Element' into text. Assumes empty XML prolog
--
-- See also 'render'
--
-- >>> :{
--   let
--     bare l   = (l, Data.Map.empty, [])
--     tag l    = _Element # bare l
--     subtag l = _NodeElement._Element # bare l
--     doc      = tag "root"
--         & elementNodes <>~ [subtag "child1", subtag "child2", subtag "child3"]
--         & elementNodes %~ (subtag "child0" <|)
-- :}
--
-- >>> Data.Text.Lazy.IO.putStr $ doc ^. render
-- <?xml version="1.0" encoding="UTF-8"?><root><child0/><child1/><child2/><child3/></root>
--
-- >>> Data.Text.Lazy.IO.putStr $ doc ^. renderWith (rsPretty .~ True)
-- <?xml version="1.0" encoding="UTF-8"?>
-- <root>
--     <child0/>
--     <child1/>
--     <child2/>
--     <child3/>
-- </root>
renderWith :: AsXmlDocument t => (RenderSettings -> RenderSettings) -> Fold 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 = renderWith id
{-# INLINE render #-}

-- | A Lens into XML DOCTYPE declaration
--
-- >>> let doc = "<!DOCTYPE foo><root/>" :: TL.Text
--
-- >>> doc ^? prolog.doctype.folded.doctypeName
-- Just "foo"
--
-- >>> doc & prolog.doctype.traverse.doctypeName .~ "moo"
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><!DOCTYPE moo><root/>"
--
-- Since @doctype@'s a Lens, it's possible to attach DOCTYPE declaration
-- to an XML document which didn't have it before:
--
-- >>> ("<root/>" :: TL.Text) & prolog.doctype ?~ XML.Doctype "moo" Nothing
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><!DOCTYPE moo><root/>"
doctype :: Lens' Prologue (Maybe Doctype)
doctype = prologueDoctype
{-# INLINE doctype #-}

-- | A Lens into nodes before XML DOCTYPE declaration
--
-- >>> let doc = "<!--foo--><!DOCTYPE bar><!--baz--><root/>" :: TL.Text
--
-- >>> doc ^? prolog.beforeDoctype.folded.comments
-- Just "foo"
--
-- >>> doc & prolog.beforeDoctype.traverse.comments %~ Text.toUpper
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><!--FOO--><!DOCTYPE bar><!--baz--><root/>"
beforeDoctype :: Lens' Prologue [Miscellaneous]
beforeDoctype = prologueBefore
{-# INLINE beforeDoctype #-}

-- | A Lens into nodes after XML DOCTYPE declaration
--
-- >>> let doc = "<!--foo--><!DOCTYPE bar><!--baz--><root/>" :: TL.Text
--
-- >>> doc ^? prolog.afterDoctype.folded.comments
-- Just "baz"
--
-- >>> doc & prolog.afterDoctype.traverse.comments %~ Text.toUpper
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><!--foo--><!DOCTYPE bar><!--BAZ--><root/>"
afterDoctype :: Lens' Prologue [Miscellaneous]
afterDoctype = prologueAfter
{-# INLINE afterDoctype #-}

-- | A Traversal into XML epilog
--
-- >>> let doc = "<root/><!--qux--><?foo bar?><!--quux-->" :: TL.Text
--
-- >>> doc ^.. epilog.folded.comments
-- ["qux","quux"]
--
-- >>> doc ^.. epilog.folded.instructions.target
-- ["foo"]
--
-- >>> doc & epilog .~ []
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root/>"
epilog :: AsXmlDocument t => Traversal' t [Miscellaneous]
epilog = _XmlDocument . documentEpilogue
{-# INLINE epilog #-}

type instance Index Element = Int
type instance IxValue Element = Element

-- | Index child 'Element's by an 'Int'
--
-- >>> let doc = "<root>zero<foo>one</foo><bar>two</bar>three<baz/>four</root>" :: TL.Text
--
-- >>> doc ^? xml.parts.ix 1.text
-- Just "two"
--
-- To index subnodes indexed by a Traversal', use 'ixOf'
instance Ixed Element where
  ix n = parts . ix n
  {-# INLINE ix #-}

-- | Index subnodes selected with a 'Traversal' by an 'Int'
--
-- >>> let doc = "<root>zero<foo>one</foo><bar>two</bar>three<baz/>four</root>" :: TL.Text
--
-- >>> doc ^? xml.ixOf _NodeContent 2
-- Just "four"
ixOf :: Traversal' Node a -> Index Element -> Traversal' Element a
ixOf p n = partsOf (insideOf p) . ix n
{-# INLINE ixOf #-}

-- | Traverse immediate children
--
-- >>> let doc = "<root><foo>4</foo><foo>7</foo><bar>11</bar></root>" :: TL.Text
--
-- >>> doc ^.. xml...name
-- ["foo","foo","bar"]
--
-- >>> doc & partsOf (root...name) .~ ["boo", "hoo", "moo"]
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root><boo>4</boo><hoo>7</hoo><moo>11</moo></root>"
instance Plated Element where
  plate = insideOf _NodeElement
  {-# INLINE plate #-}

insideOf :: Traversal Node Node a b -> Traversal Element Element a b
insideOf p = elementNodes . traverse . p
{-# INLINE insideOf #-}

-- | Traverse immediate children with a specific name
--
-- >>> let doc = "<root><foo>boo</foo><foo>hoo</foo><bar>moo</bar></root>" :: TL.Text
--
-- >>> doc ^. xml.node "foo".text
-- "boohoo"
--
-- >>> doc ^? xml.node "bar".text
-- Just "moo"
--
-- >>> doc ^? xml.node "baz".text
-- Nothing
node :: Name -> Traversal' Element Element
node n = elementNodes . traverse . _NodeElement . named (only n)
{-# INLINE node #-}

-- | Select nodes by name
--
-- >>> let doc = "<root><foo>4</foo><foo>7</foo><bar>11</bar><bar xmlns=\"zap\">28</bar></root>" :: TL.Text
--
-- >>> doc ^.. xml...named (only "foo").name
-- ["foo","foo"]
--
-- >>> doc ^? xml...named (namespace.traverse.only "zap").text
-- Just "28"
--
-- >>> doc ^? xml...named (only "baz").name
-- Nothing
named :: Fold Name a -> Traversal' Element Element
named l = filtered (has (elementName . l))
{-# INLINE named #-}

-- | Traverse node attributes
--
-- >>> let doc = "<root><foo bar=\"baz\" qux=\"zap\"/><foo quux=\"xyzzy\"/></root>" :: TL.Text
--
-- >>> doc ^.. xml...attrs.indices (has (name.unpacked.prefixed "qu"))
-- ["zap","xyzzy"]
--
-- >>> doc & xml...attrs %~ Text.toUpper
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root><foo bar=\"BAZ\" qux=\"ZAP\"/><foo quux=\"XYZZY\"/></root>"
attrs :: IndexedTraversal' Name Element Text
attrs = elementAttributes . itraversed
{-# INLINE attrs #-}

-- | Traverse node attributes with a specific name
--
-- >>> let doc = "<root><foo bar=\"baz\" qux=\"quux\"/><foo qux=\"xyzzy\"/></root>" :: TL.Text
--
-- >>> doc ^.. xml...attr "qux".traverse
-- ["quux","xyzzy"]
--
-- >>> doc ^.. xml...attr "bar"
-- [Just "baz",Nothing]
--
-- >>> doc & xml...attr "qux".traverse %~ Text.reverse
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root><foo bar=\"baz\" qux=\"xuuq\"/><foo qux=\"yzzyx\"/></root>"
--
-- >>> doc & xml.ix 1.attr "bar" ?~ "bazzy"
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root><foo bar=\"baz\" qux=\"quux\"/><foo bar=\"bazzy\" qux=\"xyzzy\"/></root>"
attr :: Name -> Lens' Element (Maybe Text)
attr n = elementAttributes . at n
{-# INLINE attr #-}

-- | Select nodes by attributes' values
--
-- >>> let doc = "<root><foo bar=\"baz\">4</foo><foo bar=\"quux\">7</foo><bar bar=\"baz\">11</bar></root>" :: TL.Text
--
-- >>> doc ^.. xml...attributed (ix "bar".only "baz").text
-- ["4","11"]
--
-- >>> doc ^? xml...attributed (folded.to Text.length.only 4).text
-- Just "7"
attributed :: Fold (Map Name Text) a -> Traversal' Element Element
attributed p = filtered (has (elementAttributes . p))
{-# INLINE attributed #-}

-- | Traverse node text contents
--
-- >>> let doc = "<root>boo</root>" :: TL.Text
--
-- >>> doc ^? xml.text
-- Just "boo"
--
-- >>> doc & xml.text <>~ "hoo"
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root>boohoo</root>"
text :: Traversal' Element Text
text = elementNodes . traverse . _NodeContent
{-# INLINE text #-}

-- | Traverse node text contents recursively
--
-- >>> let doc = "<root>qux<foo>boo</foo><bar><baz>hoo</baz>quux</bar></root>" :: TL.Text
--
-- >>> doc ^.. xml.texts
-- ["qux","boo","hoo","quux"]
--
-- >>> doc & xml.texts %~ Text.toUpper
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root>QUX<foo>BOO</foo><bar><baz>HOO</baz>QUUX</bar></root>"
texts :: Traversal' Element Text
texts f = elementNodes (traverse go) where
  go (NodeElement e) = NodeElement <$> texts f e
  go (NodeContent c) = NodeContent <$> f c
  go x = pure x

-- | Anything that has comments
class HasComments t where
  comments :: Traversal' t Text

instance HasComments Element where
  -- | Traverse node comments
  --
  -- >>> let doc = "<root><!-- qux --><foo>bar</foo><!-- quux --></root>" :: TL.Text
  --
  -- >>> doc ^.. xml.comments
  -- [" qux "," quux "]
  --
  -- >>> doc & xml.partsOf comments .~ [" xyz ", " xyzzy "]
  -- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root><!-- xyz --><foo>bar</foo><!-- xyzzy --></root>"
  comments = elementNodes . traverse . _NodeComment
  {-# INLINE comments #-}

instance HasComments Miscellaneous where
  -- | Traverse node comments
  comments = _MiscComment
  {-# INLINE comments #-}

-- | Anything that has processing instructions
class HasInstructions t where
  instructions :: Traversal' t Instruction

  -- | Traverse node instructions
  --
  -- >>> let doc = "<root><!-- foo --><?foo bar?><qux/><?xyz xyzzy?><quux/></root>" :: TL.Text
  --
  -- >>> doc ^.. xml.instructions.target
  -- ["foo","xyz"]
  --
  -- >>> doc & xml.instructions.data_ %~ Text.toUpper
  -- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root><!-- foo --><?foo BAR?><qux/><?xyz XYZZY?><quux/></root>"
instance HasInstructions Element where
  instructions = elementNodes . traverse . _NodeInstruction
  {-# INLINE instructions #-}

instance HasInstructions Miscellaneous where
  -- | Traverse node instructions
  instructions = _MiscInstruction
  {-# INLINE instructions #-}

-- | Processing instruction target
--
-- >>> let doc = "<root><?foo bar?></root>" :: TL.Text
--
-- >>> doc ^? xml.instructions.target
-- Just "foo"
--
-- >>> doc & xml.instructions.target .~ "boo"
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root><?boo bar?></root>"
target :: Traversal' Instruction Text
target = instructionTarget
{-# INLINE target #-}

-- | Processing instruction data
--
-- >>> let doc = "<root><?foo bar?></root>" :: TL.Text
--
-- >>> doc ^? xml.instructions.data_
-- Just "bar"
--
-- >>> doc & xml.instructions.data_ .~ "hoo"
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root><?foo hoo?></root>"
data_ :: Traversal' Instruction Text
data_ = instructionData
{-# INLINE data_ #-}

-- | Anything that has a name
class HasName t where
  fullName :: Lens' t Name

instance HasName Name where
  fullName = id
  {-# INLINE fullName #-}

instance HasName Element where
  fullName = elementName
  {-# INLINE fullName #-}

-- | A Lens into node name
--
-- >>> ("<root/>" :: TL.Text) ^. xml.name
-- "root"
--
-- >>> ("<root><foo/><bar/><baz/></root>" :: TL.Text) ^.. xml...name
-- ["foo","bar","baz"]
--
-- >>> ("<root><foo/><bar/><baz></root>" :: TL.Text) & xml.partsOf (plate.name) .~ ["boo", "hoo", "moo"]
-- "<root><foo/><bar/><baz></root>"
name :: HasName t => Lens' t Text
name = fullName . nameLocalName
{-# INLINE name #-}

-- | A Lens into node namespace
--
-- >>> ("<root/>" :: TL.Text) ^. xml.namespace
-- Nothing
--
-- >>> ("<root/>" :: TL.Text) & xml.namespace ?~ "foo"
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root xmlns=\"foo\"/>"
--
-- >>> ("<root xmlns=\"foo\"/>" :: TL.Text) & xml.namespace .~ Nothing
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root/>"
namespace :: HasName t => Lens' t (Maybe Text)
namespace = fullName . nameNamespace
{-# INLINE namespace #-}

-- | A Lens into node namespace
--
-- >>> ("<root/>" :: TL.Text) ^. xml.prefix
-- Nothing
--
-- >>> ("<root/>" :: TL.Text) & xml.prefix ?~ "foo"
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root/>"
--
-- >>> ("<root xmlns=\"foo\"/>" :: TL.Text) & xml.prefix ?~ "foo"
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo:root xmlns:foo=\"foo\"/>"
--
-- >>> ("<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo:root xmlns:foo=\"foo\"/>" :: TL.Text) & xml.prefix .~ Nothing
-- "<?xml version=\"1.0\" encoding=\"UTF-8\"?><root xmlns=\"foo\"/>"
prefix :: HasName t => Lens' t (Maybe Text)
prefix = fullName . namePrefix
{-# INLINE prefix #-}

-- | @xml-conduit@ entity resolving exceptions overloading
class AsUnresolvedEntityException t where
  _UnresolvedEntityException :: Prism' t UnresolvedEntityException

instance AsUnresolvedEntityException UnresolvedEntityException where
  _UnresolvedEntityException = id
  {-# INLINE _UnresolvedEntityException #-}

instance AsUnresolvedEntityException SomeException where
  _UnresolvedEntityException = exception
  {-# INLINE _UnresolvedEntityException #-}

-- | @xml-conduit@ general XML exception overloading
class AsXMLException t where
  _XMLException :: Prism' t XMLException

instance AsXMLException XMLException where
  _XMLException = id
  {-# INLINE _XMLException #-}

instance AsXMLException SomeException where
  _XMLException = exception
  {-# INLINE _XMLException #-}

-- | @xml-conduit@ XML parsing exceptions overloading
class AsInvalidEventStream t where
  _InvalidEventStream :: Prism' t InvalidEventStream

instance AsInvalidEventStream InvalidEventStream where
  _InvalidEventStream = id
  {-# INLINE _InvalidEventStream #-}

instance AsInvalidEventStream SomeException where
  _InvalidEventStream = exception
  {-# INLINE _InvalidEventStream #-}

-- | A Prism into 'ContentAfterRoot'
_ContentAfterRoot :: AsInvalidEventStream t => Prism' t EventPos
_ContentAfterRoot = _InvalidEventStream
  . prism' ContentAfterRoot (\s -> case s of ContentAfterRoot e -> Just e; _ -> Nothing)
{-# INLINE _ContentAfterRoot #-}

-- | A Prism into 'MissingRootElement'
_MissingRootElement :: AsInvalidEventStream t => Prism' t ()
_MissingRootElement = _InvalidEventStream
  . prism' (const MissingRootElement) (\s -> case s of MissingRootElement -> Just (); _ -> Nothing)
{-# INLINE _MissingRootElement #-}

-- | A Prism into 'InvalidInlineDoctype'
_InvalidInlineDoctype :: AsInvalidEventStream t => Prism' t EventPos
_InvalidInlineDoctype = _InvalidEventStream
  . prism' InvalidInlineDoctype (\s -> case s of InvalidInlineDoctype e -> Just e; _ -> Nothing)
{-# INLINE _InvalidInlineDoctype #-}

-- | A Prism into 'MissingEndElement'
_MissingEndElement :: AsInvalidEventStream t => Prism' t (Name, Maybe EventPos)
_MissingEndElement = _InvalidEventStream
  . prism' (uncurry MissingEndElement) (\s -> case s of MissingEndElement e p -> Just (e, p); _ -> Nothing)
{-# INLINE _MissingEndElement #-}

-- | A Prism into 'UnterminatedInlineDoctype'
_UnterminatedInlineDoctype :: AsInvalidEventStream t => Prism' t ()
_UnterminatedInlineDoctype = _InvalidEventStream
  . prism' (const UnterminatedInlineDoctype) (\s -> case s of UnterminatedInlineDoctype -> Just (); _ -> Nothing)
{-# INLINE _UnterminatedInlineDoctype #-}