-- editorconfig-checker-disable-file
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE TypeOperators     #-}

-- | UPLC property tests (pretty-printing\/parsing and binary encoding\/decoding).
module Generators where

import PlutusPrelude (display, fold, on, void, zipExact, (&&&))

import PlutusCore (Name, _nameText)
import PlutusCore.Annotation
import PlutusCore.Compiler.Erase (eraseProgram, eraseTerm)
import PlutusCore.Default (Closed, DefaultFun, DefaultUni, Everywhere, GEq)
import PlutusCore.Error (ParserErrorBundle)
import PlutusCore.Generators.Hedgehog (forAllPretty)
import PlutusCore.Generators.Hedgehog.AST (AstGen, runAstGen)
import PlutusCore.Generators.Hedgehog.AST qualified as AST
import PlutusCore.Parser (defaultUni, parseGen)
import PlutusCore.Pretty (displayPlc)
import PlutusCore.Quote (QuoteT, runQuoteT)
import PlutusCore.Test (isSerialisable)
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Core.Type (Program (Program), Term (..), progTerm, termAnn)
import UntypedPlutusCore.Generators.Hedgehog (discardIfAnyConstant)
import UntypedPlutusCore.Parser (parseProgram, parseTerm)

import Control.Lens (view)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Vector qualified as V

import Hedgehog (annotate, annotateShow, failure, property, tripping, (===))
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testPropertyNamed)
import Test.Tasty.HUnit (testCase, (@?=))

import Flat qualified

-- | A 'Program' which we compare using textual equality of names rather than alpha-equivalence.
newtype TextualProgram a = TextualProgram
    { forall a. TextualProgram a -> Program Name DefaultUni DefaultFun a
unTextualProgram :: Program Name DefaultUni DefaultFun a
    } deriving stock Int -> TextualProgram a -> ShowS
[TextualProgram a] -> ShowS
TextualProgram a -> [Char]
(Int -> TextualProgram a -> ShowS)
-> (TextualProgram a -> [Char])
-> ([TextualProgram a] -> ShowS)
-> Show (TextualProgram a)
forall a. Show a => Int -> TextualProgram a -> ShowS
forall a. Show a => [TextualProgram a] -> ShowS
forall a. Show a => TextualProgram a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> TextualProgram a -> ShowS
showsPrec :: Int -> TextualProgram a -> ShowS
$cshow :: forall a. Show a => TextualProgram a -> [Char]
show :: TextualProgram a -> [Char]
$cshowList :: forall a. Show a => [TextualProgram a] -> ShowS
showList :: [TextualProgram a] -> ShowS
Show

instance Eq a => Eq (TextualProgram a) where
    (TextualProgram Program Name DefaultUni DefaultFun a
p1) == :: TextualProgram a -> TextualProgram a -> Bool
== (TextualProgram Program Name DefaultUni DefaultFun a
p2) = Program Name DefaultUni DefaultFun a
-> Program Name DefaultUni DefaultFun a -> Bool
forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Program Name uni fun a -> Program Name uni fun a -> Bool
compareProgram Program Name DefaultUni DefaultFun a
p1 Program Name DefaultUni DefaultFun a
p2

compareName :: Name -> Name -> Bool
compareName :: Name -> Name -> Bool
compareName = Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Text -> Text -> Bool) -> (Name -> Text) -> Name -> Name -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Name -> Text
_nameText

compareTerm
    :: (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq a)
    => Term Name uni fun a -> Term Name uni fun a -> Bool
