hw-xml-0.4.0.0: test/HaskellWorks/Data/Xml/Succinct/CursorSpec.hs
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module HaskellWorks.Data.Xml.Succinct.CursorSpec(spec) where
import Control.Monad
import Data.String
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.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) #-}
fc = TC.firstChild
ns = TC.nextSibling
pn = TC.parent
cd = TC.depth
ss = TC.subtreeSize
spec :: Spec
spec = describe "HaskellWorks.Data.Xml.Succinct.CursorSpec" $ do
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" $ 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 === 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
let ic64 = bitShow $ interests cursor64
ic16 `shouldBeginWith` ic8
ic32 `shouldBeginWith` ic16
ic64 `shouldBeginWith` ic32
shouldBeginWith :: (Eq a, Show a) => [a] -> [a] -> PropertyT IO ()
shouldBeginWith as bs = take (length bs) as === bs
genSpec :: forall t u.
( Eq t
, Show t
, Select1 t
, Eq u
, Show u
, Rank0 u
, Rank1 u
, BalancedParens u
, TestBit u
, IsString (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" $ 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 = "<widget debug=\"on\"> \
\ <window name=\"main_window\"> \
\ <dimension>500</dimension> \
\ <dimension>600.01e-02</dimension> \
\ <dimension> false </dimension> \
\ </window> \
\</widget>" :: 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