XmlPickler.hs revision 463a7b70ba0f1427008025026375cd28be7bc86f
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder{-# LANGUAGE TypeSynonymInstances #-}
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederModule : $Header$
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederDescription : xml pickler
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederCopyright : (c) Christian Maeder, DFKI GmbH 2010
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederLicense : GPLv2 or higher, see LICENSE.txt
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederMaintainer : Christian.Maeder@dfki.de
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederStability : provisional
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederPortability : portable
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maederxml pickler on top of the xml light package
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder-- | the pickler data type (without a state)
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maederdata PU a = PU
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder { pickleToContent :: a -> Content
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder , unpickleContent :: Content -> Result a }
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederxpPrim :: (Show a, Read a) => PU a
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder { pickleToContent = mkText . show
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder , unpickleContent = \ c -> case c of
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder Text t -> let s = cdData t in case readMaybe s of
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder Nothing -> fail $ "unexpected text: " ++ s
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder Just a -> return a
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder _ -> fail "expected primitive text data"
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederxpString :: PU String
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder { pickleToContent = mkText
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder , unpickleContent = \ c -> case c of
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder Text t -> return $ cdData t
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder _ -> fail "expected a string"
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maederclass XmlPickler a where
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder xmlPickler :: PU a
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maederinstance XmlPickler String where
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder xmlPickler = xpString
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maederinstance XmlPickler Int where
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder xmlPickler = xpPrim
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maederinstance XmlPickler Integer where
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder xmlPickler = xpPrim
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederxpPair :: String -> PU a -> PU b -> PU (a, b)
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederxpPair tag pua pub =
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder let err = fail $ "expected pair element with tag: " ++ tag
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder { pickleToContent = \ (a, b) ->
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder Elem $ unode tag [pickleToContent pua a, pickleToContent pub b]
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder , unpickleContent = \ c -> case c of
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder Elem e -> case elContent e of
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder [e1, e2] | qName (elName e) == tag -> do
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder a <- unpickleContent pua e1
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder b <- unpickleContent pub e2
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder return (a, b)
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederxpList :: String -> PU a -> PU [a]
463a7b70ba0f1427008025026375cd28be7bc86fChristian MaederxpList tag pua =
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder let err = fail $ "expecting list element with tag: " ++ tag
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder { pickleToContent = Elem . unode tag . map (pickleToContent pua)
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder , unpickleContent = \ c -> case c of
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder Elem e -> if qName (elName e) == tag then
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder mapM (unpickleContent pua) $ elContent e
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder-- | attribute pickler
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maederdata AU a b = AU
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder { pickleToAttrs :: a -> [Attr]
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder , stripAttrContent :: a -> b
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder , unpickleAttrs :: b -> [Attr] -> Result a
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maederxa :: AU a b -> PU b -> PU a
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maederxa au pub = PU
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder { pickleToContent = \ a ->
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder Elem $ add_attrs (pickleToAttrs au a)
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder $ case pickleToContent pub (stripAttrContent au a) of
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder , unpickleContent = \ c -> case c of
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder b <- unpickleContent pub c
463a7b70ba0f1427008025026375cd28be7bc86fChristian Maeder unpickleAttrs au b $ elAttribs e