diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Jose Iborra (c) 2017 + +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 Jose Iborra 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,4 @@ +# hexml-lens +[![Hackage](https://img.shields.io/hackage/v/hexml-lens.svg)](https://hackage.haskell.org/package/hexml-lens) +[![Stackage Nightly](http://stackage.org/package/hexml-lens/badge/nightly)](http://stackage.org/nightly/package/hexml-lens) +[![Travis Build Status](https://travis-ci.org/pepeiborra/hexml-lens.svg)](https://travis-ci.org/pepeiborra/hexml-lens) 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/hexml-lens.cabal b/hexml-lens.cabal new file mode 100644 --- /dev/null +++ b/hexml-lens.cabal @@ -0,0 +1,52 @@ +-- This file has been generated from package.yaml by hpack version 0.17.1. +-- +-- see: https://github.com/sol/hpack + +name: hexml-lens +version: 0.1.0.0 +synopsis: Lenses for the hexml package +description: Lenses for the hexml package +category: lens +homepage: https://github.com/pepeiborra/hexml-lens#readme +author: Jose Iborra +maintainer: pepeiborra@gmail.com +copyright: All Rights Reserved +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + +library + hs-source-dirs: + src + build-depends: + base >= 4.7 && < 5 + , bytestring + , foundation + , hexml + , lens + , text + exposed-modules: + Main + Text.XML.Hexml.Lens + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: Doctests.hs + hs-source-dirs: + test + build-depends: + base >= 4.7 && < 5 + , bytestring + , foundation + , hexml + , lens + , text + , doctest + , hexml-lens + , QuickCheck + default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,5 @@ +module Main where + +main :: IO () +main = do + putStrLn "hello world" diff --git a/src/Text/XML/Hexml/Lens.hs b/src/Text/XML/Hexml/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Hexml/Lens.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE RankNTypes #-} +module Text.XML.Hexml.Lens + ( -- * Nodes + _children + , _contents + , ChildNode(..) + , TextContents(..) + -- * Attributes + , Attributes(..) + -- * Parsing + , AsXML(..) + ) where + +import Control.Lens hiding (children) +import Data.ByteString as Strict (ByteString) +import qualified Data.ByteString.Internal as Strict +import Data.ByteString.Lens +import Data.String +import qualified Data.Text as Strict +import qualified Data.Text.Encoding as Strict +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) +_contents :: Fold Node (Either ByteString Node) +_contents = folding contents + +-- --------------------------------------------------------------------------------- +-- | Folds for element nodes +class ChildNode s where + 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_ = folding $ flip childrenBy ( 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_ = folding $ flip childrenBy ( 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 ByteString where + node name_ = folding $ flip childrenBy name_ + +-- | 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_ = folding $ flip childrenBy ( name_ ^. strictTextUtf8 ) + +-- | 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 ByteString where + textContents = folding contents . _Left + +instance TextContents String where + textContents = textContents @ByteString . from strictUtf8 + +instance TextContents Strict.Text where + textContents = textContents . from strictTextUtf8 + +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 ByteString where + _Attribute n = pre $ to (`attributeBy` n) . folded . to attributeValue + iattributes = ifolding (map (\ (Attribute n v) -> (n^.from strictUtf8, v)) . attributes ) + +instance Attributes String where + _Attribute n = pre $ to (`attributeBy` (n ^. packedChars)) . folded . to attributeValue . from strictUtf8 + iattributes = iattributes @ ByteString . unpackedChars + +instance Attributes Strict.Text where + _Attribute n = pre $ to (`attributeBy` (n ^. strictTextUtf8)) . folded . to attributeValue . from strictTextUtf8 + 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 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 String where + _XML = strictUtf8 . _XML @ ByteString + +instance AsXML Strict.Text where + _XML = strictTextUtf8 . _XML + +-- --------------------------------------------------------------------------------- + +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 + +-- Test setup +-- --------------------------------------------------------------------------------- +-- $setup +-- >>> import Test.QuickCheck +-- >>> :set -XTypeApplications +-- >>> :set -XOverloadedStrings diff --git a/test/Doctests.hs b/test/Doctests.hs new file mode 100644 --- /dev/null +++ b/test/Doctests.hs @@ -0,0 +1,4 @@ +import Test.DocTest + +main :: IO () +main = doctest ["-isrc", "src/Text/XML/Hexml/Lens.hs"]