diff --git a/app/App/Commands.hs b/app/App/Commands.hs --- a/app/App/Commands.hs +++ b/app/App/Commands.hs @@ -1,8 +1,12 @@ module App.Commands where import App.Commands.Count +import App.Commands.CreateBlankedXml +import App.Commands.CreateBpIndex +import App.Commands.CreateIbIndex +import App.Commands.CreateIndex import App.Commands.Demo -import Data.Semigroup ((<>)) +import Data.Semigroup ((<>)) import Options.Applicative commands :: Parser (IO ()) @@ -12,4 +16,8 @@ commandsGeneral = subparser $ mempty <> commandGroup "Commands:" <> cmdCount + <> cmdCreateIndex + <> cmdCreateBlankedXml + <> cmdCreateIbIndex + <> cmdCreateBpIndex <> cmdDemo diff --git a/app/App/Commands/CreateBlankedXml.hs b/app/App/Commands/CreateBlankedXml.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/CreateBlankedXml.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module App.Commands.CreateBlankedXml + ( cmdCreateBlankedXml + ) where + +import Control.Lens +import Data.Generics.Product.Any +import Data.Semigroup ((<>)) +import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml +import Options.Applicative hiding (columns) + +import qualified App.Commands.Types as Z +import qualified Data.ByteString.Lazy as LBS + +runCreateBlankedXml :: Z.CreateBlankedXmlOptions -> IO () +runCreateBlankedXml opt = do + let input = opt ^. the @"input" + let output = opt ^. the @"output" + + lbs <- LBS.readFile input + let blankedXml = lbsToBlankedXml lbs + LBS.writeFile output (LBS.fromChunks (blankedXml ^. the @1)) + + return () + +optsCreateBlankedXml :: Parser Z.CreateBlankedXmlOptions +optsCreateBlankedXml = Z.CreateBlankedXmlOptions + <$> strOption + ( long "input" + <> help "Input file" + <> metavar "FILE" + ) + <*> strOption + ( long "output" + <> help "Blanked XML output" + <> metavar "FILE" + ) + +cmdCreateBlankedXml :: Mod CommandFields (IO ()) +cmdCreateBlankedXml = command "create-blanked-xml" $ flip info idm $ runCreateBlankedXml <$> optsCreateBlankedXml diff --git a/app/App/Commands/CreateBpIndex.hs b/app/App/Commands/CreateBpIndex.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/CreateBpIndex.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module App.Commands.CreateBpIndex + ( cmdCreateBpIndex + ) where + +import Control.Lens +import Data.Generics.Product.Any +import Data.Semigroup ((<>)) +import HaskellWorks.Data.Xml.Internal.ToIbBp64 +import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml +import Options.Applicative hiding (columns) + +import qualified App.Commands.Types as Z +import qualified Data.ByteString.Lazy as LBS + +runCreateBpIndex :: Z.CreateBpIndexOptions -> IO () +runCreateBpIndex opt = do + let input = opt ^. the @"input" + let output = opt ^. the @"output" + + lbs <- LBS.readFile input + let blankedXml = lbsToBlankedXml lbs + let ib = toBalancedParens64' blankedXml + LBS.writeFile output (LBS.fromChunks ib) + + return () + +optsCreateBpIndex :: Parser Z.CreateBpIndexOptions +optsCreateBpIndex = Z.CreateBpIndexOptions + <$> strOption + ( long "input" + <> help "Input file" + <> metavar "FILE" + ) + <*> strOption + ( long "output" + <> help "Balanced parens output" + <> metavar "FILE" + ) + +cmdCreateBpIndex :: Mod CommandFields (IO ()) +cmdCreateBpIndex = command "create-bp-index" $ flip info idm $ runCreateBpIndex <$> optsCreateBpIndex diff --git a/app/App/Commands/CreateIbIndex.hs b/app/App/Commands/CreateIbIndex.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/CreateIbIndex.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module App.Commands.CreateIbIndex + ( cmdCreateIbIndex + ) where + +import Control.Lens +import Data.Generics.Product.Any +import Data.Semigroup ((<>)) +import HaskellWorks.Data.Xml.Internal.ToIbBp64 +import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml +import Options.Applicative hiding (columns) + +import qualified App.Commands.Types as Z +import qualified Data.ByteString.Lazy as LBS + +runCreateIbIndex :: Z.CreateIbIndexOptions -> IO () +runCreateIbIndex opt = do + let input = opt ^. the @"input" + let output = opt ^. the @"output" + + lbs <- LBS.readFile input + let blankedXml = lbsToBlankedXml lbs + let ib = toInterestBits64' blankedXml + LBS.writeFile output (LBS.fromChunks ib) + + return () + +optsCreateIbIndex :: Parser Z.CreateIbIndexOptions +optsCreateIbIndex = Z.CreateIbIndexOptions + <$> strOption + ( long "input" + <> help "Input file" + <> metavar "FILE" + ) + <*> strOption + ( long "output" + <> help "Interest Bits output" + <> metavar "FILE" + ) + +cmdCreateIbIndex :: Mod CommandFields (IO ()) +cmdCreateIbIndex = command "create-ib-index" $ flip info idm $ runCreateIbIndex <$> optsCreateIbIndex diff --git a/app/App/Commands/CreateIndex.hs b/app/App/Commands/CreateIndex.hs new file mode 100644 --- /dev/null +++ b/app/App/Commands/CreateIndex.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module App.Commands.CreateIndex + ( cmdCreateIndex + ) where + +import App.Options +import Control.Lens +import Control.Monad +import Data.Generics.Product.Any +import Data.Semigroup ((<>)) +import HaskellWorks.Data.Xml.Internal.ToIbBp64 +import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml +import HaskellWorks.Data.Xml.Succinct.Cursor.MMap +import Options.Applicative hiding (columns) + +import qualified App.Commands.Types as Z +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.IO as TIO +import qualified HaskellWorks.Data.ByteString.Lazy as LBS +import qualified Options.Applicative as OA +import qualified System.Exit as IO +import qualified System.IO as IO + +runCreateIndex :: Z.CreateIndexOptions -> IO () +runCreateIndex opt = do + let input = opt ^. the @"input" + let ibOutput = opt ^. the @"ibOutput" + let bpOutput = opt ^. the @"bpOutput" + let method = opt ^. the @"method" + + case method of + "memory" -> do + cursor <- mmapSlowCursor input + + LBS.writeFile ibOutput (LBS.toLazyByteString (cursor ^. the @"interests" . the @1)) + LBS.writeFile bpOutput (LBS.toLazyByteString (cursor ^. the @"balancedParens" . the @1)) + "stream" -> do + lbs <- LBS.readFile input + let blankedXml = lbsToBlankedXml lbs + let ibBp = toIbBp64 blankedXml + + hIbOutput <- IO.openFile ibOutput IO.WriteMode + hBpOutput <- IO.openFile bpOutput IO.WriteMode + + forM_ ibBp $ \(ib, bp) -> do + BS.hPut hIbOutput ib + BS.hPut hBpOutput bp + + IO.hClose hIbOutput + IO.hClose hBpOutput + + return () + unknown -> do + TIO.hPutStrLn IO.stderr $ "Unsupported method: " <> unknown + IO.exitFailure + +optsCreateIndex :: Parser Z.CreateIndexOptions +optsCreateIndex = Z.CreateIndexOptions + <$> strOption + ( long "input" + <> help "Input file" + <> metavar "FILE" + ) + <*> strOption + ( long "ib-output" + <> help "Interest Bits output" + <> metavar "FILE" + ) + <*> strOption + ( long "bp-output" + <> help "Balanced Parens output" + <> metavar "FILE" + ) + <*> textOption + ( long "method" + <> help "Method" + <> metavar "METHOD" + <> OA.value "memory" + ) + +cmdCreateIndex :: Mod CommandFields (IO ()) +cmdCreateIndex = command "create-index" $ flip info idm $ runCreateIndex <$> optsCreateIndex diff --git a/app/App/Commands/Types.hs b/app/App/Commands/Types.hs --- a/app/App/Commands/Types.hs +++ b/app/App/Commands/Types.hs @@ -3,6 +3,10 @@ module App.Commands.Types ( CountOptions(..) + , CreateBlankedXmlOptions(..) + , CreateBpIndexOptions(..) + , CreateIbIndexOptions(..) + , CreateIndexOptions(..) , DemoOptions(..) ) where @@ -16,4 +20,26 @@ { input :: FilePath , xpath :: XPath , method :: Text + } deriving (Eq, Show, Generic) + +data CreateIndexOptions = CreateIndexOptions + { input :: FilePath + , ibOutput :: FilePath + , bpOutput :: FilePath + , method :: Text + } deriving (Eq, Show, Generic) + +data CreateBlankedXmlOptions = CreateBlankedXmlOptions + { input :: FilePath + , output :: FilePath + } deriving (Eq, Show, Generic) + +data CreateIbIndexOptions = CreateIbIndexOptions + { input :: FilePath + , output :: FilePath + } deriving (Eq, Show, Generic) + +data CreateBpIndexOptions = CreateBpIndexOptions + { input :: FilePath + , output :: FilePath } deriving (Eq, Show, Generic) 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.4.0.0 +version: 0.4.0.1 synopsis: Conduits for tokenizing streams. description: Conduits for tokenizing streams. Please see README.md category: Data, XML, Succinct Data Structures, Data Structures @@ -37,8 +37,8 @@ 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-balancedparens { build-depends: hw-balancedparens >= 0.3.0.1 && < 0.4 } +common hw-bits { build-depends: hw-bits >= 0.7.0.7 && < 0.8 } 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.33 && < 0.7 } @@ -139,6 +139,10 @@ other-modules: Paths_hw_xml App.Commands App.Commands.Count + App.Commands.CreateBlankedXml + App.Commands.CreateBpIndex + App.Commands.CreateIbIndex + App.Commands.CreateIndex App.Commands.Demo App.Commands.Types App.Options 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 @@ -10,30 +10,35 @@ , isInterestingWord8 ) where -import Data.Array.Unboxed as A import Data.ByteString as BS import Data.Word import Data.Word8 +import HaskellWorks.Data.AtIndex ((!!!)) import HaskellWorks.Data.Bits.BitWise import Prelude as P -import qualified Data.Bits as BITS +import qualified Data.Bits as BITS +import qualified Data.Vector.Storable as DVS -interestingWord8s :: A.UArray Word8 Word8 -interestingWord8s = A.array (0, 255) [ - (w, if w == _bracketleft - || w == _braceleft - || w == _parenleft - || w == _bracketleft - || w == _less - || w == _a || w == _v || w == _t - then 1 - else 0) - | w <- [0 .. 255]] +interestingWord8s :: DVS.Vector Word8 +interestingWord8s = DVS.constructN 256 go + where go :: DVS.Vector Word8 -> Word8 + go v = if w == _bracketleft + || w == _braceleft + || w == _parenleft + || w == _bracketleft + || w == _less + || w == _a + || w == _v + || w == _t + then 1 + else 0 + where w :: Word8 + w = fromIntegral (DVS.length v) {-# NOINLINE interestingWord8s #-} isInterestingWord8 :: Word8 -> Word8 -isInterestingWord8 b = interestingWord8s ! b +isInterestingWord8 b = fromIntegral (interestingWord8s !!! fromIntegral b) {-# INLINABLE isInterestingWord8 #-} blankedXmlToInterestBits :: [BS.ByteString] -> [BS.ByteString] @@ -55,7 +60,7 @@ where gen :: ByteString -> Maybe (Word8, ByteString) gen as = if BS.length as == 0 then Nothing - else Just ( BS.foldr' (\b m -> (interestingWord8s ! b) .|. (m .<. 1)) 0 (BS.take 8 as) + else Just ( BS.foldr' (\b m -> isInterestingWord8 b .|. (m .<. 1)) 0 (BS.take 8 as) , BS.drop 8 as ) 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 @@ -1,17 +1,23 @@ +{-# LANGUAGE DeriveGeneric #-} module HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml ( BlankedXml(..) , FromBlankedXml(..) , getBlankedXml , bsToBlankedXml + , lbsToBlankedXml ) where -import HaskellWorks.Data.ByteString +import GHC.Generics import HaskellWorks.Data.Xml.Conduit.Blank -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified HaskellWorks.Data.ByteString as BS -newtype BlankedXml = BlankedXml [BS.ByteString] deriving (Eq, Show) +newtype BlankedXml = BlankedXml + { unblankedXml :: [BS.ByteString] + } deriving (Eq, Show, Generic) getBlankedXml :: BlankedXml -> [BS.ByteString] getBlankedXml (BlankedXml bs) = bs @@ -20,4 +26,7 @@ fromBlankedXml :: BlankedXml -> a bsToBlankedXml :: BS.ByteString -> BlankedXml -bsToBlankedXml bs = BlankedXml (blankXml (chunkedBy 4064 bs)) +bsToBlankedXml bs = BlankedXml (blankXml (BS.chunkedBy 4064 bs)) + +lbsToBlankedXml :: LBS.ByteString -> BlankedXml +lbsToBlankedXml lbs = BlankedXml (blankXml (BS.resegmentPadded 4096 (LBS.toChunks lbs)))