Common.hs

{-# LANGUAGE CPP #-}

{-|
Description:    

Copyright:      (c) 2020 Samuel May
License:        MPL-2.0
Maintainer:     ag.eitilt@gmail.com

Stability:      experimental
Portability:    portable
-}
module Test.Willow.Property.Common
    ( Test
    , packGroup
    , packTest
    , genText
    , checkEndOfStream
    , checkInvalid
    , checkInvalidInit
    , checkInvalidAll
    , checkTrailing
    , checkTrailingInit
    , checkTrailingAll
#if MIN_VERSION_base(4,11,0)
#else
    , (<>)
#endif
    ) where


import qualified Data.ByteString as BS
import qualified Data.ByteString.Short as BS.SH
import qualified Data.String as S
import qualified Data.Text as T
import qualified Data.Word as W

import qualified Hedgehog as H
import qualified Hedgehog.Gen as H.G
import qualified Hedgehog.Range as H.R

import Web.Willow.Common.Encoding

import Hedgehog ( (===) )

#if MIN_VERSION_base(4,11,0)
#else
import Data.Semigroup ( (<>) )
#endif


type Test = (H.PropertyName, H.Property)


packGroup :: String -> [Test] -> H.Group
packGroup name tests = H.Group
    { H.groupName = S.fromString name
    , H.groupProperties = tests
    }

packTest :: String -> H.PropertyT IO () -> Test
packTest name prop = (S.fromString name, H.property prop)


genText :: H.Gen T.Text
genText = H.G.text (H.R.linear 0 64) (H.G.choice [H.G.latin1, H.G.unicode])


type CheckRightFunction
    = BS.ByteString
    -> DecoderState
    -> [Either BS.SH.ShortByteString String]
    -> H.PropertyT IO ()

type CheckLeftFunction
    = BS.SH.ShortByteString
    -> [W.Word8]
    -> BS.ByteString
    -> DecoderState
    -> [Either BS.SH.ShortByteString String]
    -> H.PropertyT IO ()

check :: CheckRightFunction -> CheckLeftFunction -> Encoding -> [W.Word8] -> H.PropertyT IO ()
check success failure enc char = do
    trail <- H.forAll . H.G.bytes $ H.R.linear 0 16
    let bs = BS.pack char <> trail
        (cs, state', bs') = decodeStep (initialDecoderState enc) bs
    case cs of
        Nothing -> H.footnote "decoder returned nothing"
        Just (Left err) -> failure err char trail state' $ finalize state' bs'
        _ -> success trail state' $ finalize state' bs'
    case finalizeDecode state' of
        [] -> return ()
        _ -> H.footnote "unexpected data in recovery"

finalize :: DecoderState -> BS.ByteString -> [Either BS.SH.ShortByteString String]
finalize state bs =
    let (cs, state') = decode state bs
    in  cs <> finalizeDecode state'

expectSuccess :: CheckRightFunction
expectSuccess trail state' bs' = bs' === finalize state' trail

expectFailure :: CheckRightFunction
expectFailure _ _ _ = H.footnote "unexpected parsed character"

error1 :: CheckLeftFunction
error1 err char trail state' bs' = do
    BS.SH.unpack err === take 1 char
    bs' === finalize state' trail'
  where trail' = BS.pack (drop 1 char) <> trail

errorInit :: Word -> CheckLeftFunction
errorInit l err char trail state' bs' = do
    BS.SH.unpack err === take l' char
    bs' === finalize state' trail'
  where l' = length char - fromIntegral l
        trail' = BS.pack (drop l' char) <> trail

errorAll :: CheckLeftFunction
errorAll err char trail state' bs' = do
    BS.SH.unpack err === char
    bs' === finalize state' trail


checkInvalid :: Encoding -> [W.Word8] -> H.PropertyT IO ()
checkInvalid = check expectFailure error1

checkInvalidInit :: Word -> Encoding -> [W.Word8] -> H.PropertyT IO ()
checkInvalidInit l = check expectFailure $ errorInit l

checkInvalidAll :: Encoding -> [W.Word8] -> H.PropertyT IO ()
checkInvalidAll = check expectFailure errorAll

checkTrailing :: Encoding -> [W.Word8] -> H.PropertyT IO ()
checkTrailing = check expectSuccess error1

checkTrailingInit :: Word -> Encoding -> [W.Word8] -> H.PropertyT IO ()
checkTrailingInit l = check expectSuccess $ errorInit l

checkTrailingAll :: Encoding -> [W.Word8] -> H.PropertyT IO ()
checkTrailingAll = check expectSuccess errorAll


checkEndOfStream :: Encoding -> [W.Word8] -> H.PropertyT IO ()
checkEndOfStream enc char = do
    bs <- H.forAll $ H.G.element
        [ take i char
        | i <- [1..length char]
        ]
    let (cs, state', bs') = decodeStep (initialDecoderState enc) $ BS.pack bs
    case cs of
        Nothing -> H.footnote "decoder returned nothing"
        Just (Right _) -> expectFailure BS.empty state' []
        _ | not (BS.null bs') -> H.footnote "stream not completely consumed"
        _ -> return ()
    case finalizeDecode state' of
        [] -> H.footnote "no character fallback recovered"
        [Left err] -> err === BS.SH.pack bs
        [Right _] -> expectFailure BS.empty state' []
        _ -> H.footnote "unexpected trailing data in recovery"