{-# LANGUAGE OverloadedStrings #-}

module Analysis.Lib where

import Data.Text qualified as Text
import Numeric.Natural (Natural)
import PlutusCore.Builtin (BuiltinSemanticsVariant)
import PlutusCore.Default (DefaultFun, DefaultUni)
import PlutusCore.Default.Builtins (DefaultFun (..))
import PlutusCore.MkPlc (mkConstant, mkIterAppNoAnn)
import PlutusCore.Name.Unique (Name (..), Unique (..))
import PlutusCore.Pretty (prettyPlcReadable)
import PlutusCore.Quote (freshName, runQuote)
import PlutusPrelude (def)
import Test.Tasty.Extras (TestNested, nestedGoldenVsDoc)
import UntypedPlutusCore.Core.Type (Term (..))
import UntypedPlutusCore.Purity (termEvaluationOrder)

builtinSemantics :: BuiltinSemanticsVariant DefaultFun
builtinSemantics :: BuiltinSemanticsVariant DefaultFun
builtinSemantics = BuiltinSemanticsVariant DefaultFun
forall a. Default a => a
def

goldenEvalOrder :: String -> Term Name DefaultUni DefaultFun () -> TestNested
goldenEvalOrder :: String -> Term Name DefaultUni DefaultFun () -> TestNested
goldenEvalOrder String
name Term Name DefaultUni DefaultFun ()
tm =
  let order :: EvalOrder Name DefaultUni DefaultFun ()
order = BuiltinSemanticsVariant DefaultFun
-> Term Name DefaultUni DefaultFun ()
-> EvalOrder Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun a.
ToBuiltinMeaning uni fun =>
BuiltinSemanticsVariant fun
-> Term name uni fun a -> EvalOrder name uni fun a
termEvaluationOrder BuiltinSemanticsVariant DefaultFun
builtinSemantics Term Name DefaultUni DefaultFun ()
tm
   in String -> String -> Doc Any -> TestNested
forall ann. String -> String -> Doc ann -> TestNested
nestedGoldenVsDoc String
name String
"" (EvalOrder Name DefaultUni DefaultFun () -> Doc Any
forall a ann. PrettyPlc a => a -> Doc ann
prettyPlcReadable EvalOrder Name DefaultUni DefaultFun ()
order)

--------------------------------------------------------------------------------
-- Terms for testing -----------------------------------------------------------

termIfThenElse :: Term Name DefaultUni DefaultFun ()
termIfThenElse :: Term Name DefaultUni DefaultFun ()
termIfThenElse =
  ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
Apply
    ()
    ( ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
Apply
        ()
        (()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
Apply () (()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
Force () (() -> DefaultFun -> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> fun -> Term name uni fun ann
Builtin () DefaultFun
IfThenElse)) (Natural -> Term Name DefaultUni DefaultFun ()
termVar Natural
1))
        (Natural -> Term Name DefaultUni DefaultFun ()
termVar Natural
2)
    )
    (Natural -> Term Name DefaultUni DefaultFun ()
termVar Natural
3)

termVar :: Natural -> Term Name DefaultUni DefaultFun ()
termVar :: Natural -> Term Name DefaultUni DefaultFun ()
termVar Natural
n =
  () -> Name -> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann
Var () (Text -> Unique -> Name
Name (Text
"var" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Natural -> String
forall a. Show a => a -> String
show Natural
n)) (Int -> Unique
Unique (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n)))

-- that the computation is lazy
-- [ [ n m ] (constr 1 [undefined]) ]
dangerTerm :: Term Name DefaultUni DefaultFun ()
dangerTerm :: Term Name DefaultUni DefaultFun ()
dangerTerm = Quote (Term Name DefaultUni DefaultFun ())
-> Term Name DefaultUni DefaultFun ()
forall a. Quote a -> a
runQuote (Quote (Term Name DefaultUni DefaultFun ())
 -> Term Name DefaultUni DefaultFun ())
-> Quote (Term Name DefaultUni DefaultFun ())
-> Term Name DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$ do
  Name
n <- Text -> QuoteT Identity Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
freshName Text
"n"
  Name
m <- Text -> QuoteT Identity Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
freshName Text
"m"
  -- The UPLC term type is strict, so it's hard to hide an undefined in there
  -- Take advantage of the fact that it's still using lazy lists for constr
  -- arguments for now.
  Term Name DefaultUni DefaultFun ()
