{-# LANGUAGE TemplateHaskell, FlexibleInstances,
             OverlappingInstances, UndecidableInstances #-}

module Xml.Base where

import Control.Monad.State
import Data.Char
import Data.List
import Xml.DeriveAll
import Data.Generics.SYB.WithClass.Basics
import Data.Generics.SYB.WithClass.Instances ()
import Data.Maybe
import           Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Language.Haskell.TH

$(deriveAll [d|
    data Element = Elem String [Element]
                 | CData String
                 | Attr String String
 |])

-- This is a more readable representation than the default, but is still
-- Haskell syntax
instance Show Element where
    show (Elem s es) = "Elem " ++ show s ++ " ["
                    ++ fiddle (unlines (indent (concatMap (lines . show) es)))
                    ++ "]"
        where indent = map ("    " ++)
              fiddle "" = ""
              fiddle xs = '\n' : (if last xs == '\n' then init xs else xs)
    show (CData s) = "CData " ++ show s
    show (Attr k v) = "Attr " ++ show k ++ " " ++ show v

-- XXX defaulting should happen here?
fromXml :: Xml a => [Element] -> Maybe a
fromXml xs = fmap snd $ readXml xs

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

instance Data XmlD t => Xml t

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

xmlProxy :: Proxy XmlD
xmlProxy = error "xmlProxy"

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

first :: (a -> a) -> [a] -> [a]
first _ [] = []
first f (x:xs) = f x : xs

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

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

transparentReadXml :: Xml t => [Element] -> Maybe ([Element], t)
transparentReadXml es = res
    where resType = dataTypeOf xmlProxy (snd $ fromJust res)
          res = aConstrFromElements (dataTypeConstrs resType) es

transparentXml :: Name -> Q [Dec]
transparentXml n
 = do i <- reify n
      case i of
          TyConI (DataD _ _ vs _ _) ->
              do argNames <- replicateM (length vs) (newName "a")
                 let args = map varT argNames
                     mkXml a = conT ''Xml `appT` a
                     ctxt = cxt $ map mkXml args
                     typ = mkXml $ foldl appT (conT n) args
                 decs <- [d| toXml = transparentToXml
                             readXml = transparentReadXml |]
                 d <- instanceD ctxt typ (map return decs)
                 return [d]

defaultFromXml :: Xml t => [Element] -> Maybe ([Element], t)
defaultFromXml = fromXmlWith fromElement

fromXmlWith :: Xml t
            => (Element -> Maybe t) -> [Element] -> Maybe ([Element], t)
fromXmlWith f = fromXmlWith' f []

fromXmlWith' :: Xml t
             => (Element -> Maybe t) -> [Element] -> [Element]
             -> Maybe ([Element], t)
fromXmlWith' f acc (x:xs)
 = case f x of
       Nothing -> fromXmlWith' f (x:acc) xs
       Just v ->
           Just (reverse acc ++ xs, v)
fromXmlWith' _ _ [] = Nothing

fromElement :: Xml t => Element -> Maybe t
fromElement (Elem n es) = res
    where resType = dataTypeOf xmlProxy (fromJust res)
          res = case readConstr resType $ first toUpper n of
                Just c ->
                    case constrFromElements c es of
                    -- We ignore left over elements
                    Just (_, x) -> Just x
                    Nothing -> Nothing
                Nothing -> Nothing
fromElement _ = Nothing

aConstrFromElements :: Xml t => [Constr] -> [Element] -> Maybe ([Element], t)
aConstrFromElements cs es = msum [ constrFromElements c es | c <- cs ]

constrFromElements :: Xml t => Constr -> [Element] -> Maybe ([Element], t)
constrFromElements c es = case runStateT m st of
                          -- XXX Should we flip the result order?
                          Just (x, st) -> Just (xmls st, x)
                          Nothing -> Nothing
    where m = fromConstrM xmlProxy (readMXmlD dict) c
          st = ReadState { xmls = es }

type ReadM = StateT ReadState Maybe

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

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

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

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

xmlAttr :: Name -> Q [Dec]
xmlAttr newTypeName
 = do i <- reify newTypeName
      case i of
          TyConI (NewtypeD _ n _ (NormalC c [(_, ConT t)]) _)
           | t == ''ByteString -> mkDecs n c t
          _ -> fail "xmlAttr: Didn't get what I wanted"

    where mkDecs n c t =
            do let x = mkName "x"
                   f = mkName "f"
                   cstr = stringL $ first toLower $ nameBase c
                   -- toXml (c x) = [Attr "c" $ BS.unpack x]
                   toFun = funD
                             'toXml
                             [clause
                                 [conP c [varP x]]
                                 (normalB [| [Attr $(litE cstr)
                                                   $ BS.unpack $(varE x)] |])
                                 []]
                   -- readXml = fromXmlWith f
                   --     where <readHelper>
                   readFun = funD
                             'readXml
                             [clause
                                 []
                                 (normalB [| fromXmlWith $(varE f) |])
                                 [readHelper]]
                   -- f (Attr "c" x) = Just $ c $ BS.pack x
                   -- f _ = Nothing
                   readHelper
                    = funD f
                           [
                            clause [conP 'Attr [litP cstr, (varP x)]]
                                   (normalB [| Just $ $(conE c)
                                                    $ BS.pack $(varE x) |])
                                   [],
                            clause [wildP]
                                   (normalB [| Nothing |])
                                   []
                           ]
               inst <- instanceD (cxt [])
                                 ( conT ''Xml `appT` conT n)
                                 [toFun, readFun]
               return [inst]

xmlShowCDatas :: [Name] -> Q [Dec]
xmlShowCDatas = liftM concat . mapM xmlShowCData

xmlShowCData :: Name -> Q [Dec]
xmlShowCData newTypeName
 = do ds <- [d|
                toXml x = [CData $ show x]
                readXml = fromXmlWith f
                    where f (CData x)
                           | [(v, "")] <- reads x = Just v
                          f _ = Nothing
              |]
      d <- instanceD (cxt [])
                     (conT ''Xml `appT` conT newTypeName)
                     (map return ds)
      return [d]