diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -31,7 +31,7 @@ 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 = blankXml .| blankedXmlToInterestBits runCon :: Conduit i [] BS.ByteString -> i -> BS.ByteString runCon con bs = BS.concat $ runListConduit con [bs] diff --git a/hw-xml.cabal b/hw-xml.cabal --- a/hw-xml.cabal +++ b/hw-xml.cabal @@ -1,14 +1,10 @@ --- This file has been generated from package.yaml by hpack version 0.20.0. --- --- see: https://github.com/sol/hpack --- --- hash: f1fd8d238f37c04b371124c3513386147393fb1a832396113b7048d61c1a3fb9 +cabal-version: 1.12 name: hw-xml -version: 0.1.0.3 +version: 0.1.0.4 synopsis: Conduits for tokenizing streams. -description: Please see README.md -category: Data, XML +description: Conduits for tokenizing streams. Please see README.md +category: Data, XML, Succinct Data Structures, Data Structures homepage: http://github.com/haskell-works/hw-xml#readme bug-reports: https://github.com/haskell-works/hw-xml/issues author: John Ky, @@ -19,11 +15,8 @@ license: BSD3 license-file: LICENSE build-type: Simple -cabal-version: >= 1.10 - extra-source-files: README.md - data-files: data/catalog.xml @@ -32,33 +25,6 @@ location: https://github.com/haskell-works/hw-xml library - hs-source-dirs: - src - ghc-options: -Wall -O2 -msse4.2 - build-depends: - ansi-wl-pprint - , array - , attoparsec - , base >=4 && <5 - , bytestring - , cereal - , conduit - , containers - , deepseq - , ghc-prim - , hw-balancedparens >=0.1.0.0 - , hw-bits >=0.4.0.0 - , hw-conduit >=0.2.0.2 - , hw-parser - , hw-prim >=0.4.0.0 - , hw-rankselect >=0.7.0.0 - , hw-rankselect-base >=0.2.0.0 - , lens - , mtl - , resourcet - , transformers - , vector - , word8 exposed-modules: HaskellWorks.Data.Xml HaskellWorks.Data.Xml.Blank @@ -89,10 +55,39 @@ HaskellWorks.Data.Xml.Value other-modules: Paths_hw_xml + hs-source-dirs: + src + ghc-options: -Wall -O2 -msse4.2 + build-depends: + ansi-wl-pprint + , array + , attoparsec + , base >=4 && <5 + , bytestring + , cereal + , conduit + , containers + , deepseq + , ghc-prim + , hw-balancedparens >=0.1.0.0 + , hw-bits >=0.4.0.0 + , hw-conduit >=0.2.0.2 + , hw-parser + , hw-prim >=0.4.0.0 + , hw-rankselect >=0.7.0.0 + , hw-rankselect-base >=0.2.0.0 + , lens + , mtl + , resourcet + , transformers + , vector + , word8 default-language: Haskell2010 executable hw-xml-example main-is: Main.hs + other-modules: + Paths_hw_xml hs-source-dirs: app ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -msse4.2 @@ -105,13 +100,20 @@ , hw-rankselect >=0.10.0.3 , hw-xml , vector - other-modules: - Paths_hw_xml default-language: Haskell2010 test-suite hw-xml-test type: exitcode-stdio-1.0 main-is: Spec.hs + other-modules: + HaskellWorks.Data.Xml.Conduit.BlankSpec + HaskellWorks.Data.Xml.RawValueSpec + HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec + HaskellWorks.Data.Xml.Succinct.Cursor.InterestBitsSpec + HaskellWorks.Data.Xml.Succinct.CursorSpec + HaskellWorks.Data.Xml.Token.TokenizeSpec + HaskellWorks.Data.Xml.TypeSpec + Paths_hw_xml hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N @@ -130,20 +132,14 @@ , hw-rankselect-base >=0.2.0.0 , hw-xml , vector - other-modules: - HaskellWorks.Data.Xml.Conduit.BlankSpec - HaskellWorks.Data.Xml.RawValueSpec - HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec - HaskellWorks.Data.Xml.Succinct.Cursor.InterestBitsSpec - HaskellWorks.Data.Xml.Succinct.CursorSpec - HaskellWorks.Data.Xml.Token.TokenizeSpec - HaskellWorks.Data.Xml.TypeSpec - Paths_hw_xml default-language: Haskell2010 + build-tool-depends: hspec-discover:hspec-discover benchmark bench type: exitcode-stdio-1.0 main-is: Main.hs + other-modules: + Paths_hw_xml hs-source-dirs: bench ghc-options: -O2 -Wall -msse4.2 @@ -160,6 +156,4 @@ , mmap , resourcet , vector - other-modules: - Paths_hw_xml default-language: Haskell2010 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 @@ -39,10 +39,10 @@ isInterestingWord8 b = interestingWord8s ! b {-# INLINABLE isInterestingWord8 #-} -blankedXmlToInterestBits :: Monad m => Conduit BS.ByteString m BS.ByteString +blankedXmlToInterestBits :: Monad m => ConduitT BS.ByteString BS.ByteString m () blankedXmlToInterestBits = blankedXmlToInterestBits' "" -blankedXmlToInterestBits' :: Monad m => BS.ByteString -> Conduit BS.ByteString m BS.ByteString +blankedXmlToInterestBits' :: Monad m => BS.ByteString -> ConduitT BS.ByteString BS.ByteString m () blankedXmlToInterestBits' rs = do mbs <- await case mbs of @@ -65,27 +65,27 @@ , BS.drop 8 as ) -blankedXmlToBalancedParens :: Monad m => Conduit BS.ByteString m Bool +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 -> Conduit BS.ByteString m Bool +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 () + 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 () @@ -95,10 +95,10 @@ abLen = BS.length abBS cLen = (abLen `div` 8) * 8 -compressWordAsBit :: Monad m => Conduit BS.ByteString m BS.ByteString +compressWordAsBit :: Monad m => ConduitT BS.ByteString BS.ByteString m () compressWordAsBit = compressWordAsBit' BS.empty -compressWordAsBit' :: Monad m => BS.ByteString -> Conduit BS.ByteString m BS.ByteString +compressWordAsBit' :: Monad m => BS.ByteString -> ConduitT BS.ByteString BS.ByteString m () compressWordAsBit' aBS = do mbBS <- await case mbBS of @@ -117,7 +117,7 @@ , BS.drop 8 xs ) -blankedXmlToBalancedParens2 :: Monad m => Conduit BS.ByteString m BS.ByteString +blankedXmlToBalancedParens2 :: Monad m => ConduitT BS.ByteString BS.ByteString m () blankedXmlToBalancedParens2 = do mbs <- await case mbs of @@ -141,18 +141,18 @@ balancedParensOf :: Word8 -> MiniBP balancedParensOf c = case c of - d | d == _less -> MiniT - d | d == _greater -> MiniF - d | d == _bracketleft -> MiniT - d | d == _bracketright -> MiniF - d | d == _parenleft -> MiniT - d | d == _parenright -> MiniF - d | d == _t -> MiniTF - d | d == _a -> MiniTF - d | d == _v -> MiniTF - _ -> MiniN + d | d == _less -> MiniT + d | d == _greater -> MiniF + d | d == _bracketleft -> MiniT + d | d == _bracketright -> MiniF + d | d == _parenleft -> MiniT + d | d == _parenright -> MiniF + d | d == _t -> MiniTF + d | d == _a -> MiniTF + d | d == _v -> MiniTF + _ -> MiniN -yieldBitsOfWord8 :: Monad m => Word8 -> Conduit BS.ByteString m Bool +yieldBitsOfWord8 :: Monad m => Word8 -> ConduitT BS.ByteString Bool m () yieldBitsOfWord8 w = do yield ((w .&. BITS.bit 0) /= 0) yield ((w .&. BITS.bit 1) /= 0) @@ -163,10 +163,10 @@ yield ((w .&. BITS.bit 6) /= 0) yield ((w .&. BITS.bit 7) /= 0) -yieldBitsofWord8s :: Monad m => [Word8] -> Conduit BS.ByteString m Bool +yieldBitsofWord8s :: Monad m => [Word8] -> ConduitT BS.ByteString Bool m () yieldBitsofWord8s = P.foldr ((>>) . yieldBitsOfWord8) (return ()) -byteStringToBits :: Monad m => Conduit BS.ByteString m Bool +byteStringToBits :: Monad m => ConduitT BS.ByteString Bool m () byteStringToBits = do mbs <- await case mbs of 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 @@ -11,7 +11,7 @@ import Control.Monad.Trans.Resource (MonadThrow) import Data.ByteString as BS import Data.Conduit -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) import Data.Word import Data.Word8 import HaskellWorks.Data.Xml.Conduit.Words @@ -35,16 +35,16 @@ | InIdent data BlankData = BlankData - { blankState :: !BlankState - , blankA :: !Word8 - , blankB :: !Word8 - , blankC :: !ByteString + { blankState :: !BlankState + , blankA :: !Word8 + , blankB :: !Word8 + , blankC :: !ByteString } -blankXml :: MonadThrow m => Conduit BS.ByteString m BS.ByteString +blankXml :: MonadThrow m => ConduitT BS.ByteString BS.ByteString m () blankXml = blankXmlPlan1 BS.empty InXml -blankXmlPlan1 :: MonadThrow m => BS.ByteString -> BlankState -> Conduit BS.ByteString m BS.ByteString +blankXmlPlan1 :: MonadThrow m => BS.ByteString -> BlankState -> ConduitT BS.ByteString BS.ByteString m () blankXmlPlan1 as lastState = do mbs <- await case mbs of @@ -53,32 +53,32 @@ 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 -> blankXmlPlan1 cs lastState Nothing -> yield $ BS.map (const _space) as -blankXmlPlan2 :: MonadThrow m => Word8 -> Word8 -> BlankState -> Conduit BS.ByteString m BS.ByteString +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 -blankXmlRun :: MonadThrow m => Bool -> Word8 -> Word8 -> BS.ByteString -> BlankState -> Conduit BS.ByteString m BS.ByteString +blankXmlRun :: MonadThrow m => Bool -> Word8 -> Word8 -> BS.ByteString -> BlankState -> ConduitT BS.ByteString BS.ByteString m () blankXmlRun done a b cs lastState = do let (!ds, Just (BlankData !nextState _ _ _)) = unfoldrN (BS.length cs) blankByteString (BlankData lastState a b cs) yield ds let (yy, zz) = case BS.unsnoc cs of Just (ys, z) -> case BS.unsnoc ys of Just (_, y) -> (y, z) - Nothing -> (b, z) + Nothing -> (b, z) Nothing -> (a, b) unless done (blankXmlPlan2 yy zz nextState) mkNext :: Word8 -> BlankState -> Word8 -> BS.ByteString -> Maybe (Word8, BlankData) mkNext w s a bs = case BS.uncons bs of - Just (b, cs) -> Just (w, BlankData s a b cs) - Nothing -> error "This should never happen" + Just (b, cs) -> Just (w, BlankData s a b cs) + Nothing -> error "This should never happen" {-# INLINE mkNext #-} blankByteString :: BlankData -> Maybe (Word8, BlankData) @@ -87,57 +87,57 @@ blankByteString (BlankData InXml a b cs) | isTextStart a = mkNext _t InText b cs blankByteString (BlankData InXml a b cs) | a == _less = mkNext _less InTag b cs blankByteString (BlankData InXml a b cs) | isSpace a = mkNext a InXml b cs -blankByteString (BlankData InXml _ b cs) = mkNext _space InXml b cs +blankByteString (BlankData InXml _ b cs) = mkNext _space InXml b cs blankByteString (BlankData InTag a b cs) | isSpace a = mkNext _parenleft InAttrList b cs blankByteString (BlankData InTag a b cs) | isTagClose a b = mkNext _space InClose b cs blankByteString (BlankData InTag a b cs) | a == _greater = mkNext _space InXml b cs blankByteString (BlankData InTag a b cs) | isSpace a = mkNext a InTag b cs -blankByteString (BlankData InTag _ b cs) = mkNext _space InTag b cs +blankByteString (BlankData InTag _ b cs) = mkNext _space InTag b cs blankByteString (BlankData InCloseTag a b cs) | a == _greater = mkNext _greater InXml b cs blankByteString (BlankData InCloseTag a b cs) | isSpace a = mkNext a InCloseTag b cs -blankByteString (BlankData InCloseTag _ b cs) = mkNext _space InCloseTag b cs +blankByteString (BlankData InCloseTag _ b cs) = mkNext _space InCloseTag b cs blankByteString (BlankData InAttrList a b cs) | a == _greater = mkNext _parenright InXml b cs blankByteString (BlankData InAttrList a b cs) | isTagClose a b = mkNext _parenright InClose b cs blankByteString (BlankData InAttrList a b cs) | isNameStartChar a = mkNext _a InIdent b cs blankByteString (BlankData InAttrList a b cs) | isQuote a = mkNext _v (InString a) b cs blankByteString (BlankData InAttrList a b cs) | isSpace a = mkNext a InAttrList b cs -blankByteString (BlankData InAttrList _ b cs) = mkNext _space InAttrList b cs -blankByteString (BlankData InClose _ b cs) = mkNext _greater InXml b cs +blankByteString (BlankData InAttrList _ b cs) = mkNext _space InAttrList b cs +blankByteString (BlankData InClose _ b cs) = mkNext _greater InXml b cs blankByteString (BlankData InIdent a b cs) | isNameChar a = mkNext _space InIdent b cs blankByteString (BlankData InIdent a b cs) | isSpace a = mkNext _space InAttrList b cs blankByteString (BlankData InIdent a b cs) | a == _equal = mkNext _space InAttrList b cs blankByteString (BlankData InIdent a b cs) | isSpace a = mkNext a InAttrList b cs -blankByteString (BlankData InIdent _ b cs) = mkNext _space InAttrList b cs +blankByteString (BlankData InIdent _ b cs) = mkNext _space InAttrList b cs blankByteString (BlankData (InString q ) a b cs) | a == q = mkNext _space InAttrList b cs blankByteString (BlankData (InString q ) a b cs) | isSpace a = mkNext a (InString q) b cs -blankByteString (BlankData (InString q ) _ b cs) = mkNext _space (InString q) b cs +blankByteString (BlankData (InString q ) _ b cs) = mkNext _space (InString q) b cs blankByteString (BlankData InText a b cs) | isEndTag a b = mkNext _space InCloseTag b cs blankByteString (BlankData InText _ b cs) | b == _less = mkNext _space InXml b cs blankByteString (BlankData InText a b cs) | isSpace a = mkNext a InText b cs -blankByteString (BlankData InText _ b cs) = mkNext _space InText b cs +blankByteString (BlankData InText _ b cs) = mkNext _space InText b cs blankByteString (BlankData InMeta a b cs) | a == _exclam = mkNext _space InMeta b cs blankByteString (BlankData InMeta a b cs) | a == _hyphen = mkNext _space (InRem 0) b cs blankByteString (BlankData InMeta a b cs) | a == _bracketleft = mkNext _space InCdataTag b cs blankByteString (BlankData InMeta a b cs) | a == _greater = mkNext _bracketright InXml b cs blankByteString (BlankData InMeta a b cs) | isSpace a = mkNext a (InBang 1) b cs -blankByteString (BlankData InMeta _ b cs) = mkNext _space (InBang 1) b cs +blankByteString (BlankData InMeta _ b cs) = mkNext _space (InBang 1) b cs blankByteString (BlankData InCdataTag a b cs) | a == _bracketleft = mkNext _space (InCdata 0) b cs blankByteString (BlankData InCdataTag a b cs) | isSpace a = mkNext a InCdataTag b cs -blankByteString (BlankData InCdataTag _ b cs) = mkNext _space InCdataTag b cs +blankByteString (BlankData InCdataTag _ b cs) = mkNext _space InCdataTag b cs blankByteString (BlankData (InCdata n ) a b cs) | a == _greater && n >= 2 = mkNext _bracketright InXml b cs blankByteString (BlankData (InCdata n ) a b cs) | isCdataEnd a b && n > 0 = mkNext _space (InCdata (n+1)) b cs blankByteString (BlankData (InCdata n ) a b cs) | a == _bracketright = mkNext _space (InCdata (n+1)) b cs blankByteString (BlankData (InCdata _ ) a b cs) | isSpace a = mkNext a (InCdata 0) b cs -blankByteString (BlankData (InCdata _ ) _ b cs) = mkNext _space (InCdata 0) b cs +blankByteString (BlankData (InCdata _ ) _ b cs) = mkNext _space (InCdata 0) b cs blankByteString (BlankData (InRem n ) a b cs) | a == _greater && n >= 2 = mkNext _bracketright InXml b cs blankByteString (BlankData (InRem n ) a b cs) | a == _hyphen = mkNext _space (InRem (n+1)) b cs blankByteString (BlankData (InRem _ ) a b cs) | isSpace a = mkNext a (InRem 0) b cs -blankByteString (BlankData (InRem _ ) _ b cs) = mkNext _space (InRem 0) b cs +blankByteString (BlankData (InRem _ ) _ b cs) = mkNext _space (InRem 0) b cs blankByteString (BlankData (InBang n ) a b cs) | a == _less = mkNext _bracketleft (InBang (n+1)) b cs blankByteString (BlankData (InBang n ) a b cs) | a == _greater && n == 1 = mkNext _bracketright InXml b cs blankByteString (BlankData (InBang n ) a b cs) | a == _greater = mkNext _bracketright (InBang (n-1)) b cs blankByteString (BlankData (InBang n ) a b cs) | isSpace a = mkNext a (InBang n) b cs -blankByteString (BlankData (InBang n ) _ b cs) = mkNext _space (InBang n) b cs +blankByteString (BlankData (InBang n ) _ b cs) = mkNext _space (InBang n) b cs {-# INLINE blankByteString #-} isEndTag :: Word8 -> Word8 -> Bool diff --git a/src/HaskellWorks/Data/Xml/DecodeResult.hs b/src/HaskellWorks/Data/Xml/DecodeResult.hs --- a/src/HaskellWorks/Data/Xml/DecodeResult.hs +++ b/src/HaskellWorks/Data/Xml/DecodeResult.hs @@ -38,6 +38,10 @@ foldr f z (DecodeOk a) = f a z foldr _ z (DecodeFailed _) = z +instance Traversable DecodeResult where + traverse _ (DecodeFailed e) = pure (DecodeFailed e) + traverse f (DecodeOk x) = DecodeOk <$> f x + toEither :: DecodeResult a -> Either DecodeError a toEither (DecodeOk a) = Right a toEither (DecodeFailed e) = Left e diff --git a/src/HaskellWorks/Data/Xml/Grammar.hs b/src/HaskellWorks/Data/Xml/Grammar.hs --- a/src/HaskellWorks/Data/Xml/Grammar.hs +++ b/src/HaskellWorks/Data/Xml/Grammar.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -9,6 +10,7 @@ import Control.Applicative import Data.Char import Data.String +import Data.Word import HaskellWorks.Data.Parser as P import qualified Data.Attoparsec.Types as T @@ -20,12 +22,12 @@ | XmlElementTypeCData | XmlElementTypeMeta String -parseXmlString :: (P.Parser t, IsString t) => T.Parser t String +parseXmlString :: (P.Parser t Word8, IsString t) => T.Parser t String parseXmlString = do q <- satisfyChar (=='"') <|> satisfyChar (=='\'') many (satisfyChar (/= q)) -parseXmlElement :: (P.Parser t, IsString t) => T.Parser t XmlElementType +parseXmlElement :: (P.Parser t Word8, IsString t) => T.Parser t XmlElementType parseXmlElement = comment <|> cdata <|> doc <|> meta <|> element where comment = const XmlElementTypeComment <$> string "!--" @@ -34,10 +36,10 @@ doc = const XmlElementTypeDocument <$> string "?xml" element = XmlElementTypeElement <$> parseXmlToken -parseXmlToken :: (P.Parser t, IsString t) => T.Parser t String +parseXmlToken :: (P.Parser t Word8, IsString t) => T.Parser t String parseXmlToken = many $ satisfyChar isNameChar "invalid string character" -parseXmlAttributeName :: (P.Parser t, IsString t) => T.Parser t String +parseXmlAttributeName :: (P.Parser t Word8, IsString t) => T.Parser t String parseXmlAttributeName = parseXmlToken isNameStartChar :: Char -> Bool 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 @@ -33,20 +33,20 @@ 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 (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) (getBlankedXml bj)) newLen = (BS.length interestBS + 7) `div` 8 * 8 instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word16))) where fromBlankedXml bj = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) - where interestBS = BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml bj)) + where interestBS = BS.concat (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) (getBlankedXml bj)) newLen = (BS.length interestBS + 7) `div` 8 * 8 instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word32))) where fromBlankedXml bj = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) - where interestBS = BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml bj)) + where interestBS = BS.concat (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) (getBlankedXml bj)) newLen = (BS.length interestBS + 7) `div` 8 * 8 instance FromBlankedXml (XmlBalancedParens (SimpleBalancedParens (DVS.Vector Word64))) where fromBlankedXml bj = XmlBalancedParens (SimpleBalancedParens (DVS.unsafeCast (DVS.unfoldrN newLen genBitWordsForever interestBS))) - where interestBS = BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml bj)) + where interestBS = BS.concat (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) (getBlankedXml bj)) newLen = (BS.length interestBS + 7) `div` 8 * 8 diff --git a/src/HaskellWorks/Data/Xml/Token/Tokenize.hs b/src/HaskellWorks/Data/Xml/Token/Tokenize.hs --- a/src/HaskellWorks/Data/Xml/Token/Tokenize.hs +++ b/src/HaskellWorks/Data/Xml/Token/Tokenize.hs @@ -24,22 +24,22 @@ import qualified Data.Attoparsec.Types as T import qualified Data.ByteString as BS -hexDigitNumeric :: P.Parser t => T.Parser t Int +hexDigitNumeric :: P.Parser t Word8 => T.Parser t Int hexDigitNumeric = do c <- satisfyChar (\c -> '0' <= c && c <= '9') return $ ord c - ord '0' -hexDigitAlphaLower :: P.Parser t => T.Parser t Int +hexDigitAlphaLower :: P.Parser t Word8 => T.Parser t Int hexDigitAlphaLower = do c <- satisfyChar (\c -> 'a' <= c && c <= 'z') return $ ord c - ord 'a' + 10 -hexDigitAlphaUpper :: P.Parser t => T.Parser t Int +hexDigitAlphaUpper :: P.Parser t Word8 => T.Parser t Int hexDigitAlphaUpper = do c <- satisfyChar (\c -> 'A' <= c && c <= 'Z') return $ ord c - ord 'A' + 10 -hexDigit :: P.Parser t => T.Parser t Int +hexDigit :: P.Parser t Word8 => T.Parser t Int hexDigit = hexDigitNumeric <|> hexDigitAlphaLower <|> hexDigitAlphaUpper class ParseXml t s d where 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 @@ -23,14 +23,14 @@ spec = describe "HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec" $ do it "Blanking XML should work 1" $ do let blankedXml = BlankedXml [">"] - let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml blankedXml)) + let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) (getBlankedXml blankedXml)) bp `shouldBe` fromString "11011000" it "Blanking XML should work 2" $ do let blankedXml = BlankedXml [ "<><><><><><><><>" , "<><><><><><><><>" ] - let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) (getBlankedXml blankedXml)) + let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) (getBlankedXml blankedXml)) bp `shouldBe` fromString "1010101010101010\ \1010101010101010" @@ -47,12 +47,12 @@ unchunkedInput `shouldBe` BS.concat chunkedInput it "Blanking XML should work 3" $ do - let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) chunkedBlank) + let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) chunkedBlank) putStrLn $ "Good: " <> show chunkedBlank bp `shouldBe` fromString "11101010 10001101 01010100" it "Blanking XML should work 3" $ do - let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) chunkedBadBlank) + let bp = BitShown $ BS.concat (runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit) chunkedBadBlank) putStrLn $ "Bad: " <> show chunkedBadBlank bp `shouldBe` fromString "11101010 10001101 01010100" @@ -72,4 +72,4 @@ mkBlank csize bs = runListConduit blankXml (chunkedBy csize bs) mkBits :: [BS.ByteString] -> [BS.ByteString] -mkBits = runListConduit (blankedXmlToBalancedParens2 =$= compressWordAsBit) +mkBits = runListConduit (blankedXmlToBalancedParens2 .| compressWordAsBit)