hw-xml 0.3.0.0 → 0.4.0.0

raw patch · 31 files changed

+854/−537 lines, 31 filesdep +generic-lensdep +hedgehogdep +hw-hspec-hedgehogdep −QuickCheckdep −conduitdep −hw-conduitdep ~hw-primnew-component:exe:hw-xmlPVP ok

version bump matches the API change (PVP)

Dependencies added: generic-lens, hedgehog, hw-hspec-hedgehog, optparse-applicative, text

Dependencies removed: QuickCheck, conduit, hw-conduit

Dependency ranges changed: hw-prim

API changes (from Hackage documentation)

Files

• app/App/Commands.hs +15/−0
• app/App/Commands/Count.hs +119/−0
• app/App/Commands/Demo.hs +92/−0
• app/App/Commands/Types.hs +19/−0
• app/App/Naive.hs +44/−0
• app/App/Options.hs +16/−0
• app/App/Show.hs +10/−0
• app/App/XPath/Parser.hs +19/−0
• app/App/XPath/Types.hs +10/−0
• app/Main.hs +7/−108
• bench/Main.hs +4/−7
• hw-xml.cabal +37/−19
• src/HaskellWorks/Data/Xml/Conduit.hs +47/−84
• src/HaskellWorks/Data/Xml/Conduit/Blank.hs +20/−26
• src/HaskellWorks/Data/Xml/Decode.hs +4/−4
• src/HaskellWorks/Data/Xml/Internal/ToIbBp64.hs +44/−0
• src/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParens.hs +4/−9
• src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs +3/−5
• src/HaskellWorks/Data/Xml/Succinct/Cursor/Create.hs +34/−0
• src/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBits.hs +3/−3
• src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs +2/−13
• src/HaskellWorks/Data/Xml/Succinct/Cursor/Load.hs +21/−0
• src/HaskellWorks/Data/Xml/Succinct/Cursor/MMap.hs +51/−0
• src/HaskellWorks/Data/Xml/Succinct/Cursor/Types.hs +20/−0
• test/HaskellWorks/Data/Xml/Conduit/BlankSpec.hs +30/−26
• test/HaskellWorks/Data/Xml/RawValueSpec.hs +21/−25
• test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs +26/−27
• test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs +18/−17
• test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs +52/−73
• test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs +34/−32
• test/HaskellWorks/Data/Xml/TypeSpec.hs +28/−59

@@ -0,0 +1,15 @@+module App.Commands where++import App.Commands.Count+import App.Commands.Demo+import Data.Semigroup      ((<>))+import Options.Applicative++commands :: Parser (IO ())+commands = commandsGeneral++commandsGeneral :: Parser (IO ())+commandsGeneral = subparser $ mempty+  <>  commandGroup "Commands:"+  <>  cmdCount+  <>  cmdDemo

@@ -0,0 +1,119 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeSynonymInstances #-}++module App.Commands.Count+  ( cmdCount+  ) where++import App.Options+import Control.Lens+import Control.Monad+import Data.Generics.Product.Any+import Data.Semigroup                             ((<>))+import Data.Text                                  (Text)+import HaskellWorks.Data.TreeCursor+import HaskellWorks.Data.Xml.DecodeResult+import HaskellWorks.Data.Xml.RawDecode+import HaskellWorks.Data.Xml.RawValue+import HaskellWorks.Data.Xml.Succinct.Cursor.Load+import HaskellWorks.Data.Xml.Succinct.Cursor.MMap+import HaskellWorks.Data.Xml.Succinct.Index+import HaskellWorks.Data.Xml.Value+import Options.Applicative                        hiding (columns)++import qualified App.Commands.Types as Z+import qualified App.Naive          as NAIVE+import qualified App.XPath.Parser   as XPP+import qualified Data.Text          as T+import qualified System.Exit        as IO+import qualified System.IO          as IO++-- | Document model.  This does not need to be able to completely represent all+-- the data in the XML document.  In fact, having a smaller model may improve+-- Count performance.+data Plant = Plant+  { common :: String+  , price  :: String+  } deriving (Eq, Show)++newtype Catalog = Catalog+  { plants :: [Plant]+  } deriving (Eq, Show)++tags :: Value -> String -> [Value]+tags xml@(XmlElement n _ _) elemName = if n == elemName+  then [xml]+  else []+tags _ _ = []++kids :: Value -> [Value]+kids (XmlElement _ _ cs) = cs+kids _                   = []++countAtPath :: [Text] -> Value -> DecodeResult Int+countAtPath []  _   = return 0+countAtPath [t] xml = return (length (tags xml (T.unpack t)))+countAtPath (t:ts) xml = do+  counts <- forM (tags xml (T.unpack t) >>= kids) $ countAtPath ts+  return (sum counts)++runCount :: Z.CountOptions -> IO ()+runCount opt = do+  let input   = opt ^. the @"input"+  let xpath   = opt ^. the @"xpath"+  let method  = opt ^. the @"method"++  IO.putStrLn $ "XPath: " <> show xpath++  cursorResult <- case method of+    "mmap"   -> Right <$> mmapFastCursor input+    "memory" -> Right <$> loadFastCursor input+    "naive"  -> Right <$> NAIVE.loadFastCursor input+    unknown  -> return (Left ("Unknown method " <> show unknown))++  case cursorResult of+    Right !cursor -> do+      -- Skip the XML declaration to get to the root element cursor+      case nextSibling cursor of+        Just rootCursor -> do+          -- Get the root raw XML value at the root element cursor+          let rootValue = rawValueAt (xmlIndexAt rootCursor)+          -- Show what we have at this cursor+          putStrLn $ "Raw value: " <> take 100 (show rootValue)+          -- Decode the raw XML value+          case countAtPath (xpath ^. the @"path") (rawDecode rootValue) of+            DecodeOk count   -> putStrLn $ "Count: " <> show count+            DecodeFailed msg -> putStrLn $ "Error: " <> show msg+        Nothing -> do+          putStrLn "Could not read XML"+          return ()+    Left msg -> do+      IO.putStrLn $ "Error: " <> msg+      IO.exitFailure++optsCount :: Parser Z.CountOptions+optsCount = Z.CountOptions+  <$> strOption+      (   long "input"+      <>  help "Input file"+      <>  metavar "FILE"+      )+  <*> optionParser XPP.path+      (   long "xpath"+      <>  help "XPath expression"+      <>  metavar "XPATH"+      )+  <*> textOption+      (   long "method"+      <>  help "Read method"+      <>  metavar "METHOD"+      )++cmdCount :: Mod CommandFields (IO ())+cmdCount = command "count"  $ flip info idm $ runCount <$> optsCount

@@ -0,0 +1,92 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeSynonymInstances #-}++module App.Commands.Demo+  ( cmdDemo+  ) where++import Data.Foldable+import Data.Maybe+import Data.Semigroup                             ((<>))+import HaskellWorks.Data.TreeCursor+import HaskellWorks.Data.Xml.Decode+import HaskellWorks.Data.Xml.DecodeResult+import HaskellWorks.Data.Xml.RawDecode+import HaskellWorks.Data.Xml.RawValue+import HaskellWorks.Data.Xml.Succinct.Cursor.Load+import HaskellWorks.Data.Xml.Succinct.Index+import HaskellWorks.Data.Xml.Value+import Options.Applicative                        hiding (columns)++import qualified App.Commands.Types as Z++-- | Parse the text of an XML node.+class ParseText a where+  parseText :: Value -> DecodeResult a++instance ParseText String where+  parseText (XmlText text)      = DecodeOk text+  parseText (XmlCData text)     = DecodeOk text+  parseText (XmlElement _ _ cs) = DecodeOk $ concat $ concat $ toList . parseText <$> cs+  parseText _                   = DecodeOk ""++-- | Convert a decode result to a maybe+decodeResultToMaybe :: DecodeResult a -> Maybe a+decodeResultToMaybe (DecodeOk a) = Just a+decodeResultToMaybe _            = Nothing++-- | Document model.  This does not need to be able to completely represent all+-- the data in the XML document.  In fact, having a smaller model may improve+-- query performance.+data Plant = Plant+  { common :: String+  , price  :: String+  } deriving (Eq, Show)++newtype Catalog = Catalog+  { plants :: [Plant]+  } deriving (Eq, Show)++-- | Decode plant element+decodePlant :: Value -> DecodeResult Plant+decodePlant xml = do+  aCommon <- xml /> "common"  >>= parseText+  aPrice  <- xml /> "price"   >>= parseText+  return $ Plant aCommon aPrice++-- | Decode catalog element+decodeCatalog :: Value -> DecodeResult Catalog+decodeCatalog xml = do+  aPlantXmls <- xml />> "plant"+  let aPlants = catMaybes (decodeResultToMaybe . decodePlant <$> aPlantXmls)+  return $ Catalog aPlants++runDemo :: Z.DemoOptions -> IO ()+runDemo _ = do+  -- Read XML into memory as a query-optimised cursor+  !cursor <- loadFastCursor "data/catalog.xml"+  -- Skip the XML declaration to get to the root element cursor+  case nextSibling cursor of+    Just rootCursor -> do+      -- Get the root raw XML value at the root element cursor+      let rootValue = rawValueAt (xmlIndexAt rootCursor)+      -- Show what we have at this cursor+      putStrLn $ "Raw value: " <> take 100 (show rootValue)+      -- Decode the raw XML value+      case decodeCatalog (rawDecode rootValue) of+        DecodeOk catalog -> putStrLn $ "Catalog: " <> show catalog+        DecodeFailed msg -> putStrLn $ "Error: " <> show msg+    Nothing -> do+      putStrLn "Could not read XML"+      return ()++optsDemo :: Parser Z.DemoOptions+optsDemo = pure Z.DemoOptions++cmdDemo :: Mod CommandFields (IO ())+cmdDemo = command "demo"  $ flip info idm $ runDemo <$> optsDemo

@@ -0,0 +1,19 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}++module App.Commands.Types+  ( CountOptions(..)+  , DemoOptions(..)+  ) where++import App.XPath.Types (XPath)+import Data.Text       (Text)+import GHC.Generics++data DemoOptions = DemoOptions deriving (Eq, Show, Generic)++data CountOptions = CountOptions+  { input  :: FilePath+  , xpath  :: XPath+  , method :: Text+  } deriving (Eq, Show, Generic)

