{-# LANGUAGE RoleAnnotations #-}

module Plutarch.Internal (
  -- | $hoisted
  (:-->) (PLam),
  PDelayed,
  -- | $term
  Term (..),
  asClosedRawTerm,
  Script (Script),
  mapTerm,
  plam',
  plet,
  papp,
  pdelay,
  pforce,
  phoistAcyclic,
  perror,
  punsafeCoerce,
  punsafeBuiltin,
  punsafeConstant,
  punsafeConstantInternal,
  compile,
  compile',
  ClosedTerm,
  Dig,
  hashTerm,
  hashRawTerm,
  RawTerm (..),
  TermResult (TermResult, getDeps, getTerm),
  S (SI),
  PType,
  pthrow,
  Config (..),
  TracingMode (..),
  pgetConfig,
  TermMonad (..),
  (#),
  (#$),
) where

import Control.Monad.Reader (ReaderT (ReaderT), ask, runReaderT)
import Crypto.Hash (Context, Digest, hashFinalize, hashInit, hashUpdate)
import Crypto.Hash.Algorithms (Blake2b_160)
import Crypto.Hash.IO (HashAlgorithm)
import Data.ByteString qualified as BS
import Data.Default (Default (def))
import Data.Functor ((<&>))
import Data.Kind (Type)
import Data.List (foldl', groupBy, sortOn)
import Data.Map.Lazy qualified as M
import Data.Set qualified as S
import Data.String (fromString)
import Data.Text (Text)
import Flat.Run qualified as F
import GHC.Stack (HasCallStack, callStack, prettyCallStack)
import GHC.Word (Word64)
import Plutarch.Internal.Evaluate (evalScript)
import Plutarch.Script (Script (Script))
import PlutusCore (Some (Some), ValueOf (ValueOf))
import PlutusCore qualified as PLC
import PlutusCore.DeBruijn (DeBruijn (DeBruijn), Index (Index))
import UntypedPlutusCore qualified as UPLC

{- $hoisted
 __Explanation for hoisted terms:__
 Hoisting is a convenient way of importing terms without duplicating them
 across your tree. Currently, hoisting is only supported on terms that do
 not refer to any free variables.

 An RHoisted contains a term and its hash. A RawTerm will have a DAG
 of hoisted terms, where an edge represents a dependency.
 We topologically sort these hoisted terms, such that each has an index.

 We wrap our RawTerm in RLamAbs and RApply in an order corresponding to the
 indices. Each level can refer to levels above it by the nature of De Bruijn naming,
 though the name is relative to the current level.
-}

type Dig = Digest Blake2b_160

data HoistedTerm = HoistedTerm Dig RawTerm
  deriving stock (Int -> HoistedTerm -> ShowS
[HoistedTerm] -> ShowS
HoistedTerm -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HoistedTerm] -> ShowS
$cshowList :: [HoistedTerm] -> ShowS
show :: HoistedTerm -> String
$cshow :: HoistedTerm -> String
showsPrec :: Int -> HoistedTerm -> ShowS
$cshowsPrec :: Int -> HoistedTerm -> ShowS
Show)

type UTerm = UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()

data RawTerm
  = RVar Word64
  | RLamAbs Word64 RawTerm
  | RApply RawTerm [RawTerm]
  | RForce RawTerm
  | RDelay RawTerm
  | RConstant (Some (ValueOf PLC.DefaultUni))
  | RBuiltin PLC.DefaultFun
  | RCompiled UTerm
  | RError
  | RHoisted HoistedTerm
  deriving stock (Int -> RawTerm -> ShowS
[RawTerm] -> ShowS
RawTerm -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawTerm] -> ShowS
$cshowList :: [RawTerm] -> ShowS
show :: RawTerm -> String
$cshow :: RawTerm -> String
showsPrec :: Int -> RawTerm -> ShowS
$cshowsPrec :: Int -> RawTerm -> ShowS
Show)

hashRawTerm' :: HashAlgorithm alg => RawTerm -> Context alg -> Context alg
hashRawTerm' :: forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' (RVar Word64
x) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ByteString
"0" :: BS.ByteString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (forall a. Flat a => a -> ByteString
F.flat (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x :: Integer))
hashRawTerm' (RLamAbs Word64
n RawTerm
x) =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ByteString
"1" :: BS.ByteString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (forall a. Flat a => a -> ByteString
F.flat (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n :: Integer)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' RawTerm
x
hashRawTerm' (RApply RawTerm
x [RawTerm]
y) =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ByteString
"2" :: BS.ByteString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' RawTerm
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm') [RawTerm]
y
hashRawTerm' (RForce RawTerm
x) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ByteString
"3" :: BS.ByteString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' RawTerm
x
hashRawTerm' (RDelay RawTerm
x) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ByteString
"4" :: BS.ByteString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' RawTerm
x
hashRawTerm' (RConstant Some @Type (ValueOf DefaultUni)
x) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ByteString
"5" :: BS.ByteString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (forall a. Flat a => a -> ByteString
F.flat Some @Type (ValueOf DefaultUni)
x)
hashRawTerm' (RBuiltin DefaultFun
x) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ByteString
"6" :: BS.ByteString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (forall a. Flat a => a -> ByteString
F.flat DefaultFun
x)
hashRawTerm' RawTerm
RError = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ByteString
"7" :: BS.ByteString)
hashRawTerm' (RHoisted (HoistedTerm Dig
hash RawTerm
_)) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ByteString
"8" :: BS.ByteString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate Dig
hash
hashRawTerm' (RCompiled UTerm
code) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ByteString
"9" :: BS.ByteString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (forall a. Flat a => a -> ByteString
F.flat UTerm
code)

