{-# 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
--
--
-----------------------------------------------------------------------------
module Text.XML.Lens.Micro (
  root,
  epilogue,
  named,
  nodes,
  subtree,
  -- ** node attribute combinators
  attrs,
  attributeSatisfies,
  attributeIs,
  withoutAttribute,
  remapAttributes,
                           ) where


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

-- case-insensitive
import qualified Data.CaseInsensitive as CI
-- containers
import qualified Data.Map as M (Map, 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 #-}

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 #-}

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 #-}

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 #-}


-- | Isolate a DOM subtree that 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


-- | Handy for editing HREF targets etc.
remapAttributes :: (Name -> Text -> Maybe (Name, Text)) -- ^ operate on element attribute (name, value)
                -> Getting r Element Element
remapAttributes :: forall r.
(Name -> Text -> Maybe (Name, Text)) -> Getting r Element Element
remapAttributes Name -> Text -> Maybe (Name, Text)
f = forall s a. (s -> a) -> SimpleGetter s a
to ((Name -> Text -> Maybe (Name, Text)) -> Element -> Element
_remapAttributes Name -> Text -> Maybe (Name, Text)
f)

_remapAttributes :: (Name -> Text -> Maybe (Name, Text))
               -> Element -> Element
_remapAttributes :: (Name -> Text -> Maybe (Name, Text)) -> Element -> Element
_remapAttributes Name -> Text -> Maybe (Name, Text)
p el :: Element
el@(Element Name
_ Map Name Text
ats [Node]
_) =
  Element
el{ elementAttributes :: Map Name Text
elementAttributes = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey (\Name
k Text
v Map Name Text
acc -> case Name -> Text -> Maybe (Name, Text)
p Name
k Text
v of
                                             Maybe (Name, Text)
Nothing -> forall k a. k -> a -> Map k a
M.singleton Name
k Text
v forall a. Semigroup a => a -> a -> a
<> Map Name Text
acc
                                             Just (Name
k', Text
v') -> forall k a. k -> a -> Map k a
M.singleton Name
k' Text
v' forall a. Semigroup a => a -> a -> a
<> Map Name Text
acc
                                         ) forall a. Monoid a => a
mempty 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 -> Text -> Maybe (Name, Text)) -> Element -> Element
_remapAttributes Name -> Text -> Maybe (Name, Text)
p 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