generic-xmlpickler (empty) → 0.1.0.0

raw patch · 6 files changed

+257/−0 lines, 6 filesdep +basedep +generic-derivingdep +hxtsetup-changed

Dependencies added: base, generic-deriving, hxt, text

Files

CHANGELOG.md +3/−0
LICENSE +28/−0
README.md +36/−0
Setup.hs +2/−0
generic-xmlpickler.cabal +32/−0
src/Generics/XmlPickler.hs +156/−0

+ CHANGELOG.md view

@@ -0,0 +1,3 @@+## 0.1.0.0++* Initial release, ported from regular-xmlpickler.

+ LICENSE view

@@ -0,0 +1,28 @@+Copyright (c) 2015 Silk B.V.+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.+

+ README.md view

@@ -0,0 +1,36 @@+# generic-xmlpickler+[![Build Status](https://travis-ci.org/silkapp/generic-xmlpickler.svg?branch=master)](https://travis-ci.org/silkapp/generic-xmlpickler)++This package allows you to automatically derive+[hxt](http://hackage.haskell.org/package/hxt) picklers (conversions to+and from xml) using GHC Generics. It has been ported from+[regular-xmlpickler](http://hackage.haskell.org/package/regular-xmlpickler)++A simple example:++```Haskell+{-# LANGUAGE DeriveGeneric #-}++import GHC.Generics+import Data.Maybe (listToMaybe)+import Generics.XmlPickler (gxpickle)+import Text.XML.HXT.Arrow.Pickle (XmlPickler (..), showPickled, unpickleDoc)+import Text.XML.HXT.Parser.XmlParsec (xread)++data User = User+  { name  :: String+  , admin :: Bool+  } deriving (Show, Generic)++instance XmlPickler User where+  xpickle = gxpickle+++userString :: String+userString = showPickled [] (User "Simon" True)+-- = "<user><name>Simon</name><admin>true</admin></user>"++user :: Maybe User+user = unpickleDoc xpickle =<< listToMaybe (xread "<user><name>Simon</name><admin>true</admin></user>")+-- = Just (User {name = "Simon", admin = True})+```

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ generic-xmlpickler.cabal view

@@ -0,0 +1,32 @@+name:                generic-xmlpickler+version:             0.1.0.0+description:         Generic generation of HXT XmlPickler instances using GHC Generics.+synopsis:            Generic generation of HXT XmlPickler instances using GHC Generics.+category:            XML, Data+cabal-version:       >= 1.6+author:              Silk+copyright:           (c) 2015, Silk+maintainer:          code@silk.co+homepage:            http://github.com/silkapp/generic-xmlpickler+license:             BSD3+license-file:        LICENSE+build-type:          Simple++extra-source-files:+  CHANGELOG.md+  LICENSE+  README.md++source-repository head+  type:              git+  location:          https://github.com/silkapp/regular-xmlpickler.git++library+  ghc-options:       -Wall+  hs-source-dirs:    src+  exposed-modules:   Generics.XmlPickler+  build-depends:+      base == 4.*+    , generic-deriving >= 1.6 && < 1.8+    , hxt >= 9.2 && < 9.4+    , text

+ src/Generics/XmlPickler.hs view

