diff --git a/app/App/Commands.hs b/app/App/Commands.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands.hs @@ -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 diff --git a/app/App/Commands/Count.hs b/app/App/Commands/Count.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/Count.hs @@ -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 diff --git a/app/App/Commands/Demo.hs b/app/App/Commands/Demo.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/Demo.hs @@ -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 diff --git a/app/App/Commands/Types.hs b/app/App/Commands/Types.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/Types.hs @@ -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) diff --git a/app/App/Naive.hs b/app/App/Naive.hs new file mode 100644 --- /dev/null +++ b/app/App/Naive.hs @@ -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 diff --git a/app/App/Options.hs b/app/App/Options.hs new file mode 100644 --- /dev/null +++ b/app/App/Options.hs @@ -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 diff --git a/app/App/Show.hs b/app/App/Show.hs new file mode 100644 --- /dev/null +++ b/app/App/Show.hs @@ -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 diff --git a/app/App/XPath/Parser.hs b/app/App/XPath/Parser.hs new file mode 100644 --- /dev/null +++ b/app/App/XPath/Parser.hs @@ -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 '/') diff --git a/app/App/XPath/Types.hs b/app/App/XPath/Types.hs new file mode 100644 --- /dev/null +++ b/app/App/XPath/Types.hs @@ -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) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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) diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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 = diff --git a/hw-xml.cabal b/hw-xml.cabal --- a/hw-xml.cabal +++ b/hw-xml.cabal @@ -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 diff --git a/src/HaskellWorks/Data/Xml/Conduit.hs b/src/HaskellWorks/Data/Xml/Conduit.hs --- a/src/HaskellWorks/Data/Xml/Conduit.hs +++ b/src/HaskellWorks/Data/Xml/Conduit.hs @@ -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 + [] -> [] diff --git a/src/HaskellWorks/Data/Xml/Conduit/Blank.hs b/src/HaskellWorks/Data/Xml/Conduit/Blank.hs --- a/src/HaskellWorks/Data/Xml/Conduit/Blank.hs +++ b/src/HaskellWorks/Data/Xml/Conduit/Blank.hs @@ -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 diff --git a/src/HaskellWorks/Data/Xml/Decode.hs b/src/HaskellWorks/Data/Xml/Decode.hs --- a/src/HaskellWorks/Data/Xml/Decode.hs +++ b/src/HaskellWorks/Data/Xml/Decode.hs @@ -4,7 +4,7 @@ import Control.Lens import Control.Monad import Data.Foldable -import Data.Monoid ((<>)) +import Data.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 diff --git a/src/HaskellWorks/Data/Xml/Internal/ToIbBp64.hs b/src/HaskellWorks/Data/Xml/Internal/ToIbBp64.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Internal/ToIbBp64.hs @@ -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) diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParens.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParens.hs --- a/src/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParens.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParens.hs @@ -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 diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs --- a/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs @@ -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)) diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/Create.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Create.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Create.hs @@ -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) diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBits.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBits.hs --- a/src/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBits.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBits.hs @@ -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 diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs --- a/src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Internal.hs @@ -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 diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/Load.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Load.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Load.hs @@ -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 diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/MMap.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/MMap.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/MMap.hs @@ -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 diff --git a/src/HaskellWorks/Data/Xml/Succinct/Cursor/Types.hs b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Types.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Xml/Succinct/Cursor/Types.hs @@ -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) diff --git a/test/HaskellWorks/Data/Xml/Conduit/BlankSpec.hs b/test/HaskellWorks/Data/Xml/Conduit/BlankSpec.hs --- a/test/HaskellWorks/Data/Xml/Conduit/BlankSpec.hs +++ b/test/HaskellWorks/Data/Xml/Conduit/BlankSpec.hs @@ -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 @@ "00" `whenBlankedXmlShouldBe` "< < t >< > >" "0" `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 = "\n\n " let inputOriginalSuffix = "\n \n \n \n \n \n\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 = "" let inputOriginalSuffix = "\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 = "" let inputOriginalSuffix = "\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 diff --git a/test/HaskellWorks/Data/Xml/RawValueSpec.hs b/test/HaskellWorks/Data/Xml/RawValueSpec.hs --- a/test/HaskellWorks/Data/Xml/RawValueSpec.hs +++ b/test/HaskellWorks/Data/Xml/RawValueSpec.hs @@ -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 "" $ \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 "" $ \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 "" $ \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 "value text" $ \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 "" $ \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 "" $ \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 " tag]]>" $ \cursor -> do - it "should parse cdata data" $ rawValueVia (Just cursor) `shouldBe` + it "should parse cdata data" $ requireTest $ rawValueVia (Just cursor) === RawCData "a
tag" forXml "]>" $ \cursor -> do - it "should parse metas" $ rawValueVia (Just cursor) `shouldBe` + it "should parse metas" $ requireTest $ rawValueVia (Just cursor) === RawMeta "DOCTYPE" [RawMeta "ELEMENT" []] forXml "free" $ \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" diff --git a/test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs b/test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs --- a/test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs +++ b/test/HaskellWorks/Data/Xml/Succinct/Cursor/BalancedParensSpec.hs @@ -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 [">"] - 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 = "\n\n \n \n \n \n \n \n\n" let chunkedInput = chunkedBy 15 unchunkedInput - let chunkedBlank = runListConduit blankXml chunkedInput + let chunkedBlank = blankXml chunkedInput let unchunkedBadInput = "\n\n \n \n \n \n \n \n\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 = "free" 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 diff --git a/test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs b/test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs --- a/test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs +++ b/test/HaskellWorks/Data/Xml/Succinct/Cursor/InterestBitsSpec.hs @@ -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 "" :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "10010000 00000000" - (interestBitsOf " " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "01011010 00000000" - (interestBitsOf " " :: BitShown (DVS.Vector Word8)) `shouldBe` fromString "01000000 00000000" - (interestBitsOf "" :: BitShown (DVS.Vector Word8)) === fromString "10010000 00000000" + (interestBitsOf " " :: BitShown (DVS.Vector Word8)) === fromString "01011010 00000000" + (interestBitsOf " " :: BitShown (DVS.Vector Word8)) === fromString "01000000 00000000" + (interestBitsOf " >" ] - 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 diff --git a/test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs b/test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs --- a/test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs +++ b/test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs @@ -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 = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - cd cursor `shouldBe` Just 1 - it "depth at attribute list" $ do - let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> cd) cursor `shouldBe` Just 2 - it "depth first attribute" $ do - let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> fc >=> cd) cursor `shouldBe` Just 3 - it "depth second attribute" $ do - let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> fc >=> ns >=> cd) cursor `shouldBe` Just 3 - it "depth at value" $ do - let cursor = "text" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> ns >=> cd) cursor `shouldBe` Just 2 - 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 = " \ @@ -125,39 +104,39 @@ \ false \ \ \ \" :: 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 diff --git a/test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs b/test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs --- a/test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs +++ b/test/HaskellWorks/Data/Xml/Token/TokenizeSpec.hs @@ -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 diff --git a/test/HaskellWorks/Data/Xml/TypeSpec.hs b/test/HaskellWorks/Data/Xml/TypeSpec.hs --- a/test/HaskellWorks/Data/Xml/TypeSpec.hs +++ b/test/HaskellWorks/Data/Xml/TypeSpec.hs @@ -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 = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - xmlTypeAt cursor `shouldBe` Just XmlTypeElement - it "initialises to beginning of empty object preceded by spaces" $ do - let cursor = " " :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - xmlTypeAt cursor `shouldBe` Just XmlTypeElement - it "cursor can navigate to attr list" $ do - let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList - it "cursor can navigate through attrs" $ do - let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --foo - (fc >=> fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --bar - (fc >=> fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --boo - (fc >=> fc >=> ns >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --buzz - (fc >=> fc >=> ns >=> ns >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing --back off! - it "cursor can navigate to children" $ do - let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --b - (fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --c - (fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing --back off! - it "cursor recognises child element as an element child next to attr list" $ do - let cursor = "" :: XmlCursor String (BitShown [Bool]) (SimpleBalancedParens [Bool]) - (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList - (fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement - (fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing -- no more! - - genSpec "DVS.Vector Word8" (undefined :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))) + genSpec "DVS.Vector 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 "" $ \cursor -> do - it "should have correct type" $ xmlTypeAt cursor `shouldBe` Just XmlTypeElement + it "should have correct type" . requireTest $ xmlTypeAt cursor === Just XmlTypeElement forXml " " $ \cursor -> do - it "should have correct type" $ xmlTypeAt cursor `shouldBe` Just XmlTypeElement + it "should have correct type" . requireTest $ xmlTypeAt cursor === Just XmlTypeElement forXml "" $ \cursor -> do - it "cursor can navigate to second attribute" $ do - (fc >=> fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken - it "cursor can navigate to first attribute of an inner element" $ do - (fc >=> ns >=> fc >=> fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken - it "cursor can navigate to first atrribute value of an inner element" $ do - (fc >=> ns >=> fc >=> fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken + 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 = "text" :: XmlCursor BS.ByteString t u - it "can navigate down and forwards" $ do - ( xmlTypeAt) cursor `shouldBe` Just XmlTypeElement - (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken - (fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing - (fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Nothing + 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 = " \ \ \ @@ -119,12 +88,12 @@ \ false \ \ \ \" :: XmlCursor BS.ByteString t u - it "can navigate down and forwards" $ do - ( xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --widget - (fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList --widget attrs - (fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --window - (fc >=> ns >=> fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeAttrList --window attrs - (fc >=> ns >=> fc >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --dimension 500 - (fc >=> ns >=> fc >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --dimension 600 - (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeElement --dimension false - (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> xmlTypeAt) cursor `shouldBe` Just XmlTypeToken --false + 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