@@ -0,0 +1,44 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeSynonymInstances #-}++module App.Naive+  ( loadSlowCursor+  , loadFastCursor+  ) where++import HaskellWorks.Data.BalancedParens.RangeMin2+import HaskellWorks.Data.BalancedParens.Simple+import HaskellWorks.Data.Bits.BitShown+import HaskellWorks.Data.FromByteString+import HaskellWorks.Data.RankSelect.CsPoppy1+import HaskellWorks.Data.Xml.Succinct.Cursor+import HaskellWorks.Data.Xml.Succinct.Cursor.MMap++import qualified Data.ByteString as BS++-- | Load an XML file into memory and return a raw cursor initialised to the+-- start of the XML document.+loadSlowCursor :: String -> IO SlowCursor+loadSlowCursor path = do+  !bs <- BS.readFile path+  let !cursor = fromByteString bs :: SlowCursor+  return cursor++-- | Load an XML file into memory and return a query-optimised cursor initialised+-- to the start of the XML document.+loadFastCursor :: String -> IO FastCursor+loadFastCursor filename = do+  -- Load the XML file into memory as a raw cursor.+  -- The raw XML data is `text`, and `ib` and `bp` are the indexes.+  -- `ib` and `bp` can be persisted to an index file for later use to avoid+  -- re-parsing the file.+  XmlCursor !text (BitShown !ib) (SimpleBalancedParens !bp) _ <- loadSlowCursor filename+  let !bpCsPoppy = makeCsPoppy bp+  let !rangeMinMax = mkRangeMin2 bpCsPoppy+  let !ibCsPoppy = makeCsPoppy ib+  return $ XmlCursor text ibCsPoppy rangeMinMax 1

@@ -0,0 +1,16 @@+module App.Options+  ( optionParser+  , textOption+  ) where++import Data.Text (Text)++import qualified Data.Attoparsec.Text as AT+import qualified Data.Text            as T+import qualified Options.Applicative  as OA++optionParser :: AT.Parser a -> OA.Mod OA.OptionFields a -> OA.Parser a+optionParser p = OA.option (OA.eitherReader (AT.parseOnly p . T.pack))++textOption :: OA.Mod OA.OptionFields String -> OA.Parser Text+textOption = fmap T.pack . OA.strOption

@@ -0,0 +1,10 @@+module App.Show+  ( tshow+  ) where++import Data.Text (Text)++import qualified Data.Text as T++tshow :: Show a => a -> Text+tshow = T.pack . show

@@ -0,0 +1,19 @@+module App.XPath.Parser+  ( path+  ) where++import Control.Applicative+import Data.Attoparsec.Text+import Data.Text            (Text)++import qualified App.XPath.Types as XP+import qualified Data.Text       as T++tag :: Parser Text+tag = T.cons <$> letter <*> tagTail++tagTail :: Parser Text+tagTail = T.pack <$> many (letter <|> digit <|> char '-' <|> char '_')++path :: Parser XP.XPath+path = XP.XPath <$> sepBy1 tag (char '/')

