{-# LANGUAGE TemplateHaskell, FlexibleInstances, ScopedTypeVariables,
             GADTs, RankNTypes, FlexibleContexts, TypeSynonymInstances,
             MultiParamTypeClasses, DeriveDataTypeable, PatternGuards,
             OverlappingInstances, UndecidableInstances, CPP #-}

module T1735_Help.Xml (Element(..), Xml, fromXml) where

import T1735_Help.Basics
import T1735_Help.Instances ()
import T1735_Help.State

data Element = Elem String [Element]
             | CData String
             | Attr String String

fromXml :: Xml a => [Element] -> Maybe a
fromXml xs = case readXml xs of
             Just (_, v) -> return v
             Nothing -> error "XXX"

class (Data XmlD a) => Xml a where
    toXml :: a -> [Element]
    toXml = defaultToXml

    readXml :: [Element] -> Maybe ([Element], a)
    readXml = defaultReadXml

    readXml' :: [Element] -> Maybe ([Element], a)
    readXml' = defaultReadXml'

instance (Data XmlD t, Show t) => Xml t

data XmlD a = XmlD { toXmlD :: a -> [Element], readMXmlD :: ReadM Maybe a }

xmlProxy :: Proxy XmlD
xmlProxy = error "xmlProxy"

instance Xml t => Sat (XmlD t) where
    dict = XmlD { toXmlD = toXml, readMXmlD = readMXml }

defaultToXml :: Xml t => t -> [Element]
defaultToXml x = [Elem (constring $ toConstr xmlProxy x) (transparentToXml x)]

transparentToXml :: Xml t => t -> [Element]
transparentToXml x = concat $ gmapQ xmlProxy (toXmlD dict) x

-- Don't do any defaulting here, as these functions can be implemented
-- differently by the user. We do the defaulting elsewhere instead.
-- The t' type is thus not used.

defaultReadXml :: Xml t => [Element] -> Maybe ([Element], t)
defaultReadXml es = readXml' es

defaultReadXml' :: Xml t => [Element] -> Maybe ([Element], t)
defaultReadXml' = readXmlWith readVersionedElement

readXmlWith :: Xml t
            => (Element -> Maybe t)
            -> [Element]
            -> Maybe ([Element], t)
readXmlWith f es = case es of
                       e : es' ->
                           case f e of
                               Just v -> Just (es', v)
                               Nothing -> Nothing
                       [] ->
                           Nothing

readVersionedElement :: forall t . Xml t => Element -> Maybe t
readVersionedElement e = readElement e

readElement :: forall t . Xml t => Element -> Maybe t
readElement (Elem n es) = res
    where resType :: t
          resType = typeNotValue resType
          resDataType = dataTypeOf xmlProxy resType
          con = readConstr resDataType n
          res = case con of
                Just c -> f c
                Nothing -> Nothing
          f c =     let m :: Maybe ([Element], t)
                        m = constrFromElements c es
                    in case m of
                           Just ([], x) -> Just x
                           _ -> Nothing
readElement _ = Nothing

constrFromElements :: forall t . Xml t
                   => Constr -> [Element] -> Maybe ([Element], t)
constrFromElements c es
 = do let st = ReadState { xmls = es }
          m :: ReadM Maybe t
          m = fromConstrM xmlProxy (readMXmlD dict) c
      -- XXX Should we flip the result order?
      (x, st') <- runStateT m st
      return (xmls st', x)

type ReadM m = StateT ReadState m

data ReadState = ReadState {
                     xmls :: [Element]
                 }

getXmls :: Monad m => ReadM m [Element]
getXmls = do st <- get
             return $ xmls st

putXmls :: Monad m => [Element] -> ReadM m ()
putXmls xs = do st <- get
                put $ st { xmls = xs }

readMXml :: Xml a => ReadM Maybe a
readMXml
 = do xs <- getXmls
      case readXml xs of
          Nothing -> fail "Cannot read value"
          Just (xs', v) ->
              do putXmls xs'
                 return v

typeNotValue :: Xml a => a -> a
typeNotValue t = error ("Type used as value: " ++ typeName)
    where typeName = dataTypeName (dataTypeOf xmlProxy t)

-- The Xml [a] context is a bit scary, but if we don't have it then
-- GHC complains about overlapping instances

instance (Xml a {-, Xml [a] -}) => Xml [a] where
    toXml = concatMap toXml
    readXml = f [] []
        where f acc_xs acc_vs [] = Just (reverse acc_xs, reverse acc_vs)
              f acc_xs acc_vs (x:xs) = case readXml [x] of
                                           Just ([], v) ->
                                               f acc_xs (v:acc_vs) xs
                                           _ ->
                                               f (x:acc_xs) acc_vs xs

instance Xml String where
    toXml x = [CData x]
    readXml = readXmlWith f
        where f (CData x) = Just x
              f _ = Nothing

