summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--LICENSE30
-rw-r--r--Text/XML/HXT/Arrow/Pickle/Xml/Invertible.hs92
-rw-r--r--invertible-hxt.cabal29
3 files changed, 151 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..283a1cf
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2016-2017, Dylan Simon
+
+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 Dylan Simon 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/Text/XML/HXT/Arrow/Pickle/Xml/Invertible.hs b/Text/XML/HXT/Arrow/Pickle/Xml/Invertible.hs
new file mode 100644
index 0000000..df92a76
--- /dev/null
+++ b/Text/XML/HXT/Arrow/Pickle/Xml/Invertible.hs
@@ -0,0 +1,92 @@
+-- |Allow combining 'PU's using "Control.Invertible.Monoidal".
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Text.XML.HXT.Arrow.Pickle.Xml.Invertible
+ ( module Text.XML.HXT.Arrow.Pickle.Xml
+ , module Control.Invertible.Monoidal
+ , xpWhitespace
+ , xpTrim
+ , xpAnyCont
+ , xpAnyAttrs
+ , xpAny
+ , xpAnyElem
+ ) where
+
+import Control.Invertible.Monoidal
+import Control.Monad.State.Class (modify, state)
+import Data.Char.Properties.XMLCharProps (isXmlSpaceChar)
+import qualified Data.Invertible as Inv
+import Data.List (partition)
+import Data.Void (absurd)
+import Text.XML.HXT.Arrow.Pickle.Schema (Schema(Any), scEmpty, scSeq, scAlt, scNull)
+import Text.XML.HXT.Arrow.Pickle.Xml
+import qualified Text.XML.HXT.Core as HXT
+import qualified Text.XML.HXT.DOM.XmlNode as XN
+
+instance Inv.Functor PU where
+ fmap (f Inv.:<->: g) p = PU -- xpWrap
+ { appPickle = appPickle p . g
+ , appUnPickle = fmap f $ appUnPickle p
+ , theSchema = theSchema p
+ }
+
+instance Monoidal PU where
+ unit = xpUnit
+ p >*< q = PU -- xpPair
+ { appPickle = \(a, b) -> appPickle p a . appPickle q b
+ , appUnPickle = do
+ a <- appUnPickle p
+ b <- appUnPickle q
+ return (a, b)
+ , theSchema = theSchema p `scSeq` theSchema q
+ }
+
+instance MonoidalAlt PU where
+ zero = PU
+ { appPickle = \a _ -> absurd a
+ , appUnPickle = throwMsg "PU.zero"
+ , theSchema = scNull
+ }
+ p >|< q = PU
+ { appPickle = either (appPickle p) (appPickle q)
+ , appUnPickle = mchoice (Left <$> appUnPickle p) return (Right <$> appUnPickle q)
+ , theSchema = theSchema p `scAlt` theSchema q
+ }
+
+-- |Ignore any whitespace and produce nothing
+xpWhitespace :: PU ()
+xpWhitespace = PU
+ { appPickle = const id
+ , appUnPickle = modify $ \s -> s{ contents = dropWhile (any (all isXmlSpaceChar) . XN.getText) $ contents s }
+ , theSchema = scEmpty
+ }
+
+-- |Ignore leading whitespace
+xpTrim :: PU a -> PU a
+xpTrim = (xpWhitespace *<)
+
+-- |Like 'xpTrees' but more efficient
+xpAnyCont :: PU HXT.XmlTrees
+xpAnyCont = PU
+ { appPickle = \c s -> s{ contents = c ++ contents s }
+ , appUnPickle = state $ \s -> (contents s, s{ contents = [] })
+ , theSchema = Any -- XXX
+ }
+
+-- |All attributes
+xpAnyAttrs :: PU HXT.XmlTrees
+xpAnyAttrs = PU
+ { appPickle = \a s -> s{ attributes = a ++ attributes s }
+ , appUnPickle = state $ \s -> (attributes s, s{ attributes = [] })
+ , theSchema = Any -- XXX
+ }
+
+-- |Any content and attributes: combine 'xpAnyCont' and 'xpAnyAttrs'
+xpAny :: PU HXT.XmlTrees
+xpAny = (uncurry (++) Inv.:<->: partition XN.isAttr) >$< (xpAnyAttrs >*< xpAnyCont)
+
+-- |Any single element
+xpAnyElem :: PU HXT.XmlTree
+xpAnyElem = xpWrapEither
+ ( \e -> if XN.isElem e then Right e else Left "xpAnyElem: any element expected"
+ , id
+ ) xpTree
diff --git a/invertible-hxt.cabal b/invertible-hxt.cabal
new file mode 100644
index 0000000..29fc653
--- /dev/null
+++ b/invertible-hxt.cabal
@@ -0,0 +1,29 @@
+name: invertible-hxt
+version: 0.1
+synopsis: invertible transformer instances for HXT Picklers
+description: Provides alternative syntax for HXT's Picklers (XML parser/generators) based on generic invertible Monoidal
+license: BSD3
+license-file: LICENSE
+author: Dylan Simon
+maintainer: dylan@dylex.net
+copyright: 2017
+category: Composition, XML
+build-type: Simple
+cabal-version: >=1.10
+tested-with: GHC == 7.10.3, GHC == 8.0.1
+
+source-repository head
+ type: git
+ location: https://github.com/dylex/invertible
+
+library
+ exposed-modules:
+ Text.XML.HXT.Arrow.Pickle.Xml.Invertible
+ build-depends:
+ base >= 4.8 && <5,
+ mtl,
+ hxt,
+ hxt-charproperties,
+ invertible
+ default-language: Haskell2010
+ ghc-options: -Wall