hashRawTerm :: RawTerm -> Dig
hashRawTerm :: RawTerm -> Dig
hashRawTerm RawTerm
t = forall a. HashAlgorithm a => Context a -> Digest a
hashFinalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' RawTerm
t forall a b. (a -> b) -> a -> b
$ forall a. HashAlgorithm a => Context a
hashInit

data TermResult = TermResult
  { TermResult -> RawTerm
getTerm :: RawTerm
  , TermResult -> [HoistedTerm]
getDeps :: [HoistedTerm]
  }

mapTerm :: (RawTerm -> RawTerm) -> TermResult -> TermResult
mapTerm :: (RawTerm -> RawTerm) -> TermResult -> TermResult
mapTerm RawTerm -> RawTerm
f (TermResult RawTerm
t [HoistedTerm]
d) = RawTerm -> [HoistedTerm] -> TermResult
TermResult (RawTerm -> RawTerm
f RawTerm
t) [HoistedTerm]
d

mkTermRes :: RawTerm -> TermResult
mkTermRes :: RawTerm -> TermResult
mkTermRes RawTerm
r = RawTerm -> [HoistedTerm] -> TermResult
TermResult RawTerm
r []

{- Type of `s` in `Term s a`. See: "What is the `s`?" section on the Plutarch guide.

`SI` is the identity type of kind `S`. It is used in type class/family instances
to "forget" the `s`.
-}
data S = SI

-- | Shorthand for Plutarch types.
type PType = S -> Type

newtype Config = Config
  { Config -> TracingMode
tracingMode :: TracingMode
  }

data TracingMode = NoTracing | DetTracing | DoTracing | DoTracingAndBinds

-- | Default is to be efficient
instance Default Config where
  def :: Config
def =
    Config
      { $sel:tracingMode:Config :: TracingMode
tracingMode = TracingMode
NoTracing
      }

newtype TermMonad m = TermMonad {forall m. TermMonad m -> ReaderT Config (Either Text) m
runTermMonad :: ReaderT Config (Either Text) m}
  deriving newtype (forall a b. a -> TermMonad b -> TermMonad a
forall a b. (a -> b) -> TermMonad a -> TermMonad b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> TermMonad b -> TermMonad a
$c<$ :: forall a b. a -> TermMonad b -> TermMonad a
fmap :: forall a b. (a -> b) -> TermMonad a -> TermMonad b
$cfmap :: forall a b. (a -> b) -> TermMonad a -> TermMonad b
Functor, Functor TermMonad
forall a. a -> TermMonad a
forall a b. TermMonad a -> TermMonad b -> TermMonad a
forall a b. TermMonad a -> TermMonad b -> TermMonad b
forall a b. TermMonad (a -> b) -> TermMonad a -> TermMonad b
forall a b c.
(a -> b -> c) -> TermMonad a -> TermMonad b -> TermMonad c
forall (f :: Type -> Type).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. TermMonad a -> TermMonad b -> TermMonad a
$c<* :: forall a b. TermMonad a -> TermMonad b -> TermMonad a
*> :: forall a b. TermMonad a -> TermMonad b -> TermMonad b
$c*> :: forall a b. TermMonad a -> TermMonad b -> TermMonad b
liftA2 :: forall a b c.
(a -> b -> c) -> TermMonad a -> TermMonad b -> TermMonad c
$cliftA2 :: forall a b c.
(a -> b -> c) -> TermMonad a -> TermMonad b -> TermMonad c
<*> :: forall a b. TermMonad (a -> b) -> TermMonad a -> TermMonad b
$c<*> :: forall a b. TermMonad (a -> b) -> TermMonad a -> TermMonad b
pure :: forall a. a -> TermMonad a
$cpure :: forall a. a -> TermMonad a
Applicative, Applicative TermMonad
forall a. a -> TermMonad a
forall a b. TermMonad a -> TermMonad b -> TermMonad b
forall a b. TermMonad a -> (a -> TermMonad b) -> TermMonad b
forall (m :: Type -> Type).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> TermMonad a
$creturn :: forall a. a -> TermMonad a
>> :: forall a b. TermMonad a -> TermMonad b -> TermMonad b
$c>> :: forall a b. TermMonad a -> TermMonad b -> TermMonad b
>>= :: forall a b. TermMonad a -> (a -> TermMonad b) -> TermMonad b
$c>>= :: forall a b. TermMonad a -> (a -> TermMonad b) -> TermMonad b
Monad)

type role Term nominal nominal

