hexpat-pickle-0.1: test.hs

{-# LANGUAGE Rank2Types, FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}

import qualified Text.XML.Expat.IO as EIO
import Text.XML.Expat.Tree as ETree
import Text.XML.Expat.Pickle
import Text.XML.Expat.Format
import Data.Tree
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Internal as B (w2c)
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

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 Node (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 (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 $
    xp4Tuple
        (xpAttr "lang" xpText0)
        (xpOption $ xpAttr "text" xpText0)
        (xpOption $ xpAttr "time" xpText0)
        xpText0

data LanguageKey k => MultiLanguage k = MultiLanguage {
        texts :: [MultiText k]
    }
    deriving (Eq, Show)

nullMultiLanguage :: LanguageKey k => MultiLanguage k
nullMultiLanguage = MultiLanguage []

instance XmlPickler Node (MultiLanguage SiteLanguageKey) where
    xpickle = xpMultiLanguage "text"

xpMultiLanguage :: LanguageKey k => String -> PU (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 Node Mnemonic where
    xpickle = xpMnemonic

xpMnemonic :: PU Mnemonic
xpMnemonic = xpElem "mnemonic" $ xpMnemonicAttrs

xpMnemonicAttrs :: PU Mnemonic
xpMnemonicAttrs =
    xpWrap (
        (\(mne, cat, com, tex, lin) ->
            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, tex,
                liftM ((fromMaybe "" . stripPrefix "category.") . keyValue) lin))
    ) $
    xp5Tuple
        (xpAttr "name" xpText0)
        (xpAttr "category" xpText0)
        (xpOption $ xpAttr "comment" $ xpText0)
        (xpMultiLanguage "text")
        (xpOption $ xpAttr "link" $ xpText)

main_eio doc = do
  parser <- EIO.newParser Nothing
  EIO.setStartElementHandler parser startElement
  EIO.parse parser doc -- True
  putStrLn "ok"
  where
  startElement name attrs = putStrLn $ show name ++ " " ++ show attrs

main_tree doc = do
  start <- getCurrentTime
  let mTree = ETree.parse Nothing doc
  --putStrLn $ show mTree
  case mTree of
      Just tree -> do
          let pickler = xpElem "mnemonics" $ xpList xpMnemonic
          let eMnems = unpickleTree pickler tree
          case eMnems of
              Right mnems -> do
                  --putStrLn $ show mnems
                  let pickled = pickleTree pickler mnems
                      out = formatDocS (Just UTF8) pickled "\n"
                  --putStrLn $ show pickled
                  --putStrLn $ out
                  let xml =  map B.w2c (B.unpack doc)
                  if out == xml
                      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 - mismatch:"
                          putStr out
              Left error -> do
                  hPutStrLn stderr $ "FAILED: "++error
      Nothing -> return ()

main = do
  xml <- B.readFile "test.xml"
  main_tree xml