regular-xmlpickler 0.1.2 → 0.2
raw patch · 5 files changed
+154/−36 lines, 5 filesdep +textdep ~hxt
Dependencies added: text
Dependency ranges changed: hxt
Files
- CHANGELOG +11/−0
- README.md +41/−0
- regular-xmlpickler.cabal +23/−17
- src/Generics/Regular/XmlPickler/Function.hs +43/−12
- src/Generics/Regular/XmlPickler/Instances.hs +36/−7
+ CHANGELOG view
@@ -0,0 +1,11 @@+0.1.2 -> 0.2+ - Upgrade to hxt 9.2/9.3.+ - Allow missing data for Maybe fields in records.+ - Add instances for Text in addition to String.+ - More lenient Bool parsing.+ - Better error reporting in Bool parsing.+ - Strip leading and trailing underscores from element names.+ - Only lowercase first character of element names.+ - Add pickler for Either.+ - Fixed recursive schema generation.+ - Move from typLAB to Silk.
+ README.md view
@@ -0,0 +1,41 @@+This package allows you to automatically derive hxt picklers+(conversions to and from xml) using the regular generics package.++A simple example:++```Haskell+{-# LANGUAGE TemplateHaskell+ , EmptyDataDecls+ , TypeFamilies+ #-}++import Generics.Regular (deriveAll, PF)+import Text.XML.HXT.Arrow.Pickle (XmlPickler (..))+import Generics.Regular.XmlPickler (gxpickle)++data User = User+ { name :: String+ , admin :: Bool+ }++-- Derive Regular instance.+deriveAll ''User "PFUser"+type instance PF User = PFUser++-- Define generic pickler instance.+instance XmlPickler User where+ xpickle = gxpickle+```++Now you can use the functionality from `Text.XML.HXT.Arrow.Pickle`.+For example:++```+> showPickled [] (User "Simon" True)++"<user><name>Simon</name><admin>true</admin></user>"++> unpickleDoc xpickle $ head $ xread "<user><name>Simon</name><admin>true</admin></user>" :: Maybe User++Just (User {name = "Simon", admin = True})+```
regular-xmlpickler.cabal view
@@ -1,24 +1,30 @@-Name: regular-xmlpickler-Version: 0.1.2-Description: Generic generation of HXT XmlPickler instances using Regular.-Synopsis: Generic generation of HXT XmlPickler instances using Regular.-Category: XML, Data-Cabal-Version: >= 1.6-Author: typLAB-Copyright: (c) 2009, typLAB-Maintainer: code@typlab.com-Homepage: http://github.com/typLAB/regular-xmlpickler-License: BSD3-License-File: LICENSE-Build-Type: Simple+Name: regular-xmlpickler+Version: 0.2+Description: Generic generation of HXT XmlPickler instances using Regular.+Synopsis: Generic generation of HXT XmlPickler instances using Regular.+Category: XML, Data+Cabal-Version: >= 1.6+Author: Silk+Copyright: (c) 2014, Silk+Maintainer: code@silk.co+Homepage: http://github.com/silkapp/regular-xmlpickler+License: BSD3+License-File: LICENSE+Build-Type: Simple+Extra-Source-Files: CHANGELOG, README.md Library- Build-Depends: base == 4.*- , hxt >=8.3 && < 9.1+ Build-Depends: base == 4.*+ , hxt >= 9.2 && < 9.4 , regular >= 0.2 && < 0.4- + , text+ HS-Source-Dirs: src- GHC-Options: -Wall -fno-warn-orphans+ GHC-Options: -Wall Exposed-Modules: Generics.Regular.XmlPickler, Generics.Regular.XmlPickler.Function, Generics.Regular.XmlPickler.Instances++Source-Repository head+ Type: git+ Location: https://github.com/silkapp/regular-xmlpickler.git
src/Generics/Regular/XmlPickler/Function.hs view
@@ -2,6 +2,7 @@ TypeOperators , FlexibleContexts , ScopedTypeVariables+ , OverlappingInstances #-} ------------------------------------------------------------------------------- -- |@@ -16,11 +17,17 @@ -- from Generics.Regular.XmlPickler.Instances. -- --------------------------------------------------------------------------------module Generics.Regular.XmlPickler.Function (gxpickle, GXmlPickler(..)) where+module Generics.Regular.XmlPickler.Function+ ( gxpickle+ , GXmlPickler(..)+ , formatElement+ , xpEither+ ) where import Data.Char (toLower) import Generics.Regular-import Text.XML.HXT.Arrow.Pickle+import Text.XML.HXT.Core+import Text.XML.HXT.Arrow.Pickle.Xml import Text.XML.HXT.Arrow.Pickle.Schema -- | The generic XmlPickler class. This gives generic xml picklers for@@ -30,7 +37,7 @@ gxpicklef :: PU a -> PU (f a) instance GXmlPickler I where- gxpicklef = xpWrap (I, unI)+ gxpicklef pu = (xpWrap (I, unI) pu) { theSchema = ElemRef "data" } instance XmlPickler a => GXmlPickler (K a) where gxpicklef _ = (K, unK) `xpWrap` xpickle@@ -45,10 +52,10 @@ gxpicklef f = (uncurry (:*:), \(a :*: b) -> (a, b)) `xpWrap` (gxpicklef f `xpPair` gxpicklef f) instance (Constructor c, GXmlPickler f) => GXmlPickler (C c f) where- gxpicklef f = xpElem (map toLower $ conName (undefined :: C c f r)) ((C, unC) `xpWrap` (gxpicklef f))+ gxpicklef f = xpElem (formatElement $ conName (undefined :: C c f r)) ((C, unC) `xpWrap` (gxpicklef f)) instance (Selector s, GXmlPickler f) => GXmlPickler (S s f) where- gxpicklef f = xpElem (map toLower $ selName (undefined :: S s f r)) ((S, unS) `xpWrap` gxpicklef f)+ gxpicklef f = xpElem (formatElement $ selName (undefined :: S s f r)) ((S, unS) `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@@ -66,14 +73,17 @@ -- 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))- (\x -> case tl x of- (Nothing, _) -> lmap (fmap Right) (tr x)- r -> lmap (fmap Left) r)+ (\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)- where lmap f (a, b) = (f a, b) xpSum :: PU (f r) -> PU (g r) -> PU ((f :+: g) r) xpSum l r = (i, o) `xpWrap` xpEither l r@@ -82,3 +92,24 @@ i (Right x) = R x o (L x) = Left x o (R x) = Right x++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
src/Generics/Regular/XmlPickler/Instances.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, OverlappingInstances #-} ------------------------------------------------------------------------------- -- | -- Module : Generics.Regular.XmlPickler@@ -16,6 +17,8 @@ ------------------------------------------------------------------------------- module Generics.Regular.XmlPickler.Instances() where +import Data.Char (toLower)+import Data.Text (Text, pack, unpack) import Generics.Regular import Generics.Regular.XmlPickler.Function import Text.XML.HXT.Arrow.Pickle@@ -23,18 +26,44 @@ -- * Boolean instance for XmlPickler. instance XmlPickler Bool where- xpickle = (toBool, fromBool) `xpWrap` xpText+ xpickle = (toBool, fromBool) `xpWrapEither` xpText -toBool :: String -> Bool-toBool "true" = True-toBool "false" = False-toBool _ = error "No parse for bool in toBool (XmlPickler)."+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" --- * GXmlPickler instance for String.+-- * 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 (K String) where gxpicklef _ = (K, unK) `xpWrap` xpText0++instance GXmlPickler (K Text) where+ gxpicklef _ = (K . pack, unpack . unK) `xpWrap` xpText0++instance (XmlPickler a, Selector s) => GXmlPickler (S s (K (Maybe a))) where+ gxpicklef _ = (S . K, unK . unS)+ `xpWrap` xpOption (xpElem (formatElement $ selName (undefined :: S s f r)) xpickle)++instance Selector s => GXmlPickler (S s (K (Maybe String))) where+ gxpicklef _ = (S . K, unK . unS)+ `xpWrap` xpOption (xpElem (formatElement $ selName (undefined :: S s f r)) xpText0)++instance Selector s => GXmlPickler (S s (K (Maybe Text))) where+ gxpicklef _ = (S . K . fmap pack, fmap unpack . unK . unS)+ `xpWrap` xpOption (xpElem (formatElement $ selName (undefined :: S s f r)) xpText0)