{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoPartialTypeSignatures #-}

module Plutarch.Internal.Other (
  printTerm,
  printScript,
  Flip,
) where

import Data.Kind (Type)
import Data.Text qualified as T
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Plutarch.Internal.Term (
  Config,
  S,
  Term,
  compile,
 )
import Plutarch.Script (Script (Script))
import PlutusCore qualified as PLC
import PlutusCore.Pretty (prettyPlcReadable)
import Prettyprinter (defaultLayoutOptions, layoutSmart)
import Prettyprinter.Render.String (renderString)
import UntypedPlutusCore qualified as UPLC

-- | Prettyprint a compiled Script via the PLC pretty printer
printScript :: Script -> String
printScript :: Script -> [Char]
printScript =
  SimpleDocStream (Any @Type) -> [Char]
forall ann. SimpleDocStream ann -> [Char]
renderString
    (SimpleDocStream (Any @Type) -> [Char])
-> (Script -> SimpleDocStream (Any @Type)) -> Script -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc (Any @Type) -> SimpleDocStream (Any @Type)
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions
    (Doc (Any @Type) -> SimpleDocStream (Any @Type))
-> (Script -> Doc (Any @Type))
-> Script
-> SimpleDocStream (Any @Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term Name DefaultUni DefaultFun () -> Doc (Any @Type)
forall a ann. PrettyPlc a => a -> Doc ann
prettyPlcReadable
    (Term Name DefaultUni DefaultFun () -> Doc (Any @Type))
-> (Script -> Term Name DefaultUni DefaultFun ())
-> Script
-> Doc (Any @Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term NamedDeBruijn DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
mkNames
    (Term NamedDeBruijn DefaultUni DefaultFun ()
 -> Term Name DefaultUni DefaultFun ())
-> (Script -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> Script
-> Term Name DefaultUni DefaultFun ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeBruijn -> NamedDeBruijn)
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term NamedDeBruijn DefaultUni DefaultFun ()
forall name name' (uni :: Type -> Type) fun ann.
(name -> name') -> Term name uni fun ann -> Term name' uni fun ann
UPLC.termMapNames DeBruijn -> NamedDeBruijn
UPLC.fakeNameDeBruijn
    (Term DeBruijn DefaultUni DefaultFun ()
 -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> (Script -> Term DeBruijn DefaultUni DefaultFun ())
-> Script
-> Term NamedDeBruijn DefaultUni DefaultFun ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
programToTerm
    (Program DeBruijn DefaultUni DefaultFun ()
 -> Term DeBruijn DefaultUni DefaultFun ())
-> (Script -> Program DeBruijn DefaultUni DefaultFun ())
-> Script
-> Term DeBruijn DefaultUni DefaultFun ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Script Program DeBruijn DefaultUni DefaultFun ()
s) -> Program DeBruijn DefaultUni DefaultFun ()
s)
  where
    programToTerm ::
      UPLC.Program UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () ->
      UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()
    programToTerm :: Program DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
programToTerm (UPLC.Program ()
_ Version
_ Term DeBruijn DefaultUni DefaultFun ()
t) = Term DeBruijn DefaultUni DefaultFun ()
t
    mkNames ::
      UPLC.Term UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun () ->
      UPLC.Term PLC.Name UPLC.DefaultUni UPLC.DefaultFun ()
    mkNames :: Term NamedDeBruijn DefaultUni DefaultFun ()
-> Term Name DefaultUni DefaultFun ()
mkNames Term NamedDeBruijn DefaultUni DefaultFun ()
t = case QuoteT
  (Either FreeVariableError) (Term Name DefaultUni DefaultFun ())
-> Either FreeVariableError (Term Name DefaultUni DefaultFun ())
forall (m :: Type -> Type) a. Monad m => QuoteT m a -> m a
PLC.runQuoteT (QuoteT
   (Either FreeVariableError) (Term Name DefaultUni DefaultFun ())
 -> Either FreeVariableError (Term Name DefaultUni DefaultFun ()))
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> QuoteT
         (Either FreeVariableError) (Term Name DefaultUni DefaultFun ()))
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Either FreeVariableError (Term Name DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term Name DefaultUni DefaultFun ())
forall (m :: Type -> Type) (uni :: Type -> Type) fun ann.
(MonadQuote m, MonadError FreeVariableError m) =>
Term NamedDeBruijn uni fun ann -> m (Term Name uni fun ann)
UPLC.unDeBruijnTerm (Term NamedDeBruijn DefaultUni DefaultFun ()
 -> Either FreeVariableError (Term Name DefaultUni DefaultFun ()))
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Either FreeVariableError (Term Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ Term NamedDeBruijn DefaultUni DefaultFun ()
t of
      -- This is essentially impossible
      Left FreeVariableError
_ -> [Char] -> Term Name DefaultUni DefaultFun ()
forall a. HasCallStack => [Char] -> a
error [Char]
"printScript: could not generate names. This should never happen."
      Right Term Name DefaultUni DefaultFun ()
res -> Term Name DefaultUni DefaultFun ()
res

{- | Prettyprint a Term via the PLC pretty printer

  TODO: Heavily improve. It's unreadable right now.

  We could convert the de Bruijn indices into names with:

  > show . prettyPlcReadableDef . (\(Right p) -> p) . Scripts.mkTermToEvaluate . compile $ term
-}
printTerm :: forall (a :: S -> Type). HasCallStack => Config -> (forall (s :: S). Term s a) -> String
printTerm :: forall (a :: S -> Type).
HasCallStack =>
Config -> (forall (s :: S). Term s a) -> [Char]
printTerm Config
config forall (s :: S). Term s a
term = Script -> [Char]
printScript (Script -> [Char]) -> Script -> [Char]
forall a b. (a -> b) -> a -> b
$ (Text -> Script)
-> (Script -> Script) -> Either Text Script -> Script
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> Script
forall a. HasCallStack => [Char] -> a
error ([Char] -> Script) -> (Text -> [Char]) -> Text -> Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) Script -> Script
forall a. a -> a
id (Either Text Script -> Script) -> Either Text Script -> Script
forall a b. (a -> b) -> a -> b
$ Config -> (forall (s :: S). Term s a) -> Either Text Script
forall (a :: S -> Type).
Config -> (forall (s :: S). Term s a) -> Either Text Script
compile Config
config Term s a
forall (s :: S). Term s a
term

{- | Type level flip operation, reversing the order of arguments
Commonly used in Plutarch to get the PTryFromExcess associated type of PTryFrom for a Plutarch type

@since 1.12.0
-}
newtype Flip (f :: k1 -> k2 -> Type) (a :: k2) (b :: k1) = Flip (f b a)
  deriving stock ((forall x. Flip @k1 @k2 f a b -> Rep (Flip @k1 @k2 f a b) x)
-> (forall x. Rep (Flip @k1 @k2 f a b) x -> Flip @k1 @k2 f a b)
-> Generic (Flip @k1 @k2 f a b)
forall x. Rep (Flip @k1 @k2 f a b) x -> Flip @k1 @k2 f a b
forall x. Flip @k1 @k2 f a b -> Rep (Flip @k1 @k2 f a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k2 k1 (f :: k1 -> k2 -> Type) (a :: k2) (b :: k1) x.
Rep (Flip @k1 @k2 f a b) x -> Flip @k1 @k2 f a b
forall k2 k1 (f :: k1 -> k2 -> Type) (a :: k2) (b :: k1) x.
Flip @k1 @k2 f a b -> Rep (Flip @k1 @k2 f a b) x
$cfrom :: forall k2 k1 (f :: k1 -> k2 -> Type) (a :: k2) (b :: k1) x.
Flip @k1 @k2 f a b -> Rep (Flip @k1 @k2 f a b) x
from :: forall x. Flip @k1 @k2 f a b -> Rep (Flip @k1 @k2 f a b) x
$cto :: forall k2 k1 (f :: k1 -> k2 -> Type) (a :: k2) (b :: k1) x.
Rep (Flip @k1 @k2 f a b) x -> Flip @k1 @k2 f a b
to :: forall x. Rep (Flip @k1 @k2 f a b) x -> Flip @k1 @k2 f a b
Generic)