module Text.Roundtrip.Xml.Printer (
XmlPrinter, runXmlPrinter,
runXmlPrinterByteString, runXmlPrinterLazyByteString,
runXmlPrinterText, runXmlPrinterLazyText,
runXmlPrinterString
) where
import Control.Monad (mplus, liftM2)
import Data.XML.Types
import Control.Monad.State
import Control.Exception (SomeException)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Enumerator as E
import qualified Data.Enumerator.List as EL
import qualified Data.Enumerator.Binary as EB
import qualified Data.Enumerator.Text as ET
import qualified Text.XML.Enumerator.Render as EX
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Control.Isomorphism.Partial
import Text.Roundtrip
import Text.Roundtrip.Printer
data PxState = PxStateJust Name [Attribute]
| PxStateNothing
deriving (Show)
newtype XmlPrinter a = XmlPrinter { unXmlPrinter :: Printer (State PxState) [Event] a }
instance IsoFunctor XmlPrinter where
iso <$> (XmlPrinter p) = XmlPrinter $ iso `printerApply` p
instance ProductFunctor XmlPrinter where
XmlPrinter p <*> XmlPrinter q = XmlPrinter (p `printerConcat` q)
instance Alternative XmlPrinter where
XmlPrinter p <||> XmlPrinter q = XmlPrinter (p `printerAlternative` q)
empty = XmlPrinter printerEmpty
instance Syntax XmlPrinter where
pure x = XmlPrinter (printerPure x)
runXmlPrinterGen :: Monad m => XmlPrinter a -> a
-> (m (Either SomeException [c]) -> Either SomeException [c])
-> E.Enumeratee Event c m [c] -> Maybe [c]
runXmlPrinterGen p x run render =
case runXmlPrinter p x of
Nothing -> Nothing
Just l ->
case run $
E.run $
E.enumList 20 l E.$$
E.joinI $ (render E.$$ EL.consume)
of Left _ -> Nothing
Right t -> Just t
runXmlPrinterByteString :: XmlPrinter a -> a -> Maybe BS.ByteString
runXmlPrinterByteString p x =
do l <- runXmlPrinterGen p x unsafePerformIO EX.renderBytes
return $ BS.concat l
runXmlPrinterLazyByteString :: XmlPrinter a -> a -> Maybe BSL.ByteString
runXmlPrinterLazyByteString p x =
do l <- runXmlPrinterGen p x unsafePerformIO EX.renderBytes
return $ BSL.fromChunks l
runXmlPrinterText :: XmlPrinter a -> a -> Maybe T.Text
runXmlPrinterText p x =
do l <- runXmlPrinterGen p x unsafePerformIO EX.renderText
return $ T.concat l
runXmlPrinterLazyText :: XmlPrinter a -> a -> Maybe TL.Text
runXmlPrinterLazyText p x =
do l <- runXmlPrinterGen p x unsafePerformIO EX.renderText
return $ TL.fromChunks l
runXmlPrinterString :: XmlPrinter a -> a -> Maybe String
runXmlPrinterString p x =
do tl <- runXmlPrinterLazyText p x
case TL.unpack tl of
('<':'?':'x':'m':'l':z) -> Just (eat z)
str -> Just str
where
eat l =
case dropWhile (/= '?') l of
'>':xs -> xs
[] -> []
_:xs -> eat xs
runXmlPrinter :: XmlPrinter a -> a -> Maybe [Event]
runXmlPrinter (XmlPrinter (Printer p)) x =
evalState (p x) PxStateNothing
instance XmlSyntax XmlPrinter where
xmlBeginDoc = xmlPrinterBeginDoc
xmlEndDoc = xmlPrinterEndDoc
xmlBeginElem = xmlPrinterBeginElem
xmlEndElem = xmlPrinterEndElem
xmlAttrValue = xmlPrinterAttrValue
xmlTextNotEmpty = xmlPrinterTextNotEmpty
mkXmlPrinter :: (a -> State PxState (Maybe [Event])) -> XmlPrinter a
mkXmlPrinter = XmlPrinter . Printer
xmlPrinterBeginDoc :: XmlPrinter ()
xmlPrinterBeginDoc = mkXmlPrinter $ \() -> return (Just [EventBeginDocument])
xmlPrinterEndDoc :: XmlPrinter ()
xmlPrinterEndDoc = mkXmlPrinter $ \() -> return (Just [EventEndDocument])
xmlPrinterBeginElem :: Name -> XmlPrinter ()
xmlPrinterBeginElem name = mkXmlPrinter $ \() ->
do l <- possiblyCloseOpeningTag []
state <- get
let newState = case state of
PxStateNothing -> PxStateJust name []
_ -> error $ "expected state Nothing, but got " ++ (show state)
put newState
return l
xmlPrinterEndElem :: Name -> XmlPrinter ()
xmlPrinterEndElem name = mkXmlPrinter $ \() -> possiblyCloseOpeningTag [EventEndElement name]
xmlPrinterAttrValue :: Name -> XmlPrinter T.Text
xmlPrinterAttrValue aName = mkXmlPrinter $ \value ->
do state <- get
let newState = case state of
PxStateJust elName attrs ->
PxStateJust elName ((aName, [ContentText value]) : attrs)
PxStateNothing -> error "xmlAttribute: state is Nothing"
put newState
return $ Just []
xmlPrinterTextNotEmpty :: XmlPrinter T.Text
xmlPrinterTextNotEmpty = mkXmlPrinter $ \value ->
if T.null value
then return $ Just []
else possiblyCloseOpeningTag [EventContent (ContentText value)]
possiblyCloseOpeningTag :: [Event] -> State PxState (Maybe [Event])
possiblyCloseOpeningTag l =
do state <- get
case state of
PxStateJust name attrs ->
do put PxStateNothing
return $ Just (EventBeginElement name (reverse attrs) : l)
PxStateNothing -> return $ Just l