{- $term
 Source: Unembedding Domain-Specific Languages by Robert Atkey, Sam Lindley, Jeremy Yallop
 Thanks!
 NB: Hoisted terms must be sorted such that the dependents are first and dependencies last.

 s: This parameter isn't ever instantiated with something concrete. It is merely here
 to ensure that `compile` and `phoistAcyclic` only accept terms without any free variables.

 __Explanation of how the unembedding works:__
 Each term must be instantiated with its de-Bruijn level.
 `plam'`, given its own level, will create an `RVar` that figures out the
 de-Bruijn index needed to reach its own level given the level it itself is
 instantiated with.
-}
newtype Term (s :: S) (a :: PType) = Term {forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm :: Word64 -> TermMonad TermResult}

{- |
  *Closed* terms with no free variables.
-}
type ClosedTerm (a :: PType) = forall (s :: S). Term s a

newtype (:-->) (a :: PType) (b :: PType) (s :: S)
  = PLam (Term s a -> Term s b)
infixr 0 :-->

data PDelayed (a :: PType) (s :: S)

{- |
  Lambda abstraction.

  Only works with a single argument.
  Use 'plam' instead, to support currying.
-}
plam' :: (Term s a -> Term s b) -> Term s (a :--> b)
plam' :: forall (s :: S) (a :: PType) (b :: PType).
(Term s a -> Term s b) -> Term s (a :--> b)
plam' Term s a -> Term s b
f = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
i ->
  let v :: Term s a
v = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
j -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RawTerm -> TermResult
mkTermRes forall a b. (a -> b) -> a -> b
$ Word64 -> RawTerm
RVar (Word64
j forall a. Num a => a -> a -> a
- (Word64
i forall a. Num a => a -> a -> a
+ Word64
1))
   in forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v) (Word64
i forall a. Num a => a -> a -> a
+ Word64
1)) \case
        -- eta-reduce for arity 1
        t :: TermResult
t@(TermResult -> RawTerm
getTerm -> RApply t' :: RawTerm
t'@(RawTerm -> Maybe Word64
getArity -> Just Word64
_) [RVar Word64
0]) -> TermResult
t {$sel:getTerm:TermResult :: RawTerm
getTerm = RawTerm
t'}
        -- eta-reduce for arity 2 + n
        t :: TermResult
t@(TermResult -> RawTerm
getTerm -> RLamAbs Word64
n (RApply t' :: RawTerm
t'@(RawTerm -> Maybe Word64
getArity -> Just Word64
n') [RawTerm]
args))
          | (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just [Word64
0 .. Word64
n forall a. Num a => a -> a -> a
+ Word64
1]) (forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\case RVar Word64
n -> forall a. a -> Maybe a
Just Word64
n; RawTerm
_ -> forall a. Maybe a
Nothing) [RawTerm]
args)
              Bool -> Bool -> Bool
&& Word64
n' forall a. Ord a => a -> a -> Bool
>= Word64
n forall a. Num a => a -> a -> a
+ Word64
1 ->
              TermResult
t {$sel:getTerm:TermResult :: RawTerm
getTerm = RawTerm
t'}
        -- increment arity
        t :: TermResult
t@(TermResult -> RawTerm
getTerm -> RLamAbs Word64
n RawTerm
t') -> TermResult
t {$sel:getTerm:TermResult :: RawTerm
getTerm = Word64 -> RawTerm -> RawTerm
RLamAbs (Word64
n forall a. Num a => a -> a -> a
+ Word64
1) RawTerm
t'}
        -- new lambda
        TermResult
t -> (RawTerm -> RawTerm) -> TermResult -> TermResult
mapTerm (Word64 -> RawTerm -> RawTerm
RLamAbs Word64
0) TermResult
t
  where
    -- 0 is 1
    getArity :: RawTerm -> Maybe Word64
    -- We only do this if it's hoisted, since it's only safe if it doesn't
    -- refer to any of the variables in the wrapping lambda.
    getArity :: RawTerm -> Maybe Word64
getArity (RHoisted (HoistedTerm Dig
_ (RLamAbs Word64
n RawTerm
_))) = forall a. a -> Maybe a
Just Word64
n
    getArity (RHoisted (HoistedTerm Dig
_ RawTerm
t)) = RawTerm -> Maybe Word64
getArityBuiltin RawTerm
t
    getArity RawTerm
t = RawTerm -> Maybe Word64
getArityBuiltin RawTerm
t

    getArityBuiltin :: RawTerm -> Maybe Word64
    getArityBuiltin :: RawTerm -> Maybe Word64
getArityBuiltin (RBuiltin DefaultFun
PLC.AddInteger) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.SubtractInteger) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.MultiplyInteger) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.DivideInteger) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.QuotientInteger) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.RemainderInteger) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.ModInteger) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.EqualsInteger) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.LessThanInteger) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.LessThanEqualsInteger) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.AppendByteString) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.ConsByteString) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.SliceByteString) = forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.LengthOfByteString) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.IndexByteString) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.EqualsByteString) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.LessThanByteString) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.LessThanEqualsByteString) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Sha2_256) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Sha3_256) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Blake2b_256) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.VerifyEd25519Signature) = forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.VerifyEcdsaSecp256k1Signature) = forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.VerifySchnorrSecp256k1Signature) = forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.AppendString) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.EqualsString) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.EncodeUtf8) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.DecodeUtf8) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.IfThenElse)) = forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.ChooseUnit)) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.Trace)) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RForce (RForce (RBuiltin DefaultFun
PLC.FstPair))) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RForce (RBuiltin DefaultFun
PLC.SndPair))) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RForce (RBuiltin DefaultFun
PLC.ChooseList))) = forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.MkCons)) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.HeadList)) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.TailList)) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.NullList)) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.ChooseData)) = forall a. a -> Maybe a
Just Word64
5
    getArityBuiltin (RBuiltin DefaultFun
PLC.ConstrData) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.MapData) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.ListData) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.IData) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.BData) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.UnConstrData) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.UnMapData) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.UnListData) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.UnIData) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.UnBData) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.EqualsData) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.MkPairData) = forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.MkNilData) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.MkNilPairData) = forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin RawTerm
_ = forall a. Maybe a
Nothing