@@ -0,0 +1,156 @@+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE+    FlexibleContexts+  , FlexibleInstances+  , OverlappingInstances+  , ScopedTypeVariables+  , TypeOperators+  #-}+module Generics.XmlPickler+  ( gxpickle+  , GXmlPickler (..)+  , formatElement+  , xpEither+  ) where++import Data.Char (toLower)+import Data.Text (Text, pack, unpack)+import GHC.Generics+import Generics.Deriving.ConNames+import Text.XML.HXT.Arrow.Pickle.Schema+import Text.XML.HXT.Arrow.Pickle.Xml++-- | The generic XmlPickler class. This gives generic xml picklers for+-- the functors from 'Generics.Regular'. These are usually not used+-- directly.+class GXmlPickler f where+  gxpicklef :: PU a -> PU (f a)++-- Void: Used for data types without constructors+--instance GXmlPickler I where+--  gxpicklef pu = (xpWrap (I, unI) pu) { theSchema = ElemRef "data" }++instance XmlPickler a => GXmlPickler (K1 i a) where+  gxpicklef _ = (K1, unK1) `xpWrap` xpickle++instance GXmlPickler U1 where+  gxpicklef _ = (const U1, const ()) `xpWrap` xpUnit++instance (GXmlPickler f, GXmlPickler g) => GXmlPickler (f :+: g) where+  gxpicklef f = gxpicklef f `xpSum` gxpicklef f++instance (GXmlPickler f, GXmlPickler g) => GXmlPickler (f :*: g) where+  gxpicklef f = (uncurry (:*:), \(a :*: b) -> (a, b)) `xpWrap` (gxpicklef f `xpPair` gxpicklef f)++instance GXmlPickler f => GXmlPickler (M1 D c f) where+  gxpicklef f = (M1, unM1) `xpWrap` gxpicklef f++instance (Constructor c, GXmlPickler f) => GXmlPickler (M1 C c f) where+  gxpicklef f = xpElem (formatElement $ conName (undefined :: M1 C c f p)) ((M1, unM1) `xpWrap` gxpicklef f)++instance (Selector c, GXmlPickler f) => GXmlPickler (M1 S c f) where+  gxpicklef f = xpElem (formatElement $ selName (undefined :: M1 S c f p)) ((M1, unM1) `xpWrap` gxpicklef f)++-- | The generic pickler. Uses a tag for each constructor with the+-- lower case constructor name, and a tag for each record field with+-- the lower case field name. Most values are pickled using their own+-- 'XmlPickler' instance, and 'String's are pickled as possibly empty+-- text nodes.+gxpickle :: forall a. (Generic a, GXmlPickler (Rep a), ConNames (Rep a)) => PU a+gxpickle = (to, from) `xpWrap` gxpicklef (gxpickle :: PU a)++-- * Pickling combinators++-- | Combine two picklers into a pickler for 'Either'. While pickling,+-- check if the either is a 'Left' or 'Right' and use the appropriate+-- pickler. During unpickling, first try the first, and if it fails,+-- try the second.+xpEither :: PU a -> PU b -> PU (Either a b)+xpEither ~(PU fl tl sa) ~(PU fr tr sb) = PU+  (\x st -> case x of+              Left  y -> fl y st+              Right y -> fr y st)+  (UP $ \x -> case runUP tl x of+                -- When the first fails with error message es, try the second+                (Left (es, _), _) ->+                  case runUP tr x of+                    (Left (es', _), st)  -> (Left (es ++ "\n" ++ es', st), st)+                    (Right r, st) -> (Right (Right r), st)+                (Right r, st) -> (Right (Left r), st))+  (sa `scAlt` sb)++xpSum :: PU (f r) -> PU (g r) -> PU ((f :+: g) r)+xpSum l r = (i, o) `xpWrap` xpEither l r+  where+    i (Left  x) = L1 x+    i (Right x) = R1 x+    o (L1 x) = Left x+    o (R1 x) = Right x++-- * Boolean instance for XmlPickler.++instance XmlPickler Bool where+  xpickle = (toBool, fromBool) `xpWrapEither` xpText++toBool :: String -> Either String Bool+toBool k | k' == "yes"  = Right True+         | k' == "true" = Right True+         | k' == "on"   = Right True+  where k' = map toLower k+toBool k | k' == "no"    = Right False+         | k' == "false" = Right False+         | k' == "off"   = Right False+  where k' = map toLower k+toBool k                 = Left ("XmlPickler Bool: unexpected value: " ++ k)++fromBool :: Bool -> String+fromBool True  = "true"+fromBool False = "false"++-- * Either instance for XmlPickler.++instance (XmlPickler a, XmlPickler b) => XmlPickler (Either a b) where+  xpickle = xpEither xpickle xpickle++-- * GXmlPickler instance for String, Text and Maybes.++instance GXmlPickler (K1 i String) where+  gxpicklef _ = (K1, unK1) `xpWrap` xpText0++instance GXmlPickler (K1 i Text) where+  gxpicklef _ = (K1 . pack, unpack . unK1) `xpWrap` xpText0++instance (XmlPickler a, Selector c) => GXmlPickler (M1 S c (K1 i (Maybe a))) where+  gxpicklef _ = (M1 . K1, unK1 . unM1)+         `xpWrap` xpOption (xpElem (formatElement $ selName (undefined :: M1 S c f p)) xpickle)++instance Selector c => GXmlPickler (M1 S c (K1 i (Maybe String))) where+  gxpicklef _ = (M1 . K1, unK1 . unM1)+         `xpWrap` xpOption (xpElem (formatElement $ selName (undefined :: M1 S c f p)) xpText0)++instance Selector c => GXmlPickler (M1 S c (K1 i (Maybe Text))) where+  gxpicklef _ = (M1 . K1 . fmap pack, fmap unpack . unK1 . unM1)+         `xpWrap` xpOption (xpElem (formatElement $ selName (undefined :: M1 S c f p)) xpText0)++-- * Utilities++formatElement :: String -> String+formatElement = headToLower+              . stripLeadingAndTrailingUnderscore++headToLower :: String -> String+headToLower []     = []+headToLower (x:xs) = toLower x : xs++stripLeadingAndTrailingUnderscore :: String -> String+stripLeadingAndTrailingUnderscore = stripLeadingUnderscore+                                  . stripTrailingUnderscore++stripLeadingUnderscore :: String -> String+stripLeadingUnderscore ('_':ls) = ls+stripLeadingUnderscore ls       = ls++stripTrailingUnderscore :: String -> String+stripTrailingUnderscore ""         = ""+stripTrailingUnderscore (x:'_':[]) = [x]+stripTrailingUnderscore (x:xs)     = x : stripTrailingUnderscore xs