diff --git a/Text/XML/Expat/Pickle.hs b/Text/XML/Expat/Pickle.hs --- a/Text/XML/Expat/Pickle.hs +++ b/Text/XML/Expat/Pickle.hs @@ -224,7 +224,7 @@ PU (Node tag text) a -> a -> BL.ByteString -pickleXML pu value = formatTree $ pickleTree pu value +pickleXML pu value = format $ pickleTree pu value -- | A helper that combines 'pickleTree' with 'formatXML' to pickle to an -- XML document. Strict variant returning strict ByteString. @@ -232,7 +232,7 @@ PU (Node tag text) a -> a -> B.ByteString -pickleXML' pu value = formatTree' $ pickleTree pu value +pickleXML' pu value = format' $ pickleTree pu value -- | A helper that combines 'parseXML' with 'unpickleTree' to unpickle from an -- XML document - lazy version. In the event of an error, it throws either diff --git a/hexpat-pickle.cabal b/hexpat-pickle.cabal --- a/hexpat-pickle.cabal +++ b/hexpat-pickle.cabal @@ -1,6 +1,6 @@ -Cabal-Version: >= 1.2 +Cabal-Version: >= 1.6 Name: hexpat-pickle -Version: 0.5 +Version: 0.6 Synopsis: XML picklers based on hexpat, source-code-similar to those of the HXT package Description: A library of combinators that allows Haskell data structures to be pickled @@ -25,13 +25,14 @@ Homepage: http://code.haskell.org/hexpat-pickle/ Extra-Source-Files: test/tests.hs, - test/test.hs, - test/test.xml, test/example.hs, test/lazyUnpickle.hs, test/lazyUnpickleThrow.hs Build-Type: Simple Stability: beta +source-repository head + type: darcs + location: http://code.haskell.org/hexpat-pickle/ Library Build-Depends: diff --git a/test/test.hs b/test/test.hs deleted file mode 100644 --- a/test/test.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} - -import Text.XML.Expat.Tree -import Text.XML.Expat.Pickle -import Text.XML.Expat.Format -import Data.Tree -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Internal (w2c, c2w) -import Control.Monad -import Data.Maybe -import Data.Either -import Data.List -import Data.Char -import Debug.Trace -import Data.Time.Clock -import Numeric -import System.IO -import Data.Monoid - -class Key k where - keyValue :: k -> String - -class Key k => LanguageKey k where - isoOf :: k -> String - makeLanguageKey :: String -> k - -data MnemonicKey = MnemonicKey String - deriving Show - -instance Key MnemonicKey where - keyValue (MnemonicKey str) = str - -data LanguageKey k => MultiText k = MultiText { - lang :: k, - languageText :: String, - timestamp :: Integer - } - deriving (Eq, Show) - -instance LanguageKey k => XmlPickler (UNodes String) (MultiText k) where - xpickle = xpMultiText "text" - -data SiteLanguageKey = SiteLanguageKey String - deriving Show - -instance Key SiteLanguageKey where - keyValue (SiteLanguageKey a) = a - -instance LanguageKey SiteLanguageKey where - isoOf = keyValue - makeLanguageKey str = SiteLanguageKey str - -maybeRead :: Read a => String -> Maybe a -maybeRead s = case reads s of - [(x, "")] -> Just x - _ -> Nothing - -xpMultiText :: LanguageKey k => String -> PU (UNodes String) (MultiText k) -xpMultiText tagName = - xpWrap ( - (\((lan, tex1, tim), tex2) -> MultiText - (makeLanguageKey lan) - (if tex2 /= "" then tex2 else fromMaybe "" tex1) - (truncate $ fromMaybe 0 ((maybeRead (fromMaybe "0" tim))::Maybe Float))), - (\(MultiText lan tex tim) -> ((isoOf lan, Nothing, Just $ show tim), tex)) - ) $ - xpElem tagName - (xpTriple - (xpAttr "lang" xpText0) - (xpOption $ xpAttr "text" xpText0) - (xpOption $ xpAttr "time" xpText0)) - (xpContent xpText0) - -data LanguageKey k => MultiLanguage k = MultiLanguage { - texts :: [MultiText k] - } - deriving (Eq, Show) - -nullMultiLanguage :: LanguageKey k => MultiLanguage k -nullMultiLanguage = MultiLanguage [] - -instance XmlPickler (UNodes String) (MultiLanguage SiteLanguageKey) where - xpickle = xpMultiLanguage "text" - -xpMultiLanguage :: LanguageKey k => String -> PU (UNodes String) (MultiLanguage k) -xpMultiLanguage childTagName = - xpWrap ( - (\ts -> MultiLanguage ts), - (\(MultiLanguage ts) -> ts) - ) $ - xpList (xpMultiText childTagName) - -data Mnemonic = Mnemonic { - mnemonicKey :: MnemonicKey, - category :: String, - comment :: String, - multiLanguage :: MultiLanguage SiteLanguageKey, - linkTo :: Maybe MnemonicKey - } - deriving (Show) - -instance XmlPickler (UNodes String) Mnemonic where - xpickle = xpMnemonic - -xpMnemonic :: PU (UNodes String) Mnemonic -xpMnemonic = - xpWrap ( - (\((mne, cat, com, lin), tex) -> - Mnemonic (MnemonicKey mne) cat (fromMaybe "" com) tex - (liftM (MnemonicKey . ("category."++)) lin)), - (\(Mnemonic (MnemonicKey mne) cat com tex lin) -> - ((mne, cat, if com == "" then Nothing else Just com, - liftM ((fromMaybe "" . stripPrefix "category.") . keyValue) lin), tex)) - ) $ - xpElem "mnemonic" - (xp4Tuple - (xpAttr "name" xpText0) - (xpAttr "category" xpText0) - (xpOption $ xpAttr "comment" $ xpText0) - (xpOption $ xpAttr "link" $ xpText)) - (xpMultiLanguage "text") - -main_tree doc = do - start <- getCurrentTime - let pickler = xpRoot $ xpElemNodes "mnemonics" $ xpList xpMnemonic - case unpickleXML' defaultParserOptions pickler doc of - Right mnems -> do - let xml = mconcat . L.toChunks $ pickleXML pickler mnems `mappend` L.pack (map c2w "\n") - if xml == doc - then do - let mnems = unpickleXML defaultParserOptions pickler $ L.fromChunks [doc] - xml = mconcat . L.toChunks $ pickleXML pickler mnems `mappend` L.pack (map c2w "\n") - if xml == doc - then do - end <- getCurrentTime - let took = end `diffUTCTime` start - hPutStrLn stderr $ "passed" - hPutStrLn stderr $ "took "++showFFloat (Just 3) (realToFrac took) ""++" sec" - else do - hPutStrLn stderr $ "Failed test 2 - mismatch:" - B.putStr xml - else do - hPutStrLn stderr $ "Failed test 1 - mismatch:" - B.putStr xml - Left error -> do - hPutStrLn stderr $ "FAILED: "++error - -main = do - xml <- B.readFile "test.xml" - main_tree xml diff --git a/test/test.xml b/test/test.xml deleted file mode 100644 --- a/test/test.xml +++ /dev/null @@ -1,2 +0,0 @@ - -Gana Prajatantri BangladeshBangladesciBangladeshAn BhanglaidéisBangladesh - বাংলাদেশBangladesiaບັງກະລາເທດBangladeşBangladesjBangladešaBangladešasบังคลาเทศБангладешబంగ్లాదేశ్பங்களாதேஷ்BangladeschBangladeshབངྒ་ལ་དེཤBangladeshಬಾಂಗ್ಲಾದೇಶবাংলাদেশΜπανγκλαντέςBangladeŝoBangladesh孟加拉国BangladeshBangladeshBangladeshБангладешBangladeshБангладэшБангладешBangladeshBangladeshGonaoprojatontri BangladeshBangladešバングラデシュBangladèshBangladeschБангладешBangla DeshBangladeshBangladéšبنګله‌دیشBangladeshBangladeshBangladeszԲանգլադեշBangladešBangladèchBangladesबंगलादेशבנגלאדשBangladeshബംഗ്ലാദേശ്Бангладешبنگلہ دیشBangladexxБангладешबांगलादेशبېنگلاBangladesjBangladeshBangladessባንግላዲሽBangladeshBangladeshبنغلاديشBangladeshBangladeshBangladeshबंगलादेशBangladeshBangladeshBangladeshBangladeshBangladeshBangaala-DeeshBangladeshBangladeshBangladesبنگلادشBangladeshBangladesjბანგლადეშიБангладешBangladeshi방글라데시Bangladeshបង់ក្លាដេស្ហBangladéšBangladešBangladeshBangladeşBangladešBangladeshBelgienYn VelgBelgiëBelgiuAn BheilgBélxica - BelgiëBelgiaBelschBelgiaBɛ́ljikaເບວຢຽມBelçikaBelsjBeļģijaBelhikaเบลเยียมБелгияபெல்ஜியம்BelgienBelgienབེལ་ཇིཡམBelgienBelgjeBilgasuyuA' BheilgΒέλγιοBelgujoBelgium比利时BelgioܒܠܓܝܟܐBelgikaBelgiaBéljikaBélgicaБельгияBelgiaBelgiaবেল্জিয়মBelgiskaБэльгіяБелгияБельгіяBeldjikeBélxicaBelgiaཔེར་ཅིནBelgiaBelgijaベルギーBelgiumBelgicaBelgienБельгиBèlgicaGwlad BelgBelgieБельгиبلجيمBélgicaBelgijaBèlg·iqueBỉBelhikaBelgiaԲելգիաBelgiqueBelgijaBèljikBelgiumबेल्जियमבלגיהBelgjoБелгијаBelġjuBelgiumबेल्जियमBelgiumBelgië벨기에BelgíaቤልጄምBelgioBelchicaبلجيكاបែលហ្ស៉ិកBelgiaBelgicaBelgiaKoninkrijk BelgiëBelgiaBelgiaBelgiumBelgiaबेल्जियमBeljiyamBelgiumBelgiqueBelgjeبلژیکBelgiaBelgiaბელგიაБелгијаBelgjikëUbelgijiBelgienBelsumBelgickoBelgijaPow BelgBelçîkaBelgijagugdrbelgiबेल्जियमBelgia diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -3,7 +3,7 @@ import Text.XML.Expat.Tree import Text.XML.Expat.Format import Control.Exception.Extensible as E -import Control.Parallel.Strategies +import Control.DeepSeq import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as B import Data.ByteString.Internal (c2w) @@ -13,16 +13,16 @@ -- | Tests where input and XML output differ u2 :: (NFData a, Eq a, Show a) => String -> String -> String -> Either String a -> PU [UNode String] a -> IO () u2 title inXML chkXML inEVal inPU = do - let inTree = parseThrowing (defaultParseOptions { defaultEncoding = Just UTF8 }) (L.pack $ map c2w inXML) - inTreeXML = formatTree' inTree + let inTree = parseThrowing (defaultParseOptions { overrideEncoding = Just UTF8 }) (L.pack $ map c2w inXML) + inTreeXML = format' inTree eVal = unpickleTree' (xpRoot inPU) inTree assertEqual (title++" - strict unpickle") inEVal eVal case eVal of Right val -> do -- Make sure that the lazy unpickler gives the same result assertEqual (title++" - lazy unpickle") val (unpickleTree (xpRoot inPU) inTree) - let chkTree = parseThrowing (defaultParseOptions { defaultEncoding = Just UTF8 }) (L.pack $ map c2w chkXML) :: UNode String - chkTreeXML = formatTree' chkTree + let chkTree = parseThrowing (defaultParseOptions { overrideEncoding = Just UTF8 }) (L.pack $ map c2w chkXML) :: UNode String + chkTreeXML = format' chkTree outXML = pickleXML' (xpRoot inPU) val assertEqual (title++" - pickle") chkTreeXML outXML Left err ->