    {-# LANGUAGE PatternGuards, CPP #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Text.CSL.Pickle
    -- Copyright   :  (c) Uwe Schmidt Andrea Rossato
    -- License     :  BSD-style (see LICENSE)
    --
    -- Maintainer  :  Andrea Rossato <andrea.rossato@unitn.it>
    -- Stability   :  unstable
    -- Portability :  portable
    --
    -- This module is mostly copied from Text.XML.HXT.Arrow.Pickle.Xml
    -- which is an adaptation of the pickler combinators developed by
    -- Andrew Kennedy.
    --
    -- See: <http://research.microsoft.com/~akenn/fun/picklercombinators.pdf>
    -----------------------------------------------------------------------------

    module Text.CSL.Pickle where

    import Control.Monad    ( unless        )
    import Data.List        ( elemIndex     )
    import Data.Maybe
    import System.Directory ( doesFileExist )
    import qualified Data.ByteString.Lazy as L

    #ifdef USE_HEXPAT
    import Text.CSL.Pickle.Hexpat
    #else
    import Text.CSL.Pickle.Xml
    import Text.XML.Light
    #endif

    data St
        = St { attributes :: [Attr]
    	 , contents   :: [Content]
    	 }

    data PU a
        = PU { appPickle   :: (a, St) -> St
    	 , appUnPickle :: St -> (Maybe a, St)
             }

    pickleXML :: PU a -> a -> String
    pickleXML p v = concatMap showXML $ contents st
        where st = appPickle p (v, emptySt)

    unpickleXML :: PU a -> [Content] -> Maybe a
    unpickleXML p t
        = fst . appUnPickle p $ St { attributes = []
    			       , contents   = t
    			       }

    emptySt	:: St
    emptySt	=  St { attributes = []
    	      , contents   = []
    	      }

    addAtt	:: Attr -> St -> St
    addAtt x s = s {attributes = x : attributes s}

    addCont	:: Content -> St -> St
    addCont x s = s {contents = x : contents s}

    dropCont :: St -> St
    dropCont s = s { contents = dropFirstElem (contents s)}

    getAtt :: String -> St -> Maybe Attr
    getAtt name
        = listToMaybe . filter ((==) name .  getAttName) . attributes

    getCont	:: St -> Maybe Content
    getCont	= listToMaybe . contents

    class XmlPickler a where
        xpickle :: PU a

    instance XmlPickler Int where
        xpickle = xpPrim

    instance XmlPickler Integer where
        xpickle = xpPrim

    instance XmlPickler () where
        xpickle = xpUnit

    instance XmlPickler a => XmlPickler [a] where
        xpickle = xpList xpickle

    instance XmlPickler a => XmlPickler (Maybe a) where
        xpickle = xpOption xpickle

    xpPrim	:: (Read a, Show a) => PU a
    xpPrim
        = xpWrapMaybe (readMaybe, show) xpText
        where
        readMaybe :: Read a => String -> Maybe a
        readMaybe str
    	= val (reads str)
    	where
    	val [(x,"")] = Just x
    	val _        = Nothing

    xpUnit :: PU ()
    xpUnit = xpLift ()

    xpZero :: PU a
    xpZero
        =  PU { appPickle   = snd
    	  , appUnPickle = \ s -> (Nothing, s)
              }

    xpLift :: a -> PU a
    xpLift x
        =  PU { appPickle   = snd
    	  , appUnPickle = \ s -> (Just x, s)
              }

    xpCondSeq :: PU b -> (b -> a) -> PU a -> (a -> PU b) -> PU b
    xpCondSeq pd f pa k
        = PU { appPickle   = ( \ (b, s) ->
    	                   let
    			   a  = f b
    			   pb = k a
    			   in
    			   appPickle pa (a, (appPickle pb (b, s)))
    			 )
    	 , appUnPickle = ( \ s ->
    			   let
    			   (a, s') = appUnPickle pa s
    			   in
    			   case a of
    			   Nothing -> appUnPickle pd     s
    			   Just a' -> appUnPickle (k a') s'
    			 )
    	 }

    xpSeq :: (b -> a) -> PU a -> (a -> PU b) -> PU b
    xpSeq = xpCondSeq xpZero

    xpChoice :: PU b -> PU a -> (a -> PU b) -> PU b
    xpChoice pb = xpCondSeq pb undefined

    xpWrap	:: (a -> b, b -> a) -> PU a -> PU b
    xpWrap (f, g) pa = xpSeq g pa (xpLift . f)

    xpDefault :: (Eq a) => a -> PU a -> PU a
    xpDefault df
        = xpWrap ( fromMaybe df
    	     , \ x -> if x == df then Nothing else Just x
    	     ) .
          xpOption

    xpOption :: PU a -> PU (Maybe a)
    xpOption pa
        = PU { appPickle   = ( \ (a, st) ->
    			   case a of
    			   Nothing -> st
    			   Just x  -> appPickle pa (x, st)
    			 )
    	 , appUnPickle = appUnPickle $
    	                 xpChoice (xpLift Nothing) pa (xpLift . Just)
    	 }

    xpAlt	:: (a -> Int) -> [PU a] -> PU a
    xpAlt tag ps
        = PU { appPickle   = ( \ (a, st) ->
    			   let
    			   pa = ps !! (tag a)
    			   in
    			   appPickle pa (a, st)
    			 )
    	 , appUnPickle = appUnPickle $
    	                 ( case ps of
    			   []     -> xpZero
    			   pa:ps1 -> xpChoice (xpAlt tag ps1) pa xpLift
    			 )
    	 }

    xpList	:: PU a -> PU [a]
    xpList pa
        = PU { appPickle   = ( \ (a, st) ->
    			   case a of
    			   []  -> st
    			   _:_ -> appPickle pc (a, st)
    			 )
    	 , appUnPickle = appUnPickle $
                             xpChoice (xpLift []) pa
    	                   (\ x -> xpSeq id (xpList pa) (\xs -> xpLift (x:xs)))
    	 }
          where
          pc = xpSeq head  pa       (\ x ->
    	   xpSeq tail (xpList pa) (\ xs ->
    	   xpLift (x:xs)))

    xpLiftMaybe :: Maybe a -> PU a
    xpLiftMaybe = maybe xpZero xpLift

    xpWrapMaybe :: (a -> Maybe b, b -> a) -> PU a -> PU b
    xpWrapMaybe (i, j) pa	= xpSeq j pa (xpLiftMaybe . i)

    xpPair :: PU a -> PU b -> PU (a, b)
    xpPair pa pb
        = ( xpSeq fst pa (\ a ->
            xpSeq snd pb (\ b ->
            xpLift (a,b)))
          )

    xpTriple :: PU a -> PU b -> PU c -> PU (a, b, c)
    xpTriple pa pb pc
        = xpWrap (toTriple, fromTriple) (xpPair pa (xpPair pb pc))
        where
        toTriple   ~(a, ~(b, c)) = (a,  b, c )
        fromTriple ~(a,   b, c ) = (a, (b, c))

    xp4Tuple :: PU a -> PU b -> PU c -> PU d -> PU (a, b, c, d)
    xp4Tuple pa pb pc pd
        = xpWrap (toQuad, fromQuad) (xpPair pa (xpPair pb (xpPair pc pd)))
        where
        toQuad   ~(a, ~(b, ~(c, d))) = (a,  b,  c, d  )
        fromQuad ~(a,   b,   c, d  ) = (a, (b, (c, d)))

    xp5Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU (a, b, c, d, e)
    xp5Tuple pa pb pc pd pe
        = xpWrap (toQuint, fromQuint) (xpPair pa (xpPair pb (xpPair pc (xpPair pd pe))))
        where
        toQuint   ~(a, ~(b, ~(c, ~(d, e)))) = (a,  b,  c,  d, e   )
        fromQuint ~(a,   b,   c,   d, e   ) = (a, (b, (c, (d, e))))

    xp6Tuple :: PU a -> PU b -> PU c -> PU d -> PU e -> PU f -> PU (a, b, c, d, e, f)
    xp6Tuple pa pb pc pd pe pf
        = xpWrap (toSix, fromSix) (xpPair pa (xpPair pb (xpPair pc (xpPair pd (xpPair pe pf)))))
        where
        toSix   ~(a, ~(b, ~(c, ~(d, ~(e, f))))) = (a,  b,  c,  d,  e, f    )
        fromSix ~(a,   b,   c,   d,   e, f    ) = (a, (b, (c, (d, (e, f)))))

    --------------------------------------------------------------------------------

    xpText :: PU String
    xpText
        = PU { appPickle   = \ (s, st) -> addCont (mkText s) st
    	 , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleString st)
    	 }
        where
        unpickleString st
    	= do
    	  s <- getText (contents st)
    	  return (Just (unescape s), st {contents = dropText $ contents st})

    xpText0 :: PU String
    xpText0
        = xpWrap (fromMaybe "", emptyToNothing) $ xpOption $ xpText
        where
        emptyToNothing "" = Nothing
        emptyToNothing x  = Just x

    xpElem	:: String -> PU a -> PU a
    xpElem name pa
        = PU { appPickle   = ( \ (a, st) ->
    			   let
    	                   st' = appPickle pa (a, emptySt)
    			   in
    			   addCont (mkElement name (attributes st') (contents st')) st
    			 )
    	 , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)
    	 }
          where
          unpickleElement st
              = do
                e <- listToMaybe . onlyElems' . contents $ st
                n <- getElemName e
                if qualifiedName n /= name
                  then fail "element name does not match"
                  else do
                    al  <- Just $ getAttrl e
                    res <- fst . appUnPickle pa $ St {attributes = al, contents = getChildren e}
                    return (Just res, dropCont st)

    -- | A pickler for interleaved elements.
    xpIElem	:: String -> PU a -> PU a
    xpIElem name pa
        = PU { appPickle   = ( \ (a, st) ->
    			   let
    	                   st' = appPickle pa (a, emptySt)
    			   in
    			   addCont (mkElement name (attributes st') (contents st')) st
    			 )
    	 , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleElement st)
    	 }
          where
          unpickleElement st
              = do
                let t = onlyElems' . contents $ st
                ns <- mapM getElemName t
                case elemIndex name (map qualifiedName ns) of
                  Nothing -> fail "element name does not match"
                  Just i  -> do
                    let cs = getChildren (t !! i)
                    al <- Just $ getAttrl (t !! i)
                    res <- fst . appUnPickle pa $ St {attributes = al, contents = cs}
                    return (Just res, st {contents = take i t ++ drop (i + 1) t})

    xpAttr	:: String -> PU a -> PU a
    xpAttr name pa
        = PU { appPickle   = ( \ (a, st) ->
    			   let
    			   st' = appPickle pa (a, emptySt)
    			   in
    			   addAtt (mkAttribute name $ getAttrVal $ contents st') st
    			 )
    	 , appUnPickle = \ st -> fromMaybe (Nothing, st) (unpickleAttr st)
    	 }
          where
          unpickleAttr st
    	  = do
    	    a <- getAtt name st
    	    res <- fst . appUnPickle pa $ St { attributes = []
                                                 , contents   = [attrToCont a]}
    	    return (Just res, st)

    xpElemWithAttrValue :: String -> String -> String -> PU a -> PU a
    xpElemWithAttrValue n a v = xpIElem n . xpAddFixedAttr a v

    xpAttrFixed	:: String -> String -> PU ()
    xpAttrFixed name val
        = ( xpWrapMaybe ( \ v -> if v == val then Just () else Nothing
    		    , const val
    		    ) $
    	xpAttr name xpText
          )

    xpAddFixedAttr	:: String -> String -> PU a -> PU a
    xpAddFixedAttr name val pa
        = xpWrap ( snd
    	     , (,) ()
    	     ) $
          xpPair (xpAttrFixed name val) pa

    uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
    uncurry3 f (a,b,c) = f a b c

    uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
    uncurry4 f (a,b,c,d) = f a b c d

    uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a, b, c, d, e) -> f
    uncurry5 f (a,b,c,d,e) = f a b c d e

    unescape :: String -> String
    unescape [] = []
    unescape ('&':'l':'t':    ';':xs) = "<" ++ unescape xs
    unescape ('&':'g':'t':    ';':xs) = ">" ++ unescape xs
    unescape ('&':'a':'m':'p':';':xs) = "&" ++ unescape xs
    unescape (x:                  xs) = x    : unescape xs

    readXmlString :: Show a => PU a -> L.ByteString -> a
    readXmlString xp s
        = case unpickleXML xp $ parseXML' s of
            Just a -> a
            _      -> error "error while parsing the XML string"

    readXmlFile :: Show a => PU a -> FilePath -> IO a
    readXmlFile xp f = readXmlString xp `fmap` readFile' f

    readFile' :: FilePath -> IO L.ByteString
    readFile' f = do
      flip unless (error $ f ++ " file does not exist") =<< doesFileExist f
      L.readFile f