roundtrip-xml (empty) → 0.1.0.0
raw patch · 13 files changed
+838/−0 lines, 13 filesdep +basedep +blaze-builderdep +blaze-builder-enumeratorsetup-changed
Dependencies added: base, blaze-builder, blaze-builder-enumerator, bytestring, containers, enumerator, mtl, parsec, pretty, roundtrip, safe, text, xml-enumerator, xml-types
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- roundtrip-xml.cabal +47/−0
- src/Text/Roundtrip/Xml.hs +13/−0
- src/Text/Roundtrip/Xml/Classes.hs +39/−0
- src/Text/Roundtrip/Xml/Combinators.hs +39/−0
- src/Text/Roundtrip/Xml/Enumerator.hs +13/−0
- src/Text/Roundtrip/Xml/Enumerator/Parser.hs +148/−0
- src/Text/Roundtrip/Xml/Enumerator/Printer.hs +78/−0
- src/Text/Roundtrip/Xml/Parser.hs +213/−0
- src/Text/Roundtrip/Xml/ParserInternal.hs +71/−0
- src/Text/Roundtrip/Xml/Pretty.hs +26/−0
- src/Text/Roundtrip/Xml/Printer.hs +119/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, ++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ roundtrip-xml.cabal view
@@ -0,0 +1,47 @@+Name: roundtrip-xml+Version: 0.1.0.0+Synopsis: Bidirectional (de-)serialization for XML.+Description: Roundtrip allows the definition of bidirectional+ (de-)serialization specifications. This package provides+ concrete implementations of these specifications+ for the serialization format XML. See the roundtrip+ package for more details.+License: BSD3+License-file: LICENSE+Author: Stefan Wehr <wehr@factisresearch.com>,+ David Leuschner <leuschner@factisresearch.com>+Maintainer: Stefan Wehr <wehr@factisresearch.com>,+Category: Text+Build-type: Simple+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+ , Text.Roundtrip.Xml.Enumerator.Printer+ , Text.Roundtrip.Xml.Enumerator.Parser+ Other-modules:+ Text.Roundtrip.Xml.ParserInternal+ , Text.Roundtrip.Xml.Pretty+ Build-depends:+ base == 4.*+ , safe == 0.3.*+ , bytestring == 0.9.*+ , containers >= 0.3 && < 0.6+ , mtl >= 1.1.1.1+ , text == 0.11.*+ , enumerator >= 0.4.8 && < 0.5+ , xml-enumerator == 0.3.*+ , xml-types == 0.3.*+ , blaze-builder == 0.2.*+ , blaze-builder-enumerator == 0.2.*+ , pretty == 1.0.*+ , parsec == 3.1.*+ , roundtrip == 0.1.*
+ src/Text/Roundtrip/Xml.hs view
@@ -0,0 +1,13 @@+module Text.Roundtrip.Xml (++ module Text.Roundtrip.Xml.Classes+ , module Text.Roundtrip.Xml.Combinators+ , 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 view
@@ -0,0 +1,39 @@+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 view
@@ -0,0 +1,39 @@+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
@@ -0,0 +1,13 @@+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.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
@@ -0,0 +1,148 @@+{-# OPTIONS_GHC -ddump-minimal-imports #-}+{-# LANGUAGE DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}+module Text.Roundtrip.Xml.Enumerator.Parser (++ XmlParseIteratee, parseXml, parseXml', parseXml''+ , XmlException(..)++) where++import Control.Monad.State+import Control.Exception++import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import qualified Data.Text as T+import Data.XML.Types+import Data.Typeable++import qualified Debug.Trace++import qualified Text.Parsec as P++import Text.Roundtrip+import Text.Roundtrip.Xml+import Text.Roundtrip.Xml.ParserInternal++type PStreamPos = Int+type PStreamState = (PStreamPos, Maybe RtEventWithPos) -- last event read from stream with position++type XmlParseIteratee m a = GenXmlParser PStreamPos (StateT PStreamState (E.Iteratee RtEventWithPos m)) a++data XmlException = ParseError P.ParseError+ | InvalidEntity T.Text P.SourcePos+ deriving (Typeable, Show)++instance Exception XmlException++instance Monad m => P.Stream PStreamPos (StateT PStreamState (E.Iteratee RtEventWithPos m)) RtEventWithPos where+ uncons pos =+ do (lastPos, mLastTok) <- get+ case () of+ _| pos == lastPos ->+ do mx <- lift $ EL.head+ let pos' = pos + 1+ put (pos', mx)+ ("returning " ++ show mx ++ " from underlying stream, position " ++ show pos') `debug`+ case mx of+ Just x -> return $ Just (x, pos')+ Nothing -> return Nothing+ | pos == lastPos - 1 ->+ ("returning " ++ show mLastTok ++ " from lookahead buffer, position " ++ show lastPos) `debug`+ case mLastTok of+ Just lastTok -> return $ Just (lastTok, lastPos)+ Nothing -> return Nothing+ | otherwise -> ("invalid lookahead, position request: " ++ show (pos + 1) +++ ", position of next token: " ++ show (lastPos + 1) +++ ", 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 sourceName entityRenderer p =+ E.joinI $ EL.map eventWithoutPos E.$$+ E.joinI $ simplify entityRenderer E.$$+ parseXml''' sourceName p++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++parseXml'' :: Monad m => P.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''' sourceName p =+ let GenXmlParser q = xmlBeginDoc *> p <* xmlEndDoc+ in do let startPos = -1+ res <- evalStateT (P.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++simplify :: Monad m => (T.Text -> Maybe T.Text) -> E.Enumeratee EventWithPos RtEventWithPos m b+simplify renderEntity = loop+ where+ loop = E.checkDone go+ go k =+ do x <- EL.head+ case x of+ Nothing -> k (E.Chunks []) E.>>== return+ Just (WithPos EventBeginDocument pos) ->+ k (E.Chunks [WithPos RtBeginDocument pos]) E.>>== loop+ Just (WithPos EventEndDocument pos) ->+ k (E.Chunks [WithPos RtEndDocument pos]) E.>>== loop+ Just (WithPos (EventInstruction{}) pos) -> go k+ Just (WithPos (EventBeginDoctype{}) pos) -> go k+ Just (WithPos (EventEndDoctype{}) pos) -> go k+ Just (WithPos (EventBeginElement n as) pos) ->+ let insertAttr m (k, vs) =+ do vs' <- mapM (contentToText pos) vs+ return $ (k, (T.concat vs')) : m+ in do as' <- foldM insertAttr [] as+ as' `seq` k (E.Chunks [WithPos (RtBeginElement n (reverse as')) pos])+ E.>>== loop+ Just (WithPos (EventEndElement n) pos) ->+ k (E.Chunks [WithPos (RtEndElement n) pos]) E.>>== loop+ Just (WithPos (EventContent c) pos) -> do+ t <- contentToText pos c+ ts <- takeContents $ (:) t+ let text = T.strip $ T.concat $ ts []+ if T.null text+ then go k+ else k (E.Chunks [WithPos (RtText text) pos]) E.>>== loop+ Just (WithPos (EventComment{}) _) -> go k+ contentToText pos c =+ case c of+ ContentEntity e ->+ case renderEntity e of+ Nothing -> E.throwError $ InvalidEntity e pos+ Just t -> return t+ ContentText t -> return t+ takeContents front = do+ do x <- E.peek+ case x of+ Nothing -> return front+ Just (WithPos EventBeginElement{} pos) -> return front+ Just (WithPos EventEndElement{} pos) -> return front+ Just (WithPos (EventContent c) pos) ->+ do EL.drop 1+ t <- contentToText pos c+ takeContents $ front . (:) t+ Just (WithPos EventBeginDocument pos) -> return front+ Just (WithPos EventEndDocument pos) -> return front+ Just (WithPos EventInstruction{} pos) -> helper+ Just (WithPos EventBeginDoctype{} pos) -> helper+ Just (WithPos EventEndDoctype{} pos) -> helper+ Just (WithPos EventComment{} pos) -> helper+ where+ helper = EL.drop 1 >> takeContents front++warn = Debug.Trace.trace++-- debug = Debug.Trace.trace+debug _ x = x
+ src/Text/Roundtrip/Xml/Enumerator/Printer.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Text.Roundtrip.Xml.Enumerator.Printer (++ XmlPrinter, xmlPrintEnumerator, printToLazyByteString, printToByteString, printToString++) where++import Control.Monad.Identity+import Control.Exception (SomeException, Exception, toException)+import Data.Typeable (Typeable)+import Data.Monoid (mconcat)++import System.IO.Unsafe (unsafePerformIO)++import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString as BS++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 Data.Text.Lazy as TL+import qualified Text.XML.Enumerator.Render as Xml+import Blaze.ByteString.Builder (Builder, toLazyByteString, toByteString)++import Data.XML.Types++import Text.Roundtrip.Xml.Printer++data PrinterError = PrinterError+ deriving (Show, Typeable)++instance Exception PrinterError++_CHUNK_SIZE_ :: Integer+_CHUNK_SIZE_ = 20++xmlPrintEnumerator :: Monad m => XmlPrinter a -> a -> E.Enumerator Event m b+xmlPrintEnumerator p x =+ case runXmlPrinter p x of+ Just l -> E.enumList _CHUNK_SIZE_ l+ 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
@@ -0,0 +1,213 @@+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+module Text.Roundtrip.Xml.Parser (++ GenXmlParser, XmlParser, runXmlParser, runXmlParser', runXmlParser''++ , WithPos, EventWithPos, eventWithPos, eventWithoutPos++ , P.SourceName, P.Line, P.Column, P.ParseError++ , EntityRenderer, defaultEntityRenderer++) where++import Control.Monad (unless, foldM)+import Control.Monad.State+import Control.Monad.Identity (Identity)+import Control.Exception (ErrorCall(..), SomeException, Exception, toException)++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 Text.Parsec as P+import qualified Text.Parsec.Pos as P++import qualified Text.PrettyPrint.HughesPJ as Pp++import Data.XML.Types++import Text.Roundtrip+import Text.Roundtrip.Xml.Classes+import Text.Roundtrip.Xml.ParserInternal+import Text.Roundtrip.Xml.Pretty++type EntityRenderer = T.Text -> Maybe T.Text++defaultEntityRenderer :: EntityRenderer+defaultEntityRenderer = const Nothing++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++runXmlParser' :: EntityRenderer -> [EventWithPos] -> XmlParser a -> (Either P.ParseError a)+runXmlParser' renderer events p = runXmlParser'' sourceName renderer events p+ where+ sourceName = case events of+ [] -> ""+ (e:_) -> P.sourceName (wp_pos e)++runXmlParser'' :: P.SourceName -> EntityRenderer -> [EventWithPos] -> XmlParser a -> (Either P.ParseError a)+runXmlParser'' sourceName entityRenderer events p =+ let GenXmlParser q = xmlBeginDoc *> p <* xmlEndDoc+ rtEvents = List.unfoldr (simplifyEvents entityRenderer) events+ in P.runParser q Nothing sourceName rtEvents++simplifyEvents :: EntityRenderer -> [EventWithPos] -> Maybe (RtEventWithPos, [EventWithPos])+simplifyEvents renderEntity evs = go evs+ where+ go evs =+ case evs of+ [] -> Nothing+ (WithPos EventBeginDocument pos : rest) -> Just (WithPos RtBeginDocument pos, rest)+ (WithPos EventEndDocument pos : rest) -> Just (WithPos RtEndDocument pos, rest)+ (WithPos (EventInstruction _) _ : rest) -> go rest+ (WithPos (EventBeginDoctype _ _) _ : rest) -> go rest+ (WithPos EventEndDoctype _ : rest) -> go rest+ (WithPos (EventBeginElement n as) pos : rest) ->+ let insertAttr :: Either T.Text AttrMap -> Attribute+ -> Either T.Text AttrMap+ insertAttr em (k, vs) =+ case em of+ Right m ->+ case partitionEithers (map contentToText vs) of+ ((t:_), _) -> Left t+ ([], vs') -> Right ((k, T.concat vs') : m)+ Left t -> Left t+ in case Prelude.foldl insertAttr (Right []) as of+ Right as' -> as' `seq` Just (WithPos (RtBeginElement n (reverse as')) pos, rest)+ Left t -> Just (WithPos (RtInvalidEntity t) pos, [])+ (WithPos (EventEndElement n) pos : rest) -> Just (WithPos (RtEndElement n) pos, rest)+ (WithPos (EventContent c) pos : rest) ->+ case contentToText c of+ Left t -> Just (WithPos (RtInvalidEntity t) pos, [])+ Right t ->+ let (cs, rest') = splitContent rest+ in case partitionEithers (map contentToText cs) of+ ((t:_), _) -> Just (WithPos (RtInvalidEntity t) pos, [])+ ([], ts) -> let text = T.strip $ t `T.append` T.concat ts+ in if T.null text+ then go rest'+ else Just (WithPos (RtText text) pos, rest')+ (WithPos (EventComment _) _ : rest) -> go rest+ splitContent (WithPos (EventContent c) pos : rest) =+ let (cs, rest') = splitContent rest+ in (c:cs, rest')+ splitContent l = ([], l)+ contentToText c =+ case c of+ ContentText t -> Right t+ ContentEntity t ->+ case renderEntity t of+ 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)++xmlParserAlternative1Lookahead p q = p P.<|> q++xmlParserAlternativeInfLookahead p q = P.try p P.<|> q++instance (Monad m, P.Stream s m RtEventWithPos) => Syntax (GenXmlParser s m) where+ pure x = GenXmlParser (return x)++instance (Monad m, P.Stream s m RtEventWithPos) => XmlSyntax (GenXmlParser s m) where+ xmlBeginDoc = GenXmlParser xmlParserBeginDoc+ xmlEndDoc = GenXmlParser xmlParserEndDoc+ xmlBeginElem = GenXmlParser . xmlParserBeginElem+ xmlAttrValue = GenXmlParser . xmlParserAttrValue+ 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 matcher desc =+ do state <- P.getState+ case state of+ Just _ -> P.parserZero+ Nothing -> P.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)++xmlParserBeginDoc :: (Monad m, P.Stream s m RtEventWithPos) => PParser s m ()+xmlParserBeginDoc = mkPParser "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" $+ 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 ++ " ...>") $+ 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)+ return ()++xmlParserAttrValue :: Monad m => Name -> PParser s m T.Text+xmlParserAttrValue name = mkPParser ("attribute " ++ ppStr name) $+ do state <- P.getState+ case state of+ Nothing -> P.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')+ return t+ _ -> P.parserZero++xmlParserEndElem :: (Monad m, P.Stream s m RtEventWithPos) => Name -> PParser s m ()+xmlParserEndElem name = mkPParser ("</" ++ 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" $+ let f (RtText t) = Just t+ f _ = Nothing+ in matchEvent f "text node"++-- debug = Debug.Trace.trace+debug _ x = x
+ src/Text/Roundtrip/Xml/ParserInternal.hs view
@@ -0,0 +1,71 @@+module Text.Roundtrip.Xml.ParserInternal (++ PState, PParser, GenXmlParser(..)+ , AttrMap, RtEvent(..)+ , WithPos(..), RtEventWithPos+ , EventWithPos, eventWithPos, eventWithoutPos++) where++import Data.XML.Types+import qualified Data.Text as T++import Text.PrettyPrint.HughesPJ++import qualified Text.Parsec as P+import qualified Text.Parsec.Pos as P++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 AttrMap = [(Name, T.Text)]++data RtEvent+ = RtBeginDocument+ | RtEndDocument+ | RtBeginElement Name AttrMap+ | RtText T.Text+ | RtEndElement Name+ | RtInvalidEntity T.Text+ deriving (Eq)++instance Pretty RtEvent where+ pp RtBeginDocument = text "begin-document"+ pp RtEndDocument = text "end-document"+ pp (RtBeginElement n m) = text "<" <> pp n <>+ (if null m+ then empty+ else Prelude.foldl (\d (n, t) -> d <+> pp n <> text "=" <>+ doubleQuotes (text (T.unpack t)))+ (text "") m)+ <> text ">"+ pp (RtText t) = text "text" <> parens (shorten 32 t)+ where shorten n t | T.length t <= n = text (T.unpack t)+ | otherwise = text (T.unpack (T.take n t)) <+> text "..."+ pp (RtEndElement n) = text "</" <> pp n <> text ">"++instance Show RtEvent where+ showsPrec _ ev = showString (render (pp ev))++data WithPos a = WithPos {+ wp_data :: a+ , wp_pos :: P.SourcePos+ }++eventWithPos :: a -> P.SourceName -> P.Line -> P.Column -> WithPos a+eventWithPos x s l c = WithPos x (P.newPos s l c)++eventWithoutPos :: a -> WithPos a+eventWithoutPos x = WithPos x (P.newPos "" (-1) (-1))++type EventWithPos = WithPos Event+type RtEventWithPos = WithPos RtEvent++instance Pretty a => Pretty (WithPos a) where+ pp (WithPos a p) = pp a <+> text " at " <+> text (show p)++instance Pretty a => Show (WithPos a) where+ showsPrec _ p = showString (render (pp p))
+ src/Text/Roundtrip/Xml/Pretty.hs view
@@ -0,0 +1,26 @@+module Text.Roundtrip.Xml.Pretty (++ Pretty(..)++) where++import qualified Data.Text as T++import Data.XML.Types+import Text.PrettyPrint.HughesPJ++class Pretty p where+ pp :: p -> Doc+ ppStr :: p -> String+ ppStr = render . pp++instance Pretty Name where+ pp n =+ case n of+ Name localName _ (Just prefix) ->+ text (T.unpack prefix) <> char ':' <>+ text (T.unpack localName)+ Name localName (Just ns) Nothing ->+ char '{' <> text (T.unpack ns) <> char '}' <>+ text (T.unpack localName)+ Name localName Nothing Nothing -> text (T.unpack localName)
+ src/Text/Roundtrip/Xml/Printer.hs view
@@ -0,0 +1,119 @@+{-# 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