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.5.1.0 +version: 0.5.1.1 synopsis: XML parser based on succinct data structures. description: XML parser based on succinct data structures. Please see README.md category: Data, XML, Succinct Data Structures, Data Structures @@ -10,11 +10,11 @@ author: John Ky, Alexey Raga maintainer: alexey.raga@gmail.com -copyright: 2016-2020 John Ky +copyright: 2016-2021 John Ky , 2016-2019 Alexey Raga license: BSD-3-Clause license-file: LICENSE -tested-with: GHC == 8.10.1, GHC == 8.8.3, GHC == 8.6.5, GHC == 8.4.4 +tested-with: GHC == 9.2.2, GHC == 9.0.2, GHC == 8.10.7, GHC == 8.8.4, GHC == 8.6.5 build-type: Simple extra-source-files: README.md data-files: data/catalog.xml @@ -27,32 +27,32 @@ 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 attoparsec { build-depends: attoparsec >= 0.13.2.2 && < 0.15 } +common bytestring { build-depends: bytestring >= 0.10.8.2 && < 0.12 } common cereal { build-depends: cereal >= 0.5.8.1 && < 0.6 } common containers { build-depends: containers >= 0.5.10.2 && < 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 doctest { build-depends: doctest >= 0.16.2 && < 0.17 } +common doctest { build-depends: doctest >= 0.16.2 && < 0.21 } common doctest-discover { build-depends: doctest-discover >= 0.2 && < 0.3 } -common generic-lens { build-depends: generic-lens >= 1.2.0.1 && < 1.3 } -common ghc-prim { build-depends: ghc-prim >= 0.5 && < 0.7 } -common hedgehog { build-depends: hedgehog >= 1.0 && < 1.1 } +common generic-lens { build-depends: generic-lens >= 2.2 && < 2.3 } +common ghc-prim { build-depends: ghc-prim >= 0.5 && < 0.9 } +common hedgehog { build-depends: hedgehog >= 1.0 && < 1.2 } common hspec { build-depends: hspec >= 2.5 && < 3.0 } -common hw-balancedparens { build-depends: hw-balancedparens >= 0.3.0.1 && < 0.4 } +common hw-balancedparens { build-depends: hw-balancedparens >= 0.3.0.1 && < 0.5 } common hw-bits { build-depends: hw-bits >= 0.7.0.9 && < 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.39 && < 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 lens { build-depends: lens >= 4.17.1 && < 6 } 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 optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 && < 0.18 } common resourcet { build-depends: resourcet >= 1.2.2 && < 1.3 } common text { build-depends: text >= 1.2.3.2 && < 1.3 } -common transformers { build-depends: transformers >= 0.5 && < 0.6 } +common transformers { build-depends: transformers >= 0.5 && < 0.7 } common vector { build-depends: vector >= 0.12.0.3 && < 0.13 } common word8 { build-depends: word8 >= 0.1.3 && < 0.2 } @@ -190,6 +190,7 @@ HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXmlSpec HaskellWorks.Data.Xml.Succinct.Cursor.InterestBitsSpec + HaskellWorks.Data.Xml.Succinct.CursorSpec.Make HaskellWorks.Data.Xml.Succinct.CursorSpec HaskellWorks.Data.Xml.Token.TokenizeSpec HaskellWorks.Data.Xml.TypeSpec @@ -216,7 +217,7 @@ , doctest-discover , hw-xml type: exitcode-stdio-1.0 - ghc-options: -threaded + ghc-options: -threaded -rtsopts -with-rtsopts=-N main-is: DoctestDriver.hs HS-Source-Dirs: doctest build-tool-depends: doctest-discover:doctest-discover 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 @@ -21,9 +21,6 @@ {-# INLINE (<*>) #-} instance Monad DecodeResult where - return = DecodeOk - {-# INLINE return #-} - (>>=) (DecodeOk a) f = f a (>>=) (DecodeFailed e) _ = DecodeFailed e {-# INLINE (>>=) #-} diff --git a/src/HaskellWorks/Data/Xml/Internal/Blank.hs b/src/HaskellWorks/Data/Xml/Internal/Blank.hs --- a/src/HaskellWorks/Data/Xml/Internal/Blank.hs +++ b/src/HaskellWorks/Data/Xml/Internal/Blank.hs @@ -60,15 +60,18 @@ blankXmlRun :: Bool -> Word8 -> Word8 -> ByteString -> BlankState -> [ByteString] -> [ByteString] blankXmlRun done a b cs lastState is = do - let (!ds, Just (BlankData !nextState _ _ _)) = BS.unfoldrN (BS.length cs) blankByteString (BlankData lastState a b cs) - 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) - if done - then [ds] - else ds:blankXmlPlan2 yy zz nextState is + let (!ds, mState) = BS.unfoldrN (BS.length cs) blankByteString (BlankData lastState a b cs) + case mState of + Just (BlankData !nextState _ _ _) -> do + 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) + if done + then [ds] + else ds:blankXmlPlan2 yy zz nextState is + Nothing -> error "No state: blankXmlRun" mkNext :: Word8 -> BlankState -> Word8 -> ByteString -> Maybe (Word8, BlankData) mkNext w s a bs = case BS.uncons bs of diff --git a/src/HaskellWorks/Data/Xml/Type.hs b/src/HaskellWorks/Data/Xml/Type.hs --- a/src/HaskellWorks/Data/Xml/Type.hs +++ b/src/HaskellWorks/Data/Xml/Type.hs @@ -18,7 +18,7 @@ import qualified Data.ByteString as BS import qualified HaskellWorks.Data.BalancedParens as BP -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{- HLINT ignore "Reduce duplication" -} data XmlType = XmlTypeElement @@ -32,9 +32,9 @@ instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => XmlTypeAt (XmlCursor String v w) where xmlTypeAtPosition p k = case drop (toCount p) (cursorText k) of - c:_ | fromIntegral (ord c) == _less -> Just XmlTypeElement - c:_ | W8.isSpace $ fromIntegral (ord c) -> Just XmlTypeAttrList - _ -> Just XmlTypeToken + c:_ | fromIntegral (ord c) == _less -> Just XmlTypeElement + c:_ | W8.isSpace $ fromIntegral (ord c) -> Just XmlTypeAttrList + _ -> Just XmlTypeToken xmlTypeAt k = xmlTypeAtPosition p k where p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k))) @@ -43,9 +43,9 @@ instance (BP.BalancedParens w, Rank0 w, Rank1 w, Select1 v, TestBit w) => XmlTypeAt (XmlCursor BS.ByteString v w) where xmlTypeAtPosition p k = case BS.uncons (drop (toCount p) (cursorText k)) of - Just (c, _) | c == _less -> Just XmlTypeElement - Just (c, _) | W8.isSpace c -> Just XmlTypeAttrList - _ -> Just XmlTypeToken + Just (c, _) | c == _less -> Just XmlTypeElement + Just (c, _) | W8.isSpace c -> Just XmlTypeAttrList + _ -> Just XmlTypeToken xmlTypeAt k = xmlTypeAtPosition p k where p = lastPositionOf (select1 ik (rank1 bpk (cursorRank k))) diff --git a/test/HaskellWorks/Data/Xml/Internal/BlankSpec.hs b/test/HaskellWorks/Data/Xml/Internal/BlankSpec.hs --- a/test/HaskellWorks/Data/Xml/Internal/BlankSpec.hs +++ b/test/HaskellWorks/Data/Xml/Internal/BlankSpec.hs @@ -14,8 +14,8 @@ 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) #-} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Reduce duplication" -} whenBlankedXmlShouldBe :: BS.ByteString -> BS.ByteString -> Spec whenBlankedXmlShouldBe original expected = do 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 @@ -35,8 +35,9 @@ import qualified Data.Vector.Storable as DVS import qualified HaskellWorks.Data.TreeCursor as TC -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Redundant return" -} +{- HLINT ignore "Reduce duplication" -} fc = TC.firstChild ns = TC.nextSibling 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 @@ -18,7 +18,7 @@ import qualified Data.ByteString as BS -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{- HLINT ignore "Redundant do" -} spec :: Spec spec = describe "HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec" $ do @@ -52,7 +52,7 @@ annotate $ "Good: " <> show chunkedBlank bp === fromString "11101010 10001101 01010100" - it "Blanking XML should work 3" $ requireTest $do + it "Blanking XML should work 3" $ requireTest $ do let bp = BitShown $ BS.concat (compressWordAsBit (blankedXmlToBalancedParens chunkedBadBlank)) annotate $ "Bad: " <> show chunkedBadBlank bp === fromString "11101010 10001101 01010100" @@ -62,10 +62,10 @@ let whole = mkBlank 4096 document let chunked = mkBlank 15 document - it "should BP the same with chanks" $ requireTest $do + it "should BP the same with chanks" $ requireTest $ do BS.concat chunked === BS.concat whole - it "should produce same bits" $ requireTest $do + it "should produce same bits" $ requireTest $ do BS.concat (mkBits chunked) === BS.concat (mkBits whole) diff --git a/test/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXmlSpec.hs b/test/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXmlSpec.hs --- a/test/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXmlSpec.hs +++ b/test/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXmlSpec.hs @@ -10,7 +10,7 @@ import Hedgehog import Test.Hspec -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{- HLINT ignore "Redundant do" -} spec :: Spec spec = describe "HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXmlSpec" $ do 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 @@ -16,7 +16,7 @@ import qualified Data.ByteString as BS import qualified Data.Vector.Storable as DVS -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{- HLINT ignore "Redundant do" -} interestBitsOf :: FromBlankedXml (XmlInterestBits a) => BS.ByteString -> a interestBitsOf = getXmlInterestBits . fromBlankedXml . bsToBlankedXml @@ -33,7 +33,7 @@ (interestBitsOf " " :: BitShown (DVS.Vector Word8)) === fromString "01011010 00000000" (interestBitsOf " " :: BitShown (DVS.Vector Word8)) === fromString "01000000 00000000" (interestBitsOf " XmlCursor BS.ByteString (BitShown (DVS.Vector Word8 )) (SimpleBalancedParens (DVS.Vector Word8 ))) - genSpec "DVS.Vector Word16" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) - genSpec "DVS.Vector Word32" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) - genSpec "DVS.Vector Word64" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) - genSpec "Poppy512" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) - genSpec "DVS.Vector Word8" CC.byteStringAsFastCursor - genSpec "DVS.Vector Word16" CC.byteStringAsFastCursor - genSpec "DVS.Vector Word32" CC.byteStringAsFastCursor - genSpec "DVS.Vector Word64" CC.byteStringAsFastCursor - genSpec "Poppy512" CC.byteStringAsFastCursor + make "DVS.Vector Word8" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString (BitShown (DVS.Vector Word8 )) (SimpleBalancedParens (DVS.Vector Word8 ))) + make "DVS.Vector Word16" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))) + make "DVS.Vector Word32" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32))) + make "DVS.Vector Word64" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64))) + make "Poppy512" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64))) + make "DVS.Vector Word8" CC.byteStringAsFastCursor + make "DVS.Vector Word16" CC.byteStringAsFastCursor + make "DVS.Vector Word32" CC.byteStringAsFastCursor + make "DVS.Vector Word64" CC.byteStringAsFastCursor + make "Poppy512" CC.byteStringAsFastCursor 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)) @@ -77,70 +78,3 @@ shouldBeginWith :: (Eq a, Show a) => [a] -> [a] -> PropertyT IO () shouldBeginWith as bs = take (length bs) as === bs - -genSpec :: forall t u. - ( Select1 t - , Rank0 u - , Rank1 u - , BalancedParens u - , TestBit u - ) - => String -> (BS.ByteString -> XmlCursor BS.ByteString t u) -> SpecWith () -genSpec t mkCursor = do - describe ("Cursor for (" ++ t ++ ")") $ do - let forXml bs f = let cursor = mkCursor bs in describe (T.unpack ("of value " <> T.decodeUtf8 bs)) (f cursor) - forXml "[null]" $ \cursor -> do - xit "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" $ 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 = mkCursor " \ - \ \ - \ 500 \ - \ 600.01e-02 \ - \ false \ - \ \ - \" :: XmlCursor BS.ByteString t u - 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/Succinct/CursorSpec/Make.hs b/test/HaskellWorks/Data/Xml/Succinct/CursorSpec/Make.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Xml/Succinct/CursorSpec/Make.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module HaskellWorks.Data.Xml.Succinct.CursorSpec.Make + ( make + ) where + +import Control.Monad +import Data.Word +import HaskellWorks.Data.BalancedParens.BalancedParens +import HaskellWorks.Data.BalancedParens.Simple +import HaskellWorks.Data.Bits.BitShow +import HaskellWorks.Data.Bits.BitShown +import HaskellWorks.Data.Bits.BitWise +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.Token +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Test.Hspec + +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.FromByteString as BS +import qualified HaskellWorks.Data.TreeCursor as TC +import qualified HaskellWorks.Data.Xml.Succinct.Cursor.Create as CC + +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Reduce duplication" -} + +fc = TC.firstChild +ns = TC.nextSibling +pn = TC.parent +cd = TC.depth +ss = TC.subtreeSize + +make :: forall t u. + ( Select1 t + , Rank0 u + , Rank1 u + , BalancedParens u + , TestBit u + ) + => String -> (BS.ByteString -> XmlCursor BS.ByteString t u) -> SpecWith () +make t mkCursor = do + describe ("Cursor for (" ++ t ++ ")") $ do + let forXml bs f = let cursor = mkCursor bs in describe (T.unpack ("of value " <> T.decodeUtf8 bs)) (f cursor) + forXml "[null]" $ \cursor -> do + xit "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" $ 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 = mkCursor " \ + \ \ + \ 500 \ + \ 600.01e-02 \ + \ false \ + \ \ + \" :: XmlCursor BS.ByteString t u + 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 @@ -11,7 +11,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as BC import qualified Data.ByteString as BS -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{- HLINT ignore "Redundant do" -} parseXmlToken' :: ByteString -> Either String (XmlToken String Double) parseXmlToken' = BC.parseOnly parseXmlToken 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 @@ -33,9 +33,9 @@ import qualified Data.Vector.Storable as DVS import qualified HaskellWorks.Data.TreeCursor as TC -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -{-# ANN module ("HLint: ignore Redundant bracket" :: String) #-} +{- HLINT ignore "Redundant do" -} +{- HLINT ignore "Redundant bracket" -} +{- HLINT ignore "Reduce duplication" -} fc = TC.firstChild ns = TC.nextSibling