{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# language ExistentialQuantification #-}
{-# language OverloadedStrings #-}
{-# language RecordWildCards #-}
{-# language Rank2Types #-}
{-# options_ghc -Wno-unused-imports #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.XML.Lens.Micro
-- Copyright   :  (c) 2015-2023 Fumiaki Kinoshita, 2023 Marco Zocca
-- License     :  BSD-style
--
-- Maintainer  :  ocramz
-- Stability   :  experimental
-- Portability :  portable
--
-- XML (and HTML) DOM selectors for `xml-conduit` based on `microlens`.
--
-- This library provides combinators for traversing and folding over XML trees.
-- It could be useful for editing trees, adding attributes selectively (e.g. refactoring CSS,
-- adding HTMX attributes etc.)
--
-- Some definitions are taken from 'xml-lens' but we import 'microlens' to achieve
-- a smaller dependency footprint.
-----------------------------------------------------------------------------
module Text.XML.Lens.Micro (
  subtree,
  remapAttributes,
  -- * From 'xml-lens'
  root,
  prologue,
  epilogue,
  named,
  nodes,
  attrs,
  attributeSatisfies,
  attributeIs,
  withoutAttribute,

                           ) where


import Data.Maybe (fromMaybe, isNothing)
import Data.Monoid (First(..), Any(..))

-- case-insensitive
import qualified Data.CaseInsensitive as CI
-- containers
import qualified Data.Map as M (Map, insert, lookup, singleton, fromList, foldrWithKey)
-- microlens
import Lens.Micro.GHC (to, Getting, Lens', (^.), Traversal', ix, filtered)
import Lens.Micro.Extras (preview)
-- text
import Data.Text (Text)
-- xml-conduit
import Text.XML (Prologue(..), Doctype(..), Document(..), Element(..), Name(..), Node(..), Miscellaneous(..))




-- | The root element of the 'Document'.
root :: Lens' Document Element
root :: Lens' Document Element
root Element -> f Element
f Document
doc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Element
p -> Document
doc { documentRoot :: Element
documentRoot = Element
p} ) forall a b. (a -> b) -> a -> b
$ Element -> f Element
f forall a b. (a -> b) -> a -> b
$ Document -> Element
documentRoot Document
doc
{-# INLINE root #-}

-- | 'Prologue' of the 'Document'
prologue :: Lens' Document Prologue
prologue :: Lens' Document Prologue
prologue Prologue -> f Prologue
f Document
doc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Prologue
p -> Document
doc { documentPrologue :: Prologue
documentPrologue = Prologue
p} ) forall a b. (a -> b) -> a -> b
$ Prologue -> f Prologue
f forall a b. (a -> b) -> a -> b
$ Document -> Prologue
documentPrologue Document
doc
{-# INLINE prologue #-}

-- | Epilogue, i.e. the last elements, of the 'Document'
epilogue :: Lens' Document [Miscellaneous]
epilogue :: Lens' Document [Miscellaneous]
epilogue [Miscellaneous] -> f [Miscellaneous]
f Document
doc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Miscellaneous]
p -> Document
doc { documentEpilogue :: [Miscellaneous]
documentEpilogue = [Miscellaneous]
p} ) forall a b. (a -> b) -> a -> b
$ [Miscellaneous] -> f [Miscellaneous]
f forall a b. (a -> b) -> a -> b
$ Document -> [Miscellaneous]
documentEpilogue Document
doc
{-# INLINE epilogue #-}

-- | Traverse elements which has the specified *local* name (case-insensitive).
named :: CI.CI Text -> Traversal' Element Element
named :: CI Text -> Traversal' Element Element
named CI Text
n Element -> f Element
f Element
s
    | forall s. FoldCase s => s -> CI s
CI.mk (Name -> Text
nameLocalName (Element -> Name
elementName Element
s)) forall a. Eq a => a -> a -> Bool
== CI Text
n = Element -> f Element
f Element
s
    | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure Element
s
{-# INLINE named #-}

-- | All 'Node's of an 'Element'
nodes :: Lens' Element [Node]
nodes :: Lens' Element [Node]
nodes [Node] -> f [Node]
f Element
e = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Node]
x -> Element
e { elementNodes :: [Node]
elementNodes = [Node]
x }) forall a b. (a -> b) -> a -> b
$ [Node] -> f [Node]
f forall a b. (a -> b) -> a -> b
$ Element -> [Node]
elementNodes Element
e
{-# INLINE nodes #-}

-- | Node attributes
attrs :: Lens' Element (M.Map Name Text)
attrs :: Lens' Element (Map Name Text)
attrs Map Name Text -> f (Map Name Text)
f Element
e = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Map Name Text
x -> Element
e { elementAttributes :: Map Name Text
elementAttributes = Map Name Text
x }) forall a b. (a -> b) -> a -> b
$ Map Name Text -> f (Map Name Text)
f forall a b. (a -> b) -> a -> b
$ Element -> Map Name Text
elementAttributes Element
e
{-# INLINE attrs #-}

-- | Traverse over only the elements such that the value of the given attribute satisfy a predicate
attributeSatisfies :: Name -- ^ attribute name
                   -> (Text -> Bool) -- ^ predicate on the value of the attribute
                   -> Traversal' Element Element
attributeSatisfies :: Name -> (Text -> Bool) -> Traversal' Element Element
attributeSatisfies Name
n Text -> Bool
p = Name -> (Maybe Text -> Bool) -> Traversal' Element Element
attributeSatisfies' Name
n (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Text -> Bool
p)
{-# INLINE attributeSatisfies #-}

attributeSatisfies' :: Name -> (Maybe Text -> Bool) -> Traversal' Element Element
attributeSatisfies' :: Name -> (Maybe Text -> Bool) -> Traversal' Element Element
attributeSatisfies' Name
n Maybe Text -> Bool
p = forall a. (a -> Bool) -> Traversal' a a
filtered (Maybe Text -> Bool
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a s. Getting (First a) s a -> s -> Maybe a
preview (Lens' Element (Map Name Text)
attrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Name
n))
{-# INLINE attributeSatisfies' #-}

-- nodesSatisfy :: ([Node] -> Bool) -> Traversal' Element Element
-- nodesSatisfy p = nodesSatisfy' (maybe False p)

-- nodesSatisfy' :: (Maybe [Node] -> Bool) -> Traversal' Element Element
-- nodesSatisfy' p = filtered (p . preview (nodes))


withoutAttribute :: Name -> Traversal' Element Element
withoutAttribute :: Name -> Traversal' Element Element
withoutAttribute Name
n = Name -> (Maybe Text -> Bool) -> Traversal' Element Element
attributeSatisfies' Name
n forall a. Maybe a -> Bool
isNothing
{-# INLINE withoutAttribute #-}

-- | Traverse over only the elements with a given attribute name and value
attributeIs :: Name -- ^ attribute name
            -> Text -- ^ value of the attribute
            -> Traversal' Element Element
attributeIs :: Name -> Text -> Traversal' Element Element
attributeIs Name
n Text
v = Name -> (Text -> Bool) -> Traversal' Element Element
attributeSatisfies Name
n (forall a. Eq a => a -> a -> Bool
== Text
v)
{-# INLINE attributeIs #-}


-- | Extract a DOM subtree whose root element satisfies the given predicates
subtree :: (Text -> Bool) -- ^ predicate on element name
        -> (Text -> Text -> Bool) -- ^ predicate on attribute name, value
        -> Getting r Element (Maybe Element)
subtree :: forall r.
(Text -> Bool)
-> (Text -> Text -> Bool) -> Getting r Element (Maybe Element)
subtree Text -> Bool
f Text -> Text -> Bool
h = forall s a. (s -> a) -> SimpleGetter s a
to ((Text -> Bool)
-> (Text -> Text -> Bool) -> Element -> Maybe Element
_subtree Text -> Bool
f Text -> Text -> Bool
h)

_subtree :: (Text -> Bool)
         -> (Text -> Text -> Bool) -> Element -> Maybe Element
_subtree :: (Text -> Bool)
-> (Text -> Text -> Bool) -> Element -> Maybe Element
_subtree Text -> Bool
f Text -> Text -> Bool
h el :: Element
el@(Element Name
n Map Name Text
ats [Node]
nds) = case Text -> Bool
f (Name -> Text
nameLocalName Name
n) Bool -> Bool -> Bool
&& (Any -> Bool
getAny forall a b. (a -> b) -> a -> b
$ forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (\Name
k Text
v Any
acc -> Bool -> Any
Any (Text -> Text -> Bool
h (Name -> Text
nameLocalName Name
k) Text
v) forall a. Semigroup a => a -> a -> a
<> Any
acc) forall a. Monoid a => a
mempty Map Name Text
ats) of
  Bool
True -> forall a. a -> Maybe a
Just Element
el
  Bool
False -> forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. Maybe a -> First a
First forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Maybe Element
g) [Node]
nds
  where
    g :: Node -> Maybe Element
g = \case
      NodeElement Element
e -> (Text -> Bool)
-> (Text -> Text -> Bool) -> Element -> Maybe Element
_subtree Text -> Bool
f Text -> Text -> Bool
h Element
e
      Node
_ -> forall a. Maybe a
Nothing

-- | Remap all attributes. Handy for editing HREF or SRC targets, adding HTMX attributes to certain elements only, etc.
--
-- If the callback returns Nothing, the element attributes are left unchanged
remapAttributes ::
  (Name -> M.Map Name Text -> Maybe (M.Map Name Text)) -- ^ element name, element attributes
  -> Getting r Element Element
remapAttributes :: forall r.
(Name -> Map Name Text -> Maybe (Map Name Text))
-> Getting r Element Element
remapAttributes Name -> Map Name Text -> Maybe (Map Name Text)
f = forall s a. (s -> a) -> SimpleGetter s a
to ((Name -> Map Name Text -> Maybe (Map Name Text))
-> Element -> Element
_remapAttributes Name -> Map Name Text -> Maybe (Map Name Text)
f)

_remapAttributes :: (Name -> M.Map Name Text -> Maybe (M.Map Name Text))
                     -> Element -> Element
_remapAttributes :: (Name -> Map Name Text -> Maybe (Map Name Text))
-> Element -> Element
_remapAttributes Name -> Map Name Text -> Maybe (Map Name Text)
f el :: Element
el@(Element Name
n Map Name Text
ats [Node]
_) =
  Element
el{ elementAttributes :: Map Name Text
elementAttributes = forall a. a -> Maybe a -> a
fromMaybe Map Name Text
ats (Name -> Map Name Text -> Maybe (Map Name Text)
f Name
n Map Name Text
ats),
      elementNodes :: [Node]
elementNodes = forall a b. (a -> b) -> [a] -> [b]
map (\Node
nn -> case Node
nn of
                             NodeElement Element
e -> Element -> Node
NodeElement ((Name -> Map Name Text -> Maybe (Map Name Text))
-> Element -> Element
_remapAttributes Name -> Map Name Text -> Maybe (Map Name Text)
f Element
e)
                             Node
x -> Node
x
                         ) forall a b. (a -> b) -> a -> b
$ Element -> [Node]
elementNodes Element
el }





-- t0 :: TL.Text
-- t0 = "<!DOCTYPE html><html><head><title>Page Title</title></head><body><h1>My First Heading</h1><p>My first paragraph.</p><div id=\'z42\'></div></body></html>"
-- t0e :: Either SomeException Document
-- t0e = parseText def t0

-- dok :: Document
-- dok = Document {documentPrologue = Prologue {prologueBefore = [], prologueDoctype = Just (Doctype {doctypeName = "html", doctypeID = Nothing}), prologueAfter = []}, documentRoot = Element {elementName = Name {nameLocalName = "html", nameNamespace = Nothing, namePrefix = Nothing}, elementAttributes = M.fromList [], elementNodes = [NodeElement (Element {elementName = Name {nameLocalName = "head", nameNamespace = Nothing, namePrefix = Nothing}, elementAttributes = M.fromList [], elementNodes = [NodeElement (Element {elementName = Name {nameLocalName = "title", nameNamespace = Nothing, namePrefix = Nothing}, elementAttributes = M.fromList [], elementNodes = [NodeContent "Page Title"]})]}),NodeElement (Element {elementName = Name {nameLocalName = "body", nameNamespace = Nothing, namePrefix = Nothing}, elementAttributes = M.fromList [], elementNodes = [NodeElement (Element {elementName = Name {nameLocalName = "h1", nameNamespace = Nothing, namePrefix = Nothing}, elementAttributes = M.fromList [], elementNodes = [NodeContent "My First Heading"]}),NodeElement (Element {elementName = Name {nameLocalName = "p", nameNamespace = Nothing, namePrefix = Nothing}, elementAttributes = M.fromList [], elementNodes = [NodeContent "My first paragraph."]}),NodeElement (Element {elementName = Name {nameLocalName = "div", nameNamespace = Nothing, namePrefix = Nothing}, elementAttributes = M.fromList [(Name {nameLocalName = "id", nameNamespace = Nothing, namePrefix = Nothing},"z42")], elementNodes = []})]})]}, documentEpilogue = []}












-- nodeElement :: (Element -> Maybe Element) -> Node -> Maybe Node
-- nodeElement f = \case
--   NodeElement e -> NodeElement <$> f e
--   _ -> Nothing

-- nodeContent :: (Text -> Maybe Text) -> Node -> Maybe Node
-- nodeContent f = \case
--   NodeContent c -> NodeContent <$> f c
--   _ -> Nothing

-- -- from https://blog.jle.im/entry/lenses-products-prisms-sums.html#through-the-looking-prism
-- data Prism' s a = forall q. Prism'
--     { match  :: s -> Either a q
--     , inject :: Either a q -> s
--     }

-- -- | Focus on node elements
-- _Element :: Prism' Node Element
-- _Element = Prism' {
--   match = \case
--       NodeElement e -> Left e
--       i -> Right i
--   , inject = \case
--       Left e -> NodeElement e
--       Right i -> i
--                   }

-- -- | Focus on the text content of nodes
-- _Content :: Prism' Node Text
-- _Content = Prism' {
--   match = \case
--       NodeContent c -> Left c
--       i -> Right i
--   , inject = \case
--       Left c -> NodeContent c
--       Right i -> i
--                   }


-- -- | 'preview' for 'Prism''
-- previewP :: Prism' s a -> (s -> Maybe a)
-- previewP Prism'{..} x = case match x of
--     Left  y -> Just y
--     Right _ -> Nothing