{- |
  Let bindings.

  This is appoximately a shorthand for a lambda and application:

  @plet v f@ == @ papp (plam f) v@

  But sufficiently small terms in WHNF may be inlined for efficiency.
-}
plet :: Term s a -> (Term s a -> Term s b) -> Term s b
plet :: forall (s :: S) (a :: PType) (b :: PType).
Term s a -> (Term s a -> Term s b) -> Term s b
plet Term s a
v Term s a -> Term s b
f = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
i ->
  forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s a
v Word64
i forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- Inline sufficiently small terms in WHNF
    (TermResult -> RawTerm
getTerm -> RVar Word64
_) -> forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v) Word64
i
    (TermResult -> RawTerm
getTerm -> RBuiltin DefaultFun
_) -> forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v) Word64
i
    (TermResult -> RawTerm
getTerm -> RHoisted HoistedTerm
_) -> forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v) Word64
i
    TermResult
_ -> forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
papp (forall (s :: S) (a :: PType) (b :: PType).
(Term s a -> Term s b) -> Term s (a :--> b)
plam' Term s a -> Term s b
f) Term s a
v) Word64
i

pthrow' :: HasCallStack => Text -> TermMonad a
pthrow' :: forall a. HasCallStack => Text -> TermMonad a
pthrow' Text
msg = forall m. ReaderT Config (Either Text) m -> TermMonad m
TermMonad forall a b. (a -> b) -> a -> b
$ forall r (m :: Type -> Type) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (forall a. IsString a => String -> a
fromString (CallStack -> String
prettyCallStack HasCallStack => CallStack
callStack) forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" forall a. Semigroup a => a -> a -> a
<> Text
msg)

pthrow :: HasCallStack => Text -> Term s a
pthrow :: forall (s :: S) (a :: PType). HasCallStack => Text -> Term s a
pthrow = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Text -> TermMonad a
pthrow'

-- | Lambda Application.
papp :: HasCallStack => Term s (a :--> b) -> Term s a -> Term s b
papp :: forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
papp Term s (a :--> b)
x Term s a
y = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
i ->
  (,) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s (a :--> b)
