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