hexpat-pickle-generic 0.1.5 → 0.1.6
raw patch · 2 files changed
+211/−77 lines, 2 filesdep +text
Dependencies added: text
Files
hexpat-pickle-generic.cabal view
@@ -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
src/Text/XML/Expat/Pickle/Generic.hs view
@@ -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