{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE RankNTypes #-} module Text.XML.Hexml.Lens ( -- * Nodes _children , ChildNode(..) , Contents(..) , TextContents(..) -- * Attributes , Attributes(..) -- * Parsing , AsXML(..) ) where import Control.Arrow import Control.Lens hiding (children) import qualified Data.ByteString as Strict import qualified Data.ByteString.Internal as Strict import qualified Data.ByteString.Lazy as Lazy import Data.ByteString.Lens import Data.String import qualified Data.Text as Strict import qualified Data.Text.Lazy as Lazy import qualified Data.Text.Encoding as Strict import qualified Data.Text.Lazy.Encoding as Lazy import Data.Text.Lens import qualified Foundation as F import qualified Foundation.String as F import qualified Foundation.Array.Internal as F import Text.XML.Hexml -- | Fold over the element children _children :: Fold Node Node _children = folding children -- | Fold over all the children (text and element) class Contents s where _contents :: Fold Node (Either s Node) instance Contents String where _contents = _contents . firsting (from strictUtf8) instance Contents F.String where _contents = _contents . lefting (foundation F.UTF8) instance Contents Strict.Text where _contents = _contents . firsting (from strictTextUtf8) instance Contents Lazy.Text where _contents = _contents . firsting (from lazyTextUtf8) instance Contents Strict.ByteString where _contents = folding contents instance Contents Lazy.ByteString where _contents = _contents . firsting lazy -- --------------------------------------------------------------------------------- -- | Folds for element nodes class ChildNode s where -- | Fold over a specific child node :: s -> Fold Node Node -- | A fold for accessing named children nodes -- This is a more efficient version of -- -- > node foo = _children . filtered (\n -> name n == foo) instance ChildNode String where node name_ = node ( name_ ^. strictUtf8) -- | A fold for accessing named children nodes -- This is a more efficient version of -- -- > node foo = _children . filtered (\n -> name n == foo) instance ChildNode F.String where node name_ = node ( F.toList name_ ^. strictUtf8) -- | A fold for accessing named children nodes -- This is a more efficient version of -- -- > node foo = _children . filtered (\n -> name n == foo) instance ChildNode Strict.ByteString where node name_ = folding $ flip childrenBy name_ instance ChildNode Lazy.ByteString where node name_ = node (name_ ^. strict) -- | A fold for accessing named children nodes -- This is a more efficient version of -- -- > node foo = _children . filtered (\n -> name n == foo) instance ChildNode Strict.Text where node name_ = node ( name_ ^. strictTextUtf8 ) instance ChildNode Lazy.Text where node name_ = node ( name_ ^. lazyTextUtf8 ) -- | A fold for accessing a child node by its index instance ChildNode Int where node n = folding $ take 1 . drop n . children -- --------------------------------------------------------------------------------- -- | Fold for accessing the text contents of a node class TextContents s where textContents :: Fold Node s instance TextContents Strict.ByteString where textContents = folding contents . _Left instance TextContents Lazy.ByteString where textContents = textContents . lazy instance TextContents String where textContents = textContents @Strict.ByteString . from strictUtf8 instance TextContents Strict.Text where textContents = textContents . from strictTextUtf8 instance TextContents Lazy.Text where textContents = textContents . from lazyTextUtf8 instance TextContents F.String where textContents = textContents . foundation F.UTF8 -- --------------------------------------------------------------------------------- -- | Optics for accessing attributes class Attributes s where -- | Fold for accessing attributes by name. _Attribute :: s -> Getter Node (Maybe s) -- | Name-Indexed fold over the attribute values iattributes :: IndexedFold String Node s instance Attributes Strict.ByteString where _Attribute n = pre $ to(`attributeBy` n).folded.to(attributeValue) iattributes = ifolding (map (\ (Attribute n v) -> (n^.from strictUtf8, v)) . attributes ) instance Attributes Lazy.ByteString where _Attribute n = _Attribute(n^.strict).mapping(lazy) iattributes = iattributes.lazy instance Attributes String where _Attribute n = _Attribute(n ^. packedChars).mapping(from strictUtf8) iattributes = iattributes @ Strict.ByteString . unpackedChars instance Attributes Strict.Text where _Attribute n = _Attribute(n ^. strictTextUtf8).mapping(from strictTextUtf8) iattributes = iattributes . packed instance Attributes Lazy.Text where _Attribute n = _Attribute(n ^. lazyTextUtf8).mapping(from lazyTextUtf8) iattributes = iattributes . packed instance Attributes F.String where _Attribute n = pre $ to (`attributeBy` (F.toList n ^. packedChars)) . folded . to attributeValue . foundation F.UTF8 iattributes = iattributes . to fromString -- --------------------------------------------------------------------------------- class AsXML s where -- | A prism for parsing and unparsing XML. -- -- unparsing is provided by 'outer'. -- -- >>> "" ^? _XML -- Just Node "" -- -- Nameless nodes are inserted for trees with >1 root. -- -- >>> "" ^? _XML.to name -- Just "" -- -- >>> "" ^? _XML.node(0::Int) -- Just Node "" -- -- >>> "" ^? _XML.node(1::Int) -- Just Node "" -- -- If the tree has only 1 root, no nameless nodes are inserted. -- -- >>> "" ^? _XML.re(_XML @String)._XML.to name -- Just "foo" -- -- The law @x ^? re _XML . _XML == x@ doesn't hold for the nameless nodes -- injected by 'parse'. -- -- >>> parse "" ^? _Right.to name -- Just "" -- >>> parse "" ^? _Right.re(_XML @String)._XML.to name -- Just "foo" _XML :: Prism' s Node instance AsXML Strict.ByteString where _XML = prism' outer doParse where doParse x = case parse x of Right n -> Just $ case children n of [y] -> y ; _ -> n Left _ -> Nothing instance AsXML Lazy.ByteString where _XML = strict . _XML @ Strict.ByteString instance AsXML String where _XML = strictUtf8 . _XML @ Strict.ByteString instance AsXML Strict.Text where _XML = strictTextUtf8 . _XML instance AsXML Lazy.Text where _XML = lazyTextUtf8 . _XML -- --------------------------------------------------------------------------------- lazyTextUtf8 :: Iso' Lazy.Text Lazy.ByteString lazyTextUtf8 = iso Lazy.encodeUtf8 Lazy.decodeUtf8 strictTextUtf8 :: Iso' Strict.Text Strict.ByteString strictTextUtf8 = iso Strict.encodeUtf8 Strict.decodeUtf8 strictUtf8 :: Iso' String Strict.ByteString strictUtf8 = packed . strictTextUtf8 foundation :: F.Encoding -> Fold Strict.ByteString F.String foundation encoding = to (F.fromBytes encoding . fromByteString) . filtered (hasn't (_2.folded)) . _1 where fromByteString = F.fromForeignPtr . Strict.toForeignPtr -- | A more restricted version of 'firsting' which works on 'Fold's lefting :: Fold l l' -> Fold (Either l a) (Either l' a) lefting fold = runFold (left $ Fold fold) -- Test setup -- --------------------------------------------------------------------------------- -- $setup -- >>> import Test.QuickCheck -- >>> :set -XTypeApplications -- >>> :set -XOverloadedStrings