diff --git a/hexpat-pickle-generic.cabal b/hexpat-pickle-generic.cabal --- a/hexpat-pickle-generic.cabal +++ b/hexpat-pickle-generic.cabal @@ -1,5 +1,5 @@ name: hexpat-pickle-generic -version: 0.1.5 +version: 0.1.6 synopsis: Picklers for de/serialising Generic data types to and from XML license: BSD3 license-file: LICENSE @@ -36,6 +36,7 @@ base >= 4.6 && < 5 , bytestring , hexpat + , text test-suite hexpat-pickle-generic-tests default-language: Haskell2010 diff --git a/src/Text/XML/Expat/Pickle/Generic.hs b/src/Text/XML/Expat/Pickle/Generic.hs --- a/src/Text/XML/Expat/Pickle/Generic.hs +++ b/src/Text/XML/Expat/Pickle/Generic.hs @@ -1,17 +1,13 @@ {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} @@ -36,15 +32,17 @@ , fromXML -- * Data Types + , Node , XMLPU (..) -- * Options , XMLOptions (..) , defaultXMLOptions + , namespacedXMLOptions -- * Generics + , XMLGeneric , genericXMLPickler - , rootXMLPickler -- * Combinators , xpWrap @@ -54,36 +52,49 @@ , xpSum , xpEither , xpPrim - , xpEmpty , xpOption , xpPair + , xpTriple + , xp4Tuple + , xp5Tuple + , xp6Tuple , xpUnit , xpLift + , xpEmpty + , xpConst , xpText , xpText0 , xpContent + + -- * Re-exported Tag Helpers + , module Text.XML.Expat.Internal.Namespaced + , module Text.XML.Expat.Internal.Qualified ) where -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import Data.Char (isLower, isSpace) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Char (isLower, isSpace) import Data.Either import Data.Maybe import Data.Monoid +import Data.Text (Text) +import Data.Text.Encoding import GHC.Generics import Text.XML.Expat.Format -import Text.XML.Expat.Tree hiding (Node) +import Text.XML.Expat.Internal.Namespaced +import Text.XML.Expat.Internal.Qualified hiding (fromQualified) +import Text.XML.Expat.Tree hiding (Node, fromQualified) -- -- Class -- -type Node = UNode ByteString +type Node = NNode ByteString data XMLPU t a = XMLPU { pickleTree :: a -> t , unpickleTree :: t -> Either String a - , root :: Maybe ByteString + , root :: Maybe (NName ByteString) } type PU = XMLPU @@ -99,59 +110,58 @@ -- toXML :: IsXML a => a -> ByteString -toXML = format' . maybe head (\n -> Element n []) (root pu) . pickleTree pu - where - pu = xmlPickler +toXML = toIndentedXML 2 toIndentedXML :: IsXML a => Int -> a -> ByteString toIndentedXML i = format' . indent i - . maybe head (\n -> Element n []) (root pu) - . pickleTree pu - where - pu = xmlPickler + . fromQualified + . fromNamespaced + . pickleTree (xpRoot xmlPickler) fromXML :: IsXML a => ByteString -> Either String a -fromXML = either (Left . show) unwrap . parse' defaultParseOptions +fromXML = either (Left . show) unpickle . 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 + unpickle = unpickleTree (xpRoot xmlPickler) . toNamespaced . toQualified -- -- Options -- data XMLOptions = XMLOptions - { xmlCtorModifier :: String -> ByteString + { xmlCtorModifier :: String -> NName ByteString -- ^ Function applied to constructor tags. - , xmlFieldModifier :: String -> ByteString + , xmlFieldModifier :: String -> NName ByteString -- ^ Function applied to record field labels. - , xmlListElement :: ByteString + , xmlListElement :: NName ByteString -- ^ Default element name to wrap list items with. } -type Options = XMLOptions +defaultXMLOptions :: XMLOptions +defaultXMLOptions = XMLOptions + { xmlCtorModifier = mkAnNName . BS.pack + , xmlFieldModifier = mkAnNName . BS.pack . dropWhile isLower + , xmlListElement = mkAnNName "Value" + } -defaultXMLOptions :: Options -defaultXMLOptions = XMLOptions BS.pack (BS.pack . dropWhile isLower) "Value" +namespacedXMLOptions :: ByteString -> XMLOptions +namespacedXMLOptions ns = XMLOptions + { xmlCtorModifier = mkNName ns . BS.pack + , xmlFieldModifier = mkNName ns . BS.pack . dropWhile isLower + , xmlListElement = mkNName ns "Value" + } -- -- Generics -- +type XMLGeneric a = (Generic a, GIsXML (Rep a)) => PU [Node] a + genericXMLPickler opts = (to, from) `xpWrap` (gXMLPickler opts) (genericXMLPickler opts) -rootXMLPickler name = - (genericXMLPickler defaultXMLOptions) { root = Just name } - class GIsXML f where - gXMLPickler :: Options -> PU [Node] a -> PU [Node] (f a) + gXMLPickler :: XMLOptions -> PU [Node] a -> PU [Node] (f a) instance IsXML a => GIsXML (K1 i a) where gXMLPickler _ _ = (K1, unK1) `xpWrap` xmlPickler @@ -178,32 +188,46 @@ ((M1, unM1) `xpWrap` gXMLPickler opts f) instance (Selector s, IsXML a) => GIsXML (S1 s (K1 i [a])) where - gXMLPickler opts _ = xpElem + gXMLPickler opts _ = xpDefault (xmlFieldModifier opts $ selName (undefined :: t s (K1 i [a]) p)) + (M1 $ K1 []) ((M1 . K1, unK1 . unM1) `xpWrap` xpList (xpElem key pu)) where key = fromMaybe (xmlListElement opts) $ root pu pu = xmlPickler +instance (Selector s, IsXML a) => GIsXML (S1 s (K1 i (Maybe a))) where + gXMLPickler opts _ = + (M1 . K1, unK1 . unM1) `xpWrap` xpOption (xpElem name xmlPickler) + where + name = xmlFieldModifier opts $ selName (undefined :: t s (K1 i (Maybe a)) p) + -- -- Combinators -- +xpRoot :: PU [Node] a -> PU Node a +xpRoot pu = pu + { pickleTree = + (maybe head (\n -> Element n []) $ root pu) . pickleTree pu + , unpickleTree = \t -> case t of + (Element _ _ cs) -> unpickleTree pu cs + t1 -> unpickleTree pu [t1] + } + xpWrap :: (a -> b, b -> a) -> PU [n] a -> PU [n] b -xpWrap (f, g) pu = XMLPU +xpWrap (f, g) pu = pu { pickleTree = pickleTree pu . g , unpickleTree = fmap f . unpickleTree pu - , root = root pu } -xpElemList :: ByteString -> PU [Node] a -> PU [Node] [a] +xpElemList :: NName ByteString -> PU [Node] a -> PU [Node] [a] xpElemList name = xpList . xpElem name xpList :: PU [Node] a -> PU [Node] [a] -xpList pu = XMLPU +xpList pu = pu { pickleTree = concatMap (pickleTree pu) , unpickleTree = concatEithers . unpickle - , root = root pu } where unpickle (e@(Element _ _ _):es) = unpickleTree pu [e] : unpickle es @@ -214,9 +238,10 @@ ([], rs) -> Right rs (l:_, _) -> Left l -xpElem :: ByteString -> PU [Node] a -> PU [Node] a +xpElem :: NName ByteString -> PU [Node] a -> PU [Node] a xpElem name pu = XMLPU - { pickleTree = \x -> [Element name [] (pickleTree pu x)] + { root = Just name + , pickleTree = \x -> [Element name [] (pickleTree pu x)] , unpickleTree = \t -> let children = map matching t in case catMaybes children of @@ -224,15 +249,33 @@ (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 ++ ">" + tag = "<" ++ show name ++ ">" +xpDefault :: NName ByteString -> a -> PU [Node] a -> PU [Node] a +xpDefault name val pu = XMLPU + { root = Just name + , pickleTree = \x -> [Element name [] (pickleTree pu x)] + , unpickleTree = \t -> + let children = map matching t + in case catMaybes children of + [] -> Right val + (x:_) -> case x of + Left e -> Left $ "in " ++ tag ++ ", " ++ e + r -> r + } + where + matching (Element n _ cs) + | n == name = Just $ unpickleTree pu cs + matching _ = Nothing + + tag = "<" ++ show 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 @@ -244,85 +287,158 @@ xpEither :: PU [t] a -> PU [t] b -> PU [t] (Either a b) xpEither pa pb = XMLPU - { pickleTree = either (pickleTree pa) (pickleTree pb) + { root = listToMaybe $ catMaybes [root pa, root pb] + , 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] } xpPrim :: (Read a, Show a) => PU ByteString a xpPrim = XMLPU - { pickleTree = BS.pack . show + { root = Nothing + , 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 } -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 - } - xpOption :: PU [n] a -> PU [n] (Maybe a) -xpOption pu = XMLPU +xpOption pu = pu { 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 + { root = listToMaybe $ catMaybes [root pa, root pb] + , pickleTree = \(a, b) -> concat [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] } +xpTriple :: PU [n] a -> PU [n] b -> PU [n] c -> PU [n] (a, b, c) +xpTriple pa pb pc = XMLPU + { root = listToMaybe $ catMaybes [root pa, root pb, root pc] + , pickleTree = \(a, b, c) -> + concat [pickleTree pa a, pickleTree pb b, pickleTree pc c] + , unpickleTree = \t -> + case (unpickleTree pa t, unpickleTree pb t, unpickleTree pc t) of + (Right a, Right b, Right c) -> Right (a, b, c) + (Left e, _, _) -> Left $ "in 1st of triple, " ++ e + (_, Left e, _) -> Left $ "in 2nd of triple, " ++ e + (_, _, Left e) -> Left $ "in 3rd of triple, " ++ e + } + +xp4Tuple :: PU [n] a -> PU [n] b -> PU [n] c -> PU [n] d -> PU [n] (a, b, c, d) +xp4Tuple pa pb pc pd = XMLPU + { root = listToMaybe $ catMaybes [root pa, root pb, root pc, root pd] + , pickleTree = \(a, b, c, d) -> + concat [pickleTree pa a, pickleTree pb b, pickleTree pc c, pickleTree pd d] + , unpickleTree = \t -> + case (unpickleTree pa t, unpickleTree pb t, unpickleTree pc t, + unpickleTree pd t) of + (Right a, Right b, Right c, Right d) -> Right (a, b, c, d) + (Left e, _, _, _) -> Left $ "in 1st of 4-tuple, " ++ e + (_, Left e, _, _) -> Left $ "in 2nd of 4-tuple, " ++ e + (_, _, Left e, _) -> Left $ "in 3rd of 4-tuple, " ++ e + (_, _, _, Left e) -> Left $ "in 4th of 4-tuple, " ++ e + } + +xp5Tuple :: PU [n] a -> PU [n] b -> PU [n] c -> PU [n] d -> PU [n] e -> PU [n] (a, b, c, d, e) +xp5Tuple pa pb pc pd pe = XMLPU + { root = listToMaybe $ catMaybes [root pa, root pb, root pc, root pd, root pe] + , pickleTree = \(a, b, c, d, e) -> + concat [pickleTree pa a, pickleTree pb b, pickleTree pc c, pickleTree pd d, pickleTree pe e] + , unpickleTree = \t -> + case (unpickleTree pa t, unpickleTree pb t, unpickleTree pc t, + unpickleTree pd t, unpickleTree pe t) of + (Right a, Right b, Right c, Right d, Right e) -> Right (a, b, c, d, e) + (Left e, _, _, _, _) -> Left $ "in 1st of 5-tuple, " ++ e + (_, Left e, _, _, _) -> Left $ "in 2nd of 5-tuple, " ++ e + (_, _, Left e, _, _) -> Left $ "in 3rd of 5-tuple, " ++ e + (_, _, _, Left e, _) -> Left $ "in 4th of 5-tuple, " ++ e + (_, _, _, _, Left e) -> Left $ "in 5th of 5-tuple, " ++ e + } + +xp6Tuple :: PU [n] a -> PU [n] b -> PU [n] c -> PU [n] d -> PU [n] e -> PU [n] f -> PU [n] (a, b, c, d, e, f) +xp6Tuple pa pb pc pd pe pf = XMLPU + { root = listToMaybe $ catMaybes [root pa, root pb, root pc, root pd, root pe, root pf] + , pickleTree = \(a, b, c, d, e, f) -> + concat [pickleTree pa a, pickleTree pb b, pickleTree pc c, pickleTree pd d, pickleTree pe e, pickleTree pf f] + , unpickleTree = \t -> + case (unpickleTree pa t, unpickleTree pb t, unpickleTree pc t, + unpickleTree pd t, unpickleTree pe t, unpickleTree pf t) of + (Right a, Right b, Right c, Right d, Right e', Right f) -> Right (a, b, c, d, e', f) + (Left e, _, _, _, _, _) -> Left $ "in 1st of 6-tuple, " ++ e + (_, Left e, _, _, _, _) -> Left $ "in 2nd of 6-tuple, " ++ e + (_, _, Left e, _, _, _) -> Left $ "in 3rd of 6-tuple, " ++ e + (_, _, _, Left e, _, _) -> Left $ "in 4th of 6-tuple, " ++ e + (_, _, _, _, Left e, _) -> Left $ "in 5th of 6-tuple, " ++ e + (_, _, _, _, _, Left e) -> Left $ "in 6th of 6-tuple, " ++ e + } + xpUnit :: PU [n] () xpUnit = xpLift () xpLift :: a -> PU [n] a xpLift a = XMLPU - { pickleTree = const [] + { root = Nothing + , pickleTree = const [] , unpickleTree = const $ Right a - , root = Nothing } +xpEmpty :: (Read a, Show a) => Maybe ByteString -> PU [Node] a +xpEmpty mns = XMLPU + { root = Nothing + , pickleTree = \x -> [Element (name x) [] []] + , unpickleTree = \t -> case t of + [(Element n _ _)] -> let s = BS.unpack $ nnLocalPart n + in case reads s of + [(x, "")] -> Right x + _ -> Left $ "failed to read: " ++ s + l -> Left $ "expected empty element, got: " ++ show l + } + where + name x = maybe (mkAnNName local) (`mkNName` local) mns + where + local = BS.pack $ show x + +xpConst :: Show a => ByteString -> a -> XMLPU [Node] a +xpConst ns val = XMLPU + { root = Just name + , pickleTree = const [Element name [] []] + , unpickleTree = const $ Right val + } + where + name = mkNName ns . BS.pack $ show val + xpText :: PU ByteString ByteString xpText = XMLPU - { pickleTree = id + { root = Nothing + , 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 + { root = Nothing + , pickleTree = id , unpickleTree = Right - , root = Nothing } xpContent :: PU ByteString a -> PU [Node] a xpContent pu = XMLPU - { pickleTree = \t -> + { root = root pu + , 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 @@ -360,3 +476,20 @@ instance IsXML ByteString where xmlPickler = xpContent xpText + +instance IsXML Text where + xmlPickler = (decodeUtf8, encodeUtf8) `xpWrap` xmlPickler + +-- +-- Qualified Prefix Hack +-- + +fromQualified :: (NodeClass n c, GenericXMLString text) + => n c (QName text) text + -> n c text text +fromQualified = mapAllTags tag + where + tag (QName Nothing local) = local + tag (QName (Just prefix) local) + | prefix == xmlns = prefix + | otherwise = local