{-# OPTIONS -fno-warn-orphans #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Text.XML.Expat.Lens.Generic (
name, attributes, text,
children, allNodes, (./),
named, parameterized
) where
import Control.Applicative
import Control.Lens hiding (children)
import Control.Monad
import Text.XML.Expat.Tree
name :: Traversal' (NodeG f tag text) tag
name inj (Element n a c) = (\n' -> Element n' a c) <$> inj n
name _ t = pure t
{-# INLINE name #-}
attributes :: Traversal' (NodeG f tag text) (Attributes tag text)
attributes inj (Element n a c) = (\a' -> Element n a' c) <$> inj a
attributes _ t = pure t
{-# INLINE attributes #-}
type instance Index (NodeG f tag text) = tag
type instance IxValue (NodeG f tag text) = text
instance Eq tag => At (NodeG f tag text) where
at k f e =
indexed f k (join (e ^? attributes . to (lookup k)))
<&> \r -> e & attributes %~ ins k r
where
ins _ Nothing [] = []
ins key (Just res) [] = [(key, res)]
ins key mayRes ((key', res'):rest)
| key == key' = case mayRes of
Nothing -> rest
Just res -> (key, res):rest
| otherwise = (key', res') : ins key mayRes rest
{-# INLINE ins #-}
{-# INLINE at #-}
instance (Eq tag) => Ixed (NodeG c tag text) where
ix = ixAt
instance Traversable f => Plated (NodeG f tag text) where
plate = children . traverse
{-# INLINE plate #-}
children :: Traversal' (NodeG f tag text) (f (NodeG f tag text))
children inj (Element n a c) = Element n a <$> inj c
children _ t = pure t
{-# INLINE children #-}
text :: Prism' (NodeG f tag text) text
text = dimap go come . right' where
go e@Element{} = Left e
go (Text t) = Right t
{-# INLINE go #-}
come (Left it) = pure it
come (Right t) = Text <$> t
{-# INLINE come #-}
{-# INLINE text #-}
allNodes :: Traversable c => NodeG c tag text -> [NodeG c tag text]
allNodes = universe
{-# INLINE allNodes #-}
named
:: (Eq a, Applicative f, Choice p) =>
a -> Optic' p f (NodeG f1 a text) (NodeG f1 a text)
named n = filtered $ maybe False (== n) . preview name
{-# INLINE named #-}
parameterized
:: (Eq (IxValue a), Applicative f, Choice p, Ixed a) =>
Index a -> IxValue a -> Optic' p f a a
parameterized k v = filtered check where
check u = case u ^? ix k . to (==v) of
Just True -> True
_ -> False
{-# INLINE check #-}
{-# INLINE parameterized #-}
infixr 9 ./
(./) :: Plated i => Traversal' s i -> Traversal' i a -> Traversal' s a
l ./ m = l . plate . m