{-# LANGUAGE OverloadedStrings, BangPatterns #-}
module Text.Roundtrip.Xml.Printer (

    XmlPrinter, runXmlPrinter

) where

import Control.Monad (mplus, liftM2)

import Data.XML.Types
import Control.Monad.State
import qualified Data.Text as T

import Control.Isomorphism.Partial
import Text.Roundtrip
import Text.Roundtrip.Xml.Classes

data PState = PStateJust Name [Attribute]
            | PStateNothing
              deriving (Show)

newtype XmlPrinter a = XmlPrinter { unXmlPrinter :: (a -> State PState (Maybe [Event])) }

instance IsoFunctor XmlPrinter where
    -- (<$>) :: Iso a b -> XmlPrinter a -> XmlPrinter b
    (<$>) = xmlPrinterApply

xmlPrinterApply iso (XmlPrinter p) = XmlPrinter (\b -> case unapply iso b of
                                                         Just x -> p x
                                                         Nothing -> return Nothing)

instance ProductFunctor XmlPrinter where
    -- (<*>) :: XmlPrinter a -> XmlPrinter b -> XmlPrinter (a, b)
    (<*>) = {-# SCC "<*>XmlPrinter" #-} xmlPrinterConcat

xmlPrinterConcat p q =
    XmlPrinter (\(a, b) -> do ma <- unXmlPrinter p a
                              case ma of
                                Nothing -> return Nothing
                                Just !ea -> do mb <- unXmlPrinter q b
                                               case mb of
                                                 Nothing -> return Nothing
                                                 Just eb -> return (Just (ea ++ eb)))

instance Alternative XmlPrinter where
    -- (<|>) :: XmlPrinter a -> XmlPrinter a -> XmlPrinter a
    (<|>) = xmlPrinterAlternative
    (<||>) = xmlPrinterAlternative
    empty = XmlPrinter (\_ -> return Nothing)

xmlPrinterAlternative (XmlPrinter p) (XmlPrinter q) =
    XmlPrinter (\a -> do state <- get
                         ma <- p a
                         case ma of
                           Nothing -> put state >> q a
                           Just ea -> return (Just ea))

instance Syntax XmlPrinter where
    pure = xmlPrinterPure

xmlPrinterPure x = XmlPrinter (\y -> if x == y
                                              then return (Just [])
                                              else return Nothing)

runXmlPrinter :: XmlPrinter a -> a -> Maybe [Event]
runXmlPrinter (XmlPrinter p) x =
    evalState (p x) PStateNothing

instance XmlSyntax XmlPrinter where
    xmlBeginDoc = xmlPrinterBeginDoc
    xmlEndDoc = xmlPrinterEndDoc
    xmlBeginElem = xmlPrinterBeginElem
    xmlEndElem = xmlPrinterEndElem
    xmlAttrValue = xmlPrinterAttrValue
    xmlTextNotEmpty = xmlPrinterTextNotEmpty

xmlPrinterBeginDoc :: XmlPrinter ()
xmlPrinterBeginDoc = XmlPrinter $ \() -> return (Just [EventBeginDocument])

xmlPrinterEndDoc :: XmlPrinter ()
xmlPrinterEndDoc = XmlPrinter $ \() -> return (Just [EventEndDocument])

xmlPrinterBeginElem :: Name -> XmlPrinter ()
xmlPrinterBeginElem name = XmlPrinter $ \() ->
    do l <- possiblyCloseOpeningTag []
       state <- get
       let newState = case state of
                        PStateNothing -> PStateJust name []
                        _ -> error $ "expected state Nothing, but got " ++ (show state)
       put newState
       return l

xmlPrinterEndElem :: Name -> XmlPrinter ()
xmlPrinterEndElem name = XmlPrinter $ \() -> possiblyCloseOpeningTag [EventEndElement name]

xmlPrinterAttrValue :: Name -> XmlPrinter T.Text
xmlPrinterAttrValue aName = XmlPrinter $ \value ->
     do state <- get
        let newState = case state of
                         PStateJust elName attrs ->
                             PStateJust elName ((aName, [ContentText value]) : attrs)
                         PStateNothing -> error "xmlAttribute: state is Nothing"
        put newState
        return $ Just []

xmlPrinterTextNotEmpty :: XmlPrinter T.Text
xmlPrinterTextNotEmpty = XmlPrinter $ \value ->
                         if T.null value
                            then return $ Just []
                            else possiblyCloseOpeningTag [EventContent (ContentText value)]

possiblyCloseOpeningTag :: [Event] -> State PState (Maybe [Event])
possiblyCloseOpeningTag l =
    do state <- get
       case state of
         PStateJust name attrs ->
             do put PStateNothing
                return $ Just (EventBeginElement name (reverse attrs) : l)
         PStateNothing -> return $ Just l