hexpat-pickle-generic 0.1.3 → 0.1.5

raw patch · 3 files changed

+435/−79 lines, 3 filesdep +QuickCheckdep +hexpatdep +hexpat-pickle-genericdep −hexpat-pickledep −textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck, hexpat, hexpat-pickle-generic, test-framework, test-framework-quickcheck2

Dependencies removed: hexpat-pickle, text

API changes (from Hackage documentation)

Files

• hexpat-pickle-generic.cabal +22/−6
• src/Text/XML/Expat/Pickle/Generic.hs +242/−73
• test/Main.hs +171/−0

@@ -1,5 +1,5 @@ name:                  hexpat-pickle-generic-version:               0.1.3+version:               0.1.5 synopsis:              Picklers for de/serialising Generic data types to and from XML license:               BSD3 license-file:          LICENSE@@ -12,8 +12,7 @@ cabal-version:         >= 1.10  description:-    An IsXML class and GHC.Generics implementation for pickleable-    data types using hexpat and hexpat-pickle.+    An IsXML class and GHC.Generics implementation for pickleable data types using hexpat.  extra-source-files:     README.md@@ -34,7 +33,24 @@         -O2      build-depends:-        base          >= 4.6 && < 5+        base       >= 4.6 && < 5       , bytestring-      , hexpat-pickle-      , text+      , hexpat++test-suite hexpat-pickle-generic-tests+    default-language:   Haskell2010+    type:               exitcode-stdio-1.0+    hs-source-dirs:     test+    main-is:            Main.hs++    ghc-options:+        -Wall+        -fwarn-tabs++    build-depends:+        base                       >= 4.6 && < 5+      , bytestring+      , hexpat-pickle-generic+      , QuickCheck                 >= 2.5+      , test-framework             >= 0.8+      , test-framework-quickcheck2 >= 0.3

