{-# LANGUAGE TypeOperators #-}

module Generators.Lib where

import Data.Vector qualified as V
import PlutusCore (Name, _nameText)
import PlutusCore.Compiler.Erase (eraseProgram, eraseTerm)
import PlutusCore.Default (Closed, DefaultFun, DefaultUni, Everywhere, GEq)
import PlutusCore.Generators.Hedgehog.AST (AstGen)
import PlutusCore.Generators.Hedgehog.AST qualified as AST
import PlutusPrelude (on, zipExact)
import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Core.Type (Term (..))

genTerm
  :: forall fun
   . (Bounded fun, Enum fun)
  => AstGen (UPLC.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 (UPLC.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

{-| 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 :: UPLC.Program Name DefaultUni DefaultFun a
  }
  deriving stock Int -> TextualProgram a -> ShowS
[TextualProgram a] -> ShowS
TextualProgram a -> String
(Int -> TextualProgram a -> ShowS)
-> (TextualProgram a -> String)
-> ([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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([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 -> String
show :: TextualProgram a -> String
$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
&& case [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') of
      Maybe [(Term Name uni fun a, Term Name uni fun a)]
Nothing    -> Bool
False
      Just [(Term Name uni fun a, Term Name uni fun a)]
pairs -> ((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)]
pairs
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)
  => UPLC.Program Name uni fun a -> UPLC.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 (UPLC.Program a
_ Version
v Term Name uni fun a
t) (UPLC.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'