x Word64
i forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s a
y Word64
i forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- Applying anything to an error is an error.
    (TermResult -> RawTerm
getTerm -> RawTerm
RError, TermResult
_) -> forall a. HasCallStack => Text -> TermMonad a
pthrow' Text
"application to an error"
    -- Applying an error to anything is an error.
    (TermResult
_, TermResult -> RawTerm
getTerm -> RawTerm
RError) -> forall a. HasCallStack => Text -> TermMonad a
pthrow' Text
"application with an error"
    -- Applying to `id` changes nothing.
    (TermResult -> RawTerm
getTerm -> RLamAbs Word64
0 (RVar Word64
0), TermResult
y') -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TermResult
y'
    (TermResult -> RawTerm
getTerm -> RHoisted (HoistedTerm Dig
_ (RLamAbs Word64
0 (RVar Word64
0))), TermResult
y') -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TermResult
y'
    -- append argument
    (x' :: TermResult
x'@(TermResult -> RawTerm
getTerm -> RApply RawTerm
x'l [RawTerm]
x'r), TermResult
y') -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RawTerm -> [HoistedTerm] -> TermResult
TermResult (RawTerm -> [RawTerm] -> RawTerm
RApply RawTerm
x'l (TermResult -> RawTerm
getTerm TermResult
y' forall a. a -> [a] -> [a]
: [RawTerm]
x'r)) (TermResult -> [HoistedTerm]
getDeps TermResult
x' forall a. Semigroup a => a -> a -> a
<> TermResult -> [HoistedTerm]
getDeps TermResult
y')
    -- new RApply
    (TermResult
x', TermResult
y') -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RawTerm -> [HoistedTerm] -> TermResult
TermResult (RawTerm -> [RawTerm] -> RawTerm
RApply (TermResult -> RawTerm
getTerm TermResult
x') [TermResult -> RawTerm
getTerm TermResult
y']) (TermResult -> [HoistedTerm]
getDeps TermResult
x' forall a. Semigroup a => a -> a -> a
<> TermResult -> [HoistedTerm]
getDeps TermResult
y')

{- |
  Plutus \'delay\', used for laziness.
-}
pdelay :: Term s a -> Term s (PDelayed a)
pdelay :: forall (s :: S) (a :: PType). Term s a -> Term s (PDelayed a)
pdelay Term s a
x = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term (forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RawTerm -> RawTerm) -> TermResult -> TermResult
mapTerm RawTerm -> RawTerm
RDelay) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s a
x)

{- |
  Plutus \'force\',
  used to force evaluation of 'PDelayed' terms.
-}
pforce :: Term s (PDelayed a) -> Term s a
pforce :: forall (s :: S) (a :: PType). Term s (PDelayed a) -> Term s a
pforce Term s (PDelayed a)
x = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
i ->
  forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s (PDelayed a)
x Word64
i forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    -- A force cancels a delay
    t :: TermResult
t@(TermResult -> RawTerm
getTerm -> RDelay RawTerm
t') -> TermResult
t {$sel:getTerm:TermResult :: RawTerm
getTerm = RawTerm
t'}
    TermResult
t -> (RawTerm -> RawTerm) -> TermResult -> TermResult
mapTerm RawTerm -> RawTerm
RForce TermResult
t

{- |
  Plutus \'error\'.

  When using this explicitly, it should be ensured that
  the containing term is delayed, avoiding premature evaluation.
-}
perror :: Term s a
perror :: forall (s :: S) (a :: PType). Term s a
perror = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
_ -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RawTerm -> TermResult
mkTermRes RawTerm
RError

pgetConfig :: (Config -> Term s a) -> Term s a
pgetConfig :: forall (s :: S) (a :: PType). (Config -> Term s a) -> Term s a
pgetConfig Config -> Term s a
f = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
lvl -> forall m. ReaderT Config (Either Text) m -> TermMonad m
TermMonad forall a b. (a -> b) -> a -> b
$ do
  Config
config <- forall r (m :: Type -> Type). MonadReader r m => m r
ask
  forall m. TermMonad m -> ReaderT Config (Either Text) m
runTermMonad forall a b. (a -> b) -> a -> b
$ forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Config -> Term s a
f Config
config) Word64
lvl

{- |
  Unsafely coerce the type-tag of a Term.

  This should mostly be avoided, though it can be safely
  used to assert known types of Datums, Redeemers or ScriptContext.
-}
punsafeCoerce :: Term s a -> Term s b
punsafeCoerce :: forall (s :: S) (a :: PType) (b :: PType). Term s a -> Term s b
punsafeCoerce (Term Word64 -> TermMonad TermResult
x) = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term Word64 -> TermMonad TermResult
x

punsafeBuiltin :: UPLC.DefaultFun -> Term s a
punsafeBuiltin :: forall (s :: S) (a :: PType). DefaultFun -> Term s a
punsafeBuiltin DefaultFun
f = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
_ -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RawTerm -> TermResult
mkTermRes forall a b. (a -> b) -> a -> b
$ DefaultFun -> RawTerm
RBuiltin DefaultFun
f

{-# DEPRECATED punsafeConstant "Use `pconstant` instead." #-}
punsafeConstant :: Some (ValueOf PLC.DefaultUni) -> Term s a
punsafeConstant :: forall (s :: S) (a :: PType).
Some @Type (ValueOf DefaultUni) -> Term s a
punsafeConstant = forall (s :: S) (a :: PType).
Some @Type (ValueOf DefaultUni) -> Term s a
punsafeConstantInternal

punsafeConstantInternal :: Some (ValueOf PLC.DefaultUni) -> Term s a
punsafeConstantInternal :: forall (s :: S) (a :: PType).
Some @Type (ValueOf DefaultUni) -> Term s a
punsafeConstantInternal Some @Type (ValueOf DefaultUni)
c = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
_ ->
  forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Some @Type (ValueOf DefaultUni)
c of
    -- These constants are smaller than variable references.
    Some (ValueOf DefaultUni (Esc @Type a)
PLC.DefaultUniBool a
_) -> RawTerm -> TermResult
mkTermRes forall a b. (a -> b) -> a -> b
$ Some @Type (ValueOf DefaultUni) -> RawTerm
RConstant Some @Type (ValueOf DefaultUni)
c
    Some (ValueOf DefaultUni (Esc @Type a)
PLC.DefaultUniUnit a
_) -> RawTerm -> TermResult
mkTermRes forall a b. (a -> b) -> a -> b
$ Some @Type (ValueOf DefaultUni) -> RawTerm
RConstant Some @Type (ValueOf DefaultUni)
c
    Some (ValueOf DefaultUni (Esc @Type a)
PLC.DefaultUniInteger a
n) | a
n forall a. Ord a => a -> a -> Bool
< a
256 -> RawTerm -> TermResult
mkTermRes forall a b. (a -> b) -> a -> b
$ Some @Type (ValueOf DefaultUni) -> RawTerm
RConstant Some @Type (ValueOf DefaultUni)
c
    Some @Type (ValueOf DefaultUni)
_ ->
      let hoisted :: HoistedTerm
hoisted = Dig -> RawTerm -> HoistedTerm
HoistedTerm (RawTerm -> Dig
hashRawTerm forall a b. (a -> b) -> a -> b
$ Some @Type (ValueOf DefaultUni) -> RawTerm
RConstant Some @Type (ValueOf DefaultUni)
c) (Some @Type (ValueOf DefaultUni) -> RawTerm
RConstant Some @Type (ValueOf DefaultUni)
c)
       in RawTerm -> [HoistedTerm] -> TermResult
TermResult (HoistedTerm -> RawTerm
RHoisted HoistedTerm
hoisted) [HoistedTerm
hoisted]

asClosedRawTerm :: ClosedTerm a -> TermMonad TermResult
asClosedRawTerm :: forall (a :: PType). ClosedTerm a -> TermMonad TermResult
asClosedRawTerm ClosedTerm a
t = forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm ClosedTerm a
t Word64
0

-- FIXME: Give proper error message when mutually recursive.
phoistAcyclic :: HasCallStack => ClosedTerm a -> Term s a
phoistAcyclic :: forall (a :: PType) (s :: S).
HasCallStack =>
ClosedTerm a -> Term s a
phoistAcyclic ClosedTerm a
t = forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
_ ->
  forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm ClosedTerm a
t Word64
0 forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- Built-ins are smaller than variable references
    t' :: TermResult
t'@(TermResult -> RawTerm
getTerm -> RBuiltin DefaultFun
_) -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TermResult
t'
    TermResult
t' -> case Script -> (Either EvalError Script, ExBudget, [Text])
evalScript forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program DeBruijn DefaultUni DefaultFun () -> Script
Script forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (uni :: Type -> Type) fun ann.
ann
-> Version ann -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program () (forall ann. ann -> Version ann
PLC.defaultVersion ()) forall a b. (a -> b) -> a -> b
$ TermResult -> UTerm
compile' TermResult
t' of
      (Right Script
_, ExBudget
_, [Text]
_) ->
        let hoisted :: HoistedTerm
hoisted = Dig -> RawTerm -> HoistedTerm
HoistedTerm (RawTerm -> Dig
hashRawTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> RawTerm
getTerm forall a b. (a -> b) -> a -> b
$ TermResult
t') (TermResult -> RawTerm
getTerm TermResult
t')
         in forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RawTerm -> [HoistedTerm] -> TermResult
TermResult (HoistedTerm -> RawTerm
RHoisted HoistedTerm
hoisted) (HoistedTerm
hoisted forall a. a -> [a] -> [a]
: TermResult -> [HoistedTerm]
getDeps TermResult
t')
      (Left EvalError
e, ExBudget
_, [Text]
_) -> forall a. HasCallStack => Text -> TermMonad a
pthrow' forall a b. (a -> b) -> a -> b
$ Text
"Hoisted term errs! " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => String -> a
fromString (forall a. Show a => a -> String
show EvalError
e)

-- Couldn't find a definition for this in plutus-core
subst :: Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst :: Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst Word64
idx Word64 -> UTerm
x (UPLC.Apply () UTerm
yx UTerm
yy) = forall name (uni :: Type -> Type) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
UPLC.Apply () (Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst Word64
idx Word64 -> UTerm
x UTerm
yx) (Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst Word64
idx Word64 -> UTerm
x UTerm
yy)
subst Word64
idx Word64 -> UTerm
x (UPLC.LamAbs () DeBruijn
name UTerm
y) = forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann -> Term name uni fun ann
UPLC.LamAbs () DeBruijn
name (Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst (Word64
idx forall a. Num a => a -> a -> a
+ Word64
1) Word64 -> UTerm
x UTerm
y)
subst Word64
idx Word64 -> UTerm
x (UPLC.Delay () UTerm
y) = forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Delay () (Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst Word64
idx Word64 -> UTerm
x UTerm
y)
subst Word64
idx Word64 -> UTerm
x (UPLC.Force () UTerm
y) = forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Force () (Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst Word64
idx Word64 -> UTerm
x UTerm
y)
subst Word64
idx Word64 -> UTerm
x (UPLC.Var () (DeBruijn (Index Word64
idx'))) | Word64
idx forall a. Eq a => a -> a -> Bool
== Word64
idx' = Word64 -> UTerm
x Word64
idx
subst Word64
idx Word64 -> UTerm
_ y :: UTerm
y@(UPLC.Var () (DeBruijn (Index Word64
idx'))) | Word64
idx forall a. Ord a => a -> a -> Bool
> Word64
idx' = UTerm
y
subst Word64
idx Word64 -> UTerm
_ (UPLC.Var () (DeBruijn (Index Word64
idx'))) | Word64
idx forall a. Ord a => a -> a -> Bool
< Word64
idx' = forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann
UPLC.Var () (Index -> DeBruijn
DeBruijn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Index
Index forall a b. (a -> b) -> a -> b
$ Word64
idx' forall a. Num a => a -> a -> a
- Word64
1)
subst Word64
_ Word64 -> UTerm
_ UTerm
y = UTerm
y

rawTermToUPLC ::
  (HoistedTerm -> Word64 -> UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) ->
  Word64 ->
  RawTerm ->
  UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()
rawTermToUPLC :: (HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
_ Word64
_ (RVar Word64
i) = forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann
UPLC.Var () (Index -> DeBruijn
DeBruijn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Index
Index forall a b. (a -> b) -> a -> b
$ Word64
i forall a. Num a => a -> a -> a
+ Word64
1) -- Why the fuck does it start from 1 and not 0?
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l (RLamAbs Word64
n RawTerm
t) =
  forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) ((HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m (Word64
l forall a. Num a => a -> a -> a
+ Word64
n forall a. Num a => a -> a -> a
+ Word64
1) RawTerm
t) (forall a. Int -> a -> [a]
replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Word64
n forall a. Num a => a -> a -> a
+ Word64
1) forall a b. (a -> b) -> a -> b
$ forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann -> Term name uni fun ann
UPLC.LamAbs () (Index -> DeBruijn
DeBruijn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Index
Index forall a b. (a -> b) -> a -> b
$ Word64
0))
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l (RApply RawTerm
x [RawTerm]
y) =
  let f :: RawTerm -> UTerm -> UTerm
f RawTerm
y t :: UTerm
t@(UPLC.LamAbs () DeBruijn
_ UTerm
body) =
        case (HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l RawTerm
y of
          -- Inline unconditionally if it's a variable or built-in.
          -- These terms are very small and are always WHNF.
          UPLC.Var () (DeBruijn (Index Word64
idx)) -> Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst Word64
1 (\Word64
lvl -> forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann
UPLC.Var () (Index -> DeBruijn
DeBruijn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Index
Index forall a b. (a -> b) -> a -> b
$ Word64
idx forall a. Num a => a -> a -> a
+ Word64
lvl forall a. Num a => a -> a -> a
- Word64
1)) UTerm
body
          arg :: UTerm
arg@UPLC.Builtin {} -> Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst Word64
1 (forall a b. a -> b -> a
const UTerm
arg) UTerm
body
          UTerm
arg -> forall name (uni :: Type -> Type) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
UPLC.Apply () UTerm
t UTerm
arg
      f RawTerm
y UTerm
t = forall name (uni :: Type -> Type) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
UPLC.Apply () UTerm
t ((HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l RawTerm
y)
   in forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) ((HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l RawTerm
x) (RawTerm -> UTerm -> UTerm
f forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawTerm]
y)
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l (RDelay RawTerm
t) = forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Delay () ((HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l RawTerm
t)
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l (RForce RawTerm
t) = forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Force () ((HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l RawTerm
t)
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
_ Word64
_ (RBuiltin DefaultFun
f) = forall name (uni :: Type -> Type) fun ann.
ann -> fun -> Term name uni fun ann
UPLC.Builtin () DefaultFun
f
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
_ Word64
_ (RConstant Some @Type (ValueOf DefaultUni)
c) = forall name (uni :: Type -> Type) fun ann.
ann -> Some @Type (ValueOf uni) -> Term name uni fun ann
UPLC.Constant () Some @Type (ValueOf DefaultUni)
c
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
_ Word64
_ (RCompiled UTerm
code) = UTerm
code
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
_ Word64
_ RawTerm
RError = forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann
UPLC.Error ()
-- rawTermToUPLC m l (RHoisted hoisted) = UPLC.Var () . DeBruijn . Index $ l - m hoisted
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l (RHoisted HoistedTerm
hoisted) = HoistedTerm -> Word64 -> UTerm
m HoistedTerm
hoisted Word64
l -- UPLC.Var () . DeBruijn . Index $ l - m hoisted

-- The logic is mostly for hoisting
compile' :: TermResult -> UTerm
compile' :: TermResult -> UTerm
compile' TermResult
t =
  let t' :: RawTerm
t' = TermResult -> RawTerm
getTerm TermResult
t
      deps :: [HoistedTerm]
deps = TermResult -> [HoistedTerm]
getDeps TermResult
t

      f :: Word64 -> Maybe Word64 -> (Bool, Maybe Word64)
      f :: Word64 -> Maybe Word64 -> (Bool, Maybe Word64)
f Word64
n Maybe Word64
Nothing = (Bool
True, forall a. a -> Maybe a
Just Word64
n)
      f Word64
_ (Just Word64
n) = (Bool
False, forall a. a -> Maybe a
Just Word64
n)

      g ::
        HoistedTerm ->
        (M.Map Dig Word64, [(Word64, RawTerm)], Word64) ->
        (M.Map Dig Word64, [(Word64, RawTerm)], Word64)
      g :: HoistedTerm
-> (Map Dig Word64, [(Word64, RawTerm)], Word64)
-> (Map Dig Word64, [(Word64, RawTerm)], Word64)
g (HoistedTerm Dig
hash RawTerm
term) (Map Dig Word64
m, [(Word64, RawTerm)]
defs, Word64
n) = case forall (f :: Type -> Type) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
M.alterF (Word64 -> Maybe Word64 -> (Bool, Maybe Word64)
f Word64
n) Dig
hash Map Dig Word64
m of
        (Bool
True, Map Dig Word64
m) -> (Map Dig Word64
m, (Word64
n, RawTerm
term) forall a. a -> [a] -> [a]
: [(Word64, RawTerm)]
defs, Word64
n forall a. Num a => a -> a -> a
+ Word64
1)
        (Bool
False, Map Dig Word64
m) -> (Map Dig Word64
m, [(Word64, RawTerm)]
defs, Word64
n)

      toInline :: S.Set Dig
      toInline :: Set Dig
toInline =
        forall a. Ord a => [a] -> Set a
S.fromList
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(HoistedTerm Dig
hash RawTerm
_) -> Dig
hash)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> a
head <$>)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: Type -> Type) a. Foldable t => t a -> Int
length)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\(HoistedTerm Dig
x RawTerm
_) (HoistedTerm Dig
y RawTerm
_) -> Dig
x forall a. Eq a => a -> a -> Bool
== Dig
y)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(HoistedTerm Dig
hash RawTerm
_) -> Dig
hash)
          forall a b. (a -> b) -> a -> b
$ [HoistedTerm]
deps

      -- map: term -> de Bruijn level
      -- defs: the terms, level 0 is last
      -- n: # of terms
      (Map Dig Word64
m, [(Word64, RawTerm)]
defs, Word64
n) = forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HoistedTerm
-> (Map Dig Word64, [(Word64, RawTerm)], Word64)
-> (Map Dig Word64, [(Word64, RawTerm)], Word64)
g (forall k a. Map k a
M.empty, [], Word64
0) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(HoistedTerm Dig
hash RawTerm
_) -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
S.member Dig
hash Set Dig
toInline) [HoistedTerm]
deps

      map' :: HoistedTerm -> Word64 -> UTerm
map' (HoistedTerm Dig
hash RawTerm
term) Word64
l = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Dig
hash Map Dig Word64
m of
        Just Word64
l' -> forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann
UPLC.Var () forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index -> DeBruijn
DeBruijn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Index
Index forall a b. (a -> b) -> a -> b
$ Word64
l forall a. Num a => a -> a -> a
- Word64
l'
        Maybe Word64
Nothing -> (HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
map' Word64
l RawTerm
term

      body :: UTerm
body = (HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
map' Word64
n RawTerm
t'

      wrapped :: UTerm
wrapped =
        forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
          (\UTerm
b (Word64
lvl, RawTerm
def) -> forall name (uni :: Type -> Type) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
UPLC.Apply () (forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann -> Term name uni fun ann
UPLC.LamAbs () (Index -> DeBruijn
DeBruijn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Index
Index forall a b. (a -> b) -> a -> b
$ Word64
0) UTerm
b) ((HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
map' Word64
lvl RawTerm
def))
          UTerm
body
          [(Word64, RawTerm)]
defs
   in UTerm
wrapped

-- | Compile a (closed) Plutus Term to a usable script
compile :: Config -> ClosedTerm a -> Either Text Script
compile :: forall (a :: PType). Config -> ClosedTerm a -> Either Text Script
compile Config
config ClosedTerm a
t = case forall (a :: PType). ClosedTerm a -> TermMonad TermResult
asClosedRawTerm ClosedTerm a
t of
  TermMonad (ReaderT Config -> Either Text TermResult
t') -> Program DeBruijn DefaultUni DefaultFun () -> Script
Script forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name (uni :: Type -> Type) fun ann.
ann
-> Version ann -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program () (forall ann. ann -> Natural -> Natural -> Natural -> Version ann
UPLC.Version () Natural
1 Natural
0 Natural
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> UTerm
compile' forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Either Text TermResult
t' Config
config

hashTerm :: Config -> ClosedTerm a -> Either Text Dig
hashTerm :: forall (a :: PType). Config -> ClosedTerm a -> Either Text Dig
hashTerm Config
config ClosedTerm a
t = RawTerm -> Dig
hashRawTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> RawTerm
getTerm forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (forall m. TermMonad m -> ReaderT Config (Either Text) m
runTermMonad forall a b. (a -> b) -> a -> b
$ forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm ClosedTerm a
t Word64
0) Config
config

{- |
  High precedence infixl synonym of 'papp', to be used like
  function juxtaposition. e.g.:

  >>> f # x # y
  f x y
-}
(#) :: HasCallStack => Term s (a :--> b) -> Term s a -> Term s b
# :: forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
(#) = forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
papp

infixl 8 #

{- |
  Low precedence infixr synonym of 'papp', to be used like
  '$', in combination with '#'. e.g.:

  >>> f # x #$ g # y # z
  f x (g y z)
-}
(#$) :: HasCallStack => Term s (a :--> b) -> Term s a -> Term s b
#$ :: forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
(#$) = forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
papp

infixr 0 #$