diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2013 Brendan Hay +Initial non-GHC.Generics implementation Copyright (c) 2009 typLAB + +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of Universiteit Utrecht nor the names of its 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,37 @@ +## hexpat-generic-pickle + +[![Build Status](https://secure.travis-ci.org/brendanhay/hexpat-generic-pickle.png)](http://travis-ci.org/brendanhay/hexpat-generic-pickle) + + +## Table of Contents + +* [Introduction](#introduction) +* [Examples](#examples) +* [Compatibility](#compatibility) +* [Contributing](#contributing) +* [Licence](#licence) + + +## Introduction + +> TODO + + +## Examples + +> TODO + + +## Compatibility + +> TODO + + +## Contributing + +For any problems, comments or feedback please create an issue [here on GitHub](github.com/brendanhay/hexpat-generic-pickle/issues). + + +## Licence + +hexpat-generic-pickle is released under the [Mozilla Public License Version 2.0](http://www.mozilla.org/MPL/) 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/hexpat-pickle-generic.cabal b/hexpat-pickle-generic.cabal new file mode 100644 --- /dev/null +++ b/hexpat-pickle-generic.cabal @@ -0,0 +1,40 @@ +name: hexpat-pickle-generic +version: 0.1.0 +synopsis: Picklers for de/serialising Generic data types to and from XML +license: BSD3 +license-file: LICENSE +author: Brendan Hay +maintainer: Brendan Hay +copyright: Copyright (c) 2013 Brendan Hay +stability: Experimental +category: Data, XML +build-type: Simple +cabal-version: >= 1.10 + +description: + An IsXML class and GHC.Generics implementation for pickleable + data types using hexpat and hexpat-pickle. + +extra-source-files: + README.md + +source-repository head + type: git + location: git://github.com/brendanhay/hexpat-pickle-generic.git + +library + default-language: Haskell2010 + hs-source-dirs: src + + exposed-modules: + Text.XML.Expat.Pickle.Generic + + ghc-options: + -Wall + -O2 + + build-depends: + base >= 4.6 && < 5 + , bytestring + , hexpat-pickle + , text diff --git a/src/Text/XML/Expat/Pickle/Generic.hs b/src/Text/XML/Expat/Pickle/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Text/XML/Expat/Pickle/Generic.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +-- Module : Text.XML.Expat.Pickle.Generic +-- Copyright : (c) 2013 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- Berkeley Software Distribution License, v. 3.0. +-- You can obtain it at +-- http://http://opensource.org/licenses/BSD-3-Clause. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Text.XML.Expat.Pickle.Generic + ( + -- * Class + IsXML (..) + + -- * Functions + , encode + , decode + , decodeEither + + -- * Re-exported Data Types + , PU (..) + + -- * Options + , Options (..) + , defaultOptions + + -- * Generics + , genericXMLPickler + + -- * Combinators + , xpSum + , xpEither + , xpGenericString + + -- * Re-exported Combinators + , xpText0 + , xpText + , xpList0 + , xpList + , xpContent + , xpPrim + , xpWrap + ) where + +import Data.ByteString (ByteString) +import Data.Char (isLower) +import Data.Text (Text) +import GHC.Generics +import qualified Text.XML.Expat.Pickle as Pickle +import Text.XML.Expat.Pickle hiding (xpPrim) + +-- +-- Class +-- + +class IsXML a where + xmlPickler :: PU [UNode ByteString] a + + default xmlPickler :: (Generic a, GIsXML [UNode ByteString] (Rep a)) + => PU [UNode ByteString] a + xmlPickler = genericXMLPickler defaultOptions + +-- +-- Functions +-- + +encode :: IsXML a => a -> ByteString +encode = pickleXML' (xpRoot xmlPickler) + +decode :: IsXML a => ByteString -> Maybe a +decode = either (const Nothing) Just . decodeEither + +decodeEither :: IsXML a => ByteString -> Either String a +decodeEither = unpickleXML' defaultParseOptions (xpRoot xmlPickler) + +-- +-- Defining Picklers +-- + +data Options = Options + { constructorTagModifier :: String -> String + -- ^ Function applied to constructor tags. + , fieldLabelModifier :: String -> String + -- ^ Function applied to record field labels. + } + +defaultOptions :: Options +defaultOptions = Options id (dropWhile isLower) + +-- +-- Generics +-- + +genericXMLPickler opts = + (to, from) `xpWrap` (gXMLPickler opts) (genericXMLPickler opts) + +class GIsXML t f where + gXMLPickler :: Options -> PU t a -> PU t (f a) + +instance IsXML a => GIsXML [UNode ByteString] (K1 i a) where + gXMLPickler _ _ = (K1, unK1) `xpWrap` xmlPickler + +instance GIsXML [t] U1 where + gXMLPickler _ _ = (const U1, const ()) `xpWrap` xpUnit + +instance (GIsXML t f, GIsXML t g) => GIsXML t (f :+: g) where + gXMLPickler opts f = gXMLPickler opts f `xpSum` gXMLPickler opts f + +instance (GIsXML [t] f, GIsXML [t] g) => GIsXML [t] (f :*: g) where + gXMLPickler opts f = xpWrap + (uncurry (:*:), \(a :*: b) -> (a, b)) + (gXMLPickler opts f `xpPair` gXMLPickler opts f) + +instance (Datatype d, GIsXML t f) => GIsXML t (M1 D d f) where + gXMLPickler opts = xpWrap (M1, unM1) . gXMLPickler opts + +instance (Constructor c, GIsXML [UNode ByteString] f) + => GIsXML [UNode ByteString] (M1 C c f) where + gXMLPickler opts f = xpElemNodes + (gxFromString . constructorTagModifier opts $ conName (undefined :: M1 C c f r)) + ((M1, unM1) `xpWrap` gXMLPickler opts f) + +instance (Selector s, GIsXML [UNode ByteString] f) + => GIsXML [UNode ByteString] (M1 S s f) where + gXMLPickler opts f = xpElemNodes + (gxFromString . fieldLabelModifier opts $ selName (undefined :: M1 S s f r)) + ((M1, unM1) `xpWrap` gXMLPickler opts f) + +-- +-- Combinators +-- + +xpPrim :: (Read b, Show b, GenericXMLString t) => PU [Node a t] b +xpPrim = xpContent Pickle.xpPrim + +xpSum :: PU t (f r) -> PU t (g r) -> PU t ((f :+: g) r) +xpSum left right = (inp, out) `xpWrap` xpEither left right + where + inp (Left x) = L1 x + inp (Right x) = R1 x + + out (L1 x) = Left x + out (R1 x) = Right x + +xpEither :: PU t a -> PU t b -> PU t (Either a b) +xpEither ~(PU _ uea pa) ~(PU ub ueb pb) = + PU unpickle unpickleEither pickle + where + unpickle t = case uea t of + Right x -> Left x + Left _ -> Right $ ub t + + unpickleEither t = case uea t of + Right x -> Right . Left $ x + Left _ -> Right `fmap` ueb t + + pickle (Left x) = pa x + pickle (Right y) = pb y + +xpGenericString :: GenericXMLString t => PU [UNode ByteString] t +xpGenericString = (gxFromByteString, gxToByteString) `xpWrap` xpContent xpText0 + +-- +-- Instances +-- + +instance IsXML Int where + xmlPickler = xpPrim + +instance IsXML Integer where + xmlPickler = xpPrim + +instance IsXML Text where + xmlPickler = xpGenericString + +instance IsXML ByteString where + xmlPickler = xpGenericString + +instance IsXML a => IsXML (Maybe a) where + xmlPickler = xpOption xmlPickler + +instance IsXML a => IsXML [a] where + xmlPickler = xpList0 xmlPickler