hexpat-pickle-0.3: test/test.hs

{-# 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' Nothing 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 Nothing 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