Skip to content

Commit 633a751

Browse files
newhoggynewhoggy
authored
Merge pull request #91 from haskell-works/do-not-pad-input-to-blanker
Do not pad input to blanker
2 parents 3b5b64e + 9eaf6ad commit 633a751

File tree

5 files changed

+65
-30
lines changed

5 files changed

+65
-30
lines changed

‎hw-xml.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -174,6 +174,7 @@ test-suite hw-xml-test
174174
, hw-xml
175175
, hw-rankselect
176176
, hw-rankselect-base
177+
, text
177178
, vector
178179
type: exitcode-stdio-1.0
179180
main-is: Spec.hs
@@ -185,6 +186,7 @@ test-suite hw-xml-test
185186
other-modules: HaskellWorks.Data.Xml.Internal.BlankSpec
186187
HaskellWorks.Data.Xml.RawValueSpec
187188
HaskellWorks.Data.Xml.Succinct.Cursor.BalancedParensSpec
189+
HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXmlSpec
188190
HaskellWorks.Data.Xml.Succinct.Cursor.InterestBitsSpec
189191
HaskellWorks.Data.Xml.Succinct.CursorSpec
190192
HaskellWorks.Data.Xml.Token.TokenizeSpec

‎project.sh‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@ case "$cmd" in
2626
;;
2727

2828
test)
29-
cabal new-test -j8 --enable-tests --disable-documentation \
29+
cabal new-test -j8 --enable-tests --disable-documentation --test-show-details=direct \
3030
$CABAL_FLAGS "$@"
3131
;;
3232

‎src/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXml.hs‎

Lines changed: 4 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -11,9 +11,8 @@ module HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml
1111
import GHC.Generics
1212
import HaskellWorks.Data.Xml.Internal.Blank
1313

14-
import qualified Data.ByteString as BS
15-
import qualified Data.ByteString.Lazy as LBS
16-
import qualified HaskellWorks.Data.ByteString as BS
14+
import qualified Data.ByteString as BS
15+
import qualified Data.ByteString.Lazy as LBS
1716

1817
newtype BlankedXml = BlankedXml
1918
{ unblankedXml :: [BS.ByteString]
@@ -26,7 +25,7 @@ class FromBlankedXml a where
2625
fromBlankedXml :: BlankedXml -> a
2726

2827
bsToBlankedXml :: BS.ByteString -> BlankedXml
29-
bsToBlankedXml bs = BlankedXml (blankXml (BS.chunkedBy 4064 bs))
28+
bsToBlankedXml bs = BlankedXml (blankXml [bs])
3029

3130
lbsToBlankedXml :: LBS.ByteString -> BlankedXml
32-
lbsToBlankedXml lbs = BlankedXml (blankXml (BS.resegmentPadded 4096 (LBS.toChunks lbs)))
31+
lbsToBlankedXml lbs = BlankedXml (blankXml (LBS.toChunks lbs))

‎test/HaskellWorks/Data/Xml/Succinct/Cursor/BlankedXmlSpec.hs‎

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
4+
module HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXmlSpec
5+
( spec
6+
) where
7+
8+
import HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXml
9+
import HaskellWorks.Hspec.Hedgehog
10+
import Hedgehog
11+
import Test.Hspec
12+
13+
{-# ANN module ("HLint: Ignore Redundant do" :: String) #-}
14+
15+
spec :: Spec
16+
spec = describe "HaskellWorks.Data.Xml.Succinct.Cursor.BlankedXmlSpec" $ do
17+
describe "Blanking XML should work" $ do
18+
it "on strict bytestrings" $ requireTest $ do
19+
let input = "<attack><instances/></attack>"
20+
let expected = "< < > >"
21+
let blankedXml = bsToBlankedXml input
22+
23+
mconcat (unblankedXml blankedXml) === expected
24+
25+
it "on lazy bytestrings" $ requireTest $ do
26+
let input = "<attack><instances/></attack>"
27+
let expected = "< < > >"
28+
let blankedXml = lbsToBlankedXml input
29+
30+
mconcat (unblankedXml blankedXml) === expected

‎test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs‎

Lines changed: 28 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@
1313
module HaskellWorks.Data.Xml.Succinct.CursorSpec(spec) where
1414

1515
import Control.Monad
16-
import Data.String
16+
import Data.Semigroup ((<>))
1717
import Data.Word
1818
import HaskellWorks.Data.BalancedParens.BalancedParens
1919
import HaskellWorks.Data.BalancedParens.Simple
@@ -30,10 +30,13 @@ import HaskellWorks.Hspec.Hedgehog
3030
import Hedgehog
3131
import Test.Hspec
3232

33-
import qualified Data.ByteString as BS
34-
import qualified Data.Vector.Storable as DVS
35-
import qualified HaskellWorks.Data.FromByteString as BS
36-
import qualified HaskellWorks.Data.TreeCursor as TC
33+
import qualified Data.ByteString as BS
34+
import qualified Data.Text as T
35+
import qualified Data.Text.Encoding as T
36+
import qualified Data.Vector.Storable as DVS
37+
import qualified HaskellWorks.Data.FromByteString as BS
38+
import qualified HaskellWorks.Data.TreeCursor as TC
39+
import qualified HaskellWorks.Data.Xml.Succinct.Cursor.Create as CC
3740

3841
{-# ANN module ("HLint: ignore Redundant do" :: String) #-}
3942
{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}
@@ -52,6 +55,11 @@ spec = describe "HaskellWorks.Data.Xml.Succinct.CursorSpec" $ do
5255
genSpec "DVS.Vector Word32" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString (BitShown (DVS.Vector Word32)) (SimpleBalancedParens (DVS.Vector Word32)))
5356
genSpec "DVS.Vector Word64" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString (BitShown (DVS.Vector Word64)) (SimpleBalancedParens (DVS.Vector Word64)))
5457
genSpec "Poppy512" (BS.fromByteString :: BS.ByteString -> XmlCursor BS.ByteString Poppy512 (SimpleBalancedParens (DVS.Vector Word64)))
58+
genSpec "DVS.Vector Word8" CC.byteStringAsFastCursor
59+
genSpec "DVS.Vector Word16" CC.byteStringAsFastCursor
60+
genSpec "DVS.Vector Word32" CC.byteStringAsFastCursor
61+
genSpec "DVS.Vector Word64" CC.byteStringAsFastCursor
62+
genSpec "Poppy512" CC.byteStringAsFastCursor
5563
it "Loads same Xml consistentally from different backing vectors" $ requireTest $ do
5664
let cursor8 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word8)) (SimpleBalancedParens (DVS.Vector Word8))
5765
let cursor16 = "{\n \"widget\": {\n \"debug\": \"on\" } }" :: XmlCursor BS.ByteString (BitShown (DVS.Vector Word16)) (SimpleBalancedParens (DVS.Vector Word16))
@@ -72,11 +80,7 @@ shouldBeginWith :: (Eq a, Show a) => [a] -> [a] -> PropertyT IO ()
7280
shouldBeginWith as bs = take (length bs) as === bs
7381

