streamly-0.11.1: test/Streamly/Test/Data/Parser.hs
{-# Language NoMonoLocalBinds #-}
-- XXX We are using head/tail at one place
#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif
module Main (main) where
import Control.Applicative ((<|>))
import Control.Exception (displayException)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Char (isSpace)
import Data.Foldable (for_)
import Data.Word (Word8, Word32, Word64)
import Streamly.Internal.Data.Fold (Fold(..))
import Streamly.Internal.Data.Parser (Parser(..), Step(..), Initial(..), Final(..))
import Streamly.Test.Common (listEquals, checkListEqual, chooseInt)
import Streamly.Internal.Data.Parser (ParseError(..))
import Test.QuickCheck (forAll, Property, property, listOf, vectorOf, Gen)
import Test.QuickCheck.Monadic (monadicIO, assert, run)
import Prelude hiding (sequence)
import qualified Streamly.Test.Data.Parser.Common as Common
import qualified Streamly.Data.Stream as S
import qualified Streamly.Internal.Data.Array as A
import qualified Streamly.Internal.Data.Fold as FL
import qualified Streamly.Internal.Data.Parser as P
import qualified Streamly.Internal.Data.ParserK as PK
import qualified Streamly.Internal.Data.Producer as Producer
import qualified Streamly.Internal.Data.Unfold as Unfold
import qualified Streamly.Internal.Data.Stream as SI
import qualified Streamly.Internal.Data.StreamK as K
import qualified Test.Hspec as H
import Test.Hspec
import Test.Hspec.QuickCheck
import Streamly.Test.Parser.Common
#if MIN_VERSION_QuickCheck(2,14,0)
import Test.QuickCheck (chooseAny)
#else
import System.Random (Random(random))
import Test.QuickCheck.Gen (Gen(MkGen))
-- | Generates a random element over the natural range of `a`.
chooseAny :: Random a => Gen a
chooseAny = MkGen (\r _ -> let (x,_) = random r in x)
#endif
maxTestCount :: Int
maxTestCount = 100
-------------------------------------------------------------------------------
-- Stream parsing
-------------------------------------------------------------------------------
parseManyWordQuotedBy :: H.SpecWith ()
parseManyWordQuotedBy =
describe "parseMany wordQuotedBy"
$ for_ testCases
$ \c@(kQ, isQ, input, expected) -> do
let inpStrm = S.fromList input
esc = '\\'
spc ' ' = True
spc _ = False
tr _ _ = Nothing
parser = P.wordWithQuotes kQ tr esc isQ spc FL.toList
result <- H.runIO $ S.fold FL.toList $ S.catRights $ S.parseMany parser inpStrm
H.it (showCase c) $ result `H.shouldBe` expected
where
showCase (kQ, _, input, expected) =
show kQ ++ ", " ++ input ++ " -> " ++ show expected
testCases =
[ ( True
, \x -> if x == '\'' then Just '\'' else Nothing
, "The quick brown fox"
, ["The", "quick", "brown", "fox"])
, ( True
, \x -> if x == '\'' then Just '\'' else Nothing
, "The' quick brown' fox"
, ["The' quick brown'", "fox"])
, ( False
, \x -> if x == '\'' then Just '\'' else Nothing
, "The' quick brown' fox"
, ["The quick brown", "fox"])
, ( True
, \x -> if x == '[' then Just ']' else Nothing
, "The[ quick brown] fox"
, ["The[ quick brown]", "fox"])
, ( True
, \x -> if x == '[' then Just ']' else Nothing
, "The[ qui[ck] brown] \\ f[ ox]"
, ["The[ qui[ck] brown]", " f[ ox]"])
, ( False
, \x -> if x == '[' then Just ']' else Nothing
, "The[ qui[ck] brown] fox"
, ["The qui[ck] brown", "fox"])
]
parseMany :: Property
parseMany =
forAll (chooseInt (1,100)) $ \len ->
forAll (listOf (vectorOf len (chooseAny :: Gen Int))) $ \ ins ->
monadicIO $ do
outs <- do
let p = P.fromFold $ FL.take len FL.toList
run
$ S.fold FL.toList
$ S.catRights
$ S.parseMany p (S.fromList $ concat ins)
listEquals (==) outs ins
-- basic sanity test for parsing from arrays
parseUnfold :: Property
parseUnfold = do
let len = 200
-- ls = input list (stream)
-- clen = chunk size
-- tlen = parser take size
forAll
((,,)
<$> vectorOf len (chooseAny :: Gen Int)
<*> chooseInt (1, len)
<*> chooseInt (1, len)) $ \(ls, clen, tlen) ->
monadicIO $ do
arrays <- S.toList $ A.chunksOf clen (S.fromList ls)
let src = Producer.source (Just (Producer.OuterLoop arrays))
let parser = P.fromFold (FL.take tlen FL.toList)
let readSrc =
Producer.producer
$ Producer.concat Producer.fromList A.producer
let streamParser =
Producer.simplify (Producer.parseManyD parser readSrc)
xs <- run
$ S.toList
$ S.unfoldEach Unfold.fromList
$ S.catRights
$ S.unfold streamParser src
listEquals (==) xs ls
parserSequence :: Property
parserSequence =
forAll (vectorOf 11 (listOf (chooseAny :: Gen Int))) $ \ins ->
monadicIO $ do
let parsers = S.fromList
$ fmap (\xs -> P.fromFold $ FL.take (length xs) FL.sum) ins
let sequencedParser = P.sequence parsers FL.sum
outs <-
S.parse sequencedParser $ S.concatMap S.fromList (S.fromList ins)
return $
case outs of
Right x -> x == sum (map sum ins)
Left _ -> False
-------------------------------------------------------------------------------
-- Test for a particular case hit during fs events testing
-------------------------------------------------------------------------------
evId :: [Word8]
evId = [96,238,17,9,0,0,0,0]
evFlags :: [Word8]
evFlags = [0,4,1,0,0,0,0,0]
evPathLen :: [Word8]
evPathLen = [71,0,0,0,0,0,0,0]
evPath :: [Word8]
evPath =
[47,85,115,101,114,115,47,118,111,108,47,118,101,109,98,97,47,99,111,109
,112,111,115,101,119,101 ,108,108,45,116,101,99,104,47,69,110,103,47,112
,114,111,106,101,99,116,115,47,115,116,114,101,97,109,108,121,47,115,116
,114,101,97,109,108,121,47,116,109,112,47,122,122
]
event :: [Word8]
event = evId ++ evFlags ++ evPathLen ++ evPath
data Event = Event
{ eventId :: Word64
, eventFlags :: Word32
, eventAbsPath :: A.Array Word8
} deriving (Show, Ord, Eq)
readOneEvent :: P.Parser Word8 IO Event
readOneEvent = do
arr <- P.takeEQ 24 (A.createOf 24)
let arr1 = A.unsafeCast arr :: A.Array Word64
eid = A.unsafeGetIndex 0 arr1
eflags = A.unsafeGetIndex 1 arr1
pathLen = fromIntegral $ A.unsafeGetIndex 2 arr1
-- XXX handle if pathLen is 0
path <- P.takeEQ pathLen (A.createOf pathLen)
return $ Event
{ eventId = eid
, eventFlags = fromIntegral eflags
, eventAbsPath = path
}
parseMany2Events :: Property
parseMany2Events =
monadicIO $ do
xs <-
( run
$ S.fold FL.toList
$ S.catRights
$ S.parseMany readOneEvent
$ S.fromList (concat (replicate 2 event))
)
assert (length xs == 2)
-- XXX assuming little endian machine
let ev = Event
{ eventId = 152170080
, eventFlags = 66560
, eventAbsPath = A.fromList evPath
}
in listEquals (==) xs (replicate 2 ev)
--------------------------------------------------------------------------------
-- Parser sequence tests
--------------------------------------------------------------------------------
manyEqParseMany :: Property
manyEqParseMany =
forAll (listOf (chooseInt (0, 100))) $ \lst ->
forAll (chooseInt (1, 100)) $ \i ->
monadicIO $ do
let strm = S.fromList lst
r1 <- run $ S.parse (P.many (split i) FL.toList) strm
r2 <- run $ S.fold FL.toList $ S.catRights $ S.parseMany (split i) strm
return $
case r1 of
Right o1 -> o1 == r2
Left _ -> False
where
split i = P.fromFold (FL.take i FL.toList)
splitWithSuffix
:: Monad m
=> (a -> Bool) -> FL.Fold m a b -> S.Stream m a -> S.Stream m b
splitWithSuffix predicate f = S.foldMany (FL.takeEndBy predicate f)
takeEndBy2 :: Property
takeEndBy2 =
forAll (listOf (chooseInt (0, 1))) $ \ls ->
let
strm = S.fromList ls
predicate = (==0)
eitherParsedList =
S.fold FL.toList
$ S.catRights
$ S.parseMany (P.takeEndBy predicate prsr) strm
where
prsr = P.many (P.satisfy (const True)) FL.toList
eitherSplitList =
case ls of
[] -> return []
_ ->
if last ls == 0
then S.fold FL.toList $ S.append strm1 (S.fromList [])
else S.fold FL.toList strm1
where
strm1 = splitWithSuffix predicate FL.toList strm
in
case eitherParsedList of
Left _ -> property False
Right parsedList ->
case eitherSplitList of
Left _ -> property False
Right splitList -> checkListEqual parsedList splitList
--------------------------------------------------------------------------------
-- Parser quoted word tests
--------------------------------------------------------------------------------
quotedWordTest :: String -> [String] -> IO ()
quotedWordTest inp expected = do
res <-
S.fold FL.toList
$ catRightsErr
$ S.parseMany quotedWord $ S.fromList inp
res `shouldBe` expected
where
catRightsErr = fmap (either (error . displayException) id)
quotedWord =
let toRQuote x =
case x of
'"' -> Just x
'\'' -> Just x
_ -> Nothing
-- Inside ",
-- * \\ is translated to \
-- * \" is translated to "
trEsc '"' x =
case x of
'\\' -> Just '\\'
'"' -> Just '"'
_ -> Nothing
trEsc _ _ = Nothing
in P.wordWithQuotes False trEsc '\\' toRQuote isSpace FL.toList
--------------------------------------------------------------------------------
-- Parser sanity tests
--------------------------------------------------------------------------------
{-
TODO:
Add sanity tests for
- Producer.parse
- Producer.parseMany
-}
sanityParseBreak :: [Move] -> SpecWith ()
sanityParseBreak jumps = it (show jumps) $ do
(val, rest) <- SI.parseBreakPos (jumpParser jumps) $ S.fromList tape
lst <- S.toList rest
(val, lst) `shouldBe` (expectedResult jumps tape)
sanityParseDBreak :: [Move] -> SpecWith ()
sanityParseDBreak jumps = it (show jumps) $ do
(val, rest) <- K.parseBreakPos (PK.toParserK (jumpParser jumps)) $ K.fromList tape
lst <- K.toList rest
(val, lst) `shouldBe` (expectedResult jumps tape)
{-
sanityParseBreakChunksK :: [Move] -> SpecWith ()
sanityParseBreakChunksK jumps = it (show jumps) $ do
(val, rest) <-
A.parseBreakChunksK (jumpParser jumps)
$ K.fromList $ Prelude.map A.fromList chunkedTape
lst <- Prelude.map A.toList <$> K.toList rest
(val, concat lst) `shouldBe` (expectedResult jumps tape)
-}
sanityParseMany :: [Move] -> SpecWith ()
sanityParseMany jumps = it (show jumps) $ do
res <- S.toList $ SI.parseManyPos (jumpParser jumps) $ S.fromList tape
res `shouldBe` (expectedResultMany jumps tape)
sanityParseIterate :: [Move] -> SpecWith ()
sanityParseIterate jumps = it (show jumps) $ do
res <-
S.toList
$ SI.parseIteratePos (const (jumpParser jumps)) [] $ S.fromList tape
res `shouldBe` (expectedResultMany jumps tape)
-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------
{-# INLINE takeWhileFailD #-}
takeWhileFailD :: Monad m => (a -> Bool) -> Fold m a b -> Parser a m b
takeWhileFailD predicate (Fold fstep finitial _ ffinal) =
Parser step initial extract
where
initial = do
res <- finitial
return $ case res of
FL.Partial s -> IPartial s
FL.Done b -> IDone b
step s a =
if predicate a
then do
fres <- fstep s a
return
$ case fres of
FL.Partial s1 -> SContinue 1 s1
FL.Done b -> SDone 1 b
else return $ SError "fail"
extract s = fmap (FDone 0) (ffinal s)
{-# INLINE takeWhileFail #-}
takeWhileFail :: MonadIO m =>
(a -> Bool) -> Fold m a b -> PK.ParserK a m b
takeWhileFail p f = PK.toParserK (takeWhileFailD p f)
{-# INLINE takeWhileK #-}
takeWhileK :: MonadIO m => (a -> Bool) -> PK.ParserK a m [a]
takeWhileK p = PK.toParserK $ P.takeWhile p FL.toList
{-# INLINE alt2 #-}
alt2 :: MonadIO m => K.StreamK m Int -> m (Either ParseError [Int])
alt2 =
K.parse
( takeWhileFail (<= 5) FL.toList
<|> takeWhileK (<= 7)
)
{-# INLINE altD #-}
altD :: MonadIO m => S.Stream m Int -> m (Either P.ParseError [Int])
altD =
S.parse
( takeWhileFailD (<= 5) FL.toList
<|> P.takeWhile (<= 7) FL.toList
)
altTests :: Spec
altTests =
describe "alt" $ do
it "alt2 [1..20]" $ alt2 (K.fromList [1..20]) `shouldReturn` Right [1..7]
it "altD [1..20]" $ altD (S.fromList [1..20]) `shouldReturn` Right [1..7]
-------------------------------------------------------------------------------
-- Main
-------------------------------------------------------------------------------
moduleName :: String
moduleName = "Data.Parser"
main :: IO ()
main = do
hspec $
H.parallel $
modifyMaxSuccess (const maxTestCount) $ do
describe moduleName $ do
parserSanityTests "Stream.parseBreak" sanityParseBreak
parserSanityTests "StreamK.parseDBreak" sanityParseDBreak
-- parserSanityTests "A.sanityParseBreakChunksK" sanityParseBreakChunksK
parserSanityTests "Stream.parseMany" sanityParseMany
parserSanityTests "Stream.parseIterate" sanityParseIterate
describe "Stream parsing" $ do
prop "parseMany" parseMany
prop "parseMany2Events" parseMany2Events
prop "parseUnfold" parseUnfold
prop "parserSequence" parserSequence
describe "test for sequence parser" $ do
parseManyWordQuotedBy
prop "P.many == S.parseMany" manyEqParseMany
prop "takeEndBy2" takeEndBy2
describe "quotedWordTest" $ do
it "Single quote test" $ do
quotedWordTest "'hello\\\\\"world'" ["hello\\\\\"world"]
quotedWordTest "'hello\\'" ["hello\\"]
it "Double quote test" $ do
quotedWordTest
"\"hello\\\"\\\\w\\'orld\""
["hello\"\\w\\'orld"]
altTests
Common.main