diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2013, Fumiaki Kinoshita +Copyright (c) 2014, Matvey Aksenov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Fumiaki Kinoshita nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +xml-html-conduit-lens +===================== +[![Hackage](https://budueba.com/hackage/xml-html-conduit-lens)](http://hackage.haskell.org/package/xml-html-conduit-lens) +[![Build Status](https://secure.travis-ci.org/supki/xml-html-conduit-lens.png?branch=master)](http://travis-ci.org/supki/xml-html-conduit-lens) + +Optics for [xml-conduit][0] and [html-conduit][1] + + [0]: http://hackage.haskell.org/package/xml-conduit + [1]: http://hackage.haskell.org/package/html-conduit diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Text/Xml/Lens.hs b/src/Text/Xml/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Text/Xml/Lens.hs @@ -0,0 +1,524 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Optics for xml-conduit and html-conduit +module Text.Xml.Lens + ( -- * Document + Document + , xml + , html + , root + , prolog + , epilog + , AsXmlDocument(..) + , _XmlDocument + , AsHtmlDocument(..) + -- * Doctype + , Doctype + , doctype + , beforeDoctype + , afterDoctype + -- * Element + , Element + , node + , named + , attrs + , attr + , attributed + , text + , 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, Doctype, Prologue + , 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 -> RenderSettings -> Prism' t Document + +instance AsXmlDocument Document where + _XmlDocumentWith _ _ = id + {-# INLINE _XmlDocumentWith #-} + +instance AsXmlDocument BL.ByteString where + _XmlDocumentWith ps rs = prism' (renderLBS rs) (either (const Nothing) Just . parseLBS ps) + {-# INLINE _XmlDocumentWith #-} + +instance AsXmlDocument TL.Text where + _XmlDocumentWith ps rs = prism' (renderText rs) (either (const Nothing) Just . parseText ps) + {-# 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 +-- +-- >>> ("" :: TL.Text) ^? xml.name +-- Just "foo" +-- +-- >>> ("" :: TL.Text) ^? xml.name +-- Just "foo" +-- +-- >>> ("" :: TL.Text) & xml.name .~ "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 = "

" :: BL.ByteString +-- +-- >>> quasiXml ^.. html.plate.name +-- ["br","br"] +-- +-- >>> quasiXml ^? xml.plate.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 #-} + +-- | A Lens into XML DOCTYPE declaration +-- +-- >>> let doc = "" :: TL.Text +-- +-- >>> doc ^? prolog.doctype.folded.doctypeName +-- Just "foo" +-- +-- >>> doc & prolog.doctype.traverse.doctypeName .~ "moo" +-- "" +-- +-- Since @doctype@'s a Lens, it's possible to attach DOCTYPE declaration +-- to an XML document which didn't have it before: +-- +-- >>> ("" :: TL.Text) & prolog.doctype ?~ XML.Doctype "moo" Nothing +-- "" +doctype :: Lens' Prologue (Maybe Doctype) +doctype = prologueDoctype +{-# INLINE doctype #-} + +-- | A Lens into nodes before XML DOCTYPE declaration +-- +-- >>> let doc = "" :: TL.Text +-- +-- >>> doc ^? prolog.beforeDoctype.folded.comments +-- Just "foo" +-- +-- >>> doc & prolog.beforeDoctype.traverse.comments %~ Text.toUpper +-- "" +beforeDoctype :: Lens' Prologue [Miscellaneous] +beforeDoctype = prologueBefore +{-# INLINE beforeDoctype #-} + +-- | A Lens into nodes after XML DOCTYPE declaration +-- +-- >>> let doc = "" :: TL.Text +-- +-- >>> doc ^? prolog.afterDoctype.folded.comments +-- Just "baz" +-- +-- >>> doc & prolog.afterDoctype.traverse.comments %~ Text.toUpper +-- "" +afterDoctype :: Lens' Prologue [Miscellaneous] +afterDoctype = prologueAfter +{-# INLINE afterDoctype #-} + +-- | A Traversal into XML epilog +-- +-- >>> let doc = "" :: TL.Text +-- +-- >>> doc ^.. epilog.folded.comments +-- ["qux","quux"] +-- +-- >>> doc ^.. epilog.folded.instructions.target +-- ["foo"] +-- +-- >>> doc & epilog .~ [] +-- "" +epilog :: AsXmlDocument t => Traversal' t [Miscellaneous] +epilog = _XmlDocument . documentEpilogue +{-# INLINE epilog #-} + +type instance Index Element = Name +type instance IxValue Element = Text + +instance At Element where + at n = elementAttributes . at n + {-# INLINE at #-} + +instance Applicative f => Ixed f Element where + ix n = elementAttributes . ix n + {-# INLINE ix #-} + +-- | Traverse immediate children +-- +-- >>> let doc = "4711" :: TL.Text +-- +-- >>> doc ^.. xml.plate.name +-- ["foo","foo","bar"] +-- +-- >>> doc & partsOf (root.plate.name) .~ ["boo", "hoo", "moo"] +-- "4711" +instance Plated Element where + plate = elementNodes . traverse . _NodeElement + {-# INLINE plate #-} + +-- | Traverse immediate children with a specific name +-- +-- >>> let doc = "boohoomoo" :: 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 = "471128" :: TL.Text +-- +-- >>> doc ^.. xml.plate.named (only "foo").name +-- ["foo","foo"] +-- +-- >>> doc ^? xml.plate.named (namespace.traverse.only "zap").text +-- Just "28" +-- +-- >>> doc ^? xml.plate.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 = "" :: TL.Text +-- +-- >>> doc ^.. xml.plate.attrs.indices (has (name.unpacked.prefixed "qu")) +-- ["zap","xyzzy"] +-- +-- >>> doc & xml.plate.attrs %~ Text.toUpper +-- "" +attrs :: IndexedTraversal' Name Element Text +attrs = elementAttributes . itraversed +{-# INLINE attrs #-} + +-- | Traverse node attributes with a specific name +-- +-- >>> let doc = "" :: TL.Text +-- +-- >>> doc ^.. xml.plate.attr "qux" +-- ["quux","xyzzy"] +-- +-- >>> doc ^.. xml.plate.attr "bar" +-- ["baz"] +-- +-- >>> doc & xml.plate.attr "qux" %~ Text.reverse +-- "" +attr :: Name -> IndexedTraversal' Name Element Text +attr n = elementAttributes . ix n +{-# INLINE attr #-} + +-- | Select nodes by attributes' values +-- +-- >>> let doc = "4711" :: TL.Text +-- +-- >>> doc ^.. xml.plate.attributed (ix "bar".only "baz").text +-- ["4","11"] +-- +-- >>> doc ^? xml.plate.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 = "boo" :: TL.Text +-- +-- >>> doc ^? xml.text +-- Just "boo" +-- +-- >>> doc & xml.text <>~ "hoo" +-- "boohoo" +text :: Traversal' Element Text +text = elementNodes . traverse . _NodeContent +{-# INLINE text #-} + +-- | Anything that has comments +class HasComments t where + comments :: Traversal' t Text + +instance HasComments Element where + -- | Traverse node comments + -- + -- >>> let doc = "bar" :: TL.Text + -- + -- >>> doc ^.. xml.comments + -- [" qux "," quux "] + -- + -- >>> doc & xml.partsOf comments .~ [" xyz ", " xyzzy "] + -- "bar" + 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 = "" :: TL.Text + -- + -- >>> doc ^.. xml.instructions.target + -- ["foo","xyz"] + -- + -- >>> doc & xml.instructions.data_ %~ Text.toUpper + -- "" +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 = "" :: TL.Text +-- +-- >>> doc ^? xml.instructions.target +-- Just "foo" +-- +-- >>> doc & xml.instructions.target .~ "boo" +-- "" +target :: Traversal' Instruction Text +target = instructionTarget +{-# INLINE target #-} + +-- | Processing instruction data +-- +-- >>> let doc = "" :: TL.Text +-- +-- >>> doc ^? xml.instructions.data_ +-- Just "bar" +-- +-- >>> doc & xml.instructions.data_ .~ "hoo" +-- "" +data_ :: Traversal' Instruction Text +data_ = instructionData +{-# INLINE data_ #-} + +-- | Anything that has a name +class HasName t where + _Name :: Lens' t Name + +instance HasName Name where + _Name = id + {-# INLINE _Name #-} + +instance HasName Element where + _Name = elementName + {-# INLINE _Name #-} + +-- | A Lens into node name +-- +-- >>> ("" :: TL.Text) ^. xml.name +-- "root" +-- +-- >>> ("" :: TL.Text) ^.. xml.plate.name +-- ["foo","bar","baz"] +-- +-- >>> ("" :: TL.Text) & xml.partsOf (plate.name) .~ ["boo", "hoo", "moo"] +-- "" +name :: HasName t => Lens' t Text +name = _Name . nameLocalName +{-# INLINE name #-} + +-- | A Lens into node namespace +-- +-- >>> ("" :: TL.Text) ^. xml.namespace +-- Nothing +-- +-- >>> ("" :: TL.Text) & xml.namespace ?~ "foo" +-- "" +-- +-- >>> ("" :: TL.Text) & xml.namespace .~ Nothing +-- "" +namespace :: HasName t => Lens' t (Maybe Text) +namespace = _Name . nameNamespace +{-# INLINE namespace #-} + +-- | A Lens into node namespace +-- +-- >>> ("" :: TL.Text) ^. xml.prefix +-- Nothing +-- +-- >>> ("" :: TL.Text) & xml.prefix ?~ "foo" +-- "" +-- +-- >>> ("" :: TL.Text) & xml.prefix ?~ "foo" +-- "" +-- +-- >>> ("" :: TL.Text) & xml.prefix .~ Nothing +-- "" +prefix :: HasName t => Lens' t (Maybe Text) +prefix = _Name . 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 #-} diff --git a/src/Text/Xml/Lens/LowLevel.hs b/src/Text/Xml/Lens/LowLevel.hs new file mode 100644 --- /dev/null +++ b/src/Text/Xml/Lens/LowLevel.hs @@ -0,0 +1,153 @@ +-- | Lenses and Prisms Template Haskell could handle +module Text.Xml.Lens.LowLevel where + +import Control.Lens +import Data.Map (Map) +import Data.Text (Text) +import Text.XML + ( ParseSettings, RenderSettings + , Document, Doctype, Prologue, ExternalID + , Node(..), Element, Instruction, Name, Miscellaneous(..) + ) +import Text.XML.Stream.Parse (DecodeEntities) +import qualified Text.XML as XML + +-- | A Lens into 'XML.rsPretty' +psDecodeEntities :: Lens' ParseSettings DecodeEntities +psDecodeEntities f ps = f (XML.psDecodeEntities ps) <&> \p -> ps { XML.psDecodeEntities = p } +{-# INLINE psDecodeEntities #-} + +-- | A Lens into 'XML.rsPretty' +rsPretty :: Lens' RenderSettings Bool +rsPretty f rs = f (XML.rsPretty rs) <&> \p -> rs { XML.rsPretty = p } +{-# INLINE rsPretty #-} + +-- | A Lens into 'XML.rsNamespaces' +rsNamespaces :: Lens' RenderSettings [(Text, Text)] +rsNamespaces f rs = f (XML.rsNamespaces rs) <&> \p -> rs { XML.rsNamespaces = p } +{-# INLINE rsNamespaces #-} + +-- | A Lens into 'XML.rsAttrOrder' +rsAttrOrder :: Lens' RenderSettings (Name -> Map Name Text -> [(Name, Text)]) +rsAttrOrder f rs = f (XML.rsAttrOrder rs) <&> \p -> rs { XML.rsAttrOrder = p } +{-# INLINE rsAttrOrder #-} + +-- | A Lens into 'XML.documentPrologue' +documentPrologue :: Lens' Document Prologue +documentPrologue f doc = f (XML.documentPrologue doc) <&> \p -> doc { XML.documentPrologue = p } +{-# INLINE documentPrologue #-} + +-- | A Lens into 'XML.documentRoot' +documentRoot :: Lens' Document Element +documentRoot f doc = f (XML.documentRoot doc) <&> \p -> doc { XML.documentRoot = p } +{-# INLINE documentRoot #-} + +-- | A Lens into 'XML.documentEpilogue' +documentEpilogue :: Lens' Document [Miscellaneous] +documentEpilogue f doc = f (XML.documentEpilogue doc) <&> \p -> doc { XML.documentEpilogue = p } +{-# INLINE documentEpilogue #-} + +-- | A Lens into 'XML.prologueBefore' +prologueBefore :: Lens' Prologue [Miscellaneous] +prologueBefore f doc = f (XML.prologueBefore doc) <&> \p -> doc { XML.prologueBefore = p } +{-# INLINE prologueBefore #-} + +-- | A Lens into 'XML.prologueDoctype' +prologueDoctype :: Lens' Prologue (Maybe Doctype) +prologueDoctype f doc = f (XML.prologueDoctype doc) <&> \p -> doc { XML.prologueDoctype = p } +{-# INLINE prologueDoctype #-} + +-- | A Lens into 'XML.prologueAfter' +prologueAfter :: Lens' Prologue [Miscellaneous] +prologueAfter f doc = f (XML.prologueAfter doc) <&> \p -> doc { XML.prologueAfter = p } +{-# INLINE prologueAfter #-} + +-- | A Lens into 'XML.doctypeName' +doctypeName :: Lens' Doctype Text +doctypeName f doc = f (XML.doctypeName doc) <&> \p -> doc { XML.doctypeName = p } +{-# INLINE doctypeName #-} + +-- | A Lens into 'XML.doctypeID' +doctypeID :: Lens' Doctype (Maybe ExternalID) +doctypeID f doc = f (XML.doctypeID doc) <&> \p -> doc { XML.doctypeID = p } +{-# INLINE doctypeID #-} + +-- | A Prism into 'XML.SystemID' +_SystemID :: Prism' ExternalID Text +_SystemID = prism' XML.SystemID (\s -> case s of XML.SystemID e -> Just e; _ -> Nothing) +{-# INLINE _SystemID #-} + +-- | A Prism into 'XML.SystemID' +_PublicID :: Prism' ExternalID (Text, Text) +_PublicID = prism' (uncurry XML.PublicID) (\s -> case s of XML.PublicID e e' -> Just (e, e'); _ -> Nothing) +{-# INLINE _PublicID #-} + +-- | A Lens into 'XML.elementName' +elementName :: Lens' Element Name +elementName f e = f (XML.elementName e) <&> \p -> e { XML.elementName = p } +{-# INLINE elementName #-} + +-- | A Lens into 'XML.elementAttributes' +elementAttributes :: Lens' Element (Map Name Text) +elementAttributes f e = f (XML.elementAttributes e) <&> \p -> e { XML.elementAttributes = p } +{-# INLINE elementAttributes #-} + +-- | A Lens into 'XML.elementNodes' +elementNodes :: Lens' Element [Node] +elementNodes f e = f (XML.elementNodes e) <&> \p -> e { XML.elementNodes = p } +{-# INLINE elementNodes #-} + +-- | A Lens into 'XML.nameLocalName' +nameLocalName :: Lens' Name Text +nameLocalName f n = f (XML.nameLocalName n) <&> \p -> n { XML.nameLocalName = p } +{-# INLINE nameLocalName #-} + +-- | A Lens into 'XML.nameNamespace' +nameNamespace :: Lens' Name (Maybe Text) +nameNamespace f n = f (XML.nameNamespace n) <&> \p -> n { XML.nameNamespace = p } +{-# INLINE nameNamespace #-} + +-- | A Lens into 'XML.namePrefix' +namePrefix :: Lens' Name (Maybe Text) +namePrefix f n = f (XML.namePrefix n) <&> \p -> n { XML.namePrefix = p } +{-# INLINE namePrefix #-} + +-- | A Lens into 'XML.instructionTarget' +instructionTarget :: Lens' Instruction Text +instructionTarget f i = f (XML.instructionTarget i) <&> \p -> i { XML.instructionTarget = p } +{-# INLINE instructionTarget #-} + +-- | A Lens into 'XML.instructionData' +instructionData :: Lens' Instruction Text +instructionData f i = f (XML.instructionData i) <&> \p -> i { XML.instructionData = p } +{-# INLINE instructionData #-} + +-- | A Prism into 'XML.NodeElement' +_NodeElement :: Prism' Node Element +_NodeElement = prism' NodeElement (\s -> case s of NodeElement e -> Just e; _ -> Nothing) +{-# INLINE _NodeElement #-} + +-- | A Prism into 'XML.NodeContent' +_NodeContent :: Prism' Node Text +_NodeContent = prism' NodeContent (\s -> case s of NodeContent e -> Just e; _ -> Nothing) +{-# INLINE _NodeContent #-} + +-- | A Prism into 'XML.NodeInstruction' +_NodeInstruction :: Prism' Node Instruction +_NodeInstruction = prism' NodeInstruction (\s -> case s of NodeInstruction e -> Just e; _ -> Nothing) +{-# INLINE _NodeInstruction #-} + +-- | A Prism into 'XML.NodeComment' +_NodeComment :: Prism' Node Text +_NodeComment = prism' NodeComment (\s -> case s of NodeComment e -> Just e; _ -> Nothing) +{-# INLINE _NodeComment #-} + +-- | A Prism into 'XML.MiscComment' +_MiscComment :: Prism' Miscellaneous Text +_MiscComment = prism' MiscComment (\s -> case s of MiscComment e -> Just e; _ -> Nothing) +{-# INLINE _MiscComment #-} + +-- | A Prism into 'XML.MiscInstruction' +_MiscInstruction :: Prism' Miscellaneous Instruction +_MiscInstruction = prism' MiscInstruction (\s -> case s of MiscInstruction e -> Just e; _ -> Nothing) +{-# INLINE _MiscInstruction #-} diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import Test.DocTest (doctest) + + +main :: IO () +main = doctest ["-isrc", "src/Text/Xml/Lens.hs", "example/queries.hs"] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Text/Xml/LensSpec.hs b/test/Text/Xml/LensSpec.hs new file mode 100644 --- /dev/null +++ b/test/Text/Xml/LensSpec.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} +module Text.Xml.LensSpec (spec) where + +import Control.Lens +import Control.Exception (evaluate) +import Test.Hspec.Lens + +import Text.XML (parseText_, def) +import Text.Xml.Lens + + +spec :: Spec +spec = + describe "AsInvalidEventStream" $ do + it "catches missing root element" $ + evaluate (parseText_ def "") `shouldThrow` _MissingRootElement + + it "catches content after root" $ + evaluate (parseText_ def "") `shouldThrow` _ContentAfterRoot + + it "catches missing end element" $ + evaluate (parseText_ def "") `shouldThrow` _MissingEndElement._1.only "root" + diff --git a/xml-html-conduit-lens.cabal b/xml-html-conduit-lens.cabal new file mode 100644 --- /dev/null +++ b/xml-html-conduit-lens.cabal @@ -0,0 +1,62 @@ +name: xml-html-conduit-lens +version: 0.1.0.0 +synopsis: Optics for xml-conduit and html-conduit +description: Optics for xml-conduit and html-conduit +homepage: https://github.com/supki/xml-html-conduit-lens#readme +license: BSD3 +license-file: LICENSE +author: Fumiaki Kinoshita, Matvey Aksenov +maintainer: Matvey Aksenov +copyright: Copyright (C) 2013 Fumiaki Kinoshita, 2014 Matvey Aksenov +category: Control +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/supki/xml-html-conduit-lens.git + +library + default-language: + Haskell2010 + build-depends: + base >= 4 && < 5 + , bytestring + , lens >= 3.8 && < 4.2 + , containers >= 0.4.0 && < 0.6 + , text >= 0.11 && < 1.2 + , xml-conduit >= 1.1 && < 1.3 + , html-conduit >= 1.1 && < 1.3 + hs-source-dirs: + src + ghc-options: + -Wall + exposed-modules: + Text.Xml.Lens + Text.Xml.Lens.LowLevel + +test-suite doctest + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Doctest.hs + build-depends: + base == 4.* + , doctest >= 0.9.10 + +test-suite hspec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base == 4.* + , hspec + , hspec-expectations-lens >= 0.2 + , lens >= 3.8 && < 4.2 + , xml-conduit >= 1.1 && < 1.3 + , xml-html-conduit-lens + other-modules: + Text.Xml.LensSpec