diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright John Ky, Alexey Raga (c) 2016 +Copyright John Ky, Alexey Raga (c) 2016-2017 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,31 +1,12 @@ # hw-xml [![CircleCI](https://circleci.com/gh/haskell-works/hw-xml.svg?style=svg)](https://circleci.com/gh/haskell-works/hw-xml) -`hw-xml` is a succinct XML parsing library. It uses succinct data-structures to allow traversal of large XML strings with minimal memory overhead. - -It is currently considered experimental and is not as optimised as it could be. - -For an example, see app/Main.hs - -``` -benchmarking XmlBig/Run blankXml -time 2.212 s (1.971 s .. 2.652 s) - 0.996 R² (0.989 R² .. 1.000 R²) -mean 2.138 s (2.073 s .. 2.186 s) -std dev 73.37 ms (0.0 s .. 83.51 ms) -variance introduced by outliers: 19% (moderately inflated) +`hw-xml` is a high performance XML parsing library. It uses +succinct data-structures to allow traversal of large XML +strings with minimal memory overhead. -benchmarking XmlBig/Run xmlToInterestBits3 -time 2.497 s (2.449 s .. 2.531 s) - 1.000 R² (1.000 R² .. 1.000 R²) -mean 2.531 s (2.515 s .. 2.540 s) -std dev 13.90 ms (0.0 s .. 14.76 ms) -variance introduced by outliers: 19% (moderately inflated) +For an example, see [app/Main.hs](../master/app/Main.hs) -benchmarking XmlBig/loadXml -time 2.768 s (2.698 s .. 2.857 s) - 1.000 R² (1.000 R² .. 1.000 R²) -mean 2.780 s (2.767 s .. 2.790 s) -std dev 15.40 ms (0.0 s .. 17.48 ms) -variance introduced by outliers: 19% (moderately inflated) -``` +# Notes +* [Semi-Indexing Semi-Structured Data in Tiny Space](http://www.di.unipi.it/~ottavian/files/semi_index_cikm.pdf) +* [Space-Efficient, High-Performance Rank & Select Structures on Uncompressed Bit Sequences](https://www.cs.cmu.edu/~dga/papers/zhou-sea2013.pdf) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,50 +1,112 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} module Main where -import qualified Data.ByteString as BS -import qualified Data.Vector.Storable as DVS -import Data.Word -import GHC.Conc -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.BalancedParens.Simple -import HaskellWorks.Data.Xml.Succinct.Cursor -import HaskellWorks.Diagnostics.Time -import System.Mem +import Data.Foldable +import Data.Maybe +import Data.Semigroup ((<>)) +import Data.Word +import HaskellWorks.Data.BalancedParens.RangeMinMax2 +import HaskellWorks.Data.BalancedParens.Simple +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.RankSelect.CsPoppy +import HaskellWorks.Data.TreeCursor +import HaskellWorks.Data.Xml.Decode +import HaskellWorks.Data.Xml.DecodeResult +import HaskellWorks.Data.Xml.RawDecode +import HaskellWorks.Data.Xml.RawValue +import HaskellWorks.Data.Xml.Succinct.Cursor +import HaskellWorks.Data.Xml.Succinct.Index +import HaskellWorks.Data.Xml.Value -readXml :: String -> IO (XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) -readXml path = do - bs <- BS.readFile path - print "Read file" - !cursor <- measure (fromByteString bs :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) - print "Created cursor" +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS + +type RawCursor = XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) +type FastCursor = XmlCursor BS.ByteString CsPoppy (RangeMinMax2 CsPoppy) + +-- | Read an XML file into memory and return a raw cursor initialised to the +-- start of the XML document. +readRawCursor :: String -> IO RawCursor +readRawCursor path = do + !bs <- BS.readFile path + let !cursor = fromByteString bs :: RawCursor return cursor +-- | Read an XML file into memory and return a query-optimised cursor initialised +-- to the start of the XML document. +readFastCursor :: String -> IO FastCursor +readFastCursor filename = do + -- Load the XML file into memory as a raw cursor. + -- The raw XML data is `text`, and `ib` and `bp` are the indexes. + -- `ib` and `bp` can be persisted to an index file for later use to avoid + -- re-parsing the file. + XmlCursor !text (BitShown !ib) (SimpleBalancedParens !bp) _ <- readRawCursor filename + let !bpCsPoppy = makeCsPoppy bp + let !rangeMinMax = mkRangeMinMax2 bpCsPoppy + let !ibCsPoppy = makeCsPoppy ib + return $ XmlCursor text ibCsPoppy rangeMinMax 1 + +-- | Parse the text of an XML node. +class ParseText a where + parseText :: Value -> DecodeResult a + +instance ParseText String where + parseText (XmlText text) = DecodeOk text + parseText (XmlCData text) = DecodeOk text + parseText (XmlElement _ _ cs) = DecodeOk $ concat $ concat $ toList . parseText <$> cs + parseText _ = DecodeOk "" + +-- | Convert a decode result to a maybe +decodeResultToMaybe :: DecodeResult a -> Maybe a +decodeResultToMaybe (DecodeOk a) = Just a +decodeResultToMaybe _ = Nothing + +-- | Document model. This does not need to be able to completely represent all +-- the data in the XML document. In fact, having a smaller model may improve +-- query performance. +data Plant = Plant + { common :: String + , price :: String + } deriving (Eq, Show) + +newtype Catalog = Catalog + { plants :: [Plant] + } deriving (Eq, Show) + +-- | Decode plant element +decodePlant :: Value -> DecodeResult Plant +decodePlant xml = do + aCommon <- xml /> "common" >>= parseText + aPrice <- xml /> "price" >>= parseText + return $ Plant aCommon aPrice + +-- | Decode catalog element +decodeCatalog :: Value -> DecodeResult Catalog +decodeCatalog xml = do + aPlantXmls <- xml />> "plant" + let aPlants = catMaybes (decodeResultToMaybe . decodePlant <$> aPlantXmls) + return $ Catalog aPlants + main :: IO () main = do - performGC - !c0 <- readXml "сorpus/105mb.xml" - !c1 <- readXml "сorpus/105mb.xml" - !c2 <- readXml "сorpus/105mb.xml" - !c3 <- readXml "сorpus/105mb.xml" - !c4 <- readXml "сorpus/105mb.xml" - !c5 <- readXml "сorpus/105mb.xml" - !c6 <- readXml "сorpus/105mb.xml" - !c7 <- readXml "сorpus/105mb.xml" - !c8 <- readXml "сorpus/105mb.xml" - !c9 <- readXml "сorpus/105mb.xml" - print "Returned from readXml" - performGC - threadDelay 100000000 - print c0 - print c1 - print c2 - print c3 - print c4 - print c5 - print c6 - print c7 - print c8 - print c9 + -- Read XML into memory as a query-optimised cursor + !cursor <- readFastCursor "data/catalog.xml" + -- Skip the XML declaration to get to the root element cursor + case nextSibling cursor of + Just rootCursor -> do + -- Get the root raw XML value at the root element cursor + let rootValue = rawValueAt (xmlIndexAt rootCursor) + -- Show what we have at this cursor + putStrLn $ "Raw value: " <> take 100 (show rootValue) + -- Decode the raw XML value + case decodeCatalog (rawDecode rootValue) of + DecodeOk catalog -> putStrLn $ "Catalog: " <> show catalog + DecodeFailed msg -> putStrLn $ "Error: " <> show msg + Nothing -> do + putStrLn "Could not read XML" + return () diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -3,23 +3,24 @@ module Main where -import Criterion.Main -import Control.Monad.Trans.Resource (MonadThrow) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BSI -import Data.Conduit -import qualified Data.Vector.Storable as DVS -import Data.Word -import Foreign -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.Conduit.List -import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.Xml.Conduit -import HaskellWorks.Data.Xml.Conduit.Blank -import HaskellWorks.Data.Xml.Succinct.Cursor -import HaskellWorks.Data.BalancedParens.Simple -import System.IO.MMap +import Control.Monad.Trans.Resource (MonadThrow) +import Criterion.Main +import Data.Conduit +import Data.Word +import Foreign +import HaskellWorks.Data.BalancedParens.Simple +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Xml.Conduit +import HaskellWorks.Data.Xml.Conduit.Blank +import HaskellWorks.Data.Xml.Succinct.Cursor +import System.IO.MMap +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BSI +import qualified Data.Vector.Storable as DVS + setupEnvXml :: FilePath -> IO BS.ByteString setupEnvXml filepath = do (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr filepath ReadOnly Nothing @@ -35,24 +36,29 @@ runCon :: Conduit i [] BS.ByteString -> i -> BS.ByteString runCon con bs = BS.concat $ runListConduit con [bs] -benchRankXml8mbConduits :: [Benchmark] -benchRankXml8mbConduits = - [ env (setupEnvXml "corpus/8mb.xml") $ \bs -> bgroup "Xml4mb" - [ bench "Run blankXml " (whnf (runCon blankXml ) bs) - , bench "Run xmlToInterestBits3 " (whnf (runCon xmlToInterestBits3 ) bs) - , bench "loadXml" (whnf loadXml bs) +benchRankXmlCatalogConduits :: [Benchmark] +benchRankXmlCatalogConduits = + [ env (setupEnvXml "data/catalog.xml") $ \bs -> bgroup "catalog.xml" + [ bench "Run blankXml" (whnf (runCon blankXml ) bs) + , bench "Run xmlToInterestBits3" (whnf (runCon xmlToInterestBits3) bs) + , bench "loadXml" (whnf loadXml bs) ] ] -benchRankXmlBigConduits :: [Benchmark] -benchRankXmlBigConduits = - [ env (setupEnvXml "corpus/105mb.xml") $ \bs -> bgroup "XmlBig" - [ bench "Run blankXml " (whnf (runCon blankXml ) bs) - , bench "Run xmlToInterestBits3 " (whnf (runCon xmlToInterestBits3 ) bs) - , bench "loadXml" (whnf loadXml bs) +setupInterestingWord8s :: IO () +setupInterestingWord8s = do + let !_ = interestingWord8s + return () + +benchIsInterestingWord8 :: [Benchmark] +benchIsInterestingWord8 = + [ env setupInterestingWord8s $ \_ -> bgroup "Interesting Word8 lookup" + [ bench "isInterestingWord8" (whnf isInterestingWord8 0) ] ] main :: IO () ---main = defaultMain benchRankXml8mbConduits -main = defaultMain benchRankXmlBigConduits +main = defaultMain $ concat + [ benchIsInterestingWord8 + , benchRankXmlCatalogConduits + ] diff --git a/data/catalog.xml b/data/catalog.xml new file mode 100644 --- /dev/null +++ b/data/catalog.xml @@ -0,0 +1,326 @@ + + + + Bloodroot + Sanguinaria canadensis + 4 + Mostly Shady + $2.44 + 031599 + + + + Columbine + Aquilegia canadensis + 3 + Mostly Shady + $9.37 + 030699 + + + + Marsh Marigold + Caltha palustris + 4 + Mostly Sunny + $6.81 + 051799 + + + + Cowslip + Caltha palustris + 4 + Mostly Shady + $9.90 + 030699 + + + + Dutchman's-Breeches + Diecentra cucullaria + 3 + Mostly Shady + $6.44 + 012099 + + + + Ginger, Wild + Asarum canadense + 3 + Mostly Shady + $9.03 + 041899 + + + + Hepatica + Hepatica americana + 4 + Mostly Shady + $4.45 + 012699 + + + + Liverleaf + Hepatica americana + 4 + Mostly Shady + $3.99 + 010299 + + + + Jack-In-The-Pulpit + Arisaema triphyllum + 4 + Mostly Shady + $3.23 + 020199 + + + + Mayapple + Podophyllum peltatum + 3 + Mostly Shady + $2.98 + 060599 + + + + Phlox, Woodland + Phlox divaricata + 3 + Sun or Shade + $2.80 + 012299 + + + + Phlox, Blue + Phlox divaricata + 3 + Sun or Shade + $5.59 + 021699 + + + + Spring-Beauty + Claytonia Virginica + 7 + Mostly Shady + $6.59 + 020199 + + + + Trillium + Trillium grandiflorum + 5 + Sun or Shade + $3.90 + 042999 + + + + Wake Robin + Trillium grandiflorum + 5 + Sun or Shade + $3.20 + 022199 + + + + Violet, Dog-Tooth + Erythronium americanum + 4 + Shade + $9.04 + 020199 + + + + Trout Lily + Erythronium americanum + 4 + Shade + $6.94 + 032499 + + + + Adder's-Tongue + Erythronium americanum + 4 + Shade + $9.58 + 041399 + + + + Anemone + Anemone blanda + 6 + Mostly Shady + $8.86 + 122698 + + + + Grecian Windflower + Anemone blanda + 6 + Mostly Shady + $9.16 + 071099 + + + + Bee Balm + Monarda didyma + 4 + Shade + $4.59 + 050399 + + + + Bergamont + Monarda didyma + 4 + Shade + $7.16 + 042799 + + + + Black-Eyed Susan + Rudbeckia hirta + Annual + Sunny + $9.80 + 061899 + + + + Buttercup + Ranunculus + 4 + Shade + $2.57 + 061099 + + + + Crowfoot + Ranunculus + 4 + Shade + $9.34 + 040399 + + + + Butterfly Weed + Asclepias tuberosa + Annual + Sunny + $2.78 + 063099 + + + + Cinquefoil + Potentilla + Annual + Shade + $7.06 + 052599 + + + + Primrose + Oenothera + 3 - 5 + Sunny + $6.56 + 013099 + + + + Gentian + Gentiana + 4 + Sun or Shade + $7.81 + 051899 + + + + Blue Gentian + Gentiana + 4 + Sun or Shade + $8.56 + 050299 + + + + Jacob's Ladder + Polemonium caeruleum + Annual + Shade + $9.26 + 022199 + + + + Greek Valerian + Polemonium caeruleum + Annual + Shade + $4.36 + 071499 + + + + California Poppy + Eschscholzia californica + Annual + Sun + $7.89 + 032799 + + + + Shooting Star + Dodecatheon + Annual + Mostly Shady + $8.60 + 051399 + + + + Snakeroot + Cimicifuga + Annual + Shade + $5.63 + 071199 + + + + Cardinal Flower + Lobelia cardinalis + 2 + Shade + $3.02 + 022299 + + diff --git a/hw-xml.cabal b/hw-xml.cabal --- a/hw-xml.cabal +++ b/hw-xml.cabal @@ -1,5 +1,5 @@ name: hw-xml -version: 0.0.0.1 +version: 0.1.0.0 synopsis: Conduits for tokenizing streams. description: Please see README.md homepage: http://github.com/haskell-works/hw-xml#readme @@ -12,7 +12,7 @@ build-type: Simple extra-source-files: README.md cabal-version: >= 1.22 -data-files: test/data/sample.xml +data-files: data/catalog.xml executable hw-xml-example hs-source-dirs: app @@ -20,28 +20,28 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -msse4.2 build-depends: base >= 4 && < 5 , bytestring - , conduit - , criterion , hw-balancedparens >= 0.1.0.0 , hw-bits >= 0.4.0.0 - , hw-conduit >= 0.1.0.0 - , hw-diagnostics >= 0.0.0.5 - , hw-xml , hw-prim >= 0.4.0.0 , hw-rankselect >= 0.7.0.0 - , mmap - , resourcet + , hw-xml , vector default-language: Haskell2010 library hs-source-dirs: src exposed-modules: HaskellWorks.Data.Xml + , HaskellWorks.Data.Xml.Blank , HaskellWorks.Data.Xml.CharLike , HaskellWorks.Data.Xml.Conduit , HaskellWorks.Data.Xml.Conduit.Blank , HaskellWorks.Data.Xml.Conduit.Words + , HaskellWorks.Data.Xml.Decode + , HaskellWorks.Data.Xml.DecodeError + , HaskellWorks.Data.Xml.DecodeResult , HaskellWorks.Data.Xml.Grammar + , HaskellWorks.Data.Xml.Index + , HaskellWorks.Data.Xml.Lens , HaskellWorks.Data.Xml.Succinct , HaskellWorks.Data.Xml.Succinct.Cursor , HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParens @@ -50,6 +50,8 @@ , HaskellWorks.Data.Xml.Succinct.Cursor.Internal , HaskellWorks.Data.Xml.Succinct.Cursor.Token , HaskellWorks.Data.Xml.Succinct.Index + , HaskellWorks.Data.Xml.RawDecode + , HaskellWorks.Data.Xml.RawValue , HaskellWorks.Data.Xml.Token.Tokenize , HaskellWorks.Data.Xml.Token.Types , HaskellWorks.Data.Xml.Token @@ -60,18 +62,21 @@ , ansi-wl-pprint , attoparsec , bytestring + , cereal , conduit , containers + , ghc-prim , hw-balancedparens >= 0.1.0.0 , hw-bits >= 0.4.0.0 - , hw-conduit >= 0.1.0.0 + , hw-conduit >= 0.2.0.2 , hw-parser , hw-prim >= 0.4.0.0 , hw-rankselect >= 0.7.0.0 , hw-rankselect-base >= 0.2.0.0 - , mono-traversable + , lens + , mtl , resourcet - , text + , transformers , vector , word8 @@ -82,29 +87,26 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - other-modules: HaskellWorks.Data.Xml.Token.TokenizeSpec + other-modules: HaskellWorks.Data.Xml.Conduit.BlankSpec + , HaskellWorks.Data.Xml.RawValueSpec + , HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec + , HaskellWorks.Data.Xml.Succinct.Cursor.InterestBitsSpec , HaskellWorks.Data.Xml.Succinct.CursorSpec + , HaskellWorks.Data.Xml.Token.TokenizeSpec , HaskellWorks.Data.Xml.TypeSpec - , HaskellWorks.Data.Xml.ValueSpec - , HaskellWorks.Data.Xml.Succinct.Cursor.InterestBitsSpec build-depends: base >= 4 && < 5 , attoparsec , bytestring , conduit - , containers , hspec , hw-balancedparens >= 0.1.0.0 , hw-bits >= 0.4.0.0 - , hw-conduit >= 0.1.0.0 + , hw-conduit >= 0.2.0.2 , hw-xml , hw-prim >= 0.4.0.0 , hw-rankselect >= 0.7.0.0 , hw-rankselect-base >= 0.2.0.0 - , mmap - , parsec , QuickCheck - , resourcet - , transformers , vector ghc-options: -threaded -rtsopts -with-rtsopts=-N -- -Wall @@ -126,10 +128,9 @@ , criterion , hw-balancedparens >= 0.1.0.0 , hw-bits >= 0.4.0.0 - , hw-conduit >= 0.1.0.0 + , hw-conduit >= 0.2.0.2 , hw-xml , hw-prim >= 0.4.0.0 - , hw-rankselect >= 0.7.0.0 , mmap , resourcet , vector diff --git a/src/HaskellWorks/Data/Xml.hs b/src/HaskellWorks/Data/Xml.hs --- a/src/HaskellWorks/Data/Xml.hs +++ b/src/HaskellWorks/Data/Xml.hs @@ -1,11 +1,8 @@ --- | --- Copyright: 2016 John Ky --- License: MIT --- --- Xml module HaskellWorks.Data.Xml ( module X ) where -import HaskellWorks.Data.Xml.Succinct as X -import HaskellWorks.Data.Xml.Token as X +import HaskellWorks.Data.Xml.Decode as X +import HaskellWorks.Data.Xml.DecodeError as X +import HaskellWorks.Data.Xml.Succinct as X +import HaskellWorks.Data.Xml.Token as X diff --git a/src/HaskellWorks/Data/Xml/Blank.hs b/src/HaskellWorks/Data/Xml/Blank.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Blank.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Xml.Blank + ( blankXml + ) where + +import Data.ByteString as BS +import Data.Word +import Data.Word8 +import HaskellWorks.Data.Xml.Conduit.Words +import Prelude as P + +type ExpectedChar = Word8 + +data BlankState + = InXml + | InTag + | InAttrList + | InCloseTag + | InClose + | InBang Int + | InString ExpectedChar + | InText + | InMeta + | InCdataTag + | InCdata Int + | InRem Int + | InIdent + deriving (Eq, Show) + +data ByteStringP = BSP Word8 ByteString | EmptyBSP deriving Show + +blankXml :: BS.ByteString -> BS.ByteString +blankXml as = fst (BS.unfoldrN (BS.length as) go (InXml, as)) + where go :: (BlankState, ByteString) -> Maybe (Word8, (BlankState, ByteString)) + go (InXml, bs) = case BS.uncons bs of + Just (!c, !cs) | isMetaStart c cs -> Just (_bracketleft , (InMeta , cs)) + Just (!c, !cs) | isEndTag c cs -> Just (_space , (InCloseTag , cs)) + Just (!c, !cs) | isTextStart c -> Just (_t , (InText , cs)) + Just (!c, !cs) | c == _less -> Just (_less , (InTag , cs)) + Just (!c, !cs) | isSpace c -> Just (c , (InXml , cs)) + Just ( _, !cs) -> Just (_space , (InXml , cs)) + Nothing -> Nothing + go (InTag, bs) = case BS.uncons bs of + Just (!c, !cs) | isSpace c -> Just (_parenleft , (InAttrList , cs)) + Just (!c, !cs) | isTagClose c cs -> Just (_space , (InClose , cs)) + Just (!c, !cs) | c == _greater -> Just (_space , (InXml , cs)) + Just (!c, !cs) | isSpace c -> Just (c , (InTag , cs)) + Just ( _, !cs) -> Just (_space , (InTag , cs)) + Nothing -> Nothing + go (InCloseTag, bs) = case BS.uncons bs of + Just (!c, !cs) | c == _greater -> Just (_greater , (InXml , cs)) + Just ( _, !cs) -> Just (_space , (InCloseTag , cs)) + Nothing -> Nothing + go (InAttrList, bs) = case BS.uncons bs of + Just (!c, !cs) | c == _greater -> Just (_parenright , (InXml , cs)) + Just (!c, !cs) | isTagClose c cs -> Just (_parenright , (InClose , cs)) + Just (!c, !cs) | isNameStartChar c -> Just (_a , (InIdent , cs)) + Just (!c, !cs) | isQuote c -> Just (_v , (InString c , cs)) + Just (!c, !cs) | isSpace c -> Just (c , (InAttrList , cs)) + Just ( _, !cs) -> Just (_space , (InAttrList , cs)) + Nothing -> Nothing + go (InClose, bs) = case BS.uncons bs of + Just (_, !cs) -> Just (_greater , (InXml , cs)) + Nothing -> Nothing + go (InIdent, bs) = case BS.uncons bs of + Just (!c, !cs) | isNameChar c -> Just (_space , (InIdent , cs)) + Just (!c, !cs) | isSpace c -> Just (_space , (InAttrList , cs)) + Just (!c, !cs) | c == _equal -> Just (_space , (InAttrList , cs)) + Just (!c, !cs) | isSpace c -> Just (c , (InAttrList , cs)) + Just ( _, !cs) -> Just (_space , (InAttrList , cs)) + Nothing -> Nothing + go (InString q, bs) = case BS.uncons bs of + Just (!c, !cs) | c == q -> Just (_space , (InAttrList , cs)) + Just (!c, !cs) | isSpace c -> Just (c , (InString q , cs)) + Just ( _, !cs) -> Just (_space , (InString q , cs)) + Nothing -> Nothing + go (InText, bs) = case BS.uncons bs of + Just (!c, !cs) | isEndTag c cs -> Just (_space , (InCloseTag , cs)) + Just ( _, !cs) | headIs (== _less) cs -> Just (_space , (InXml , cs)) + Just (!c, !cs) | isSpace c -> Just (c , (InText , cs)) + Just ( _, !cs) -> Just (_space , (InText , cs)) + Nothing -> Nothing + go (InMeta, bs) = case BS.uncons bs of + Just (!c, !cs) | c == _exclam -> Just (_space , (InMeta , cs)) + Just (!c, !cs) | c == _hyphen -> Just (_space , (InRem 0 , cs)) + Just (!c, !cs) | c == _bracketleft -> Just (_space , (InCdataTag , cs)) + Just (!c, !cs) | c == _greater -> Just (_bracketright, (InXml , cs)) + Just (!c, !cs) | isSpace c -> Just (c , (InBang 1 , cs)) + Just ( _, !cs) -> Just (_space , (InBang 1 , cs)) + Nothing -> Nothing + go (InCdataTag, bs) = case BS.uncons bs of + Just (!c, !cs) | c == _bracketleft -> Just (_space , (InCdata 0 , cs)) + Just (!c, !cs) | isSpace c -> Just (c , (InCdataTag , cs)) + Just ( _, !cs) -> Just (_space , (InCdataTag , cs)) + Nothing -> Nothing + go (InCdata n, bs) = case BS.uncons bs of + Just (!c, !cs) | c == _greater && n >= 2 -> Just (_bracketright, (InXml , cs)) + Just (!c, !cs) | isCdataEnd c cs && n > 0 -> Just (_space , (InCdata (n+1), cs)) + Just (!c, !cs) | c == _bracketright -> Just (_space , (InCdata (n+1), cs)) + Just (!c, !cs) | isSpace c -> Just (c , (InCdata 0 , cs)) + Just ( _, !cs) -> Just (_space , (InCdata 0 , cs)) + Nothing -> Nothing + go (InRem n, bs) = case BS.uncons bs of + Just (!c, !cs) | c == _greater && n >= 2 -> Just (_bracketright, (InXml , cs)) + Just (!c, !cs) | c == _hyphen -> Just (_space , (InRem (n+1) , cs)) + Just (!c, !cs) | isSpace c -> Just (c , (InRem 0 , cs)) + Just ( _, !cs) -> Just (_space , (InRem 0 , cs)) + Nothing -> Nothing + go (InBang n, bs) = case BS.uncons bs of + Just (!c, !cs) | c == _less -> Just (_bracketleft , (InBang (n+1) , cs)) + Just (!c, !cs) | c == _greater && n == 1 -> Just (_bracketright, (InXml , cs)) + Just (!c, !cs) | c == _greater -> Just (_bracketright, (InBang (n-1) , cs)) + Just (!c, !cs) | isSpace c -> Just (c , (InBang n , cs)) + Just ( _, !cs) -> Just (_space , (InBang n , cs)) + Nothing -> Nothing + +isEndTag :: Word8 -> ByteString -> Bool +isEndTag c cs = c == _less && headIs (== _slash) cs +{-# INLINE isEndTag #-} + +isTagClose :: Word8 -> ByteString -> Bool +isTagClose c cs = (c == _slash) || ((c == _slash || c == _question) && headIs (== _greater) cs) +{-# INLINE isTagClose #-} + +isMetaStart :: Word8 -> ByteString -> Bool +isMetaStart c cs = c == _less && headIs (== _exclam) cs +{-# INLINE isMetaStart #-} + +isCdataEnd :: Word8 -> ByteString -> Bool +isCdataEnd c cs = c == _bracketright && headIs (== _greater) cs +{-# INLINE isCdataEnd #-} + +headIs :: (Word8 -> Bool) -> ByteString -> Bool +headIs p bs = case BS.uncons bs of + Just (!c, _) -> p c + Nothing -> False +{-# INLINE headIs #-} diff --git a/src/HaskellWorks/Data/Xml/CharLike.hs b/src/HaskellWorks/Data/Xml/CharLike.hs --- a/src/HaskellWorks/Data/Xml/CharLike.hs +++ b/src/HaskellWorks/Data/Xml/CharLike.hs @@ -1,7 +1,7 @@ module HaskellWorks.Data.Xml.CharLike where -import Data.Word -import Data.Word8 as W +import Data.Word +import Data.Word8 as W class XmlCharLike c where isElementStart :: c -> Bool diff --git a/src/HaskellWorks/Data/Xml/Conduit.hs b/src/HaskellWorks/Data/Xml/Conduit.hs --- a/src/HaskellWorks/Data/Xml/Conduit.hs +++ b/src/HaskellWorks/Data/Xml/Conduit.hs @@ -8,19 +8,20 @@ , blankedXmlToBalancedParens2 , compressWordAsBit , interestingWord8s + , isInterestingWord8 ) where -import Control.Monad -import Data.Array.Unboxed as A -import qualified Data.Bits as BITS -import Data.ByteString as BS -import Data.Conduit -import Data.Int -import Data.Word -import Data.Word8 -import HaskellWorks.Data.Bits.BitWise -import Prelude as P +import Control.Monad +import Data.Array.Unboxed as A +import Data.ByteString as BS +import Data.Conduit +import Data.Word +import Data.Word8 +import HaskellWorks.Data.Bits.BitWise +import Prelude as P +import qualified Data.Bits as BITS + interestingWord8s :: A.UArray Word8 Word8 interestingWord8s = A.array (0, 255) [ (w, if w == _bracketleft @@ -32,17 +33,15 @@ then 1 else 0) | w <- [0 .. 255]] +{-# NOINLINE interestingWord8s #-} +isInterestingWord8 :: Word8 -> Word8 +isInterestingWord8 b = interestingWord8s ! b +{-# INLINABLE isInterestingWord8 #-} + blankedXmlToInterestBits :: Monad m => Conduit BS.ByteString m BS.ByteString blankedXmlToInterestBits = blankedXmlToInterestBits' "" -padRight :: Word8 -> Int -> BS.ByteString -> BS.ByteString -padRight w n bs = if BS.length bs >= n then bs else fst (BS.unfoldrN n gen bs) - where gen :: ByteString -> Maybe (Word8, ByteString) - gen cs = case BS.uncons cs of - Just (c, ds) -> Just (c, ds) - Nothing -> Just (w, BS.empty) - blankedXmlToInterestBits' :: Monad m => BS.ByteString -> Conduit BS.ByteString m BS.ByteString blankedXmlToInterestBits' rs = do mbs <- await @@ -50,16 +49,19 @@ Just bs -> do let cs = if BS.length rs /= 0 then BS.concat [rs, bs] else bs let lencs = BS.length cs - let q = lencs + 7 `quot` 8 + let q = lencs `quot` 8 let (ds, es) = BS.splitAt (q * 8) cs let (fs, _) = BS.unfoldrN q gen ds yield fs blankedXmlToInterestBits' es - Nothing -> return () + Nothing -> do + let lenrs = BS.length rs + let q = lenrs + 7 `quot` 8 + yield (fst (BS.unfoldrN q gen rs)) where gen :: ByteString -> Maybe (Word8, ByteString) gen as = if BS.length as == 0 then Nothing - else Just ( BS.foldr (\b m -> (interestingWord8s ! b) .|. (m .<. 1)) 0 (padRight 0 8 (BS.take 8 as)) + else Just ( BS.foldr' (\b m -> (interestingWord8s ! b) .|. (m .<. 1)) 0 (BS.take 8 as) , BS.drop 8 as ) @@ -87,18 +89,31 @@ blankedXmlToBalancedParens' cs Nothing -> return () +repartitionMod8 :: BS.ByteString -> BS.ByteString -> (BS.ByteString, BS.ByteString) +repartitionMod8 aBS bBS = (BS.take cLen abBS, BS.drop cLen abBS) + where abBS = BS.concat [aBS, bBS] + abLen = BS.length abBS + cLen = (abLen `div` 8) * 8 + compressWordAsBit :: Monad m => Conduit BS.ByteString m BS.ByteString -compressWordAsBit = do - mbs <- await - case mbs of - Just bs -> do - let (cs, _) = BS.unfoldrN (BS.length bs + 7 `div` 8) gen bs +compressWordAsBit = compressWordAsBit' BS.empty + +compressWordAsBit' :: Monad m => BS.ByteString -> Conduit BS.ByteString m BS.ByteString +compressWordAsBit' aBS = do + mbBS <- await + case mbBS of + Just bBS -> do + let (cBS, dBS) = repartitionMod8 aBS bBS + let (cs, _) = BS.unfoldrN (BS.length cBS + 7 `div` 8) gen cBS yield cs - Nothing -> return () + compressWordAsBit' dBS + Nothing -> do + let (cs, _) = BS.unfoldrN (BS.length aBS + 7 `div` 8) gen aBS + yield cs where gen :: ByteString -> Maybe (Word8, ByteString) gen xs = if BS.length xs == 0 then Nothing - else Just ( BS.foldr (\b m -> ((b .&. 1) .|. (m .<. 1))) 0 (padRight 0 8 (BS.take 8 xs)) + else Just ( BS.foldr' (\b m -> ((b .&. 1) .|. (m .<. 1))) 0 (BS.take 8 xs) , BS.drop 8 xs ) @@ -109,16 +124,17 @@ Just bs -> do let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs) yield cs + blankedXmlToBalancedParens2 Nothing -> return () where gen :: (Maybe Bool, ByteString) -> Maybe (Word8, (Maybe Bool, ByteString)) gen (Just True , bs) = Just (0xFF, (Nothing, bs)) gen (Just False , bs) = Just (0x00, (Nothing, bs)) gen (Nothing , bs) = case BS.uncons bs of Just (c, cs) -> case balancedParensOf c of - MiniN -> gen (Nothing , cs) - MiniT -> Just (0xFF, (Nothing , cs)) - MiniF -> Just (0x00, (Nothing , cs)) - MiniTF -> Just (0xFF, (Just False , cs)) + MiniN -> gen (Nothing , cs) + MiniT -> Just (0xFF, (Nothing , cs)) + MiniF -> Just (0x00, (Nothing , cs)) + MiniTF -> Just (0xFF, (Just False , cs)) Nothing -> Nothing data MiniBP = MiniN | MiniT | MiniF | MiniTF diff --git a/src/HaskellWorks/Data/Xml/Conduit/Blank.hs b/src/HaskellWorks/Data/Xml/Conduit/Blank.hs --- a/src/HaskellWorks/Data/Xml/Conduit/Blank.hs +++ b/src/HaskellWorks/Data/Xml/Conduit/Blank.hs @@ -1,166 +1,157 @@ +{-# OPTIONS_GHC-funbox-strict-fields #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module HaskellWorks.Data.Xml.Conduit.Blank ( blankXml + , BlankData(..) ) where -import Control.Monad -import Control.Monad.Trans.Resource (MonadThrow) -import Data.ByteString as BS -import Data.Conduit -import Data.Word -import Data.Word8 -import HaskellWorks.Data.Xml.Conduit.Words -import Prelude as P +import Control.Monad +import Control.Monad.Trans.Resource (MonadThrow) +import Data.ByteString as BS +import Data.Conduit +import Data.Monoid ((<>)) +import Data.Word +import Data.Word8 +import HaskellWorks.Data.Xml.Conduit.Words +import Prelude as P type ExpectedChar = Word8 + data BlankState = InXml - | InTag | InAttrList | InCloseTag | InClose - | InBang Int - | InString ExpectedChar | InText + | InTag + | InAttrList + | InCloseTag + | InClose + | InBang !Int + | InString !ExpectedChar + | InText | InMeta - | InCdataTag | InCdata Int - | InRem Int + | InCdataTag + | InCdata !Int + | InRem !Int | InIdent -data ByteStringP = BSP Word8 ByteString | EmptyBSP +data BlankData = BlankData + { blankState :: !BlankState + , blankA :: !Word8 + , blankB :: !Word8 + , blankC :: !ByteString + } blankXml :: MonadThrow m => Conduit BS.ByteString m BS.ByteString -blankXml = blankXml' Nothing InXml +blankXml = blankXmlPlan1 BS.empty InXml -blankXml' :: MonadThrow m => Maybe Word8 -> BlankState -> Conduit BS.ByteString m BS.ByteString -blankXml' lastChar lastState = do +blankXmlPlan1 :: MonadThrow m => BS.ByteString -> BlankState -> Conduit BS.ByteString m BS.ByteString +blankXmlPlan1 as lastState = do mbs <- await - case prefix lastChar mbs of - Just bsp -> do - let (safe, next) = unsnocUndecided bsp - let (!cs, Just (!nextState, _)) = unfoldrN (lenBSP safe) blankByteString (lastState, safe) - yield cs - blankXml' next nextState - Nothing -> return () - where - blankByteString :: (BlankState, ByteStringP) -> Maybe (Word8, (BlankState, ByteStringP)) - blankByteString (InXml, bs) = case bs of - BSP !c !cs | isMetaStart c cs -> Just (_bracketleft , (InMeta , toBSP cs)) - BSP !c !cs | isEndTag c cs -> Just (_space , (InCloseTag, toBSP cs)) - BSP !c !cs | isTextStart c -> Just (_t , (InText , toBSP cs)) - BSP !c !cs | c == _less -> Just (_less , (InTag , toBSP cs)) - BSP _ !cs -> Just (_space , (InXml , toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InTag, bs) = case bs of - BSP !c !cs | isSpace c -> Just (_parenleft , (InAttrList, toBSP cs)) - BSP !c !cs | isTagClose c cs -> Just (_space , (InClose , toBSP cs)) - BSP !c !cs | c == _greater -> Just (_space , (InXml , toBSP cs)) - BSP _ !cs -> Just (_space , (InTag , toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InCloseTag, bs) = case bs of - BSP !c !cs | c == _greater -> Just (_greater , (InXml , toBSP cs)) - BSP _ !cs -> Just (_space , (InCloseTag, toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InAttrList, bs) = case bs of - BSP !c !cs | c == _greater -> Just (_parenright , (InXml , toBSP cs)) - BSP !c !cs | isTagClose c cs -> Just (_parenright , (InClose , toBSP cs)) - BSP !c !cs | isNameStartChar c -> Just (_a , (InIdent , toBSP cs)) - BSP !c !cs | isQuote c -> Just (_v , (InString c, toBSP cs)) - BSP _ !cs -> Just (_space , (InAttrList, toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InClose, bs) = case bs of - BSP _ !cs -> Just (_greater , (InXml , toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InIdent, bs) = case bs of - BSP !c !cs | isNameChar c -> Just (_space , (InIdent , toBSP cs)) - BSP !c !cs | isSpace c -> Just (_space , (InAttrList, toBSP cs)) - BSP !c !cs | c == _equal -> Just (_space , (InAttrList, toBSP cs)) - BSP _ !cs -> Just (_space , (InAttrList, toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InString q, bs) = case bs of - BSP !c !cs | c == q -> Just (_space , (InAttrList, toBSP cs)) - BSP _ !cs -> Just (_space , (InString q, toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InText, bs) = case bs of - BSP !c !cs | isEndTag c cs -> Just (_space , (InCloseTag, toBSP cs)) - BSP _ !cs | headIs (== _less) cs -> Just (_space , (InXml , toBSP cs)) - BSP _ !cs -> Just (_space , (InText , toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InMeta, bs) = case bs of - BSP !c !cs | c == _exclam -> Just (_space , (InMeta , toBSP cs)) - BSP !c !cs | c == _hyphen -> Just (_space , (InRem 0 , toBSP cs)) - BSP !c !cs | c == _bracketleft -> Just (_space , (InCdataTag , toBSP cs)) - BSP !c !cs | c == _greater -> Just (_bracketright, (InXml , toBSP cs)) - BSP _ !cs -> Just (_space , (InBang 1 , toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InCdataTag, bs) = case bs of - BSP !c !cs | c == _bracketleft -> Just (_space , (InCdata 0 , toBSP cs)) - BSP _ !cs -> Just (_space , (InCdataTag , toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InCdata n, bs) = case bs of - BSP !c !cs | c == _greater && n >= 2 -> Just (_bracketright, (InXml , toBSP cs)) - BSP !c !cs | isCdataEnd c cs && n>0 -> Just (_space , (InCdata (n+1), toBSP cs)) - BSP !c !cs | c == _bracketright -> Just (_space , (InCdata (n+1), toBSP cs)) - BSP _ !cs -> Just (_space , (InCdata 0 , toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InRem n, bs) = case bs of - BSP !c !cs | c == _greater && n >= 2 -> Just (_bracketright, (InXml , toBSP cs)) - BSP !c !cs | c == _hyphen -> Just (_space , (InRem (n+1) , toBSP cs)) - BSP _ !cs -> Just (_space , (InRem 0 , toBSP cs)) - EmptyBSP -> Nothing - blankByteString (InBang n, bs) = case bs of - BSP !c !cs | c == _less -> Just (_bracketleft , (InBang (n+1) , toBSP cs)) - BSP !c !cs | c == _greater && n == 1 -> Just (_bracketright, (InXml , toBSP cs)) - BSP !c !cs | c == _greater -> Just (_bracketright, (InBang (n-1) , toBSP cs)) - BSP _ !cs -> Just (_space , (InBang n , toBSP cs)) - EmptyBSP -> Nothing - -prefix :: Maybe Word8 -> Maybe ByteString -> Maybe ByteStringP -prefix (Just s) (Just bs) = Just $ BSP s bs -prefix (Just s) Nothing = Just $ BSP s BS.empty -prefix Nothing (Just bs) = (\(!c, !cs) -> BSP c cs) <$> BS.uncons bs -prefix Nothing Nothing = Nothing - -toBSP :: ByteString -> ByteStringP -toBSP bs = case BS.uncons bs of - Just (!c, !cs) -> BSP c cs - Nothing -> EmptyBSP - -lenBSP :: ByteStringP -> Int -lenBSP (BSP _ bs) = BS.length bs + 1 -lenBSP EmptyBSP = 0 + case mbs of + Just bs -> do + let cs = as <> bs + case BS.uncons cs of + Just (d, ds) -> case BS.uncons ds of + Just (e, es) -> blankXmlRun False d e es lastState + Nothing -> blankXmlPlan1 cs lastState + Nothing -> blankXmlPlan1 cs lastState + Nothing -> yield $ BS.map (const _space) as -isEndTag :: Word8 -> ByteString -> Bool -isEndTag c cs = c == _less && headIs (== _slash) cs +blankXmlPlan2 :: MonadThrow m => Word8 -> Word8 -> BlankState -> Conduit BS.ByteString m BS.ByteString +blankXmlPlan2 a b lastState = do + mcs <- await + case mcs of + Just cs -> blankXmlRun False a b cs lastState + Nothing -> blankXmlRun True a b (BS.pack [_space, _space]) lastState --- isStartTag :: Word8 -> ByteString -> Bool --- isStartTag c cs = c == _less && headIs isNameStartChar cs +blankXmlRun :: MonadThrow m => Bool -> Word8 -> Word8 -> BS.ByteString -> BlankState -> Conduit BS.ByteString m BS.ByteString +blankXmlRun done a b cs lastState = do + let (!ds, Just (BlankData !nextState _ _ _)) = unfoldrN (BS.length cs) blankByteString (BlankData lastState a b cs) + yield ds + let (yy, zz) = case BS.unsnoc cs of + Just (ys, z) -> case BS.unsnoc ys of + Just (_, y) -> (y, z) + Nothing -> (b, z) + Nothing -> (a, b) + unless done (blankXmlPlan2 yy zz nextState) -isTagClose :: Word8 -> ByteString -> Bool -isTagClose c cs = - (c == _slash || c == _question) && headIs (== _greater) cs +mkNext :: Word8 -> BlankState -> Word8 -> BS.ByteString -> Maybe (Word8, BlankData) +mkNext w s a bs = case BS.uncons bs of + Just (b, cs) -> Just (w, BlankData s a b cs) + Nothing -> error "This should never happen" +{-# INLINE mkNext #-} -isMetaStart :: Word8 -> ByteString -> Bool -isMetaStart c cs = c == _less && headIs (== _exclam) cs +blankByteString :: BlankData -> Maybe (Word8, BlankData) +blankByteString (BlankData InXml a b cs) | isMetaStart a b = mkNext _bracketleft InMeta b cs +blankByteString (BlankData InXml a b cs) | isEndTag a b = mkNext _space InCloseTag b cs +blankByteString (BlankData InXml a b cs) | isTextStart a = mkNext _t InText b cs +blankByteString (BlankData InXml a b cs) | a == _less = mkNext _less InTag b cs +blankByteString (BlankData InXml a b cs) | isSpace a = mkNext a InXml b cs +blankByteString (BlankData InXml _ b cs) = mkNext _space InXml b cs +blankByteString (BlankData InTag a b cs) | isSpace a = mkNext _parenleft InAttrList b cs +blankByteString (BlankData InTag a b cs) | isTagClose a b = mkNext _space InClose b cs +blankByteString (BlankData InTag a b cs) | a == _greater = mkNext _space InXml b cs +blankByteString (BlankData InTag a b cs) | isSpace a = mkNext a InTag b cs +blankByteString (BlankData InTag _ b cs) = mkNext _space InTag b cs +blankByteString (BlankData InCloseTag a b cs) | a == _greater = mkNext _greater InXml b cs +blankByteString (BlankData InCloseTag a b cs) | isSpace a = mkNext a InCloseTag b cs +blankByteString (BlankData InCloseTag _ b cs) = mkNext _space InCloseTag b cs +blankByteString (BlankData InAttrList a b cs) | a == _greater = mkNext _parenright InXml b cs +blankByteString (BlankData InAttrList a b cs) | isTagClose a b = mkNext _parenright InClose b cs +blankByteString (BlankData InAttrList a b cs) | isNameStartChar a = mkNext _a InIdent b cs +blankByteString (BlankData InAttrList a b cs) | isQuote a = mkNext _v (InString a) b cs +blankByteString (BlankData InAttrList a b cs) | isSpace a = mkNext a InAttrList b cs +blankByteString (BlankData InAttrList _ b cs) = mkNext _space InAttrList b cs +blankByteString (BlankData InClose _ b cs) = mkNext _greater InXml b cs +blankByteString (BlankData InIdent a b cs) | isNameChar a = mkNext _space InIdent b cs +blankByteString (BlankData InIdent a b cs) | isSpace a = mkNext _space InAttrList b cs +blankByteString (BlankData InIdent a b cs) | a == _equal = mkNext _space InAttrList b cs +blankByteString (BlankData InIdent a b cs) | isSpace a = mkNext a InAttrList b cs +blankByteString (BlankData InIdent _ b cs) = mkNext _space InAttrList b cs +blankByteString (BlankData (InString q ) a b cs) | a == q = mkNext _space InAttrList b cs +blankByteString (BlankData (InString q ) a b cs) | isSpace a = mkNext a (InString q) b cs +blankByteString (BlankData (InString q ) _ b cs) = mkNext _space (InString q) b cs +blankByteString (BlankData InText a b cs) | isEndTag a b = mkNext _space InCloseTag b cs +blankByteString (BlankData InText _ b cs) | b == _less = mkNext _space InXml b cs +blankByteString (BlankData InText a b cs) | isSpace a = mkNext a InText b cs +blankByteString (BlankData InText _ b cs) = mkNext _space InText b cs +blankByteString (BlankData InMeta a b cs) | a == _exclam = mkNext _space InMeta b cs +blankByteString (BlankData InMeta a b cs) | a == _hyphen = mkNext _space (InRem 0) b cs +blankByteString (BlankData InMeta a b cs) | a == _bracketleft = mkNext _space InCdataTag b cs +blankByteString (BlankData InMeta a b cs) | a == _greater = mkNext _bracketright InXml b cs +blankByteString (BlankData InMeta a b cs) | isSpace a = mkNext a (InBang 1) b cs +blankByteString (BlankData InMeta _ b cs) = mkNext _space (InBang 1) b cs +blankByteString (BlankData InCdataTag a b cs) | a == _bracketleft = mkNext _space (InCdata 0) b cs +blankByteString (BlankData InCdataTag a b cs) | isSpace a = mkNext a InCdataTag b cs +blankByteString (BlankData InCdataTag _ b cs) = mkNext _space InCdataTag b cs +blankByteString (BlankData (InCdata n ) a b cs) | a == _greater && n >= 2 = mkNext _bracketright InXml b cs +blankByteString (BlankData (InCdata n ) a b cs) | isCdataEnd a b && n > 0 = mkNext _space (InCdata (n+1)) b cs +blankByteString (BlankData (InCdata n ) a b cs) | a == _bracketright = mkNext _space (InCdata (n+1)) b cs +blankByteString (BlankData (InCdata _ ) a b cs) | isSpace a = mkNext a (InCdata 0) b cs +blankByteString (BlankData (InCdata _ ) _ b cs) = mkNext _space (InCdata 0) b cs +blankByteString (BlankData (InRem n ) a b cs) | a == _greater && n >= 2 = mkNext _bracketright InXml b cs +blankByteString (BlankData (InRem n ) a b cs) | a == _hyphen = mkNext _space (InRem (n+1)) b cs +blankByteString (BlankData (InRem _ ) a b cs) | isSpace a = mkNext a (InRem 0) b cs +blankByteString (BlankData (InRem _ ) _ b cs) = mkNext _space (InRem 0) b cs +blankByteString (BlankData (InBang n ) a b cs) | a == _less = mkNext _bracketleft (InBang (n+1)) b cs +blankByteString (BlankData (InBang n ) a b cs) | a == _greater && n == 1 = mkNext _bracketright InXml b cs +blankByteString (BlankData (InBang n ) a b cs) | a == _greater = mkNext _bracketright (InBang (n-1)) b cs +blankByteString (BlankData (InBang n ) a b cs) | isSpace a = mkNext a (InBang n) b cs +blankByteString (BlankData (InBang n ) _ b cs) = mkNext _space (InBang n) b cs +{-# INLINE blankByteString #-} -isCdataEnd :: Word8 -> ByteString -> Bool -isCdataEnd c cs = c == _bracketright && headIs (== _greater) cs +isEndTag :: Word8 -> Word8 -> Bool +isEndTag a b = a == _less && b == _slash +{-# INLINE isEndTag #-} -unsnocUndecided :: ByteStringP -> (ByteStringP, Maybe Word8) -unsnocUndecided = unscnocIf (\w -> w ==_less -- or ? - || w == _slash -- or not? - || w == _hyphen -- closing comment or just - ? - || w == _bracketright) -- closing CDATA or just data? -{-# INLINE unsnocUndecided #-} +isTagClose :: Word8 -> Word8 -> Bool +isTagClose a b = a == _slash || ((a == _slash || a == _question) && b == _greater) +{-# INLINE isTagClose #-} -headIs :: (Word8 -> Bool) -> ByteString -> Bool -headIs p bs = case BS.uncons bs of - Just (!c, _) -> p c - Nothing -> False -{-# INLINE headIs #-} +isMetaStart :: Word8 -> Word8 -> Bool +isMetaStart a b = a == _less && b == _exclam +{-# INLINE isMetaStart #-} -unscnocIf :: (Word8 -> Bool) -> ByteStringP -> (ByteStringP, Maybe Word8) -unscnocIf _ EmptyBSP = (EmptyBSP, Nothing) -unscnocIf p (BSP !c !bs) = - case BS.unsnoc bs of - Just (bs', w) | p w -> (BSP c bs', Just w) - _ -> (BSP c bs , Nothing) -{-# INLINE unscnocIf #-} +isCdataEnd :: Word8 -> Word8 -> Bool +isCdataEnd a b = a == _bracketright && b == _greater +{-# INLINE isCdataEnd #-} diff --git a/src/HaskellWorks/Data/Xml/Conduit/Words.hs b/src/HaskellWorks/Data/Xml/Conduit/Words.hs --- a/src/HaskellWorks/Data/Xml/Conduit/Words.hs +++ b/src/HaskellWorks/Data/Xml/Conduit/Words.hs @@ -1,7 +1,7 @@ module HaskellWorks.Data.Xml.Conduit.Words where -import Data.Word -import Data.Word8 +import Data.Word +import Data.Word8 isLeadingDigit :: Word8 -> Bool isLeadingDigit w = w == _hyphen || (w >= _0 && w <= _9) @@ -34,4 +34,3 @@ isIn :: Word8 -> (Word8, Word8) -> Bool isIn w (s, e) = w >= s && w <= e {-# INLINE isIn #-} - diff --git a/src/HaskellWorks/Data/Xml/Decode.hs b/src/HaskellWorks/Data/Xml/Decode.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Decode.hs @@ -0,0 +1,55 @@ +module HaskellWorks.Data.Xml.Decode where + +import Control.Applicative +import Control.Lens +import Control.Monad +import Data.Foldable +import Data.Monoid ((<>)) +import HaskellWorks.Data.Xml.DecodeError +import HaskellWorks.Data.Xml.DecodeResult +import HaskellWorks.Data.Xml.Value + +class Decode a where + decode :: Value -> DecodeResult a + +instance Decode Value where + decode = DecodeOk + {-# INLINE decode #-} + +failDecode :: String -> DecodeResult a +failDecode = DecodeFailed . DecodeError + +(@>) :: Value -> String -> DecodeResult String +(@>) (XmlElement _ as _) n = case find (\v -> fst v == n) as of + Just (_, text) -> DecodeOk text + Nothing -> failDecode $ "No such attribute " <> show n +(@>) _ n = failDecode $ "Not an element whilst looking up attribute " <> show n + +(/>) :: Value -> String -> DecodeResult Value +(/>) (XmlElement _ _ cs) n = go cs + where go [] = failDecode $ "Unable to find element " <> show n + go (r:rs) = case r of + e@(XmlElement n' _ _) | n' == n -> DecodeOk e + _ -> go rs +(/>) _ n = failDecode $ "Expecting parent of element " <> show n + +(?>) :: Value -> (Value -> DecodeResult Value) -> DecodeResult Value +(?>) v f = f v <|> pure v + +(~>) :: Value -> String -> DecodeResult Value +(~>) e@(XmlElement n' _ _) n | n' == n = DecodeOk e +(~>) _ n = failDecode $ "Expecting parent of element " <> show n + +(/>>) :: Value -> String -> DecodeResult [Value] +(/>>) v n = v ^. childNodes <&> (~> n) <&> toList & join & pure + +-- Contextful + +() :: DecodeResult Value -> String -> DecodeResult Value +() ma n = ma >>= (/> n) + +(<@>) :: DecodeResult Value -> String -> DecodeResult String +(<@>) ma n = ma >>= (@> n) + +() :: DecodeResult Value -> (Value -> DecodeResult Value) -> DecodeResult Value +() ma f = ma >>= (?> f) diff --git a/src/HaskellWorks/Data/Xml/DecodeError.hs b/src/HaskellWorks/Data/Xml/DecodeError.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/DecodeError.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module HaskellWorks.Data.Xml.DecodeError where + +newtype DecodeError = DecodeError String deriving (Eq, Show) diff --git a/src/HaskellWorks/Data/Xml/DecodeResult.hs b/src/HaskellWorks/Data/Xml/DecodeResult.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/DecodeResult.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE DeriveFunctor #-} + +module HaskellWorks.Data.Xml.DecodeResult where + +import Control.Applicative +import HaskellWorks.Data.Xml.DecodeError + +data DecodeResult a + = DecodeOk a + | DecodeFailed DecodeError + deriving (Eq, Show, Functor) + +instance Applicative DecodeResult where + pure = DecodeOk + {-# INLINE pure #-} + + (<*>) (DecodeOk f ) (DecodeOk a) = DecodeOk (f a) + (<*>) (DecodeOk _ ) (DecodeFailed e) = DecodeFailed e + (<*>) (DecodeFailed e) _ = DecodeFailed e + {-# INLINE (<*>) #-} + +instance Monad DecodeResult where + return = DecodeOk + {-# INLINE return #-} + + (>>=) (DecodeOk a) f = f a + (>>=) (DecodeFailed e) _ = DecodeFailed e + {-# INLINE (>>=) #-} + +instance Alternative DecodeResult where + empty = DecodeFailed (DecodeError "Failed decode") + (<|>) (DecodeOk a) _ = DecodeOk a + (<|>) _ (DecodeOk b) = DecodeOk b + (<|>) _ (DecodeFailed e) = DecodeFailed e + {-# INLINE (<|>) #-} + +instance Foldable DecodeResult where + foldr f z (DecodeOk a) = f a z + foldr _ z (DecodeFailed _) = z + +toEither :: DecodeResult a -> Either DecodeError a +toEither (DecodeOk a) = Right a +toEither (DecodeFailed e) = Left e + +isOk :: DecodeResult a -> Bool +isOk (DecodeOk _) = True +isOk _ = False + +isFailed :: DecodeResult a -> Bool +isFailed (DecodeFailed _) = True +isFailed _ = False diff --git a/src/HaskellWorks/Data/Xml/Grammar.hs b/src/HaskellWorks/Data/Xml/Grammar.hs --- a/src/HaskellWorks/Data/Xml/Grammar.hs +++ b/src/HaskellWorks/Data/Xml/Grammar.hs @@ -3,15 +3,15 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} module HaskellWorks.Data.Xml.Grammar where -import Control.Applicative -import qualified Data.Attoparsec.Types as T -import Data.Char -import Data.String -import HaskellWorks.Data.Parser as P +import Control.Applicative +import Data.Char +import Data.String +import HaskellWorks.Data.Parser as P + +import qualified Data.Attoparsec.Types as T data XmlElementType = XmlElementTypeDocument diff --git a/src/HaskellWorks/Data/Xml/Index.hs b/src/HaskellWorks/Data/Xml/Index.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Index.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleInstances #-} + +module HaskellWorks.Data.Xml.Index + ( Index(..) + , indexVersion + ) where + +import Data.Serialize +import Data.Word +import HaskellWorks.Data.Bits.BitShown + +import qualified Data.Vector.Storable as DVS + +indexVersion :: String +indexVersion = "1.0" + +data Index = Index + { xiVersion :: String + , xiInterests :: BitShown (DVS.Vector Word64) + , xiBalancedParens :: BitShown (DVS.Vector Word64) + } deriving (Eq, Show) + +putBitShownVector :: Putter (BitShown (DVS.Vector Word64)) +putBitShownVector = putVector . bitShown + +getBitShownVector :: Get (BitShown (DVS.Vector Word64)) +getBitShownVector = BitShown <$> getVector + +putVector :: DVS.Vector Word64 -> Put +putVector v = do + let len = DVS.length v + put len + DVS.forM_ v put + +getVector :: Get (DVS.Vector Word64) +getVector = do + len <- get + DVS.generateM len (const get) + +instance Serialize Index where + put xi = do + put $ xiVersion xi + putBitShownVector $ xiInterests xi + putBitShownVector $ xiBalancedParens xi + + get = do + version <- get + ib <- getBitShownVector + bp <- getBitShownVector + return $ Index version ib bp diff --git a/src/HaskellWorks/Data/Xml/Lens.hs b/src/HaskellWorks/Data/Xml/Lens.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Lens.hs @@ -0,0 +1,11 @@ +module HaskellWorks.Data.Xml.Lens where + +import Control.Lens +import HaskellWorks.Data.Xml.Value + +isTagNamed :: String -> Value -> Bool +isTagNamed a (XmlElement b _ _) | a == b = True +isTagNamed _ _ = False + +tagNamed :: (Applicative f, Choice p) => String -> Optic' p f Value Value +tagNamed = filtered . isTagNamed diff --git a/src/HaskellWorks/Data/Xml/RawDecode.hs b/src/HaskellWorks/Data/Xml/RawDecode.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/RawDecode.hs @@ -0,0 +1,10 @@ +module HaskellWorks.Data.Xml.RawDecode where + +import HaskellWorks.Data.Xml.RawValue + +class RawDecode a where + rawDecode :: RawValue -> a + +instance RawDecode RawValue where + rawDecode = id + {-# INLINE rawDecode #-} diff --git a/src/HaskellWorks/Data/Xml/RawValue.hs b/src/HaskellWorks/Data/Xml/RawValue.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/RawValue.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Xml.RawValue + ( RawValue(..) + , RawValueAt(..) + ) where + +import Data.List +import Data.Monoid +import HaskellWorks.Data.Xml.Grammar +import HaskellWorks.Data.Xml.Succinct.Index +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) + +import qualified Data.Attoparsec.ByteString.Char8 as ABC +import qualified Data.ByteString as BS + +data RawValue + = RawDocument [RawValue] + | RawText String + | RawElement String [RawValue] + | RawCData String + | RawComment String + | RawMeta String [RawValue] + | RawAttrName String + | RawAttrValue String + | RawAttrList [RawValue] + | RawError String + deriving (Eq, Show) + +instance Pretty RawValue where + pretty mjpv = case mjpv of + RawText s -> ctext $ text s + RawAttrName s -> text s + RawAttrValue s -> (ctext . dquotes . text) s + RawAttrList ats -> formatAttrs ats + RawComment s -> text $ "" + RawElement s xs -> formatElem s xs + RawDocument xs -> formatMeta "?" "xml" xs + RawError s -> red $ text "[error " <> text s <> text "]" + RawCData s -> cangle " ctag (text "[CDATA[") <> text s <> cangle (text "]]>") + RawMeta s xs -> formatMeta "!" s xs + where + formatAttr at = case at of + RawAttrName a -> text " " <> pretty (RawAttrName a) + RawAttrValue a -> text "=" <> pretty (RawAttrValue a) + RawAttrList _ -> red $ text "ATTRS" + _ -> red $ text "booo" + formatAttrs ats = hcat (formatAttr <$> ats) + formatElem s xs = + let (ats, es) = partition isAttrL xs + in cangle langle <> ctag (text s) + <> hcat (pretty <$> ats) + <> cangle rangle + <> hcat (pretty <$> es) + <> cangle (text " ctag (text s) <> cangle rangle + formatMeta b s xs = + let (ats, es) = partition isAttr xs + in cangle (langle <> text b) <> ctag (text s) + <> hcat (pretty <$> ats) + <> cangle rangle + <> hcat (pretty <$> es) + +class RawValueAt a where + rawValueAt :: a -> RawValue + +instance RawValueAt XmlIndex where + rawValueAt i = case i of + XmlIndexCData s -> parseTextUntil "]]>" s `as` RawCData + XmlIndexComment s -> parseTextUntil "-->" s `as` RawComment + XmlIndexMeta s cs -> RawMeta s (rawValueAt <$> cs) + XmlIndexElement s cs -> RawElement s (rawValueAt <$> cs) + XmlIndexDocument cs -> RawDocument (rawValueAt <$> cs) + XmlIndexAttrName cs -> parseAttrName cs `as` RawAttrName + XmlIndexAttrValue cs -> parseString cs `as` RawAttrValue + XmlIndexAttrList cs -> RawAttrList (rawValueAt <$> cs) + XmlIndexValue s -> parseTextUntil "<" s `as` RawText + XmlIndexError s -> RawError s + --unknown -> XmlError ("Not yet supported: " <> show unknown) + where + parseUntil s = ABC.manyTill ABC.anyChar (ABC.string s) + + parseTextUntil s bs = case ABC.parse (parseUntil s) bs of + ABC.Fail {} -> decodeErr ("Unable to find " <> show s <> ".") bs + ABC.Partial _ -> decodeErr ("Unexpected end, expected " <> show s <> ".") bs + ABC.Done _ r -> Right r + parseString bs = case ABC.parse parseXmlString bs of + ABC.Fail {} -> decodeErr "Unable to parse string" bs + ABC.Partial _ -> decodeErr "Unexpected end of string, expected" bs + ABC.Done _ r -> Right r + parseAttrName bs = case ABC.parse parseXmlAttributeName bs of + ABC.Fail {} -> decodeErr "Unable to parse attribute name" bs + ABC.Partial _ -> decodeErr "Unexpected end of attr name, expected" bs + ABC.Done _ r -> Right r + +cangle :: Doc -> Doc +cangle = dullwhite + +ctag :: Doc -> Doc +ctag = bold + +ctext :: Doc -> Doc +ctext = dullgreen + +isAttrL :: RawValue -> Bool +isAttrL (RawAttrList _) = True +isAttrL _ = False + +isAttr :: RawValue -> Bool +isAttr v = case v of + RawAttrName _ -> True + RawAttrValue _ -> True + RawAttrList _ -> True + _ -> False + +as :: Either String a -> (a -> RawValue) -> RawValue +as = flip $ either RawError + +decodeErr :: String -> BS.ByteString -> Either String a +decodeErr reason bs = + Left $ reason <>" (" <> show (BS.take 20 bs) <> "...)" diff --git a/src/HaskellWorks/Data/Xml/Succinct.hs b/src/HaskellWorks/Data/Xml/Succinct.hs --- a/src/HaskellWorks/Data/Xml/Succinct.hs +++ b/src/HaskellWorks/Data/Xml/Succinct.hs @@ -2,4 +2,4 @@ ( module X ) where -import HaskellWorks.Data.Xml.Succinct.Cursor as X +import HaskellWorks.Data.Xml.Succinct.Cursor as X diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor.hs --- a/src/HaskellWorks/Data/Xml/Succinct/Cursor.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor.hs @@ -3,5 +3,5 @@ ( module X ) where -import HaskellWorks.Data.Xml.Succinct.Cursor.Internal as X -import HaskellWorks.Data.Xml.Succinct.Cursor.Token as X +import HaskellWorks.Data.Xml.Succinct.Cursor.Internal as X +import HaskellWorks.Data.Xml.Succinct.Cursor.Token as X diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParens.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParens.hs --- a/src/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParens.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParens.hs @@ -8,15 +8,16 @@ , getXmlBalancedParens ) where -import Control.Applicative -import qualified Data.ByteString as BS -import Data.Conduit -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.BalancedParens as BP -import HaskellWorks.Data.Conduit.List -import HaskellWorks.Data.Xml.Conduit -import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml +import Control.Applicative +import Data.Conduit +import Data.Word +import HaskellWorks.Data.BalancedParens as BP +import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.Xml.Conduit +import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml + +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS newtype XmlBalancedParens a = XmlBalancedParens a diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs --- a/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs @@ -5,12 +5,13 @@ , getBlankedXml ) where -import qualified Data.ByteString as BS -import HaskellWorks.Data.ByteString -import HaskellWorks.Data.Conduit.List -import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.Xml.Conduit.Blank +import HaskellWorks.Data.ByteString +import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Xml.Conduit.Blank +import qualified Data.ByteString as BS + newtype BlankedXml = BlankedXml [BS.ByteString] deriving (Eq, Show) getBlankedXml :: BlankedXml -> [BS.ByteString] @@ -18,6 +19,7 @@ class FromBlankedXml a where fromBlankedXml :: BlankedXml -> a + instance FromByteString BlankedXml where fromByteString bs = BlankedXml (runListConduit blankXml (chunkedBy 4064 bs)) diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBits.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBits.hs --- a/src/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBits.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBits.hs @@ -6,19 +6,22 @@ module HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits ( XmlInterestBits(..) , getXmlInterestBits + , blankedXmlToInterestBits + , blankedXmlBssToInterestBitsBs ) where -import Control.Applicative -import qualified Data.ByteString as BS -import Data.ByteString.Internal -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.Conduit.List -import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.RankSelect.Poppy512 -import HaskellWorks.Data.Xml.Conduit -import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml +import Control.Applicative +import Data.ByteString.Internal +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.RankSelect.Poppy512 +import HaskellWorks.Data.Xml.Conduit +import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml + +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS newtype XmlInterestBits a = XmlInterestBits a diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs --- a/src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs @@ -9,26 +9,27 @@ , xmlCursorPos ) where +import Data.ByteString.Internal as BSI +import Data.String +import Data.Word +import Foreign.ForeignPtr +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.FromForeignRegion +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.RankSelect.Base.Select1 +import HaskellWorks.Data.RankSelect.Poppy512 +import HaskellWorks.Data.TreeCursor +import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml +import HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits + import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC -import Data.ByteString.Internal as BSI -import Data.String import qualified Data.Vector.Storable as DVS -import Data.Word -import Foreign.ForeignPtr import qualified HaskellWorks.Data.BalancedParens as BP -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.FromForeignRegion -import HaskellWorks.Data.Positioning -import HaskellWorks.Data.RankSelect.Base.Rank0 -import HaskellWorks.Data.RankSelect.Base.Rank1 -import HaskellWorks.Data.RankSelect.Base.Select1 -import HaskellWorks.Data.RankSelect.Poppy512 -import HaskellWorks.Data.TreeCursor import qualified HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParens as CBP -import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml -import HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits data XmlCursor t v w = XmlCursor { cursorText :: !t diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/Token.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Token.hs --- a/src/HaskellWorks/Data/Xml/Succinct/Cursor/Token.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Token.hs @@ -3,16 +3,17 @@ ( xmlTokenAt ) where -import qualified Data.Attoparsec.ByteString.Char8 as ABC -import Data.ByteString.Internal as BSI -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Drop -import HaskellWorks.Data.Positioning -import HaskellWorks.Data.RankSelect.Base.Rank1 -import HaskellWorks.Data.RankSelect.Base.Select1 -import HaskellWorks.Data.Xml.Succinct.Cursor.Internal -import HaskellWorks.Data.Xml.Token.Tokenize -import Prelude hiding (drop) +import Data.ByteString.Internal as BSI +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Drop +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.RankSelect.Base.Select1 +import HaskellWorks.Data.Xml.Succinct.Cursor.Internal +import HaskellWorks.Data.Xml.Token.Tokenize +import Prelude hiding (drop) + +import qualified Data.Attoparsec.ByteString.Char8 as ABC xmlTokenAt :: (Rank1 w, Select1 v, TestBit w) => XmlCursor ByteString v w -> Maybe (XmlToken String Double) xmlTokenAt k = if balancedParens k .?. lastPositionOf (cursorRank k) diff --git a/src/HaskellWorks/Data/Xml/Succinct/Index.hs b/src/HaskellWorks/Data/Xml/Succinct/Index.hs --- a/src/HaskellWorks/Data/Xml/Succinct/Index.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Index.hs @@ -10,25 +10,26 @@ ) where -import Control.Arrow -import qualified Data.Attoparsec.ByteString.Char8 as ABC -import qualified Data.ByteString as BS -import qualified Data.List as L -import Data.Monoid -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Drop -import HaskellWorks.Data.Positioning -import qualified HaskellWorks.Data.BalancedParens as BP -import HaskellWorks.Data.RankSelect.Base.Rank0 -import HaskellWorks.Data.RankSelect.Base.Rank1 -import HaskellWorks.Data.RankSelect.Base.Select1 -import HaskellWorks.Data.TreeCursor -import HaskellWorks.Data.Uncons -import HaskellWorks.Data.Xml.CharLike -import HaskellWorks.Data.Xml.Grammar -import HaskellWorks.Data.Xml.Succinct -import Prelude hiding (drop) +import Control.Arrow +import Data.Monoid +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Drop +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.RankSelect.Base.Select1 +import HaskellWorks.Data.TreeCursor +import HaskellWorks.Data.Uncons +import HaskellWorks.Data.Xml.CharLike +import HaskellWorks.Data.Xml.Grammar +import HaskellWorks.Data.Xml.Succinct +import Prelude hiding (drop) +import qualified Data.Attoparsec.ByteString.Char8 as ABC +import qualified Data.ByteString as BS +import qualified Data.List as L +import qualified HaskellWorks.Data.BalancedParens as BP + data XmlIndex = XmlIndexDocument [XmlIndex] | XmlIndexElement String [XmlIndex] @@ -42,6 +43,12 @@ | XmlIndexError String deriving (Eq, Show) +data XmlIndexState + = InAttrList + | InElement + | Unknown + deriving (Eq, Show) + class XmlIndexAt a where xmlIndexAt :: a -> XmlIndex @@ -53,30 +60,36 @@ instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => XmlIndexAt (XmlCursor BS.ByteString v w) where xmlIndexAt :: XmlCursor BS.ByteString v w -> XmlIndex - xmlIndexAt k = case uncons remainder of - Just (!c, cs) | isElementStart c -> parseElem cs - Just (!c, _ ) | isSpace c -> XmlIndexAttrList $ mapValuesFrom (firstChild k) - Just (!c, _ ) | isAttribute && isQuote c -> XmlIndexAttrValue remainder - Just _ | isAttribute -> XmlIndexAttrName remainder - Just _ -> XmlIndexValue remainder - Nothing -> XmlIndexError "End of data" - where remainder = remText k - mapValuesFrom = L.unfoldr (fmap (xmlIndexAt &&& nextSibling)) - isAttribute = case remText <$> parent k >>= uncons of - Just (!c, _) | isSpace c -> True - _ -> False + xmlIndexAt = getIndexAt Unknown - parseElem bs = - case ABC.parse parseXmlElement bs of - ABC.Fail {} -> decodeErr "Unable to parse element name" bs - ABC.Partial _ -> decodeErr "Unexpected end of string" bs - ABC.Done i r -> case r of - XmlElementTypeCData -> XmlIndexCData i - XmlElementTypeComment -> XmlIndexComment i - XmlElementTypeMeta s -> XmlIndexMeta s (mapValuesFrom $ firstChild k) - XmlElementTypeElement s -> XmlIndexElement s (mapValuesFrom $ firstChild k) - XmlElementTypeDocument -> XmlIndexDocument (mapValuesFrom (firstChild k) <> mapValuesFrom (nextSibling k)) +getIndexAt :: (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => XmlIndexState -> XmlCursor BS.ByteString v w -> XmlIndex +getIndexAt state k = case uncons remainder of + Just (!c, cs) | isElementStart c -> parseElem cs + Just (!c, _ ) | isSpace c -> XmlIndexAttrList $ mapValuesFrom InAttrList (firstChild k) + Just (!c, _ ) | isAttribute && isQuote c -> XmlIndexAttrValue remainder + Just _ | isAttribute -> XmlIndexAttrName remainder + Just _ -> XmlIndexValue remainder + Nothing -> XmlIndexError "End of data" + where remainder = remText k + mapValuesFrom s = L.unfoldr (fmap (getIndexAt s &&& nextSibling)) + isAttribute = case state of + InAttrList -> True + InElement -> False + Unknown -> case remText <$> parent k >>= uncons of + Just (!c, _) | isSpace c -> True + _ -> False + + parseElem bs = + case ABC.parse parseXmlElement bs of + ABC.Fail {} -> decodeErr "Unable to parse element name" bs + ABC.Partial _ -> decodeErr "Unexpected end of string" bs + ABC.Done i r -> case r of + XmlElementTypeCData -> XmlIndexCData i + XmlElementTypeComment -> XmlIndexComment i + XmlElementTypeMeta s -> XmlIndexMeta s (mapValuesFrom InElement $ firstChild k) + XmlElementTypeElement s -> XmlIndexElement s (mapValuesFrom InElement $ firstChild k) + XmlElementTypeDocument -> XmlIndexDocument (mapValuesFrom InElement (firstChild k) <> mapValuesFrom InElement (nextSibling k)) decodeErr :: String -> BS.ByteString -> XmlIndex decodeErr reason bs = diff --git a/src/HaskellWorks/Data/Xml/Token.hs b/src/HaskellWorks/Data/Xml/Token.hs --- a/src/HaskellWorks/Data/Xml/Token.hs +++ b/src/HaskellWorks/Data/Xml/Token.hs @@ -2,5 +2,5 @@ ( module X ) where -import HaskellWorks.Data.Xml.Token.Types as X -import HaskellWorks.Data.Xml.Token.Tokenize as X +import HaskellWorks.Data.Xml.Token.Types as X +import HaskellWorks.Data.Xml.Token.Tokenize as X diff --git a/src/HaskellWorks/Data/Xml/Token/Tokenize.hs b/src/HaskellWorks/Data/Xml/Token/Tokenize.hs --- a/src/HaskellWorks/Data/Xml/Token/Tokenize.hs +++ b/src/HaskellWorks/Data/Xml/Token/Tokenize.hs @@ -10,18 +10,19 @@ , ParseXml(..) ) where -import Control.Applicative -import qualified Data.Attoparsec.ByteString.Char8 as BC -import qualified Data.Attoparsec.Combinator as AC -import qualified Data.Attoparsec.Types as T -import Data.Bits -import qualified Data.ByteString as BS -import Data.Char -import Data.Word -import Data.Word8 -import HaskellWorks.Data.Char.IsChar -import HaskellWorks.Data.Parser as P -import HaskellWorks.Data.Xml.Token.Types +import Control.Applicative +import Data.Bits +import Data.Char +import Data.Word +import Data.Word8 +import HaskellWorks.Data.Char.IsChar +import HaskellWorks.Data.Parser as P +import HaskellWorks.Data.Xml.Token.Types + +import qualified Data.Attoparsec.ByteString.Char8 as BC +import qualified Data.Attoparsec.Combinator as AC +import qualified Data.Attoparsec.Types as T +import qualified Data.ByteString as BS hexDigitNumeric :: P.Parser t => T.Parser t Int hexDigitNumeric = do diff --git a/src/HaskellWorks/Data/Xml/Type.hs b/src/HaskellWorks/Data/Xml/Type.hs --- a/src/HaskellWorks/Data/Xml/Type.hs +++ b/src/HaskellWorks/Data/Xml/Type.hs @@ -4,19 +4,20 @@ module HaskellWorks.Data.Xml.Type where -import qualified Data.ByteString as BS -import Data.Char -import Data.Word8 as W8 -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.Drop -import qualified HaskellWorks.Data.BalancedParens as BP -import HaskellWorks.Data.Positioning -import HaskellWorks.Data.RankSelect.Base.Rank0 -import HaskellWorks.Data.RankSelect.Base.Rank1 -import HaskellWorks.Data.RankSelect.Base.Select1 -import HaskellWorks.Data.Xml.Succinct -import Prelude hiding (drop) +import Data.Char +import Data.Word8 as W8 +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Drop +import HaskellWorks.Data.Positioning +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.RankSelect.Base.Select1 +import HaskellWorks.Data.Xml.Succinct +import Prelude hiding (drop) +import qualified Data.ByteString as BS +import qualified HaskellWorks.Data.BalancedParens as BP + {-# ANN module ("HLint: Ignore Reduce duplication" :: String) #-} data XmlType @@ -33,7 +34,7 @@ xmlTypeAtPosition p k = case drop (toCount p) (cursorText k) of c:_ | fromIntegral (ord c) == _less -> Just XmlTypeElement c:_ | W8.isSpace $ fromIntegral (ord c) -> Just XmlTypeAttrList - _ -> Just XmlTypeToken + _ -> Just XmlTypeToken xmlTypeAt k = xmlTypeAtPosition p k where p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k))) @@ -44,7 +45,7 @@ xmlTypeAtPosition p k = case BS.uncons (drop (toCount p) (cursorText k)) of Just (c, _) | c == _less -> Just XmlTypeElement Just (c, _) | W8.isSpace c -> Just XmlTypeAttrList - _ -> Just XmlTypeToken + _ -> Just XmlTypeToken xmlTypeAt k = xmlTypeAtPosition p k where p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k))) diff --git a/src/HaskellWorks/Data/Xml/Value.hs b/src/HaskellWorks/Data/Xml/Value.hs --- a/src/HaskellWorks/Data/Xml/Value.hs +++ b/src/HaskellWorks/Data/Xml/Value.hs @@ -3,123 +3,73 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} module HaskellWorks.Data.Xml.Value -( XmlValue(..) -, XmlValueAt(..) -) -where + ( Value(..) + , HasValue(..) + , _XmlDocument + , _XmlText + , _XmlElement + , _XmlCData + , _XmlComment + , _XmlMeta + , _XmlError + ) where -import qualified Data.Attoparsec.ByteString.Char8 as ABC -import qualified Data.ByteString as BS -import Data.Monoid -import Data.List -import HaskellWorks.Data.Xml.Grammar -import HaskellWorks.Data.Xml.Succinct.Index -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) +import Control.Lens +import Data.Monoid ((<>)) +import HaskellWorks.Data.Xml.RawDecode +import HaskellWorks.Data.Xml.RawValue -data XmlValue - = XmlDocument [XmlValue] - | XmlText String - | XmlElement String [XmlValue] - | XmlCData String - | XmlComment String - | XmlMeta String [XmlValue] - | XmlAttrName String - | XmlAttrValue String - | XmlAttrList [XmlValue] - | XmlError String +data Value + = XmlDocument + { _childNodes :: [Value] + } + | XmlText + { _textValue :: String + } + | XmlElement + { _name :: String + , _attributes :: [(String, String)] + , _childNodes :: [Value] + } + | XmlCData + { _cdata :: String + } + | XmlComment + { _comment :: String + } + | XmlMeta + { _name :: String + , _childNodes :: [Value] + } + | XmlError + { _errorMessage :: String + } deriving (Eq, Show) -instance Pretty XmlValue where - pretty mjpv = case mjpv of - XmlText s -> ctext $ text s - XmlAttrName s -> text s - XmlAttrValue s -> (ctext . dquotes . text) s - XmlAttrList ats -> formatAttrs ats - XmlComment s -> text $ "" - XmlElement s xs -> formatElem s xs - XmlDocument xs -> formatMeta "?" "xml" xs - XmlError s -> red $ text "[error " <> text s <> text "]" - XmlCData s -> cangle " ctag (text "[CDATA[") <> text s <> cangle (text "]]>") - XmlMeta s xs -> formatMeta "!" s xs - where - formatAttr at = case at of - XmlAttrName a -> text " " <> pretty (XmlAttrName a) - XmlAttrValue a -> text "=" <> pretty (XmlAttrValue a) - XmlAttrList _ -> red $ text "ATTRS" - _ -> red $ text "booo" - formatAttrs ats = hcat (formatAttr <$> ats) - formatElem s xs = - let (ats, es) = partition isAttrL xs - in cangle langle <> ctag (text s) - <> hcat (pretty <$> ats) - <> cangle rangle - <> hcat (pretty <$> es) - <> cangle (text " ctag (text s) <> cangle rangle - formatMeta b s xs = - let (ats, es) = partition isAttr xs - in cangle (langle <> text b) <> ctag (text s) - <> hcat (pretty <$> ats) - <> cangle rangle - <> hcat (pretty <$> es) - -class XmlValueAt a where - xmlValueAt :: a -> XmlValue - -instance XmlValueAt XmlIndex where - xmlValueAt i = case i of - XmlIndexCData s -> parseTextUntil "]]>" s `as` XmlCData - XmlIndexComment s -> parseTextUntil "-->" s `as` XmlComment - XmlIndexMeta s cs -> XmlMeta s (xmlValueAt <$> cs) - XmlIndexElement s cs -> XmlElement s (xmlValueAt <$> cs) - XmlIndexDocument cs -> XmlDocument (xmlValueAt <$> cs) - XmlIndexAttrName cs -> parseAttrName cs `as` XmlAttrName - XmlIndexAttrValue cs -> parseString cs `as` XmlAttrValue - XmlIndexAttrList cs -> XmlAttrList (xmlValueAt <$> cs) - XmlIndexValue s -> parseTextUntil "<" s `as` XmlText - XmlIndexError s -> XmlError s - --unknown -> XmlError ("Not yet supported: " <> show unknown) - where - parseUntil s = ABC.manyTill ABC.anyChar (ABC.string s) - - parseTextUntil s bs = case ABC.parse (parseUntil s) bs of - ABC.Fail {} -> decodeErr ("Unable to find " <> show s <> ".") bs - ABC.Partial _ -> decodeErr ("Unexpected end, expected " <> show s <> ".") bs - ABC.Done _ r -> Right r - parseString bs = case ABC.parse parseXmlString bs of - ABC.Fail {} -> decodeErr "Unable to parse string" bs - ABC.Partial _ -> decodeErr "Unexpected end of string, expected" bs - ABC.Done _ r -> Right r - parseAttrName bs = case ABC.parse parseXmlAttributeName bs of - ABC.Fail {} -> decodeErr "Unable to parse attribute name" bs - ABC.Partial _ -> decodeErr "Unexpected end of attr name, expected" bs - ABC.Done _ r -> Right r - -cangle :: Doc -> Doc -cangle = dullwhite - -ctag :: Doc -> Doc -ctag = bold - -ctext :: Doc -> Doc -ctext = dullgreen - -isAttrL :: XmlValue -> Bool -isAttrL (XmlAttrList _) = True -isAttrL _ = False +makeClassy ''Value +makePrisms ''Value -isAttr :: XmlValue -> Bool -isAttr v = case v of - XmlAttrName _ -> True - XmlAttrValue _ -> True - XmlAttrList _ -> True - _ -> False +instance RawDecode Value where + rawDecode (RawDocument rvs ) = XmlDocument (rawDecode <$> rvs) + rawDecode (RawText text ) = XmlText text + rawDecode (RawElement n cs ) = mkXmlElement n cs + rawDecode (RawCData text ) = XmlCData text + rawDecode (RawComment text ) = XmlComment text + rawDecode (RawMeta n cs ) = XmlMeta n (rawDecode <$> cs) + rawDecode (RawAttrName nameValue ) = XmlError ("Can't decode attribute name: " <> nameValue) + rawDecode (RawAttrValue attrValue ) = XmlError ("Can't decode attribute value: " <> attrValue) + rawDecode (RawAttrList as ) = XmlError ("Can't decode attribute list: " <> show as) + rawDecode (RawError msg ) = XmlError msg -as :: Either String a -> (a -> XmlValue) -> XmlValue -as = flip $ either XmlError +mkXmlElement :: String -> [RawValue] -> Value +mkXmlElement n (RawAttrList as:cs) = XmlElement n (mkAttrs as) (rawDecode <$> cs) +mkXmlElement n cs = XmlElement n [] (rawDecode <$> cs) -decodeErr :: String -> BS.ByteString -> Either String a -decodeErr reason bs = - Left $ reason <>" (" <> show (BS.take 20 bs) <> "...)" +mkAttrs :: [RawValue] -> [(String, String)] +mkAttrs (RawAttrName n:RawAttrValue v:cs) = (n, v):mkAttrs cs +mkAttrs (_:cs) = mkAttrs cs +mkAttrs [] = [] diff --git a/test/HaskellWorks/Data/Xml/Conduit/BlankSpec.hs b/test/HaskellWorks/Data/Xml/Conduit/BlankSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Xml/Conduit/BlankSpec.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Xml.Conduit.BlankSpec (spec) where + +import Data.Char +import Data.Monoid +import HaskellWorks.Data.ByteString +import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.Xml.Conduit.Blank +import Test.Hspec +import Test.QuickCheck + +import qualified Data.ByteString as BS + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +whenBlankedXmlShouldBe :: BS.ByteString -> BS.ByteString -> Spec +whenBlankedXmlShouldBe original expected = do + it (show original <> " when blanked xml should be " <> show expected) $ do + BS.concat (runListConduit blankXml [original]) `shouldBe` expected + +repeatBS :: Int -> BS.ByteString -> BS.ByteString +repeatBS n bs | n > 0 = bs <> repeatBS (n - 1) bs +repeatBS _ _ = BS.empty + +noSpaces :: BS.ByteString -> BS.ByteString +noSpaces = BS.filter (/= fromIntegral (ord ' ')) + +data Annotated a b = Annotated a b deriving Show + +instance Eq a => Eq (Annotated a b) where + (Annotated a _) == (Annotated b _) = a == b + +spec :: Spec +spec = describe "HaskellWorks.Data.Xml.Conduit.BlankSpec" $ do + describe "Can blank XML" $ do + "" `whenBlankedXmlShouldBe` "< >" + "" `whenBlankedXmlShouldBe` "< >" + "text" `whenBlankedXmlShouldBe` "< t >" + " text " `whenBlankedXmlShouldBe` "< t >" + "" `whenBlankedXmlShouldBe` "< ()>" + "" `whenBlankedXmlShouldBe` "< (a v )>" + "" `whenBlankedXmlShouldBe` "< (a v )>" + "" `whenBlankedXmlShouldBe` "< (a v )>" + "" `whenBlankedXmlShouldBe` "< (a v a v )>" + "text" `whenBlankedXmlShouldBe` "< (a v a v )t >" + "" `whenBlankedXmlShouldBe` "< (a v a v )>" + "" `whenBlankedXmlShouldBe` "< (a v )< > >" + "test" `whenBlankedXmlShouldBe` "< (a v )< t > >" + " text bold " `whenBlankedXmlShouldBe` "< t < t > >" + " text bold uuu" `whenBlankedXmlShouldBe` "< t < t > t >" + "" `whenBlankedXmlShouldBe` "< (a v )>" + " " `whenBlankedXmlShouldBe` "< [ ] >" + " " `whenBlankedXmlShouldBe` "< [ ] >" + + " " `whenBlankedXmlShouldBe` "< [ ] >" + "" `whenBlankedXmlShouldBe` "< (a v a v )>" + + "]>" `whenBlankedXmlShouldBe` "[ [ ] ]" + + "Hello,\ + \ world!]]>" `whenBlankedXmlShouldBe` "< [ ] >" + + "" `whenBlankedXmlShouldBe` "< [ ] >" + "00" `whenBlankedXmlShouldBe` "< < t >< > >" + "0" `whenBlankedXmlShouldBe` "< < t >< > >" + + it "Can blank across chunk boundaries with basic tags" $ do + let inputOriginalPrefix = "\n\n " + let inputOriginalSuffix = "\n \n \n \n \n \n\n" + let inputOriginal = inputOriginalPrefix <> inputOriginalSuffix + let inputOriginalChunked = chunkedBy 16 inputOriginal + let inputOriginalBlanked = runListConduit blankXml inputOriginalChunked + + forAll (choose (0, 16)) $ \(n :: Int) -> do + let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix + let inputShiftedChunked = chunkedBy 16 inputShifted + let inputShiftedBlanked = runListConduit blankXml inputShiftedChunked + + noSpaces (BS.concat inputShiftedBlanked) `shouldBe` noSpaces (BS.concat inputOriginalBlanked) + it "Can blank across chunk boundaries with auto-close tags" $ do + let inputOriginalPrefix = "" + let inputOriginalSuffix = "\n" + let inputOriginal = inputOriginalPrefix <> inputOriginalSuffix + let inputOriginalChunked = chunkedBy 16 inputOriginal + let inputOriginalBlanked = runListConduit blankXml inputOriginalChunked + + forAll (choose (0, 16)) $ \(n :: Int) -> do + let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix + let inputShiftedChunked = chunkedBy 16 inputShifted + let inputShiftedBlanked = runListConduit blankXml inputShiftedChunked + + -- putStrLn $ show (BS.concat inputShiftedBlanked) <> " vs " <> show (BS.concat inputOriginalBlanked) + let actual = Annotated (noSpaces (BS.concat inputShiftedBlanked )) (inputShiftedBlanked, n) + let expected = Annotated (noSpaces (BS.concat inputOriginalBlanked)) (inputOriginalBlanked, n) + + actual `shouldBe` expected + it "Can blank across chunk boundaries with auto-close tags" $ do + let inputOriginalPrefix = "" + let inputOriginalSuffix = "\n" + let inputOriginal = inputOriginalPrefix <> inputOriginalSuffix + let inputOriginalChunked = chunkedBy 16 inputOriginal + let inputOriginalBlanked = runListConduit blankXml inputOriginalChunked + + let n = 15 + let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix + let inputShiftedChunked = chunkedBy 16 inputShifted + let inputShiftedBlanked = runListConduit blankXml inputShiftedChunked + + -- putStrLn $ show (BS.concat inputShiftedBlanked) <> " vs " <> show (BS.concat inputOriginalBlanked) + let actual = Annotated (noSpaces (BS.concat inputShiftedBlanked )) (inputShiftedBlanked, n) + let expected = Annotated (noSpaces (BS.concat inputOriginalBlanked)) (inputOriginalBlanked, n) + + actual `shouldBe` expected diff --git a/test/HaskellWorks/Data/Xml/RawValueSpec.hs b/test/HaskellWorks/Data/Xml/RawValueSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Xml/RawValueSpec.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module HaskellWorks.Data.Xml.RawValueSpec (spec) where + +import Control.Monad +import Data.Monoid +import Data.String +import Data.Word +import HaskellWorks.Data.BalancedParens.BalancedParens +import HaskellWorks.Data.BalancedParens.Simple +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.FromForeignRegion +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.RankSelect.Base.Select1 +import HaskellWorks.Data.RankSelect.Poppy512 +import HaskellWorks.Data.Xml.Succinct.Cursor as C +import HaskellWorks.Data.Xml.Succinct.Index +import HaskellWorks.Data.Xml.RawValue +import Test.Hspec + +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.TreeCursor as TC + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +--{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} + +fc = TC.firstChild +ns = TC.nextSibling +-- cd = TC.depth + +attrs :: [(String, String)] -> RawValue +attrs as = RawAttrList $ as >>= (\(k, v) -> [RawAttrName k, RawAttrValue v]) + +spec :: Spec +spec = describe "HaskellWorks.Data.Xml.ValueSpec" $ do + genSpec "DVS.Vector Word8" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) + genSpec "DVS.Vector Word16" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) + genSpec "DVS.Vector Word32" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) + genSpec "DVS.Vector Word64" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + genSpec "Poppy512" (undefined :: XmlCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) + +rawValueVia :: XmlIndexAt (XmlCursor BS.ByteString t u) + => Maybe (XmlCursor BS.ByteString t u) -> RawValue +rawValueVia mk = case mk of + Just k -> rawValueAt (xmlIndexAt k) --either (\(DecodeError e) -> XmlError e) id (rawValueAt <$> xmlIndexAt k) + Nothing -> RawError "No such element" + +genSpec :: forall t u. + ( Eq t + , Show t + , Select1 t + , Eq u + , Show u + , Rank0 u + , Rank1 u + , BalancedParens u + , TestBit u + , FromForeignRegion (XmlCursor BS.ByteString t u) + , IsString (XmlCursor BS.ByteString t u) + , XmlIndexAt (XmlCursor BS.ByteString t u) + ) + => String -> XmlCursor BS.ByteString t u -> SpecWith () +genSpec t _ = do + describe ("XML cursor of type " <> t) $ do + let forXml (cursor :: XmlCursor BS.ByteString t u) f = describe ("of value " <> show cursor) (f cursor) + + forXml "" $ \cursor -> do + it "should have correct value" $ rawValueVia (Just cursor) `shouldBe` RawElement "a" [] + + forXml "" $ \cursor -> do + it "should have correct value" $ rawValueVia (Just cursor) `shouldBe` + RawElement "a" [attrs [("attr", "value")]] + + forXml "" $ \cursor -> do + it "should have correct value" $ rawValueVia (Just cursor) `shouldBe` + RawElement "a" [attrs [("attr", "value")], + RawElement "b" [attrs [("attr", "value")]]] + + forXml "value text" $ \cursor -> do + it "should have correct value" $ rawValueVia (Just cursor) `shouldBe` + RawElement "a" [RawText "value text"] + + forXml "" $ \cursor -> do + it "should parse space separared comment" $ rawValueVia (Just cursor) `shouldBe` + RawComment " some comment " + + forXml "" $ \cursor -> do + it "should parse space separared comment" $ rawValueVia (Just cursor) `shouldBe` + RawComment "some comment ->" + + forXml " tag]]>" $ \cursor -> do + it "should parse cdata data" $ rawValueVia (Just cursor) `shouldBe` + RawCData "a
tag" + + forXml "]>" $ \cursor -> do + it "should parse metas" $ rawValueVia (Just cursor) `shouldBe` + RawMeta "DOCTYPE" [RawMeta "ELEMENT" []] + + forXml "free" $ \cursor -> do + it "should parse xml header" $ rawValueVia (Just cursor) `shouldBe` + RawDocument [ + attrs [("version", "1.0"), ("encoding", "UTF-8")], + RawElement "a" [attrs [("text", "value")], + RawText "free"]] + + it "navigate around" $ do + rawValueVia (ns cursor) `shouldBe` RawElement "a" [attrs [("text", "value")], RawText "free"] + rawValueVia ((ns >=> fc) cursor) `shouldBe` attrs [("text", "value")] + rawValueVia ((ns >=> fc >=> fc) cursor) `shouldBe` RawAttrName "text" + rawValueVia ((ns >=> fc >=> fc >=> ns) cursor) `shouldBe` RawAttrValue "value" + rawValueVia ((ns >=> fc >=> ns) cursor) `shouldBe` RawText "free" diff --git a/test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs b/test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec(spec) where + +import Data.Conduit +import Data.Monoid ((<>)) +import Data.String +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.ByteString +import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.Xml.Conduit +import HaskellWorks.Data.Xml.Conduit.Blank +import HaskellWorks.Data.Xml.Conduit.Blank +import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml +import Test.Hspec + +import qualified Data.ByteString as BS + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec" $ do + it "Blanking XML should work 1" $ do + let blankedXml = BlankedXml [">"] + let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml blankedXml)) + bp `shouldBe` fromString "11011000" + it "Blanking XML should work 2" $ do + let blankedXml = BlankedXml + [ "<><><><><><><><>" + , "<><><><><><><><>" + ] + let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml blankedXml)) + bp `shouldBe` fromString + "1010101010101010\ + \1010101010101010" + + let unchunkedInput = "\n\n \n \n \n \n \n \n\n" + let chunkedInput = chunkedBy 15 unchunkedInput + let chunkedBlank = runListConduit blankXml chunkedInput + + let unchunkedBadInput = "\n\n \n \n \n \n \n \n\n" + let chunkedBadInput = chunkedBy 15 unchunkedBadInput + let chunkedBadBlank = runListConduit blankXml chunkedBadInput + + it "Same input" $ do + unchunkedInput `shouldBe` BS.concat chunkedInput + + it "Blanking XML should work 3" $ do + let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) chunkedBlank) + putStrLn $ "Good: " <> show chunkedBlank + bp `shouldBe` fromString "11101010 10001101 01010100" + + it "Blanking XML should work 3" $ do + let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) chunkedBadBlank) + putStrLn $ "Bad: " <> show chunkedBadBlank + bp `shouldBe` fromString "11101010 10001101 01010100" + + describe "Chunking works" $ do + let document = "free" + let whole = mkBlank 4096 document + let chunked = mkBlank 15 document + + it "should BP the same with chanks" $ do + BS.concat chunked `shouldBe` BS.concat whole + + it "should produce same bits" $ do + BS.concat (mkBits chunked) `shouldBe` BS.concat (mkBits whole) + + +mkBlank :: Int -> BS.ByteString -> [BS.ByteString] +mkBlank csize bs = runListConduit blankXml (chunkedBy csize bs) + +mkBits :: [BS.ByteString] -> [BS.ByteString] +mkBits = runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) diff --git a/test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs b/test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs --- a/test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs +++ b/test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs @@ -1,19 +1,21 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} - module HaskellWorks.Data.Xml.Succinct.Cursor.InterestBitsSpec(spec) where -import qualified Data.ByteString as BS -import Data.String -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml -import HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits -import Test.Hspec +import Data.Monoid ((<>)) +import Data.String +import Data.Word +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Conduit.List +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml +import HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits +import Test.Hspec +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS + {-# ANN module ("HLint: ignore Redundant do" :: String) #-} interestBitsOf :: FromBlankedXml (XmlInterestBits a) => BS.ByteString -> a @@ -31,3 +33,23 @@ (interestBitsOf " " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "01011010 00000000" (interestBitsOf " " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "01000000 00000000" (interestBitsOf " " + , "< < " + , "> >" + ] + putStrLn $ "Blanked: " <> show blanked + let ib :: XmlInterestBits (BitShown (DVS.Vector Word8)) + ib = XmlInterestBits (getXmlInterestBits (fromBlankedXml (BlankedXml blanked))) + let moo :: [BS.ByteString] + moo = runListConduit blankedXmlToInterestBits blanked -- :: XmlInterestBits (BitShown (DVS.Vector Word8)) + putStrLn $ "Moo: " <> show (BitShown . BS.unpack <$> moo) + let actual = getXmlInterestBits ib :: BitShown (DVS.Vector Word8) + let expected = fromString "10000110 00000010 00001000 00000100 00000001 00100000 00000000" + + actual `shouldBe` expected diff --git a/test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs b/test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs --- a/test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs +++ b/test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs @@ -11,38 +11,37 @@ module HaskellWorks.Data.Xml.Succinct.CursorSpec(spec) where -import Control.Monad --- import qualified Data.ByteString as BS --- import qualified Data.Map as M --- import Data.String --- import qualified Data.Vector.Storable as DVS --- import Data.Word --- import HaskellWorks.Data.Bits.BitShow -import HaskellWorks.Data.Bits.BitShown --- import HaskellWorks.Data.Bits.BitWise --- import HaskellWorks.Data.FromForeignRegion --- import HaskellWorks.Data.BalancedParens.BalancedParens -import HaskellWorks.Data.BalancedParens.Simple --- import HaskellWorks.Data.RankSelect.Base.Rank0 --- import HaskellWorks.Data.RankSelect.Base.Rank1 --- import HaskellWorks.Data.RankSelect.Base.Select1 --- import HaskellWorks.Data.RankSelect.Poppy512 -import qualified HaskellWorks.Data.TreeCursor as TC -import HaskellWorks.Data.Xml.Succinct.Cursor as C ---import HaskellWorks.Data.Xml.Succinct.Index ---import HaskellWorks.Data.Xml.Token ---import HaskellWorks.Data.Xml.Value ---import System.IO.MMap -import Test.Hspec +import Control.Monad +import Data.String +import Data.Word +import HaskellWorks.Data.BalancedParens.BalancedParens +import HaskellWorks.Data.BalancedParens.Simple +import HaskellWorks.Data.Bits.BitShow +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.FromForeignRegion +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.RankSelect.Base.Select1 +import HaskellWorks.Data.RankSelect.Poppy512 +import HaskellWorks.Data.Xml.Succinct.Cursor as C +import HaskellWorks.Data.Xml.Succinct.Index +import HaskellWorks.Data.Xml.Token +import Test.Hspec +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.TreeCursor as TC + {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} fc = TC.firstChild ns = TC.nextSibling --- pn = TC.parent +pn = TC.parent cd = TC.depth --- ss = TC.subtreeSize +ss = TC.subtreeSize spec :: Spec spec = describe "HaskellWorks.Data.Xml.Succinct.CursorSpec" $ do @@ -62,103 +61,103 @@ it "depth at value" $ do let cursor = "text" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) (fc >=> ns >=> cd) cursor `shouldBe` Just 2 - -- it "depth at first child of object at second child of array" $ do - -- let cursor = "[null, {\"field\": 1}]" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - -- (fc >=> ns >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3 --- genSpec "DVS.Vector Word8" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) --- genSpec "DVS.Vector Word16" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) --- genSpec "DVS.Vector Word32" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) --- genSpec "DVS.Vector Word64" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) --- genSpec "Poppy512" (undefined :: XmlCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) --- it "Loads same Xml consistentally from different backing vectors" $ do --- let cursor8 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8)) --- let cursor16 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16)) --- let cursor32 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32)) --- let cursor64 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) --- cursorText cursor8 `shouldBe` cursorText cursor16 --- cursorText cursor8 `shouldBe` cursorText cursor32 --- cursorText cursor8 `shouldBe` cursorText cursor64 --- let ic8 = bitShow $ interests cursor8 --- let ic16 = bitShow $ interests cursor16 --- let ic32 = bitShow $ interests cursor32 --- let ic64 = bitShow $ interests cursor64 --- ic16 `shouldBeginWith` ic8 --- ic32 `shouldBeginWith` ic16 --- ic64 `shouldBeginWith` ic32 + xit "depth at first child of object at second child of array" $ do + let cursor = "[null, {\"field\": 1}]" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + (fc >=> ns >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3 + genSpec "DVS.Vector Word8" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) + genSpec "DVS.Vector Word16" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) + genSpec "DVS.Vector Word32" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) + genSpec "DVS.Vector Word64" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + genSpec "Poppy512" (undefined :: XmlCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) + it "Loads same Xml consistentally from different backing vectors" $ do + let cursor8 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8)) + let cursor16 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16)) + let cursor32 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32)) + let cursor64 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + cursorText cursor8 `shouldBe` cursorText cursor16 + cursorText cursor8 `shouldBe` cursorText cursor32 + cursorText cursor8 `shouldBe` cursorText cursor64 + let ic8 = bitShow $ interests cursor8 + let ic16 = bitShow $ interests cursor16 + let ic32 = bitShow $ interests cursor32 + let ic64 = bitShow $ interests cursor64 + ic16 `shouldBeginWith` ic8 + ic32 `shouldBeginWith` ic16 + ic64 `shouldBeginWith` ic32 --- shouldBeginWith :: (Eq a, Show a) => [a] -> [a] -> IO () --- shouldBeginWith as bs = take (length bs) as `shouldBe` bs +shouldBeginWith :: (Eq a, Show a) => [a] -> [a] -> IO () +shouldBeginWith as bs = take (length bs) as `shouldBe` bs --- genSpec :: forall t u. --- ( Eq t --- , Show t --- , Select1 t --- , Eq u --- , Show u --- , Rank0 u --- , Rank1 u --- , BalancedParens u --- , TestBit u --- , FromForeignRegion (XmlCursor BS.ByteString t u) --- , IsString (XmlCursor BS.ByteString t u) --- , XmlIndexAt (XmlCursor BS.ByteString t u) --- ) --- => String -> (XmlCursor BS.ByteString t u) -> SpecWith () --- genSpec t _ = do --- describe ("Cursor for (" ++ t ++ ")") $ do --- let forXml (cursor :: XmlCursor BS.ByteString t u) f = describe ("of value " ++ show cursor) (f cursor) --- forXml "[null]" $ \cursor -> do --- it "depth at top" $ cd cursor `shouldBe` Just 1 --- it "depth at first child of array" $ (fc >=> cd) cursor `shouldBe` Just 2 --- forXml "[null, {\"field\": 1}]" $ \cursor -> do --- it "depth at second child of array" $ do --- (fc >=> ns >=> cd) cursor `shouldBe` Just 2 --- it "depth at first child of object at second child of array" $ do --- (fc >=> ns >=> fc >=> cd) cursor `shouldBe` Just 3 --- it "depth at first child of object at second child of array" $ do --- (fc >=> ns >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3 +genSpec :: forall t u. + ( Eq t + , Show t + , Select1 t + , Eq u + , Show u + , Rank0 u + , Rank1 u + , BalancedParens u + , TestBit u + , FromForeignRegion (XmlCursor BS.ByteString t u) + , IsString (XmlCursor BS.ByteString t u) + , XmlIndexAt (XmlCursor BS.ByteString t u) + ) + => String -> XmlCursor BS.ByteString t u -> SpecWith () +genSpec t _ = do + describe ("Cursor for (" ++ t ++ ")") $ do + let forXml (cursor :: XmlCursor BS.ByteString t u) f = describe ("of value " ++ show cursor) (f cursor) + forXml "[null]" $ \cursor -> do + it "depth at top" $ cd cursor `shouldBe` Just 1 + xit "depth at first child of array" $ (fc >=> cd) cursor `shouldBe` Just 2 + forXml "[null, {\"field\": 1}]" $ \cursor -> do + xit "depth at second child of array" $ do + (fc >=> ns >=> cd) cursor `shouldBe` Just 2 + xit "depth at first child of object at second child of array" $ do + (fc >=> ns >=> fc >=> cd) cursor `shouldBe` Just 3 + xit "depth at first child of object at second child of array" $ do + (fc >=> ns >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3 --- describe "For sample Json" $ do --- let cursor = " \ --- \ \ --- \ 500 \ --- \ 600.01e-02 \ --- \ false \ --- \ \ --- \" :: XmlCursor BS.ByteString t u --- it "can get token at cursor" $ do --- (xmlTokenAt ) cursor `shouldBe` Just (XmlTokenBraceL ) --- (fc >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "widget" ) --- (fc >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenBraceL ) --- (fc >=> ns >=> fc >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "debug" ) --- (fc >=> ns >=> fc >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "on" ) --- (fc >=> ns >=> fc >=> ns >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "window" ) --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenBraceL ) --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "name" ) --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "main_window" ) --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "dimensions" ) --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenBracketL ) --- it "can navigate up" $ do --- ( pn) cursor `shouldBe` Nothing --- (fc >=> pn) cursor `shouldBe` Just cursor --- (fc >=> ns >=> pn) cursor `shouldBe` Just cursor --- (fc >=> ns >=> fc >=> pn) cursor `shouldBe` (fc >=> ns ) cursor --- (fc >=> ns >=> fc >=> ns >=> pn) cursor `shouldBe` (fc >=> ns ) cursor --- (fc >=> ns >=> fc >=> ns >=> ns >=> pn) cursor `shouldBe` (fc >=> ns ) cursor --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor `shouldBe` (fc >=> ns ) cursor --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor --- it "can get subtree size" $ do --- ( ss) cursor `shouldBe` Just 16 --- (fc >=> ss) cursor `shouldBe` Just 1 --- (fc >=> ns >=> ss) cursor `shouldBe` Just 14 --- (fc >=> ns >=> fc >=> ss) cursor `shouldBe` Just 1 --- (fc >=> ns >=> fc >=> ns >=> ss) cursor `shouldBe` Just 1 --- (fc >=> ns >=> fc >=> ns >=> ns >=> ss) cursor `shouldBe` Just 1 --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> ss) cursor `shouldBe` Just 10 --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ss) cursor `shouldBe` Just 1 --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ss) cursor `shouldBe` Just 1 --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ss) cursor `shouldBe` Just 1 --- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> ss) cursor `shouldBe` Just 6 + describe "For sample XML" $ do + let cursor = " \ + \ \ + \ 500 \ + \ 600.01e-02 \ + \ false \ + \ \ + \" :: XmlCursor BS.ByteString t u + xit "can get token at cursor" $ do + (xmlTokenAt ) cursor `shouldBe` Just (XmlTokenBraceL ) + (fc >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "widget" ) + (fc >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenBraceL ) + (fc >=> ns >=> fc >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "debug" ) + (fc >=> ns >=> fc >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "on" ) + (fc >=> ns >=> fc >=> ns >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "window" ) + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenBraceL ) + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "name" ) + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "main_window" ) + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString "dimensions" ) + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenBracketL ) + xit "can navigate up" $ do + ( pn) cursor `shouldBe` Nothing + (fc >=> pn) cursor `shouldBe` Just cursor + (fc >=> ns >=> pn) cursor `shouldBe` Just cursor + (fc >=> ns >=> fc >=> pn) cursor `shouldBe` (fc >=> ns ) cursor + (fc >=> ns >=> fc >=> ns >=> pn) cursor `shouldBe` (fc >=> ns ) cursor + (fc >=> ns >=> fc >=> ns >=> ns >=> pn) cursor `shouldBe` (fc >=> ns ) cursor + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor `shouldBe` (fc >=> ns ) cursor + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor + xit "can get subtree size" $ do + ( ss) cursor `shouldBe` Just 16 + (fc >=> ss) cursor `shouldBe` Just 1 + (fc >=> ns >=> ss) cursor `shouldBe` Just 14 + (fc >=> ns >=> fc >=> ss) cursor `shouldBe` Just 1 + (fc >=> ns >=> fc >=> ns >=> ss) cursor `shouldBe` Just 1 + (fc >=> ns >=> fc >=> ns >=> ns >=> ss) cursor `shouldBe` Just 1 + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> ss) cursor `shouldBe` Just 10 + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ss) cursor `shouldBe` Just 1 + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ss) cursor `shouldBe` Just 1 + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ss) cursor `shouldBe` Just 1 + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> ss) cursor `shouldBe` Just 6 diff --git a/test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs b/test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs --- a/test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs +++ b/test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs @@ -2,10 +2,11 @@ module HaskellWorks.Data.Xml.Token.TokenizeSpec (spec) where -import qualified Data.Attoparsec.ByteString.Char8 as BC -import Data.ByteString as BS -import HaskellWorks.Data.Xml.Token.Tokenize -import Test.Hspec +import Data.ByteString as BS +import HaskellWorks.Data.Xml.Token.Tokenize +import Test.Hspec + +import qualified Data.Attoparsec.ByteString.Char8 as BC {-# ANN module ("HLint: ignore Redundant do" :: String) #-} diff --git a/test/HaskellWorks/Data/Xml/TypeSpec.hs b/test/HaskellWorks/Data/Xml/TypeSpec.hs --- a/test/HaskellWorks/Data/Xml/TypeSpec.hs +++ b/test/HaskellWorks/Data/Xml/TypeSpec.hs @@ -11,26 +11,27 @@ module HaskellWorks.Data.Xml.TypeSpec (spec) where -import Control.Monad -import qualified Data.ByteString as BS -import Data.String -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.FromForeignRegion -import HaskellWorks.Data.BalancedParens.BalancedParens -import HaskellWorks.Data.BalancedParens.Simple -import HaskellWorks.Data.RankSelect.Base.Rank0 -import HaskellWorks.Data.RankSelect.Base.Rank1 -import HaskellWorks.Data.RankSelect.Base.Select1 -import HaskellWorks.Data.RankSelect.Poppy512 -import qualified HaskellWorks.Data.TreeCursor as TC -import HaskellWorks.Data.Xml.Succinct.Cursor as C -import HaskellWorks.Data.Xml.Succinct.Index -import HaskellWorks.Data.Xml.Type -import Test.Hspec +import Control.Monad +import Data.String +import Data.Word +import HaskellWorks.Data.BalancedParens.BalancedParens +import HaskellWorks.Data.BalancedParens.Simple +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.FromForeignRegion +import HaskellWorks.Data.RankSelect.Base.Rank0 +import HaskellWorks.Data.RankSelect.Base.Rank1 +import HaskellWorks.Data.RankSelect.Base.Select1 +import HaskellWorks.Data.RankSelect.Poppy512 +import HaskellWorks.Data.Xml.Succinct.Cursor as C +import HaskellWorks.Data.Xml.Succinct.Index +import HaskellWorks.Data.Xml.Type +import Test.Hspec +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.TreeCursor as TC + {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} {-# ANN module ("HLint: redundant bracket" :: String) #-} @@ -39,7 +40,7 @@ ns = TC.nextSibling spec :: Spec -spec = describe "HaskellWorks.Data.Json.Succinct.CursorSpec" $ do +spec = describe "HaskellWorks.Data.Xml.TypeSpec" $ do describe "Cursor for [Bool]" $ do it "initialises to beginning of empty object" $ do let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) @@ -90,7 +91,7 @@ ) => String -> (XmlCursor BS.ByteString t u) -> SpecWith () genSpec t _ = do - describe ("Json cursor of type " ++ t) $ do + describe ("XML cursor of type " ++ t) $ do let forXml (cursor :: XmlCursor BS.ByteString t u) f = describe ("of value " ++ show cursor) (f cursor) forXml "" $ \cursor -> do it "should have correct type" $ xmlTypeAt cursor `shouldBe` Just XmlTypeElement diff --git a/test/HaskellWorks/Data/Xml/ValueSpec.hs b/test/HaskellWorks/Data/Xml/ValueSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Data/Xml/ValueSpec.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} - -module HaskellWorks.Data.Xml.ValueSpec (spec) where - -import Control.Monad -import Data.Monoid -import qualified Data.ByteString as BS -import Data.String -import qualified Data.Vector.Storable as DVS -import Data.Word -import HaskellWorks.Data.Bits.BitShown -import HaskellWorks.Data.Bits.BitWise -import HaskellWorks.Data.FromForeignRegion -import HaskellWorks.Data.Xml.Succinct.Cursor as C -import HaskellWorks.Data.Xml.Succinct.Index -import HaskellWorks.Data.Xml.Value -import HaskellWorks.Data.BalancedParens.BalancedParens -import HaskellWorks.Data.BalancedParens.Simple -import HaskellWorks.Data.RankSelect.Base.Rank0 -import HaskellWorks.Data.RankSelect.Base.Rank1 -import HaskellWorks.Data.RankSelect.Base.Select1 -import HaskellWorks.Data.RankSelect.Poppy512 -import qualified HaskellWorks.Data.TreeCursor as TC -import Test.Hspec - -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} ---{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} - -fc = TC.firstChild -ns = TC.nextSibling --- cd = TC.depth - -attrs :: [(String, String)] -> XmlValue -attrs as = XmlAttrList $ as >>= (\(k, v) -> [XmlAttrName k, XmlAttrValue v]) - -spec :: Spec -spec = describe "HaskellWorks.Data.Xml.ValueSpec" $ do - genSpec "DVS.Vector Word8" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) - genSpec "DVS.Vector Word16" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) - genSpec "DVS.Vector Word32" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) - genSpec "DVS.Vector Word64" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) - genSpec "Poppy512" (undefined :: XmlCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) - -xmlValueVia :: XmlIndexAt (XmlCursor BS.ByteString t u) - => Maybe (XmlCursor BS.ByteString t u) -> XmlValue -xmlValueVia mk = case mk of - Just k -> xmlValueAt (xmlIndexAt k) --either (\(DecodeError e) -> XmlError e) id (xmlValueAt <$> xmlIndexAt k) - Nothing -> XmlError "No such element" - -genSpec :: forall t u. - ( Eq t - , Show t - , Select1 t - , Eq u - , Show u - , Rank0 u - , Rank1 u - , BalancedParens u - , TestBit u - , FromForeignRegion (XmlCursor BS.ByteString t u) - , IsString (XmlCursor BS.ByteString t u) - , XmlIndexAt (XmlCursor BS.ByteString t u) - ) - => String -> XmlCursor BS.ByteString t u -> SpecWith () -genSpec t _ = do - describe ("Json cursor of type " <> t) $ do - let forXml (cursor :: XmlCursor BS.ByteString t u) f = describe ("of value " <> show cursor) (f cursor) - - forXml "" $ \cursor -> do - it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` XmlElement "a" [] - - forXml "" $ \cursor -> do - it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` - XmlElement "a" [attrs [("attr", "value")]] - - forXml "" $ \cursor -> do - it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` - XmlElement "a" [attrs [("attr", "value")], - XmlElement "b" [attrs [("attr", "value")]]] - - forXml "value text" $ \cursor -> do - it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` - XmlElement "a" [XmlText "value text"] - - forXml "" $ \cursor -> do - it "should parse space separared comment" $ xmlValueVia (Just cursor) `shouldBe` - XmlComment " some comment " - - forXml "" $ \cursor -> do - it "should parse space separared comment" $ xmlValueVia (Just cursor) `shouldBe` - XmlComment "some comment ->" - - forXml " tag]]>" $ \cursor -> do - it "should parse cdata data" $ xmlValueVia (Just cursor) `shouldBe` - XmlCData "a
tag" - - forXml "]>" $ \cursor -> do - it "should parse metas" $ xmlValueVia (Just cursor) `shouldBe` - XmlMeta "DOCTYPE" [XmlMeta "ELEMENT" []] - - forXml "free" $ \cursor -> do - it "should parse xml header" $ xmlValueVia (Just cursor) `shouldBe` - XmlDocument [ - attrs [("version", "1.0"), ("encoding", "UTF-8")], - XmlElement "a" [attrs [("text", "value")], - XmlText "free"]] - - it "navigate around" $ do - xmlValueVia (ns cursor) `shouldBe` XmlElement "a" [attrs [("text", "value")], XmlText "free"] - xmlValueVia ((ns >=> fc) cursor) `shouldBe` attrs [("text", "value")] - xmlValueVia ((ns >=> fc >=> fc) cursor) `shouldBe` XmlAttrName "text" - xmlValueVia ((ns >=> fc >=> fc >=> ns) cursor) `shouldBe` XmlAttrValue "value" - xmlValueVia ((ns >=> fc >=> ns) cursor) `shouldBe` XmlText "free" - - -- forXml " {}" $ \cursor -> do - -- it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` Right (JsonObject []) - -- forXml "1234" $ \cursor -> do - -- it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` Right (JsonNumber 1234) - -- forXml "\"Hello\"" $ \cursor -> do - -- it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` Right (JsonString "Hello") - -- forXml "[]" $ \cursor -> do - -- it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` Right (JsonArray []) - -- forXml "true" $ \cursor -> do - -- it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` Right (JsonBool True) - -- forXml "false" $ \cursor -> do - -- it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` Right (JsonBool False) - -- forXml "null" $ \cursor -> do - -- it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` Right JsonNull - -- forXml "[null]" $ \cursor -> do - -- it "should have correct value" $ xmlValueVia (Just cursor) `shouldBe` Right (JsonArray [JsonNull]) - -- it "should have correct value" $ xmlValueVia (fc cursor) `shouldBe` Right JsonNull - -- it "depth at top" $ cd cursor `shouldBe` Just 1 - -- it "depth at first child of array" $ (fc >=> cd) cursor `shouldBe` Just 2 - -- forXml "[null, {\"field\": 1}]" $ \cursor -> do - -- it "cursor can navigate to second child of array" $ do - -- xmlValueVia ((fc >=> ns) cursor) `shouldBe` Right ( JsonObject [("field", JsonNumber 1)] ) - -- xmlValueVia (Just cursor) `shouldBe` Right (JsonArray [JsonNull, JsonObject [("field", JsonNumber 1)]]) - -- it "depth at second child of array" $ do - -- (fc >=> ns >=> cd) cursor `shouldBe` Just 2 - -- it "depth at first child of object at second child of array" $ do - -- (fc >=> ns >=> fc >=> cd) cursor `shouldBe` Just 3 - -- it "depth at first child of object at second child of array" $ do - -- (fc >=> ns >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3 - -- describe "For empty json array" $ do - -- let cursor = "[]" :: XmlCursor BS.ByteString t u - -- it "can navigate down and forwards" $ do - -- xmlValueVia (Just cursor) `shouldBe` Right (JsonArray []) - -- describe "For empty json array" $ do - -- let cursor = "[null]" :: XmlCursor BS.ByteString t u - -- it "can navigate down and forwards" $ do - -- xmlValueVia (Just cursor) `shouldBe` Right (JsonArray [JsonNull]) - -- describe "For sample Json" $ do - -- let cursor = "{ \ - -- \ \"widget\": { \ - -- \ \"debug\": \"on\", \ - -- \ \"window\": { \ - -- \ \"name\": \"main_window\", \ - -- \ \"dimensions\": [500, 600.01e-02, true, false, null] \ - -- \ } \ - -- \ } \ - -- \}" :: XmlCursor BS.ByteString t u - -- it "can navigate down and forwards" $ do - -- let array = JsonArray [JsonNumber 500, JsonNumber 600.01e-02, JsonBool True, JsonBool False, JsonNull] :: JsonValue - -- let object1 = JsonObject ([("name", JsonString "main_window"), ("dimensions", array)]) :: JsonValue - -- let object2 = JsonObject ([("debug", JsonString "on"), ("window", object1)]) :: JsonValue - -- let object3 = JsonObject ([("widget", object2)]) :: JsonValue - -- xmlValueVia (Just cursor) `shouldBe` Right object3 - -- xmlValueVia ((fc ) cursor) `shouldBe` Right (JsonString "widget" ) - -- xmlValueVia ((fc >=> ns ) cursor) `shouldBe` Right (object2 ) - -- xmlValueVia ((fc >=> ns >=> fc ) cursor) `shouldBe` Right (JsonString "debug" ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns ) cursor) `shouldBe` Right (JsonString "on" ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns >=> ns ) cursor) `shouldBe` Right (JsonString "window" ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) `shouldBe` Right (object1 ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc ) cursor) `shouldBe` Right (JsonString "name" ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns ) cursor) `shouldBe` Right (JsonString "main_window" ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns ) cursor) `shouldBe` Right (JsonString "dimensions" ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) `shouldBe` Right (array ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc ) cursor) `shouldBe` Right (JsonNumber 500 ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns ) cursor) `shouldBe` Right (JsonNumber 600.01e-02 ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns ) cursor) `shouldBe` Right (JsonBool True ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns ) cursor) `shouldBe` Right (JsonBool False ) - -- xmlValueVia ((fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> ns) cursor) `shouldBe` Right JsonNull diff --git a/test/data/sample.xml b/test/data/sample.xml deleted file mode 100644 --- a/test/data/sample.xml +++ /dev/null @@ -1,28 +0,0 @@ -{ - "widget": { - "debug": "on", - "window": { - "title": "Sample Konfabulator Widget", - "name": "main_window", - "width": 500, - "height": 500 - }, - "image": { - "src": "Images/Sun.png", - "name": "sun1", - "hOffset": 250, - "vOffset": 250, - "alignment": "center" - }, - "text": { - "data": "Click Here", - "size": 36, - "style": "bold", - "name": "text1", - "hOffset": 250, - "vOffset": 100, - "alignment": "center", - "onMouseUp": "sun1.opacity = (sun1.opacity / 100) * 90;" - } - } -}