sax (empty) → 0.1.0.0
raw patch · 7 files changed
+467/−0 lines, 7 filesdep +basedep +bytestringdep +deepseqsetup-changed
Dependencies added: base, bytestring, deepseq, hspec, mtl, sax, streaming, text, xeno
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- sax.cabal +40/−0
- src/SAX.hs +276/−0
- src/SAX/Streaming.hs +34/−0
- test/Main.hs +80/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for sax-parser++## 0.1.0.0 -- 2018-03-12++* Initial release. Monadic XML parser based on xeno.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Denis Redozubov++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 Denis Redozubov 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
+ sax.cabal view
@@ -0,0 +1,40 @@+name: sax+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+maintainer: denis.redozubov@gmail.com+synopsis: Monadic streaming parser based on xeno xml parsing library+category: Text+author: Denis Redozubov+extra-source-files:+ ChangeLog.md++library+ exposed-modules:+ SAX.Streaming+ SAX+ build-depends:+ base >=4.9 && <4.11,+ deepseq -any,+ bytestring -any,+ mtl -any,+ streaming -any,+ text -any,+ xeno -any+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall -funbox-strict-fields++test-suite xeno-test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ build-depends:+ base -any,+ sax -any,+ hspec -any,+ bytestring -any+ default-language: Haskell2010+ hs-source-dirs: test+ ghc-options: -Wall
+ src/SAX.hs view
@@ -0,0 +1,276 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module SAX+ ( SaxStream+ , Result(..)+ , SaxParser(..)+ , parseSax+ , skip+ , skipAndMark+ , openTag+ , endOfOpenTag+ , bytes+ , closeTag+ , skipUntil+ , withTag+ , withTagAndAttrs+ , skipTag+ , atTag+ , streamXml+ ) where+++import Control.Applicative+import Control.Monad.Fail+import Data.ByteString hiding (empty)+import Data.Semigroup hiding (Any)+import Prelude hiding (fail, concat)+import SAX.Streaming+import Streaming hiding ((<>))+import qualified Streaming.Prelude as S+import Xeno.Types+++type SaxStream = Stream (Of SaxEvent) (Either XenoException) ()++data Result r+ = Partial (SaxEvent -> (Result r)) [ByteString] SaxStream+ -- ^ Partial result contains a continuation, a list of tags that parser will+ -- skip automatically(if parsers from `skipUntil` family of combinators were used before)+ -- the rest of the stream to consume+ | Done r+ -- ^ The parse succeeded. The @i@ parameter is the input that had+ -- not yet been consumed (if any) when the parse succeeded.+ | Fail String+ -- ^ The parse failed with current message+ deriving (Functor)++instance Show r => Show (Result r) where+ show (Fail s) = "Fail \"" ++ s ++ "\""+ show (Partial _ _ _) = "Partial { <...> }"+ show (Done r) = "Done " ++ show r++newtype SaxParser a = SaxParser+ { runSaxParser :: forall r+ . [ByteString]+ -> SaxStream+ -> ([ByteString] -> SaxStream -> Result r)+ -> ([ByteString] -> SaxStream -> a -> Result r)+ -> Result r+ }++instance Functor SaxParser where+ fmap f (SaxParser p) = SaxParser $ \tst s fk k ->+ let k' tst' s' a = k tst' s' (f a) in p tst s fk k'++apm :: SaxParser (a -> b) -> SaxParser a -> SaxParser b+apm pab pa = do+ ab <- pab+ a <- pa+ return $ ab a+{-# INLINE apm #-}++instance Applicative SaxParser where+ pure a = SaxParser $ \tst s _ k -> k tst s a+ {-# INLINE pure #-}++ (<*>) = apm+ {-# INLINE (<*>) #-}++ f *> k = f >>= const k+ {-# INLINE (*>) #-}++ k <* f = k >>= \a -> f >> pure a+ {-# INLINE (<*) #-}++instance Semigroup (SaxParser a) where+ SaxParser a <> SaxParser b = SaxParser $ \tst s fk k ->+ let fk' tst' s' = b tst' s' fk k+ in a tst s fk' k+ {-# INLINE (<>) #-}++instance Alternative SaxParser where+ empty = fail "empty alternative"+ {-# INLINE empty #-}++ (<|>) = (<>)+ {-# INLINE (<|>) #-}++instance Monad SaxParser where+ return = pure+ {-# INLINE return #-}++ SaxParser p >>= k = SaxParser $ \tst s fk ir ->+ let f tst' s' a = runSaxParser (k a) tst' s' fk ir in p tst s fk f+ {-# INLINE (>>=) #-}++ (>>) = (*>)+ {-# INLINE (>>) #-}++instance MonadFail SaxParser where+ fail s = SaxParser $ \_ _ _ _ -> Fail s+ {-# INLINE fail #-}++parseSax :: SaxParser a -> SaxStream -> Result a+parseSax (SaxParser p) s = p [] s (\_ _ -> Fail "fail handler") (\_ _ a -> Done a)+{-# INLINE parseSax #-}++-- | Shows current @SaxEvent@.+peek :: SaxParser SaxEvent+peek = SaxParser $ \tst s fk k ->+ case S.next s of+ Right (Right (event, _)) -> k tst s event+ Right (Left e) -> Fail "peek: empty sax stream"+ Left _ -> Fail "SAX stream exhausted"+{-# INLINE peek #-}++safeHead :: [a] -> Maybe (a, [a])+safeHead [] = Nothing+safeHead (a:as) = Just (a, as)+{-# INLINE safeHead #-}++skip :: SaxParser ()+skip = SaxParser $ \tst s _ k ->+ case S.next s of+ Right (Right (e, s')) ->+ k tst s' ()+ _ -> Fail "skip: stream exhausted"+{-# INLINE skip #-}++skipAndMark :: SaxParser ()+skipAndMark = SaxParser $ \tst s _ k ->+ case S.next s of+ Right (Right (event, s')) ->+ case event of+ EndOfOpenTag tag ->+ k (tag:tst) s' ()+ _ -> k tst s' ()+ _ -> Fail "skip: stream exhausted"+{-# INLINE skipAndMark #-}++openTag :: ByteString -> SaxParser ()+openTag tag = SaxParser $ \tst s fk k ->+ case S.next s of+ Right (Right (event, s')) ->+ case event of+ OpenTag tagN -> if tagN == tag then k tst s' () else fk tst s+ e -> case safeHead tst of+ Nothing -> fk tst s+ Just (tagS,rest) -> if e == CloseTag tagS+ then k rest s' ()+ else fk tst s+ Right (Left e) -> Fail (show e)+ Left _ -> Fail "SAX stream exhausted"+{-# INLINE openTag #-}++openAndMark :: SaxParser ByteString+openAndMark = SaxParser $ \tst s fk k ->+ case S.next s of+ Right (Right (event, s')) ->+ case event of+ OpenTag tagN -> k (tagN:tst) s' tagN+ _ -> fk tst s+ Right (Left e) -> Fail (show e)+ Left _ -> Fail "SAX stream exhausted"+{-# INLINE openAndMark #-}++endOfOpenTag :: ByteString -> SaxParser ()+endOfOpenTag tag = SaxParser $ \tst s fk k ->+ case S.next s of+ Right (Right (event, s')) ->+ case event of+ EndOfOpenTag tagN -> if tagN == tag then k tst s' () else fk tst s+ e -> case safeHead tst of+ Nothing -> fk tst s+ Just (tagS,rest) -> if e == CloseTag tagS+ then k rest s' ()+ else fk tst s+ Right (Left e) -> Fail (show e)+ Left _ -> Fail "SAX stream exhausted"+{-# INLINE endOfOpenTag #-}++bytes :: SaxParser ByteString+bytes = SaxParser $ \tst s fk k -> case S.next s of+ Right (Right (event, s')) ->+ let+ k' tst' s'' a = case event of+ Text textVal -> k tst' s'' textVal+ e -> case safeHead tst of+ Nothing -> fk tst s+ Just (tagS,rest) -> if e == CloseTag tagS+ then k rest s' a+ else Fail $ "expected text value, got "+ ++ show event+ ++ " instead"+ in k' tst s' ""+ Right (Left e) -> Fail (show e)+ Left _ -> Fail "SAX stream exhausted"+{-# INLINE bytes #-}++closeTag :: ByteString -> SaxParser ()+closeTag tag = SaxParser $ \tst s fk k ->+ case S.next s of+ Right (Right (event, s')) -> case event of+ CloseTag tagN ->+ if tagN == tag then k tst s' () else case safeHead tst of+ Nothing -> fk tst s+ Just (tagS,rest) -> if tagS == tagN then k rest s' () else fk tst s+ _ ->+ fk tst s+ Right (Left e) -> Fail (show e)+ Left e -> Fail "SAX stream exhausted"+{-# INLINE closeTag #-}++-- | Parses tag with its content, skipping the attributes.+withTag :: ByteString -> SaxParser a -> SaxParser a+withTag tag s = do+ openTag tag+ skipUntil' (endOfOpenTag tag)+ res <- s+ closeTag tag+ pure res+{-# INLINE withTag #-}++withTagAndAttrs+ :: ByteString+ -> SaxParser attrs+ -> SaxParser a+ -> SaxParser (attrs, a)+withTagAndAttrs tag sattrs sa = do+ openTag tag+ attrs <- sattrs+ endOfOpenTag tag+ res <- sa+ closeTag tag+ pure (attrs, res)+{-# INLINE withTagAndAttrs #-}++atTag :: ByteString -> SaxParser a -> SaxParser a+atTag tag p = do+ withTag tag p <|> (do+ t <- openAndMark+ skipUntil' (closeTag t)+ atTag tag p+ )+{-# INLINE atTag #-}++-- | Skips a tag and all of its children.+skipTag :: ByteString -> SaxParser ()+skipTag tag = do+ openTag tag+ skipUntil' (closeTag tag)+ pure ()+{-# INLINE skipTag #-}++skipUntil :: SaxParser a -> SaxParser a+skipUntil s = s <|> (skipAndMark >> skipUntil s)+{-# INLINE skipUntil #-}++-- | A version of @skipUntil@ without @skipAndMark@.+skipUntil' :: SaxParser a -> SaxParser a+skipUntil' s = s <|> (skip >> skipUntil' s)+{-# INLINE skipUntil' #-}
+ src/SAX/Streaming.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}++module SAX.Streaming where++import Control.Monad.Except+import Data.ByteString (ByteString)+import Streaming+import qualified Streaming.Prelude as S+import Xeno.SAX+import Xeno.Types+++data SaxEvent+ = OpenTag !ByteString+ | Attr !ByteString !ByteString+ | EndOfOpenTag !ByteString+ | Text !ByteString+ | CloseTag !ByteString+ | CDATA !ByteString+ deriving (Show, Eq, Ord)++streamXml+ :: (MonadError XenoException m)+ => ByteString+ -> Stream (Of SaxEvent) m ()+streamXml str = process+ (S.yield . OpenTag)+ (\a b -> S.yield $ Attr a b)+ (S.yield . EndOfOpenTag)+ (S.yield . Text)+ (S.yield . CloseTag)+ (S.yield . CDATA)+ str
+ test/Main.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Applicative+import Data.ByteString as BS+import Data.Foldable+import Data.Monoid+import SAX+import Test.Hspec+++newtype World = World ByteString deriving (Show, Eq)+data Hello = Hello+ { hHello :: ByteString+ , hWorld :: World+ , hIsDom :: Bool+ , hNonExistent :: [ByteString]+ } deriving (Show, Eq)++newtype R r = R (Result r)++instance Eq r => Eq (R r) where+ (R (Done a)) == (R (Done b)) = a == b+ (R (Fail a)) == (R (Fail b)) = a == b+ _ == _ = False++helloXml :: ByteString+helloXml = "<?xml version=\"1.1\"?><f><foo bla=\"alb\"><bar><hello><inner>Hello</inner><skipMe><meToo>and Me</meToo></skipMe><world> wor</world><world>ld!</world></hello></bar></foo></f>"++helloParser :: SaxParser Hello+helloParser = do+ withTag "f" $ do+ withTag "foo" $ do+ withTag "bar" $ do+ withTag "hello" $ do+ hello <- withTag "inner" bytes+ skipTag "skipMe"+ world <- World . BS.concat <$> some (withTag "world" bytes)+ isDom <- (withTag "is_dom" $ pure True) <|> pure False+ ne <- many (withTag "fish" bytes)+ pure $ Hello hello world isDom ne++skipTagXmls :: [(ByteString, SaxParser ByteString)]+skipTagXmls = fmap (\(x,p) -> ("<?xml version=\"1.1\"?>" <> x, p))+ [ ("<a></a><b>b</b>", skipTag "a" >> withTag "b" bytes)+ , ("<a><nested></nested></a><b>b</b>", skipTag "a" >> withTag "b" bytes)+ ]++atTagXmls :: [(ByteString, SaxParser ByteString, R ByteString)]+atTagXmls = fmap (\(x,p, r) -> ("<?xml version=\"1.1\"?>" <> x, p, r))+ [ ("<b>b</b>", atTag "b" bytes, R (Done "b"))+ , ("<a><b>b</b></a>", atTag "a" $ atTag "b" bytes, R (Done "b"))+ , ("<a><c cattr=\"c\">c</c><b>b</b></a>", atTag "a" $ atTag "b" bytes, R (Done "b"))+ , ("<a></a>", atTag "b" bytes, R (Fail "()"))+ , ("<a><a></a></a><b>b</b>", atTag "b" bytes, R (Done "b"))+ , ("<a><c cattr=\"c\">c</c></a><b>b</b><c>true</c>", atTag "a" $ atTag "c" bytes, R (Done "c"))+ , ("<a><c cattr=\"c\">c</c></a><b>b</b><c>true</c>", atTag "c" bytes, R (Done "true"))+ ]++main :: IO ()+main = hspec $ do+ describe "parser" $ do+ it "works" $ do+ parseSax helloParser (streamXml helloXml) `shouldSatisfy`+ \res -> case res of+ (Done r ) -> r == Hello "Hello" (World " world!") False []+ _ -> False+ describe "skipTag" $ do+ for_ skipTagXmls $ \(xml, parser) ->+ it (" parses " ++ show xml) $ do+ parseSax parser (streamXml xml) `shouldSatisfy` \case+ Done _ -> True+ _ -> False++ describe "atTag" $ do+ for_ atTagXmls $ \(xml, parser, result) ->+ it (" parses " ++ show xml) $ do+ parseSax parser (streamXml xml) `shouldSatisfy` ((==result) . R)