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

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

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

import Control.Lens (view)
import Data.Text (Text)
import Data.Text qualified as T
import Hedgehog (annotate, annotateShow, failure, property, tripping, (===))
import Hedgehog.Gen qualified as Gen
import Hedgehog.Range qualified as Range
import PlutusCore (Name)
import PlutusCore.Annotation (SrcSpan (..))
import PlutusCore.Default (DefaultFun, DefaultUni)
import PlutusCore.Error (ParserErrorBundle (ParseErrorB))
import PlutusCore.Flat (flat, unflat)
import PlutusCore.Generators.Hedgehog (forAllPretty)
import PlutusCore.Generators.Hedgehog.AST (runAstGen)
import PlutusCore.Parser (defaultUni, parseGen)
import PlutusCore.Pretty (displayPlc)
import PlutusCore.Quote (runQuoteT)
import PlutusCore.Test (isSerialisable)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Golden (goldenVsString)
import Test.Tasty.HUnit (testCase, (@?=))
import Test.Tasty.Hedgehog (testPropertyNamed)
import Text.Megaparsec (errorBundlePretty)

import Data.ByteString.Lazy qualified as BSL
import Data.Text.Encoding (encodeUtf8)
import UntypedPlutusCore (Program)
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Core.Type (progTerm, termAnn)
import UntypedPlutusCore.Generators.Hedgehog.AST (genProgram, regenConstantsUntil)
import UntypedPlutusCore.Parser (parseProgram, parseTerm)

--------------------------------------------------------------------------------
-- Main Test Group -------------------------------------------------------------

test_parsing :: TestTree
test_parsing :: TestTree
test_parsing =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"Parsing"
    [ TestTree
propFlat
    , TestTree
propParser
    , TestTree
propTermSrcSpan
    , TestTree
propUnit
    , TestTree
propDefaultUni
    , [Char] -> [TestTree] -> TestTree
testGroup
        [Char]
"Error Messages"
        [ TestTree
propListElementErrorLocation
        , TestTree
propTypeNameTypoErrorLocation
        , TestTree
propMissingClosingParen
        , TestTree
propMissingClosingBracket
        , TestTree
propMissingBuiltinOperand
        , TestTree
propMissingConOperands
        , TestTree
propInvalidKeyword
        , TestTree
propBracketMismatch
        ]
    ]

--------------------------------------------------------------------------------
-- Test Definitions ------------------------------------------------------------

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)
-> Program Name DefaultUni DefaultFun ()
-> AstGen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) name fun ann.
MonadGen m =>
(Some (ValueOf DefaultUni) -> Bool)
-> Program name DefaultUni fun ann
-> m (Program name DefaultUni fun ann)
regenConstantsUntil Some (ValueOf DefaultUni) -> Bool
isSerialisable (Program Name DefaultUni DefaultFun ()
 -> AstGen (Program Name DefaultUni DefaultFun ()))
-> AstGen (Program Name DefaultUni DefaultFun ())
-> AstGen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall fun.
(Bounded fun, Enum fun) =>
AstGen (Program Name DefaultUni fun ())
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 (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
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
  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 (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)
-> Program Name DefaultUni DefaultFun ()
-> AstGen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) name fun ann.
MonadGen m =>
(Some (ValueOf DefaultUni) -> Bool)
-> Program name DefaultUni fun ann
-> m (Program name DefaultUni fun ann)
regenConstantsUntil Some (ValueOf DefaultUni) -> Bool
isSerialisable (Program Name DefaultUni DefaultFun ()
 -> AstGen (Program Name DefaultUni DefaultFun ()))
-> AstGen (Program Name DefaultUni DefaultFun ())
-> AstGen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AstGen (Program Name DefaultUni DefaultFun ())
forall fun.
(Bounded fun, Enum fun) =>
AstGen (Program Name DefaultUni fun ())
genProgram)
  Program Name DefaultUni DefaultFun ()