compareTerm :: forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Term Name uni fun a -> Term Name uni fun a -> Bool
compareTerm (Var a
_ Name
n) (Var a
_ Name
n')              = Name -> Name -> Bool
compareName Name
n Name
n'
compareTerm (LamAbs a
_ Name
n Term Name uni fun a
t) (LamAbs a
_ Name
n' Term Name uni fun a
t')   = Name -> Name -> Bool
compareName Name
n Name
n' Bool -> Bool -> Bool
&& Term Name uni fun a -> Term Name uni fun a -> Bool
forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Term Name uni fun a -> Term Name uni fun a -> Bool
compareTerm Term Name uni fun a
t Term Name uni fun a
t'
compareTerm (Apply a
_ Term Name uni fun a
t Term Name uni fun a
t'') (Apply a
_ Term Name uni fun a
t' Term Name uni fun a
t''') = Term Name uni fun a -> Term Name uni fun a -> Bool
forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Term Name uni fun a -> Term Name uni fun a -> Bool
compareTerm Term Name uni fun a
t Term Name uni fun a
t' Bool -> Bool -> Bool
&& Term Name uni fun a -> Term Name uni fun a -> Bool
forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Term Name uni fun a -> Term Name uni fun a -> Bool
compareTerm Term Name uni fun a
t'' Term Name uni fun a
t'''
compareTerm (Force a
_ Term Name uni fun a
t ) (Force a
_ Term Name uni fun a
t')         = Term Name uni fun a -> Term Name uni fun a -> Bool
forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Term Name uni fun a -> Term Name uni fun a -> Bool
compareTerm Term Name uni fun a
t Term Name uni fun a
t'
compareTerm (Delay a
_ Term Name uni fun a
t ) (Delay a
_ Term Name uni fun a
t')         = Term Name uni fun a -> Term Name uni fun a -> Bool
forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Term Name uni fun a -> Term Name uni fun a -> Bool
compareTerm Term Name uni fun a
t Term Name uni fun a
t'
compareTerm (Constant a
_ Some (ValueOf uni)
x) (Constant a
_ Some (ValueOf uni)
y)     = Some (ValueOf uni)
x Some (ValueOf uni) -> Some (ValueOf uni) -> Bool
forall a. Eq a => a -> a -> Bool
== Some (ValueOf uni)
y
compareTerm (Builtin a
_ fun
bi) (Builtin a
_ fun
bi')    = fun
bi fun -> fun -> Bool
forall a. Eq a => a -> a -> Bool
== fun
bi'
compareTerm (Constr a
_ Word64
i [Term Name uni fun a]
es) (Constr a
_ Word64
i' [Term Name uni fun a]
es') = Word64
i Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
i' Bool -> Bool -> Bool
&& Bool
-> ([(Term Name uni fun a, Term Name uni fun a)] -> Bool)
-> Maybe [(Term Name uni fun a, Term Name uni fun a)]
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (((Term Name uni fun a, Term Name uni fun a) -> Bool)
-> [(Term Name uni fun a, Term Name uni fun a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Term Name uni fun a -> Term Name uni fun a -> Bool)
-> (Term Name uni fun a, Term Name uni fun a) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Term Name uni fun a -> Term Name uni fun a -> Bool
forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Term Name uni fun a -> Term Name uni fun a -> Bool
compareTerm)) ([Term Name uni fun a]
-> [Term Name uni fun a]
-> Maybe [(Term Name uni fun a, Term Name uni fun a)]
forall a b. [a] -> [b] -> Maybe [(a, b)]
zipExact [Term Name uni fun a]
es [Term Name uni fun a]
es')
compareTerm (Case a
_ Term Name uni fun a
arg Vector (Term Name uni fun a)
cs) (Case a
_ Term Name uni fun a
arg' Vector (Term Name uni fun a)
cs') = Term Name uni fun a -> Term Name uni fun a -> Bool
forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Term Name uni fun a -> Term Name uni fun a -> Bool
compareTerm Term Name uni fun a
arg Term Name uni fun a
arg' Bool -> Bool -> Bool
&& Bool
-> ([(Term Name uni fun a, Term Name uni fun a)] -> Bool)
-> Maybe [(Term Name uni fun a, Term Name uni fun a)]
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (((Term Name uni fun a, Term Name uni fun a) -> Bool)
-> [(Term Name uni fun a, Term Name uni fun a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Term Name uni fun a -> Term Name uni fun a -> Bool)
-> (Term Name uni fun a, Term Name uni fun a) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Term Name uni fun a -> Term Name uni fun a -> Bool
forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Term Name uni fun a -> Term Name uni fun a -> Bool
compareTerm)) ([Term Name uni fun a]
-> [Term Name uni fun a]
-> Maybe [(Term Name uni fun a, Term Name uni fun a)]
forall a b. [a] -> [b] -> Maybe [(a, b)]
zipExact (Vector (Term Name uni fun a) -> [Term Name uni fun a]
forall a. Vector a -> [a]
V.toList Vector (Term Name uni fun a)
cs) (Vector (Term Name uni fun a) -> [Term Name uni fun a]
forall a. Vector a -> [a]
V.toList Vector (Term Name uni fun a)
cs'))
compareTerm (Error a
_ ) (Error a
_ )             = Bool
True
compareTerm Term Name uni fun a
_ Term Name uni fun a
_                               = Bool
False

compareProgram
    :: (GEq uni, Closed uni, uni `Everywhere` Eq, Eq fun, Eq a)
    => Program Name uni fun a -> Program Name uni fun a -> Bool
compareProgram :: forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Program Name uni fun a -> Program Name uni fun a -> Bool
compareProgram (Program a
_ Version
v Term Name uni fun a
t) (Program a
_ Version
v' Term Name uni fun a
t') = Version
v Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
v' Bool -> Bool -> Bool
&& Term Name uni fun a -> Term Name uni fun a -> Bool
forall (uni :: * -> *) fun a.
(GEq uni, Closed uni, Everywhere uni Eq, Eq fun, Eq a) =>
Term Name uni fun a -> Term Name uni fun a -> Bool
compareTerm Term Name uni fun a
t Term Name uni fun a
t'

genTerm :: forall fun. (Bounded fun, Enum fun) => AstGen (Term Name DefaultUni fun ())
genTerm :: forall fun.
(Bounded fun, Enum fun) =>
AstGen (Term Name DefaultUni fun ())
genTerm = (Term TyName Name DefaultUni fun () -> Term Name DefaultUni fun ())
-> GenT (Reader [Name]) (Term TyName Name DefaultUni fun ())
-> GenT (Reader [Name]) (Term Name DefaultUni fun ())
forall a b.
(a -> b) -> GenT (Reader [Name]) a -> GenT (Reader [Name]) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term TyName Name DefaultUni fun () -> Term Name DefaultUni fun ()
forall name tyname (uni :: * -> *) fun ann.
HasUnique name TermUnique =>
Term tyname name uni fun ann -> Term name uni fun ann
eraseTerm GenT (Reader [Name]) (Term TyName Name DefaultUni fun ())
forall fun.
(Bounded fun, Enum fun) =>
AstGen (Term TyName Name DefaultUni fun ())
AST.genTerm

genProgram :: forall fun. (Bounded fun, Enum fun) => AstGen (Program Name DefaultUni fun ())
genProgram :: forall fun.
(Bounded fun, Enum fun) =>
AstGen (Program Name DefaultUni fun ())
genProgram = (Program TyName Name DefaultUni fun ()
 -> Program Name DefaultUni fun ())
-> GenT (Reader [Name]) (Program TyName Name DefaultUni fun ())
-> GenT (Reader [Name]) (Program Name DefaultUni fun ())
forall a b.
(a -> b) -> GenT (Reader [Name]) a -> GenT (Reader [Name]) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Program TyName Name DefaultUni fun ()
-> Program Name DefaultUni fun ()
forall name tyname (uni :: * -> *) fun ann.
HasUnique name TermUnique =>
Program tyname name uni fun ann -> Program name uni fun ann
eraseProgram GenT (Reader [Name]) (Program TyName Name DefaultUni fun ())
forall fun.
(Bounded fun, Enum fun) =>
AstGen (Program TyName Name DefaultUni fun ())
AST.genProgram

propFlat :: TestTree
propFlat :: TestTree
propFlat = [Char] -> PropertyName -> Property -> TestTree
testPropertyNamed [Char]
"Flat" PropertyName
"Flat" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
    Program Name DefaultUni DefaultFun ()
prog <- Gen (Program Name DefaultUni DefaultFun ())
-> PropertyT IO (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) a.
(Monad m, Pretty a) =>
Gen a -> PropertyT m a
forAllPretty (Gen (Program Name DefaultUni DefaultFun ())
 -> PropertyT IO (Program Name DefaultUni DefaultFun ()))
-> (AstGen (Program Name DefaultUni DefaultFun ())
    -> Gen (Program Name DefaultUni DefaultFun ()))
-> AstGen (Program Name DefaultUni DefaultFun ())
-> PropertyT IO (Program Name DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AstGen (Program Name DefaultUni DefaultFun ())
-> Gen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) a. MonadGen m => AstGen a -> m a
runAstGen (AstGen (Program Name DefaultUni DefaultFun ())
 -> PropertyT IO (Program Name DefaultUni DefaultFun ()))
-> AstGen (Program Name DefaultUni DefaultFun ())
-> PropertyT IO (Program Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$
        (Some (ValueOf DefaultUni) -> Bool)
-> AstGen (Program Name DefaultUni DefaultFun ())
-> AstGen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) (uni :: * -> *) name fun ann.
MonadGen m =>
(Some (ValueOf uni) -> Bool)
-> m (Program name uni fun ann) -> m (Program name uni fun ann)
discardIfAnyConstant (Bool -> Bool
not (Bool -> Bool)
-> (Some (ValueOf DefaultUni) -> Bool)
-> Some (ValueOf DefaultUni)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Some (ValueOf DefaultUni) -> Bool
isSerialisable) (AstGen (Program Name DefaultUni DefaultFun ())
 -> AstGen (Program Name DefaultUni DefaultFun ()))
-> AstGen (Program Name DefaultUni DefaultFun ())
-> AstGen (Program Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ forall fun.
(Bounded fun, Enum fun) =>
AstGen (Program Name DefaultUni fun ())
Generators.genProgram @DefaultFun
    Program Name DefaultUni DefaultFun ()
-> (Program Name DefaultUni DefaultFun () -> ByteString)
-> (ByteString
    -> Either DecodeException (Program Name DefaultUni DefaultFun ()))
-> PropertyT IO ()
forall (m :: * -> *) (f :: * -> *) b a.
(MonadTest m, Applicative f, Show b, Show (f a), Eq (f a),
 HasCallStack) =>
a -> (a -> b) -> (b -> f a) -> m ()
tripping Program Name DefaultUni DefaultFun ()
prog (UnrestrictedProgram Name DefaultUni DefaultFun () -> ByteString
forall a. Flat a => a -> ByteString
Flat.flat (UnrestrictedProgram Name DefaultUni DefaultFun () -> ByteString)
-> (Program Name DefaultUni DefaultFun ()
    -> UnrestrictedProgram Name DefaultUni DefaultFun ())
-> Program Name DefaultUni DefaultFun ()
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program Name DefaultUni DefaultFun ()
-> UnrestrictedProgram Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> UnrestrictedProgram name uni fun ann
UPLC.UnrestrictedProgram) ((UnrestrictedProgram Name DefaultUni DefaultFun ()
 -> Program Name DefaultUni DefaultFun ())
-> Either
     DecodeException (UnrestrictedProgram Name DefaultUni DefaultFun ())
-> Either DecodeException (Program Name DefaultUni DefaultFun ())
forall a b.
(a -> b) -> Either DecodeException a -> Either DecodeException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnrestrictedProgram Name DefaultUni DefaultFun ()
-> Program Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
UnrestrictedProgram name uni fun ann -> Program name uni fun ann
UPLC.unUnrestrictedProgram (Either
   DecodeException (UnrestrictedProgram Name DefaultUni DefaultFun ())
 -> Either DecodeException (Program Name DefaultUni DefaultFun ()))
-> (ByteString
    -> Either
         DecodeException
         (UnrestrictedProgram Name DefaultUni DefaultFun ()))
-> ByteString
-> Either DecodeException (Program Name DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString
-> Either
     DecodeException (UnrestrictedProgram Name DefaultUni DefaultFun ())
forall a b. (Flat a, AsByteString b) => b -> Decoded a
Flat.unflat)

propParser :: TestTree
propParser :: TestTree
propParser = [Char] -> PropertyName -> Property -> TestTree
testPropertyNamed [Char]
"Parser" PropertyName
"parser" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$ HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$ do
    TextualProgram ()
prog <- Program Name DefaultUni DefaultFun () -> TextualProgram ()
forall a. Program Name DefaultUni DefaultFun a -> TextualProgram a
TextualProgram (Program Name DefaultUni DefaultFun () -> TextualProgram ())
-> PropertyT IO (Program Name DefaultUni DefaultFun ())
-> PropertyT IO (TextualProgram ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        Gen (Program Name DefaultUni DefaultFun ())
-> PropertyT IO (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) a.
(Monad m, Pretty a) =>
Gen a -> PropertyT m a
forAllPretty (AstGen (Program Name DefaultUni DefaultFun ())
-> Gen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) a. MonadGen m => AstGen a -> m a
runAstGen (AstGen (Program Name DefaultUni DefaultFun ())
 -> Gen (Program Name DefaultUni DefaultFun ()))
-> AstGen (Program Name DefaultUni DefaultFun ())
-> Gen (Program Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ (Some (ValueOf DefaultUni) -> Bool)
-> AstGen (Program Name DefaultUni DefaultFun ())
-> AstGen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) (uni :: * -> *) name fun ann.
MonadGen m =>
(Some (ValueOf uni) -> Bool)
-> m (Program name uni fun ann) -> m (Program name uni fun ann)
discardIfAnyConstant (Bool -> Bool
not (Bool -> Bool)
-> (Some (ValueOf DefaultUni) -> Bool)
-> Some (ValueOf DefaultUni)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Some (ValueOf DefaultUni) -> Bool
isSerialisable) AstGen (Program Name DefaultUni DefaultFun ())
forall fun.
(Bounded fun, Enum fun) =>
AstGen (Program Name DefaultUni fun ())
Generators.genProgram)
    TextualProgram ()
-> (TextualProgram () -> Text)
-> (Text -> Either ParserErrorBundle (TextualProgram ()))
-> PropertyT IO ()
forall (m :: * -> *) (f :: * -> *) b a.
(MonadTest m, Applicative f, Show b, Show (f a), Eq (f a),
 HasCallStack) =>
a -> (a -> b) -> (b -> f a) -> m ()
tripping TextualProgram ()
prog (Program Name DefaultUni DefaultFun () -> Text
forall a str. (PrettyPlc a, Render str) => a -> str
displayPlc (Program Name DefaultUni DefaultFun () -> Text)
-> (TextualProgram () -> Program Name DefaultUni DefaultFun ())
-> TextualProgram ()
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextualProgram () -> Program Name DefaultUni DefaultFun ()
forall a. TextualProgram a -> Program Name DefaultUni DefaultFun a
unTextualProgram)
                (\Text
p -> (Program Name DefaultUni DefaultFun SrcSpan -> TextualProgram ())
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
-> Either ParserErrorBundle (TextualProgram ())
forall a b.
(a -> b)
-> Either ParserErrorBundle a -> Either ParserErrorBundle b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Program Name DefaultUni DefaultFun () -> TextualProgram ()
forall a. Program Name DefaultUni DefaultFun a -> TextualProgram a
TextualProgram (Program Name DefaultUni DefaultFun () -> TextualProgram ())
-> (Program Name DefaultUni DefaultFun SrcSpan
    -> Program Name DefaultUni DefaultFun ())
-> Program Name DefaultUni DefaultFun SrcSpan
-> TextualProgram ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program Name DefaultUni DefaultFun SrcSpan
-> Program Name DefaultUni DefaultFun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void) (Text
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
parseProg Text
p))
    where
        parseProg
            :: T.Text -> Either ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
        parseProg :: Text
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
parseProg = QuoteT
  (Either ParserErrorBundle)
  (Program Name DefaultUni DefaultFun SrcSpan)
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
runQuoteT (QuoteT
   (Either ParserErrorBundle)
   (Program Name DefaultUni DefaultFun SrcSpan)
 -> Either
      ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan))
-> (Text
    -> QuoteT
         (Either ParserErrorBundle)
         (Program Name DefaultUni DefaultFun SrcSpan))
-> Text
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> QuoteT
     (Either ParserErrorBundle)
     (Program Name DefaultUni DefaultFun SrcSpan)
forall e (m :: * -> *).
(AsParserErrorBundle e, MonadError e m, MonadQuote m) =>
Text -> m (Program Name DefaultUni DefaultFun SrcSpan)
parseProgram

-- | The `SrcSpan` of a parsed `Term` should not including trailing whitespaces.
propTermSrcSpan :: TestTree
propTermSrcSpan :: TestTree
propTermSrcSpan = [Char] -> PropertyName -> Property -> TestTree
testPropertyNamed
    [Char]
"parser captures ending positions correctly"
    PropertyName
"propTermSrcSpan"
    (Property -> TestTree)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
property
    (PropertyT IO () -> TestTree) -> PropertyT IO () -> TestTree
forall a b. (a -> b) -> a -> b
$ do
        Text
code <- Term Name DefaultUni DefaultFun () -> Text
forall str a. (Pretty a, Render str) => a -> str
display (Term Name DefaultUni DefaultFun () -> Text)
-> PropertyT IO (Term Name DefaultUni DefaultFun ())
-> PropertyT IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
            Gen (Term Name DefaultUni DefaultFun ())
-> PropertyT IO (Term Name DefaultUni DefaultFun ())
forall (m :: * -> *) a.
(Monad m, Pretty a) =>
Gen a -> PropertyT m a
forAllPretty (Getting
  (Term Name DefaultUni DefaultFun ())
  (Program Name DefaultUni DefaultFun ())
  (Term Name DefaultUni DefaultFun ())
-> Program Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Term Name DefaultUni DefaultFun ())
  (Program Name DefaultUni DefaultFun ())
  (Term Name DefaultUni DefaultFun ())
forall name1 (uni1 :: * -> *) fun1 ann name2 (uni2 :: * -> *) fun2
       (f :: * -> *).
Functor f =>
(Term name1 uni1 fun1 ann -> f (Term name2 uni2 fun2 ann))
-> Program name1 uni1 fun1 ann -> f (Program name2 uni2 fun2 ann)
progTerm (Program Name DefaultUni DefaultFun ()
 -> Term Name DefaultUni DefaultFun ())
-> Gen (Program Name DefaultUni DefaultFun ())
-> Gen (Term Name DefaultUni DefaultFun ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                AstGen (Program Name DefaultUni DefaultFun ())
-> Gen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) a. MonadGen m => AstGen a -> m a
runAstGen ((Some (ValueOf DefaultUni) -> Bool)
-> AstGen (Program Name DefaultUni DefaultFun ())
-> AstGen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) (uni :: * -> *) name fun ann.
MonadGen m =>
(Some (ValueOf uni) -> Bool)
-> m (Program name uni fun ann) -> m (Program name uni fun ann)
discardIfAnyConstant (Bool -> Bool
not (Bool -> Bool)
-> (Some (ValueOf DefaultUni) -> Bool)
-> Some (ValueOf DefaultUni)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Some (ValueOf DefaultUni) -> Bool
isSerialisable)
                    (forall fun.
(Bounded fun, Enum fun) =>
AstGen (Program Name DefaultUni fun ())
Generators.genProgram @DefaultFun)))
        Text -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow Text
code
        let (Int
endingLine, Int
endingCol) = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> Int) -> ([Text] -> Int) -> [Text] -> (Int, Int)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Text -> Int
T.length (Text -> Int) -> ([Text] -> Text) -> [Text] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. HasCallStack => [a] -> a
last ([Text] -> (Int, Int)) -> [Text] -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ Text -> [Text]
T.lines Text
code
        Text
trailingSpaces <- Gen Text -> PropertyT IO Text
forall (m :: * -> *) a.
(Monad m, Pretty a) =>
Gen a -> PropertyT m a
forAllPretty (Gen Text -> PropertyT IO Text) -> Gen Text -> PropertyT IO Text
forall a b. (a -> b) -> a -> b
$ Range Int -> GenT Identity Char -> Gen Text
forall (m :: * -> *). MonadGen m => Range Int -> m Char -> m Text
Gen.text (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
10) ([Char] -> GenT Identity Char
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadGen m) =>
f a -> m a
Gen.element [Char
' ', Char
'\n'])
        case QuoteT (Either ParserErrorBundle) PTerm
-> Either ParserErrorBundle PTerm
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
runQuoteT (QuoteT (Either ParserErrorBundle) PTerm
 -> Either ParserErrorBundle PTerm)
-> (Text -> QuoteT (Either ParserErrorBundle) PTerm)
-> Text
-> Either ParserErrorBundle PTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *).
(AsParserErrorBundle e, MonadError e m, MonadQuote m) =>
Text -> m PTerm
parseTerm @ParserErrorBundle (Text -> Either ParserErrorBundle PTerm)
-> Text -> Either ParserErrorBundle PTerm
forall a b. (a -> b) -> a -> b
$ Text
code Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
trailingSpaces of
            Right PTerm
parsed ->
                let sp :: SrcSpan
sp = PTerm -> SrcSpan
forall name (uni :: * -> *) fun ann. Term name uni fun ann -> ann
termAnn PTerm
parsed
                 in (SrcSpan -> Int
srcSpanELine SrcSpan
sp, SrcSpan -> Int
srcSpanECol SrcSpan
sp) (Int, Int) -> (Int, Int) -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Eq a, Show a, HasCallStack) =>
a -> a -> m ()
=== (Int
endingLine, Int
endingCol Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            Left ParserErrorBundle
err -> [Char] -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
annotate (ParserErrorBundle -> [Char]
forall str a. (Pretty a, Render str) => a -> str
display ParserErrorBundle
err) PropertyT IO () -> PropertyT IO () -> PropertyT IO ()
forall a b. PropertyT IO a -> PropertyT IO b -> PropertyT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PropertyT IO ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure

propUnit :: TestTree
propUnit :: TestTree
propUnit = [Char] -> Assertion -> TestTree
testCase [Char]
"Unit" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ [Assertion] -> Assertion
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ [Char] -> Text
pTerm [Char]
"(con bool True)"
        Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"(con bool True)"
    , [Char] -> Text
pTerm [Char]
"(con (list bool) [True, False])"
        Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"(con (list bool) [True,False])"
    , [Char] -> Text
pTerm [Char]
"(con (pair unit (list integer)) ((),[1,2,3]))"
        Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"(con (pair unit (list integer)) ((), [1,2,3]))"
    , [Char] -> Text
pTerm [Char]
"(con (list (pair string bool)) [(\"abc\", True), (\"def\", False)])"
        Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"(con (list (pair string bool)) [(\"abc\", True), (\"def\", False)])"
    , [Char] -> Text
pTerm [Char]
"(con string \"abc\")"
        Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"(con string \"abc\")"
    ]
    where
        pTerm :: String -> Text
        pTerm :: [Char] -> Text
pTerm
            = (ParserErrorBundle -> Text)
-> (PTerm -> Text) -> Either ParserErrorBundle PTerm -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text)
-> (ParserErrorBundle -> [Char]) -> ParserErrorBundle -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserErrorBundle -> [Char]
forall str a. (Pretty a, Render str) => a -> str
display) PTerm -> Text
forall str a. (Pretty a, Render str) => a -> str
display
            (Either ParserErrorBundle PTerm -> Text)
-> ([Char] -> Either ParserErrorBundle PTerm) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuoteT (Either ParserErrorBundle) PTerm
-> Either ParserErrorBundle PTerm
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
runQuoteT
            (QuoteT (Either ParserErrorBundle) PTerm
 -> Either ParserErrorBundle PTerm)
-> ([Char] -> QuoteT (Either ParserErrorBundle) PTerm)
-> [Char]
-> Either ParserErrorBundle PTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *).
(AsParserErrorBundle e, MonadError e m, MonadQuote m) =>
Text -> m PTerm
parseTerm @_ @(QuoteT (Either ParserErrorBundle))
            (Text -> QuoteT (Either ParserErrorBundle) PTerm)
-> ([Char] -> Text)
-> [Char]
-> QuoteT (Either ParserErrorBundle) PTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack

propDefaultUni :: TestTree
propDefaultUni :: TestTree
propDefaultUni = [Char] -> Assertion -> TestTree
testCase [Char]
"DefaultUni" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ [Assertion] -> Assertion
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ [Char] -> Text
pDefaultUni [Char]
"bool" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"bool"
    , [Char] -> Text
pDefaultUni [Char]
"list" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"list"
    , [Char] -> Text
pDefaultUni [Char]
"(list integer)" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"(list integer)"
    , [Char] -> Text
pDefaultUni [Char]
"(pair (list bool))" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"(pair (list bool))"
    , [Char] -> Text
pDefaultUni [Char]
"(pair (list unit) integer)" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"(pair (list unit) integer)"
    , [Char] -> Text
pDefaultUni [Char]
"(list (pair unit integer))" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"(list (pair unit integer))"
    , [Char] -> Text
pDefaultUni [Char]
"(pair unit (pair bool integer))" Text -> Text -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Text
"(pair unit (pair bool integer))"
    ]
    where
        pDefaultUni :: String -> Text
        pDefaultUni :: [Char] -> Text
pDefaultUni
            = (ParserErrorBundle -> Text)
-> (SomeTypeIn (Kinded DefaultUni) -> Text)
-> Either ParserErrorBundle (SomeTypeIn (Kinded DefaultUni))
-> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Text
forall a. HasCallStack => [Char] -> a
error ([Char] -> Text)
-> (ParserErrorBundle -> [Char]) -> ParserErrorBundle -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserErrorBundle -> [Char]
forall str a. (Pretty a, Render str) => a -> str
display) SomeTypeIn (Kinded DefaultUni) -> Text
forall str a. (Pretty a, Render str) => a -> str
display
            (Either ParserErrorBundle (SomeTypeIn (Kinded DefaultUni)) -> Text)
-> ([Char]
    -> Either ParserErrorBundle (SomeTypeIn (Kinded DefaultUni)))
-> [Char]
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuoteT (Either ParserErrorBundle) (SomeTypeIn (Kinded DefaultUni))
-> Either ParserErrorBundle (SomeTypeIn (Kinded DefaultUni))
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
runQuoteT
            (QuoteT (Either ParserErrorBundle) (SomeTypeIn (Kinded DefaultUni))
 -> Either ParserErrorBundle (SomeTypeIn (Kinded DefaultUni)))
-> ([Char]
    -> QuoteT
         (Either ParserErrorBundle) (SomeTypeIn (Kinded DefaultUni)))
-> [Char]
-> Either ParserErrorBundle (SomeTypeIn (Kinded DefaultUni))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a.
(AsParserErrorBundle e, MonadError e m, MonadQuote m) =>
Parser a -> Text -> m a
parseGen @_ @(QuoteT (Either ParserErrorBundle)) Parser (SomeTypeIn (Kinded DefaultUni))
defaultUni
            (Text
 -> QuoteT
      (Either ParserErrorBundle) (SomeTypeIn (Kinded DefaultUni)))
-> ([Char] -> Text)
-> [Char]
-> QuoteT
     (Either ParserErrorBundle) (SomeTypeIn (Kinded DefaultUni))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack

test_parsing :: TestTree
test_parsing :: TestTree
test_parsing = [Char] -> [TestTree] -> TestTree
testGroup [Char]
"Parsing"
               [ TestTree
propFlat
               , TestTree
propParser
               , TestTree
propTermSrcSpan
               , TestTree
propUnit
               , TestTree
propDefaultUni
               ]