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
(<$>) = xmlPrinterApply
xmlPrinterApply iso (XmlPrinter p) = XmlPrinter (\b -> case unapply iso b of
Just x -> p x
Nothing -> return Nothing)
instance ProductFunctor XmlPrinter where
(<*>) = 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
(<|>) = 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