@@ -0,0 +1,10 @@+{-# LANGUAGE DeriveGeneric #-}++module App.XPath.Types where++import Data.Text    (Text)+import GHC.Generics++newtype XPath = XPath+  { path :: [Text]+  } deriving (Eq, Show, Generic)

@@ -1,112 +1,11 @@-{-# LANGUAGE BangPatterns         #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE TypeSynonymInstances #-}- module Main where -import Data.Foldable-import Data.Maybe-import Data.Semigroup                             ((<>))-import Data.Word-import HaskellWorks.Data.BalancedParens.RangeMin2-import HaskellWorks.Data.BalancedParens.Simple-import HaskellWorks.Data.Bits.BitShown-import HaskellWorks.Data.FromByteString-import HaskellWorks.Data.RankSelect.CsPoppy1-import HaskellWorks.Data.TreeCursor-import HaskellWorks.Data.Xml.Decode-import HaskellWorks.Data.Xml.DecodeResult-import HaskellWorks.Data.Xml.RawDecode-import HaskellWorks.Data.Xml.RawValue-import HaskellWorks.Data.Xml.Succinct.Cursor-import HaskellWorks.Data.Xml.Succinct.Index-import HaskellWorks.Data.Xml.Value--import qualified Data.ByteString      as BS-import qualified Data.Vector.Storable as DVS--type RawCursor = XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))-type FastCursor = XmlCursor BS.ByteString CsPoppy1 (RangeMin2 CsPoppy1)---- | Read an XML file into memory and return a raw cursor initialised to the--- start of the XML document.-readRawCursor :: String -> IO RawCursor-readRawCursor path = do-  !bs <- BS.readFile path-  let !cursor = fromByteString bs :: RawCursor-  return cursor---- | Read an XML file into memory and return a query-optimised cursor initialised--- to the start of the XML document.-readFastCursor :: String -> IO FastCursor-readFastCursor filename = do-  -- Load the XML file into memory as a raw cursor.-  -- The raw XML data is `text`, and `ib` and `bp` are the indexes.-  -- `ib` and `bp` can be persisted to an index file for later use to avoid-  -- re-parsing the file.-  XmlCursor !text (BitShown !ib) (SimpleBalancedParens !bp) _ <- readRawCursor filename-  let !bpCsPoppy = makeCsPoppy bp-  let !rangeMinMax = mkRangeMin2 bpCsPoppy-  let !ibCsPoppy = makeCsPoppy ib-  return $ XmlCursor text ibCsPoppy rangeMinMax 1---- | Parse the text of an XML node.-class ParseText a where-  parseText :: Value -> DecodeResult a--instance ParseText String where-  parseText (XmlText text)      = DecodeOk text-  parseText (XmlCData text)     = DecodeOk text-  parseText (XmlElement _ _ cs) = DecodeOk $ concat $ concat $ toList . parseText <$> cs-  parseText _                   = DecodeOk ""---- | Convert a decode result to a maybe-decodeResultToMaybe :: DecodeResult a -> Maybe a-decodeResultToMaybe (DecodeOk a) = Just a-decodeResultToMaybe _            = Nothing---- | Document model.  This does not need to be able to completely represent all--- the data in the XML document.  In fact, having a smaller model may improve--- query performance.-data Plant = Plant-  { common :: String-  , price  :: String-  } deriving (Eq, Show)--newtype Catalog = Catalog-  { plants :: [Plant]-  } deriving (Eq, Show)---- | Decode plant element-decodePlant :: Value -> DecodeResult Plant-decodePlant xml = do-  aCommon <- xml /> "common"  >>= parseText-  aPrice  <- xml /> "price"   >>= parseText-  return $ Plant aCommon aPrice---- | Decode catalog element-decodeCatalog :: Value -> DecodeResult Catalog-decodeCatalog xml = do-  aPlantXmls <- xml />> "plant"-  let aPlants = catMaybes (decodeResultToMaybe . decodePlant <$> aPlantXmls)-  return $ Catalog aPlants+import App.Commands+import Control.Monad+import Data.Semigroup      ((<>))+import Options.Applicative  main :: IO ()-main = do-  -- Read XML into memory as a query-optimised cursor-  !cursor <- readFastCursor "data/catalog.xml"-  -- Skip the XML declaration to get to the root element cursor-  case nextSibling cursor of-    Just rootCursor -> do-      -- Get the root raw XML value at the root element cursor-      let rootValue = rawValueAt (xmlIndexAt rootCursor)-      -- Show what we have at this cursor-      putStrLn $ "Raw value: " <> take 100 (show rootValue)-      -- Decode the raw XML value-      case decodeCatalog (rawDecode rootValue) of-        DecodeOk catalog -> putStrLn $ "Catalog: " <> show catalog-        DecodeFailed msg -> putStrLn $ "Error: " <> show msg-    Nothing -> do-      putStrLn "Could not read XML"-      return ()+main = join $ customExecParser+  (prefs $ showHelpOnEmpty <> showHelpOnError)+  (info (commands <**> helper) idm)

@@ -3,14 +3,11 @@  module Main where -import Control.Monad.Trans.Resource            (MonadThrow) import Criterion.Main-import Data.Conduit import Data.Word import Foreign import HaskellWorks.Data.BalancedParens.Simple import HaskellWorks.Data.Bits.BitShown-import HaskellWorks.Data.Conduit.List import HaskellWorks.Data.FromByteString import HaskellWorks.Data.Xml.Conduit import HaskellWorks.Data.Xml.Conduit.Blank@@ -30,11 +27,11 @@ 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+xmlToInterestBits3 :: [BS.ByteString] -> [BS.ByteString]+xmlToInterestBits3 = blankedXmlToInterestBits . blankXml -runCon :: Conduit i [] BS.ByteString -> i -> BS.ByteString-runCon con bs = BS.concat $ runListConduit con [bs]+runCon :: ([i] -> [BS.ByteString]) -> i -> BS.ByteString+runCon con bs = BS.concat $ con [bs]  benchRankXmlCatalogConduits :: [Benchmark] benchRankXmlCatalogConduits =

@@ -1,7 +1,7 @@ cabal-version:      2.2  name:               hw-xml-version:            0.3.0.0+version:            0.4.0.0 synopsis:           Conduits for tokenizing streams. description:        Conduits for tokenizing streams. Please see README.md category:           Data, XML, Succinct Data Structures, Data Structures@@ -25,31 +25,31 @@  common base                       { build-depends: base                       >= 4.7        && < 5      } -common QuickCheck                 { build-depends: QuickCheck                 >= 2.13.1     && < 3      } common ansi-wl-pprint             { build-depends: ansi-wl-pprint             >= 0.6.9      && < 0.7    } common array                      { build-depends: array                      >= 0.5.2.0    && < 0.6    } common attoparsec                 { build-depends: attoparsec                 >= 0.13.2.2   && < 0.14   } common bytestring                 { build-depends: bytestring                 >= 0.10.8.2   && < 0.11   } common cereal                     { build-depends: cereal                     >= 0.5.8.1    && < 0.6    }-common conduit                    { build-depends: conduit                    >= 1.3.1.1    && < 1.4    } common containers                 { build-depends: containers                 >= 0.6.2.1    && < 0.7    } common criterion                  { build-depends: criterion                  >= 1.5.5.0    && < 1.6    } common deepseq                    { build-depends: deepseq                    >= 1.4.3.0    && < 1.5    }+common generic-lens               { build-depends: generic-lens               >= 1.1.0.0    && < 1.3    } common ghc-prim                   { build-depends: ghc-prim                   >= 0.5        && < 0.6    } common hedgehog                   { build-depends: hedgehog                   >= 1.0        && < 1.1    } common hspec                      { build-depends: hspec                      >= 2.5        && < 3.0    } common hw-balancedparens          { build-depends: hw-balancedparens          >= 0.3.0.0    && < 0.4    } common hw-bits                    { build-depends: hw-bits                    >= 0.7.0.6    && < 0.8    }-common hw-conduit                 { build-depends: hw-conduit                 >= 0.2.0.5    && < 0.3    } common hw-hspec-hedgehog          { build-depends: hw-hspec-hedgehog          >= 0.1        && < 0.2    } common hw-parser                  { build-depends: hw-parser                  >= 0.1.0.1    && < 0.2    }-common hw-prim                    { build-depends: hw-prim                    >= 0.6.2.28   && < 0.7    }+common hw-prim                    { build-depends: hw-prim                    >= 0.6.2.33   && < 0.7    } common hw-rankselect              { build-depends: hw-rankselect              >= 0.13.2.0   && < 0.14   } common hw-rankselect-base         { build-depends: hw-rankselect-base         >= 0.3.2.1    && < 0.4    } common lens                       { build-depends: lens                       >= 4.17.1     && < 5.0    } common mmap                       { build-depends: mmap                       >= 0.5.9      && < 0.6    } common mtl                        { build-depends: mtl                        >= 2.2.2      && < 3      }+common optparse-applicative       { build-depends: optparse-applicative       >= 0.15.1.0   && < 0.16   } common resourcet                  { build-depends: resourcet                  >= 1.2.2      && < 1.3    }+common text                       { build-depends: text                       >= 1.2.4.0    && < 1.3    } common transformers               { build-depends: transformers               >= 0.5.5.0    && < 0.6    } common vector                     { build-depends: vector                     >= 0.12.0.3   && < 0.13   } common word8                      { build-depends: word8                      >= 0.1.3      && < 0.2    }@@ -65,18 +65,17 @@           , base           , bytestring           , cereal-          , conduit           , containers           , deepseq           , ghc-prim           , hw-balancedparens           , hw-bits-          , hw-conduit           , hw-parser           , hw-prim           , hw-rankselect           , hw-rankselect-base           , lens+          , mmap           , mtl           , resourcet           , transformers@@ -94,13 +93,18 @@     HaskellWorks.Data.Xml.DecodeResult     HaskellWorks.Data.Xml.Grammar     HaskellWorks.Data.Xml.Index+    HaskellWorks.Data.Xml.Internal.ToIbBp64     HaskellWorks.Data.Xml.Lens     HaskellWorks.Data.Xml.Succinct     HaskellWorks.Data.Xml.Succinct.Cursor     HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParens     HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml+    HaskellWorks.Data.Xml.Succinct.Cursor.Create     HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits     HaskellWorks.Data.Xml.Succinct.Cursor.Internal+    HaskellWorks.Data.Xml.Succinct.Cursor.Load+    HaskellWorks.Data.Xml.Succinct.Cursor.Types+    HaskellWorks.Data.Xml.Succinct.Cursor.MMap     HaskellWorks.Data.Xml.Succinct.Cursor.Token     HaskellWorks.Data.Xml.Succinct.Index     HaskellWorks.Data.Xml.RawDecode@@ -115,32 +119,48 @@   hs-source-dirs:     src   ghc-options:        -Wall -O2 -msse4.2 -executable hw-xml-example+executable hw-xml   import:   base, config+          , attoparsec           , bytestring+          , generic-lens           , hw-balancedparens           , hw-bits           , hw-prim           , hw-rankselect+          , lens+          , mmap+          , mtl+          , optparse-applicative+          , resourcet+          , text           , vector-  main-is:            Main.hs-  other-modules:      Paths_hw_xml-  autogen-modules:    Paths_hw_xml-  build-depends:      hw-xml-  hs-source-dirs:     app-  ghc-options:        -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -msse4.2+  main-is:              Main.hs+  other-modules:        Paths_hw_xml+                        App.Commands+                        App.Commands.Count+                        App.Commands.Demo+                        App.Commands.Types+                        App.Options+                        App.XPath.Parser+                        App.XPath.Types+                        App.Show+                        App.Naive+  autogen-modules:      Paths_hw_xml+  build-depends:        hw-xml+  hs-source-dirs:       app+  ghc-options:          -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -msse4.2  test-suite hw-xml-test   import:   base, config-          , QuickCheck           , attoparsec           , base           , bytestring-          , conduit+          , hedgehog           , hspec           , hw-balancedparens           , hw-bits-          , hw-conduit+          , hw-hspec-hedgehog           , hw-prim           , hw-rankselect           , hw-rankselect-base@@ -166,11 +186,9 @@ benchmark bench   import:   base, config           , bytestring-          , conduit           , criterion           , hw-balancedparens           , hw-bits-          , hw-conduit           , hw-prim           , mmap           , resourcet

@@ -4,17 +4,14 @@ module HaskellWorks.Data.Xml.Conduit   ( blankedXmlToInterestBits   , byteStringToBits-  , blankedXmlToBalancedParens   , blankedXmlToBalancedParens2   , compressWordAsBit   , interestingWord8s   , isInterestingWord8   ) where -import Control.Monad import Data.Array.Unboxed             as A import Data.ByteString                as BS-import Data.Conduit import Data.Word import Data.Word8 import HaskellWorks.Data.Bits.BitWise@@ -39,25 +36,22 @@ isInterestingWord8 b = interestingWord8s ! b {-# INLINABLE isInterestingWord8 #-} -blankedXmlToInterestBits :: Monad m => ConduitT BS.ByteString BS.ByteString m ()+blankedXmlToInterestBits :: [BS.ByteString] -> [BS.ByteString] blankedXmlToInterestBits = blankedXmlToInterestBits' "" -blankedXmlToInterestBits' :: Monad m => BS.ByteString -> ConduitT BS.ByteString BS.ByteString m ()-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 `quot` 8-      let (ds, es) = BS.splitAt (q * 8) cs-      let (fs, _) = BS.unfoldrN q gen ds-      yield fs-      blankedXmlToInterestBits' es-    Nothing -> do-      let lenrs = BS.length rs-      let q = lenrs + 7 `quot` 8-      yield (fst (BS.unfoldrN q gen rs))+blankedXmlToInterestBits' :: BS.ByteString -> [BS.ByteString] -> [BS.ByteString]+blankedXmlToInterestBits' rs is = case is of+  (bs:bss) -> do+    let cs = if BS.length rs /= 0 then BS.concat [rs, bs] else bs+    let lencs = BS.length cs+    let q = lencs `quot` 8+    let (ds, es) = BS.splitAt (q * 8) cs+    let (fs, _) = BS.unfoldrN q gen ds+    fs:blankedXmlToInterestBits' es bss+  [] -> do+    let lenrs = BS.length rs+    let q = lenrs + 7 `quot` 8+    [fst (BS.unfoldrN q gen rs)]   where gen :: ByteString -> Maybe (Word8, ByteString)         gen as = if BS.length as == 0           then Nothing@@ -65,51 +59,24 @@                     , BS.drop 8 as                     ) -blankedXmlToBalancedParens :: Monad m => ConduitT BS.ByteString Bool m ()-blankedXmlToBalancedParens = do-  mbs <- await-  case mbs of-    Just bs -> blankedXmlToBalancedParens' bs-    Nothing -> return ()--blankedXmlToBalancedParens' :: Monad m => BS.ByteString -> ConduitT BS.ByteString Bool m ()-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 ()- repartitionMod8 :: BS.ByteString -> BS.ByteString -> (BS.ByteString, BS.ByteString) repartitionMod8 aBS bBS = (BS.take cLen abBS, BS.drop cLen abBS)   where abBS = BS.concat [aBS, bBS]         abLen = BS.length abBS         cLen = (abLen `div` 8) * 8 -compressWordAsBit :: Monad m => ConduitT BS.ByteString BS.ByteString m ()+compressWordAsBit :: [BS.ByteString] -> [BS.ByteString] compressWordAsBit = compressWordAsBit' BS.empty -compressWordAsBit' :: Monad m => BS.ByteString -> ConduitT BS.ByteString BS.ByteString m ()-compressWordAsBit' aBS = do-  mbBS <- await-  case mbBS of-    Just bBS -> do-      let (cBS, dBS) = repartitionMod8 aBS bBS-      let (cs, _) = BS.unfoldrN (BS.length cBS + 7 `div` 8) gen cBS-      yield cs-      compressWordAsBit' dBS-    Nothing -> do-      let (cs, _) = BS.unfoldrN (BS.length aBS + 7 `div` 8) gen aBS-      yield cs+compressWordAsBit' :: BS.ByteString -> [BS.ByteString] -> [BS.ByteString]+compressWordAsBit' aBS iBS = case iBS of+  (bBS:bBSs) -> do+    let (cBS, dBS) = repartitionMod8 aBS bBS+    let (cs, _) = BS.unfoldrN (BS.length cBS + 7 `div` 8) gen cBS+    cs:compressWordAsBit' dBS bBSs+  [] -> do+    let (cs, _) = BS.unfoldrN (BS.length aBS + 7 `div` 8) gen aBS+    [cs]   where gen :: ByteString -> Maybe (Word8, ByteString)         gen xs = if BS.length xs == 0           then Nothing@@ -117,15 +84,12 @@                     , BS.drop 8 xs                     ) -blankedXmlToBalancedParens2 :: Monad m => ConduitT BS.ByteString BS.ByteString m ()-blankedXmlToBalancedParens2 = do-  mbs <- await-  case mbs of-    Just bs -> do-      let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs)-      yield cs-      blankedXmlToBalancedParens2-    Nothing -> return ()+blankedXmlToBalancedParens2 :: [BS.ByteString] -> [BS.ByteString]+blankedXmlToBalancedParens2 is = case is of+  (bs:bss) -> do+    let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs)+    cs:blankedXmlToBalancedParens2 bss+  [] -> []   where gen :: (Maybe Bool, ByteString) -> Maybe (Word8, (Maybe Bool, ByteString))         gen (Just True  , bs) = Just (0xFF, (Nothing, bs))         gen (Just False , bs) = Just (0x00, (Nothing, bs))@@ -152,23 +116,22 @@     d | d == _v            -> MiniTF     _                      -> MiniN -yieldBitsOfWord8 :: Monad m => Word8 -> ConduitT BS.ByteString Bool m ()-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)+yieldBitsOfWord8 :: Word8 -> [Bool]+yieldBitsOfWord8 w =+  [ (w .&. BITS.bit 0) /= 0+  , (w .&. BITS.bit 1) /= 0+  , (w .&. BITS.bit 2) /= 0+  , (w .&. BITS.bit 3) /= 0+  , (w .&. BITS.bit 4) /= 0+  , (w .&. BITS.bit 5) /= 0+  , (w .&. BITS.bit 6) /= 0+  , (w .&. BITS.bit 7) /= 0+  ] -yieldBitsofWord8s :: Monad m => [Word8] -> ConduitT BS.ByteString Bool m ()-yieldBitsofWord8s = P.foldr ((>>) . yieldBitsOfWord8) (return ())+yieldBitsofWord8s :: [Word8] -> [Bool]+yieldBitsofWord8s = P.foldr ((++) . yieldBitsOfWord8) [] -byteStringToBits :: Monad m => ConduitT BS.ByteString Bool m ()-byteStringToBits = do-  mbs <- await-  case mbs of-    Just bs -> yieldBitsofWord8s (BS.unpack bs) >> byteStringToBits-    Nothing -> return ()+byteStringToBits :: [BS.ByteString] -> [Bool]+byteStringToBits is = case is of+  (bs:bss) -> yieldBitsofWord8s (BS.unpack bs) ++ byteStringToBits bss+  []       -> []

@@ -7,10 +7,7 @@   , BlankData(..)   ) where -import Control.Monad-import Control.Monad.Trans.Resource        (MonadThrow) import Data.ByteString                     as BS-import Data.Conduit import Data.Monoid                         ((<>)) import Data.Word import Data.Word8@@ -41,39 +38,36 @@   , blankC     :: !ByteString   } -blankXml :: MonadThrow m => ConduitT BS.ByteString BS.ByteString m ()+blankXml :: [BS.ByteString] -> [BS.ByteString] blankXml = blankXmlPlan1 BS.empty InXml -blankXmlPlan1 :: MonadThrow m => BS.ByteString -> BlankState -> ConduitT BS.ByteString BS.ByteString m ()-blankXmlPlan1 as lastState = do-  mbs <- await-  case mbs of-    Just bs -> do-      let cs = as <> bs-      case BS.uncons cs of-        Just (d, ds) -> case BS.uncons ds of-          Just (e, es) -> blankXmlRun False d e es lastState-          Nothing      -> blankXmlPlan1 cs lastState-        Nothing -> blankXmlPlan1 cs lastState-    Nothing -> yield $ BS.map (const _space) as+blankXmlPlan1 :: BS.ByteString -> BlankState -> [BS.ByteString] -> [BS.ByteString]+blankXmlPlan1 as lastState is = case is of+  (bs:bss) -> do+    let cs = as <> bs+    case BS.uncons cs of+      Just (d, ds) -> case BS.uncons ds of+        Just (e, es) -> blankXmlRun False d e es lastState bss+        Nothing      -> blankXmlPlan1 cs lastState bss+      Nothing -> blankXmlPlan1 cs lastState bss+  [] -> [BS.map (const _space) as] -blankXmlPlan2 :: MonadThrow m => Word8 -> Word8 -> BlankState -> ConduitT BS.ByteString BS.ByteString m ()-blankXmlPlan2 a b lastState = do-  mcs <- await-  case mcs of-    Just cs -> blankXmlRun False a b cs lastState-    Nothing -> blankXmlRun True a b (BS.pack [_space, _space]) lastState+blankXmlPlan2 :: Word8 -> Word8 -> BlankState -> [BS.ByteString] -> [BS.ByteString]+blankXmlPlan2 a b lastState is = case is of+  (cs:css) -> blankXmlRun False a b cs lastState css+  []       -> blankXmlRun True a b (BS.pack [_space, _space]) lastState [] -blankXmlRun :: MonadThrow m => Bool -> Word8 -> Word8 -> BS.ByteString -> BlankState -> ConduitT BS.ByteString BS.ByteString m ()-blankXmlRun done a b cs lastState = do+blankXmlRun :: Bool -> Word8 -> Word8 -> BS.ByteString -> BlankState -> [BS.ByteString] -> [BS.ByteString]+blankXmlRun done a b cs lastState is = do   let (!ds, Just (BlankData !nextState _ _ _)) = unfoldrN (BS.length cs) blankByteString (BlankData lastState a b cs)-  yield ds   let (yy, zz) = case BS.unsnoc cs of         Just (ys, z) -> case BS.unsnoc ys of           Just (_, y) -> (y, z)           Nothing     -> (b, z)         Nothing -> (a, b)-  unless done (blankXmlPlan2 yy zz nextState)+  if done+    then [ds]+    else ds:blankXmlPlan2 yy zz nextState is  mkNext :: Word8 -> BlankState -> Word8 -> BS.ByteString -> Maybe (Word8, BlankData) mkNext w s a bs = case BS.uncons bs of

@@ -4,7 +4,7 @@ import Control.Lens import Control.Monad import Data.Foldable-import Data.Monoid                       ((<>))+import Data.Monoid                        ((<>)) import HaskellWorks.Data.Xml.DecodeError import HaskellWorks.Data.Xml.DecodeResult import HaskellWorks.Data.Xml.Value@@ -21,8 +21,8 @@  (@>) :: Value -> String -> DecodeResult String (@>) (XmlElement _ as _) n = case find (\v -> fst v == n) as of-  Just (_, text)  -> DecodeOk text-  Nothing         -> failDecode $ "No such attribute " <> show n+  Just (_, text) -> DecodeOk text+  Nothing        -> failDecode $ "No such attribute " <> show n (@>) _ n = failDecode $ "Not an element whilst looking up attribute " <> show n  (/>) :: Value -> String -> DecodeResult Value@@ -38,7 +38,7 @@  (~>) :: Value -> String -> DecodeResult Value (~>) e@(XmlElement n' _ _)  n | n' == n = DecodeOk e-(~>) _                      n           = failDecode $ "Expecting parent of element " <> show n+(~>) _                      n = failDecode $ "Expecting parent of element " <> show n  (/>>) :: Value -> String -> DecodeResult [Value] (/>>) v n = v ^. childNodes <&> (~> n) <&> toList & join & pure

@@ -0,0 +1,44 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module HaskellWorks.Data.Xml.Internal.ToIbBp64+  ( toBalancedParens64+  , toInterestBits64+  , toBalancedParens64'+  , toInterestBits64'+  , toIbBp64+  ) where++import Control.Applicative+import Data.Word+import HaskellWorks.Data.Xml.Conduit+import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml   (BlankedXml (..))+import HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits (blankedXmlToInterestBits, genInterestForever)++import qualified Data.ByteString      as BS+import qualified Data.Vector.Storable as DVS++genBitWordsForever :: BS.ByteString -> Maybe (Word8, BS.ByteString)+genBitWordsForever bs = BS.uncons bs <|> Just (0, bs)+{-# INLINABLE genBitWordsForever #-}++toBalancedParens64 :: BlankedXml -> DVS.Vector Word64+toBalancedParens64 (BlankedXml bj) = DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS)+  where interestBS    = BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 bj))+        newLen        = (BS.length interestBS + 7) `div` 8 * 8++toBalancedParens64' :: BlankedXml -> [BS.ByteString]+toBalancedParens64' (BlankedXml bj) = compressWordAsBit (blankedXmlToBalancedParens2 bj)++toInterestBits64 :: BlankedXml -> DVS.Vector Word64+toInterestBits64 (BlankedXml bj) = DVS.unsafeCast (DVS.unfoldrN newLen genInterestForever interestBS)+    where interestBS    = BS.concat (blankedXmlToInterestBits bj)+          newLen        = (BS.length interestBS + 7) `div` 8 * 8++toInterestBits64' :: BlankedXml -> [BS.ByteString]+toInterestBits64' (BlankedXml bj) = blankedXmlToInterestBits bj++toIbBp64 :: BlankedXml -> [(BS.ByteString, BS.ByteString)]+toIbBp64 bj = zip (toInterestBits64' bj) (toBalancedParens64' bj)

@@ -9,10 +9,8 @@   ) where  import Control.Applicative-import Data.Conduit import Data.Word import HaskellWorks.Data.BalancedParens                 as BP-import HaskellWorks.Data.Conduit.List import HaskellWorks.Data.Xml.Conduit import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml @@ -28,25 +26,22 @@ 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))+    where interestBS    = BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 (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))+    where interestBS    = BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 (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))+    where interestBS    = BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 (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))+    where interestBS    = BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 (getBlankedXml bj)))           newLen        = (BS.length interestBS + 7) `div` 8 * 8

