{-# Language CPP #-}
{-# Language DerivingVia #-}
{-# Language FlexibleContexts #-}
{-# Language LambdaCase #-}
{-# Language ScopedTypeVariables #-}
{-# Language TupleSections #-}
{-# Language TypeApplications #-}
module Test.Parsable
(
ParseCoverage(..)
, parsableQuickCheck
, parsableProp
, wordGen
, parsableHUnit
, printableHUnit
, parsableAssertion
, printableAssertion
, runCheckParsable
, checkParsable
, checkCoverage
, ParseError
, module Control.Monad.STM
, module Data.Void
) where
import Control.Monad.STM
import Control.Concurrent.STM.TChan
import Data.Function (fix)
import Data.Semigroup (Last(..))
import Data.Typeable
import Data.Void
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck hiding (checkCoverage)
import Data.Parsable hiding (label)
data ParseCoverage
= PartialParse String
| CompleteParse
deriving stock (Int -> ParseCoverage -> ShowS
[ParseCoverage] -> ShowS
ParseCoverage -> String
(Int -> ParseCoverage -> ShowS)
-> (ParseCoverage -> String)
-> ([ParseCoverage] -> ShowS)
-> Show ParseCoverage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseCoverage -> ShowS
showsPrec :: Int -> ParseCoverage -> ShowS
$cshow :: ParseCoverage -> String
show :: ParseCoverage -> String
$cshowList :: [ParseCoverage] -> ShowS
showList :: [ParseCoverage] -> ShowS
Show, ParseCoverage -> ParseCoverage -> Bool
(ParseCoverage -> ParseCoverage -> Bool)
-> (ParseCoverage -> ParseCoverage -> Bool) -> Eq ParseCoverage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParseCoverage -> ParseCoverage -> Bool
== :: ParseCoverage -> ParseCoverage -> Bool
$c/= :: ParseCoverage -> ParseCoverage -> Bool
/= :: ParseCoverage -> ParseCoverage -> Bool
Eq, Eq ParseCoverage
Eq ParseCoverage =>
(ParseCoverage -> ParseCoverage -> Ordering)
-> (ParseCoverage -> ParseCoverage -> Bool)
-> (ParseCoverage -> ParseCoverage -> Bool)
-> (ParseCoverage -> ParseCoverage -> Bool)
-> (ParseCoverage -> ParseCoverage -> Bool)
-> (ParseCoverage -> ParseCoverage -> ParseCoverage)
-> (ParseCoverage -> ParseCoverage -> ParseCoverage)
-> Ord ParseCoverage
ParseCoverage -> ParseCoverage -> Bool
ParseCoverage -> ParseCoverage -> Ordering
ParseCoverage -> ParseCoverage -> ParseCoverage
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ParseCoverage -> ParseCoverage -> Ordering
compare :: ParseCoverage -> ParseCoverage -> Ordering
$c< :: ParseCoverage -> ParseCoverage -> Bool
< :: ParseCoverage -> ParseCoverage -> Bool
$c<= :: ParseCoverage -> ParseCoverage -> Bool
<= :: ParseCoverage -> ParseCoverage -> Bool
$c> :: ParseCoverage -> ParseCoverage -> Bool
> :: ParseCoverage -> ParseCoverage -> Bool
$c>= :: ParseCoverage -> ParseCoverage -> Bool
>= :: ParseCoverage -> ParseCoverage -> Bool
$cmax :: ParseCoverage -> ParseCoverage -> ParseCoverage
max :: ParseCoverage -> ParseCoverage -> ParseCoverage
$cmin :: ParseCoverage -> ParseCoverage -> ParseCoverage
min :: ParseCoverage -> ParseCoverage -> ParseCoverage
Ord)
deriving NonEmpty ParseCoverage -> ParseCoverage
ParseCoverage -> ParseCoverage -> ParseCoverage
(ParseCoverage -> ParseCoverage -> ParseCoverage)
-> (NonEmpty ParseCoverage -> ParseCoverage)
-> (forall b. Integral b => b -> ParseCoverage -> ParseCoverage)
-> Semigroup ParseCoverage
forall b. Integral b => b -> ParseCoverage -> ParseCoverage
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: ParseCoverage -> ParseCoverage -> ParseCoverage
<> :: ParseCoverage -> ParseCoverage -> ParseCoverage
$csconcat :: NonEmpty ParseCoverage -> ParseCoverage
sconcat :: NonEmpty ParseCoverage -> ParseCoverage
$cstimes :: forall b. Integral b => b -> ParseCoverage -> ParseCoverage
stimes :: forall b. Integral b => b -> ParseCoverage -> ParseCoverage
Semigroup via Last ParseCoverage
parsableQuickCheck :: forall proxy a.
( Parsable a Identity () String
, Printable a
, Arbitrary a
, Eq a
, Show a
, Typeable a
) => proxy a -> STM TestTree
parsableQuickCheck :: forall (proxy :: * -> *) a.
(Parsable a Identity () String, Printable a, Arbitrary a, Eq a,
Show a, Typeable a) =>
proxy a -> STM TestTree
parsableQuickCheck proxy a
p = do
TChan ParseError
c <- STM (TChan ParseError)
forall a. STM (TChan a)
newTChan
TestTree -> STM TestTree
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestTree -> STM TestTree) -> TestTree -> STM TestTree
forall a b. (a -> b) -> a -> b
$ String -> [TestTree] -> TestTree
testGroup (TypeRep -> String
forall a. Show a => a -> String
show (proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep proxy a
p))
[ String -> (a -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"parsableProp" (forall a.
(Parsable a Identity () String, Printable a, Eq a, Show a) =>
TChan ParseError -> a -> Property
parsableProp @a TChan ParseError
c)
]
parsableProp :: forall a.
( Parsable a Identity () String
, Printable a
, Eq a
, Show a
) => TChan ParseError -> a -> Property
parsableProp :: forall a.
(Parsable a Identity () String, Printable a, Eq a, Show a) =>
TChan ParseError -> a -> Property
parsableProp TChan ParseError
c a
x = IO () -> Property -> Property
forall prop. Testable prop => IO () -> prop -> Property
whenFail (TChan ParseError -> IO ()
printErrorTChan TChan ParseError
c) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ IO Property -> Property
forall prop. Testable prop => IO prop -> Property
idempotentIOProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$ do
let s :: String
s = a -> String
forall t. Printable t => t -> String
toString a
x
let r :: Either ParseError (ParseCoverage, a)
r = forall a.
Parsable a Identity () String =>
String -> Either ParseError (ParseCoverage, a)
runCheckParsable @a String
s
()
_ <- (ParseError -> IO ())
-> ((ParseCoverage, a) -> IO ())
-> Either ParseError (ParseCoverage, a)
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (ParseError -> STM ()) -> ParseError -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TChan ParseError -> ParseError -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan ParseError
c) (IO () -> (ParseCoverage, a) -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) Either ParseError (ParseCoverage, a)
r
#if defined(VERBOSE_TESTS)
pure $ label s $ r === Right (CompleteParse, x)
#else
Property -> IO Property
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Property -> IO Property) -> Property -> IO Property
forall a b. (a -> b) -> a -> b
$ Either ParseError (ParseCoverage, a)
r Either ParseError (ParseCoverage, a)
-> Either ParseError (ParseCoverage, a) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== (ParseCoverage, a) -> Either ParseError (ParseCoverage, a)
forall a b. b -> Either a b
Right (ParseCoverage
CompleteParse, a
x)
#endif
parsableHUnit :: forall proxy a.
( Parsable a Identity () String
, Printable a
, Show a
) => proxy a -> String -> TestTree
parsableHUnit :: forall (proxy :: * -> *) a.
(Parsable a Identity () String, Printable a, Show a) =>
proxy a -> String -> TestTree
parsableHUnit proxy a
p String
str = String -> IO () -> TestTree
testCase (ShowS
forall a. Show a => a -> String
show String
str) (IO () -> TestTree) -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ proxy a -> String -> IO ()
forall (proxy :: * -> *) a.
(Parsable a Identity () String, Printable a, Show a) =>
proxy a -> String -> IO ()
parsableAssertion proxy a
p String
str
printableHUnit :: forall a.
( Parsable a Identity () String
, Printable a
, Show a
, Eq a) => a -> TestTree
printableHUnit :: forall a.
(Parsable a Identity () String, Printable a, Show a, Eq a) =>
a -> TestTree
printableHUnit a
x = String -> IO () -> TestTree
testCase (ShowS
forall a. Show a => a -> String
show String
str) (IO () -> TestTree) -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
Proxy a -> String -> IO ()
forall (proxy :: * -> *) a.
(Parsable a Identity () String, Printable a, Show a) =>
proxy a -> String -> IO ()
parsableAssertion (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) String
str
a -> IO ()
forall a.
(Parsable a Identity () String, Printable a, Show a, Eq a) =>
a -> IO ()
printableAssertion a
x
where str :: String
str = a -> String
forall t. Printable t => t -> String
toString a
x
parsableAssertion :: forall proxy a.
( Parsable a Identity () String
, Printable a
, Show a
) => proxy a -> String -> Assertion
parsableAssertion :: forall (proxy :: * -> *) a.
(Parsable a Identity () String, Printable a, Show a) =>
proxy a -> String -> IO ()
parsableAssertion proxy a
_ String
s = case forall a.
Parsable a Identity () String =>
String -> Either ParseError (ParseCoverage, a)
runCheckParsable @a String
s of
Left ParseError
e ->
String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Could not parse: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Error:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
e
Right p :: (ParseCoverage, a)
p@(PartialParse String
_, a
_) ->
String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Got a PartialParse when it should be a CompleteParse:\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Output: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ParseCoverage, a) -> String
forall a. Show a => a -> String
show (ParseCoverage, a)
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
Right (ParseCoverage
CompleteParse, a
x) ->
String -> String -> String -> IO ()
forall a. (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()
assertEqual String
"resulting string equals original" (a -> String
forall t. Printable t => t -> String
toString a
x) String
s
printableAssertion :: forall a.
( Parsable a Identity () String
, Printable a
, Show a
, Eq a
) => a -> Assertion
printableAssertion :: forall a.
(Parsable a Identity () String, Printable a, Show a, Eq a) =>
a -> IO ()
printableAssertion a
x = (a -> IO ()) -> Either ParseError (ParseCoverage, a) -> IO ()
forall a.
Show a =>
(a -> IO ()) -> Either ParseError (ParseCoverage, a) -> IO ()
ppAssertion a -> IO ()
f (Either ParseError (ParseCoverage, a) -> IO ())
-> Either ParseError (ParseCoverage, a) -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Either ParseError (ParseCoverage, a)
forall a.
Parsable a Identity () String =>
String -> Either ParseError (ParseCoverage, a)
runCheckParsable (a -> String
forall t. Printable t => t -> String
toString a
x)
where f :: a -> IO ()
f = String -> a -> a -> IO ()
forall a. (Eq a, Show a, HasCallStack) => String -> a -> a -> IO ()
assertEqual String
"parse result equals original" a
x
ppAssertion ::
( Show a
) => (a -> Assertion)
-> Either ParseError (ParseCoverage, a)
-> Assertion
ppAssertion :: forall a.
Show a =>
(a -> IO ()) -> Either ParseError (ParseCoverage, a) -> IO ()
ppAssertion a -> IO ()
f = \case
Left ParseError
e ->
String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Could not parse input string:\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Error:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
e
Right p :: (ParseCoverage, a)
p@(PartialParse String
_, a
_) ->
String -> IO ()
forall a. HasCallStack => String -> IO a
assertFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
String
"Got a PartialParse when it should be a CompleteParse:\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Output: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (ParseCoverage, a) -> String
forall a. Show a => a -> String
show (ParseCoverage, a)
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
Right (ParseCoverage
CompleteParse, a
x) -> a -> IO ()
f a
x
runCheckParsable
:: Parsable a Identity () String
=> String
-> Either ParseError (ParseCoverage, a)
runCheckParsable :: forall a.
Parsable a Identity () String =>
String -> Either ParseError (ParseCoverage, a)
runCheckParsable = Parsec String () (ParseCoverage, a)
-> () -> String -> String -> Either ParseError (ParseCoverage, a)
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser Parsec String () (ParseCoverage, a)
forall a s u (m :: * -> *).
(Stream s m Char, Parsable a m u s) =>
ParsecT s u m (ParseCoverage, a)
checkParsable () String
""
checkParsable
:: forall a s u m
. (Stream s m Char, Parsable a m u s)
=> ParsecT s u m (ParseCoverage, a)
checkParsable :: forall a s u (m :: * -> *).
(Stream s m Char, Parsable a m u s) =>
ParsecT s u m (ParseCoverage, a)
checkParsable = ParsecT s u m a -> ParsecT s u m (ParseCoverage, a)
forall s (m :: * -> *) u a.
Stream s m Char =>
ParsecT s u m a -> ParsecT s u m (ParseCoverage, a)
checkCoverage (ParsecT s u m a
forall a (m :: * -> *) u s. Parsable a m u s => ParsecT s u m a
parser ParsecT s u m a -> String -> ParsecT s u m a
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
n)
where n :: String
n = ParserName a s u m -> String
forall a s u (m :: * -> *). ParserName a s u m -> String
getParserName (ParserName a s u m -> String) -> ParserName a s u m -> String
forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *) u s. Parsable a m u s => ParserName a s u m
parserName @a @m @u @s
checkCoverage
:: Stream s m Char
=> ParsecT s u m a
-> ParsecT s u m (ParseCoverage, a)
checkCoverage :: forall s (m :: * -> *) u a.
Stream s m Char =>
ParsecT s u m a -> ParsecT s u m (ParseCoverage, a)
checkCoverage ParsecT s u m a
p = do
a
x <- ParsecT s u m a
p
(,a
x) (ParseCoverage -> (ParseCoverage, a))
-> ParsecT s u m ParseCoverage -> ParsecT s u m (ParseCoverage, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParsecT s u m ParseCoverage] -> ParsecT s u m ParseCoverage
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice
[ ParseCoverage
CompleteParse ParseCoverage -> ParsecT s u m () -> ParsecT s u m ParseCoverage
forall a b. a -> ParsecT s u m b -> ParsecT s u m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT s u m ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
, String -> ParseCoverage
PartialParse (String -> ParseCoverage)
-> ParsecT s u m String -> ParsecT s u m ParseCoverage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT s u m String -> ParsecT s u m String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead (ParsecT s u m Char
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m t
anyToken ParsecT s u m Char -> ParsecT s u m () -> ParsecT s u m String
forall s (m :: * -> *) t u a end.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
`manyTill` ParsecT s u m ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof)
]
wordGen :: [Char -> Bool] -> [Char -> Bool] -> Gen String
wordGen :: [Char -> Bool] -> [Char -> Bool] -> Gen String
wordGen [Char -> Bool]
wordStart [Char -> Bool]
wordRest = do
Char
c <- Gen Char
forall a. Arbitrary a => Gen a
arbitrary Gen Char -> (Char -> Bool) -> Gen Char
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` [Char -> Bool] -> Char -> Bool
anySat [Char -> Bool]
wordStart
String
cs <- Gen Char -> Gen String
forall a. Gen a -> Gen [a]
listOf (Gen Char -> Gen String) -> Gen Char -> Gen String
forall a b. (a -> b) -> a -> b
$ Gen Char
forall a. Arbitrary a => Gen a
arbitrary Gen Char -> (Char -> Bool) -> Gen Char
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` [Char -> Bool] -> Char -> Bool
anySat [Char -> Bool]
wordRest
String -> Gen String
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Gen String) -> String -> Gen String
forall a b. (a -> b) -> a -> b
$ Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs
where
anySat :: [Char -> Bool] -> Char -> Bool
anySat :: [Char -> Bool] -> Char -> Bool
anySat [Char -> Bool]
l Char
x = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Char -> Bool
f Char
x | Char -> Bool
f <- [Char -> Bool]
l]
printErrorTChan :: TChan ParseError -> IO ()
printErrorTChan :: TChan ParseError -> IO ()
printErrorTChan TChan ParseError
c = (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
Maybe ParseError
me <- STM (Maybe ParseError) -> IO (Maybe ParseError)
forall a. STM a -> IO a
atomically (STM (Maybe ParseError) -> IO (Maybe ParseError))
-> STM (Maybe ParseError) -> IO (Maybe ParseError)
forall a b. (a -> b) -> a -> b
$ TChan ParseError -> STM (Maybe ParseError)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan ParseError
c
case Maybe ParseError
me of
Just ParseError
e -> String -> IO ()
putStrLn (ParseError -> String
forall a. Show a => a -> String
show ParseError
e) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IO ()
loop
Maybe ParseError
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()