roundtrip-xml 0.1.0.0 → 0.2.0.0
raw patch · 11 files changed
+226/−278 lines, 11 filesdep +roundtrip-stringdep −parsecdep ~roundtrip
Dependencies added: roundtrip-string
Dependencies removed: parsec
Dependency ranges changed: roundtrip
Files
- LICENSE +2/−2
- roundtrip-xml.cabal +3/−6
- src/Text/Roundtrip/Xml.hs +1/−5
- src/Text/Roundtrip/Xml/Classes.hs +0/−39
- src/Text/Roundtrip/Xml/Combinators.hs +0/−39
- src/Text/Roundtrip/Xml/Enumerator.hs +1/−5
- src/Text/Roundtrip/Xml/Enumerator/Parser.hs +12/−13
- src/Text/Roundtrip/Xml/Enumerator/Printer.hs +2/−36
- src/Text/Roundtrip/Xml/Parser.hs +99/−69
- src/Text/Roundtrip/Xml/ParserInternal.hs +9/−11
- src/Text/Roundtrip/Xml/Printer.hs +97/−53
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2011, +Copyright (c) 2011 factis research GmbH All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of nor the names of other+ * Neither the name of factis research GmbH nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission.
roundtrip-xml.cabal view
@@ -1,5 +1,5 @@ Name: roundtrip-xml-Version: 0.1.0.0+Version: 0.2.0.0 Synopsis: Bidirectional (de-)serialization for XML. Description: Roundtrip allows the definition of bidirectional (de-)serialization specifications. This package provides@@ -16,12 +16,9 @@ Cabal-version: >=1.8 Library- GHC-Prof-Options: -auto-all -caf-all Hs-Source-Dirs: src Exposed-modules: Text.Roundtrip.Xml- , Text.Roundtrip.Xml.Classes- , Text.Roundtrip.Xml.Combinators , Text.Roundtrip.Xml.Printer , Text.Roundtrip.Xml.Parser , Text.Roundtrip.Xml.Enumerator@@ -43,5 +40,5 @@ , blaze-builder == 0.2.* , blaze-builder-enumerator == 0.2.* , pretty == 1.0.*- , parsec == 3.1.*- , roundtrip == 0.1.*+ , roundtrip == 0.2.*+ , roundtrip-string == 0.1.*
src/Text/Roundtrip/Xml.hs view
@@ -1,13 +1,9 @@ module Text.Roundtrip.Xml ( - module Text.Roundtrip.Xml.Classes- , module Text.Roundtrip.Xml.Combinators- , module Text.Roundtrip.Xml.Printer+ module Text.Roundtrip.Xml.Printer , module Text.Roundtrip.Xml.Parser ) where -import Text.Roundtrip.Xml.Classes-import Text.Roundtrip.Xml.Combinators import Text.Roundtrip.Xml.Printer import Text.Roundtrip.Xml.Parser
− src/Text/Roundtrip/Xml/Classes.hs
@@ -1,39 +0,0 @@-module Text.Roundtrip.Xml.Classes (-- XmlSyntax(..), Attribute--) where--import Data.Text as T--import Data.XML.Types (Name(..), Content)--import qualified Text.PrettyPrint.HughesPJ as P--import Text.Roundtrip.Classes-import Text.Roundtrip.SpecPrinter--type Attribute = (Name, [Content])--class Syntax delta => XmlSyntax delta where- xmlBeginDoc :: delta ()- xmlEndDoc :: delta ()- xmlBeginElem :: Name -> delta ()- xmlEndElem :: Name -> delta ()- xmlAttrValue :: Name -> delta T.Text -- FIXME: parser for attr value- xmlTextNotEmpty :: delta T.Text--instance XmlSyntax SpecPrinter where- xmlBeginDoc = specPrinter $ P.text "begin-doc"- xmlEndDoc = specPrinter $ P.text "end-doc"- xmlBeginElem name = specPrinter $ P.text "<" P.<> P.text (format name) P.<+> P.text "...>"- xmlEndElem name = specPrinter $ P.text "</" P.<> P.text (format name) P.<> P.text ">"- xmlAttrValue name = specPrinter $ P.text "attr" P.<+> P.text (format name)- xmlTextNotEmpty = specPrinter $ P.text "text-node"--format :: Name -> String-format n =- case n of- Name localName _ (Just prefix) -> T.unpack prefix ++ ':' : T.unpack localName- Name localName (Just ns) Nothing -> '{' : (T.unpack ns ++ '}' : T.unpack localName)- Name localName Nothing Nothing -> T.unpack localName
− src/Text/Roundtrip/Xml/Combinators.hs
@@ -1,39 +0,0 @@-module Text.Roundtrip.Xml.Combinators (-- eatWhiteSpace, xmlElem, xmlAttr, xmlFixedAttr, xmlText, xmlString--) where--import Prelude hiding ((.))--import Control.Category ((.))-import Data.Char (isSpace)-import qualified Data.Text as T--import Data.XML.Types (Name)-import Safe (readMay)--import Text.Roundtrip.Classes-import Text.Roundtrip.Combinators-import Text.Roundtrip.Xml.Classes--import Control.Isomorphism.Partial--eatWhiteSpace :: XmlSyntax d => d ()-eatWhiteSpace = ignore T.empty . subset "allIsSpace" (T.all isSpace) <$> xmlText <|> pure ()--xmlElem :: XmlSyntax x => Name -> x a -> x a-xmlElem name children =- xmlBeginElem name *> children <* xmlEndElem name--xmlAttr :: XmlSyntax x => Name -> Iso T.Text a -> x a-xmlAttr name p = p <$> xmlAttrValue name--xmlFixedAttr :: XmlSyntax x => Name -> T.Text -> x ()-xmlFixedAttr name value = fixedValue value <$> xmlAttrValue name--xmlText :: XmlSyntax d => d T.Text-xmlText = optionalWithDefault T.empty xmlTextNotEmpty--xmlString :: XmlSyntax d => d String-xmlString = textStringIso <$> xmlText
src/Text/Roundtrip/Xml/Enumerator.hs view
@@ -1,13 +1,9 @@ module Text.Roundtrip.Xml.Enumerator ( - module Text.Roundtrip.Xml.Classes- , module Text.Roundtrip.Xml.Combinators- , module Text.Roundtrip.Xml.Enumerator.Printer+ module Text.Roundtrip.Xml.Enumerator.Printer , module Text.Roundtrip.Xml.Enumerator.Parser ) where -import Text.Roundtrip.Xml.Classes-import Text.Roundtrip.Xml.Combinators import Text.Roundtrip.Xml.Enumerator.Printer import Text.Roundtrip.Xml.Enumerator.Parser
src/Text/Roundtrip/Xml/Enumerator/Parser.hs view
@@ -18,9 +18,8 @@ import qualified Debug.Trace -import qualified Text.Parsec as P- import Text.Roundtrip+import Text.Roundtrip.Parser import Text.Roundtrip.Xml import Text.Roundtrip.Xml.ParserInternal @@ -29,13 +28,13 @@ type XmlParseIteratee m a = GenXmlParser PStreamPos (StateT PStreamState (E.Iteratee RtEventWithPos m)) a -data XmlException = ParseError P.ParseError- | InvalidEntity T.Text P.SourcePos+data XmlException = ParseError ParseError+ | InvalidEntity T.Text SourcePos deriving (Typeable, Show) instance Exception XmlException -instance Monad m => P.Stream PStreamPos (StateT PStreamState (E.Iteratee RtEventWithPos m)) RtEventWithPos where+instance Monad m => Stream PStreamPos (StateT PStreamState (E.Iteratee RtEventWithPos m)) RtEventWithPos where uncons pos = do (lastPos, mLastTok) <- get case () of@@ -57,7 +56,7 @@ ", position of buffered token: " ++ show lastPos ++ " (" ++ show mLastTok ++ ")") `warn` return Nothing -parseXml :: Monad m => P.SourceName -> EntityRenderer -> XmlParseIteratee m a -> E.Iteratee Event m a+parseXml :: Monad m => SourceName -> EntityRenderer -> XmlParseIteratee m a -> E.Iteratee Event m a parseXml sourceName entityRenderer p = E.joinI $ EL.map eventWithoutPos E.$$ E.joinI $ simplify entityRenderer E.$$@@ -66,20 +65,20 @@ parseXml' :: Monad m => EntityRenderer -> XmlParseIteratee m a -> E.Iteratee EventWithPos m a parseXml' entityRenderer p = do first <- E.peek- let sourceName = case first of- Just (WithPos _ pos) -> P.sourceName pos- Nothing -> ""- E.joinI $ simplify entityRenderer E.$$ parseXml''' sourceName p+ let src = case first of+ Just (WithPos _ pos) -> sourceName pos+ Nothing -> ""+ E.joinI $ simplify entityRenderer E.$$ parseXml''' src p -parseXml'' :: Monad m => P.SourceName -> EntityRenderer -> XmlParseIteratee m a -> E.Iteratee EventWithPos m a+parseXml'' :: Monad m => SourceName -> EntityRenderer -> XmlParseIteratee m a -> E.Iteratee EventWithPos m a parseXml'' sourceName entityRenderer p = E.joinI $ simplify entityRenderer E.$$ parseXml''' sourceName p -parseXml''' :: Monad m => P.SourceName -> XmlParseIteratee m a -> E.Iteratee RtEventWithPos m a+parseXml''' :: Monad m => SourceName -> XmlParseIteratee m a -> E.Iteratee RtEventWithPos m a parseXml''' sourceName p = let GenXmlParser q = xmlBeginDoc *> p <* xmlEndDoc in do let startPos = -1- res <- evalStateT (P.runParserT q Nothing sourceName startPos) (startPos, Nothing)+ res <- evalStateT (runParserT q Nothing sourceName startPos) (startPos, Nothing) case res of Left err -> E.returnI (E.Error $ toException $ ParseError err) Right x -> E.yield x E.EOF
src/Text/Roundtrip/Xml/Enumerator/Printer.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} module Text.Roundtrip.Xml.Enumerator.Printer ( - XmlPrinter, xmlPrintEnumerator, printToLazyByteString, printToByteString, printToString+ XmlPrinter, xmlPrintEnumerator ) where @@ -12,8 +12,8 @@ import System.IO.Unsafe (unsafePerformIO) -import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL import qualified Data.Enumerator as E import qualified Data.Enumerator.List as EL@@ -42,37 +42,3 @@ Nothing -> \step -> case step of E.Error e -> E.throwError e _ -> E.throwError PrinterError--printToByteString :: XmlPrinter a -> a -> Either SomeException BS.ByteString-printToByteString p x =- case printToLazyByteString p x of- Right bsl -> Right $ BS.concat (BSL.toChunks bsl)- Left err -> Left err--printToLazyByteString :: XmlPrinter a -> a -> Either SomeException BSL.ByteString-printToLazyByteString p x =- unsafePerformIO $- E.run $- xmlPrintEnumerator p x E.$$- E.joinI $ (Xml.renderBytes E.$$ EB.consume)--printToText p x =- unsafePerformIO $- E.run $- xmlPrintEnumerator p x E.$$- E.joinI $ (Xml.renderText E.$$ ET.consume)--printToString :: XmlPrinter a -> a -> Either SomeException String-printToString p x =- case printToText p x of- Left err -> Left err- Right text ->- case TL.unpack text of- ('<':'?':'x':'m':'l':z) -> Right (eat z)- str -> Right str- where- eat l =- case dropWhile (/= '?') l of- '>':xs -> xs- [] -> []- _:xs -> eat xs
src/Text/Roundtrip/Xml/Parser.hs view
@@ -5,35 +5,43 @@ , WithPos, EventWithPos, eventWithPos, eventWithoutPos - , P.SourceName, P.Line, P.Column, P.ParseError+ , SourceName, Line, Column, ParseError , EntityRenderer, defaultEntityRenderer + , runXmlParserString, runXmlParserText, runXmlParserLazyText+ , runXmlParserByteString, runXmlParserLazyByteString+ ) where import Control.Monad (unless, foldM) import Control.Monad.State-import Control.Monad.Identity (Identity)+import Control.Monad.Identity (Identity, runIdentity) import Control.Exception (ErrorCall(..), SomeException, Exception, toException) +import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import qualified Text.XML.Enumerator.Parse as EP import qualified Data.Map as Map import Data.Map (Map) import qualified Data.List as List import Data.Typeable (Typeable)-import qualified Data.Text as T import Data.Either (partitionEithers) -import qualified Debug.Trace+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL -import qualified Text.Parsec as P-import qualified Text.Parsec.Pos as P +import qualified Debug.Trace+ import qualified Text.PrettyPrint.HughesPJ as Pp import Data.XML.Types import Text.Roundtrip-import Text.Roundtrip.Xml.Classes+import Text.Roundtrip.Parser import Text.Roundtrip.Xml.ParserInternal import Text.Roundtrip.Xml.Pretty @@ -44,22 +52,59 @@ type XmlParser a = GenXmlParser [RtEventWithPos] Identity a -runXmlParser :: P.SourceName -> EntityRenderer -> [Event] -> XmlParser a -> (Either P.ParseError a)-runXmlParser sourceName renderer events p =- runXmlParser'' sourceName renderer (map eventWithoutPos events) p+type EventGen a = EP.DecodeEntities -> E.Enumeratee a Event Identity [Event] -runXmlParser' :: EntityRenderer -> [EventWithPos] -> XmlParser a -> (Either P.ParseError a)-runXmlParser' renderer events p = runXmlParser'' sourceName renderer events p+genEvents :: [a] -> EventGen a -> Either SomeException [Event]+genEvents items f =+ runIdentity $ E.run $+ E.joinI $+ E.enumList chunkSize items E.$$+ f EP.decodeEntities E.$$+ EL.consume where- sourceName = case events of- [] -> ""- (e:_) -> P.sourceName (wp_pos e)+ chunkSize = 1 -runXmlParser'' :: P.SourceName -> EntityRenderer -> [EventWithPos] -> XmlParser a -> (Either P.ParseError a)-runXmlParser'' sourceName entityRenderer events p =+-- Parsing a string/text/bytestring into a list of events into is done via+-- enumerators. This is not optimal because the resulting list is too strict.+-- However, currently no other functions exists for such a conversion.++runXmlParserGen :: XmlParser a -> SourceName -> EntityRenderer -> [b] -> EventGen b -> (Either ParseError a)+runXmlParserGen p src er items gen =+ case genEvents items gen of+ Left err -> Left $ mkParseError (initialPos src) (show err)+ Right events -> runXmlParser p src er events++runXmlParserString :: XmlParser a -> SourceName -> EntityRenderer -> String -> (Either ParseError a)+runXmlParserString p src e str = runXmlParserGen p src e [T.pack str] EP.parseText++runXmlParserText :: XmlParser a -> SourceName -> EntityRenderer -> T.Text -> (Either ParseError a)+runXmlParserText p src e t = runXmlParserGen p src e [t] EP.parseText++runXmlParserLazyText :: XmlParser a -> SourceName -> EntityRenderer -> TL.Text -> (Either ParseError a)+runXmlParserLazyText p src e t = runXmlParserGen p src e (TL.toChunks t) EP.parseText++runXmlParserByteString :: XmlParser a -> SourceName -> EntityRenderer -> BS.ByteString -> (Either ParseError a)+runXmlParserByteString p src e bs = runXmlParserGen p src e [bs] EP.parseBytes++runXmlParserLazyByteString :: XmlParser a -> SourceName -> EntityRenderer -> BSL.ByteString -> (Either ParseError a)+runXmlParserLazyByteString p src e bs = runXmlParserGen p src e (BSL.toChunks bs) EP.parseBytes++runXmlParser :: XmlParser a -> SourceName -> EntityRenderer -> [Event] -> (Either ParseError a)+runXmlParser p sourceName renderer events =+ runXmlParser'' p sourceName renderer (map eventWithoutPos events)++runXmlParser' :: XmlParser a -> EntityRenderer -> [EventWithPos] -> (Either ParseError a)+runXmlParser' p renderer events = runXmlParser'' p src renderer events+ where+ src = case events of+ [] -> ""+ (e:_) -> sourceName (wp_pos e)++runXmlParser'' :: XmlParser a -> SourceName -> EntityRenderer -> [EventWithPos] -> (Either ParseError a)+runXmlParser'' p sourceName entityRenderer events = let GenXmlParser q = xmlBeginDoc *> p <* xmlEndDoc rtEvents = List.unfoldr (simplifyEvents entityRenderer) events- in P.runParser q Nothing sourceName rtEvents+ in runParser q Nothing sourceName rtEvents simplifyEvents :: EntityRenderer -> [EventWithPos] -> Maybe (RtEventWithPos, [EventWithPos]) simplifyEvents renderEntity evs = go evs@@ -110,36 +155,21 @@ Just t' -> Right t' Nothing -> Left t -instance (Monad m, P.Stream s m RtEventWithPos) => IsoFunctor (GenXmlParser s m) where- iso <$> (GenXmlParser p) = GenXmlParser $ xmlParserApply iso p--instance (Monad m, P.Stream s m RtEventWithPos) => ProductFunctor (GenXmlParser s m) where- (GenXmlParser p) <*> (GenXmlParser q) = GenXmlParser $ xmlParserConcat p q--instance (Monad m, P.Stream s m RtEventWithPos) => Alternative (GenXmlParser s m) where- GenXmlParser p <|> GenXmlParser q = GenXmlParser $ xmlParserAlternative1Lookahead p q- GenXmlParser p <||> GenXmlParser q = GenXmlParser $ xmlParserAlternativeInfLookahead p q- empty = GenXmlParser P.parserZero--xmlParserApply iso p =- do a <- p- case apply iso a of- Just b -> return b- Nothing -> fail $ isoFailedErrorMessageL iso a--xmlParserConcat p q =- do x <- p- y <- q- return (x, y)+instance (Monad m, Stream s m RtEventWithPos) => IsoFunctor (GenXmlParser s m) where+ iso <$> (GenXmlParser p) = GenXmlParser $ parsecApply iso p -xmlParserAlternative1Lookahead p q = p P.<|> q+instance (Monad m, Stream s m RtEventWithPos) => ProductFunctor (GenXmlParser s m) where+ (GenXmlParser p) <*> (GenXmlParser q) = GenXmlParser $ parsecConcat p q -xmlParserAlternativeInfLookahead p q = P.try p P.<|> q+instance (Monad m, Stream s m RtEventWithPos) => Alternative (GenXmlParser s m) where+ GenXmlParser p <|> GenXmlParser q = GenXmlParser $ parsecAlternative1Lookahead p q+ GenXmlParser p <||> GenXmlParser q = GenXmlParser $ parsecAlternativeInfLookahead p q+ empty = GenXmlParser parsecEmpty -instance (Monad m, P.Stream s m RtEventWithPos) => Syntax (GenXmlParser s m) where- pure x = GenXmlParser (return x)+instance (Monad m, Stream s m RtEventWithPos) => Syntax (GenXmlParser s m) where+ pure x = GenXmlParser (parsecPure x) -instance (Monad m, P.Stream s m RtEventWithPos) => XmlSyntax (GenXmlParser s m) where+instance (Monad m, Stream s m RtEventWithPos) => XmlSyntax (GenXmlParser s m) where xmlBeginDoc = GenXmlParser xmlParserBeginDoc xmlEndDoc = GenXmlParser xmlParserEndDoc xmlBeginElem = GenXmlParser . xmlParserBeginElem@@ -147,64 +177,64 @@ xmlTextNotEmpty = GenXmlParser xmlParserTextNotEmpty xmlEndElem = GenXmlParser . xmlParserEndElem -matchEvent :: (Show a, Monad m, P.Stream s m RtEventWithPos)- => (RtEvent -> Maybe a) -> String -> PParser s m a+matchEvent :: (Show a, Monad m, Stream s m RtEventWithPos)+ => (RtEvent -> Maybe a) -> String -> PxParser s m a matchEvent matcher desc =- do state <- P.getState+ do state <- getState case state of- Just _ -> P.parserZero- Nothing -> P.tokenPrim show (\_ t _ -> wp_pos t) debugMatcher+ Just _ -> parserZero+ Nothing -> tokenPrim show (\_ t _ -> wp_pos t) debugMatcher where debugMatcher ev = let res = matcher (wp_data ev) in ("matching " ++ show ev ++ " against " ++ desc ++ ", result: " ++ show res) `debug` res -mkPParser :: Monad m => String -> PParser s m a -> PParser s m a-mkPParser msg p = (p P.<?> msg)+mkPxParser :: Monad m => String -> PxParser s m a -> PxParser s m a+mkPxParser msg p = (p <?> msg) -xmlParserBeginDoc :: (Monad m, P.Stream s m RtEventWithPos) => PParser s m ()-xmlParserBeginDoc = mkPParser "begin-document" $+xmlParserBeginDoc :: (Monad m, Stream s m RtEventWithPos) => PxParser s m ()+xmlParserBeginDoc = mkPxParser "begin-document" $ let f RtBeginDocument = Just () f _ = Nothing in matchEvent f "begin-document" -xmlParserEndDoc :: (Monad m, P.Stream s m RtEventWithPos) => PParser s m ()-xmlParserEndDoc = mkPParser "end-document" $+xmlParserEndDoc :: (Monad m, Stream s m RtEventWithPos) => PxParser s m ()+xmlParserEndDoc = mkPxParser "end-document" $ let f RtEndDocument = Just () f _ = Nothing in matchEvent f "end-document" -xmlParserBeginElem :: (Monad m, P.Stream s m RtEventWithPos) => Name -> PParser s m ()-xmlParserBeginElem name = mkPParser ("<" ++ ppStr name ++ " ...>") $+xmlParserBeginElem :: (Monad m, Stream s m RtEventWithPos) => Name -> PxParser s m ()+xmlParserBeginElem name = mkPxParser ("<" ++ ppStr name ++ " ...>") $ do let f (RtBeginElement name' attrs) | name == name' = Just attrs f _ = Nothing attrs <- matchEvent f ("begin-element " ++ ppStr name)- unless (null attrs) (P.putState $ Just attrs)+ unless (null attrs) (putState $ Just attrs) return () -xmlParserAttrValue :: Monad m => Name -> PParser s m T.Text-xmlParserAttrValue name = mkPParser ("attribute " ++ ppStr name) $- do state <- P.getState+xmlParserAttrValue :: Monad m => Name -> PxParser s m T.Text+xmlParserAttrValue name = mkPxParser ("attribute " ++ ppStr name) $+ do state <- getState case state of- Nothing -> P.parserZero+ Nothing -> parserZero Just m -> case List.break (\(x,_) -> x == name) m of (prefix, (_, t) : suffix) -> do let m' = prefix ++ suffix if null m'- then P.putState Nothing- else P.putState (Just m')+ then putState Nothing+ else putState (Just m') return t- _ -> P.parserZero+ _ -> parserZero -xmlParserEndElem :: (Monad m, P.Stream s m RtEventWithPos) => Name -> PParser s m ()-xmlParserEndElem name = mkPParser ("</" ++ ppStr name ++ ">") $+xmlParserEndElem :: (Monad m, Stream s m RtEventWithPos) => Name -> PxParser s m ()+xmlParserEndElem name = mkPxParser ("</" ++ ppStr name ++ ">") $ let f (RtEndElement name') | name == name' = Just () f _ = Nothing in matchEvent f ("end-element " ++ ppStr name) -xmlParserTextNotEmpty :: (Monad m, P.Stream s m RtEventWithPos) => PParser s m T.Text-xmlParserTextNotEmpty = mkPParser "text node" $+xmlParserTextNotEmpty :: (Monad m, Stream s m RtEventWithPos) => PxParser s m T.Text+xmlParserTextNotEmpty = mkPxParser "text node" $ let f (RtText t) = Just t f _ = Nothing in matchEvent f "text node"
src/Text/Roundtrip/Xml/ParserInternal.hs view
@@ -1,6 +1,6 @@ module Text.Roundtrip.Xml.ParserInternal ( - PState, PParser, GenXmlParser(..)+ PxState, PxParser, GenXmlParser(..) , AttrMap, RtEvent(..) , WithPos(..), RtEventWithPos , EventWithPos, eventWithPos, eventWithoutPos@@ -12,14 +12,12 @@ import Text.PrettyPrint.HughesPJ -import qualified Text.Parsec as P-import qualified Text.Parsec.Pos as P-+import Text.Roundtrip.Parser import Text.Roundtrip.Xml.Pretty -type PState = Maybe AttrMap-type PParser s m a = P.ParsecT s PState m a-newtype GenXmlParser s m a = GenXmlParser (PParser s m a)+type PxState = Maybe AttrMap+type PxParser s m a = PParser s PxState m a+newtype GenXmlParser s m a = GenXmlParser (PxParser s m a) type AttrMap = [(Name, T.Text)] @@ -52,14 +50,14 @@ data WithPos a = WithPos { wp_data :: a- , wp_pos :: P.SourcePos+ , wp_pos :: SourcePos } -eventWithPos :: a -> P.SourceName -> P.Line -> P.Column -> WithPos a-eventWithPos x s l c = WithPos x (P.newPos s l c)+eventWithPos :: a -> SourceName -> Line -> Column -> WithPos a+eventWithPos x s l c = WithPos x (newPos s l c) eventWithoutPos :: a -> WithPos a-eventWithoutPos x = WithPos x (P.newPos "" (-1) (-1))+eventWithoutPos x = WithPos x (newPos "" (-1) (-1)) type EventWithPos = WithPos Event type RtEventWithPos = WithPos RtEvent
src/Text/Roundtrip/Xml/Printer.hs view
@@ -1,70 +1,111 @@ {-# LANGUAGE OverloadedStrings, BangPatterns #-} module Text.Roundtrip.Xml.Printer ( - XmlPrinter, runXmlPrinter+ 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.Xml.Classes+import Text.Roundtrip.Printer -data PState = PStateJust Name [Attribute]- | PStateNothing+data PxState = PxStateJust Name [Attribute]+ | PxStateNothing deriving (Show) -newtype XmlPrinter a = XmlPrinter { unXmlPrinter :: (a -> State PState (Maybe [Event])) }+newtype XmlPrinter a = XmlPrinter { unXmlPrinter :: Printer (State PxState) [Event] a } 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)+ iso <$> (XmlPrinter p) = XmlPrinter $ iso `printerApply` p 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)))+ XmlPrinter p <*> XmlPrinter q = XmlPrinter (p `printerConcat` q) 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))+ XmlPrinter p <||> XmlPrinter q = XmlPrinter (p `printerAlternative` q)+ empty = XmlPrinter printerEmpty instance Syntax XmlPrinter where- pure = xmlPrinterPure+ pure x = XmlPrinter (printerPure x) -xmlPrinterPure x = XmlPrinter (\y -> if x == y- then return (Just [])- else return Nothing)+-- Rendering a list of events into a string/text/bytestring is done via+-- enumerators. This is not optimal because the resulting list is too strict.+-- However, currently no other functions exists for such a conversion.+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 p) x =- evalState (p x) PStateNothing+runXmlPrinter (XmlPrinter (Printer p)) x =+ evalState (p x) PxStateNothing instance XmlSyntax XmlPrinter where xmlBeginDoc = xmlPrinterBeginDoc@@ -74,46 +115,49 @@ xmlAttrValue = xmlPrinterAttrValue xmlTextNotEmpty = xmlPrinterTextNotEmpty +mkXmlPrinter :: (a -> State PxState (Maybe [Event])) -> XmlPrinter a+mkXmlPrinter = XmlPrinter . Printer+ xmlPrinterBeginDoc :: XmlPrinter ()-xmlPrinterBeginDoc = XmlPrinter $ \() -> return (Just [EventBeginDocument])+xmlPrinterBeginDoc = mkXmlPrinter $ \() -> return (Just [EventBeginDocument]) xmlPrinterEndDoc :: XmlPrinter ()-xmlPrinterEndDoc = XmlPrinter $ \() -> return (Just [EventEndDocument])+xmlPrinterEndDoc = mkXmlPrinter $ \() -> return (Just [EventEndDocument]) xmlPrinterBeginElem :: Name -> XmlPrinter ()-xmlPrinterBeginElem name = XmlPrinter $ \() ->+xmlPrinterBeginElem name = mkXmlPrinter $ \() -> do l <- possiblyCloseOpeningTag [] state <- get let newState = case state of- PStateNothing -> PStateJust name []+ PxStateNothing -> PxStateJust name [] _ -> error $ "expected state Nothing, but got " ++ (show state) put newState return l xmlPrinterEndElem :: Name -> XmlPrinter ()-xmlPrinterEndElem name = XmlPrinter $ \() -> possiblyCloseOpeningTag [EventEndElement name]+xmlPrinterEndElem name = mkXmlPrinter $ \() -> possiblyCloseOpeningTag [EventEndElement name] xmlPrinterAttrValue :: Name -> XmlPrinter T.Text-xmlPrinterAttrValue aName = XmlPrinter $ \value ->+xmlPrinterAttrValue aName = mkXmlPrinter $ \value -> do state <- get let newState = case state of- PStateJust elName attrs ->- PStateJust elName ((aName, [ContentText value]) : attrs)- PStateNothing -> error "xmlAttribute: state is Nothing"+ PxStateJust elName attrs ->+ PxStateJust elName ((aName, [ContentText value]) : attrs)+ PxStateNothing -> error "xmlAttribute: state is Nothing" put newState return $ Just [] xmlPrinterTextNotEmpty :: XmlPrinter T.Text-xmlPrinterTextNotEmpty = XmlPrinter $ \value ->+xmlPrinterTextNotEmpty = mkXmlPrinter $ \value -> if T.null value then return $ Just [] else possiblyCloseOpeningTag [EventContent (ContentText value)] -possiblyCloseOpeningTag :: [Event] -> State PState (Maybe [Event])+possiblyCloseOpeningTag :: [Event] -> State PxState (Maybe [Event]) possiblyCloseOpeningTag l = do state <- get case state of- PStateJust name attrs ->- do put PStateNothing+ PxStateJust name attrs ->+ do put PxStateNothing return $ Just (EventBeginElement name (reverse attrs) : l)- PStateNothing -> return $ Just l+ PxStateNothing -> return $ Just l