@@ -3,11 +3,10 @@   ( BlankedXml(..)   , FromBlankedXml(..)   , getBlankedXml+  , bsToBlankedXml   ) where  import HaskellWorks.Data.ByteString-import HaskellWorks.Data.Conduit.List-import HaskellWorks.Data.FromByteString import HaskellWorks.Data.Xml.Conduit.Blank  import qualified Data.ByteString as BS@@ -20,6 +19,5 @@ class FromBlankedXml a where   fromBlankedXml :: BlankedXml -> a --instance FromByteString BlankedXml where-  fromByteString bs = BlankedXml (runListConduit blankXml (chunkedBy 4064 bs))+bsToBlankedXml :: BS.ByteString -> BlankedXml+bsToBlankedXml bs = BlankedXml (blankXml (chunkedBy 4064 bs))

@@ -0,0 +1,34 @@+module HaskellWorks.Data.Xml.Succinct.Cursor.Create+  ( byteStringAsFastCursor+  , byteStringAsSlowCursor+  ) where++import Data.Coerce+import HaskellWorks.Data.BalancedParens.RangeMin2+import HaskellWorks.Data.BalancedParens.Simple+import HaskellWorks.Data.Bits.BitShown+import HaskellWorks.Data.RankSelect.CsPoppy1+import HaskellWorks.Data.Vector.Storable+import HaskellWorks.Data.Xml.Succinct.Cursor+import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml+import HaskellWorks.Data.Xml.Succinct.Cursor.Types++import qualified Data.ByteString                         as BS+import qualified HaskellWorks.Data.Xml.Internal.ToIbBp64 as I++byteStringAsSlowCursor :: BS.ByteString -> SlowCursor+byteStringAsSlowCursor bs = XmlCursor+  { cursorText      = bs+  , interests       = BitShown ib+  , balancedParens  = SimpleBalancedParens bp+  , cursorRank      = 1+  }+  where blankedXml = bsToBlankedXml bs+        (ib, bp) = construct64UnzipN (BS.length bs) (I.toIbBp64 blankedXml)++byteStringAsFastCursor :: BS.ByteString -> FastCursor+byteStringAsFastCursor bs = XmlCursor bs ibCsPoppy rangeMinMax r+  where XmlCursor _ ib bp r = byteStringAsSlowCursor bs+        bpCsPoppy           = makeCsPoppy (coerce bp)+        rangeMinMax         = mkRangeMin2 bpCsPoppy+        ibCsPoppy           = makeCsPoppy (coerce ib)

