diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright John Ky, Alexey Raga (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,31 @@ +# 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) + +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) + +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) +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +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 + +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" + return cursor + +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 diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +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 + +setupEnvXml :: FilePath -> IO BS.ByteString +setupEnvXml filepath = do + (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr filepath ReadOnly Nothing + let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size + return bs + +loadXml :: BS.ByteString -> XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) +loadXml bs = fromByteString bs :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) + +xmlToInterestBits3 :: MonadThrow m => Conduit BS.ByteString m BS.ByteString +xmlToInterestBits3 = blankXml =$= blankedXmlToInterestBits + +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) + ] + ] + +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) + ] + ] + +main :: IO () +--main = defaultMain benchRankXml8mbConduits +main = defaultMain benchRankXmlBigConduits diff --git a/hw-xml.cabal b/hw-xml.cabal new file mode 100644 --- /dev/null +++ b/hw-xml.cabal @@ -0,0 +1,135 @@ +name: hw-xml +version: 0.0.0.1 +synopsis: Conduits for tokenizing streams. +description: Please see README.md +homepage: http://github.com/haskell-works/hw-xml#readme +license: BSD3 +license-file: LICENSE +author: John Ky, Alexey Raga +maintainer: alexey.raga@gmail.com +copyright: 2016 John Ky, Alexey Raga +category: Data, XML +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.22 +data-files: test/data/sample.xml + +executable hw-xml-example + hs-source-dirs: app + main-is: Main.hs + 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 + , vector + default-language: Haskell2010 + +library + hs-source-dirs: src + exposed-modules: HaskellWorks.Data.Xml + , HaskellWorks.Data.Xml.CharLike + , HaskellWorks.Data.Xml.Conduit + , HaskellWorks.Data.Xml.Conduit.Blank + , HaskellWorks.Data.Xml.Conduit.Words + , HaskellWorks.Data.Xml.Grammar + , HaskellWorks.Data.Xml.Succinct + , HaskellWorks.Data.Xml.Succinct.Cursor + , HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParens + , HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml + , HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits + , HaskellWorks.Data.Xml.Succinct.Cursor.Internal + , HaskellWorks.Data.Xml.Succinct.Cursor.Token + , HaskellWorks.Data.Xml.Succinct.Index + , HaskellWorks.Data.Xml.Token.Tokenize + , HaskellWorks.Data.Xml.Token.Types + , HaskellWorks.Data.Xml.Token + , HaskellWorks.Data.Xml.Type + , HaskellWorks.Data.Xml.Value + build-depends: base >= 4 && < 5 + , array + , ansi-wl-pprint + , attoparsec + , bytestring + , conduit + , containers + , hw-balancedparens >= 0.1.0.0 + , hw-bits >= 0.4.0.0 + , hw-conduit >= 0.1.0.0 + , hw-parser + , hw-prim >= 0.4.0.0 + , hw-rankselect >= 0.7.0.0 + , hw-rankselect-base >= 0.2.0.0 + , mono-traversable + , resourcet + , text + , vector + , word8 + + default-language: Haskell2010 + ghc-options: -Wall -O2 -msse4.2 + +test-suite hw-xml-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: HaskellWorks.Data.Xml.Token.TokenizeSpec + , HaskellWorks.Data.Xml.Succinct.CursorSpec + , 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-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 + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/haskell-works/hw-xml + +benchmark bench + Type: exitcode-stdio-1.0 + HS-Source-Dirs: bench + Main-Is: Main.hs + GHC-Options: -O2 -Wall -msse4.2 + Default-Language: Haskell2010 + 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-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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml.hs @@ -0,0 +1,11 @@ +-- | +-- 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 diff --git a/src/HaskellWorks/Data/Xml/CharLike.hs b/src/HaskellWorks/Data/Xml/CharLike.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/CharLike.hs @@ -0,0 +1,22 @@ +module HaskellWorks.Data.Xml.CharLike where + +import Data.Word +import Data.Word8 as W + +class XmlCharLike c where + isElementStart :: c -> Bool + isExclam :: c -> Bool + isHyphen :: c -> Bool + isOpenBracket :: c -> Bool + isQuestion :: c -> Bool + isQuote :: c -> Bool + isSpace :: c -> Bool + +instance XmlCharLike Word8 where + isElementStart = (== _less) + isExclam = (== _exclam) + isHyphen = (== _hyphen) + isOpenBracket = (== _bracketleft) + isQuestion = (== _question) + isQuote c = c == _quotedbl || c == _quotesingle + isSpace = W.isSpace diff --git a/src/HaskellWorks/Data/Xml/Conduit.hs b/src/HaskellWorks/Data/Xml/Conduit.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Conduit.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module HaskellWorks.Data.Xml.Conduit + ( blankedXmlToInterestBits + , byteStringToBits + , blankedXmlToBalancedParens + , blankedXmlToBalancedParens2 + , compressWordAsBit + , interestingWord8s + ) 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 + +interestingWord8s :: A.UArray Word8 Word8 +interestingWord8s = A.array (0, 255) [ + (w, if w == _bracketleft + || w == _braceleft + || w == _parenleft + || w == _bracketleft + || w == _less + || w == _a || w == _v || w == _t + then 1 + else 0) + | w <- [0 .. 255]] + +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 + case mbs of + 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 (ds, es) = BS.splitAt (q * 8) cs + let (fs, _) = BS.unfoldrN q gen ds + yield fs + blankedXmlToInterestBits' es + Nothing -> return () + 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)) + , BS.drop 8 as + ) + +blankedXmlToBalancedParens :: Monad m => Conduit BS.ByteString m Bool +blankedXmlToBalancedParens = do + mbs <- await + case mbs of + Just bs -> blankedXmlToBalancedParens' bs + Nothing -> return () + +blankedXmlToBalancedParens' :: Monad m => BS.ByteString -> Conduit BS.ByteString m Bool +blankedXmlToBalancedParens' bs = case BS.uncons bs of + Just (c, cs) -> do + case c of + d | d == _less -> yield True + d | d == _greater -> yield False + d | d == _bracketleft -> yield True + d | d == _bracketright -> yield False + d | d == _parenleft -> yield True + d | d == _parenright -> yield False + d | d == _a -> yield True >> yield False + d | d == _v -> yield True >> yield False + d | d == _t -> yield True >> yield False + _ -> return () + blankedXmlToBalancedParens' cs + Nothing -> return () + +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 + yield cs + Nothing -> return () + 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)) + , BS.drop 8 xs + ) + +blankedXmlToBalancedParens2 :: Monad m => Conduit BS.ByteString m BS.ByteString +blankedXmlToBalancedParens2 = do + mbs <- await + case mbs of + Just bs -> do + let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs) + yield cs + 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)) + Nothing -> Nothing + +data MiniBP = MiniN | MiniT | MiniF | MiniTF + +balancedParensOf :: Word8 -> MiniBP +balancedParensOf c = case c of + d | d == _less -> MiniT + d | d == _greater -> MiniF + d | d == _bracketleft -> MiniT + d | d == _bracketright -> MiniF + d | d == _parenleft -> MiniT + d | d == _parenright -> MiniF + d | d == _t -> MiniTF + d | d == _a -> MiniTF + d | d == _v -> MiniTF + _ -> MiniN + +yieldBitsOfWord8 :: Monad m => Word8 -> Conduit BS.ByteString m Bool +yieldBitsOfWord8 w = do + yield ((w .&. BITS.bit 0) /= 0) + yield ((w .&. BITS.bit 1) /= 0) + yield ((w .&. BITS.bit 2) /= 0) + yield ((w .&. BITS.bit 3) /= 0) + yield ((w .&. BITS.bit 4) /= 0) + yield ((w .&. BITS.bit 5) /= 0) + yield ((w .&. BITS.bit 6) /= 0) + yield ((w .&. BITS.bit 7) /= 0) + +yieldBitsofWord8s :: Monad m => [Word8] -> Conduit BS.ByteString m Bool +yieldBitsofWord8s = P.foldr ((>>) . yieldBitsOfWord8) (return ()) + +byteStringToBits :: Monad m => Conduit BS.ByteString m Bool +byteStringToBits = do + mbs <- await + case mbs of + Just bs -> yieldBitsofWord8s (BS.unpack bs) >> byteStringToBits + Nothing -> return () diff --git a/src/HaskellWorks/Data/Xml/Conduit/Blank.hs b/src/HaskellWorks/Data/Xml/Conduit/Blank.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Conduit/Blank.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Xml.Conduit.Blank + ( blankXml + ) 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 + +type ExpectedChar = Word8 +data BlankState + = InXml + | InTag | InAttrList | InCloseTag | InClose + | InBang Int + | InString ExpectedChar | InText + | InMeta + | InCdataTag | InCdata Int + | InRem Int + | InIdent + +data ByteStringP = BSP Word8 ByteString | EmptyBSP + +blankXml :: MonadThrow m => Conduit BS.ByteString m BS.ByteString +blankXml = blankXml' Nothing InXml + +blankXml' :: MonadThrow m => Maybe Word8 -> BlankState -> Conduit BS.ByteString m BS.ByteString +blankXml' lastChar 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 + +isEndTag :: Word8 -> ByteString -> Bool +isEndTag c cs = c == _less && headIs (== _slash) cs + +-- isStartTag :: Word8 -> ByteString -> Bool +-- isStartTag c cs = c == _less && headIs isNameStartChar cs + +isTagClose :: Word8 -> ByteString -> Bool +isTagClose c cs = + (c == _slash || c == _question) && headIs (== _greater) cs + +isMetaStart :: Word8 -> ByteString -> Bool +isMetaStart c cs = c == _less && headIs (== _exclam) cs + +isCdataEnd :: Word8 -> ByteString -> Bool +isCdataEnd c cs = c == _bracketright && headIs (== _greater) cs + +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 #-} + +headIs :: (Word8 -> Bool) -> ByteString -> Bool +headIs p bs = case BS.uncons bs of + Just (!c, _) -> p c + Nothing -> False +{-# INLINE headIs #-} + +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 #-} diff --git a/src/HaskellWorks/Data/Xml/Conduit/Words.hs b/src/HaskellWorks/Data/Xml/Conduit/Words.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Conduit/Words.hs @@ -0,0 +1,37 @@ +module HaskellWorks.Data.Xml.Conduit.Words where + +import Data.Word +import Data.Word8 + +isLeadingDigit :: Word8 -> Bool +isLeadingDigit w = w == _hyphen || (w >= _0 && w <= _9) + +isTrailingDigit :: Word8 -> Bool +isTrailingDigit w = w == _plus || w == _hyphen || (w >= _0 && w <= _9) || w == _period || w == _E || w == _e + +isAlphabetic :: Word8 -> Bool +isAlphabetic w = (w >= _A && w <= _Z) || (w >= _a && w <= _z) + +isQuote :: Word8 -> Bool +isQuote w = w == _quotedbl || w == _quotesingle + +isNameStartChar :: Word8 -> Bool +isNameStartChar w = w == _underscore || w == _colon || isAlphabetic w + || w `isIn` (0xc0, 0xd6) + || w `isIn` (0xd8, 0xf6) + || w `isIn` (0xf8, 0xff) + +isNameChar :: Word8 -> Bool +isNameChar w = isNameStartChar w || w == _hyphen || w == _period + || w == 0xb7 || w `isIn` (0, 9) + +isXml :: Word8 -> Bool +isXml w = w == _less || w == _greater + +isTextStart :: Word8 -> Bool +isTextStart w = not (isSpace w) && w /= _less && w /= _greater + +isIn :: Word8 -> (Word8, Word8) -> Bool +isIn w (s, e) = w >= s && w <= e +{-# INLINE isIn #-} + diff --git a/src/HaskellWorks/Data/Xml/Grammar.hs b/src/HaskellWorks/Data/Xml/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Grammar.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# 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 + +data XmlElementType + = XmlElementTypeDocument + | XmlElementTypeElement String + | XmlElementTypeComment + | XmlElementTypeCData + | XmlElementTypeMeta String + +parseXmlString :: (P.Parser t, IsString t) => T.Parser t String +parseXmlString = do + q <- satisfyChar (=='"') <|> satisfyChar (=='\'') + many (satisfyChar (/= q)) + +parseXmlElement :: (P.Parser t, IsString t) => T.Parser t XmlElementType +parseXmlElement = comment <|> cdata <|> doc <|> meta <|> element + where + comment = const XmlElementTypeComment <$> string "!--" + cdata = const XmlElementTypeCData <$> string "![CDATA[" + meta = XmlElementTypeMeta <$> (string "!" >> parseXmlToken) + doc = const XmlElementTypeDocument <$> string "?xml" + element = XmlElementTypeElement <$> parseXmlToken + +parseXmlToken :: (P.Parser t, IsString t) => T.Parser t String +parseXmlToken = many $ satisfyChar isNameChar "invalid string character" + +parseXmlAttributeName :: (P.Parser t, IsString t) => T.Parser t String +parseXmlAttributeName = parseXmlToken + +isNameStartChar :: Char -> Bool +isNameStartChar w = + let iw = ord w + in w == '_' || w == ':' || isAlpha w + || (iw >= 0xc0 && iw <= 0xd6) + || (iw >= 0xd8 && iw <= 0xf6) + || (iw >= 0xf8 && iw <= 0xff) + +isNameChar :: Char -> Bool +isNameChar w = isNameStartChar w || w == '-' || w == '.' + || ord w == 0xb7 || isNumber w diff --git a/src/HaskellWorks/Data/Xml/Succinct.hs b/src/HaskellWorks/Data/Xml/Succinct.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct.hs @@ -0,0 +1,5 @@ +module HaskellWorks.Data.Xml.Succinct + ( module X + ) where + +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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor.hs @@ -0,0 +1,7 @@ + +module HaskellWorks.Data.Xml.Succinct.Cursor + ( module X + ) where + +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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParens.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParens + ( XmlBalancedParens(..) + , 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 + +newtype XmlBalancedParens a = XmlBalancedParens a + +getXmlBalancedParens :: XmlBalancedParens a -> a +getXmlBalancedParens (XmlBalancedParens a) = a + +genBitWordsForever :: BS.ByteString -> Maybe (Word8, BS.ByteString) +genBitWordsForever bs = BS.uncons bs <|> Just (0, bs) +{-# INLINABLE genBitWordsForever #-} + +instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens [Bool])) where + fromBlankedXml (BlankedXml bj) = XmlBalancedParens (SimpleBalancedParens (runListConduit blankedXmlToBalancedParens bj)) + +instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word8))) where + fromBlankedXml bj = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) + where interestBS = BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml bj)) + newLen = (BS.length interestBS + 7) `div` 8 * 8 + +instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word16))) where + fromBlankedXml bj = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) + where interestBS = BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml bj)) + newLen = (BS.length interestBS + 7) `div` 8 * 8 + +instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word32))) where + fromBlankedXml bj = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) + where interestBS = BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml bj)) + newLen = (BS.length interestBS + 7) `div` 8 * 8 + +instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word64))) where + fromBlankedXml bj = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) + where interestBS = BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml bj)) + newLen = (BS.length interestBS + 7) `div` 8 * 8 diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs @@ -0,0 +1,23 @@ + +module HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml + ( BlankedXml(..) + , FromBlankedXml(..) + , 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 + +newtype BlankedXml = BlankedXml [BS.ByteString] deriving (Eq, Show) + +getBlankedXml :: BlankedXml -> [BS.ByteString] +getBlankedXml (BlankedXml bs) = bs + +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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBits.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits + ( XmlInterestBits(..) + , getXmlInterestBits + ) 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 + +newtype XmlInterestBits a = XmlInterestBits a + +getXmlInterestBits :: XmlInterestBits a -> a +getXmlInterestBits (XmlInterestBits a) = a + +blankedXmlBssToInterestBitsBs :: [ByteString] -> ByteString +blankedXmlBssToInterestBitsBs bss = BS.concat $ runListConduit blankedXmlToInterestBits bss + +genInterest :: ByteString -> Maybe (Word8, ByteString) +genInterest = BS.uncons + +genInterestForever :: ByteString -> Maybe (Word8, ByteString) +genInterestForever bs = BS.uncons bs <|> Just (0, bs) + +instance FromBlankedXml (XmlInterestBits (BitShown [Bool])) where + fromBlankedXml = XmlInterestBits . fromByteString . BS.concat . runListConduit blankedXmlToInterestBits . getBlankedXml + +instance FromBlankedXml (XmlInterestBits (BitShown BS.ByteString)) where + fromBlankedXml = XmlInterestBits . BitShown . BS.unfoldr genInterest . blankedXmlBssToInterestBitsBs . getBlankedXml + +instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word8))) where + fromBlankedXml = XmlInterestBits . BitShown . DVS.unfoldr genInterest . blankedXmlBssToInterestBitsBs . getBlankedXml + +instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word16))) where + fromBlankedXml bj = XmlInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) + where interestBS = blankedXmlBssToInterestBitsBs (getBlankedXml bj) + newLen = (BS.length interestBS + 1) `div` 2 * 2 + +instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word32))) where + fromBlankedXml bj = XmlInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) + where interestBS = blankedXmlBssToInterestBitsBs (getBlankedXml bj) + newLen = (BS.length interestBS + 3) `div` 4 * 4 + +instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word64))) where + fromBlankedXml bj = XmlInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS))) + where interestBS = blankedXmlBssToInterestBitsBs (getBlankedXml bj) + newLen = (BS.length interestBS + 7) `div` 8 * 8 + +instance FromBlankedXml (XmlInterestBits Poppy512) where + fromBlankedXml = XmlInterestBits . makePoppy512 . bitShown . getXmlInterestBits . fromBlankedXml diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Xml.Succinct.Cursor.Internal + ( XmlCursor(..) + , xmlCursorPos + ) where + +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 + , interests :: !v + , balancedParens :: !w + , cursorRank :: !Count + } + deriving (Eq, Show) + +instance (FromBlankedXml (XmlInterestBits a), FromBlankedXml (CBP.XmlBalancedParens b)) + => FromByteString (XmlCursor BS.ByteString a b) where + fromByteString bs = XmlCursor + { cursorText = bs + , interests = getXmlInterestBits (fromBlankedXml blankedXml) + , balancedParens = CBP.getXmlBalancedParens (fromBlankedXml blankedXml) + , cursorRank = 1 + } + where blankedXml :: BlankedXml + blankedXml = fromByteString bs + +instance IsString (XmlCursor String (BitShown [Bool]) (BP.SimpleBalancedParens [Bool])) where + fromString :: String -> XmlCursor String (BitShown [Bool]) (BP.SimpleBalancedParens [Bool]) + fromString s = XmlCursor + { cursorText = s + , cursorRank = 1 + , interests = getXmlInterestBits (fromBlankedXml blankedXml) + , balancedParens = CBP.getXmlBalancedParens (fromBlankedXml blankedXml) + } + where blankedXml :: BlankedXml + blankedXml = fromByteString (BSC.pack s) + +instance IsString (XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (BP.SimpleBalancedParens (DVS.Vector Word8))) where + fromString = fromByteString . BSC.pack + +instance IsString (XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (BP.SimpleBalancedParens (DVS.Vector Word16))) where + fromString = fromByteString . BSC.pack + +instance IsString (XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (BP.SimpleBalancedParens (DVS.Vector Word32))) where + fromString = fromByteString . BSC.pack + +instance IsString (XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (BP.SimpleBalancedParens (DVS.Vector Word64))) where + fromString = fromByteString . BSC.pack + +instance IsString (XmlCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64))) where + fromString = fromByteString . BSC.pack + +instance FromForeignRegion (XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (BP.SimpleBalancedParens (DVS.Vector Word8))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (BP.SimpleBalancedParens (DVS.Vector Word16))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (BP.SimpleBalancedParens (DVS.Vector Word32))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (BP.SimpleBalancedParens (DVS.Vector Word64))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance FromForeignRegion (XmlCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64))) where + fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size) + +instance (BP.BalancedParens u, Rank1 u, Rank0 u) => TreeCursor (XmlCursor t v u) where + firstChild :: XmlCursor t v u -> Maybe (XmlCursor t v u) + firstChild k = let mq = BP.firstChild (balancedParens k) (cursorRank k) in (\q -> k { cursorRank = q }) <$> mq + + nextSibling :: XmlCursor t v u -> Maybe (XmlCursor t v u) + nextSibling k = (\q -> k { cursorRank = q }) <$> BP.nextSibling (balancedParens k) (cursorRank k) + + parent :: XmlCursor t v u -> Maybe (XmlCursor t v u) + parent k = let mq = BP.parent (balancedParens k) (cursorRank k) in (\q -> k { cursorRank = q }) <$> mq + + depth :: XmlCursor t v u -> Maybe Count + depth k = BP.depth (balancedParens k) (cursorRank k) + + subtreeSize :: XmlCursor t v u -> Maybe Count + subtreeSize k = BP.subtreeSize (balancedParens k) (cursorRank k) + +xmlCursorPos :: (Rank1 w, Select1 v) => XmlCursor s v w -> Position +xmlCursorPos k = toPosition (select1 ik (rank1 bpk (cursorRank k)) - 1) + where ik = interests k + bpk = balancedParens k diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/Token.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Token.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Token.hs @@ -0,0 +1,23 @@ + +module HaskellWorks.Data.Xml.Succinct.Cursor.Token + ( 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) + +xmlTokenAt :: (Rank1 w, Select1 v, TestBit w) => XmlCursor ByteString v w -> Maybe (XmlToken String Double) +xmlTokenAt k = if balancedParens k .?. lastPositionOf (cursorRank k) + then case ABC.parse parseXmlToken (drop (toCount (xmlCursorPos k)) (cursorText k)) of + ABC.Fail {} -> error "Failed to parse token in cursor" + ABC.Partial _ -> error "Failed to parse token in cursor" + ABC.Done _ r -> Just r + else Nothing diff --git a/src/HaskellWorks/Data/Xml/Succinct/Index.hs b/src/HaskellWorks/Data/Xml/Succinct/Index.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct/Index.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module HaskellWorks.Data.Xml.Succinct.Index +( XmlIndex(..) +, XmlIndexAt(..) +) +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) + +data XmlIndex + = XmlIndexDocument [XmlIndex] + | XmlIndexElement String [XmlIndex] + | XmlIndexCData BS.ByteString + | XmlIndexComment BS.ByteString + | XmlIndexMeta String [XmlIndex] + | XmlIndexAttrList [XmlIndex] + | XmlIndexValue BS.ByteString + | XmlIndexAttrName BS.ByteString + | XmlIndexAttrValue BS.ByteString + | XmlIndexError String + deriving (Eq, Show) + +class XmlIndexAt a where + xmlIndexAt :: a -> XmlIndex + +pos :: (Select1 v, Rank1 w) => XmlCursor t v w -> Position +pos c = lastPositionOf (select1 (interests c) (rank1 (balancedParens c) (cursorRank c))) + +remText :: (Drop v, Select1 v1, Rank1 w) => XmlCursor v v1 w -> v +remText c = drop (toCount (pos c)) (cursorText c) + +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 + + 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)) + + +decodeErr :: String -> BS.ByteString -> XmlIndex +decodeErr reason bs = + XmlIndexError $ reason <>": " <> show (BS.take 20 bs) <> "...'" diff --git a/src/HaskellWorks/Data/Xml/Token.hs b/src/HaskellWorks/Data/Xml/Token.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Token.hs @@ -0,0 +1,6 @@ +module HaskellWorks.Data.Xml.Token + ( module X + ) where + +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 new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Token/Tokenize.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module HaskellWorks.Data.Xml.Token.Tokenize + ( IsChar(..) + , XmlToken(..) + , 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 + +hexDigitNumeric :: P.Parser t => T.Parser t Int +hexDigitNumeric = do + c <- satisfyChar (\c -> '0' <= c && c <= '9') + return $ ord c - ord '0' + +hexDigitAlphaLower :: P.Parser t => T.Parser t Int +hexDigitAlphaLower = do + c <- satisfyChar (\c -> 'a' <= c && c <= 'z') + return $ ord c - ord 'a' + 10 + +hexDigitAlphaUpper :: P.Parser t => T.Parser t Int +hexDigitAlphaUpper = do + c <- satisfyChar (\c -> 'A' <= c && c <= 'Z') + return $ ord c - ord 'A' + 10 + +hexDigit :: P.Parser t => T.Parser t Int +hexDigit = hexDigitNumeric <|> hexDigitAlphaLower <|> hexDigitAlphaUpper + +class ParseXml t s d where + parseXmlTokenString :: T.Parser t (XmlToken s d) + parseXmlToken :: T.Parser t (XmlToken s d) + parseXmlTokenBraceL :: T.Parser t (XmlToken s d) + parseXmlTokenBraceR :: T.Parser t (XmlToken s d) + parseXmlTokenBracketL :: T.Parser t (XmlToken s d) + parseXmlTokenBracketR :: T.Parser t (XmlToken s d) + parseXmlTokenComma :: T.Parser t (XmlToken s d) + parseXmlTokenColon :: T.Parser t (XmlToken s d) + parseXmlTokenWhitespace :: T.Parser t (XmlToken s d) + parseXmlTokenNull :: T.Parser t (XmlToken s d) + parseXmlTokenBoolean :: T.Parser t (XmlToken s d) + parseXmlTokenDouble :: T.Parser t (XmlToken s d) + + parseXmlToken = + parseXmlTokenString <|> + parseXmlTokenBraceL <|> + parseXmlTokenBraceR <|> + parseXmlTokenBracketL <|> + parseXmlTokenBracketR <|> + parseXmlTokenComma <|> + parseXmlTokenColon <|> + parseXmlTokenWhitespace <|> + parseXmlTokenNull <|> + parseXmlTokenBoolean <|> + parseXmlTokenDouble + +instance ParseXml BS.ByteString String Double where + parseXmlTokenBraceL = string "{" >> return XmlTokenBraceL + parseXmlTokenBraceR = string "}" >> return XmlTokenBraceR + parseXmlTokenBracketL = string "[" >> return XmlTokenBracketL + parseXmlTokenBracketR = string "]" >> return XmlTokenBracketR + parseXmlTokenComma = string "," >> return XmlTokenComma + parseXmlTokenColon = string ":" >> return XmlTokenColon + parseXmlTokenNull = string "null" >> return XmlTokenNull + parseXmlTokenDouble = XmlTokenNumber <$> rational + + parseXmlTokenString = do + _ <- string "\"" + value <- many (verbatimChar <|> escapedChar <|> escapedCode) + _ <- string "\"" + return $ XmlTokenString value + where + verbatimChar = satisfyChar (BC.notInClass "\"\\") "invalid string character" + escapedChar = do + _ <- string "\\" + ( char '"' >> return '"' ) <|> + ( char 'b' >> return '\b' ) <|> + ( char 'n' >> return '\n' ) <|> + ( char 'f' >> return '\f' ) <|> + ( char 'r' >> return '\r' ) <|> + ( char 't' >> return '\t' ) <|> + ( char '\\' >> return '\\' ) <|> + ( char '\'' >> return '\'' ) <|> + ( char '/' >> return '/' ) + escapedCode :: T.Parser BS.ByteString Char + escapedCode = do + _ <- string "\\u" + a <- hexDigit + b <- hexDigit + c <- hexDigit + d <- hexDigit + return . chr $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d + + parseXmlTokenWhitespace = do + _ <- AC.many1' $ BC.choice [string " ", string "\t", string "\n", string "\r"] + return XmlTokenWhitespace + + parseXmlTokenBoolean = true <|> false + where + true = string "true" >> return (XmlTokenBoolean True) + false = string "false" >> return (XmlTokenBoolean False) + +instance ParseXml BS.ByteString BS.ByteString Double where + parseXmlTokenBraceL = string "{" >> return XmlTokenBraceL + parseXmlTokenBraceR = string "}" >> return XmlTokenBraceR + parseXmlTokenBracketL = string "[" >> return XmlTokenBracketL + parseXmlTokenBracketR = string "]" >> return XmlTokenBracketR + parseXmlTokenComma = string "," >> return XmlTokenComma + parseXmlTokenColon = string ":" >> return XmlTokenColon + parseXmlTokenNull = string "null" >> return XmlTokenNull + parseXmlTokenDouble = XmlTokenNumber <$> rational + + parseXmlTokenString = do + _ <- string "\"" + value <- many (verbatimChar <|> escapedChar <|> escapedCode) + _ <- string "\"" + return . XmlTokenString $ BS.pack value + where + word :: Word8 -> T.Parser BS.ByteString Word8 + word w = satisfy (== w) + verbatimChar :: T.Parser BS.ByteString Word8 + verbatimChar = satisfy (\w -> w /= _quotedbl && w /= _backslash) -- "invalid string character" + escapedChar :: T.Parser BS.ByteString Word8 + escapedChar = do + _ <- string "\\" + ( word _quotedbl >> return _quotedbl ) <|> + ( word _b >> return 0x08 ) <|> + ( word _n >> return _lf ) <|> + ( word _f >> return _np ) <|> + ( word _r >> return _cr ) <|> + ( word _t >> return _tab ) <|> + ( word _backslash >> return _backslash ) <|> + ( word _quotesingle >> return _quotesingle ) <|> + ( word _slash >> return _slash ) + escapedCode :: T.Parser BS.ByteString Word8 + escapedCode = do + _ <- string "\\u" + a <- hexDigit + b <- hexDigit + c <- hexDigit + d <- hexDigit + return . fromIntegral $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d + + parseXmlTokenWhitespace = do + _ <- AC.many1' $ BC.choice [string " ", string "\t", string "\n", string "\r"] + return XmlTokenWhitespace + + parseXmlTokenBoolean = true <|> false + where + true = string "true" >> return (XmlTokenBoolean True) + false = string "false" >> return (XmlTokenBoolean False) diff --git a/src/HaskellWorks/Data/Xml/Token/Types.hs b/src/HaskellWorks/Data/Xml/Token/Types.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Token/Types.hs @@ -0,0 +1,15 @@ +module HaskellWorks.Data.Xml.Token.Types (XmlToken(..)) where + +data XmlToken s d + = XmlTokenBraceL + | XmlTokenBraceR + | XmlTokenBracketL + | XmlTokenBracketR + | XmlTokenComma + | XmlTokenColon + | XmlTokenWhitespace + | XmlTokenString s + | XmlTokenBoolean Bool + | XmlTokenNumber d + | XmlTokenNull + deriving (Eq, Show) diff --git a/src/HaskellWorks/Data/Xml/Type.hs b/src/HaskellWorks/Data/Xml/Type.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Type.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +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) + +{-# ANN module ("HLint: Ignore Reduce duplication" :: String) #-} + +data XmlType + = XmlTypeElement + | XmlTypeAttrList + | XmlTypeToken + deriving (Eq, Show) + +class XmlTypeAt a where + xmlTypeAtPosition :: Position -> a -> Maybe XmlType + xmlTypeAt :: a -> Maybe XmlType + +instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => XmlTypeAt (XmlCursor String v w) where + 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 + + xmlTypeAt k = xmlTypeAtPosition p k + where p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k))) + ik = interests k + bpk = balancedParens k + +instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => XmlTypeAt (XmlCursor BS.ByteString v w) where + 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 + + xmlTypeAt k = xmlTypeAtPosition p k + where p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k))) + ik = interests k + bpk = balancedParens k diff --git a/src/HaskellWorks/Data/Xml/Value.hs b/src/HaskellWorks/Data/Xml/Value.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Value.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HaskellWorks.Data.Xml.Value +( XmlValue(..) +, XmlValueAt(..) +) +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 ((<$>), (<>)) + +data XmlValue + = XmlDocument [XmlValue] + | XmlText String + | XmlElement String [XmlValue] + | XmlCData String + | XmlComment String + | XmlMeta String [XmlValue] + | XmlAttrName String + | XmlAttrValue String + | XmlAttrList [XmlValue] + | XmlError 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 + +isAttr :: XmlValue -> Bool +isAttr v = case v of + XmlAttrName _ -> True + XmlAttrValue _ -> True + XmlAttrList _ -> True + _ -> False + +as :: Either String a -> (a -> XmlValue) -> XmlValue +as = flip $ either XmlError + +decodeErr :: String -> BS.ByteString -> Either String a +decodeErr reason bs = + Left $ reason <>" (" <> show (BS.take 20 bs) <> "...)" diff --git a/test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs b/test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs @@ -0,0 +1,33 @@ +{-# 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 + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +interestBitsOf :: FromBlankedXml (XmlInterestBits a) => BS.ByteString -> a +interestBitsOf = getXmlInterestBits . fromBlankedXml . fromByteString + +spec :: Spec +spec = describe "HaskellWorks.Data.Xml.Succinct.Cursor.InterestBitsSpec" $ do + it "Evaluating interest bits" $ do + (interestBitsOf "" :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "" + (interestBitsOf " \n \r \t " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000" + (interestBitsOf "" :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10010000 00000000" + (interestBitsOf " " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "01011010 00000000" + (interestBitsOf " " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "01000000 00000000" + (interestBitsOf "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + cd cursor `shouldBe` Just 1 + it "depth at attribute list" $ do + let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + (fc >=> cd) cursor `shouldBe` Just 2 + it "depth first attribute" $ do + let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + (fc >=> fc >=> cd) cursor `shouldBe` Just 3 + it "depth second attribute" $ do + let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + (fc >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3 + 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 + +-- 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 + +-- 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 diff --git a/test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs b/test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +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 + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +parseXmlToken' :: ByteString -> Either String (XmlToken String Double) +parseXmlToken' = BC.parseOnly parseXmlToken + +spec :: Spec +spec = describe "Data.Conduit.Succinct.XmlSpec" $ do + describe "When parsing single token at beginning of text" $ do + it "Empty Xml should produce no bits" $ + parseXmlToken' "" `shouldBe` Left "not enough input" + it "Xml with one space should produce whitespace token" $ + parseXmlToken' " " `shouldBe` Right XmlTokenWhitespace + it "Xml with two spaces should produce whitespace token" $ + parseXmlToken' " " `shouldBe` Right XmlTokenWhitespace + it "Spaces and newlines should produce no bits" $ + parseXmlToken' " \n \r \t " `shouldBe` Right XmlTokenWhitespace + it "`null` at beginning should produce one bit" $ + parseXmlToken' "null " `shouldBe` Right XmlTokenNull + it "number at beginning should produce one bit" $ + parseXmlToken' "1234 " `shouldBe` Right (XmlTokenNumber 1234) + it "false at beginning should produce one bit" $ + parseXmlToken' "false " `shouldBe` Right (XmlTokenBoolean False) + it "true at beginning should produce one bit" $ + parseXmlToken' "true " `shouldBe` Right (XmlTokenBoolean True) + it "string at beginning should produce one bit" $ + parseXmlToken' "\"hello\" " `shouldBe` Right (XmlTokenString "hello") + it "quoted string should parse" $ + parseXmlToken' "\"\\\"\" " `shouldBe` Right (XmlTokenString "\"") + it "left brace at beginning should produce one bit" $ + parseXmlToken' "{ " `shouldBe` Right XmlTokenBraceL + it "right brace at beginning should produce one bit" $ + parseXmlToken' "} " `shouldBe` Right XmlTokenBraceR + it "left bracket at beginning should produce one bit" $ + parseXmlToken' "[ " `shouldBe` Right XmlTokenBracketL + it "right bracket at beginning should produce one bit" $ + parseXmlToken' "] " `shouldBe` Right XmlTokenBracketR + it "right bracket at beginning should produce one bit" $ + parseXmlToken' ": " `shouldBe` Right XmlTokenColon + it "right bracket at beginning should produce one bit" $ + parseXmlToken' ", " `shouldBe` Right XmlTokenComma diff --git a/test/HaskellWorks/Data/Xml/TypeSpec.hs b/test/HaskellWorks/Data/Xml/TypeSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Xml/TypeSpec.hs @@ -0,0 +1,129 @@ +{-# 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.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 + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{-# ANN module ("HLint: redundant bracket" :: String) #-} + +fc = TC.firstChild +ns = TC.nextSibling + +spec :: Spec +spec = describe "HaskellWorks.Data.Json.Succinct.CursorSpec" $ do + describe "Cursor for [Bool]" $ do + it "initialises to beginning of empty object" $ do + let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + xmlTypeAt cursor `shouldBe` Just XmlTypeElement + it "initialises to beginning of empty object preceded by spaces" $ do + let cursor = " " :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + xmlTypeAt cursor `shouldBe` Just XmlTypeElement + it "cursor can navigate to attr list" $ do + let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList + it "cursor can navigate through attrs" $ do + let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + (fc >=> fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --foo + (fc >=> fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --bar + (fc >=> fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --boo + (fc >=> fc >=> ns >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --buzz + (fc >=> fc >=> ns >=> ns >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing --back off! + it "cursor can navigate to children" $ do + let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --b + (fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --c + (fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing --back off! + it "cursor recognises child element as an element child next to attr list" $ do + let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) + (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList + (fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement + (fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing -- no more! + + 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))) + +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 type" $ xmlTypeAt cursor `shouldBe` Just XmlTypeElement + forXml " " $ \cursor -> do + it "should have correct type" $ xmlTypeAt cursor `shouldBe` Just XmlTypeElement + forXml "" $ \cursor -> do + it "cursor can navigate to second attribute" $ do + (fc >=> fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken + it "cursor can navigate to first attribute of an inner element" $ do + (fc >=> ns >=> fc >=> fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken + it "cursor can navigate to first atrribute value of an inner element" $ do + (fc >=> ns >=> fc >=> fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken + describe "For a single element" $ do + let cursor = "text" :: XmlCursor BS.ByteString t u + it "can navigate down and forwards" $ do + ( xmlTypeAt) cursor `shouldBe` Just XmlTypeElement + (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken + (fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing + (fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing + describe "For sample Xml" $ do + let cursor = " \ + \ \ + \ 500 \ + \ 600.01e-02 \ + \ false \ + \ \ + \" :: XmlCursor BS.ByteString t u + it "can navigate down and forwards" $ do + ( xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --widget + (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList --widget attrs + (fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --window + (fc >=> ns >=> fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList --window attrs + (fc >=> ns >=> fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --dimension 500 + (fc >=> ns >=> fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --dimension 600 + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --dimension false + (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --false diff --git a/test/HaskellWorks/Data/Xml/ValueSpec.hs b/test/HaskellWorks/Data/Xml/ValueSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Xml/ValueSpec.hs @@ -0,0 +1,192 @@ +{-# 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/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/data/sample.xml b/test/data/sample.xml new file mode 100644 --- /dev/null +++ b/test/data/sample.xml @@ -0,0 +1,28 @@ +{ + "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;" + } + } +}