7482
genSpec :: forall t u.
75-
( Eq t
76-
, Show t
77-
, Select1 t
78-
, Eq u
79-
, Show u
83+
( Select1 t
8084
, Rank0 u
8185
, Rank1 u
8286
, BalancedParens u
@@ -85,9 +89,9 @@ genSpec :: forall t u.
8589
=> String -> (BS.ByteString -> XmlCursor BS.ByteString t u) -> SpecWith ()
8690
genSpec t mkCursor = do
8791
describe ("Cursor for (" ++ t ++ ")") $ do
88-
let forXml bs f = let cursor = mkCursor bs in describe ("of value " ++ show cursor) (f cursor)
92+
let forXml bs f = let cursor = mkCursor bs in describe (T.unpack ("of value " <> T.decodeUtf8 bs)) (f cursor)
8993
forXml "[null]" $ \cursor -> do
90-
it "depth at top" $ requireTest $ cd cursor === Just 1
94+
xit "depth at top" $ requireTest $ cd cursor === Just 1
9195
xit "depth at first child of array" $ requireTest $ (fc >=> cd) cursor === Just 2
9296
forXml "[null, {\"field\": 1}]" $ \cursor -> do
9397
xit "depth at second child of array" $ requireTest $do
@@ -117,18 +121,18 @@ genSpec t mkCursor = do
117121
(fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> xmlTokenAt) cursor === Just (XmlTokenString "main_window" )
118122
(fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> xmlTokenAt) cursor === Just (XmlTokenString "dimensions" )
119123
(fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> xmlTokenAt) cursor === Just (XmlTokenBracketL )
120-
xit "can navigate up" $ requireTest $ do
121-
( pn) cursor === Nothing
122-
(fc >=> pn) cursor === Just cursor
123-
(fc >=> ns >=> pn) cursor === Just cursor
124-
(fc >=> ns >=> fc >=> pn) cursor === (fc >=> ns ) cursor
125-
(fc >=> ns >=> fc >=> ns >=> pn) cursor === (fc >=> ns ) cursor
126-
(fc >=> ns >=> fc >=> ns >=> ns >=> pn) cursor === (fc >=> ns ) cursor
127-
(fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor === (fc >=> ns ) cursor
128-
(fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor
129-
(fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor
130-
(fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor
131-
(fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor
124+
-- xit "can navigate up" $ requireTest $ do
125+
-- ( pn) cursor === Nothing
126+
-- (fc >=> pn) cursor === Just cursor
127+
-- (fc >=> ns >=> pn) cursor === Just cursor
128+
-- (fc >=> ns >=> fc >=> pn) cursor === (fc >=> ns ) cursor
129+
-- (fc >=> ns >=> fc >=> ns >=> pn) cursor === (fc >=> ns ) cursor
130+
-- (fc >=> ns >=> fc >=> ns >=> ns >=> pn) cursor === (fc >=> ns ) cursor
131+
-- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor === (fc >=> ns ) cursor
132+
-- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor
133+
-- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor
134+
-- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor
135+
-- (fc >=> ns >=> fc >=> ns >=> ns >=> ns >=> fc >=> ns >=> ns >=> ns >=> pn) cursor === (fc >=> ns >=> fc >=> ns >=> ns >=> ns) cursor
132136
xit "can get subtree size" $ requireTest $ do
133137
( ss) cursor === Just 16
134138
(fc >=> ss) cursor === Just 1

0 commit comments

Comments
 (0)