@@ -8,13 +8,13 @@   , getXmlInterestBits   , blankedXmlToInterestBits   , blankedXmlBssToInterestBitsBs+  , genInterestForever   ) where  import Control.Applicative import Data.ByteString.Internal import Data.Word import HaskellWorks.Data.Bits.BitShown-import HaskellWorks.Data.Conduit.List import HaskellWorks.Data.FromByteString import HaskellWorks.Data.RankSelect.Poppy512 import HaskellWorks.Data.Xml.Conduit@@ -29,7 +29,7 @@ getXmlInterestBits (XmlInterestBits a) = a  blankedXmlBssToInterestBitsBs :: [ByteString] -> ByteString-blankedXmlBssToInterestBitsBs bss = BS.concat $ runListConduit blankedXmlToInterestBits bss+blankedXmlBssToInterestBitsBs bss = BS.concat $ blankedXmlToInterestBits bss  genInterest :: ByteString -> Maybe (Word8, ByteString) genInterest = BS.uncons@@ -38,7 +38,7 @@ genInterestForever bs = BS.uncons bs <|> Just (0, bs)  instance FromBlankedXml (XmlInterestBits (BitShown [Bool])) where-  fromBlankedXml = XmlInterestBits . fromByteString . BS.concat . runListConduit blankedXmlToInterestBits . getBlankedXml+  fromBlankedXml = XmlInterestBits . fromByteString . BS.concat . blankedXmlToInterestBits . getBlankedXml  instance FromBlankedXml (XmlInterestBits (BitShown BS.ByteString)) where   fromBlankedXml = XmlInterestBits . BitShown . BS.unfoldr genInterest . blankedXmlBssToInterestBitsBs . getBlankedXml

@@ -10,7 +10,7 @@   , xmlCursorPos   ) where -import Control.DeepSeq                                    (NFData(..))+import Control.DeepSeq                                    (NFData (..)) import Data.ByteString.Internal                           as BSI import Data.String import Data.Word@@ -54,18 +54,7 @@     , 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)+          blankedXml = bsToBlankedXml bs  instance IsString (XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (BP.SimpleBalancedParens (DVS.Vector Word8))) where   fromString = fromByteString . BSC.pack

@@ -0,0 +1,21 @@+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.Xml.Succinct.Cursor.Load+  ( loadSlowCursor+  , loadFastCursor+  ) where++import HaskellWorks.Data.Xml.Succinct.Cursor.Create+import HaskellWorks.Data.Xml.Succinct.Cursor.Types++import qualified Data.ByteString as BS++-- | Load an XML file into memory and return a raw cursor initialised to the+-- start of the XML document.+loadSlowCursor :: String -> IO SlowCursor+loadSlowCursor = fmap byteStringAsSlowCursor . BS.readFile++-- | Load an XML file into memory and return a query-optimised cursor initialised+-- to the start of the XML document.+loadFastCursor :: String -> IO FastCursor+loadFastCursor = fmap byteStringAsFastCursor . BS.readFile

@@ -0,0 +1,51 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.Xml.Succinct.Cursor.MMap+  ( SlowCursor+  , FastCursor+  , mmapSlowCursor+  , mmapFastCursor+  ) where++import Data.Word+import Foreign.ForeignPtr+import HaskellWorks.Data.BalancedParens.RangeMin2+import HaskellWorks.Data.BalancedParens.Simple+import HaskellWorks.Data.Bits.BitShown+import HaskellWorks.Data.RankSelect.CsPoppy1+import HaskellWorks.Data.Vector.Storable+import HaskellWorks.Data.Xml.Succinct.Cursor+import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml+import HaskellWorks.Data.Xml.Succinct.Cursor.Types++import qualified Data.ByteString.Internal                as BSI+import qualified HaskellWorks.Data.Xml.Internal.ToIbBp64 as I+import qualified System.IO.MMap                          as IO++mmapSlowCursor :: String -> IO SlowCursor+mmapSlowCursor filePath = do+  (fptr :: ForeignPtr Word8, offset, size) <- IO.mmapFileForeignPtr filePath IO.ReadOnly Nothing+  let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size+  let blankedXml = bsToBlankedXml bs+  let (ib, bp) = construct64UnzipN (fromIntegral size) (I.toIbBp64 blankedXml)+  let !cursor = XmlCursor+        { cursorText      = bs+        , interests       = BitShown ib+        , balancedParens  = SimpleBalancedParens bp+        , cursorRank      = 1+        }++  return cursor++mmapFastCursor :: String -> IO FastCursor+mmapFastCursor filename = do+  -- Load the XML file into memory as a raw cursor.+  -- The raw XML data is `text`, and `ib` and `bp` are the indexes.+  -- `ib` and `bp` can be persisted to an index file for later use to avoid+  -- re-parsing the file.+  XmlCursor !text (BitShown !ib) (SimpleBalancedParens !bp) _ <- mmapSlowCursor filename+  let !bpCsPoppy = makeCsPoppy bp+  let !rangeMinMax = mkRangeMin2 bpCsPoppy+  let !ibCsPoppy = makeCsPoppy ib+  return $ XmlCursor text ibCsPoppy rangeMinMax 1

@@ -0,0 +1,20 @@+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.Data.Xml.Succinct.Cursor.Types+  ( SlowCursor+  , FastCursor+  ) where++import Data.Word+import HaskellWorks.Data.BalancedParens.RangeMin2+import HaskellWorks.Data.BalancedParens.Simple+import HaskellWorks.Data.Bits.BitShown+import HaskellWorks.Data.RankSelect.CsPoppy1+import HaskellWorks.Data.Xml.Succinct.Cursor++import qualified Data.ByteString      as BS+import qualified Data.Vector.Storable as DVS++type SlowCursor = XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))++type FastCursor = XmlCursor BS.ByteString CsPoppy1 (RangeMin2 CsPoppy1)

@@ -4,22 +4,24 @@ module HaskellWorks.Data.Xml.Conduit.BlankSpec (spec) where  import Data.Char-import Data.Monoid+import Data.Semigroup                      ((<>)) import HaskellWorks.Data.ByteString-import HaskellWorks.Data.Conduit.List import HaskellWorks.Data.Xml.Conduit.Blank+import HaskellWorks.Hspec.Hedgehog+import Hedgehog import Test.Hspec-import Test.QuickCheck  import qualified Data.ByteString as BS+import qualified Hedgehog.Gen    as G+import qualified Hedgehog.Range  as R  {-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}  whenBlankedXmlShouldBe :: BS.ByteString -> BS.ByteString -> Spec whenBlankedXmlShouldBe original expected = do-  it (show original <> " when blanked xml should be " <> show expected) $ do-    BS.concat (runListConduit blankXml [original]) `shouldBe` expected+  it (show original <> " when blanked xml should be " <> show expected) $ requireTest $ do+    BS.concat (blankXml [original]) === expected  repeatBS :: Int -> BS.ByteString -> BS.ByteString repeatBS n bs | n > 0   = bs <> repeatBS (n - 1) bs@@ -68,50 +70,52 @@     "<a><c>00</c><s/></a>"                    `whenBlankedXmlShouldBe` "<  <  t    ><  >   >"     "<a><c>0</c><s/></a>"                     `whenBlankedXmlShouldBe` "<  <  t   ><  >   >" -  it "Can blank across chunk boundaries with basic tags" $ do+  it "Can blank across chunk boundaries with basic tags" $ requireTest $ do     let inputOriginalPrefix = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<statistics>\n  <attack>"     let inputOriginalSuffix = "\n  </attack>\n  <attack></attack>\n  <attack></attack>\n  <attack></attack>\n  <attack></attack>\n</statistics>\n"     let inputOriginal = inputOriginalPrefix <> inputOriginalSuffix     let inputOriginalChunked = chunkedBy 16 inputOriginal-    let inputOriginalBlanked = runListConduit blankXml inputOriginalChunked+    let inputOriginalBlanked = blankXml inputOriginalChunked -    forAll (choose (0, 16)) $ \(n :: Int) -> do-      let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix-      let inputShiftedChunked = chunkedBy 16 inputShifted-      let inputShiftedBlanked = runListConduit blankXml inputShiftedChunked+    n <- forAll $ G.int (R.linear 0 16) -      noSpaces (BS.concat inputShiftedBlanked) `shouldBe` noSpaces (BS.concat inputOriginalBlanked)-  it "Can blank across chunk boundaries with auto-close tags" $ do+    let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix+    let inputShiftedChunked = chunkedBy 16 inputShifted+    let inputShiftedBlanked = blankXml inputShiftedChunked++    noSpaces (BS.concat inputShiftedBlanked) === noSpaces (BS.concat inputOriginalBlanked)+  it "Can blank across chunk boundaries with auto-close tags" $ requireTest $ do     let inputOriginalPrefix = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><statistics><attack>"     let inputOriginalSuffix = "<inner/></attack><attack></attack></statistics>\n"     let inputOriginal = inputOriginalPrefix <> inputOriginalSuffix     let inputOriginalChunked = chunkedBy 16 inputOriginal-    let inputOriginalBlanked = runListConduit blankXml inputOriginalChunked+    let inputOriginalBlanked = blankXml inputOriginalChunked -    forAll (choose (0, 16)) $ \(n :: Int) -> do-      let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix-      let inputShiftedChunked = chunkedBy 16 inputShifted-      let inputShiftedBlanked = runListConduit blankXml inputShiftedChunked+    n <- forAll $ G.int (R.linear 0 16) -      -- putStrLn $ show (BS.concat inputShiftedBlanked) <> " vs " <> show (BS.concat inputOriginalBlanked)-      let actual    = Annotated (noSpaces (BS.concat inputShiftedBlanked )) (inputShiftedBlanked, n)-      let expected  = Annotated (noSpaces (BS.concat inputOriginalBlanked)) (inputOriginalBlanked, n)+    let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix+    let inputShiftedChunked = chunkedBy 16 inputShifted+    let inputShiftedBlanked = blankXml inputShiftedChunked -      actual `shouldBe` expected-  it "Can blank across chunk boundaries with auto-close tags" $ do+    -- putStrLn $ show (BS.concat inputShiftedBlanked) <> " vs " <> show (BS.concat inputOriginalBlanked)+    let actual    = Annotated (noSpaces (BS.concat inputShiftedBlanked )) (inputShiftedBlanked, n)+    let expected  = Annotated (noSpaces (BS.concat inputOriginalBlanked)) (inputOriginalBlanked, n)++    actual === expected+  it "Can blank across chunk boundaries with auto-close tags" $ requireTest $ do     let inputOriginalPrefix = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><statistics><attack>"     let inputOriginalSuffix = "<inner/></attack><attack></attack></statistics>\n"     let inputOriginal = inputOriginalPrefix <> inputOriginalSuffix     let inputOriginalChunked = chunkedBy 16 inputOriginal-    let inputOriginalBlanked = runListConduit blankXml inputOriginalChunked+    let inputOriginalBlanked = blankXml inputOriginalChunked      let n = 15     let inputShifted = inputOriginalPrefix <> repeatBS n " " <> inputOriginalSuffix     let inputShiftedChunked = chunkedBy 16 inputShifted-    let inputShiftedBlanked = runListConduit blankXml inputShiftedChunked+    let inputShiftedBlanked = blankXml inputShiftedChunked      -- putStrLn $ show (BS.concat inputShiftedBlanked) <> " vs " <> show (BS.concat inputOriginalBlanked)     let actual    = Annotated (noSpaces (BS.concat inputShiftedBlanked )) (inputShiftedBlanked, n)     let expected  = Annotated (noSpaces (BS.concat inputOriginalBlanked)) (inputOriginalBlanked, n) -    actual `shouldBe` expected+    actual === expected

