{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE PolyKinds #-}

module Plutarch.Test.Utils (
  fewerTests,
  prettyShow,
  prettyEquals,
  typeName,
  instanceOfType,
  typeName',
  precompileTerm,
) where

import Plutarch.Internal.Term (
  Config (NoTracing),
  RawTerm (RCompiled),
  Term (Term),
  TermResult (TermResult),
  compile,
 )
import Plutarch.Prelude
import Plutarch.Script (Script (Script))
import Prettyprinter (Pretty (pretty), defaultLayoutOptions, layoutPretty, (<+>))
import Prettyprinter.Render.String (renderString)
import Test.Tasty.QuickCheck (Property, QuickCheckTests, counterexample)
import Type.Reflection (TypeRep, Typeable, tyConName, typeRep, typeRepTyCon, pattern App)
import UntypedPlutusCore (Program (_progTerm))

-- | Decrease number of quickcheck tests by specified factor
fewerTests :: QuickCheckTests -> QuickCheckTests -> QuickCheckTests
fewerTests :: QuickCheckTests -> QuickCheckTests -> QuickCheckTests
fewerTests QuickCheckTests
divisor = (QuickCheckTests -> QuickCheckTests -> QuickCheckTests
forall a. Integral a => a -> a -> a
`quot` QuickCheckTests
divisor)

prettyShow :: forall (a :: Type). Pretty a => a -> String
prettyShow :: forall a. Pretty a => a -> String
prettyShow = SimpleDocStream (Any @Type) -> String
forall ann. SimpleDocStream ann -> String
renderString (SimpleDocStream (Any @Type) -> String)
-> (a -> SimpleDocStream (Any @Type)) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc (Any @Type) -> SimpleDocStream (Any @Type)
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc (Any @Type) -> SimpleDocStream (Any @Type))
-> (a -> Doc (Any @Type)) -> a -> SimpleDocStream (Any @Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc (Any @Type)
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

prettyEquals :: (Eq a, Pretty a) => a -> a -> Property
prettyEquals :: forall a. (Eq a, Pretty a) => a -> a -> Property
prettyEquals a
x a
y =
  String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
    (SimpleDocStream (Any @Type) -> String
forall ann. SimpleDocStream ann -> String
renderString (SimpleDocStream (Any @Type) -> String)
-> SimpleDocStream (Any @Type) -> String
forall a b. (a -> b) -> a -> b
$ LayoutOptions -> Doc (Any @Type) -> SimpleDocStream (Any @Type)
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (a -> Doc (Any @Type)
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
x Doc (Any @Type) -> Doc (Any @Type) -> Doc (Any @Type)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Bool -> Doc (Any @Type)
forall {a}. IsString a => Bool -> a
interpret Bool
res Doc (Any @Type) -> Doc (Any @Type) -> Doc (Any @Type)
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc (Any @Type)
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
y))
    Bool
res
  where
    res :: Bool
res = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
    interpret :: Bool -> a
interpret Bool
True = a
" == "
    interpret Bool
False = a
" /= "

typeName :: forall k (a :: k). Typeable a => String
typeName :: forall k (a :: k). Typeable @k a => String
typeName = Bool -> TypeRep @k a -> String
forall {k} (k :: k). Bool -> TypeRep @k k -> String
typeName' Bool
True (forall (a :: k). Typeable @k a => TypeRep @k a
forall {k} (a :: k). Typeable @k a => TypeRep @k a
typeRep @a)

typeName' ::
  -- | Wrap in parentheses if contains space
  Bool ->
  TypeRep k ->
  String
typeName' :: forall {k} (k :: k). Bool -> TypeRep @k k -> String
typeName' Bool
isTopLevel TypeRep @k k
rep =
  case TypeRep @k k
rep of
    App TypeRep @(k1 -> k) a
lhs TypeRep @k1 b
rhs -> String -> String
wrap (Bool -> TypeRep @(k1 -> k) a -> String
forall {k} (k :: k). Bool -> TypeRep @k k -> String
typeName' Bool
False TypeRep @(k1 -> k) a
lhs String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> TypeRep @k1 b -> String
forall {k} (k :: k). Bool -> TypeRep @k k -> String
typeName' Bool
False TypeRep @k1 b
rhs)
    TypeRep @k k
rep -> TyCon -> String
tyConName (TyCon -> String) -> TyCon -> String
forall a b. (a -> b) -> a -> b
$ TypeRep @k k -> TyCon
forall {k} (a :: k). TypeRep @k a -> TyCon
typeRepTyCon TypeRep @k k
rep
  where
    wrap :: String -> String
    wrap :: String -> String
wrap String
s
      | Bool -> Bool
not Bool
isTopLevel = String
"(" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
      | Bool
otherwise = String
s

instanceOfType ::
  forall k (a :: k).
  Typeable a =>
  -- | Instance name
  String ->
  String
instanceOfType :: forall k (a :: k). Typeable @k a => String -> String
instanceOfType String
instanceName = String
instanceName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Bool -> TypeRep @k a -> String
forall {k} (k :: k). Bool -> TypeRep @k k -> String
typeName' Bool
False (forall (a :: k). Typeable @k a => TypeRep @k a
forall {k} (a :: k). Typeable @k a => TypeRep @k a
typeRep @a)

-- | @since WIP
precompileTerm :: forall (p :: S -> Type). ClosedTerm p -> ClosedTerm p
precompileTerm :: forall (p :: S -> Type). ClosedTerm p -> ClosedTerm p
precompileTerm ClosedTerm p
t =
  case Config -> ClosedTerm p -> Either Text Script
forall (a :: S -> Type).
Config -> ClosedTerm a -> Either Text Script
compile Config
NoTracing Term s p
ClosedTerm p
t of
    Left Text
err -> String -> Term s p
forall a. HasCallStack => String -> a
error (String -> Term s p) -> String -> Term s p
forall a b. (a -> b) -> a -> b
$ String
"precompileTerm: failed to compile: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
err
    Right Script
script -> Script -> ClosedTerm p
forall (p :: S -> Type). Script -> ClosedTerm p
unsafeTermFromScript Script
script

unsafeTermFromScript :: forall (p :: S -> Type). Script -> ClosedTerm p
unsafeTermFromScript :: forall (p :: S -> Type). Script -> ClosedTerm p
unsafeTermFromScript (Script Program DeBruijn DefaultUni DefaultFun ()
script) =
  (Word64 -> TermMonad TermResult) -> Term s p
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term ((Word64 -> TermMonad TermResult) -> Term s p)
-> (Word64 -> TermMonad TermResult) -> Term s p
forall a b. (a -> b) -> a -> b
$ TermMonad TermResult -> Word64 -> TermMonad TermResult
forall a b. a -> b -> a
const (TermMonad TermResult -> Word64 -> TermMonad TermResult)
-> TermMonad TermResult -> Word64 -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> TermMonad TermResult)
-> TermResult -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> [HoistedTerm] -> TermResult
TermResult (UTerm -> RawTerm
RCompiled (UTerm -> RawTerm) -> UTerm -> RawTerm
forall a b. (a -> b) -> a -> b
$ Program DeBruijn DefaultUni DefaultFun () -> UTerm
forall name (uni :: Type -> Type) fun ann.
Program name uni fun ann -> Term name uni fun ann
_progTerm Program DeBruijn DefaultUni DefaultFun ()
script) []