-> Quote (Term Name DefaultUni DefaultFun ())
forall a. a -> QuoteT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term Name DefaultUni DefaultFun ()
 -> Quote (Term Name DefaultUni DefaultFun ()))
-> Term Name DefaultUni DefaultFun ()
-> Quote (Term Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
Apply () (()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
Apply () (() -> Name -> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann
Var () Name
n) (() -> Name -> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann
Var () Name
m)) (()
-> Word64
-> [Term Name DefaultUni DefaultFun ()]
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> Word64 -> [Term name uni fun ann] -> Term name uni fun ann
Constr () Word64
1 [Term Name DefaultUni DefaultFun ()
forall a. HasCallStack => a
undefined])

letFun :: Term Name DefaultUni DefaultFun ()
letFun :: Term Name DefaultUni DefaultFun ()
letFun = Quote (Term Name DefaultUni DefaultFun ())
-> Term Name DefaultUni DefaultFun ()
forall a. Quote a -> a
runQuote (Quote (Term Name DefaultUni DefaultFun ())
 -> Term Name DefaultUni DefaultFun ())
-> Quote (Term Name DefaultUni DefaultFun ())
-> Term Name DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$ do
  Name
n <- Text -> QuoteT Identity Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
freshName Text
"n"
  let intConst :: Term Name DefaultUni DefaultFun ()
intConst = () -> Integer -> Term Name DefaultUni DefaultFun ()
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
mkConstant () (Integer
1 :: Integer)
  Term Name DefaultUni DefaultFun ()
-> Quote (Term Name DefaultUni DefaultFun ())
forall a. a -> QuoteT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term Name DefaultUni DefaultFun ()
 -> Quote (Term Name DefaultUni DefaultFun ()))
-> Term Name DefaultUni DefaultFun ()
-> Quote (Term Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$
    ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
Apply
      ()
      (()
-> Name
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann -> Term name uni fun ann
LamAbs () Name
n (Term Name DefaultUni DefaultFun ()
-> [Term Name DefaultUni DefaultFun ()]
-> Term Name DefaultUni DefaultFun ()
forall (term :: * -> *) tyname name (uni :: * -> *) fun.
TermLike term tyname name uni fun =>
term () -> [term ()] -> term ()
mkIterAppNoAnn (() -> Name -> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann
Var () Name
n) [Term Name DefaultUni DefaultFun ()
intConst, Term Name DefaultUni DefaultFun ()
intConst]))
      (() -> DefaultFun -> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> fun -> Term name uni fun ann
Builtin () DefaultFun
AddInteger)

letImpure :: Term Name DefaultUni DefaultFun ()
letImpure :: Term Name DefaultUni DefaultFun ()
letImpure = Quote (Term Name DefaultUni DefaultFun ())
-> Term Name DefaultUni DefaultFun ()
forall a. Quote a -> a
runQuote (Quote (Term Name DefaultUni DefaultFun ())
 -> Term Name DefaultUni DefaultFun ())
-> Quote (Term Name DefaultUni DefaultFun ())
-> Term Name DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$ do
  Name
n <- Text -> QuoteT Identity Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
freshName Text
"n"
  Name
m <- Text -> QuoteT Identity Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
freshName Text
"m"
  let intConst :: Term Name DefaultUni DefaultFun ()
intConst = () -> Integer -> Term Name DefaultUni DefaultFun ()
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
mkConstant () (Integer
1 :: Integer)
  Term Name DefaultUni DefaultFun ()
-> Quote (Term Name DefaultUni DefaultFun ())
forall a. a -> QuoteT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term Name DefaultUni DefaultFun ()
 -> Quote (Term Name DefaultUni DefaultFun ()))
-> Term Name DefaultUni DefaultFun ()
-> Quote (Term Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$
    ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
Apply
      ()
      (()
-> Name
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann -> Term name uni fun ann
LamAbs () Name
n (Term Name DefaultUni DefaultFun ()
-> [Term Name DefaultUni DefaultFun ()]
-> Term Name DefaultUni DefaultFun ()
forall (term :: * -> *) tyname name (uni :: * -> *) fun.
TermLike term tyname name uni fun =>
term () -> [term ()] -> term ()
mkIterAppNoAnn (() -> Name -> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann
Var () Name
n) [Term Name DefaultUni DefaultFun ()
intConst, Term Name DefaultUni DefaultFun ()
intConst]))
      -- don't need this to be well-scoped
      (()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
Apply () (() -> Name -> Term Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> name -> Term name uni fun ann
Var () Name
m) Term Name DefaultUni DefaultFun ()
intConst)