@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE InstanceSigs              #-}+{-# LANGUAGE MonoLocalBinds            #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings         #-}@@ -12,21 +13,22 @@ module HaskellWorks.Data.Xml.RawValueSpec (spec) where  import Control.Monad-import Data.Monoid+import Data.Semigroup                                  ((<>)) import Data.String import Data.Word import HaskellWorks.Data.BalancedParens.BalancedParens import HaskellWorks.Data.BalancedParens.Simple import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.Bits.BitWise-import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1 import HaskellWorks.Data.RankSelect.Base.Select1 import HaskellWorks.Data.RankSelect.Poppy512+import HaskellWorks.Data.Xml.RawValue import HaskellWorks.Data.Xml.Succinct.Cursor           as C import HaskellWorks.Data.Xml.Succinct.Index-import HaskellWorks.Data.Xml.RawValue+import HaskellWorks.Hspec.Hedgehog+import Hedgehog import Test.Hspec  import qualified Data.ByteString              as BS@@ -35,11 +37,9 @@  {-# ANN module ("HLint: ignore Redundant do"        :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}---{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}  fc = TC.firstChild ns = TC.nextSibling--- cd = TC.depth  attrs :: [(String, String)] -> RawValue attrs as = RawAttrList $ as >>= (\(k, v) -> [RawAttrName k, RawAttrValue v])@@ -59,18 +59,14 @@   Nothing -> RawError "No such element"  genSpec :: forall t u.-  ( Eq                t-  , Show              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@@ -78,47 +74,47 @@     let forXml (cursor :: XmlCursor BS.ByteString t u) f = describe ("of value " <> show cursor) (f cursor)      forXml "<a/>" $ \cursor -> do-      it "should have correct value"      $ rawValueVia (Just cursor) `shouldBe` RawElement "a" []+      it "should have correct value" $ requireTest $ rawValueVia (Just cursor) === RawElement "a" []      forXml "<a attr='value'/>" $ \cursor -> do-      it "should have correct value"    $ rawValueVia (Just cursor) `shouldBe`+      it "should have correct value"    $ requireTest $ rawValueVia (Just cursor) ===         RawElement "a" [attrs [("attr", "value")]]      forXml "<a attr='value'><b attr='value' /></a>" $ \cursor -> do-      it "should have correct value"    $ rawValueVia (Just cursor) `shouldBe`+      it "should have correct value"  $ requireTest $ rawValueVia (Just cursor) ===         RawElement "a" [attrs [("attr", "value")],           RawElement "b" [attrs [("attr", "value")]]]      forXml "<a>value text</a>" $ \cursor -> do-      it "should have correct value"      $ rawValueVia (Just cursor) `shouldBe`+      it "should have correct value"  $ requireTest $ rawValueVia (Just cursor) ===         RawElement "a" [RawText "value text"]      forXml "<!-- some comment -->" $ \cursor -> do-      it "should parse space separared comment" $ rawValueVia (Just cursor) `shouldBe`+      it "should parse space separared comment" $ requireTest $ rawValueVia (Just cursor) ===         RawComment " some comment "      forXml "<!--some comment ->-->" $ \cursor -> do-      it "should parse space separared comment" $ rawValueVia (Just cursor) `shouldBe`+      it "should parse space separared comment" $ requireTest $ rawValueVia (Just cursor) ===         RawComment "some comment ->"      forXml "<![CDATA[a <br/> tag]]>" $ \cursor -> do-      it "should parse cdata data" $ rawValueVia (Just cursor) `shouldBe`+      it "should parse cdata data" $ requireTest $ rawValueVia (Just cursor) ===         RawCData "a <br/> tag"      forXml "<!DOCTYPE greeting [<!ELEMENT greeting (#PCDATA)>]>" $ \cursor -> do-      it "should parse metas" $ rawValueVia (Just cursor) `shouldBe`+      it "should parse metas" $ requireTest $ rawValueVia (Just cursor) ===         RawMeta "DOCTYPE" [RawMeta "ELEMENT" []]      forXml "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a text='value'>free</a>" $ \cursor -> do-      it "should parse xml header" $ rawValueVia (Just cursor) `shouldBe`+      it "should parse xml header" $ requireTest $ rawValueVia (Just cursor) ===         RawDocument [           attrs [("version", "1.0"), ("encoding", "UTF-8")],           RawElement "a" [attrs [("text", "value")],           RawText "free"]] -      it "navigate around" $ do-        rawValueVia (ns cursor) `shouldBe` RawElement "a" [attrs [("text", "value")], RawText "free"]-        rawValueVia ((ns >=> fc) cursor) `shouldBe` attrs [("text", "value")]-        rawValueVia ((ns >=> fc >=> fc) cursor) `shouldBe` RawAttrName "text"-        rawValueVia ((ns >=> fc >=> fc >=> ns) cursor) `shouldBe` RawAttrValue "value"-        rawValueVia ((ns >=> fc >=> ns) cursor) `shouldBe` RawText "free"+      it "navigate around" $ requireTest $ do+        rawValueVia (ns cursor) === RawElement "a" [attrs [("text", "value")], RawText "free"]+        rawValueVia ((ns >=> fc) cursor) === attrs [("text", "value")]+        rawValueVia ((ns >=> fc >=> fc) cursor) === RawAttrName "text"+        rawValueVia ((ns >=> fc >=> fc >=> ns) cursor) === RawAttrValue "value"+        rawValueVia ((ns >=> fc >=> ns) cursor) === RawText "free"

@@ -3,16 +3,15 @@  module HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec(spec) where -import Data.Conduit import Data.Monoid                                      ((<>)) import Data.String import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.ByteString-import HaskellWorks.Data.Conduit.List import HaskellWorks.Data.Xml.Conduit import HaskellWorks.Data.Xml.Conduit.Blank-import HaskellWorks.Data.Xml.Conduit.Blank import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml+import HaskellWorks.Hspec.Hedgehog+import Hedgehog import Test.Hspec  import qualified Data.ByteString as BS@@ -21,55 +20,55 @@  spec :: Spec spec = describe "HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec" $ do-  it "Blanking XML should work 1" $ do+  it "Blanking XML should work 1" $ requireTest $ do     let blankedXml = BlankedXml ["<t<t>>"]-    let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) (getBlankedXml blankedXml))-    bp `shouldBe` fromString "11011000"-  it "Blanking XML should work 2" $ do+    let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 (getBlankedXml blankedXml)))+    bp === fromString "11011000"+  it "Blanking XML should work 2" $ requireTest $ do     let blankedXml = BlankedXml           [ "<><><><><><><><>"           , "<><><><><><><><>"           ]-    let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) (getBlankedXml blankedXml))-    bp `shouldBe` fromString+    let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 (getBlankedXml blankedXml)))+    bp === fromString           "1010101010101010\           \1010101010101010"    let unchunkedInput = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<micro_stats>\n  <metric>\n  </metric>\n  <metric></metric>\n  <metric></metric>\n  <metric></metric>\n  <metric></metric>\n</micro_stats>\n"   let chunkedInput = chunkedBy 15 unchunkedInput-  let chunkedBlank = runListConduit blankXml chunkedInput+  let chunkedBlank = blankXml chunkedInput    let unchunkedBadInput = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<micro_stats>\n  <metric>       \n  </metric>\n  <metric></metric>\n  <metric></metric>\n  <metric></metric>\n  <metric></metric>\n</micro_stats>\n"   let chunkedBadInput = chunkedBy 15 unchunkedBadInput-  let chunkedBadBlank = runListConduit blankXml chunkedBadInput+  let chunkedBadBlank = blankXml chunkedBadInput -  it "Same input" $ do-    unchunkedInput `shouldBe` BS.concat chunkedInput+  it "Same input" $ requireTest $ do+    unchunkedInput === BS.concat chunkedInput -  it "Blanking XML should work 3" $ do-    let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) chunkedBlank)-    putStrLn $ "Good: " <> show chunkedBlank-    bp `shouldBe` fromString "11101010 10001101 01010100"+  it "Blanking XML should work 3" $ requireTest $ do+    let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 chunkedBlank))+    annotate $ "Good: " <> show chunkedBlank+    bp === fromString "11101010 10001101 01010100" -  it "Blanking XML should work 3" $ do-    let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) chunkedBadBlank)-    putStrLn $ "Bad: " <> show chunkedBadBlank-    bp `shouldBe` fromString "11101010 10001101 01010100"+  it "Blanking XML should work 3" $ requireTest $do+    let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens2 chunkedBadBlank))+    annotate $ "Bad: " <> show chunkedBadBlank+    bp === fromString "11101010 10001101 01010100"    describe "Chunking works" $ do     let document = "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a text='value'>free</a>"     let whole = mkBlank 4096 document     let chunked = mkBlank 15 document -    it "should BP the same with chanks" $ do-      BS.concat chunked `shouldBe` BS.concat whole+    it "should BP the same with chanks" $ requireTest $do+      BS.concat chunked === BS.concat whole -    it "should produce same bits" $ do-      BS.concat (mkBits chunked) `shouldBe` BS.concat (mkBits whole)+    it "should produce same bits" $ requireTest $do+      BS.concat (mkBits chunked) === BS.concat (mkBits whole)   mkBlank :: Int -> BS.ByteString -> [BS.ByteString]-mkBlank csize bs = runListConduit blankXml (chunkedBy csize bs)+mkBlank csize bs = blankXml (chunkedBy csize bs)  mkBits :: [BS.ByteString] -> [BS.ByteString]-mkBits = runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit)+mkBits = compressWordAsBit . blankedXmlToBalancedParens2