-> (Program Name DefaultUni DefaultFun () -> Text)
-> (Text
    -> Either
         ParserErrorBundle (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 Program Name DefaultUni DefaultFun () -> Text
forall a str. (PrettyPlc a, Render str) => a -> str
displayPlc ((Program Name DefaultUni DefaultFun SrcSpan
 -> Program Name DefaultUni DefaultFun ())
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
-> Either ParserErrorBundle (Program Name DefaultUni DefaultFun ())
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 SrcSpan
-> Program Name DefaultUni DefaultFun ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Either
   ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
 -> Either
      ParserErrorBundle (Program Name DefaultUni DefaultFun ()))
-> (Text
    -> Either
         ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan))
-> Text
-> Either ParserErrorBundle (Program Name DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> Either
     ParserErrorBundle (Program Name DefaultUni DefaultFun SrcSpan)
parseProg)
  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 (m :: * -> *).
(MonadError ParserErrorBundle 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 <- PropertyT IO Text
genRandomCode
    Text -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow Text
code
    let (Int
endingLine, Int
endingCol) = Text -> (Int, Int)
getCodeEndingLineAndCol Text
code
    Either ParserErrorBundle PTerm
result <- Text -> PropertyT IO (Either ParserErrorBundle PTerm)
forall {m :: * -> *}.
MonadError ParserErrorBundle m =>
Text -> PropertyT IO (m PTerm)
parseTermWithTrailingSpace Text
code
    case Either ParserErrorBundle PTerm
result of
      Right PTerm
term -> do
        let (Int
endingLine', Int
endingCol') = PTerm -> (Int, Int)
forall {name} {uni :: * -> *} {fun}.
Term name uni fun SrcSpan -> (Int, Int)
getTermEndingLineAndCol PTerm
term
        (Int
endingLine', Int
endingCol') (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 ->
        ParserErrorBundle -> PropertyT IO ()
forall {m :: * -> *} {a} {b}. (MonadTest m, Pretty a) => a -> m b
handleParseError ParserErrorBundle
err
  where
    genRandomCode :: PropertyT IO Text
genRandomCode =
      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)
-> Program Name DefaultUni DefaultFun ()
-> AstGen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) name fun ann.
MonadGen m =>
(Some (ValueOf DefaultUni) -> Bool)
-> Program name DefaultUni fun ann
-> m (Program name DefaultUni fun ann)
regenConstantsUntil Some (ValueOf DefaultUni) -> Bool
isSerialisable (Program Name DefaultUni DefaultFun ()
 -> AstGen (Program Name DefaultUni DefaultFun ()))
-> AstGen (Program Name DefaultUni DefaultFun ())
-> AstGen (Program Name DefaultUni DefaultFun ())
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall fun.
(Bounded fun, Enum fun) =>
AstGen (Program Name DefaultUni fun ())
genProgram @DefaultFun)
          )

    getCodeEndingLineAndCol :: Text -> (Int, Int)
