diff --git a/app/App/Commands/CreateBpIndex.hs b/app/App/Commands/CreateBpIndex.hs --- a/app/App/Commands/CreateBpIndex.hs +++ b/app/App/Commands/CreateBpIndex.hs @@ -27,7 +27,7 @@ lbs <- LBS.readFile input let blankedXml = lbsToBlankedXml lbs - let ib = toBalancedParens64' blankedXml + let ib = toBalancedParens64 blankedXml LBS.writeFile output (LBS.fromChunks ib) return () diff --git a/app/App/Commands/CreateIbIndex.hs b/app/App/Commands/CreateIbIndex.hs --- a/app/App/Commands/CreateIbIndex.hs +++ b/app/App/Commands/CreateIbIndex.hs @@ -22,15 +22,13 @@ runCreateIbIndex :: Z.CreateIbIndexOptions -> IO () runCreateIbIndex opt = do - let input = opt ^. the @"input" + let input = opt ^. the @"input" let output = opt ^. the @"output" lbs <- LBS.readFile input - let blankedXml = lbsToBlankedXml lbs - let ib = toInterestBits64' blankedXml + let blankedXml = lbsToBlankedXml lbs + let ib = toInterestBits64 blankedXml LBS.writeFile output (LBS.fromChunks ib) - - return () optsCreateIbIndex :: Parser Z.CreateIbIndexOptions optsCreateIbIndex = Z.CreateIbIndexOptions diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -4,13 +4,15 @@ module Main where import Criterion.Main +import Data.ByteString (ByteString) import Data.Word import Foreign import HaskellWorks.Data.BalancedParens.Simple import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.FromByteString -import HaskellWorks.Data.Xml.Conduit -import HaskellWorks.Data.Xml.Conduit.Blank +import HaskellWorks.Data.Xml.Internal.Blank +import HaskellWorks.Data.Xml.Internal.List +import HaskellWorks.Data.Xml.Internal.Tables import HaskellWorks.Data.Xml.Succinct.Cursor import System.IO.MMap @@ -18,23 +20,23 @@ import qualified Data.ByteString.Internal as BSI import qualified Data.Vector.Storable as DVS -setupEnvXml :: FilePath -> IO BS.ByteString +setupEnvXml :: FilePath -> IO 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)) +loadXml :: ByteString -> XmlCursor ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) +loadXml bs = fromByteString bs :: XmlCursor ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)) -xmlToInterestBits3 :: [BS.ByteString] -> [BS.ByteString] +xmlToInterestBits3 :: [ByteString] -> [ByteString] xmlToInterestBits3 = blankedXmlToInterestBits . blankXml -runCon :: ([i] -> [BS.ByteString]) -> i -> BS.ByteString +runCon :: ([i] -> [ByteString]) -> i -> ByteString runCon con bs = BS.concat $ con [bs] -benchRankXmlCatalogConduits :: [Benchmark] -benchRankXmlCatalogConduits = +benchRankXmlCatalogLists :: [Benchmark] +benchRankXmlCatalogLists = [ env (setupEnvXml "data/catalog.xml") $ \bs -> bgroup "catalog.xml" [ bench "Run blankXml" (whnf (runCon blankXml ) bs) , bench "Run xmlToInterestBits3" (whnf (runCon xmlToInterestBits3) bs) @@ -57,5 +59,5 @@ main :: IO () main = defaultMain $ concat [ benchIsInterestingWord8 - , benchRankXmlCatalogConduits + , benchRankXmlCatalogLists ] diff --git a/hw-xml.cabal b/hw-xml.cabal --- a/hw-xml.cabal +++ b/hw-xml.cabal @@ -1,29 +1,29 @@ -cabal-version: 2.2 +cabal-version: 2.2 -name: hw-xml -version: 0.4.0.1 -synopsis: Conduits for tokenizing streams. -description: Conduits for tokenizing streams. Please see README.md -category: Data, XML, Succinct Data Structures, Data Structures -homepage: http://github.com/haskell-works/hw-xml#readme -bug-reports: https://github.com/haskell-works/hw-xml/issues -author: John Ky, - Alexey Raga -maintainer: alexey.raga@gmail.com -copyright: 2016-2019 John Ky - , 2016-2019 Alexey Raga -license: BSD-3-Clause -license-file: LICENSE -build-type: Simple -extra-source-files: README.md -data-files: - data/catalog.xml +name: hw-xml +version: 0.4.0.2 +synopsis: XML parser based on succinct data structures. +description: XML parser based on succinct data structures. Please see README.md +category: Data, XML, Succinct Data Structures, Data Structures +homepage: http://github.com/haskell-works/hw-xml#readme +bug-reports: https://github.com/haskell-works/hw-xml/issues +author: John Ky, + Alexey Raga +maintainer: alexey.raga@gmail.com +copyright: 2016-2019 John Ky + , 2016-2019 Alexey Raga +license: BSD-3-Clause +license-file: LICENSE +tested-with: GHC == 8.8.1, GHC == 8.6.5, GHC == 8.4.4, GHC == 8.2.2 +build-type: Simple +extra-source-files: README.md +data-files: data/catalog.xml source-repository head type: git location: https://github.com/haskell-works/hw-xml -common base { build-depends: base >= 4.7 && < 5 } +common base { build-depends: base >= 4.10 && < 5 } common ansi-wl-pprint { build-depends: ansi-wl-pprint >= 0.6.9 && < 0.7 } common array { build-depends: array >= 0.5.2.0 && < 0.6 } @@ -33,7 +33,7 @@ common containers { build-depends: containers >= 0.6.2.1 && < 0.7 } common criterion { build-depends: criterion >= 1.5.5.0 && < 1.6 } common deepseq { build-depends: deepseq >= 1.4.3.0 && < 1.5 } -common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 1.3 } +common generic-lens { build-depends: generic-lens >= 1.2.0.1 && < 1.3 } common ghc-prim { build-depends: ghc-prim >= 0.5 && < 0.6 } common hedgehog { build-depends: hedgehog >= 1.0 && < 1.1 } common hspec { build-depends: hspec >= 2.5 && < 3.0 } @@ -55,65 +55,70 @@ common word8 { build-depends: word8 >= 0.1.3 && < 0.2 } common config - default-language: Haskell2010 + default-language: Haskell2010 +common hw-xml + build-depends: hw-xml + library - import: base, config - , ansi-wl-pprint - , array - , attoparsec - , base - , bytestring - , cereal - , containers - , deepseq - , ghc-prim - , hw-balancedparens - , hw-bits - , hw-parser - , hw-prim - , hw-rankselect - , hw-rankselect-base - , lens - , mmap - , mtl - , resourcet - , transformers - , vector - , word8 - 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.Internal.ToIbBp64 - HaskellWorks.Data.Xml.Lens - 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.Create - HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits - HaskellWorks.Data.Xml.Succinct.Cursor.Internal - HaskellWorks.Data.Xml.Succinct.Cursor.Load - HaskellWorks.Data.Xml.Succinct.Cursor.Types - HaskellWorks.Data.Xml.Succinct.Cursor.MMap - 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 - HaskellWorks.Data.Xml.Type - HaskellWorks.Data.Xml.Value + import: base, config + , ansi-wl-pprint + , array + , attoparsec + , base + , bytestring + , cereal + , containers + , deepseq + , ghc-prim + , hw-balancedparens + , hw-bits + , hw-parser + , hw-prim + , hw-rankselect + , hw-rankselect-base + , lens + , mmap + , mtl + , resourcet + , transformers + , vector + , word8 + exposed-modules: HaskellWorks.Data.Xml + HaskellWorks.Data.Xml.Blank + HaskellWorks.Data.Xml.CharLike + HaskellWorks.Data.Xml.Decode + HaskellWorks.Data.Xml.DecodeError + HaskellWorks.Data.Xml.DecodeResult + HaskellWorks.Data.Xml.Grammar + HaskellWorks.Data.Xml.Index + HaskellWorks.Data.Xml.Internal.BalancedParens + HaskellWorks.Data.Xml.Internal.ByteString + HaskellWorks.Data.Xml.Internal.Blank + HaskellWorks.Data.Xml.Internal.List + HaskellWorks.Data.Xml.Internal.Tables + HaskellWorks.Data.Xml.Internal.ToIbBp64 + HaskellWorks.Data.Xml.Internal.Words + HaskellWorks.Data.Xml.Lens + 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.Create + HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits + HaskellWorks.Data.Xml.Succinct.Cursor.Internal + HaskellWorks.Data.Xml.Succinct.Cursor.Load + HaskellWorks.Data.Xml.Succinct.Cursor.Types + HaskellWorks.Data.Xml.Succinct.Cursor.MMap + 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 + HaskellWorks.Data.Xml.Type + HaskellWorks.Data.Xml.Value other-modules: Paths_hw_xml autogen-modules: Paths_hw_xml hs-source-dirs: src @@ -128,6 +133,7 @@ , hw-bits , hw-prim , hw-rankselect + , hw-xml , lens , mmap , mtl @@ -151,57 +157,54 @@ App.Show App.Naive autogen-modules: Paths_hw_xml - build-depends: hw-xml hs-source-dirs: app ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -msse4.2 test-suite hw-xml-test - import: base, config - , attoparsec - , base - , bytestring - , hedgehog - , hspec - , hw-balancedparens - , hw-bits - , hw-hspec-hedgehog - , hw-prim - , hw-rankselect - , hw-rankselect-base - , vector + import: base, config + , attoparsec + , base + , bytestring + , hedgehog + , hspec + , hw-balancedparens + , hw-bits + , hw-hspec-hedgehog + , hw-prim + , hw-xml + , hw-rankselect + , hw-rankselect-base + , vector type: exitcode-stdio-1.0 main-is: Spec.hs hs-source-dirs: test - build-depends: hw-xml ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover autogen-modules: Paths_hw_xml - 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 - Paths_hw_xml + other-modules: HaskellWorks.Data.Xml.Internal.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 + Paths_hw_xml benchmark bench - import: base, config - , bytestring - , criterion - , hw-balancedparens - , hw-bits - , hw-prim - , mmap - , resourcet - , vector - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: Paths_hw_xml - build-depends: hw-xml - autogen-modules: Paths_hw_xml - hs-source-dirs: bench - ghc-options: -O2 -Wall -msse4.2 - + import: base, config + , bytestring + , criterion + , hw-balancedparens + , hw-bits + , hw-prim + , mmap + , resourcet + , vector + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Paths_hw_xml + build-depends: hw-xml + autogen-modules: Paths_hw_xml + hs-source-dirs: bench + ghc-options: -O2 -Wall -msse4.2 diff --git a/src/HaskellWorks/Data/Xml/Blank.hs b/src/HaskellWorks/Data/Xml/Blank.hs --- a/src/HaskellWorks/Data/Xml/Blank.hs +++ b/src/HaskellWorks/Data/Xml/Blank.hs @@ -5,12 +5,14 @@ ( blankXml ) where -import Data.ByteString as BS +import Data.ByteString (ByteString) import Data.Word import Data.Word8 -import HaskellWorks.Data.Xml.Conduit.Words -import Prelude as P +import HaskellWorks.Data.Xml.Internal.Words +import Prelude +import qualified Data.ByteString as BS + type ExpectedChar = Word8 data BlankState @@ -35,66 +37,66 @@ 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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)) @@ -103,18 +105,18 @@ 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 + 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 + 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 diff --git a/src/HaskellWorks/Data/Xml/Conduit.hs b/src/HaskellWorks/Data/Xml/Conduit.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Xml/Conduit.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} - -module HaskellWorks.Data.Xml.Conduit - ( blankedXmlToInterestBits - , byteStringToBits - , blankedXmlToBalancedParens2 - , compressWordAsBit - , interestingWord8s - , isInterestingWord8 - ) where - -import Data.ByteString as BS -import Data.Word -import Data.Word8 -import HaskellWorks.Data.AtIndex ((!!!)) -import HaskellWorks.Data.Bits.BitWise -import Prelude as P - -import qualified Data.Bits as BITS -import qualified Data.Vector.Storable as DVS - -interestingWord8s :: DVS.Vector Word8 -interestingWord8s = DVS.constructN 256 go - where go :: DVS.Vector Word8 -> Word8 - go v = if w == _bracketleft - || w == _braceleft - || w == _parenleft - || w == _bracketleft - || w == _less - || w == _a - || w == _v - || w == _t - then 1 - else 0 - where w :: Word8 - w = fromIntegral (DVS.length v) -{-# NOINLINE interestingWord8s #-} - -isInterestingWord8 :: Word8 -> Word8 -isInterestingWord8 b = fromIntegral (interestingWord8s !!! fromIntegral b) -{-# INLINABLE isInterestingWord8 #-} - -blankedXmlToInterestBits :: [BS.ByteString] -> [BS.ByteString] -blankedXmlToInterestBits = blankedXmlToInterestBits' "" - -blankedXmlToInterestBits' :: BS.ByteString -> [BS.ByteString] -> [BS.ByteString] -blankedXmlToInterestBits' rs is = case is of - (bs:bss) -> do - let cs = if BS.length rs /= 0 then BS.concat [rs, bs] else bs - let lencs = BS.length cs - let q = lencs `quot` 8 - let (ds, es) = BS.splitAt (q * 8) cs - let (fs, _) = BS.unfoldrN q gen ds - fs:blankedXmlToInterestBits' es bss - [] -> do - let lenrs = BS.length rs - let q = lenrs + 7 `quot` 8 - [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 -> isInterestingWord8 b .|. (m .<. 1)) 0 (BS.take 8 as) - , BS.drop 8 as - ) - -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 :: [BS.ByteString] -> [BS.ByteString] -compressWordAsBit = compressWordAsBit' BS.empty - -compressWordAsBit' :: BS.ByteString -> [BS.ByteString] -> [BS.ByteString] -compressWordAsBit' aBS iBS = case iBS of - (bBS:bBSs) -> do - let (cBS, dBS) = repartitionMod8 aBS bBS - let (cs, _) = BS.unfoldrN (BS.length cBS + 7 `div` 8) gen cBS - cs:compressWordAsBit' dBS bBSs - [] -> do - let (cs, _) = BS.unfoldrN (BS.length aBS + 7 `div` 8) gen aBS - [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 (BS.take 8 xs) - , BS.drop 8 xs - ) - -blankedXmlToBalancedParens2 :: [BS.ByteString] -> [BS.ByteString] -blankedXmlToBalancedParens2 is = case is of - (bs:bss) -> do - let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs) - cs:blankedXmlToBalancedParens2 bss - [] -> [] - 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 :: Word8 -> [Bool] -yieldBitsOfWord8 w = - [ (w .&. BITS.bit 0) /= 0 - , (w .&. BITS.bit 1) /= 0 - , (w .&. BITS.bit 2) /= 0 - , (w .&. BITS.bit 3) /= 0 - , (w .&. BITS.bit 4) /= 0 - , (w .&. BITS.bit 5) /= 0 - , (w .&. BITS.bit 6) /= 0 - , (w .&. BITS.bit 7) /= 0 - ] - -yieldBitsofWord8s :: [Word8] -> [Bool] -yieldBitsofWord8s = P.foldr ((++) . yieldBitsOfWord8) [] - -byteStringToBits :: [BS.ByteString] -> [Bool] -byteStringToBits is = case is of - (bs:bss) -> yieldBitsofWord8s (BS.unpack bs) ++ byteStringToBits bss - [] -> [] diff --git a/src/HaskellWorks/Data/Xml/Conduit/Blank.hs b/src/HaskellWorks/Data/Xml/Conduit/Blank.hs deleted file mode 100644 --- a/src/HaskellWorks/Data/Xml/Conduit/Blank.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# OPTIONS_GHC-funbox-strict-fields #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module HaskellWorks.Data.Xml.Conduit.Blank - ( blankXml - , BlankData(..) - ) where - -import Data.ByteString as BS -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 - | InMeta - | InCdataTag - | InCdata !Int - | InRem !Int - | InIdent - -data BlankData = BlankData - { blankState :: !BlankState - , blankA :: !Word8 - , blankB :: !Word8 - , blankC :: !ByteString - } - -blankXml :: [BS.ByteString] -> [BS.ByteString] -blankXml = blankXmlPlan1 BS.empty InXml - -blankXmlPlan1 :: BS.ByteString -> BlankState -> [BS.ByteString] -> [BS.ByteString] -blankXmlPlan1 as lastState is = case is of - (bs:bss) -> 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 bss - Nothing -> blankXmlPlan1 cs lastState bss - Nothing -> blankXmlPlan1 cs lastState bss - [] -> [BS.map (const _space) as] - -blankXmlPlan2 :: Word8 -> Word8 -> BlankState -> [BS.ByteString] -> [BS.ByteString] -blankXmlPlan2 a b lastState is = case is of - (cs:css) -> blankXmlRun False a b cs lastState css - [] -> blankXmlRun True a b (BS.pack [_space, _space]) lastState [] - -blankXmlRun :: Bool -> Word8 -> Word8 -> BS.ByteString -> BlankState -> [BS.ByteString] -> [BS.ByteString] -blankXmlRun done a b cs lastState is = do - let (!ds, Just (BlankData !nextState _ _ _)) = unfoldrN (BS.length cs) blankByteString (BlankData lastState a b cs) - 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) - if done - then [ds] - else ds:blankXmlPlan2 yy zz nextState is - -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 #-} - -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 #-} - -isEndTag :: Word8 -> Word8 -> Bool -isEndTag a b = a == _less && b == _slash -{-# INLINE isEndTag #-} - -isTagClose :: Word8 -> Word8 -> Bool -isTagClose a b = a == _slash || ((a == _slash || a == _question) && b == _greater) -{-# INLINE isTagClose #-} - -isMetaStart :: Word8 -> Word8 -> Bool -isMetaStart a b = a == _less && b == _exclam -{-# INLINE isMetaStart #-} - -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 deleted file mode 100644 --- a/src/HaskellWorks/Data/Xml/Conduit/Words.hs +++ /dev/null @@ -1,36 +0,0 @@ -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/Decode.hs b/src/HaskellWorks/Data/Xml/Decode.hs --- a/src/HaskellWorks/Data/Xml/Decode.hs +++ b/src/HaskellWorks/Data/Xml/Decode.hs @@ -4,7 +4,7 @@ import Control.Lens import Control.Monad import Data.Foldable -import Data.Monoid ((<>)) +import Data.Semigroup ((<>)) import HaskellWorks.Data.Xml.DecodeError import HaskellWorks.Data.Xml.DecodeResult import HaskellWorks.Data.Xml.Value 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 @@ -22,7 +22,7 @@ | XmlElementTypeCData | XmlElementTypeMeta String -parseXmlString :: (P.Parser t Word8, IsString t) => T.Parser t String +parseXmlString :: (P.Parser t Word8) => T.Parser t String parseXmlString = do q <- satisfyChar (=='"') <|> satisfyChar (=='\'') many (satisfyChar (/= q)) @@ -36,10 +36,10 @@ doc = const XmlElementTypeDocument <$> string "?xml" element = XmlElementTypeElement <$> parseXmlToken -parseXmlToken :: (P.Parser t Word8, IsString t) => T.Parser t String +parseXmlToken :: (P.Parser t Word8) => T.Parser t String parseXmlToken = many $ satisfyChar isNameChar "invalid string character" -parseXmlAttributeName :: (P.Parser t Word8, IsString t) => T.Parser t String +parseXmlAttributeName :: (P.Parser t Word8) => T.Parser t String parseXmlAttributeName = parseXmlToken isNameStartChar :: Char -> Bool diff --git a/src/HaskellWorks/Data/Xml/Internal/BalancedParens.hs b/src/HaskellWorks/Data/Xml/Internal/BalancedParens.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Internal/BalancedParens.hs @@ -0,0 +1,42 @@ +module HaskellWorks.Data.Xml.Internal.BalancedParens + ( blankedXmlToBalancedParens + ) where + +import Data.ByteString (ByteString) +import Data.Word +import Data.Word8 + +import qualified Data.ByteString as BS + +data MiniBP = MiniN | MiniT | MiniF | MiniTF + +blankedXmlToBalancedParens :: [ByteString] -> [ByteString] +blankedXmlToBalancedParens is = case is of + (bs:bss) -> do + let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs) + cs:blankedXmlToBalancedParens bss + [] -> [] + 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 + +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 + diff --git a/src/HaskellWorks/Data/Xml/Internal/Blank.hs b/src/HaskellWorks/Data/Xml/Internal/Blank.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Internal/Blank.hs @@ -0,0 +1,153 @@ +{-# OPTIONS_GHC-funbox-strict-fields #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Xml.Internal.Blank + ( blankXml + , BlankData(..) + ) where + +import Data.ByteString (ByteString) +import Data.Semigroup ((<>)) +import Data.Word +import Data.Word8 +import HaskellWorks.Data.Xml.Internal.Words +import Prelude + +import qualified Data.ByteString as BS + +type ExpectedChar = Word8 + +data BlankState + = InXml + | InTag + | InAttrList + | InCloseTag + | InClose + | InBang !Int + | InString !ExpectedChar + | InText + | InMeta + | InCdataTag + | InCdata !Int + | InRem !Int + | InIdent + +data BlankData = BlankData + { blankState :: !BlankState + , blankA :: !Word8 + , blankB :: !Word8 + , blankC :: !ByteString + } + +blankXml :: [ByteString] -> [ByteString] +blankXml = blankXmlPlan1 BS.empty InXml + +blankXmlPlan1 :: ByteString -> BlankState -> [ByteString] -> [ByteString] +blankXmlPlan1 as lastState is = case is of + (bs:bss) -> 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 bss + Nothing -> blankXmlPlan1 cs lastState bss + Nothing -> blankXmlPlan1 cs lastState bss + [] -> [BS.map (const _space) as] + +blankXmlPlan2 :: Word8 -> Word8 -> BlankState -> [ByteString] -> [ByteString] +blankXmlPlan2 a b lastState is = case is of + (cs:css) -> blankXmlRun False a b cs lastState css + [] -> blankXmlRun True a b (BS.pack [_space, _space]) lastState [] + +blankXmlRun :: Bool -> Word8 -> Word8 -> ByteString -> BlankState -> [ByteString] -> [ByteString] +blankXmlRun done a b cs lastState is = do + let (!ds, Just (BlankData !nextState _ _ _)) = BS.unfoldrN (BS.length cs) blankByteString (BlankData lastState a b cs) + 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) + if done + then [ds] + else ds:blankXmlPlan2 yy zz nextState is + +mkNext :: Word8 -> BlankState -> Word8 -> 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 #-} + +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 #-} + +isEndTag :: Word8 -> Word8 -> Bool +isEndTag a b = a == _less && b == _slash +{-# INLINE isEndTag #-} + +isTagClose :: Word8 -> Word8 -> Bool +isTagClose a b = a == _slash || ((a == _slash || a == _question) && b == _greater) +{-# INLINE isTagClose #-} + +isMetaStart :: Word8 -> Word8 -> Bool +isMetaStart a b = a == _less && b == _exclam +{-# INLINE isMetaStart #-} + +isCdataEnd :: Word8 -> Word8 -> Bool +isCdataEnd a b = a == _bracketright && b == _greater +{-# INLINE isCdataEnd #-} diff --git a/src/HaskellWorks/Data/Xml/Internal/ByteString.hs b/src/HaskellWorks/Data/Xml/Internal/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Internal/ByteString.hs @@ -0,0 +1,14 @@ +module HaskellWorks.Data.Xml.Internal.ByteString + ( repartitionMod8 + ) where + +import Data.ByteString (ByteString) + +import qualified Data.ByteString as BS + +repartitionMod8 :: ByteString -> ByteString -> (ByteString, 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 +{-# INLINE repartitionMod8 #-} diff --git a/src/HaskellWorks/Data/Xml/Internal/List.hs b/src/HaskellWorks/Data/Xml/Internal/List.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Internal/List.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module HaskellWorks.Data.Xml.Internal.List + ( blankedXmlToInterestBits + , compressWordAsBit + ) where + +import Data.ByteString (ByteString) +import Data.Word +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Xml.Internal.ByteString +import HaskellWorks.Data.Xml.Internal.Tables +import Prelude + +import qualified Data.ByteString as BS + +blankedXmlToInterestBits :: [ByteString] -> [ByteString] +blankedXmlToInterestBits = blankedXmlToInterestBits' "" + +blankedXmlToInterestBits' :: ByteString -> [ByteString] -> [ByteString] +blankedXmlToInterestBits' rs is = case is of + (bs:bss) -> do + let cs = if BS.length rs /= 0 then BS.concat [rs, bs] else bs + let lencs = BS.length cs + let q = lencs `quot` 8 + let (ds, es) = BS.splitAt (q * 8) cs + let (fs, _) = BS.unfoldrN q gen ds + fs:blankedXmlToInterestBits' es bss + [] -> do + let lenrs = BS.length rs + let q = lenrs + 7 `quot` 8 + [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 -> isInterestingWord8 b .|. (m .<. 1)) 0 (BS.take 8 as) + , BS.drop 8 as + ) + +compressWordAsBit :: [ByteString] -> [ByteString] +compressWordAsBit = compressWordAsBit' BS.empty + +compressWordAsBit' :: ByteString -> [ByteString] -> [ByteString] +compressWordAsBit' aBS iBS = case iBS of + (bBS:bBSs) -> do + let (cBS, dBS) = repartitionMod8 aBS bBS + let (cs, _) = BS.unfoldrN (BS.length cBS + 7 `div` 8) gen cBS + cs:compressWordAsBit' dBS bBSs + [] -> do + let (cs, _) = BS.unfoldrN (BS.length aBS + 7 `div` 8) gen aBS + [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 (BS.take 8 xs) + , BS.drop 8 xs + ) diff --git a/src/HaskellWorks/Data/Xml/Internal/Tables.hs b/src/HaskellWorks/Data/Xml/Internal/Tables.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Internal/Tables.hs @@ -0,0 +1,32 @@ +module HaskellWorks.Data.Xml.Internal.Tables + ( interestingWord8s + , isInterestingWord8 + ) where + +import Data.Word +import Data.Word8 +import HaskellWorks.Data.AtIndex ((!!!)) +import Prelude as P + +import qualified Data.Vector.Storable as DVS + +interestingWord8s :: DVS.Vector Word8 +interestingWord8s = DVS.constructN 256 go + where go :: DVS.Vector Word8 -> Word8 + go v = if w == _bracketleft + || w == _braceleft + || w == _parenleft + || w == _bracketleft + || w == _less + || w == _a + || w == _v + || w == _t + then 1 + else 0 + where w :: Word8 + w = fromIntegral (DVS.length v) +{-# NOINLINE interestingWord8s #-} + +isInterestingWord8 :: Word8 -> Word8 +isInterestingWord8 b = fromIntegral (interestingWord8s !!! fromIntegral b) +{-# INLINABLE isInterestingWord8 #-} diff --git a/src/HaskellWorks/Data/Xml/Internal/ToIbBp64.hs b/src/HaskellWorks/Data/Xml/Internal/ToIbBp64.hs --- a/src/HaskellWorks/Data/Xml/Internal/ToIbBp64.hs +++ b/src/HaskellWorks/Data/Xml/Internal/ToIbBp64.hs @@ -6,39 +6,19 @@ module HaskellWorks.Data.Xml.Internal.ToIbBp64 ( toBalancedParens64 , toInterestBits64 - , toBalancedParens64' - , toInterestBits64' , toIbBp64 ) where -import Control.Applicative -import Data.Word -import HaskellWorks.Data.Xml.Conduit -import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml (BlankedXml (..)) -import HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits (blankedXmlToInterestBits, genInterestForever) - -import qualified Data.ByteString as BS -import qualified Data.Vector.Storable as DVS - -genBitWordsForever :: BS.ByteString -> Maybe (Word8, BS.ByteString) -genBitWordsForever bs = BS.uncons bs <|> Just (0, bs) -{-# INLINABLE genBitWordsForever #-} - -toBalancedParens64 :: BlankedXml -> DVS.Vector Word64 -toBalancedParens64 (BlankedXml bj) = DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS) - where interestBS = BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 bj)) - newLen = (BS.length interestBS + 7) `div` 8 * 8 - -toBalancedParens64' :: BlankedXml -> [BS.ByteString] -toBalancedParens64' (BlankedXml bj) = compressWordAsBit (blankedXmlToBalancedParens2 bj) +import Data.ByteString (ByteString) +import HaskellWorks.Data.Xml.Internal.BalancedParens +import HaskellWorks.Data.Xml.Internal.List +import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml (BlankedXml (..)) -toInterestBits64 :: BlankedXml -> DVS.Vector Word64 -toInterestBits64 (BlankedXml bj) = DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS) - where interestBS = BS.concat (blankedXmlToInterestBits bj) - newLen = (BS.length interestBS + 7) `div` 8 * 8 +toBalancedParens64 :: BlankedXml -> [ByteString] +toBalancedParens64 (BlankedXml bj) = compressWordAsBit (blankedXmlToBalancedParens bj) -toInterestBits64' :: BlankedXml -> [BS.ByteString] -toInterestBits64' (BlankedXml bj) = blankedXmlToInterestBits bj +toInterestBits64 :: BlankedXml -> [ByteString] +toInterestBits64 (BlankedXml bj) = blankedXmlToInterestBits bj -toIbBp64 :: BlankedXml -> [(BS.ByteString, BS.ByteString)] -toIbBp64 bj = zip (toInterestBits64' bj) (toBalancedParens64' bj) +toIbBp64 :: BlankedXml -> [(ByteString, ByteString)] +toIbBp64 bj = zip (toInterestBits64 bj) (toBalancedParens64 bj) diff --git a/src/HaskellWorks/Data/Xml/Internal/Words.hs b/src/HaskellWorks/Data/Xml/Internal/Words.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Internal/Words.hs @@ -0,0 +1,36 @@ +module HaskellWorks.Data.Xml.Internal.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/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 @@ -11,7 +11,8 @@ import Control.Applicative import Data.Word import HaskellWorks.Data.BalancedParens as BP -import HaskellWorks.Data.Xml.Conduit +import HaskellWorks.Data.Xml.Internal.BalancedParens +import HaskellWorks.Data.Xml.Internal.List import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml import qualified Data.ByteString as BS @@ -28,20 +29,20 @@ instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word8))) where fromBlankedXml bj = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) - where interestBS = BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 (getBlankedXml bj))) + where interestBS = BS.concat (compressWordAsBit (blankedXmlToBalancedParens (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 (compressWordAsBit (blankedXmlToBalancedParens2 (getBlankedXml bj))) + where interestBS = BS.concat (compressWordAsBit (blankedXmlToBalancedParens (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 (compressWordAsBit (blankedXmlToBalancedParens2 (getBlankedXml bj))) + where interestBS = BS.concat (compressWordAsBit (blankedXmlToBalancedParens (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 (compressWordAsBit (blankedXmlToBalancedParens2 (getBlankedXml bj))) + where interestBS = BS.concat (compressWordAsBit (blankedXmlToBalancedParens (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 --- a/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs @@ -9,7 +9,7 @@ ) where import GHC.Generics -import HaskellWorks.Data.Xml.Conduit.Blank +import HaskellWorks.Data.Xml.Internal.Blank import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS 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 @@ -17,7 +17,7 @@ import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.FromByteString import HaskellWorks.Data.RankSelect.Poppy512 -import HaskellWorks.Data.Xml.Conduit +import HaskellWorks.Data.Xml.Internal.List import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml import qualified Data.ByteString as BS 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 @@ -11,7 +11,6 @@ ) where import Control.DeepSeq (NFData (..)) -import Data.ByteString.Internal as BSI import Data.String import Data.Word import Foreign.ForeignPtr @@ -30,6 +29,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Internal as BSI import qualified Data.Vector.Storable as DVS import qualified HaskellWorks.Data.BalancedParens as BP import qualified HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParens as CBP 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,7 +3,7 @@ ( xmlTokenAt ) where -import Data.ByteString.Internal as BSI +import Data.ByteString (ByteString) import HaskellWorks.Data.Bits.BitWise import HaskellWorks.Data.Drop import HaskellWorks.Data.Positioning 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 @@ -19,7 +19,7 @@ ) where import Control.Lens -import Data.Monoid ((<>)) +import Data.Semigroup ((<>)) import HaskellWorks.Data.Xml.RawDecode import HaskellWorks.Data.Xml.RawValue @@ -66,8 +66,8 @@ rawDecode (RawError msg ) = XmlError msg mkXmlElement :: String -> [RawValue] -> Value -mkXmlElement n (RawAttrList as:cs) = XmlElement n (mkAttrs as) (rawDecode <$> cs) -mkXmlElement n cs = XmlElement n [] (rawDecode <$> cs) +mkXmlElement n (RawAttrList as:cs) = XmlElement n (mkAttrs as) (rawDecode <$> cs) +mkXmlElement n cs = XmlElement n [] (rawDecode <$> cs) mkAttrs :: [RawValue] -> [(String, String)] mkAttrs (RawAttrName n:RawAttrValue v:cs) = (n, v):mkAttrs cs diff --git a/test/HaskellWorks/Data/Xml/Conduit/BlankSpec.hs b/test/HaskellWorks/Data/Xml/Conduit/BlankSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Data/Xml/Conduit/BlankSpec.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module HaskellWorks.Data.Xml.Conduit.BlankSpec (spec) where - -import Data.Char -import Data.Semigroup ((<>)) -import HaskellWorks.Data.ByteString -import HaskellWorks.Data.Xml.Conduit.Blank -import HaskellWorks.Hspec.Hedgehog -import Hedgehog -import Test.Hspec - -import qualified Data.ByteString as BS -import qualified Hedgehog.Gen as G -import qualified Hedgehog.Range as R - -{-# 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) $ requireTest $ do - BS.concat (blankXml [original]) === 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" $ requireTest $ 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 = blankXml inputOriginalChunked - - n <- forAll $ G.int (R.linear 0 16) - - let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix - let inputShiftedChunked = chunkedBy 16 inputShifted - let inputShiftedBlanked = blankXml inputShiftedChunked - - noSpaces (BS.concat inputShiftedBlanked) === noSpaces (BS.concat inputOriginalBlanked) - it "Can blank across chunk boundaries with auto-close tags" $ requireTest $ do - let inputOriginalPrefix = "" - let inputOriginalSuffix = "\n" - let inputOriginal = inputOriginalPrefix <> inputOriginalSuffix - let inputOriginalChunked = chunkedBy 16 inputOriginal - let inputOriginalBlanked = blankXml inputOriginalChunked - - n <- forAll $ G.int (R.linear 0 16) - - let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix - let inputShiftedChunked = chunkedBy 16 inputShifted - let inputShiftedBlanked = 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 === expected - it "Can blank across chunk boundaries with auto-close tags" $ requireTest $ do - let inputOriginalPrefix = "" - let inputOriginalSuffix = "\n" - let inputOriginal = inputOriginalPrefix <> inputOriginalSuffix - let inputOriginalChunked = chunkedBy 16 inputOriginal - let inputOriginalBlanked = blankXml inputOriginalChunked - - let n = 15 - let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix - let inputShiftedChunked = chunkedBy 16 inputShifted - let inputShiftedBlanked = 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 === expected diff --git a/test/HaskellWorks/Data/Xml/Internal/BlankSpec.hs b/test/HaskellWorks/Data/Xml/Internal/BlankSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Xml/Internal/BlankSpec.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HaskellWorks.Data.Xml.Internal.BlankSpec (spec) where + +import Data.Char +import Data.Semigroup ((<>)) +import HaskellWorks.Data.ByteString +import HaskellWorks.Data.Xml.Internal.Blank +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Test.Hspec + +import qualified Data.ByteString as BS +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R + +{-# 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) $ requireTest $ do + BS.concat (blankXml [original]) === 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.Internal.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" $ requireTest $ 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 = blankXml inputOriginalChunked + + n <- forAll $ G.int (R.linear 0 16) + + let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix + let inputShiftedChunked = chunkedBy 16 inputShifted + let inputShiftedBlanked = blankXml inputShiftedChunked + + noSpaces (BS.concat inputShiftedBlanked) === noSpaces (BS.concat inputOriginalBlanked) + it "Can blank across chunk boundaries with auto-close tags" $ requireTest $ do + let inputOriginalPrefix = "" + let inputOriginalSuffix = "\n" + let inputOriginal = inputOriginalPrefix <> inputOriginalSuffix + let inputOriginalChunked = chunkedBy 16 inputOriginal + let inputOriginalBlanked = blankXml inputOriginalChunked + + n <- forAll $ G.int (R.linear 0 16) + + let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix + let inputShiftedChunked = chunkedBy 16 inputShifted + let inputShiftedBlanked = 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 === expected + it "Can blank across chunk boundaries with auto-close tags" $ requireTest $ do + let inputOriginalPrefix = "" + let inputOriginalSuffix = "\n" + let inputOriginal = inputOriginalPrefix <> inputOriginalSuffix + let inputOriginalChunked = chunkedBy 16 inputOriginal + let inputOriginalBlanked = blankXml inputOriginalChunked + + let n = 15 + let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix + let inputShiftedChunked = chunkedBy 16 inputShifted + let inputShiftedBlanked = 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 === expected diff --git a/test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs b/test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs --- a/test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs +++ b/test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs @@ -1,14 +1,17 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec(spec) where +module HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec + ( spec + ) where import Data.Monoid ((<>)) import Data.String import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.ByteString -import HaskellWorks.Data.Xml.Conduit -import HaskellWorks.Data.Xml.Conduit.Blank +import HaskellWorks.Data.Xml.Internal.BalancedParens +import HaskellWorks.Data.Xml.Internal.Blank +import HaskellWorks.Data.Xml.Internal.List import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml import HaskellWorks.Hspec.Hedgehog import Hedgehog @@ -22,14 +25,14 @@ spec = describe "HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec" $ do it "Blanking XML should work 1" $ requireTest $ do let blankedXml = BlankedXml [">"] - let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 (getBlankedXml blankedXml))) + let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens (getBlankedXml blankedXml))) bp === fromString "11011000" it "Blanking XML should work 2" $ requireTest $ do let blankedXml = BlankedXml [ "<><><><><><><><>" , "<><><><><><><><>" ] - let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 (getBlankedXml blankedXml))) + let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens (getBlankedXml blankedXml))) bp === fromString "1010101010101010\ \1010101010101010" @@ -46,12 +49,12 @@ unchunkedInput === BS.concat chunkedInput it "Blanking XML should work 3" $ requireTest $ do - let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 chunkedBlank)) + let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens chunkedBlank)) annotate $ "Good: " <> show chunkedBlank bp === fromString "11101010 10001101 01010100" it "Blanking XML should work 3" $ requireTest $do - let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 chunkedBadBlank)) + let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens chunkedBadBlank)) annotate $ "Bad: " <> show chunkedBadBlank bp === fromString "11101010 10001101 01010100" @@ -71,4 +74,4 @@ mkBlank csize bs = blankXml (chunkedBy csize bs) mkBits :: [BS.ByteString] -> [BS.ByteString] -mkBits = compressWordAsBit . blankedXmlToBalancedParens2 +mkBits = compressWordAsBit . blankedXmlToBalancedParens 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,13 +2,14 @@ module HaskellWorks.Data.Xml.Token.TokenizeSpec (spec) where -import Data.ByteString as BS +import Data.ByteString (ByteString) import HaskellWorks.Data.Xml.Token.Tokenize import HaskellWorks.Hspec.Hedgehog import Hedgehog import Test.Hspec import qualified Data.Attoparsec.ByteString.Char8 as BC +import qualified Data.ByteString as BS {-# ANN module ("HLint: ignore Redundant do" :: String) #-} @@ -16,7 +17,7 @@ parseXmlToken' = BC.parseOnly parseXmlToken spec :: Spec -spec = describe "Data.Conduit.Succinct.XmlSpec" $ do +spec = describe "HaskellWorks.Data.Xml.Token.TokenizeSpec" $ do describe "When parsing single token at beginning of text" $ do it "Empty Xml should produce no bits" $ requireTest $ parseXmlToken' "" === Left "not enough input"