@@ -7,10 +7,11 @@ import Data.String import Data.Word import HaskellWorks.Data.Bits.BitShown-import HaskellWorks.Data.Conduit.List import HaskellWorks.Data.FromByteString import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml import HaskellWorks.Data.Xml.Succinct.Cursor.InterestBits+import HaskellWorks.Hspec.Hedgehog+import Hedgehog import Test.Hspec  import qualified Data.ByteString      as BS@@ -19,21 +20,21 @@ {-# ANN module ("HLint: ignore Redundant do"        :: String) #-}  interestBitsOf :: FromBlankedXml (XmlInterestBits a) => BS.ByteString -> a-interestBitsOf = getXmlInterestBits . fromBlankedXml . fromByteString+interestBitsOf = getXmlInterestBits . fromBlankedXml . bsToBlankedXml  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"-  it "Can build interest bits across boundaries" $ do+  it "Evaluating interest bits" $ requireTest $ do+    (interestBitsOf ""               :: BitShown (DVS.Vector Word8)) === fromString ""+    (interestBitsOf "  \n \r \t "    :: BitShown (DVS.Vector Word8)) === fromString "00000000"+    (interestBitsOf "<el atr"        :: BitShown (DVS.Vector Word8)) === fromString "10011000"+    (interestBitsOf "[alse "         :: BitShown (DVS.Vector Word8)) === fromString "10000000"+    (interestBitsOf "(rue "          :: BitShown (DVS.Vector Word8)) === fromString "10000000"+    (interestBitsOf "<e><c></e>"     :: BitShown (DVS.Vector Word8)) === fromString "10010000 00000000"+    (interestBitsOf " <e p='a'/> "   :: BitShown (DVS.Vector Word8)) === fromString "01011010 00000000"+    (interestBitsOf " <!-- u -->"    :: BitShown (DVS.Vector Word8)) === fromString "01000000 00000000"+    (interestBitsOf "<![CDATA[ x"    :: BitShown (DVS.Vector Word8)) === fromString "10000000 00000000"+  it "Can build interest bits across boundaries" $ requireTest $do     let blanked =           [ "<    (a "           , "      v "@@ -43,13 +44,13 @@           , "<  <     "           , ">   >"           ]-    putStrLn $ "Blanked: " <> show blanked+    annotate $ "Blanked: " <> show blanked     let ib :: XmlInterestBits (BitShown (DVS.Vector Word8))         ib = XmlInterestBits (getXmlInterestBits (fromBlankedXml (BlankedXml blanked)))     let moo :: [BS.ByteString]-        moo = runListConduit blankedXmlToInterestBits blanked -- :: XmlInterestBits (BitShown (DVS.Vector Word8))-    putStrLn $ "Moo:       " <> show (BitShown . BS.unpack <$> moo)+        moo = blankedXmlToInterestBits blanked -- :: XmlInterestBits (BitShown (DVS.Vector Word8))+    annotate $ "Moo:       " <> show (BitShown . BS.unpack <$> moo)     let actual = getXmlInterestBits ib :: BitShown (DVS.Vector Word8)     let expected = fromString "10000110 00000010 00001000 00000100 00000001 00100000 00000000" -    actual `shouldBe` expected+    actual === expected

@@ -19,14 +19,14 @@ import HaskellWorks.Data.Bits.BitShow import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.Bits.BitWise-import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1 import HaskellWorks.Data.RankSelect.Base.Select1 import HaskellWorks.Data.RankSelect.Poppy512 import HaskellWorks.Data.Xml.Succinct.Cursor           as C-import HaskellWorks.Data.Xml.Succinct.Index import HaskellWorks.Data.Xml.Token+import HaskellWorks.Hspec.Hedgehog+import Hedgehog import Test.Hspec  import qualified Data.ByteString              as BS@@ -45,38 +45,19 @@  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-    xit "depth at first child of object at second child of array" $ do-      let cursor = "[null, {\"field\": 1}]" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])-      (fc >=> ns >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3   genSpec "DVS.Vector Word8"  (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8)))   genSpec "DVS.Vector Word16" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16)))   genSpec "DVS.Vector Word32" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32)))   genSpec "DVS.Vector Word64" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)))   genSpec "Poppy512"          (undefined :: XmlCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64)))-  it "Loads same Xml consistentally from different backing vectors" $ do+  it "Loads same Xml consistentally from different backing vectors" $ requireTest $ 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+    cursorText cursor8 === cursorText cursor16+    cursorText cursor8 === cursorText cursor32+    cursorText cursor8 === cursorText cursor64     let ic8   = bitShow $ interests cursor8     let ic16  = bitShow $ interests cursor16     let ic32  = bitShow $ interests cursor32@@ -85,8 +66,8 @@     ic32 `shouldBeginWith` ic16     ic64 `shouldBeginWith` ic32 -shouldBeginWith :: (Eq a, Show a) => [a] -> [a] -> IO ()-shouldBeginWith as bs = take (length bs) as `shouldBe` bs+shouldBeginWith :: (Eq a, Show a) => [a] -> [a] -> PropertyT IO ()+shouldBeginWith as bs = take (length bs) as === bs  genSpec :: forall t u.   ( Eq                t@@ -98,24 +79,22 @@   , Rank1             u   , BalancedParens    u   , TestBit           u-  , FromForeignRegion (XmlCursor BS.ByteString t u)   , IsString          (XmlCursor BS.ByteString t u)-  , XmlIndexAt        (XmlCursor BS.ByteString t u)   )   => String -> XmlCursor BS.ByteString t u -> SpecWith () genSpec t _ = do   describe ("Cursor for (" ++ t ++ ")") $ do     let forXml (cursor :: XmlCursor BS.ByteString t u) f = describe ("of value " ++ show cursor) (f cursor)     forXml "[null]" $ \cursor -> do-      it "depth at top"                   $ cd          cursor `shouldBe` Just 1-      xit "depth at first child of array"  $ (fc >=> cd) cursor `shouldBe` Just 2+      it "depth at top"                   $ requireTest $ cd          cursor === Just 1+      xit "depth at first child of array" $ requireTest $ (fc >=> cd) cursor === Just 2     forXml "[null, {\"field\": 1}]" $ \cursor -> do-      xit "depth at second child of array" $ do-        (fc >=> ns >=> cd) cursor `shouldBe` Just 2-      xit "depth at first child of object at second child of array" $ do-        (fc >=> ns >=> fc >=> cd) cursor `shouldBe` Just 3-      xit "depth at first child of object at second child of array" $ do-        (fc >=> ns >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3+      xit "depth at second child of array" $ requireTest $do+        (fc >=> ns >=> cd) cursor === Just 2+      xit "depth at first child of object at second child of array" $ requireTest $ do+        (fc >=> ns >=> fc >=> cd) cursor === Just 3+      xit "depth at first child of object at second child of array" $ requireTest $ do+        (fc >=> ns >=> fc >=> ns >=> cd) cursor === Just 3      describe "For sample XML" $ do       let cursor =  "<widget debug=\"on\"> \@@ -125,39 +104,39 @@                     \    <dimension>    false   </dimension> \                     \  </window> \                     \</widget>" :: XmlCursor BS.ByteString t u-      xit "can get token at cursor" $ do-        (xmlTokenAt                                                                      ) cursor `shouldBe` Just (XmlTokenBraceL                 )-        (fc                                                                >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString   "widget"      )-        (fc >=> ns                                                         >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenBraceL                 )-        (fc >=> ns >=> fc                                                  >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString   "debug"       )-        (fc >=> ns >=> fc >=> ns                                           >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString   "on"          )-        (fc >=> ns >=> fc >=> ns >=> ns                                    >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString   "window"      )-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns                             >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenBraceL                 )-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc                      >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString   "name"        )-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns               >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString   "main_window" )-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns        >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenString   "dimensions"  )-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> xmlTokenAt) cursor `shouldBe` Just (XmlTokenBracketL               )-      xit "can navigate up" $ do-        (                                                                      pn) cursor `shouldBe` Nothing-        (fc                                                                >=> pn) cursor `shouldBe`                                    Just cursor-        (fc >=> ns                                                         >=> pn) cursor `shouldBe`                                    Just cursor-        (fc >=> ns >=> fc                                                  >=> pn) cursor `shouldBe` (fc >=> ns                            ) cursor-        (fc >=> ns >=> fc >=> ns                                           >=> pn) cursor `shouldBe` (fc >=> ns                            ) cursor-        (fc >=> ns >=> fc >=> ns >=> ns                                    >=> pn) cursor `shouldBe` (fc >=> ns                            ) cursor-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns                             >=> pn) cursor `shouldBe` (fc >=> ns                            ) cursor-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc                      >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns               >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns        >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor `shouldBe` (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor-      xit "can get subtree size" $ do-        (                                                                      ss) cursor `shouldBe` Just 16-        (fc                                                                >=> ss) cursor `shouldBe` Just 1-        (fc >=> ns                                                         >=> ss) cursor `shouldBe` Just 14-        (fc >=> ns >=> fc                                                  >=> ss) cursor `shouldBe` Just 1-        (fc >=> ns >=> fc >=> ns                                           >=> ss) cursor `shouldBe` Just 1-        (fc >=> ns >=> fc >=> ns >=> ns                                    >=> ss) cursor `shouldBe` Just 1-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns                             >=> ss) cursor `shouldBe` Just 10-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc                      >=> ss) cursor `shouldBe` Just 1-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns               >=> ss) cursor `shouldBe` Just 1-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns        >=> ss) cursor `shouldBe` Just 1-        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> ss) cursor `shouldBe` Just 6+      xit "can get token at cursor" $ requireTest $ do+        (xmlTokenAt                                                                      ) cursor === Just (XmlTokenBraceL                 )+        (fc                                                                >=> xmlTokenAt) cursor === Just (XmlTokenString   "widget"      )+        (fc >=> ns                                                         >=> xmlTokenAt) cursor === Just (XmlTokenBraceL                 )+        (fc >=> ns >=> fc                                                  >=> xmlTokenAt) cursor === Just (XmlTokenString   "debug"       )+        (fc >=> ns >=> fc >=> ns                                           >=> xmlTokenAt) cursor === Just (XmlTokenString   "on"          )+        (fc >=> ns >=> fc >=> ns >=> ns                                    >=> xmlTokenAt) cursor === Just (XmlTokenString   "window"      )+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns                             >=> xmlTokenAt) cursor === Just (XmlTokenBraceL                 )+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc                      >=> xmlTokenAt) cursor === Just (XmlTokenString   "name"        )+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns               >=> xmlTokenAt) cursor === Just (XmlTokenString   "main_window" )+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns        >=> xmlTokenAt) cursor === Just (XmlTokenString   "dimensions"  )+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> xmlTokenAt) cursor === Just (XmlTokenBracketL               )+      xit "can navigate up" $ requireTest $ do+        (                                                                      pn) cursor === Nothing+        (fc                                                                >=> pn) cursor ===                                    Just cursor+        (fc >=> ns                                                         >=> pn) cursor ===                                    Just cursor+        (fc >=> ns >=> fc                                                  >=> pn) cursor === (fc >=> ns                            ) cursor+        (fc >=> ns >=> fc >=> ns                                           >=> pn) cursor === (fc >=> ns                            ) cursor+        (fc >=> ns >=> fc >=> ns >=> ns                                    >=> pn) cursor === (fc >=> ns                            ) cursor+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns                             >=> pn) cursor === (fc >=> ns                            ) cursor+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc                      >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns               >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns        >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor+      xit "can get subtree size" $ requireTest $ do+        (                                                                      ss) cursor === Just 16+        (fc                                                                >=> ss) cursor === Just 1+        (fc >=> ns                                                         >=> ss) cursor === Just 14+        (fc >=> ns >=> fc                                                  >=> ss) cursor === Just 1+        (fc >=> ns >=> fc >=> ns                                           >=> ss) cursor === Just 1+        (fc >=> ns >=> fc >=> ns >=> ns                                    >=> ss) cursor === Just 1+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns                             >=> ss) cursor === Just 10+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc                      >=> ss) cursor === Just 1+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns               >=> ss) cursor === Just 1+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns        >=> ss) cursor === Just 1+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> ss) cursor === Just 6