@@ -1,10 +1,16 @@ {-# LANGUAGE DefaultSignatures               #-}+{-# LANGUAGE DefaultSignatures               #-}+{-# LANGUAGE DeriveGeneric                   #-} {-# LANGUAGE FlexibleContexts                #-} {-# LANGUAGE FlexibleInstances               #-}+{-# LANGUAGE FunctionalDependencies          #-}+{-# LANGUAGE KindSignatures                  #-} {-# LANGUAGE MultiParamTypeClasses           #-}+{-# LANGUAGE OverlappingInstances            #-} {-# LANGUAGE OverloadedStrings               #-} {-# LANGUAGE ScopedTypeVariables             #-} {-# LANGUAGE TypeOperators                   #-}+{-# LANGUAGE UndecidableInstances            #-} {-# LANGUAGE ViewPatterns                    #-}  {-# OPTIONS_GHC -fno-warn-missing-signatures #-}@@ -25,11 +31,12 @@       IsXML      (..)      -- * Functions-    , encodeXML-    , decodeXML+    , toXML+    , toIndentedXML+    , fromXML -    -- * Re-exported Data Types-    , PU         (..)+    -- * Data Types+    , XMLPU      (..)      -- * Options     , XMLOptions (..)@@ -37,65 +44,101 @@      -- * Generics     , genericXMLPickler+    , rootXMLPickler      -- * Combinators+    , xpWrap+    , xpList+    , xpElemList+    , xpElem     , xpSum     , xpEither-    , xpGenericString--    -- * Re-exported Combinators-    , xpText0+    , xpPrim+    , xpEmpty+    , xpOption+    , xpPair+    , xpUnit+    , xpLift     , xpText-    , xpList0-    , xpList+    , xpText0     , xpContent-    , xpPrim-    , xpWrap     ) where  import           Data.ByteString       (ByteString)-import           Data.Char             (isLower)-import           Data.Text             (Text)+import qualified Data.ByteString.Char8 as BS+import           Data.Char             (isLower, isSpace)+import           Data.Either+import           Data.Maybe+import           Data.Monoid import           GHC.Generics-import qualified Text.XML.Expat.Pickle as Pickle-import           Text.XML.Expat.Pickle hiding (xpPrim)+import           Text.XML.Expat.Format+import           Text.XML.Expat.Tree   hiding (Node)  -- -- Class -- +type Node = UNode ByteString++data XMLPU t a = XMLPU+    { pickleTree   :: a -> t+    , unpickleTree :: t -> Either String a+    , root     :: Maybe ByteString+    }++type PU = XMLPU+ class IsXML a where-    xmlPickler :: PU [UNode ByteString] a+    xmlPickler :: PU [Node] a -    default xmlPickler :: (Generic a, GIsXML [UNode ByteString] (Rep a))-                      => PU [UNode ByteString] a+    default xmlPickler :: (Generic a, GIsXML (Rep a)) => PU [Node] a     xmlPickler = genericXMLPickler defaultXMLOptions  -- -- Functions -- -encodeXML :: IsXML a => a -> ByteString-encodeXML = pickleXML' (xpRoot xmlPickler)+toXML :: IsXML a => a -> ByteString+toXML = format' . maybe head (\n -> Element n []) (root pu) . pickleTree pu+  where+    pu = xmlPickler -decodeXML :: IsXML a => ByteString -> Either String a-decodeXML = unpickleXML' defaultParseOptions (xpRoot xmlPickler)+toIndentedXML :: IsXML a => Int -> a -> ByteString+toIndentedXML i = format'+    . indent i+    . maybe head (\n -> Element n []) (root pu)+    . pickleTree pu+  where+    pu = xmlPickler +fromXML :: IsXML a => ByteString -> Either String a+fromXML = either (Left . show) unwrap . parse' defaultParseOptions+  where+    unwrap e@(Element n _ cs) = case root pu of+        Just x | x == n -> unpickleTree pu cs+        Just _          -> Left "Unexpected root element"+        Nothing         -> unpickleTree pu [e]+    unwrap                  _ = Left "Unexpected root element"++    pu = xmlPickler+ ----- Defining Picklers+-- Options --  data XMLOptions = XMLOptions-    { xmlCtorModifier  :: String -> String+    { xmlCtorModifier  :: String -> ByteString       -- ^ Function applied to constructor tags.-    , xmlFieldModifier :: String -> String+    , xmlFieldModifier :: String -> ByteString       -- ^ Function applied to record field labels.+    , xmlListElement   :: ByteString+      -- ^ Default element name to wrap list items with.     }  type Options = XMLOptions  defaultXMLOptions :: Options-defaultXMLOptions = XMLOptions id (dropWhile isLower)+defaultXMLOptions = XMLOptions BS.pack (BS.pack . dropWhile isLower) "Value"  -- -- Generics@@ -104,46 +147,93 @@ genericXMLPickler opts =     (to, from) `xpWrap` (gXMLPickler opts) (genericXMLPickler opts) -class GIsXML t f where-    gXMLPickler :: Options -> PU t a -> PU t (f a)+rootXMLPickler name =+    (genericXMLPickler defaultXMLOptions) { root = Just name } -instance IsXML a => GIsXML [UNode ByteString] (K1 i a) where-    gXMLPickler _ _ = (K1, unK1) `xpWrap` xmlPickler+class GIsXML f where+    gXMLPickler :: Options -> PU [Node] a -> PU [Node] (f a) -instance GIsXML [t] U1 where-    gXMLPickler _ _ = (const U1, const ()) `xpWrap` xpUnit+instance IsXML a => GIsXML (K1 i a) where+    gXMLPickler _ _ = (K1, unK1) `xpWrap` xmlPickler -instance (GIsXML t f, GIsXML t g) => GIsXML t (f :+: g) where+instance (GIsXML a, GIsXML b) => GIsXML (a :+: b) where     gXMLPickler opts f = gXMLPickler opts f `xpSum` gXMLPickler opts f -instance (GIsXML [t] f, GIsXML [t] g) => GIsXML [t] (f :*: g) where+instance (GIsXML a, GIsXML b) => GIsXML (a :*: b) 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+instance (Datatype d, GIsXML a) => GIsXML (D1 d a) 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 . xmlCtorModifier opts $ conName (undefined :: M1 C c f r))-        ((M1, unM1) `xpWrap` gXMLPickler opts f)+instance (Constructor c, GIsXML a) => GIsXML (C1 c a) where+    gXMLPickler opts f = (xpWrap (M1, unM1) $ gXMLPickler opts f)+        { root = Just . xmlCtorModifier opts $ conName (undefined :: C1 c a p)+        } -instance (Selector s, GIsXML [UNode ByteString] f)-         => GIsXML [UNode ByteString] (M1 S s f) where-    gXMLPickler opts f = xpElemNodes-        (gxFromString . xmlFieldModifier opts $ selName (undefined :: M1 S s f r))+instance (Selector s, GIsXML a) => GIsXML (S1 s a) where+    gXMLPickler opts f = xpElem+        (xmlFieldModifier opts $ selName (undefined :: S1 s a p))         ((M1, unM1) `xpWrap` gXMLPickler opts f) +instance (Selector s, IsXML a) => GIsXML (S1 s (K1 i [a])) where+    gXMLPickler opts _ = xpElem+        (xmlFieldModifier opts $ selName (undefined :: t s (K1 i [a]) p))+        ((M1 . K1, unK1 . unM1) `xpWrap` xpList (xpElem key pu))+      where+        key = fromMaybe (xmlListElement opts) $ root pu+        pu  = xmlPickler+ -- -- Combinators -- -xpPrim :: (Read b, Show b, GenericXMLString t) => PU [Node a t] b-xpPrim = xpContent Pickle.xpPrim+xpWrap :: (a -> b, b -> a) -> PU [n] a -> PU [n] b+xpWrap (f, g) pu = XMLPU+    { pickleTree   = pickleTree pu . g+    , unpickleTree = fmap f . unpickleTree pu+    , root         = root pu+    } -xpSum :: PU t (f r) -> PU t (g r) -> PU t ((f :+: g) r)+xpElemList :: ByteString -> PU [Node] a -> PU [Node] [a]+xpElemList name = xpList . xpElem name++xpList :: PU [Node] a -> PU [Node] [a]+xpList pu = XMLPU+    { pickleTree   = concatMap (pickleTree pu)+    , unpickleTree = concatEithers . unpickle+    , root         = root pu+    }+  where+    unpickle (e@(Element _ _ _):es) = unpickleTree pu [e] : unpickle es+    unpickle (_:es)                 = unpickle es+    unpickle []                     = []++    concatEithers xs = case partitionEithers xs of+        ([], rs) -> Right rs+        (l:_, _) -> Left l++xpElem :: ByteString -> PU [Node] a -> PU [Node] a+xpElem name pu = XMLPU+    { pickleTree   = \x -> [Element name [] (pickleTree pu x)]+    , unpickleTree = \t ->+          let children = map matching t+          in case catMaybes children of+                 []    -> Left $ "can't find " ++ tag+                 (x:_) -> case x of+                     Left e -> Left $ "in " ++ tag ++ ", " ++ e+                     r      -> r+    , root = Just name+    }+  where+    matching (Element n _ cs)+        | n == name = Just $ unpickleTree pu cs+    matching _      = Nothing++    tag = "<" ++ gxToString name ++ ">"++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@@ -152,42 +242,121 @@     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+xpEither :: PU [t] a -> PU [t] b -> PU [t] (Either a b)+xpEither pa pb = XMLPU+    { pickleTree   = either (pickleTree pa) (pickleTree pb)+    , unpickleTree = \t -> case unpickleTree pa t of+          Right x -> Right . Left $ x+          Left  _ -> Right `fmap` unpickleTree pb t+    , root     = listToMaybe $ catMaybes [root pa, root pb]+    } -    unpickleEither t = case uea t of-        Right x -> Right . Left $ x-        Left  _ -> Right `fmap` ueb t+xpPrim :: (Read a, Show a) => PU ByteString a+xpPrim = XMLPU+    { pickleTree   = BS.pack . show+    , unpickleTree = \t ->+        let s = BS.unpack t+        in case reads s of+               [(x, "")] -> Right x+               _         -> Left $ "failed to read text: " ++ s+    , root         = Nothing+    } -    pickle (Left x)  = pa x-    pickle (Right y) = pb y+xpEmpty :: (Read a, Show a) => PU [Node] a+xpEmpty = XMLPU+    { pickleTree   = \x -> [Element (BS.pack $ show x) [] []]+    , unpickleTree = \t -> case t of+          [(Element n [] [])] -> let s = BS.unpack n+                                 in case reads s of+              [(x, "")] -> Right x+              _         -> Left $ "failed to read text: " ++ s+          _ -> Left "Expected empty element"+    , root        = Nothing+    } -xpGenericString :: GenericXMLString t => PU [UNode ByteString] t-xpGenericString = (gxFromByteString, gxToByteString) `xpWrap` xpContent xpText0+xpOption :: PU [n] a -> PU [n] (Maybe a)+xpOption pu = XMLPU+    { pickleTree   = maybe [] (pickleTree pu)+    , unpickleTree = Right . either (const Nothing) Just . unpickleTree pu+    , root     = root pu+    } +xpPair :: PU [n] a -> PU [n] b -> PU [n] (a, b)+xpPair pa pb = XMLPU+    { pickleTree   = \(a, b) -> pickleTree pa a ++ pickleTree pb b+    , unpickleTree = \t ->+          case (unpickleTree pa t, unpickleTree pb t) of+              (Right a, Right b) -> Right (a, b)+              (Left e,  _)       -> Left $ "in 1st of pair, " ++ e+              (_,       Left e)  -> Left $ "in 2nd of pair, " ++ e+    , root     = listToMaybe $ catMaybes [root pa, root pb]+    }++xpUnit :: PU [n] ()+xpUnit = xpLift ()++xpLift :: a -> PU [n] a+xpLift a = XMLPU+    { pickleTree   = const []+    , unpickleTree = const $ Right a+    , root     = Nothing+    }++xpText :: PU ByteString ByteString+xpText = XMLPU+    { pickleTree   = id+    , unpickleTree = \t -> if BS.null t then Left "empty text" else Right t+    , root         = Nothing+    }++xpText0 :: PU ByteString ByteString+xpText0 = XMLPU+    { pickleTree   = id+    , unpickleTree = Right+    , root         = Nothing+    }++xpContent :: PU ByteString a -> PU [Node] a+xpContent pu = XMLPU+    { pickleTree   = \t ->+          let txt = pickleTree pu t+          in if gxNullString txt then [] else [Text txt]+    , unpickleTree = unpickleTree pu . mconcat . map extract+    , root     = root pu+    }+  where+    extract (Element _ _ cs) = strip . mconcat $ map extract cs+    extract (Text txt)       = strip txt++    strip = snd . BS.break valid . fst . BS.breakEnd valid++    valid c+        | isSpace c = False+        | c == '\r' = False+        | c == '\n' = False+        | otherwise = True+ -- -- Instances -- +instance IsXML a => IsXML (Maybe a) where+    xmlPickler = xpOption xmlPickler++instance (IsXML a, IsXML b) => IsXML (Either a b) where+    xmlPickler = xmlPickler `xpEither` xmlPickler+ instance IsXML Int where-    xmlPickler = xpPrim+    xmlPickler = xpContent xpPrim  instance IsXML Integer where-    xmlPickler = xpPrim--instance IsXML Text where-    xmlPickler = xpGenericString+    xmlPickler = xpContent xpPrim -instance IsXML ByteString where-    xmlPickler = xpGenericString+instance IsXML Double where+    xmlPickler = xpContent xpPrim -instance IsXML a => IsXML (Maybe a) where-    xmlPickler = xpOption xmlPickler+instance IsXML Float where+    xmlPickler = xpContent xpPrim -instance IsXML a => IsXML [a] where-    xmlPickler = xpList0 xmlPickler+instance IsXML ByteString where+    xmlPickler = xpContent xpText

@@ -0,0 +1,171 @@+{-# LANGUAGE DeriveGeneric             #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}++{-# OPTIONS_GHC -fno-warn-orphans      #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}++-- Module      : Main+-- Copyright   : (c) 2013 Brendan Hay <brendan.g.hay@gmail.com>+-- License     : This Source Code Form is subject to the terms of+--               the Mozilla Public License, v. 2.0.+--               A copy of the MPL can be found in the LICENSE file or+--               you can obtain it at http://mozilla.org/MPL/2.0/.+-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>+-- Stability   : experimental+-- Portability : non-portable (GHC extensions)++module Main (main) where++import           Control.Applicative+import           Data.ByteString                      (ByteString)+import qualified Data.ByteString.Char8                as BS+import           Data.List                            (stripPrefix)+import           Data.Maybe+import           Data.String+import           GHC.Generics+import           Test.Framework+import           Test.Framework.Providers.QuickCheck2+import           Test.QuickCheck+import           Text.XML.Expat.Pickle.Generic++main :: IO ()+main = defaultMain+    [ testGroup "Isomorphisms"+        [ testProperty "Flat"    (xml :: Iso Flat)+        , testProperty "Nested"  (xml :: Iso Nested)+        , testProperty "Maybe"   (xml :: Iso MaybeRec)+        , testProperty "Complex" (xml :: Iso Complex)+        , testProperty "List"    (xml :: Iso ListRec)+        , testProperty "Nullary" (xml :: Iso Nullary)+        ]+    , testGroup "Generic Option Modifiers"+        [ testProperty "Constructors" (xml :: Iso Ctors)+        , testProperty "Fields"       (xml :: Iso Fields)+        ]+    ]++data Flat = Flat+    { fooInt        :: Int+    , fooByteString :: ByteString+    } deriving (Eq, Show, Generic)++instance IsXML Flat++instance Arbitrary Flat where+    arbitrary = Flat <$> arbitrary <*> arbitrary++data Nested = Nested+    { barInt     :: Int+    , barInteger :: Integer+    , barFlat     :: Flat+    } deriving (Eq, Show, Generic)++instance IsXML Nested++instance Arbitrary Nested where+    arbitrary = Nested <$> arbitrary <*> arbitrary <*> arbitrary++data MaybeRec = MaybeRec+    { bazFlat :: Maybe Flat+    , bazInt :: Int+    } deriving (Eq, Show, Generic)++instance IsXML MaybeRec++instance Arbitrary MaybeRec where+    arbitrary = MaybeRec <$> arbitrary <*> arbitrary++data Complex = Complex+    { waldoMaybeRec   :: MaybeRec+    , waldoMaybe :: Maybe Flat+    } deriving (Eq, Show, Generic)++instance IsXML Complex++instance Arbitrary Complex where+    arbitrary = Complex+        <$> arbitrary+        <*> arbitrary++data ListRec = ListRec+    { wibList :: [Flat]+    } deriving (Eq, Show, Generic)++instance IsXML ListRec++instance Arbitrary ListRec where+    arbitrary = ListRec <$> arbitrary++data Nullary = PrefixXyzzy | PrefixThud+    deriving (Eq, Read, Show, Generic)++instance IsXML Nullary where+    xmlPickler = (xpContent xpPrim)+        { root = Just "Nullary"+        }++instance Arbitrary Nullary where+    arbitrary = elements [PrefixXyzzy, PrefixThud]++data Fields = Fields+    { thisPrefixInt :: Int+    , thisPrefixFlat :: Flat+    } deriving (Eq, Show, Generic)++instance IsXML Fields where+    xmlPickler = genericXMLPickler $ defaultXMLOptions+        { xmlFieldModifier = reverse+        }++instance Arbitrary Fields where+    arbitrary = Fields <$> arbitrary <*> arbitrary++data Ctors = PrefixCtors+    { ctorInt  :: Int+    , ctorFlat :: Flat+    } deriving (Eq, Show, Generic)++instance IsXML Ctors where+    xmlPickler = genericXMLPickler $ defaultXMLOptions+        { xmlCtorModifier = \s -> fromMaybe s $ stripPrefix "Prefix" s+        }++instance Arbitrary Ctors where+    arbitrary = PrefixCtors <$> arbitrary <*> arbitrary++instance Arbitrary ByteString where+    arbitrary = fmap fromString . listOf1 $ oneof+        [ choose ('\48', '\57')+        , choose ('\65', '\90')+        , choose ('\97', '\122')+        ]++type Iso a = Isomorphism a -> Bool++data Isomorphism a = Iso+    { domain   :: a+    , codomain :: ByteString+    , identity :: Either String a+    }++instance Show a => Show (Isomorphism a) where+    show Iso{..} = unlines+        [ "[Input]"+        , show domain+        , ""+        , "[Encoded]"+        , BS.unpack codomain+        , ""+        , "[Parsed]"+        , show identity+        ]++instance (Eq a, Arbitrary a, Show a, IsXML a) => Arbitrary (Isomorphism a) where+    arbitrary = do+        inp <- arbitrary+        let enc = toIndentedXML 2 inp+        return . Iso inp enc $ fromXML enc++xml :: (Eq a, Arbitrary a, IsXML a) => Isomorphism a -> Bool+xml (Iso d _ i) = either (const False) (== d) i