packages feed

hw-xml (empty) → 0.0.0.1

raw patch · 32 files changed

+2078/−0 lines, 32 filesdep +QuickCheckdep +ansi-wl-pprintdep +arraysetup-changed

Dependencies added: QuickCheck, ansi-wl-pprint, array, attoparsec, base, bytestring, conduit, containers, criterion, hspec, hw-balancedparens, hw-bits, hw-conduit, hw-diagnostics, hw-parser, hw-prim, hw-rankselect, hw-rankselect-base, hw-xml, mmap, mono-traversable, parsec, resourcet, text, transformers, vector, word8

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright John Ky, Alexey Raga (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,31 @@+# hw-xml+[![CircleCI](https://circleci.com/gh/haskell-works/hw-xml.svg?style=svg)](https://circleci.com/gh/haskell-works/hw-xml)++`hw-xml` is a succinct XML parsing library. It uses succinct data-structures to allow traversal of large XML strings with minimal memory overhead.++It is currently considered experimental and is not as optimised as it could be.++For an example, see app/Main.hs++```+benchmarking XmlBig/Run blankXml+time                 2.212 s    (1.971 s .. 2.652 s)+                     0.996 R²   (0.989 R² .. 1.000 R²)+mean                 2.138 s    (2.073 s .. 2.186 s)+std dev              73.37 ms   (0.0 s .. 83.51 ms)+variance introduced by outliers: 19% (moderately inflated)++benchmarking XmlBig/Run xmlToInterestBits3+time                 2.497 s    (2.449 s .. 2.531 s)+                     1.000 R²   (1.000 R² .. 1.000 R²)+mean                 2.531 s    (2.515 s .. 2.540 s)+std dev              13.90 ms   (0.0 s .. 14.76 ms)+variance introduced by outliers: 19% (moderately inflated)++benchmarking XmlBig/loadXml+time                 2.768 s    (2.698 s .. 2.857 s)+                     1.000 R²   (1.000 R² .. 1.000 R²)+mean                 2.780 s    (2.767 s .. 2.790 s)+std dev              15.40 ms   (0.0 s .. 17.48 ms)+variance introduced by outliers: 19% (moderately inflated)+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import qualified Data.ByteString                                  as BS+import qualified Data.Vector.Storable                             as DVS+import           Data.Word+import           GHC.Conc+import           HaskellWorks.Data.Bits.BitShown+import           HaskellWorks.Data.FromByteString+import           HaskellWorks.Data.BalancedParens.Simple+import           HaskellWorks.Data.Xml.Succinct.Cursor+import           HaskellWorks.Diagnostics.Time+import           System.Mem++readXml :: String -> IO (XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)))+readXml path = do+  bs <- BS.readFile path+  print "Read file"+  !cursor <- measure (fromByteString bs :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)))+  print "Created cursor"+  return cursor++main :: IO ()+main = do+  performGC+  !c0 <- readXml "сorpus/105mb.xml"+  !c1 <- readXml "сorpus/105mb.xml"+  !c2 <- readXml "сorpus/105mb.xml"+  !c3 <- readXml "сorpus/105mb.xml"+  !c4 <- readXml "сorpus/105mb.xml"+  !c5 <- readXml "сorpus/105mb.xml"+  !c6 <- readXml "сorpus/105mb.xml"+  !c7 <- readXml "сorpus/105mb.xml"+  !c8 <- readXml "сorpus/105mb.xml"+  !c9 <- readXml "сorpus/105mb.xml"+  print "Returned from readXml"+  performGC+  threadDelay 100000000+  print c0+  print c1+  print c2+  print c3+  print c4+  print c5+  print c6+  print c7+  print c8+  print c9
+ bench/Main.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import           Criterion.Main+import           Control.Monad.Trans.Resource                        (MonadThrow)+import qualified Data.ByteString                                     as BS+import qualified Data.ByteString.Internal                            as BSI+import           Data.Conduit+import qualified Data.Vector.Storable                                as DVS+import           Data.Word+import           Foreign+import           HaskellWorks.Data.Bits.BitShown+import           HaskellWorks.Data.Conduit.List+import           HaskellWorks.Data.FromByteString+import           HaskellWorks.Data.Xml.Conduit+import           HaskellWorks.Data.Xml.Conduit.Blank+import           HaskellWorks.Data.Xml.Succinct.Cursor+import           HaskellWorks.Data.BalancedParens.Simple+import           System.IO.MMap++setupEnvXml :: FilePath -> IO BS.ByteString+setupEnvXml filepath = do+  (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr filepath ReadOnly Nothing+  let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size+  return bs++loadXml :: BS.ByteString -> XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))+loadXml bs = fromByteString bs :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))++xmlToInterestBits3 :: MonadThrow m => Conduit BS.ByteString m BS.ByteString+xmlToInterestBits3 = blankXml =$= blankedXmlToInterestBits++runCon :: Conduit i [] BS.ByteString -> i -> BS.ByteString+runCon con bs = BS.concat $ runListConduit con [bs]++benchRankXml8mbConduits :: [Benchmark]+benchRankXml8mbConduits =+  [ env (setupEnvXml "corpus/8mb.xml") $ \bs -> bgroup "Xml4mb"+    [ bench "Run blankXml                    "  (whnf (runCon blankXml                  ) bs)+    , bench "Run xmlToInterestBits3          "  (whnf (runCon xmlToInterestBits3        ) bs)+    , bench "loadXml" (whnf loadXml bs)+    ]+  ]++benchRankXmlBigConduits :: [Benchmark]+benchRankXmlBigConduits =+  [ env (setupEnvXml "corpus/105mb.xml") $ \bs -> bgroup "XmlBig"+    [ bench "Run blankXml                    "  (whnf (runCon blankXml                  ) bs)+    , bench "Run xmlToInterestBits3          "  (whnf (runCon xmlToInterestBits3        ) bs)+    , bench "loadXml" (whnf loadXml bs)+    ]+  ]++main :: IO ()+--main = defaultMain benchRankXml8mbConduits+main = defaultMain benchRankXmlBigConduits
+ hw-xml.cabal view
@@ -0,0 +1,135 @@+name:                   hw-xml+version:                0.0.0.1+synopsis:               Conduits for tokenizing streams.+description:            Please see README.md+homepage:               http://github.com/haskell-works/hw-xml#readme+license:                BSD3+license-file:           LICENSE+author:                 John Ky, Alexey Raga+maintainer:             alexey.raga@gmail.com+copyright:              2016 John Ky, Alexey Raga+category:               Data, XML+build-type:             Simple+extra-source-files:     README.md+cabal-version:          >= 1.22+data-files:             test/data/sample.xml++executable hw-xml-example+  hs-source-dirs:       app+  main-is:              Main.hs+  ghc-options:          -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -msse4.2+  build-depends:        base                          >= 4          && < 5+                      , bytestring+                      , conduit+                      , criterion+                      , hw-balancedparens             >= 0.1.0.0+                      , hw-bits                       >= 0.4.0.0+                      , hw-conduit                    >= 0.1.0.0+                      , hw-diagnostics                >= 0.0.0.5+                      , hw-xml+                      , hw-prim                       >= 0.4.0.0+                      , hw-rankselect                 >= 0.7.0.0+                      , mmap+                      , resourcet+                      , vector+  default-language:     Haskell2010++library+  hs-source-dirs:       src+  exposed-modules:      HaskellWorks.Data.Xml+                      , HaskellWorks.Data.Xml.CharLike+                      , HaskellWorks.Data.Xml.Conduit+                      , HaskellWorks.Data.Xml.Conduit.Blank+                      , HaskellWorks.Data.Xml.Conduit.Words+                      , HaskellWorks.Data.Xml.Grammar+                      , HaskellWorks.Data.Xml.Succinct+                      , HaskellWorks.Data.Xml.Succinct.Cursor+                      , HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParens+                      , HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml+                      , HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits+                      , HaskellWorks.Data.Xml.Succinct.Cursor.Internal+                      , HaskellWorks.Data.Xml.Succinct.Cursor.Token+                      , HaskellWorks.Data.Xml.Succinct.Index+                      , HaskellWorks.Data.Xml.Token.Tokenize+                      , HaskellWorks.Data.Xml.Token.Types+                      , HaskellWorks.Data.Xml.Token+                      , HaskellWorks.Data.Xml.Type+                      , HaskellWorks.Data.Xml.Value+  build-depends:        base                          >= 4          && < 5+                      , array+                      , ansi-wl-pprint+                      , attoparsec+                      , bytestring+                      , conduit+                      , containers+                      , hw-balancedparens             >= 0.1.0.0+                      , hw-bits                       >= 0.4.0.0+                      , hw-conduit                    >= 0.1.0.0+                      , hw-parser+                      , hw-prim                       >= 0.4.0.0+                      , hw-rankselect                 >= 0.7.0.0+                      , hw-rankselect-base            >= 0.2.0.0+                      , mono-traversable+                      , resourcet+                      , text+                      , vector+                      , word8++  default-language:     Haskell2010+  ghc-options:          -Wall -O2 -msse4.2++test-suite hw-xml-test+  type:                 exitcode-stdio-1.0+  hs-source-dirs:       test+  main-is:              Spec.hs+  other-modules:        HaskellWorks.Data.Xml.Token.TokenizeSpec+                      , HaskellWorks.Data.Xml.Succinct.CursorSpec+                      , HaskellWorks.Data.Xml.TypeSpec+                      , HaskellWorks.Data.Xml.ValueSpec+                      , HaskellWorks.Data.Xml.Succinct.Cursor.InterestBitsSpec+  build-depends:        base                          >= 4          && < 5+                      , attoparsec+                      , bytestring+                      , conduit+                      , containers+                      , hspec+                      , hw-balancedparens             >= 0.1.0.0+                      , hw-bits                       >= 0.4.0.0+                      , hw-conduit                    >= 0.1.0.0+                      , hw-xml+                      , hw-prim                       >= 0.4.0.0+                      , hw-rankselect                 >= 0.7.0.0+                      , hw-rankselect-base            >= 0.2.0.0+                      , mmap+                      , parsec+                      , QuickCheck+                      , resourcet+                      , transformers+                      , vector+  ghc-options:          -threaded -rtsopts -with-rtsopts=-N+  -- -Wall+  default-language:     Haskell2010++source-repository head+  type:     git+  location: https://github.com/haskell-works/hw-xml++benchmark bench+    Type: exitcode-stdio-1.0+    HS-Source-Dirs: bench+    Main-Is: Main.hs+    GHC-Options: -O2 -Wall -msse4.2+    Default-Language: Haskell2010+    Build-Depends:      base                          >= 4          && < 5+                      , bytestring+                      , conduit+                      , criterion+                      , hw-balancedparens             >= 0.1.0.0+                      , hw-bits                       >= 0.4.0.0+                      , hw-conduit                    >= 0.1.0.0+                      , hw-xml+                      , hw-prim                       >= 0.4.0.0+                      , hw-rankselect                 >= 0.7.0.0+                      , mmap+                      , resourcet+                      , vector
+ src/HaskellWorks/Data/Xml.hs view
@@ -0,0 +1,11 @@+-- |+-- Copyright: 2016 John Ky+-- License: MIT+--+-- Xml+module HaskellWorks.Data.Xml+    ( module X+    ) where++import           HaskellWorks.Data.Xml.Succinct  as X+import           HaskellWorks.Data.Xml.Token     as X
+ src/HaskellWorks/Data/Xml/CharLike.hs view
@@ -0,0 +1,22 @@+module HaskellWorks.Data.Xml.CharLike where++import           Data.Word+import           Data.Word8 as W++class XmlCharLike c where+  isElementStart :: c -> Bool+  isExclam       :: c -> Bool+  isHyphen       :: c -> Bool+  isOpenBracket  :: c -> Bool+  isQuestion     :: c -> Bool+  isQuote        :: c -> Bool+  isSpace        :: c -> Bool++instance XmlCharLike Word8 where+  isElementStart     = (== _less)+  isExclam           = (== _exclam)+  isHyphen           = (== _hyphen)+  isOpenBracket      = (== _bracketleft)+  isQuestion         = (== _question)+  isQuote c          = c == _quotedbl || c == _quotesingle+  isSpace            = W.isSpace
+ src/HaskellWorks/Data/Xml/Conduit.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes        #-}++module HaskellWorks.Data.Xml.Conduit+  ( blankedXmlToInterestBits+  , byteStringToBits+  , blankedXmlToBalancedParens+  , blankedXmlToBalancedParens2+  , compressWordAsBit+  , interestingWord8s+  ) where++import           Control.Monad+import           Data.Array.Unboxed             as A+import qualified Data.Bits                      as BITS+import           Data.ByteString                as BS+import           Data.Conduit+import           Data.Int+import           Data.Word+import           Data.Word8+import           HaskellWorks.Data.Bits.BitWise+import           Prelude                        as P++interestingWord8s :: A.UArray Word8 Word8+interestingWord8s = A.array (0, 255) [+  (w, if w == _bracketleft+         || w == _braceleft+         || w == _parenleft+         || w == _bracketleft+         || w == _less+         || w == _a || w == _v || w == _t+    then 1+    else 0)+  | w <- [0 .. 255]]++blankedXmlToInterestBits :: Monad m => Conduit BS.ByteString m BS.ByteString+blankedXmlToInterestBits = blankedXmlToInterestBits' ""++padRight :: Word8 -> Int -> BS.ByteString -> BS.ByteString+padRight w n bs = if BS.length bs >= n then bs else fst (BS.unfoldrN n gen bs)+  where gen :: ByteString -> Maybe (Word8, ByteString)+        gen cs = case BS.uncons cs of+          Just (c, ds) -> Just (c, ds)+          Nothing      -> Just (w, BS.empty)++blankedXmlToInterestBits' :: Monad m => BS.ByteString -> Conduit BS.ByteString m BS.ByteString+blankedXmlToInterestBits' rs = do+  mbs <- await+  case mbs of+    Just bs -> do+      let cs = if BS.length rs /= 0 then BS.concat [rs, bs] else bs+      let lencs = BS.length cs+      let q = lencs + 7 `quot` 8+      let (ds, es) = BS.splitAt (q * 8) cs+      let (fs, _) = BS.unfoldrN q gen ds+      yield fs+      blankedXmlToInterestBits' es+    Nothing -> return ()+  where gen :: ByteString -> Maybe (Word8, ByteString)+        gen as = if BS.length as == 0+          then Nothing+          else Just ( BS.foldr (\b m -> (interestingWord8s ! b) .|. (m .<. 1)) 0 (padRight 0 8 (BS.take 8 as))+                    , BS.drop 8 as+                    )++blankedXmlToBalancedParens :: Monad m => Conduit BS.ByteString m Bool+blankedXmlToBalancedParens = do+  mbs <- await+  case mbs of+    Just bs -> blankedXmlToBalancedParens' bs+    Nothing -> return ()++blankedXmlToBalancedParens' :: Monad m => BS.ByteString -> Conduit BS.ByteString m Bool+blankedXmlToBalancedParens' bs = case BS.uncons bs of+  Just (c, cs) -> do+    case c of+      d | d == _less          -> yield True+      d | d == _greater       -> yield False+      d | d == _bracketleft   -> yield True+      d | d == _bracketright  -> yield False+      d | d == _parenleft     -> yield True+      d | d == _parenright    -> yield False+      d | d == _a             -> yield True >> yield False+      d | d == _v             -> yield True >> yield False+      d | d == _t             -> yield True >> yield False+      _                       -> return ()+    blankedXmlToBalancedParens' cs+  Nothing -> return ()++compressWordAsBit :: Monad m => Conduit BS.ByteString m BS.ByteString+compressWordAsBit = do+  mbs <- await+  case mbs of+    Just bs -> do+      let (cs, _) = BS.unfoldrN (BS.length bs + 7 `div` 8) gen bs+      yield cs+    Nothing -> return ()+  where gen :: ByteString -> Maybe (Word8, ByteString)+        gen xs = if BS.length xs == 0+          then Nothing+          else Just ( BS.foldr (\b m -> ((b .&. 1) .|. (m .<. 1))) 0 (padRight 0 8 (BS.take 8 xs))+                    , BS.drop 8 xs+                    )++blankedXmlToBalancedParens2 :: Monad m => Conduit BS.ByteString m BS.ByteString+blankedXmlToBalancedParens2 = do+  mbs <- await+  case mbs of+    Just bs -> do+      let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs)+      yield cs+    Nothing -> return ()+  where gen :: (Maybe Bool, ByteString) -> Maybe (Word8, (Maybe Bool, ByteString))+        gen (Just True  , bs) = Just (0xFF, (Nothing, bs))+        gen (Just False , bs) = Just (0x00, (Nothing, bs))+        gen (Nothing    , bs) = case BS.uncons bs of+          Just (c, cs) -> case balancedParensOf c of+            MiniN   -> gen        (Nothing    , cs)+            MiniT   -> Just (0xFF, (Nothing    , cs))+            MiniF   -> Just (0x00, (Nothing    , cs))+            MiniTF  -> Just (0xFF, (Just False , cs))+          Nothing   -> Nothing++data MiniBP = MiniN | MiniT | MiniF | MiniTF++balancedParensOf :: Word8 -> MiniBP+balancedParensOf c = case c of+    d | d == _less          -> MiniT+    d | d == _greater       -> MiniF+    d | d == _bracketleft   -> MiniT+    d | d == _bracketright  -> MiniF+    d | d == _parenleft     -> MiniT+    d | d == _parenright    -> MiniF+    d | d == _t             -> MiniTF+    d | d == _a             -> MiniTF+    d | d == _v             -> MiniTF+    _                       -> MiniN++yieldBitsOfWord8 :: Monad m => Word8 -> Conduit BS.ByteString m Bool+yieldBitsOfWord8 w = do+  yield ((w .&. BITS.bit 0) /= 0)+  yield ((w .&. BITS.bit 1) /= 0)+  yield ((w .&. BITS.bit 2) /= 0)+  yield ((w .&. BITS.bit 3) /= 0)+  yield ((w .&. BITS.bit 4) /= 0)+  yield ((w .&. BITS.bit 5) /= 0)+  yield ((w .&. BITS.bit 6) /= 0)+  yield ((w .&. BITS.bit 7) /= 0)++yieldBitsofWord8s :: Monad m => [Word8] -> Conduit BS.ByteString m Bool+yieldBitsofWord8s = P.foldr ((>>) . yieldBitsOfWord8) (return ())++byteStringToBits :: Monad m => Conduit BS.ByteString m Bool+byteStringToBits = do+  mbs <- await+  case mbs of+    Just bs -> yieldBitsofWord8s (BS.unpack bs) >> byteStringToBits+    Nothing -> return ()
+ src/HaskellWorks/Data/Xml/Conduit/Blank.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Data.Xml.Conduit.Blank+  ( blankXml+  ) where++import           Control.Monad+import           Control.Monad.Trans.Resource        (MonadThrow)+import           Data.ByteString                     as BS+import           Data.Conduit+import           Data.Word+import           Data.Word8+import           HaskellWorks.Data.Xml.Conduit.Words+import           Prelude                             as P++type ExpectedChar      = Word8+data BlankState+  = InXml+  | InTag | InAttrList | InCloseTag | InClose+  | InBang Int+  | InString ExpectedChar | InText+  | InMeta+  | InCdataTag | InCdata Int+  | InRem Int+  | InIdent++data ByteStringP = BSP Word8 ByteString | EmptyBSP++blankXml :: MonadThrow m => Conduit BS.ByteString m BS.ByteString+blankXml = blankXml' Nothing InXml++blankXml' :: MonadThrow m => Maybe Word8 -> BlankState -> Conduit BS.ByteString m BS.ByteString+blankXml' lastChar lastState = do+  mbs <- await+  case prefix lastChar mbs of+    Just bsp -> do+      let (safe, next) = unsnocUndecided bsp+      let (!cs, Just (!nextState, _)) = unfoldrN (lenBSP safe) blankByteString (lastState, safe)+      yield cs+      blankXml' next nextState+    Nothing -> return ()+  where+    blankByteString :: (BlankState, ByteStringP) -> Maybe (Word8, (BlankState, ByteStringP))+    blankByteString (InXml, bs) = case bs of+      BSP !c !cs | isMetaStart c cs     -> Just (_bracketleft , (InMeta    , toBSP cs))+      BSP !c !cs | isEndTag c cs        -> Just (_space       , (InCloseTag, toBSP cs))+      BSP !c !cs | isTextStart c        -> Just (_t           , (InText    , toBSP cs))+      BSP !c !cs | c == _less           -> Just (_less        , (InTag     , toBSP cs))+      BSP _  !cs                        -> Just (_space       , (InXml     , toBSP cs))+      EmptyBSP                          -> Nothing+    blankByteString (InTag, bs) = case bs of+      BSP !c !cs | isSpace c            -> Just (_parenleft   , (InAttrList, toBSP cs))+      BSP !c !cs | isTagClose c cs      -> Just (_space       , (InClose   , toBSP cs))+      BSP !c !cs | c == _greater        -> Just (_space       , (InXml     , toBSP cs))+      BSP _  !cs                        -> Just (_space       , (InTag     , toBSP cs))+      EmptyBSP                          -> Nothing+    blankByteString (InCloseTag, bs) = case bs of+      BSP !c !cs | c == _greater        -> Just (_greater     , (InXml     , toBSP cs))+      BSP _  !cs                        -> Just (_space       , (InCloseTag, toBSP cs))+      EmptyBSP                          -> Nothing+    blankByteString (InAttrList, bs) = case bs of+      BSP !c !cs | c == _greater        -> Just (_parenright  , (InXml     , toBSP cs))+      BSP !c !cs | isTagClose c cs      -> Just (_parenright  , (InClose   , toBSP cs))+      BSP !c !cs | isNameStartChar c    -> Just (_a           , (InIdent   , toBSP cs))+      BSP !c !cs | isQuote c            -> Just (_v           , (InString c, toBSP cs))+      BSP _  !cs                        -> Just (_space       , (InAttrList, toBSP cs))+      EmptyBSP                          -> Nothing+    blankByteString (InClose, bs) = case bs of+      BSP _ !cs                         -> Just (_greater     , (InXml     , toBSP cs))+      EmptyBSP                          -> Nothing+    blankByteString (InIdent, bs) = case bs of+      BSP !c !cs | isNameChar c         -> Just (_space       , (InIdent   , toBSP cs))+      BSP !c !cs | isSpace c            -> Just (_space       , (InAttrList, toBSP cs))+      BSP !c !cs | c == _equal          -> Just (_space       , (InAttrList, toBSP cs))+      BSP _  !cs                        -> Just (_space       , (InAttrList, toBSP cs))+      EmptyBSP                          -> Nothing+    blankByteString (InString q, bs) = case bs of+      BSP !c !cs | c == q               -> Just (_space       , (InAttrList, toBSP cs))+      BSP _  !cs                        -> Just (_space       , (InString q, toBSP cs))+      EmptyBSP                          -> Nothing+    blankByteString (InText, bs) = case bs of+      BSP !c !cs | isEndTag c cs        -> Just (_space       , (InCloseTag, toBSP cs))+      BSP _  !cs | headIs (== _less) cs -> Just (_space       , (InXml     , toBSP cs))+      BSP _  !cs                        -> Just (_space       , (InText    , toBSP cs))+      EmptyBSP                          -> Nothing+    blankByteString (InMeta, bs) = case bs of+      BSP !c !cs | c == _exclam         -> Just (_space       , (InMeta       , toBSP cs))+      BSP !c !cs | c == _hyphen         -> Just (_space       , (InRem 0      , toBSP cs))+      BSP !c !cs | c == _bracketleft    -> Just (_space       , (InCdataTag   , toBSP cs))+      BSP !c !cs | c == _greater        -> Just (_bracketright, (InXml        , toBSP cs))+      BSP _  !cs                        -> Just (_space       , (InBang 1     , toBSP cs))+      EmptyBSP                          -> Nothing+    blankByteString (InCdataTag, bs) = case bs of+      BSP !c !cs | c == _bracketleft    -> Just (_space       , (InCdata 0    , toBSP cs))+      BSP _  !cs                        -> Just (_space       , (InCdataTag   , toBSP cs))+      EmptyBSP                          -> Nothing+    blankByteString (InCdata n, bs) = case bs of+      BSP !c !cs | c == _greater && n >= 2 -> Just (_bracketright, (InXml        , toBSP cs))+      BSP !c !cs | isCdataEnd c cs && n>0  -> Just (_space       , (InCdata (n+1), toBSP cs))+      BSP !c !cs | c == _bracketright      -> Just (_space       , (InCdata (n+1), toBSP cs))+      BSP _  !cs                           -> Just (_space       , (InCdata 0    , toBSP cs))+      EmptyBSP                             -> Nothing+    blankByteString (InRem n, bs) = case bs of+      BSP !c !cs | c == _greater && n >= 2 -> Just (_bracketright, (InXml        , toBSP cs))+      BSP !c !cs | c == _hyphen            -> Just (_space       , (InRem (n+1)  , toBSP cs))+      BSP _  !cs                           -> Just (_space       , (InRem 0      , toBSP cs))+      EmptyBSP                             -> Nothing+    blankByteString (InBang n, bs) = case bs of+      BSP !c !cs | c == _less              -> Just (_bracketleft , (InBang (n+1) , toBSP cs))+      BSP !c !cs | c == _greater && n == 1 -> Just (_bracketright, (InXml        , toBSP cs))+      BSP !c !cs | c == _greater           -> Just (_bracketright, (InBang (n-1) , toBSP cs))+      BSP _  !cs                           -> Just (_space       , (InBang n     , toBSP cs))+      EmptyBSP                             -> Nothing++prefix :: Maybe Word8 -> Maybe ByteString -> Maybe ByteStringP+prefix (Just s) (Just bs) = Just $ BSP s bs+prefix (Just s) Nothing   = Just $ BSP s BS.empty+prefix Nothing  (Just bs) = (\(!c, !cs) -> BSP c cs) <$> BS.uncons bs+prefix Nothing  Nothing   = Nothing++toBSP :: ByteString -> ByteStringP+toBSP bs = case BS.uncons bs of+  Just (!c, !cs) -> BSP c cs+  Nothing        -> EmptyBSP++lenBSP :: ByteStringP -> Int+lenBSP (BSP _ bs) = BS.length bs + 1+lenBSP EmptyBSP = 0++isEndTag :: Word8 -> ByteString -> Bool+isEndTag c cs = c == _less && headIs (== _slash) cs++-- isStartTag :: Word8 -> ByteString -> Bool+-- isStartTag c cs = c == _less && headIs isNameStartChar cs++isTagClose :: Word8 -> ByteString -> Bool+isTagClose c cs =+  (c == _slash || c == _question) && headIs (== _greater) cs++isMetaStart :: Word8 -> ByteString -> Bool+isMetaStart c cs = c == _less && headIs (== _exclam) cs++isCdataEnd :: Word8 -> ByteString -> Bool+isCdataEnd c cs = c == _bracketright && headIs (== _greater) cs++unsnocUndecided :: ByteStringP -> (ByteStringP, Maybe Word8)+unsnocUndecided = unscnocIf (\w -> w ==_less           -- <elem> or </elem>?+                                || w == _slash         -- <elem /> or not?+                                || w == _hyphen        -- closing comment or just - ?+                                || w == _bracketright) -- closing CDATA or just data?+{-# INLINE unsnocUndecided #-}++headIs :: (Word8 -> Bool) -> ByteString -> Bool+headIs p bs = case BS.uncons bs of+  Just (!c, _) -> p c+  Nothing      -> False+{-# INLINE headIs #-}++unscnocIf :: (Word8 -> Bool) -> ByteStringP -> (ByteStringP, Maybe Word8)+unscnocIf _ EmptyBSP = (EmptyBSP, Nothing)+unscnocIf p (BSP !c !bs) =+  case BS.unsnoc bs of+    Just (bs', w) | p w -> (BSP c bs', Just w)+    _                   -> (BSP c bs , Nothing)+{-# INLINE unscnocIf #-}
+ src/HaskellWorks/Data/Xml/Conduit/Words.hs view
@@ -0,0 +1,37 @@+module HaskellWorks.Data.Xml.Conduit.Words where++import           Data.Word+import           Data.Word8++isLeadingDigit :: Word8 -> Bool+isLeadingDigit w = w == _hyphen || (w >= _0 && w <= _9)++isTrailingDigit :: Word8 -> Bool+isTrailingDigit w = w == _plus || w == _hyphen || (w >= _0 && w <= _9) || w == _period || w == _E || w == _e++isAlphabetic :: Word8 -> Bool+isAlphabetic w = (w >= _A && w <= _Z) || (w >= _a && w <= _z)++isQuote :: Word8 -> Bool+isQuote w = w == _quotedbl || w == _quotesingle++isNameStartChar :: Word8 -> Bool+isNameStartChar w = w == _underscore || w == _colon || isAlphabetic w+                 || w `isIn` (0xc0, 0xd6)+                 || w `isIn` (0xd8, 0xf6)+                 || w `isIn` (0xf8, 0xff)++isNameChar :: Word8 -> Bool+isNameChar w = isNameStartChar w || w == _hyphen || w == _period+            || w == 0xb7 || w `isIn` (0, 9)++isXml :: Word8 -> Bool+isXml w = w == _less || w == _greater++isTextStart :: Word8 -> Bool+isTextStart w = not (isSpace w) && w /= _less && w /= _greater++isIn :: Word8 -> (Word8, Word8) -> Bool+isIn w (s, e) = w >= s && w <= e+{-# INLINE isIn #-}+
+ src/HaskellWorks/Data/Xml/Grammar.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TupleSections         #-}++module HaskellWorks.Data.Xml.Grammar where++import           Control.Applicative+import qualified Data.Attoparsec.Types    as T+import           Data.Char+import           Data.String+import           HaskellWorks.Data.Parser as P++data XmlElementType+  = XmlElementTypeDocument+  | XmlElementTypeElement String+  | XmlElementTypeComment+  | XmlElementTypeCData+  | XmlElementTypeMeta String++parseXmlString :: (P.Parser t, IsString t) => T.Parser t String+parseXmlString = do+  q <- satisfyChar (=='"') <|> satisfyChar (=='\'')+  many (satisfyChar (/= q))++parseXmlElement :: (P.Parser t, IsString t) => T.Parser t XmlElementType+parseXmlElement = comment <|> cdata <|> doc <|> meta <|> element+  where+  comment = const XmlElementTypeComment  <$> string "!--"+  cdata   = const XmlElementTypeCData    <$> string "![CDATA["+  meta    = XmlElementTypeMeta           <$> (string "!" >> parseXmlToken)+  doc     = const XmlElementTypeDocument <$> string "?xml"+  element = XmlElementTypeElement        <$> parseXmlToken++parseXmlToken :: (P.Parser t, IsString t) => T.Parser t String+parseXmlToken = many $ satisfyChar isNameChar <?> "invalid string character"++parseXmlAttributeName :: (P.Parser t, IsString t) => T.Parser t String+parseXmlAttributeName = parseXmlToken++isNameStartChar :: Char -> Bool+isNameStartChar w =+  let iw = ord w+  in w == '_' || w == ':' || isAlpha w+     || (iw >= 0xc0 && iw <= 0xd6)+     || (iw >= 0xd8 && iw <= 0xf6)+     || (iw >= 0xf8 && iw <= 0xff)++isNameChar :: Char -> Bool+isNameChar w = isNameStartChar w || w == '-' || w == '.'+             || ord w == 0xb7 || isNumber w
+ src/HaskellWorks/Data/Xml/Succinct.hs view
@@ -0,0 +1,5 @@+module HaskellWorks.Data.Xml.Succinct+  ( module X+  ) where++import           HaskellWorks.Data.Xml.Succinct.Cursor as X
+ src/HaskellWorks/Data/Xml/Succinct/Cursor.hs view
@@ -0,0 +1,7 @@++module HaskellWorks.Data.Xml.Succinct.Cursor+  ( module X+  ) where++import           HaskellWorks.Data.Xml.Succinct.Cursor.Internal as X+import           HaskellWorks.Data.Xml.Succinct.Cursor.Token    as X
+ src/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParens.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParens+  ( XmlBalancedParens(..)+  , getXmlBalancedParens+  ) where++import           Control.Applicative+import qualified Data.ByteString                                    as BS+import           Data.Conduit+import qualified Data.Vector.Storable                               as DVS+import           Data.Word+import           HaskellWorks.Data.BalancedParens                   as BP+import           HaskellWorks.Data.Conduit.List+import           HaskellWorks.Data.Xml.Conduit+import           HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml++newtype XmlBalancedParens a = XmlBalancedParens a++getXmlBalancedParens :: XmlBalancedParens a -> a+getXmlBalancedParens (XmlBalancedParens a) = a++genBitWordsForever :: BS.ByteString -> Maybe (Word8, BS.ByteString)+genBitWordsForever bs = BS.uncons bs <|> Just (0, bs)+{-# INLINABLE genBitWordsForever #-}++instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens [Bool])) where+  fromBlankedXml (BlankedXml bj) = XmlBalancedParens (SimpleBalancedParens (runListConduit blankedXmlToBalancedParens bj))++instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word8))) where+  fromBlankedXml bj    = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS)))+    where interestBS    = BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml bj))+          newLen        = (BS.length interestBS + 7) `div` 8 * 8++instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word16))) where+  fromBlankedXml bj    = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS)))+    where interestBS    = BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml bj))+          newLen        = (BS.length interestBS + 7) `div` 8 * 8++instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word32))) where+  fromBlankedXml bj    = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS)))+    where interestBS    = BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml bj))+          newLen        = (BS.length interestBS + 7) `div` 8 * 8++instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word64))) where+  fromBlankedXml bj    = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS)))+    where interestBS    = BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml bj))+          newLen        = (BS.length interestBS + 7) `div` 8 * 8
+ src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs view
@@ -0,0 +1,23 @@++module HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml+  ( BlankedXml(..)+  , FromBlankedXml(..)+  , getBlankedXml+  ) where++import qualified Data.ByteString                      as BS+import           HaskellWorks.Data.ByteString+import           HaskellWorks.Data.Conduit.List+import           HaskellWorks.Data.FromByteString+import           HaskellWorks.Data.Xml.Conduit.Blank++newtype BlankedXml = BlankedXml [BS.ByteString] deriving (Eq, Show)++getBlankedXml :: BlankedXml -> [BS.ByteString]+getBlankedXml (BlankedXml bs) = bs++class FromBlankedXml a where+  fromBlankedXml :: BlankedXml -> a++instance FromByteString BlankedXml where+  fromByteString bs = BlankedXml (runListConduit blankXml (chunkedBy 4064 bs))
+ src/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBits.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits+  ( XmlInterestBits(..)+  , getXmlInterestBits+  ) where++import           Control.Applicative+import qualified Data.ByteString                                       as BS+import           Data.ByteString.Internal+import qualified Data.Vector.Storable                                  as DVS+import           Data.Word+import           HaskellWorks.Data.Bits.BitShown+import           HaskellWorks.Data.Conduit.List+import           HaskellWorks.Data.FromByteString+import           HaskellWorks.Data.RankSelect.Poppy512+import           HaskellWorks.Data.Xml.Conduit+import           HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml++newtype XmlInterestBits a = XmlInterestBits a++getXmlInterestBits :: XmlInterestBits a -> a+getXmlInterestBits (XmlInterestBits a) = a++blankedXmlBssToInterestBitsBs :: [ByteString] -> ByteString+blankedXmlBssToInterestBitsBs bss = BS.concat $ runListConduit blankedXmlToInterestBits bss++genInterest :: ByteString -> Maybe (Word8, ByteString)+genInterest = BS.uncons++genInterestForever :: ByteString -> Maybe (Word8, ByteString)+genInterestForever bs = BS.uncons bs <|> Just (0, bs)++instance FromBlankedXml (XmlInterestBits (BitShown [Bool])) where+  fromBlankedXml = XmlInterestBits . fromByteString . BS.concat . runListConduit blankedXmlToInterestBits . getBlankedXml++instance FromBlankedXml (XmlInterestBits (BitShown BS.ByteString)) where+  fromBlankedXml = XmlInterestBits . BitShown . BS.unfoldr genInterest . blankedXmlBssToInterestBitsBs . getBlankedXml++instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word8))) where+  fromBlankedXml = XmlInterestBits . BitShown . DVS.unfoldr genInterest . blankedXmlBssToInterestBitsBs . getBlankedXml++instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word16))) where+  fromBlankedXml bj = XmlInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS)))+    where interestBS    = blankedXmlBssToInterestBitsBs (getBlankedXml bj)+          newLen        = (BS.length interestBS + 1) `div` 2 * 2++instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word32))) where+  fromBlankedXml bj = XmlInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS)))+    where interestBS    = blankedXmlBssToInterestBitsBs (getBlankedXml bj)+          newLen        = (BS.length interestBS + 3) `div` 4 * 4++instance FromBlankedXml (XmlInterestBits (BitShown (DVS.Vector Word64))) where+  fromBlankedXml bj    = XmlInterestBits (BitShown (DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS)))+    where interestBS    = blankedXmlBssToInterestBitsBs (getBlankedXml bj)+          newLen        = (BS.length interestBS + 7) `div` 8 * 8++instance FromBlankedXml (XmlInterestBits Poppy512) where+  fromBlankedXml = XmlInterestBits . makePoppy512 . bitShown . getXmlInterestBits . fromBlankedXml
+ src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}++module HaskellWorks.Data.Xml.Succinct.Cursor.Internal+  ( XmlCursor(..)+  , xmlCursorPos+  ) where++import qualified Data.ByteString                                      as BS+import qualified Data.ByteString.Char8                                as BSC+import           Data.ByteString.Internal                             as BSI+import           Data.String+import qualified Data.Vector.Storable                                 as DVS+import           Data.Word+import           Foreign.ForeignPtr+import qualified HaskellWorks.Data.BalancedParens                     as BP+import           HaskellWorks.Data.Bits.BitShown+import           HaskellWorks.Data.FromByteString+import           HaskellWorks.Data.FromForeignRegion+import           HaskellWorks.Data.Positioning+import           HaskellWorks.Data.RankSelect.Base.Rank0+import           HaskellWorks.Data.RankSelect.Base.Rank1+import           HaskellWorks.Data.RankSelect.Base.Select1+import           HaskellWorks.Data.RankSelect.Poppy512+import           HaskellWorks.Data.TreeCursor+import qualified HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParens as CBP+import           HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml+import           HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits++data XmlCursor t v w = XmlCursor+  { cursorText     :: !t+  , interests      :: !v+  , balancedParens :: !w+  , cursorRank     :: !Count+  }+  deriving (Eq, Show)++instance  (FromBlankedXml (XmlInterestBits a), FromBlankedXml (CBP.XmlBalancedParens b))+          => FromByteString (XmlCursor BS.ByteString a b) where+  fromByteString bs   = XmlCursor+    { cursorText      = bs+    , interests       = getXmlInterestBits (fromBlankedXml blankedXml)+    , balancedParens  = CBP.getXmlBalancedParens (fromBlankedXml blankedXml)+    , cursorRank      = 1+    }+    where blankedXml :: BlankedXml+          blankedXml = fromByteString bs++instance IsString (XmlCursor String (BitShown [Bool]) (BP.SimpleBalancedParens [Bool])) where+  fromString :: String -> XmlCursor String (BitShown [Bool]) (BP.SimpleBalancedParens [Bool])+  fromString s = XmlCursor+    { cursorText      = s+    , cursorRank      = 1+    , interests       = getXmlInterestBits (fromBlankedXml blankedXml)+    , balancedParens  = CBP.getXmlBalancedParens (fromBlankedXml blankedXml)+    }+    where blankedXml :: BlankedXml+          blankedXml = fromByteString (BSC.pack s)++instance IsString (XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (BP.SimpleBalancedParens (DVS.Vector Word8))) where+  fromString = fromByteString . BSC.pack++instance IsString (XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (BP.SimpleBalancedParens (DVS.Vector Word16))) where+  fromString = fromByteString . BSC.pack++instance IsString (XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (BP.SimpleBalancedParens (DVS.Vector Word32))) where+  fromString = fromByteString . BSC.pack++instance IsString (XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (BP.SimpleBalancedParens (DVS.Vector Word64))) where+  fromString = fromByteString . BSC.pack++instance IsString (XmlCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64))) where+  fromString = fromByteString . BSC.pack++instance FromForeignRegion (XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (BP.SimpleBalancedParens (DVS.Vector Word8))) where+  fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size)++instance FromForeignRegion (XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (BP.SimpleBalancedParens (DVS.Vector Word16))) where+  fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size)++instance FromForeignRegion (XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (BP.SimpleBalancedParens (DVS.Vector Word32))) where+  fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size)++instance FromForeignRegion (XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (BP.SimpleBalancedParens (DVS.Vector Word64))) where+  fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size)++instance FromForeignRegion (XmlCursor BS.ByteString Poppy512 (BP.SimpleBalancedParens (DVS.Vector Word64))) where+  fromForeignRegion (fptr, offset, size) = fromByteString (BSI.fromForeignPtr (castForeignPtr fptr) offset size)++instance (BP.BalancedParens u, Rank1 u, Rank0 u) => TreeCursor (XmlCursor t v u) where+  firstChild :: XmlCursor t v u -> Maybe (XmlCursor t v u)+  firstChild k = let mq = BP.firstChild (balancedParens k) (cursorRank k) in (\q -> k { cursorRank = q }) <$> mq++  nextSibling :: XmlCursor t v u -> Maybe (XmlCursor t v u)+  nextSibling k = (\q -> k { cursorRank = q }) <$> BP.nextSibling (balancedParens k) (cursorRank k)++  parent :: XmlCursor t v u -> Maybe (XmlCursor t v u)+  parent k = let mq = BP.parent (balancedParens k) (cursorRank k) in (\q -> k { cursorRank = q }) <$> mq++  depth :: XmlCursor t v u -> Maybe Count+  depth k = BP.depth (balancedParens k) (cursorRank k)++  subtreeSize :: XmlCursor t v u -> Maybe Count+  subtreeSize k = BP.subtreeSize (balancedParens k) (cursorRank k)++xmlCursorPos :: (Rank1 w, Select1 v) => XmlCursor s v w -> Position+xmlCursorPos k = toPosition (select1 ik (rank1 bpk (cursorRank k)) - 1)+  where ik  = interests k+        bpk = balancedParens k
+ src/HaskellWorks/Data/Xml/Succinct/Cursor/Token.hs view
@@ -0,0 +1,23 @@++module HaskellWorks.Data.Xml.Succinct.Cursor.Token+  ( xmlTokenAt+  ) where++import qualified Data.Attoparsec.ByteString.Char8               as ABC+import           Data.ByteString.Internal                       as BSI+import           HaskellWorks.Data.Bits.BitWise+import           HaskellWorks.Data.Drop+import           HaskellWorks.Data.Positioning+import           HaskellWorks.Data.RankSelect.Base.Rank1+import           HaskellWorks.Data.RankSelect.Base.Select1+import           HaskellWorks.Data.Xml.Succinct.Cursor.Internal+import           HaskellWorks.Data.Xml.Token.Tokenize+import           Prelude hiding (drop)++xmlTokenAt :: (Rank1 w, Select1 v, TestBit w) => XmlCursor ByteString v w -> Maybe (XmlToken String Double)+xmlTokenAt k = if balancedParens k .?. lastPositionOf (cursorRank k)+  then case ABC.parse parseXmlToken (drop (toCount (xmlCursorPos k)) (cursorText k)) of+    ABC.Fail    {}  -> error "Failed to parse token in cursor"+    ABC.Partial _   -> error "Failed to parse token in cursor"+    ABC.Done    _ r -> Just r+  else Nothing
+ src/HaskellWorks/Data/Xml/Succinct/Index.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HaskellWorks.Data.Xml.Succinct.Index+( XmlIndex(..)+, XmlIndexAt(..)+)+where++import           Control.Arrow+import qualified Data.Attoparsec.ByteString.Char8           as ABC+import qualified Data.ByteString                            as BS+import qualified Data.List                                  as L+import           Data.Monoid+import           HaskellWorks.Data.Bits.BitWise+import           HaskellWorks.Data.Drop+import           HaskellWorks.Data.Positioning+import qualified HaskellWorks.Data.BalancedParens           as BP+import           HaskellWorks.Data.RankSelect.Base.Rank0+import           HaskellWorks.Data.RankSelect.Base.Rank1+import           HaskellWorks.Data.RankSelect.Base.Select1+import           HaskellWorks.Data.TreeCursor+import           HaskellWorks.Data.Uncons+import           HaskellWorks.Data.Xml.CharLike+import           HaskellWorks.Data.Xml.Grammar+import           HaskellWorks.Data.Xml.Succinct+import           Prelude hiding (drop)++data XmlIndex+  = XmlIndexDocument [XmlIndex]+  | XmlIndexElement String [XmlIndex]+  | XmlIndexCData BS.ByteString+  | XmlIndexComment BS.ByteString+  | XmlIndexMeta String [XmlIndex]+  | XmlIndexAttrList [XmlIndex]+  | XmlIndexValue BS.ByteString+  | XmlIndexAttrName BS.ByteString+  | XmlIndexAttrValue BS.ByteString+  | XmlIndexError String+  deriving (Eq, Show)++class XmlIndexAt a where+  xmlIndexAt :: a -> XmlIndex++pos :: (Select1 v, Rank1 w) => XmlCursor t v w -> Position+pos c = lastPositionOf (select1 (interests c) (rank1 (balancedParens c) (cursorRank c)))++remText :: (Drop v, Select1 v1, Rank1 w) => XmlCursor v v1 w -> v+remText c = drop (toCount (pos c)) (cursorText c)++instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => XmlIndexAt (XmlCursor BS.ByteString v w) where+  xmlIndexAt :: XmlCursor BS.ByteString v w -> XmlIndex+  xmlIndexAt k = case uncons remainder of+    Just (!c, cs) | isElementStart c          -> parseElem cs+    Just (!c, _ ) | isSpace c                 -> XmlIndexAttrList $ mapValuesFrom (firstChild k)+    Just (!c, _ ) | isAttribute && isQuote c  -> XmlIndexAttrValue remainder+    Just _        | isAttribute               -> XmlIndexAttrName remainder+    Just _                                    -> XmlIndexValue remainder+    Nothing                                   -> XmlIndexError "End of data"+    where remainder         = remText k+          mapValuesFrom     = L.unfoldr (fmap (xmlIndexAt &&& nextSibling))+          isAttribute = case remText <$> parent k >>= uncons of+            Just (!c, _) | isSpace c -> True+            _                        -> False++          parseElem bs =+            case ABC.parse parseXmlElement bs of+              ABC.Fail {}    -> decodeErr "Unable to parse element name" bs+              ABC.Partial _  -> decodeErr "Unexpected end of string" bs+              ABC.Done i r   -> case r of+                XmlElementTypeCData     -> XmlIndexCData i+                XmlElementTypeComment   -> XmlIndexComment i+                XmlElementTypeMeta s    -> XmlIndexMeta s    (mapValuesFrom $ firstChild k)+                XmlElementTypeElement s -> XmlIndexElement s (mapValuesFrom $ firstChild k)+                XmlElementTypeDocument  -> XmlIndexDocument  (mapValuesFrom (firstChild k) <> mapValuesFrom (nextSibling k))+++decodeErr :: String -> BS.ByteString -> XmlIndex+decodeErr reason bs =+  XmlIndexError $ reason <>": " <> show (BS.take 20 bs) <> "...'"
+ src/HaskellWorks/Data/Xml/Token.hs view
@@ -0,0 +1,6 @@+module HaskellWorks.Data.Xml.Token+  ( module X+  ) where++import           HaskellWorks.Data.Xml.Token.Types     as X+import           HaskellWorks.Data.Xml.Token.Tokenize  as X
+ src/HaskellWorks/Data/Xml/Token/Tokenize.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeSynonymInstances  #-}++module HaskellWorks.Data.Xml.Token.Tokenize+    ( IsChar(..)+    , XmlToken(..)+    , ParseXml(..)+    ) where++import           Control.Applicative+import qualified Data.Attoparsec.ByteString.Char8  as BC+import qualified Data.Attoparsec.Combinator        as AC+import qualified Data.Attoparsec.Types             as T+import           Data.Bits+import qualified Data.ByteString                   as BS+import           Data.Char+import           Data.Word+import           Data.Word8+import           HaskellWorks.Data.Char.IsChar+import           HaskellWorks.Data.Parser          as P+import           HaskellWorks.Data.Xml.Token.Types++hexDigitNumeric :: P.Parser t => T.Parser t Int+hexDigitNumeric = do+  c <- satisfyChar (\c -> '0' <= c && c <= '9')+  return $ ord c - ord '0'++hexDigitAlphaLower :: P.Parser t => T.Parser t Int+hexDigitAlphaLower = do+  c <- satisfyChar (\c -> 'a' <= c && c <= 'z')+  return $ ord c - ord 'a' + 10++hexDigitAlphaUpper :: P.Parser t => T.Parser t Int+hexDigitAlphaUpper = do+  c <- satisfyChar (\c -> 'A' <= c && c <= 'Z')+  return $ ord c - ord 'A' + 10++hexDigit :: P.Parser t => T.Parser t Int+hexDigit = hexDigitNumeric <|> hexDigitAlphaLower <|> hexDigitAlphaUpper++class ParseXml t s d where+  parseXmlTokenString     :: T.Parser t (XmlToken s d)+  parseXmlToken           :: T.Parser t (XmlToken s d)+  parseXmlTokenBraceL     :: T.Parser t (XmlToken s d)+  parseXmlTokenBraceR     :: T.Parser t (XmlToken s d)+  parseXmlTokenBracketL   :: T.Parser t (XmlToken s d)+  parseXmlTokenBracketR   :: T.Parser t (XmlToken s d)+  parseXmlTokenComma      :: T.Parser t (XmlToken s d)+  parseXmlTokenColon      :: T.Parser t (XmlToken s d)+  parseXmlTokenWhitespace :: T.Parser t (XmlToken s d)+  parseXmlTokenNull       :: T.Parser t (XmlToken s d)+  parseXmlTokenBoolean    :: T.Parser t (XmlToken s d)+  parseXmlTokenDouble     :: T.Parser t (XmlToken s d)++  parseXmlToken =+    parseXmlTokenString     <|>+    parseXmlTokenBraceL     <|>+    parseXmlTokenBraceR     <|>+    parseXmlTokenBracketL   <|>+    parseXmlTokenBracketR   <|>+    parseXmlTokenComma      <|>+    parseXmlTokenColon      <|>+    parseXmlTokenWhitespace <|>+    parseXmlTokenNull       <|>+    parseXmlTokenBoolean    <|>+    parseXmlTokenDouble++instance ParseXml BS.ByteString String Double where+  parseXmlTokenBraceL   = string "{"      >> return XmlTokenBraceL+  parseXmlTokenBraceR   = string "}"      >> return XmlTokenBraceR+  parseXmlTokenBracketL = string "["      >> return XmlTokenBracketL+  parseXmlTokenBracketR = string "]"      >> return XmlTokenBracketR+  parseXmlTokenComma    = string ","      >> return XmlTokenComma+  parseXmlTokenColon    = string ":"      >> return XmlTokenColon+  parseXmlTokenNull     = string "null"   >> return XmlTokenNull+  parseXmlTokenDouble   = XmlTokenNumber <$> rational++  parseXmlTokenString = do+    _ <- string "\""+    value <- many (verbatimChar <|> escapedChar <|> escapedCode)+    _ <- string "\""+    return $ XmlTokenString value+    where+      verbatimChar  = satisfyChar (BC.notInClass "\"\\") <?> "invalid string character"+      escapedChar   = do+        _ <- string "\\"+        (   char '"'  >> return '"'  ) <|>+          ( char 'b'  >> return '\b' ) <|>+          ( char 'n'  >> return '\n' ) <|>+          ( char 'f'  >> return '\f' ) <|>+          ( char 'r'  >> return '\r' ) <|>+          ( char 't'  >> return '\t' ) <|>+          ( char '\\' >> return '\\' ) <|>+          ( char '\'' >> return '\'' ) <|>+          ( char '/'  >> return '/'  )+      escapedCode :: T.Parser BS.ByteString Char+      escapedCode   = do+        _ <- string "\\u"+        a <- hexDigit+        b <- hexDigit+        c <- hexDigit+        d <- hexDigit+        return . chr $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d++  parseXmlTokenWhitespace = do+    _ <- AC.many1' $ BC.choice [string " ", string "\t", string "\n", string "\r"]+    return XmlTokenWhitespace++  parseXmlTokenBoolean = true <|> false+    where+      true  = string "true"   >> return (XmlTokenBoolean True)+      false = string "false"  >> return (XmlTokenBoolean False)++instance ParseXml BS.ByteString BS.ByteString Double where+  parseXmlTokenBraceL   = string "{"      >> return XmlTokenBraceL+  parseXmlTokenBraceR   = string "}"      >> return XmlTokenBraceR+  parseXmlTokenBracketL = string "["      >> return XmlTokenBracketL+  parseXmlTokenBracketR = string "]"      >> return XmlTokenBracketR+  parseXmlTokenComma    = string ","      >> return XmlTokenComma+  parseXmlTokenColon    = string ":"      >> return XmlTokenColon+  parseXmlTokenNull     = string "null"   >> return XmlTokenNull+  parseXmlTokenDouble   = XmlTokenNumber <$> rational++  parseXmlTokenString = do+    _ <- string "\""+    value <- many (verbatimChar <|> escapedChar <|> escapedCode)+    _ <- string "\""+    return . XmlTokenString $ BS.pack value+    where+      word :: Word8 -> T.Parser BS.ByteString Word8+      word w = satisfy (== w)+      verbatimChar :: T.Parser BS.ByteString Word8+      verbatimChar  = satisfy (\w -> w /= _quotedbl && w /= _backslash) -- <?> "invalid string character"+      escapedChar :: T.Parser BS.ByteString Word8+      escapedChar   = do+        _ <- string "\\"+        (   word _quotedbl    >> return _quotedbl       ) <|>+          ( word _b           >> return 0x08            ) <|>+          ( word _n           >> return _lf             ) <|>+          ( word _f           >> return _np             ) <|>+          ( word _r           >> return _cr             ) <|>+          ( word _t           >> return _tab            ) <|>+          ( word _backslash   >> return _backslash      ) <|>+          ( word _quotesingle >> return _quotesingle    ) <|>+          ( word _slash       >> return _slash          )+      escapedCode :: T.Parser BS.ByteString Word8+      escapedCode   = do+        _ <- string "\\u"+        a <- hexDigit+        b <- hexDigit+        c <- hexDigit+        d <- hexDigit+        return . fromIntegral $ a `shift` 24 .|. b `shift` 16 .|. c `shift` 8 .|. d++  parseXmlTokenWhitespace = do+    _ <- AC.many1' $ BC.choice [string " ", string "\t", string "\n", string "\r"]+    return XmlTokenWhitespace++  parseXmlTokenBoolean = true <|> false+    where+      true  = string "true"   >> return (XmlTokenBoolean True)+      false = string "false"  >> return (XmlTokenBoolean False)
+ src/HaskellWorks/Data/Xml/Token/Types.hs view
@@ -0,0 +1,15 @@+module HaskellWorks.Data.Xml.Token.Types (XmlToken(..)) where++data XmlToken s d+  = XmlTokenBraceL+  | XmlTokenBraceR+  | XmlTokenBracketL+  | XmlTokenBracketR+  | XmlTokenComma+  | XmlTokenColon+  | XmlTokenWhitespace+  | XmlTokenString s+  | XmlTokenBoolean Bool+  | XmlTokenNumber d+  | XmlTokenNull+  deriving (Eq, Show)
+ src/HaskellWorks/Data/Xml/Type.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HaskellWorks.Data.Xml.Type where++import qualified Data.ByteString                            as BS+import           Data.Char+import           Data.Word8                                 as W8+import           HaskellWorks.Data.Bits.BitWise+import           HaskellWorks.Data.Drop+import qualified HaskellWorks.Data.BalancedParens           as BP+import           HaskellWorks.Data.Positioning+import           HaskellWorks.Data.RankSelect.Base.Rank0+import           HaskellWorks.Data.RankSelect.Base.Rank1+import           HaskellWorks.Data.RankSelect.Base.Select1+import           HaskellWorks.Data.Xml.Succinct+import           Prelude hiding (drop)++{-# ANN module ("HLint: Ignore Reduce duplication"  :: String) #-}++data XmlType+  = XmlTypeElement+  | XmlTypeAttrList+  | XmlTypeToken+  deriving (Eq, Show)++class XmlTypeAt a where+  xmlTypeAtPosition :: Position -> a -> Maybe XmlType+  xmlTypeAt :: a -> Maybe XmlType++instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => XmlTypeAt (XmlCursor String v w) where+  xmlTypeAtPosition p k = case drop (toCount p) (cursorText k) of+    c:_ | fromIntegral (ord c) == _less      -> Just XmlTypeElement+    c:_ | W8.isSpace $ fromIntegral (ord c)  -> Just XmlTypeAttrList+    _                                        -> Just XmlTypeToken++  xmlTypeAt k = xmlTypeAtPosition p k+    where p   = lastPositionOf (select1 ik (rank1 bpk (cursorRank k)))+          ik  = interests k+          bpk = balancedParens k++instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => XmlTypeAt (XmlCursor BS.ByteString v w) where+  xmlTypeAtPosition p k = case BS.uncons (drop (toCount p) (cursorText k)) of+    Just (c, _) | c == _less     -> Just XmlTypeElement+    Just (c, _) | W8.isSpace c   -> Just XmlTypeAttrList+    _                            -> Just XmlTypeToken++  xmlTypeAt k = xmlTypeAtPosition p k+    where p   = lastPositionOf (select1 ik (rank1 bpk (cursorRank k)))+          ik  = interests k+          bpk = balancedParens k
+ src/HaskellWorks/Data/Xml/Value.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TupleSections         #-}++module HaskellWorks.Data.Xml.Value+( XmlValue(..)+, XmlValueAt(..)+)+where++import qualified Data.Attoparsec.ByteString.Char8     as ABC+import qualified Data.ByteString                      as BS+import           Data.Monoid+import           Data.List+import           HaskellWorks.Data.Xml.Grammar+import           HaskellWorks.Data.Xml.Succinct.Index+import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))++data XmlValue+  = XmlDocument [XmlValue]+  | XmlText String+  | XmlElement String [XmlValue]+  | XmlCData String+  | XmlComment String+  | XmlMeta String [XmlValue]+  | XmlAttrName String+  | XmlAttrValue String+  | XmlAttrList [XmlValue]+  | XmlError String+  deriving (Eq, Show)++instance Pretty XmlValue where+  pretty mjpv = case mjpv of+    XmlText s       -> ctext $ text s+    XmlAttrName s   -> text s+    XmlAttrValue s  -> (ctext . dquotes . text) s+    XmlAttrList ats -> formatAttrs ats+    XmlComment s    -> text $ "<!-- " <> 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++isAttr :: XmlValue -> Bool+isAttr v = case v of+  XmlAttrName  _ -> True+  XmlAttrValue _ -> True+  XmlAttrList  _ -> True+  _              -> False++as :: Either String a -> (a -> XmlValue) -> XmlValue+as = flip $ either XmlError++decodeErr :: String -> BS.ByteString -> Either String a+decodeErr reason bs =+  Left $ reason <>" (" <> show (BS.take 20 bs) <> "...)"
+ test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+++module HaskellWorks.Data.Xml.Succinct.Cursor.InterestBitsSpec(spec) where++import qualified Data.ByteString                                    as BS+import           Data.String+import qualified Data.Vector.Storable                               as DVS+import           Data.Word+import           HaskellWorks.Data.Bits.BitShown+import           HaskellWorks.Data.FromByteString+import           HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml+import           HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits+import           Test.Hspec++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}++interestBitsOf :: FromBlankedXml (XmlInterestBits a) => BS.ByteString -> a+interestBitsOf = getXmlInterestBits . fromBlankedXml . fromByteString++spec :: Spec+spec = describe "HaskellWorks.Data.Xml.Succinct.Cursor.InterestBitsSpec" $ do+  it "Evaluating interest bits" $ do+    (interestBitsOf ""               :: BitShown (DVS.Vector Word8)) `shouldBe` fromString ""+    (interestBitsOf "  \n \r \t "    :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "00000000"+    (interestBitsOf "<el atr"        :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10011000"+    (interestBitsOf "[alse "         :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000"+    (interestBitsOf "(rue "          :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10000000"+    (interestBitsOf "<e><c></e>"     :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10010000 00000000"+    (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"
+ test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs view
@@ -0,0 +1,164 @@+{-# 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.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++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}++fc = TC.firstChild+ns = TC.nextSibling+-- pn = TC.parent+cd = TC.depth+-- ss = TC.subtreeSize++spec :: Spec+spec = describe "HaskellWorks.Data.Xml.Succinct.CursorSpec" $ do+  describe "Cursor for Element" $ do+    it "depth at top" $ do+      let cursor = "<widget debug='on'/>" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])+      cd cursor `shouldBe` Just 1+    it "depth at attribute list" $ do+      let cursor = "<widget debug='on' />" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])+      (fc >=> cd) cursor `shouldBe` Just 2+    it "depth first attribute" $ do+      let cursor = "<widget debug='on' enabled='on' />" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])+      (fc >=> fc >=> cd) cursor `shouldBe` Just 3+    it "depth second attribute" $ do+      let cursor = "<widget debug='on' enabled='on' />" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])+      (fc >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3+    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++-- shouldBeginWith :: (Eq a, Show a) => [a] -> [a] -> IO ()+-- shouldBeginWith as bs = take (length bs) as `shouldBe` bs++-- genSpec :: forall t u.+--   ( Eq                t+--   , Show              t+--   , Select1           t+--   , Eq                u+--   , Show              u+--   , Rank0             u+--   , Rank1             u+--   , BalancedParens    u+--   , TestBit           u+--   , FromForeignRegion (XmlCursor BS.ByteString t u)+--   , IsString          (XmlCursor BS.ByteString t u)+--   , XmlIndexAt       (XmlCursor BS.ByteString t u)+--   )+--   => String -> (XmlCursor BS.ByteString t u) -> SpecWith ()+-- genSpec t _ = do+--   describe ("Cursor for (" ++ t ++ ")") $ do+--     let forXml (cursor :: XmlCursor BS.ByteString t u) f = describe ("of value " ++ show cursor) (f cursor)+--     forXml "[null]" $ \cursor -> do+--       it "depth at top"                   $ cd          cursor `shouldBe` Just 1+--       it "depth at first child of array"  $ (fc >=> cd) cursor `shouldBe` Just 2+--     forXml "[null, {\"field\": 1}]" $ \cursor -> do+--       it "depth at second child of array" $ do+--         (fc >=> ns >=> cd) cursor `shouldBe` Just 2+--       it "depth at first child of object at second child of array" $ do+--         (fc >=> ns >=> fc >=> cd) cursor `shouldBe` Just 3+--       it "depth at first child of object at second child of array" $ do+--         (fc >=> ns >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3++--     describe "For sample Json" $ do+--       let cursor =  "<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
+ test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Data.Xml.Token.TokenizeSpec (spec) where++import qualified Data.Attoparsec.ByteString.Char8      as BC+import           Data.ByteString                       as BS+import           HaskellWorks.Data.Xml.Token.Tokenize+import           Test.Hspec++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}++parseXmlToken' :: ByteString -> Either String (XmlToken String Double)+parseXmlToken' = BC.parseOnly parseXmlToken++spec :: Spec+spec = describe "Data.Conduit.Succinct.XmlSpec" $ do+  describe "When parsing single token at beginning of text" $ do+    it "Empty Xml should produce no bits" $+      parseXmlToken' "" `shouldBe` Left "not enough input"+    it "Xml with one space should produce whitespace token" $+      parseXmlToken' " " `shouldBe` Right XmlTokenWhitespace+    it "Xml with two spaces should produce whitespace token" $+      parseXmlToken' "  " `shouldBe` Right XmlTokenWhitespace+    it "Spaces and newlines should produce no bits" $+      parseXmlToken' "  \n \r \t " `shouldBe` Right XmlTokenWhitespace+    it "`null` at beginning should produce one bit" $+      parseXmlToken' "null " `shouldBe` Right XmlTokenNull+    it "number at beginning should produce one bit" $+      parseXmlToken' "1234 " `shouldBe` Right (XmlTokenNumber 1234)+    it "false at beginning should produce one bit" $+      parseXmlToken' "false " `shouldBe` Right (XmlTokenBoolean False)+    it "true at beginning should produce one bit" $+      parseXmlToken' "true " `shouldBe` Right (XmlTokenBoolean True)+    it "string at beginning should produce one bit" $+      parseXmlToken' "\"hello\" " `shouldBe` Right (XmlTokenString "hello")+    it "quoted string should parse" $+      parseXmlToken' "\"\\\"\" " `shouldBe` Right (XmlTokenString "\"")+    it "left brace at beginning should produce one bit" $+      parseXmlToken' "{ " `shouldBe` Right XmlTokenBraceL+    it "right brace at beginning should produce one bit" $+      parseXmlToken' "} " `shouldBe` Right XmlTokenBraceR+    it "left bracket at beginning should produce one bit" $+      parseXmlToken' "[ " `shouldBe` Right XmlTokenBracketL+    it "right bracket at beginning should produce one bit" $+      parseXmlToken' "] " `shouldBe` Right XmlTokenBracketR+    it "right bracket at beginning should produce one bit" $+      parseXmlToken' ": " `shouldBe` Right XmlTokenColon+    it "right bracket at beginning should produce one bit" $+      parseXmlToken' ", " `shouldBe` Right XmlTokenComma
+ test/HaskellWorks/Data/Xml/TypeSpec.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ExplicitForAll            #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE InstanceSigs              #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE ScopedTypeVariables       #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module HaskellWorks.Data.Xml.TypeSpec (spec) where++import           Control.Monad+import qualified Data.ByteString                                            as BS+import           Data.String+import qualified Data.Vector.Storable                                       as DVS+import           Data.Word+import           HaskellWorks.Data.Bits.BitShown+import           HaskellWorks.Data.Bits.BitWise+import           HaskellWorks.Data.FromForeignRegion+import           HaskellWorks.Data.BalancedParens.BalancedParens+import           HaskellWorks.Data.BalancedParens.Simple+import           HaskellWorks.Data.RankSelect.Base.Rank0+import           HaskellWorks.Data.RankSelect.Base.Rank1+import           HaskellWorks.Data.RankSelect.Base.Select1+import           HaskellWorks.Data.RankSelect.Poppy512+import qualified HaskellWorks.Data.TreeCursor                               as TC+import           HaskellWorks.Data.Xml.Succinct.Cursor                      as C+import           HaskellWorks.Data.Xml.Succinct.Index+import           HaskellWorks.Data.Xml.Type+import           Test.Hspec++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: redundant bracket"          :: String) #-}++fc = TC.firstChild+ns = TC.nextSibling++spec :: Spec+spec = describe "HaskellWorks.Data.Json.Succinct.CursorSpec" $ do+  describe "Cursor for [Bool]" $ do+    it "initialises to beginning of empty object" $ do+      let cursor = "<elem />" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])+      xmlTypeAt cursor `shouldBe` Just XmlTypeElement+    it "initialises to beginning of empty object preceded by spaces" $ do+      let cursor = " <elem />" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])+      xmlTypeAt cursor `shouldBe` Just XmlTypeElement+    it "cursor can navigate to attr list" $ do+      let cursor = "<a foo='bar' boo='buzz'/>" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])+      (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList+    it "cursor can navigate through attrs" $ do+      let cursor = "<a foo='bar' boo='buzz'/>" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])+      (fc >=> fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --foo+      (fc >=> fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --bar+      (fc >=> fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --boo+      (fc >=> fc >=> ns >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --buzz+      (fc >=> fc >=> ns >=> ns >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing --back off!+    it "cursor can navigate to children" $ do+      let cursor = "<a><b /><c /></a>" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])+      (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --b+      (fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --c+      (fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing --back off!+    it "cursor recognises child element as an element child next to attr list" $ do+      let cursor = "<a foo='bar'><inner /></a>" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])+      (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList+      (fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement+      (fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing -- no more!++  genSpec "DVS.Vector Word8"  (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8)))+  genSpec "DVS.Vector Word16" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16)))+  genSpec "DVS.Vector Word32" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32)))+  genSpec "DVS.Vector Word64" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)))+  genSpec "Poppy512"          (undefined :: XmlCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64)))++genSpec :: forall t u.+  ( Eq                t+  , Show              t+  , Select1           t+  , Eq                u+  , Show              u+  , Rank0             u+  , Rank1             u+  , BalancedParens    u+  , TestBit           u+  , FromForeignRegion (XmlCursor BS.ByteString t u)+  , IsString          (XmlCursor BS.ByteString t u)+  , XmlIndexAt        (XmlCursor BS.ByteString t u)+  )+  => String -> (XmlCursor BS.ByteString t u) -> SpecWith ()+genSpec t _ = do+  describe ("Json cursor of type " ++ t) $ do+    let forXml (cursor :: XmlCursor BS.ByteString t u) f = describe ("of value " ++ show cursor) (f cursor)+    forXml "<elem/>" $ \cursor -> do+      it "should have correct type"       $         xmlTypeAt  cursor `shouldBe` Just XmlTypeElement+    forXml " <elem />" $ \cursor -> do+      it "should have correct type"       $         xmlTypeAt  cursor `shouldBe` Just XmlTypeElement+    forXml "<a foo='bar' boo='buzz'><inner data='none' /></a>" $ \cursor -> do+      it "cursor can navigate to second attribute" $ do+        (fc >=> fc >=> ns >=> ns >=> xmlTypeAt)  cursor  `shouldBe` Just XmlTypeToken+      it "cursor can navigate to first attribute of an inner element" $ do+        (fc >=> ns >=> fc >=> fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken+      it "cursor can navigate to first atrribute value of an inner element" $ do+        (fc >=> ns >=> fc >=> fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken+    describe "For a single element" $ do+      let cursor =  "<a>text</a>" :: XmlCursor BS.ByteString t u+      it "can navigate down and forwards" $ do+        (                     xmlTypeAt) cursor `shouldBe` Just XmlTypeElement+        (fc               >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken+        (fc >=> ns        >=> xmlTypeAt) cursor `shouldBe` Nothing+        (fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing+    describe "For sample Xml" $ do+      let cursor = "<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 navigate down and forwards" $ do+        (                                                                      xmlTypeAt) cursor `shouldBe` Just XmlTypeElement     --widget+        (fc                                                                >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList    --widget attrs+        (fc >=> ns                                                         >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement     --window+        (fc >=> ns >=> fc                                                  >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList    --window attrs+        (fc >=> ns >=> fc >=> ns                                           >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement     --dimension 500+        (fc >=> ns >=> fc >=> ns >=> ns                                    >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement     --dimension 600+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns                             >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement     --dimension false+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc                      >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken       --false
+ test/HaskellWorks/Data/Xml/ValueSpec.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE ExplicitForAll             #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE InstanceSigs               #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE NoMonomorphismRestriction  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE ScopedTypeVariables        #-}++{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module HaskellWorks.Data.Xml.ValueSpec (spec) where++import           Control.Monad+import           Data.Monoid+import qualified Data.ByteString                                  as BS+import           Data.String+import qualified Data.Vector.Storable                             as DVS+import           Data.Word+import           HaskellWorks.Data.Bits.BitShown+import           HaskellWorks.Data.Bits.BitWise+import           HaskellWorks.Data.FromForeignRegion+import           HaskellWorks.Data.Xml.Succinct.Cursor            as C+import           HaskellWorks.Data.Xml.Succinct.Index+import           HaskellWorks.Data.Xml.Value+import           HaskellWorks.Data.BalancedParens.BalancedParens+import           HaskellWorks.Data.BalancedParens.Simple+import           HaskellWorks.Data.RankSelect.Base.Rank0+import           HaskellWorks.Data.RankSelect.Base.Rank1+import           HaskellWorks.Data.RankSelect.Base.Select1+import           HaskellWorks.Data.RankSelect.Poppy512+import qualified HaskellWorks.Data.TreeCursor                     as TC+import           Test.Hspec++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+--{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}++fc = TC.firstChild+ns = TC.nextSibling+-- cd = TC.depth++attrs :: [(String, String)] -> XmlValue+attrs as = XmlAttrList $ as >>= (\(k, v) -> [XmlAttrName k, XmlAttrValue v])++spec :: Spec+spec = describe "HaskellWorks.Data.Xml.ValueSpec" $ do+  genSpec "DVS.Vector Word8"  (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8)))+  genSpec "DVS.Vector Word16" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16)))+  genSpec "DVS.Vector Word32" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32)))+  genSpec "DVS.Vector Word64" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)))+  genSpec "Poppy512"          (undefined :: XmlCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64)))++xmlValueVia  :: XmlIndexAt (XmlCursor BS.ByteString t u)+              => Maybe (XmlCursor BS.ByteString t u) -> XmlValue+xmlValueVia mk = case mk of+  Just k    -> xmlValueAt (xmlIndexAt k) --either (\(DecodeError e) -> XmlError e) id (xmlValueAt <$> xmlIndexAt k)+  Nothing   -> XmlError "No such element"++genSpec :: forall t u.+  ( Eq                t+  , Show              t+  , Select1           t+  , Eq                u+  , Show              u+  , Rank0             u+  , Rank1             u+  , BalancedParens    u+  , TestBit           u+  , FromForeignRegion (XmlCursor BS.ByteString t u)+  , IsString          (XmlCursor BS.ByteString t u)+  , XmlIndexAt        (XmlCursor BS.ByteString t u)+  )+  => String -> XmlCursor BS.ByteString t u -> SpecWith ()+genSpec t _ = do+  describe ("Json cursor of type " <> t) $ do+    let forXml (cursor :: XmlCursor BS.ByteString t u) f = describe ("of value " <> show cursor) (f cursor)++    forXml "<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/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/data/sample.xml view
@@ -0,0 +1,28 @@+{+    "widget": {+        "debug": "on",+        "window": {+            "title": "Sample Konfabulator Widget",+            "name": "main_window",+            "width": 500,+            "height": 500+        },+        "image": {+            "src": "Images/Sun.png",+            "name": "sun1",+            "hOffset": 250,+            "vOffset": 250,+            "alignment": "center"+        },+        "text": {+            "data": "Click Here",+            "size": 36,+            "style": "bold",+            "name": "text1",+            "hOffset": 250,+            "vOffset": 100,+            "alignment": "center",+            "onMouseUp": "sun1.opacity = (sun1.opacity / 100) * 90;"+        }+    }+}