@@ -4,6 +4,8 @@  import Data.ByteString                      as BS import HaskellWorks.Data.Xml.Token.Tokenize+import HaskellWorks.Hspec.Hedgehog+import Hedgehog import Test.Hspec  import qualified Data.Attoparsec.ByteString.Char8 as BC@@ -16,35 +18,35 @@ 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+    it "Empty Xml should produce no bits" $ requireTest $+      parseXmlToken' "" === Left "not enough input"+    it "Xml with one space should produce whitespace token" $ requireTest $+      parseXmlToken' " " === Right XmlTokenWhitespace+    it "Xml with two spaces should produce whitespace token" $ requireTest $+      parseXmlToken' "  " === Right XmlTokenWhitespace+    it "Spaces and newlines should produce no bits" $ requireTest $+      parseXmlToken' "  \n \r \t " === Right XmlTokenWhitespace+    it "`null` at beginning should produce one bit" $ requireTest $+      parseXmlToken' "null " === Right XmlTokenNull+    it "number at beginning should produce one bit" $ requireTest $+      parseXmlToken' "1234 " === Right (XmlTokenNumber 1234)+    it "false at beginning should produce one bit" $ requireTest $+      parseXmlToken' "false " === Right (XmlTokenBoolean False)+    it "true at beginning should produce one bit" $ requireTest $+      parseXmlToken' "true " === Right (XmlTokenBoolean True)+    it "string at beginning should produce one bit" $ requireTest $+      parseXmlToken' "\"hello\" " === Right (XmlTokenString "hello")+    it "quoted string should parse" $ requireTest $+      parseXmlToken' "\"\\\"\" " === Right (XmlTokenString "\"")+    it "left brace at beginning should produce one bit" $ requireTest $+      parseXmlToken' "{ " === Right XmlTokenBraceL+    it "right brace at beginning should produce one bit" $ requireTest $+      parseXmlToken' "} " === Right XmlTokenBraceR+    it "left bracket at beginning should produce one bit" $ requireTest $+      parseXmlToken' "[ " === Right XmlTokenBracketL+    it "right bracket at beginning should produce one bit" $ requireTest $+      parseXmlToken' "] " === Right XmlTokenBracketR+    it "right bracket at beginning should produce one bit" $ requireTest $+      parseXmlToken' ": " === Right XmlTokenColon+    it "right bracket at beginning should produce one bit" $ requireTest $+      parseXmlToken' ", " === Right XmlTokenComma

@@ -7,7 +7,8 @@ {-# LANGUAGE OverloadedStrings         #-} {-# LANGUAGE ScopedTypeVariables       #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures              #-}+{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints  #-}  module HaskellWorks.Data.Xml.TypeSpec (spec) where @@ -18,14 +19,14 @@ import HaskellWorks.Data.BalancedParens.Simple import HaskellWorks.Data.Bits.BitShown import HaskellWorks.Data.Bits.BitWise-import HaskellWorks.Data.FromForeignRegion import HaskellWorks.Data.RankSelect.Base.Rank0 import HaskellWorks.Data.RankSelect.Base.Rank1 import HaskellWorks.Data.RankSelect.Base.Select1 import HaskellWorks.Data.RankSelect.Poppy512 import HaskellWorks.Data.Xml.Succinct.Cursor           as C-import HaskellWorks.Data.Xml.Succinct.Index import HaskellWorks.Data.Xml.Type+import HaskellWorks.Hspec.Hedgehog+import Hedgehog import Test.Hspec  import qualified Data.ByteString              as BS@@ -41,76 +42,44 @@  spec :: Spec spec = describe "HaskellWorks.Data.Xml.TypeSpec" $ do-  describe "Cursor for [Bool]" $ do-    it "initialises to beginning of empty object" $ do-      let cursor = "<elem />" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool])-      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 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+  ( Show              t   , Select1           t-  , Eq                u   , Show              u   , Rank0             u   , Rank1             u   , BalancedParens    u   , TestBit           u-  , FromForeignRegion (XmlCursor BS.ByteString t u)   , IsString          (XmlCursor BS.ByteString t u)-  , XmlIndexAt        (XmlCursor BS.ByteString t u)   )   => String -> (XmlCursor BS.ByteString t u) -> SpecWith () genSpec t _ = do   describe ("XML cursor of type " ++ t) $ do     let forXml (cursor :: XmlCursor BS.ByteString t u) f = describe ("of value " ++ show cursor) (f cursor)     forXml "<elem/>" $ \cursor -> do-      it "should have correct type"       $         xmlTypeAt  cursor `shouldBe` Just XmlTypeElement+      it "should have correct type" . requireTest $ xmlTypeAt cursor === Just XmlTypeElement     forXml " <elem />" $ \cursor -> do-      it "should have correct type"       $         xmlTypeAt  cursor `shouldBe` Just XmlTypeElement+      it "should have correct type" . requireTest $ xmlTypeAt cursor === 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+      it "cursor can navigate to second attribute" $ requireTest $ do+        (fc >=> fc >=> ns >=> ns >=> xmlTypeAt)  cursor  === Just XmlTypeToken+      it "cursor can navigate to first attribute of an inner element" $ requireTest $ do+        (fc >=> ns >=> fc >=> fc >=> xmlTypeAt) cursor === Just XmlTypeToken+      it "cursor can navigate to first atrribute value of an inner element" $ requireTest $ do+        (fc >=> ns >=> fc >=> fc >=> ns >=> xmlTypeAt) cursor === 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+      it "can navigate down and forwards" $ requireTest $ do+        (                     xmlTypeAt) cursor === Just XmlTypeElement+        (fc               >=> xmlTypeAt) cursor === Just XmlTypeToken+        (fc >=> ns        >=> xmlTypeAt) cursor === Nothing+        (fc >=> ns >=> ns >=> xmlTypeAt) cursor === Nothing     describe "For sample Xml" $ do       let cursor = "<widget debug=\"on\"> \                     \  <window name=\"main_window\"> \@@ -119,12 +88,12 @@                     \    <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+      it "can navigate down and forwards" $ requireTest $ do+        (                                                 xmlTypeAt) cursor === Just XmlTypeElement     --widget+        (fc                                           >=> xmlTypeAt) cursor === Just XmlTypeAttrList    --widget attrs+        (fc >=> ns                                    >=> xmlTypeAt) cursor === Just XmlTypeElement     --window+        (fc >=> ns >=> fc                             >=> xmlTypeAt) cursor === Just XmlTypeAttrList    --window attrs+        (fc >=> ns >=> fc >=> ns                      >=> xmlTypeAt) cursor === Just XmlTypeElement     --dimension 500+        (fc >=> ns >=> fc >=> ns >=> ns               >=> xmlTypeAt) cursor === Just XmlTypeElement     --dimension 600+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns        >=> xmlTypeAt) cursor === Just XmlTypeElement     --dimension false+        (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> xmlTypeAt) cursor === Just XmlTypeToken       --false