getCodeEndingLineAndCol Text
code = ([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 -> [Text]
T.lines Text
code)

    parseTermWithTrailingSpace :: Text -> PropertyT IO (m PTerm)
parseTermWithTrailingSpace Text
code = do
      Text
trailingSpaces <- PropertyT IO Text
genTrailingSpaces
      m PTerm -> PropertyT IO (m PTerm)
forall a. a -> PropertyT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (m PTerm -> PropertyT IO (m PTerm))
-> m PTerm -> PropertyT IO (m PTerm)
forall a b. (a -> b) -> a -> b
$ QuoteT m PTerm -> m PTerm
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
runQuoteT (QuoteT m PTerm -> m PTerm) -> QuoteT m PTerm -> m PTerm
forall a b. (a -> b) -> a -> b
$ Text -> QuoteT m PTerm
forall (m :: * -> *).
(MonadError ParserErrorBundle m, MonadQuote m) =>
Text -> m PTerm
parseTerm (Text
code Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
trailingSpaces)

    genTrailingSpaces :: PropertyT IO Text
genTrailingSpaces = 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'])

    getTermEndingLineAndCol :: Term name uni fun SrcSpan -> (Int, Int)
getTermEndingLineAndCol Term name uni fun SrcSpan
term = do
      let sp :: SrcSpan
sp = Term name uni fun SrcSpan -> SrcSpan
forall name (uni :: * -> *) fun ann. Term name uni fun ann -> ann
termAnn Term name uni fun SrcSpan
term
      (SrcSpan -> Int
srcSpanELine SrcSpan
sp, SrcSpan -> Int
srcSpanECol SrcSpan
sp)

    handleParseError :: a -> m b
handleParseError a
err = [Char] -> m ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => [Char] -> m ()
annotate (a -> [Char]
forall str a. (Pretty a, Render str) => a -> str
display a
err) m () -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m b
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
. Text -> QuoteT (Either ParserErrorBundle) PTerm
forall (m :: * -> *).
(MonadError ParserErrorBundle m, MonadQuote m) =>
Text -> m PTerm
parseTerm
        (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
. Parser (SomeTypeIn (Kinded DefaultUni))
-> Text
-> QuoteT
     (Either ParserErrorBundle) (SomeTypeIn (Kinded DefaultUni))
forall (m :: * -> *) a.
(MonadError ParserErrorBundle m, MonadQuote m) =>
Parser a -> Text -> m a
parseGen 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 that parser errors for list element type mismatches point to the correct location.
This uses the exact example from the issue report. -}
propListElementErrorLocation :: TestTree
propListElementErrorLocation :: TestTree
propListElementErrorLocation =
  [Char] -> [Char] -> Text -> TestTree
testParseErrorGolden
    [Char]
"List element error location"
    [Char]
"list-element-type-mismatch"
    ( [Text] -> Text
T.unlines
        [ Text
"(program 1.1.0 "
        , Text
"["
        , Text
" (force (builtin mkCons)) (con integer 4) (con (list integer) [true]) ]"
        , Text
")"
        ]
    )

{-| Test that parser errors for typos in type names point to the correct location.
This tests the case where "boot" is used instead of "bool". -}
propTypeNameTypoErrorLocation :: TestTree
propTypeNameTypoErrorLocation :: TestTree
propTypeNameTypoErrorLocation =
  [Char] -> [Char] -> Text -> TestTree
testParseErrorGolden
    [Char]
"Type name typo error location"
    [Char]
"type-name-typo"
    ( [Text] -> Text
T.unlines
        [ Text
"(program 1.1.0"
        , Text
"[ (builtin integerToByteString) (con boot True) (con integer 0) (con integer 712372356934756347862573452345342345) ]"
        , Text
")"
        ]
    )

-- | Test that parser errors for missing closing parenthesis are clear.
propMissingClosingParen :: TestTree
propMissingClosingParen :: TestTree
propMissingClosingParen =
  [Char] -> [Char] -> Text -> TestTree
testParseErrorGolden
    [Char]
"Missing closing parenthesis error"
    [Char]
"missing-closing-paren"
    Text
"(program 1.1.0 (lam x (var x))"

-- | Test that parser errors for missing closing bracket are clear.
propMissingClosingBracket :: TestTree
propMissingClosingBracket :: TestTree
propMissingClosingBracket =
  [Char] -> [Char] -> Text -> TestTree
testParseErrorGolden
    [Char]
"Missing closing bracket error"
    [Char]
"missing-closing-bracket"
    Text
"(program 1.1.0 [(builtin addInteger) (con integer 1) (con integer 2))"

-- | Test that parser errors for missing builtin operand are clear.
propMissingBuiltinOperand :: TestTree
propMissingBuiltinOperand :: TestTree
propMissingBuiltinOperand =
  [Char] -> [Char] -> Text -> TestTree
testParseErrorGolden
    [Char]
"Missing builtin function name error"
    [Char]
"missing-builtin-operand"
    Text
"(program 1.1.0 (builtin))"

-- | Test that parser errors for missing con operands are clear.
propMissingConOperands :: TestTree
propMissingConOperands :: TestTree
propMissingConOperands =
  [Char] -> [Char] -> Text -> TestTree
testParseErrorGolden
    [Char]
"Missing con operands error"
    [Char]
"missing-con-operands"
    Text
"(program 1.1.0 (con))"

-- | Test that parser errors for invalid keywords are clear.
propInvalidKeyword :: TestTree
propInvalidKeyword :: TestTree
propInvalidKeyword =
  [Char] -> [Char] -> Text -> TestTree
testParseErrorGolden
    [Char]
"Invalid keyword error"
    [Char]
"invalid-keyword"
    Text
"(program 1.1.0 (foo x))"

-- | Test that parser errors for bracket mismatches are clear.
propBracketMismatch :: TestTree
propBracketMismatch :: TestTree
propBracketMismatch =
  [Char] -> [Char] -> Text -> TestTree
testParseErrorGolden
    [Char]
"Bracket type mismatch error"
    [Char]
"bracket-mismatch"
    Text
"(program 1.1.0 [(var x))"

--------------------------------------------------------------------------------
-- Helper Functions ------------------------------------------------------------

{-| Helper function to test parser error messages using golden files.
Verifies exact error message output against a golden file, ensuring error quality doesn't regress. -}
testParseErrorGolden :: String -> String -> T.Text -> TestTree
testParseErrorGolden :: [Char] -> [Char] -> Text -> TestTree
testParseErrorGolden [Char]
testName [Char]
goldenFileName Text
code =
  [Char] -> [Char] -> IO ByteString -> TestTree
goldenVsString
    [Char]
testName
    ([Char]
"untyped-plutus-core/test/Parser/Golden/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
goldenFileName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".golden")
    (IO ByteString -> TestTree) -> IO ByteString -> TestTree
forall a b. (a -> b) -> a -> b
$ case 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 (Text
-> QuoteT
     (Either ParserErrorBundle)
     (Program Name DefaultUni DefaultFun SrcSpan)
forall (m :: * -> *).
(MonadError ParserErrorBundle m, MonadQuote m) =>
Text -> m (Program Name DefaultUni DefaultFun SrcSpan)
parseProgram Text
code) of
      Right Program Name DefaultUni DefaultFun SrcSpan
_ -> [Char] -> IO ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Expected parse error, but parsing succeeded"
      Left (ParseErrorB ParseErrorBundle Text ParserError
errBundle) ->
        ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString)
-> ([Char] -> ByteString) -> [Char] -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString)
-> ([Char] -> ByteString) -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> ([Char] -> Text) -> [Char] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Text
T.pack ([Char] -> IO ByteString) -> [Char] -> IO ByteString
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text ParserError -> [Char]
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> [Char]
errorBundlePretty ParseErrorBundle Text ParserError
errBundle