content: {-# LANGUAGE TypeSynonymInstances #-}
  {- |
  Module      :  ./Common/XmlPickler.hs
  Description :  xml pickler
  Copyright   :  (c) Christian Maeder, DFKI GmbH 2010
  License     :  GPLv2 or higher, see LICENSE.txt
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  xml pickler on top of the xml light package
  -}
  
  module Common.XmlPickler where
  
  import Text.XML.Light
  import Common.Result
  import Common.ToXml
  import Common.Utils
  import qualified Control.Monad.Fail as Fail
  
  import Data.Maybe
  
  -- | the pickler data type (without a state)
  data PU a b = PU
    { pickle :: a -> b
    , unpickle :: b -> Result a }
  
  puPrim :: (Show a, Read a) => PU a String
  puPrim = PU
    { pickle = show
    , unpickle = \ s -> case readMaybe s of
          Nothing -> Fail.fail $ "unexpected text: " ++ s
          Just a -> return a
    }
  
  puId :: PU String String
  puId = PU
    { pickle = id
    , unpickle = return
    }
  
  puWrap :: PU b c -> PU a b -> PU a c
  puWrap pbc pab = PU
    { pickle = pickle pbc . pickle pab
    , unpickle = \ c ->
        unpickle pbc c >>= unpickle pab
    }
  
  xpCData :: PU String Content
  xpCData = PU
    { pickle = mkText
    , unpickle = \ c -> case c of
        Text d -> return $ cdData d
        _ -> Fail.fail $ "expected text instead of:\n" ++ ppContent c
    }
  
  xpString :: PU String Content
  xpString = puWrap xpCData puId
  
  xpPrim :: (Show a, Read a) => PU a Content
  xpPrim = puWrap xpCData puPrim
  
  class XmlPickler a where
      xmlPickler :: PU a Content
  
  instance XmlPickler String where
      xmlPickler = xpString
  
  instance XmlPickler Int where
      xmlPickler = xpPrim
  
  instance XmlPickler Integer where
      xmlPickler = xpPrim
  
  puPair :: PU a b -> PU c d -> PU (a, c) (b, d)
  puPair pab pcd = PU
    { pickle = \ (a, c) -> (pickle pab a, pickle pcd c)
    , unpickle = \ (b, d) -> joinResultWith (,) (unpickle pab b) $ unpickle pcd d
    }
  
  tagContentList :: String -> PU [Content] Element
  tagContentList tag = PU
    { pickle = unode tag
    , unpickle = \ e -> if qName (elName e) == tag then return $ elContent e
        else Fail.fail $ "expected <" ++ tag ++ "> element"
    }
  
  elemToContent :: PU Element Content
  elemToContent = PU
    { pickle = Elem
    , unpickle = \ c -> case c of
        Elem e -> return e
        _ -> Fail.fail $ "expected element instead of:\n" ++ ppContent c
    }
  
  pairToList :: PU (a, a) [a]
  pairToList = PU
    { pickle = \ (a, b) -> [a, b]
    , unpickle = \ l -> case l of
        [a, b] -> return (a, b)
        _ -> Fail.fail "expected two elements"
    }
  
  xpPair :: String -> PU a Content -> PU b Content -> PU (a, b) Element
  xpPair tag pua =
    puWrap (tagContentList tag) . puWrap pairToList . puPair pua
  
  -- | unpickles last element first
  puList :: PU a b -> PU [a] [b]
  puList pab = PU
    { pickle = map (pickle pab)
    , unpickle = foldr (joinResultWith (:) . unpickle pab) $ return []
    }
  
  xpList :: String -> PU a Content -> PU [a] Element
  xpList tag = puWrap (tagContentList tag) . puList
  
  xpAttrs :: PU (Element, [Attr]) Element
  xpAttrs = PU
    { pickle = \ (e, attrs) -> add_attrs attrs e
    , unpickle = \ e -> return (e, elAttribs e)
    }
  
  -- | attribute pickler
  xa :: PU a (b, c) -> PU c [Attr] -> PU b Element -> PU a Element
  xa split pua pub = puWrap xpAttrs $ puWrap (puPair pub pua) split
  
  tagAttr :: String -> PU String Attr
  tagAttr tag = PU
    { pickle = mkAttr tag
    , unpickle = \ a -> if qName (attrKey a) == tag then return $ attrVal a else
        Fail.fail $ "expected attribute key: " ++ tag
    }
  
  tagAttrs :: String -> PU String [Attr]
  tagAttrs tag = PU
    { pickle = \ s -> if null s then [] else [mkAttr tag s]
    , unpickle = return . fromMaybe "" . lookupAttrBy ((== tag) . qName)
    }
  