{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE NoPartialTypeSignatures #-}

module Plutarch.Internal.Term (
  -- | \$hoisted
  (:-->) (PLam),
  PDelayed,
  -- | \$term
  Term (..),
  Script (Script),
  mapTerm,
  plam',
  plet,
  papp,
  pdelay,
  pforce,
  phoistAcyclic,
  perror,
  pplaceholder,
  punsafeCoerce,
  punsafeBuiltin,
  punsafeConstantInternal,
  compile,
  compileWithInternalConfig,
  compileOptimized,
  compileOptimizedWithInternalConfig,
  compile',
  optimizeTerm,
  RawTerm (..),
  HoistedTerm (..),
  TermResult (TermResult, getDeps, getTerm),
  S (SI),
  pthrow,
  Config (NoTracing, Tracing),
  InternalConfig (..),
  TracingMode (..),
  LogLevel (..),
  tracingMode,
  logLevel,
  pgetConfig,
  pgetInternalConfig,
  pwithInternalConfig,
  (#),
  (#$),
) where

import Control.Monad.Except (
  ExceptT,
  runExceptT,
  throwError,
 )
import Control.Monad.RWS.CPS (RWS, evalRWS)
import Control.Monad.Reader (ask, asks, local)
import Data.Aeson (
  FromJSON (parseJSON),
  ToJSON (toEncoding, toJSON),
  object,
  pairs,
  withObject,
  withText,
  (.:),
  (.=),
 )
import Data.Default (def)
import Data.HashMap.Strict qualified as HM
import Data.Hashable (Hashable (hash, hashWithSalt), defaultHashWithSalt)
import Data.Kind (Type)
import Data.List (foldl')
import Data.Monoid (Last (Last))
import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Vector qualified as V
import GHC.Stack (HasCallStack, callStack, prettyCallStack)
import GHC.Word (Word64)
import Plutarch.Internal.Evaluate (evalScript, uplcVersion)
import Plutarch.Script (Script (Script))
import PlutusCore (Some (Some), ValueOf (ValueOf))
import PlutusCore qualified as PLC
import PlutusCore.DeBruijn (DeBruijn (DeBruijn), Index (Index))
import Prettyprinter (Pretty (pretty), (<+>))
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.
-}

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

{- | Hoisted term carry their own non-cryptographic hash, making it incredibly
cheap to hold these in hashmaps.
-}
instance Hashable HoistedTerm where
  hashWithSalt :: Int -> HoistedTerm -> Int
hashWithSalt = Int -> HoistedTerm -> Int
forall a. Hashable a => Int -> a -> Int
defaultHashWithSalt
  {-# INLINE hashWithSalt #-}

  -- The instance uses that this is basically 'Hashed a'.
  hash :: HoistedTerm -> Int
hash = HoistedTerm -> Int
htHash
  {-# INLINE hash #-}

{- | Equality of hoisted terms is first checked via their non-cryptographic
hash, then via term equality. Inequality, which should happen much more
often is thus cheap.

Note that we could just as well derive this instance...
-}
instance Eq HoistedTerm where
  HoistedTerm
l == :: HoistedTerm -> HoistedTerm -> Bool
== HoistedTerm
r =
    HoistedTerm -> Int
htHash HoistedTerm
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== HoistedTerm -> Int
htHash HoistedTerm
r
      Bool -> Bool -> Bool
&& HoistedTerm -> RawTerm
htRawTerm HoistedTerm
l RawTerm -> RawTerm -> Bool
forall a. Eq a => a -> a -> Bool
== HoistedTerm -> RawTerm
htRawTerm HoistedTerm
r
  {-# INLINE (==) #-}

data RawTerm
  = RVar Word64
  | RLamAbs Word64 RawTerm
  | RApply RawTerm [RawTerm] -- NB: (f a b c d) ~ RApply f [b c d a]
  | RForce RawTerm
  | RDelay RawTerm
  | RConstant (Some (ValueOf PLC.DefaultUni))
  | RBuiltin PLC.DefaultFun
  | RCompiled (UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ())
  | RError
  | RHoisted HoistedTerm
  | RPlaceHolder Integer
  | RConstr Word64 [RawTerm]
  | RCase RawTerm [RawTerm]
  | -- Let x (\x' -> ...)
    RLet RawTerm RawTerm
  deriving stock (Int -> RawTerm -> ShowS
[RawTerm] -> ShowS
RawTerm -> String
(Int -> RawTerm -> ShowS)
-> (RawTerm -> String) -> ([RawTerm] -> ShowS) -> Show RawTerm
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RawTerm -> ShowS
showsPrec :: Int -> RawTerm -> ShowS
$cshow :: RawTerm -> String
show :: RawTerm -> String
$cshowList :: [RawTerm] -> ShowS
showList :: [RawTerm] -> ShowS
Show, RawTerm -> RawTerm -> Bool
(RawTerm -> RawTerm -> Bool)
-> (RawTerm -> RawTerm -> Bool) -> Eq RawTerm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RawTerm -> RawTerm -> Bool
== :: RawTerm -> RawTerm -> Bool
$c/= :: RawTerm -> RawTerm -> Bool
/= :: RawTerm -> RawTerm -> Bool
Eq)

-- | A very cheap hash which cheapens equality, but is also needed for using an unordered container.
instance Hashable RawTerm where
  hashWithSalt :: Int -> RawTerm -> Int
hashWithSalt = Int -> RawTerm -> Int
forall a. Hashable a => Int -> a -> Int
defaultHashWithSalt
  {-# INLINE hashWithSalt #-}
  hash :: RawTerm -> Int
hash = \case
    RVar Word64
x -> (Int, Int) -> Int
forall a. Hashable a => a -> Int
hash (Int
0 :: Int, Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x :: Int)
    RLamAbs Word64
n RawTerm
x -> (Int, Word64, RawTerm) -> Int
forall a. Hashable a => a -> Int
hash (Int
1 :: Int, Word64
n, RawTerm
x)
    RApply RawTerm
x [RawTerm]
y -> (Int, [RawTerm]) -> Int
forall a. Hashable a => a -> Int
hash (Int
2 :: Int, RawTerm
x RawTerm -> [RawTerm] -> [RawTerm]
forall a. a -> [a] -> [a]
: [RawTerm]
y)
    RForce RawTerm
x -> (Int, RawTerm) -> Int
forall a. Hashable a => a -> Int
hash (Int
3 :: Int, RawTerm
x)
    RDelay RawTerm
x -> (Int, RawTerm) -> Int
forall a. Hashable a => a -> Int
hash (Int
4 :: Int, RawTerm
x)
    RConstant Some @Type (ValueOf DefaultUni)
x -> (Int, Some @Type (ValueOf DefaultUni)) -> Int
forall a. Hashable a => a -> Int
hash (Int
5 :: Int, Some @Type (ValueOf DefaultUni)
x)
    RBuiltin DefaultFun
x -> (Int, DefaultFun) -> Int
forall a. Hashable a => a -> Int
hash (Int
6 :: Int, DefaultFun
x)
    RawTerm
RError -> Int
7 :: Int
    RHoisted (HoistedTerm {Int
$sel:htHash:HoistedTerm :: HoistedTerm -> Int
htHash :: Int
htHash}) -> (Int, Int) -> Int
forall a. Hashable a => a -> Int
hash (Int
8 :: Int, Int
htHash :: Int)
    RCompiled Term DeBruijn DefaultUni DefaultFun ()
code -> (Int, Term DeBruijn DefaultUni DefaultFun ()) -> Int
forall a. Hashable a => a -> Int
hash (Int
9 :: Int, Term DeBruijn DefaultUni DefaultFun ()
code)
    RPlaceHolder Integer
x -> (Int, Integer) -> Int
forall a. Hashable a => a -> Int
hash (Int
10 :: Int, Integer
x)
    RConstr Word64
x [RawTerm]
y -> (Int, Word64, [RawTerm]) -> Int
forall a. Hashable a => a -> Int
hash (Int
11 :: Int, Word64
x, [RawTerm]
y)
    RCase RawTerm
x [RawTerm]
y -> (Int, RawTerm, [RawTerm]) -> Int
forall a. Hashable a => a -> Int
hash (Int
12 :: Int, RawTerm
x, [RawTerm]
y)
    RLet RawTerm
x RawTerm
y -> (Int, RawTerm, RawTerm) -> Int
forall a. Hashable a => a -> Int
hash (Int
13 :: Int, RawTerm
x, RawTerm
y)
  {-# INLINE hash #-}

data TermResult = TermResult
  { TermResult -> RawTerm
getTerm :: RawTerm
  , TermResult -> [HoistedTerm]
getDeps :: [HoistedTerm]
  }
  deriving stock (Int -> TermResult -> ShowS
[TermResult] -> ShowS
TermResult -> String
(Int -> TermResult -> ShowS)
-> (TermResult -> String)
-> ([TermResult] -> ShowS)
-> Show TermResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TermResult -> ShowS
showsPrec :: Int -> TermResult -> ShowS
$cshow :: TermResult -> String
show :: TermResult -> String
$cshowList :: [TermResult] -> ShowS
showList :: [TermResult] -> ShowS
Show)

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

{- | How to trace.

@since 1.6.0
-}
data TracingMode = DetTracing | DoTracing | DoTracingAndBinds
  deriving stock
    ( -- | @since 1.6.0
      TracingMode -> TracingMode -> Bool
(TracingMode -> TracingMode -> Bool)
-> (TracingMode -> TracingMode -> Bool) -> Eq TracingMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TracingMode -> TracingMode -> Bool
== :: TracingMode -> TracingMode -> Bool
$c/= :: TracingMode -> TracingMode -> Bool
/= :: TracingMode -> TracingMode -> Bool
Eq
    , -- | @since 1.6.0
      Int -> TracingMode -> ShowS
[TracingMode] -> ShowS
TracingMode -> String
(Int -> TracingMode -> ShowS)
-> (TracingMode -> String)
-> ([TracingMode] -> ShowS)
-> Show TracingMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TracingMode -> ShowS
showsPrec :: Int -> TracingMode -> ShowS
$cshow :: TracingMode -> String
show :: TracingMode -> String
$cshowList :: [TracingMode] -> ShowS
showList :: [TracingMode] -> ShowS
Show
    )

{- | We have a linear order of generality, so this instance reflects it:
\'smaller\' values are more specific. Generality is in the following order,
from least to most general:

1. @DetTracing@
2. @DoTracing@
3. @DoTracingAndBinds@

@since 1.6.0
-}
instance Ord TracingMode where
  -- Note: We write this by hand so someone re-ordering or adding 'arms' won't
  -- silently break this.
  TracingMode
tm1 <= :: TracingMode -> TracingMode -> Bool
<= TracingMode
tm2 = case TracingMode
tm1 of
    TracingMode
DetTracing -> Bool
True
    TracingMode
DoTracing -> case TracingMode
tm2 of
      TracingMode
DetTracing -> Bool
False
      TracingMode
_ -> Bool
True
    TracingMode
DoTracingAndBinds -> case TracingMode
tm2 of
      TracingMode
DoTracingAndBinds -> Bool
True
      TracingMode
_ -> Bool
False

{- | More general tracing supersedes less general.

@since 1.6.0
-}
instance Semigroup TracingMode where
  <> :: TracingMode -> TracingMode -> TracingMode
(<>) = TracingMode -> TracingMode -> TracingMode
forall a. Ord a => a -> a -> a
max

-- | @since 1.6.0
instance Pretty TracingMode where
  pretty :: forall ann. TracingMode -> Doc ann
pretty = \case
    TracingMode
DetTracing -> Doc ann
"DetTracing"
    TracingMode
DoTracing -> Doc ann
"DoTracing"
    TracingMode
DoTracingAndBinds -> Doc ann
"DoTracingAndBinds"

-- | @since 1.6.0
instance ToJSON TracingMode where
  {-# INLINEABLE toJSON #-}
  toJSON :: TracingMode -> Value
toJSON =
    forall a. ToJSON a => a -> Value
toJSON @Text (Text -> Value) -> (TracingMode -> Text) -> TracingMode -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      TracingMode
DetTracing -> Text
"DetTracing"
      TracingMode
DoTracing -> Text
"DoTracing"
      TracingMode
DoTracingAndBinds -> Text
"DoTracingAndBinds"
  {-# INLINEABLE toEncoding #-}
  toEncoding :: TracingMode -> Encoding
toEncoding =
    forall a. ToJSON a => a -> Encoding
toEncoding @Text (Text -> Encoding)
-> (TracingMode -> Text) -> TracingMode -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      TracingMode
DetTracing -> Text
"DetTracing"
      TracingMode
DoTracing -> Text
"DoTracing"
      TracingMode
DoTracingAndBinds -> Text
"DoTracingAndBinds"

-- | @since 1.6.0
instance FromJSON TracingMode where
  {-# INLINEABLE parseJSON #-}
  parseJSON :: Value -> Parser TracingMode
parseJSON = String
-> (Text -> Parser TracingMode) -> Value -> Parser TracingMode
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"TracingMode" ((Text -> Parser TracingMode) -> Value -> Parser TracingMode)
-> (Text -> Parser TracingMode) -> Value -> Parser TracingMode
forall a b. (a -> b) -> a -> b
$ \case
    Text
"DetTracing" -> TracingMode -> Parser TracingMode
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TracingMode
DetTracing
    Text
"DoTracing" -> TracingMode -> Parser TracingMode
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TracingMode
DoTracing
    Text
"DoTracingAndBinds" -> TracingMode -> Parser TracingMode
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TracingMode
DoTracingAndBinds
    Text
x -> String -> Parser TracingMode
forall a. String -> Parser a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Parser TracingMode) -> String -> Parser TracingMode
forall a b. (a -> b) -> a -> b
$ String
"Not a valid encoding: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
x

{- | What logging level we want to use.

@since 1.6.0
-}
data LogLevel = LogInfo | LogDebug
  deriving stock
    ( -- | @since 1.6.0
      LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
/= :: LogLevel -> LogLevel -> Bool
Eq
    , -- | @since 1.6.0
      Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogLevel -> ShowS
showsPrec :: Int -> LogLevel -> ShowS
$cshow :: LogLevel -> String
show :: LogLevel -> String
$cshowList :: [LogLevel] -> ShowS
showList :: [LogLevel] -> ShowS
Show
    )

{- | We have a linear order of generality, so this instance reflects it:
@LogDebug@ is more general than @LogInfo@.

@since 1.6.0
-}
instance Ord LogLevel where
  -- Note: We write this by hand so someone re-ordering or adding 'arms' won't
  -- silently break this.
  LogLevel
ll1 <= :: LogLevel -> LogLevel -> Bool
<= LogLevel
ll2 = case LogLevel
ll1 of
    LogLevel
LogInfo -> Bool
True
    LogLevel
LogDebug -> case LogLevel
ll2 of
      LogLevel
LogDebug -> Bool
True
      LogLevel
_ -> Bool
False

{- | More general logging supersedes less general.

@since 1.6.0
-}
instance Semigroup LogLevel where
  <> :: LogLevel -> LogLevel -> LogLevel
(<>) = LogLevel -> LogLevel -> LogLevel
forall a. Ord a => a -> a -> a
max

-- | @since 1.6.0
instance Pretty LogLevel where
  pretty :: forall ann. LogLevel -> Doc ann
pretty = \case
    LogLevel
LogInfo -> Doc ann
"LogInfo"
    LogLevel
LogDebug -> Doc ann
"LogDebug"

-- | @since 1.6.0
instance ToJSON LogLevel where
  {-# INLINEABLE toJSON #-}
  toJSON :: LogLevel -> Value
toJSON =
    forall a. ToJSON a => a -> Value
toJSON @Text (Text -> Value) -> (LogLevel -> Text) -> LogLevel -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      LogLevel
LogInfo -> Text
"LogInfo"
      LogLevel
LogDebug -> Text
"LogDebug"
  {-# INLINEABLE toEncoding #-}
  toEncoding :: LogLevel -> Encoding
toEncoding =
    forall a. ToJSON a => a -> Encoding
toEncoding @Text (Text -> Encoding) -> (LogLevel -> Text) -> LogLevel -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      LogLevel
LogInfo -> Text
"LogInfo"
      LogLevel
LogDebug -> Text
"LogDebug"

-- | @since 1.6.0
instance FromJSON LogLevel where
  {-# INLINEABLE parseJSON #-}
  parseJSON :: Value -> Parser LogLevel
parseJSON = String -> (Text -> Parser LogLevel) -> Value -> Parser LogLevel
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"LogLevel" ((Text -> Parser LogLevel) -> Value -> Parser LogLevel)
-> (Text -> Parser LogLevel) -> Value -> Parser LogLevel
forall a b. (a -> b) -> a -> b
$ \case
    Text
"LogInfo" -> LogLevel -> Parser LogLevel
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure LogLevel
LogInfo
    Text
"LogDebug" -> LogLevel -> Parser LogLevel
forall a. a -> Parser a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure LogLevel
LogDebug
    Text
x -> String -> Parser LogLevel
forall a. String -> Parser a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> Parser LogLevel) -> String -> Parser LogLevel
forall a b. (a -> b) -> a -> b
$ String
"Not a valid encoding: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
x

{- | Configuration for Plutarch scripts at compile time. This indicates whether
we want to trace, and if so, under what log level and mode.

@since 1.6.0
-}
newtype Config = Config (Last (LogLevel, TracingMode))
  deriving
    ( -- | @since 1.6.0
      NonEmpty Config -> Config
Config -> Config -> Config
(Config -> Config -> Config)
-> (NonEmpty Config -> Config)
-> (forall b. Integral b => b -> Config -> Config)
-> Semigroup Config
forall b. Integral b => b -> Config -> Config
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Config -> Config -> Config
<> :: Config -> Config -> Config
$csconcat :: NonEmpty Config -> Config
sconcat :: NonEmpty Config -> Config
$cstimes :: forall b. Integral b => b -> Config -> Config
stimes :: forall b. Integral b => b -> Config -> Config
Semigroup
    , -- | @since 1.6.0
      Semigroup Config
Config
Semigroup Config =>
Config
-> (Config -> Config -> Config)
-> ([Config] -> Config)
-> Monoid Config
[Config] -> Config
Config -> Config -> Config
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Config
mempty :: Config
$cmappend :: Config -> Config -> Config
mappend :: Config -> Config -> Config
$cmconcat :: [Config] -> Config
mconcat :: [Config] -> Config
Monoid
    )
    via (Last (LogLevel, TracingMode))
  deriving stock
    ( -- | @since 1.6.0
      Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
/= :: Config -> Config -> Bool
Eq
    , -- | @since 1.6.0
      Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> String
show :: Config -> String
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show
    )

-- | @since 1.6.0
instance Pretty Config where
  pretty :: forall ann. Config -> Doc ann
pretty (Config (Last Maybe (LogLevel, TracingMode)
x)) = case Maybe (LogLevel, TracingMode)
x of
    Maybe (LogLevel, TracingMode)
Nothing -> Doc ann
"NoTracing"
    Just (LogLevel
ll, TracingMode
tm) -> Doc ann
"Tracing" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> LogLevel -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. LogLevel -> Doc ann
pretty LogLevel
ll Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TracingMode -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. TracingMode -> Doc ann
pretty TracingMode
tm

-- | @since 1.6.0
instance ToJSON Config where
  -- We serialize Config as if it were a sum type for consistency. We also label
  -- its fields (when present).
  {-# INLINEABLE toJSON #-}
  toJSON :: Config -> Value
toJSON =
    [Pair] -> Value
object ([Pair] -> Value) -> (Config -> [Pair]) -> Config -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Config
NoTracing -> [Key
"tag" Key -> Int -> Item [Pair]
forall v. ToJSON v => Key -> v -> Item [Pair]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
0 :: Int)]
      Tracing LogLevel
ll TracingMode
tm ->
        [ Key
"tag" Key -> Int -> Item [Pair]
forall v. ToJSON v => Key -> v -> Item [Pair]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
1 :: Int)
        , Key
"logLevel" Key -> LogLevel -> Item [Pair]
forall v. ToJSON v => Key -> v -> Item [Pair]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= LogLevel
ll
        , Key
"tracingMode" Key -> TracingMode -> Item [Pair]
forall v. ToJSON v => Key -> v -> Item [Pair]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TracingMode
tm
        ]
  {-# INLINEABLE toEncoding #-}
  toEncoding :: Config -> Encoding
toEncoding =
    Series -> Encoding
pairs (Series -> Encoding) -> (Config -> Series) -> Config -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Config
NoTracing -> Key
"tag" Key -> Int -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
0 :: Int)
      Tracing LogLevel
ll TracingMode
tm ->
        (Key
"tag" Key -> Int -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
1 :: Int))
          Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (Key
"logLevel" Key -> LogLevel -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= LogLevel
ll)
          Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (Key
"tracingMode" Key -> TracingMode -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TracingMode
tm)

-- | @since 1.6.0
instance FromJSON Config where
  parseJSON :: Value -> Parser Config
parseJSON = String -> (Object -> Parser Config) -> Value -> Parser Config
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Config" ((Object -> Parser Config) -> Value -> Parser Config)
-> (Object -> Parser Config) -> Value -> Parser Config
forall a b. (a -> b) -> a -> b
$ \Object
v ->
    Object
v Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tag" Parser Int -> (Int -> Parser Config) -> Parser Config
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Int
tag :: Int) -> case Int
tag of
      Int
0 -> Config -> Parser Config
forall a. a -> Parser a
forall (m :: Type -> Type) a. Monad m => a -> m a
return Config
NoTracing
      Int
1 -> LogLevel -> TracingMode -> Config
Tracing (LogLevel -> TracingMode -> Config)
-> Parser LogLevel -> Parser (TracingMode -> Config)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser LogLevel
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"logLevel" Parser (TracingMode -> Config)
-> Parser TracingMode -> Parser Config
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser TracingMode
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tracingMode"
      Int
_ -> String -> Parser Config
forall a. String -> Parser a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
"Invalid tag"

{- | If the config indicates that we want to trace, get its mode.

@since 1.6.0
-}
tracingMode :: Config -> Maybe TracingMode
tracingMode :: Config -> Maybe TracingMode
tracingMode (Config (Last Maybe (LogLevel, TracingMode)
x)) = (LogLevel, TracingMode) -> TracingMode
forall a b. (a, b) -> b
snd ((LogLevel, TracingMode) -> TracingMode)
-> Maybe (LogLevel, TracingMode) -> Maybe TracingMode
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LogLevel, TracingMode)
x

{- | If the config indicates that we want to trace, get its log level.

@since 1.6.0
-}
logLevel :: Config -> Maybe LogLevel
logLevel :: Config -> Maybe LogLevel
logLevel (Config (Last Maybe (LogLevel, TracingMode)
x)) = (LogLevel, TracingMode) -> LogLevel
forall a b. (a, b) -> a
fst ((LogLevel, TracingMode) -> LogLevel)
-> Maybe (LogLevel, TracingMode) -> Maybe LogLevel
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LogLevel, TracingMode)
x

{- | Pattern for the config that does no tracing (also the default).

@since 1.6.0
-}
pattern NoTracing :: Config
pattern $mNoTracing :: forall {r}. Config -> ((# #) -> r) -> ((# #) -> r) -> r
$bNoTracing :: Config
NoTracing <- Config (Last Nothing)
  where
    NoTracing = Last (LogLevel, TracingMode) -> Config
Config (Maybe (LogLevel, TracingMode) -> Last (LogLevel, TracingMode)
forall a. Maybe a -> Last a
Last Maybe (LogLevel, TracingMode)
forall a. Maybe a
Nothing)

{- | Pattern for a tracing config, with both its log level and mode.

@since 1.6.0
-}
pattern Tracing :: LogLevel -> TracingMode -> Config
pattern $mTracing :: forall {r}.
Config -> (LogLevel -> TracingMode -> r) -> ((# #) -> r) -> r
$bTracing :: LogLevel -> TracingMode -> Config
Tracing ll tm <- Config (Last (Just (ll, tm)))
  where
    Tracing LogLevel
ll TracingMode
tm = Last (LogLevel, TracingMode) -> Config
Config (Maybe (LogLevel, TracingMode) -> Last (LogLevel, TracingMode)
forall a. Maybe a -> Last a
Last ((LogLevel, TracingMode) -> Maybe (LogLevel, TracingMode)
forall a. a -> Maybe a
Just (LogLevel
ll, TracingMode
tm)))

{-# COMPLETE NoTracing, Tracing #-}

-- These are settings we need internally
data InternalConfig = InternalConfig
  { InternalConfig -> Bool
internalConfig'dataRecPMatchOptimization :: Bool
  , InternalConfig -> Bool
internalConfig'phoistAcyclicEvalCheck :: Bool
  }
  deriving stock (Int -> InternalConfig -> ShowS
[InternalConfig] -> ShowS
InternalConfig -> String
(Int -> InternalConfig -> ShowS)
-> (InternalConfig -> String)
-> ([InternalConfig] -> ShowS)
-> Show InternalConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InternalConfig -> ShowS
showsPrec :: Int -> InternalConfig -> ShowS
$cshow :: InternalConfig -> String
show :: InternalConfig -> String
$cshowList :: [InternalConfig] -> ShowS
showList :: [InternalConfig] -> ShowS
Show, InternalConfig -> InternalConfig -> Bool
(InternalConfig -> InternalConfig -> Bool)
-> (InternalConfig -> InternalConfig -> Bool) -> Eq InternalConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InternalConfig -> InternalConfig -> Bool
== :: InternalConfig -> InternalConfig -> Bool
$c/= :: InternalConfig -> InternalConfig -> Bool
/= :: InternalConfig -> InternalConfig -> Bool
Eq)

defaultInternalConfig :: InternalConfig
defaultInternalConfig :: InternalConfig
defaultInternalConfig = Bool -> Bool -> InternalConfig
InternalConfig Bool
True Bool
True

data TermEnv = TermEnv
  { TermEnv -> Word64
teDeBruijnDepth :: Word64
  , TermEnv -> InternalConfig
teInternalConfig :: InternalConfig
  , TermEnv -> Config
teConfig :: Config
  }

{- $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 :: S -> Type) = Term
  { forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm :: ExceptT Text (RWS TermEnv () ()) TermResult
  }

type role Term nominal nominal

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

data PDelayed (a :: S -> Type) (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 :: S -> Type) (b :: S -> Type).
(Term s a -> Term s b) -> Term s (a :--> b)
plam' Term s a -> Term s b
f = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s (a :--> b)
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s (a :--> b))
-> ExceptT Text (RWS TermEnv () ()) TermResult -> Term s (a :--> b)
forall a b. (a -> b) -> a -> b
$ do
  Word64
i <- (TermEnv -> Word64) -> ExceptT Text (RWS TermEnv () ()) Word64
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks TermEnv -> Word64
teDeBruijnDepth
  let v :: Term s a
v = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall a b. (a -> b) -> a -> b
$ do
        Word64
j <- (TermEnv -> Word64) -> ExceptT Text (RWS TermEnv () ()) Word64
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks TermEnv -> Word64
teDeBruijnDepth
        TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (RawTerm -> TermResult)
-> RawTerm
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> TermResult
mkTermRes (RawTerm -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> RawTerm -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ Word64 -> RawTerm
RVar (Word64
j Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- (Word64
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1))
  TermEnv
originalEnv <- ExceptT Text (RWS TermEnv () ()) TermEnv
forall r (m :: Type -> Type). MonadReader r m => m r
ask
  let newEnv :: TermEnv
newEnv = TermEnv
originalEnv {teDeBruijnDepth = i + 1}
  TermResult
res <- (TermEnv -> TermEnv)
-> ExceptT Text (RWS TermEnv () ()) TermResult
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall a.
(TermEnv -> TermEnv)
-> ExceptT Text (RWS TermEnv () ()) a
-> ExceptT Text (RWS TermEnv () ()) a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
local (TermEnv -> TermEnv -> TermEnv
forall a b. a -> b -> a
const TermEnv
newEnv) (Term s b -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v))
  TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (TermResult -> TermResult)
-> TermResult
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> TermResult
go (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ TermResult
res
  where
    go :: TermResult -> TermResult
    go :: TermResult -> TermResult
go res :: TermResult
res@(TermResult RawTerm
t [HoistedTerm]
_) =
      let newLambda :: TermResult
newLambda = (RawTerm -> RawTerm) -> TermResult -> TermResult
mapTerm (Word64 -> RawTerm -> RawTerm
RLamAbs Word64
0) TermResult
res
       in case RawTerm
t of
            -- eta-reduce for arity 1
            RApply RawTerm
t' [RVar Word64
0] -> case RawTerm -> Maybe Word64
getArity RawTerm
t' of
              Maybe Word64
Nothing -> TermResult
newLambda
              Just Word64
_ -> TermResult
res {getTerm = t'}
            -- eta-reduce for arity 2 + n
            RLamAbs Word64
n (RApply RawTerm
t' [RawTerm]
args) -> case RawTerm -> Maybe Word64
getArity RawTerm
t' of
              Maybe Word64
Nothing -> TermResult
newLambda
              Just Word64
n' -> case [RawTerm] -> Maybe [Word64]
unpackArgs [RawTerm]
args of
                Just [Word64]
args' ->
                  if [Word64]
args' [Word64] -> [Word64] -> Bool
forall a. Eq a => a -> a -> Bool
== [Word64
Item [Word64]
0 .. Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1] Bool -> Bool -> Bool
&& Word64
n' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1
                    then TermResult
res {getTerm = t'}
                    else TermResult
newLambda
                Maybe [Word64]
_ -> TermResult
newLambda
            -- increment arity
            RLamAbs Word64
n RawTerm
t' -> TermResult
res {getTerm = RLamAbs (n + 1) t'}
            -- New lambda
            RawTerm
_ -> TermResult
newLambda
    -- Arities are one less than they should be. Thus, 'Nothing' means 'arity
    -- 0', 'Just 0' means 'arity 1', etc.
    getArity :: RawTerm -> Maybe Word64
    getArity :: RawTerm -> Maybe Word64
getArity = \case
      RHoisted (HoistedTerm Int
_ (RLamAbs Word64
n RawTerm
_)) -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
n
      RHoisted (HoistedTerm Int
_ RawTerm
t) -> RawTerm -> Maybe Word64
getArityBuiltin RawTerm
t
      RawTerm
t -> RawTerm -> Maybe Word64
getArityBuiltin RawTerm
t
    unpackArgs :: [RawTerm] -> Maybe [Word64]
    unpackArgs :: [RawTerm] -> Maybe [Word64]
unpackArgs = (RawTerm -> Maybe Word64) -> [RawTerm] -> Maybe [Word64]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\case RVar Word64
n -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
n; RawTerm
_ -> Maybe Word64
forall a. Maybe a
Nothing)
    -- Note (Koz, 14/04/2026): It is essential that _all_ Plutus Core builtins
    -- are given arities here. Thus, we keep them in a similar order to
    -- PlutusCore.Default.Builtins. However, as some of these builtins are
    -- polymorphic, we have to look inside an `RForce` to 'see' them. Thus,
    -- these get put in their own case branch, but in the same order as they
    -- would appear otherwise.
    getArityBuiltin :: RawTerm -> Maybe Word64
    getArityBuiltin :: RawTerm -> Maybe Word64
getArityBuiltin = \case
      RBuiltin DefaultFun
t -> case DefaultFun
t of
        -- Integers
        DefaultFun
PLC.AddInteger -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.SubtractInteger -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.MultiplyInteger -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.DivideInteger -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.QuotientInteger -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.RemainderInteger -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.ModInteger -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.EqualsInteger -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.LessThanEqualsInteger -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        -- Bytestrings
        DefaultFun
PLC.AppendByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.ConsByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.SliceByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        DefaultFun
PLC.LengthOfByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.IndexByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.EqualsByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.LessThanByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.LessThanEqualsByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        -- Cryptography and hashes
        DefaultFun
PLC.Sha2_256 -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.Sha3_256 -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.Blake2b_256 -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.VerifyEd25519Signature -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        DefaultFun
PLC.VerifyEcdsaSecp256k1Signature -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        DefaultFun
PLC.VerifySchnorrSecp256k1Signature -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        -- Strings
        DefaultFun
PLC.AppendString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.EqualsString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.EncodeUtf8 -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.DecodeUtf8 -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        -- Data
        DefaultFun
PLC.ConstrData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.MapData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.ListData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.IData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.BData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.UnConstrData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.UnMapData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.UnListData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.UnIData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.UnBData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.EqualsData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.SerialiseData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        -- Misc monomorphized constructors
        DefaultFun
PLC.MkPairData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.MkNilData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.MkNilPairData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        -- BLS operations
        -- G1
        DefaultFun
PLC.Bls12_381_G1_add -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.Bls12_381_G1_neg -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.Bls12_381_G1_scalarMul -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.Bls12_381_G1_equal -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.Bls12_381_G1_hashToGroup -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.Bls12_381_G1_compress -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.Bls12_381_G1_uncompress -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        -- G2
        DefaultFun
PLC.Bls12_381_G2_add -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.Bls12_381_G2_neg -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.Bls12_381_G2_scalarMul -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.Bls12_381_G2_equal -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.Bls12_381_G2_hashToGroup -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.Bls12_381_G2_compress -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.Bls12_381_G2_uncompress -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        -- Pairing
        DefaultFun
PLC.Bls12_381_millerLoop -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.Bls12_381_mulMlResult -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.Bls12_381_finalVerify -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        -- Keccak, Blake
        DefaultFun
PLC.Keccak_256 -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.Blake2b_224 -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        -- Conversions
        DefaultFun
PLC.IntegerToByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        DefaultFun
PLC.ByteStringToInteger -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        -- Logical
        DefaultFun
PLC.AndByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        DefaultFun
PLC.OrByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        DefaultFun
PLC.XorByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        DefaultFun
PLC.ComplementByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.ReadBit -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.WriteBits -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        DefaultFun
PLC.ReplicateByte -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        -- Bitwise
        DefaultFun
PLC.ShiftByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.RotateByteString -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.CountSetBits -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.FindFirstSetBit -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        -- Ripemd
        DefaultFun
PLC.Ripemd_160 -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        -- Expmod
        DefaultFun
PLC.ExpModInteger -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        -- Multi-scalar mult
        DefaultFun
PLC.Bls12_381_G1_multiScalarMul -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.Bls12_381_G2_multiScalarMul -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        -- Value
        DefaultFun
PLC.InsertCoin -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
3
        DefaultFun
PLC.LookupCoin -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        DefaultFun
PLC.UnionValue -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.ValueContains -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.ValueData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.UnValueData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.ScaleValue -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
_ -> Maybe Word64
forall a. Maybe a
Nothing
      RForce (RBuiltin DefaultFun
t) -> case DefaultFun
t of
        -- Bool
        DefaultFun
PLC.IfThenElse -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        -- Unit
        DefaultFun
PLC.ChooseUnit -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        -- Tracing
        DefaultFun
PLC.Trace -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        -- Pairs
        DefaultFun
PLC.FstPair -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.SndPair -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        -- Lists
        DefaultFun
PLC.ChooseList -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
        DefaultFun
PLC.MkCons -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
PLC.HeadList -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.TailList -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.NullList -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        -- Data
        DefaultFun
PLC.ChooseData -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
5
        -- Drop
        DefaultFun
PLC.DropList -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        -- Arrays
        DefaultFun
PLC.LengthOfArray -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.ListToArray -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
        DefaultFun
PLC.IndexArray -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
        DefaultFun
_ -> Maybe Word64
forall a. Maybe a
Nothing
      RawTerm
_ -> Maybe Word64
forall a. Maybe a
Nothing

{- |
  Let bindings.

  This is approximately 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 :: S -> Type) (b :: S -> Type).
Term s a -> (Term s a -> Term s b) -> Term s b
plet Term s a
v Term s a -> Term s b
f = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s b
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s b)
-> ExceptT Text (RWS TermEnv () ()) TermResult -> Term s b
forall a b. (a -> b) -> a -> b
$ do
  TermResult RawTerm
vt [HoistedTerm]
vDeps <- Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm Term s a
v
  let doInline :: ExceptT Text (RWS TermEnv () ()) TermResult
doInline = Term s b -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v)
      noInline :: TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
noInline (TermResult RawTerm
ft [HoistedTerm]
fDeps) = case RawTerm
ft of
        RawTerm
RError -> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (RawTerm -> TermResult)
-> RawTerm
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> TermResult
mkTermRes (RawTerm -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> RawTerm -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm
RError
        RLamAbs Word64
0 (RVar Word64
0) -> Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm Term s a
v
        RHoisted (HoistedTerm Int
_ (RLamAbs Word64
0 (RVar Word64
0))) -> Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm Term s a
v
        RApply RawTerm
xl [RawTerm]
xr -> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> ([HoistedTerm] -> TermResult)
-> [HoistedTerm]
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> [HoistedTerm] -> TermResult
TermResult (RawTerm -> [RawTerm] -> RawTerm
RApply RawTerm
xl (RawTerm
vt RawTerm -> [RawTerm] -> [RawTerm]
forall a. a -> [a] -> [a]
: [RawTerm]
xr)) ([HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> [HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ [HoistedTerm]
fDeps [HoistedTerm] -> [HoistedTerm] -> [HoistedTerm]
forall a. Semigroup a => a -> a -> a
<> [HoistedTerm]
vDeps
        RawTerm
_ -> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> [HoistedTerm] -> TermResult
TermResult (RawTerm -> RawTerm -> RawTerm
RLet RawTerm
vt RawTerm
ft) ([HoistedTerm]
fDeps [HoistedTerm] -> [HoistedTerm] -> [HoistedTerm]
forall a. Semigroup a => a -> a -> a
<> [HoistedTerm]
vDeps)
  case RawTerm
vt of
    -- Inline sufficiently small terms in WHNF
    RVar Word64
_ -> ExceptT Text (RWS TermEnv () ()) TermResult
doInline
    RBuiltin DefaultFun
_ -> ExceptT Text (RWS TermEnv () ()) TermResult
doInline
    RHoisted HoistedTerm
_ -> ExceptT Text (RWS TermEnv () ()) TermResult
doInline
    RawTerm
RError -> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (RawTerm -> TermResult)
-> RawTerm
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> TermResult
mkTermRes (RawTerm -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> RawTerm -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm
RError
    RawTerm
_ -> Term s (a :--> b) -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm ((Term s a -> Term s b) -> Term s (a :--> b)
forall (s :: S) (a :: S -> Type) (b :: S -> Type).
(Term s a -> Term s b) -> Term s (a :--> b)
plam' Term s a -> Term s b
f) ExceptT Text (RWS TermEnv () ()) TermResult
-> (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b.
ExceptT Text (RWS TermEnv () ()) a
-> (a -> ExceptT Text (RWS TermEnv () ()) b)
-> ExceptT Text (RWS TermEnv () ()) b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
noInline

pthrow :: HasCallStack => Text -> Term s a
pthrow :: forall (s :: S) (a :: S -> Type). HasCallStack => Text -> Term s a
pthrow Text
msg = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> (Text -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> Text
-> Term s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. Text -> ExceptT Text (RWS TermEnv () ()) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (Text -> Term s a) -> Text -> Term s a
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString (CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

-- | Lambda Application.
papp :: Term s (a :--> b) -> Term s a -> Term s b
papp :: forall (s :: S) (a :: S -> Type) (b :: S -> Type).
Term s (a :--> b) -> Term s a -> Term s b
papp Term s (a :--> b)
x Term s a
y = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s b
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s b)
-> ExceptT Text (RWS TermEnv () ()) TermResult -> Term s b
forall a b. (a -> b) -> a -> b
$ do
  TermResult RawTerm
ft [HoistedTerm]
fDeps <- Term s (a :--> b) -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm Term s (a :--> b)
x
  TermResult RawTerm
xt [HoistedTerm]
xDeps <- Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm Term s a
y
  case (RawTerm
ft, RawTerm
xt) of
    -- Applying anything to an error is an error.
    (RawTerm
RError, RawTerm
_) -> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (RawTerm -> TermResult)
-> RawTerm
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> TermResult
mkTermRes (RawTerm -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> RawTerm -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm
RError
    -- Applying an error to anything is an error.
    (RawTerm
_, RawTerm
RError) -> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (RawTerm -> TermResult)
-> RawTerm
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> TermResult
mkTermRes (RawTerm -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> RawTerm -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm
RError
    -- Applying anything to `id` does nothing.
    (RLamAbs Word64
0 (RVar Word64
0), RawTerm
_) -> Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm Term s a
y
    (RHoisted (HoistedTerm Int
_ (RLamAbs Word64
0 (RVar Word64
0))), RawTerm
_) -> Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm Term s a
y
    -- Append an argument to an existing application.
    (RApply RawTerm
func [RawTerm]
args, RawTerm
_) -> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> ([HoistedTerm] -> TermResult)
-> [HoistedTerm]
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> [HoistedTerm] -> TermResult
TermResult (RawTerm -> [RawTerm] -> RawTerm
RApply RawTerm
func (RawTerm
xt RawTerm -> [RawTerm] -> [RawTerm]
forall a. a -> [a] -> [a]
: [RawTerm]
args)) ([HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> [HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ [HoistedTerm]
fDeps [HoistedTerm] -> [HoistedTerm] -> [HoistedTerm]
forall a. Semigroup a => a -> a -> a
<> [HoistedTerm]
xDeps
    -- New application.
    (RawTerm, RawTerm)
_ -> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> ([HoistedTerm] -> TermResult)
-> [HoistedTerm]
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> [HoistedTerm] -> TermResult
TermResult (RawTerm -> [RawTerm] -> RawTerm
RApply RawTerm
ft [Item [RawTerm]
RawTerm
xt]) ([HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> [HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ [HoistedTerm]
fDeps [HoistedTerm] -> [HoistedTerm] -> [HoistedTerm]
forall a. Semigroup a => a -> a -> a
<> [HoistedTerm]
xDeps

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

{- |
  Plutus \'force\',
  used to force evaluation of 'PDelayed' terms.
-}
pforce :: Term s (PDelayed a) -> Term s a
pforce :: forall (s :: S) (a :: S -> Type). Term s (PDelayed a) -> Term s a
pforce = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> (Term s (PDelayed a)
    -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> Term s (PDelayed a)
-> Term s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TermResult -> TermResult)
-> ExceptT Text (RWS TermEnv () ()) TermResult
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b.
(a -> b)
-> ExceptT Text (RWS TermEnv () ()) a
-> ExceptT Text (RWS TermEnv () ()) b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap TermResult -> TermResult
go (ExceptT Text (RWS TermEnv () ()) TermResult
 -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (Term s (PDelayed a)
    -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> Term s (PDelayed a)
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term s (PDelayed a) -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm
  where
    go :: TermResult -> TermResult
    go :: TermResult -> TermResult
go res :: TermResult
res@(TermResult RawTerm
t [HoistedTerm]
deps) = case RawTerm
t of
      -- `force` cancels `delay`
      RDelay RawTerm
t' -> RawTerm -> [HoistedTerm] -> TermResult
TermResult RawTerm
t' [HoistedTerm]
deps
      RawTerm
_ -> (RawTerm -> RawTerm) -> TermResult -> TermResult
mapTerm RawTerm -> RawTerm
RForce TermResult
res

{- |
  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 :: S -> Type). Term s a
perror = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> (RawTerm -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> RawTerm
-> Term s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (RawTerm -> TermResult)
-> RawTerm
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> TermResult
mkTermRes (RawTerm -> Term s a) -> RawTerm -> Term s a
forall a b. (a -> b) -> a -> b
$ RawTerm
RError

{- |
Same as @perror@ except this holds integer id for AST look-ahead.

This can be used to "tag" branch and generate AST first to see if that branch is actually used or not,
allowing optimization cutting unused branches. For more detailed uscases, check @pmatchDataRec@.
-}
pplaceholder :: Integer -> Term s a
pplaceholder :: forall (s :: S) (a :: S -> Type). Integer -> Term s a
pplaceholder = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> (Integer -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> Integer
-> Term s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (Integer -> TermResult)
-> Integer
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> TermResult
mkTermRes (RawTerm -> TermResult)
-> (Integer -> RawTerm) -> Integer -> TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> RawTerm
RPlaceHolder

pgetConfig :: (Config -> Term s a) -> Term s a
pgetConfig :: forall (s :: S) (a :: S -> Type). (Config -> Term s a) -> Term s a
pgetConfig Config -> Term s a
f = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall a b. (a -> b) -> a -> b
$ do
  Config
conf <- (TermEnv -> Config) -> ExceptT Text (RWS TermEnv () ()) Config
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks TermEnv -> Config
teConfig
  Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm (Config -> Term s a
f Config
conf)

pgetInternalConfig :: (InternalConfig -> Term s a) -> Term s a
pgetInternalConfig :: forall (s :: S) (a :: S -> Type).
(InternalConfig -> Term s a) -> Term s a
pgetInternalConfig InternalConfig -> Term s a
f = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall a b. (a -> b) -> a -> b
$ do
  InternalConfig
iconf <- (TermEnv -> InternalConfig)
-> ExceptT Text (RWS TermEnv () ()) InternalConfig
forall r (m :: Type -> Type) a. MonadReader r m => (r -> a) -> m a
asks TermEnv -> InternalConfig
teInternalConfig
  Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm (InternalConfig -> Term s a
f InternalConfig
iconf)

pwithInternalConfig :: InternalConfig -> Term s a -> Term s a
pwithInternalConfig :: forall (s :: S) (a :: S -> Type).
InternalConfig -> Term s a -> Term s a
pwithInternalConfig InternalConfig
cfg Term s a
t = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall a b. (a -> b) -> a -> b
$ (TermEnv -> TermEnv)
-> ExceptT Text (RWS TermEnv () ()) TermResult
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall a.
(TermEnv -> TermEnv)
-> ExceptT Text (RWS TermEnv () ()) a
-> ExceptT Text (RWS TermEnv () ()) a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
local (\TermEnv
env -> TermEnv
env {teInternalConfig = cfg}) (Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm Term s a
t)

{- |
  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 :: forall b a s. Term s a -> Term s b
punsafeCoerce :: forall (b :: S -> Type) (a :: S -> Type) (s :: S).
Term s a -> Term s b
punsafeCoerce (Term ExceptT Text (RWS TermEnv () ()) TermResult
x) = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s b
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term ExceptT Text (RWS TermEnv () ()) TermResult
x

punsafeBuiltin :: UPLC.DefaultFun -> Term s a
punsafeBuiltin :: forall (s :: S) (a :: S -> Type). DefaultFun -> Term s a
punsafeBuiltin = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> (DefaultFun -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> DefaultFun
-> Term s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (DefaultFun -> TermResult)
-> DefaultFun
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> TermResult
mkTermRes (RawTerm -> TermResult)
-> (DefaultFun -> RawTerm) -> DefaultFun -> TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultFun -> RawTerm
RBuiltin

punsafeConstantInternal :: Some (ValueOf PLC.DefaultUni) -> Term s a
punsafeConstantInternal :: forall (s :: S) (a :: S -> Type).
Some @Type (ValueOf DefaultUni) -> Term s a
punsafeConstantInternal Some @Type (ValueOf DefaultUni)
c = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall a b. (a -> b) -> a -> b
$ do
  let hoisted :: HoistedTerm
hoisted = Int -> RawTerm -> HoistedTerm
HoistedTerm (RawTerm -> Int
forall a. Hashable a => a -> Int
hash (RawTerm -> Int)
-> (Some @Type (ValueOf DefaultUni) -> RawTerm)
-> Some @Type (ValueOf DefaultUni)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Some @Type (ValueOf DefaultUni) -> RawTerm
RConstant (Some @Type (ValueOf DefaultUni) -> Int)
-> Some @Type (ValueOf DefaultUni) -> Int
forall a b. (a -> b) -> a -> b
$ Some @Type (ValueOf DefaultUni)
c) (Some @Type (ValueOf DefaultUni) -> RawTerm
RConstant Some @Type (ValueOf DefaultUni)
c)
   in TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> [HoistedTerm] -> TermResult
TermResult (HoistedTerm -> RawTerm
RHoisted HoistedTerm
hoisted) [Item [HoistedTerm]
HoistedTerm
hoisted]

-- TODO: Give proper error message when mutually recursive.
phoistAcyclic :: forall (a :: S -> Type) (s :: S). HasCallStack => (forall (s' :: S). Term s' a) -> Term s a
phoistAcyclic :: forall (a :: S -> Type) (s :: S).
HasCallStack =>
(forall (s' :: S). Term s' a) -> Term s a
phoistAcyclic forall (s' :: S). Term s' a
t = (InternalConfig -> Term s a) -> Term s a
forall (s :: S) (a :: S -> Type).
(InternalConfig -> Term s a) -> Term s a
pgetInternalConfig ((InternalConfig -> Term s a) -> Term s a)
-> (InternalConfig -> Term s a) -> Term s a
forall a b. (a -> b) -> a -> b
$ \InternalConfig {$sel:internalConfig'phoistAcyclicEvalCheck:InternalConfig :: InternalConfig -> Bool
internalConfig'phoistAcyclicEvalCheck = Bool
chk} ->
  ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall a b. (a -> b) -> a -> b
$ do
    tr :: TermResult
tr@(TermResult RawTerm
t' [HoistedTerm]
deps) <- (TermEnv -> TermEnv)
-> ExceptT Text (RWS TermEnv () ()) TermResult
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall a.
(TermEnv -> TermEnv)
-> ExceptT Text (RWS TermEnv () ()) a
-> ExceptT Text (RWS TermEnv () ()) a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
local (\TermEnv
e -> TermEnv
e {teDeBruijnDepth = 0}) (Term (Any @S) a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm Term (Any @S) a
forall (s' :: S). Term s' a
t)
    case RawTerm
t' of
      RBuiltin DefaultFun
_ -> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TermResult
tr
      RawTerm
_ ->
        if Bool
chk
          then case Script
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      Script,
    ExBudget, [Text])
evalScript (Script
 -> (Either
       (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
       Script,
     ExBudget, [Text]))
-> (TermResult -> Script)
-> TermResult
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      Script,
    ExBudget, [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program DeBruijn DefaultUni DefaultFun () -> Script
Script (Program DeBruijn DefaultUni DefaultFun () -> Script)
-> (TermResult -> Program DeBruijn DefaultUni DefaultFun ())
-> TermResult
-> Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ()
-> Version
-> Term DeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Version -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program () Version
uplcVersion (Term DeBruijn DefaultUni DefaultFun ()
 -> Program DeBruijn DefaultUni DefaultFun ())
-> (TermResult -> Term DeBruijn DefaultUni DefaultFun ())
-> TermResult
-> Program DeBruijn DefaultUni DefaultFun ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> Term DeBruijn DefaultUni DefaultFun ()
compile' (TermResult
 -> (Either
       (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
       Script,
     ExBudget, [Text]))
-> TermResult
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      Script,
    ExBudget, [Text])
forall a b. (a -> b) -> a -> b
$ TermResult
tr of
            (Left CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
e, ExBudget
_, [Text]
_) -> Term (Any @S) (Any @(S -> Type))
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm (Term (Any @S) (Any @(S -> Type))
 -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (Text -> Term (Any @S) (Any @(S -> Type)))
-> Text
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Term (Any @S) (Any @(S -> Type))
forall (s :: S) (a :: S -> Type). HasCallStack => Text -> Term s a
pthrow (Text -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> Text -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ Text
"Hoisted term errors! " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> String
forall a. Show a => a -> String
show CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
e)
            (Right Script
_, ExBudget
_, [Text]
_) ->
              let hoisted :: HoistedTerm
hoisted = Int -> RawTerm -> HoistedTerm
HoistedTerm (RawTerm -> Int
forall a. Hashable a => a -> Int
hash RawTerm
t') RawTerm
t'
               in TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> ([HoistedTerm] -> TermResult)
-> [HoistedTerm]
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> [HoistedTerm] -> TermResult
TermResult (HoistedTerm -> RawTerm
RHoisted HoistedTerm
hoisted) ([HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> [HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ HoistedTerm
hoisted HoistedTerm -> [HoistedTerm] -> [HoistedTerm]
forall a. a -> [a] -> [a]
: [HoistedTerm]
deps
          else
            let hoisted :: HoistedTerm
hoisted = Int -> RawTerm -> HoistedTerm
HoistedTerm (RawTerm -> Int
forall a. Hashable a => a -> Int
hash RawTerm
t') RawTerm
t'
             in TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> ([HoistedTerm] -> TermResult)
-> [HoistedTerm]
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> [HoistedTerm] -> TermResult
TermResult (HoistedTerm -> RawTerm
RHoisted HoistedTerm
hoisted) ([HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> [HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ HoistedTerm
hoisted HoistedTerm -> [HoistedTerm] -> [HoistedTerm]
forall a. a -> [a] -> [a]
: [HoistedTerm]
deps

-- Couldn't find a definition for this in plutus-core
subst ::
  Word64 ->
  (Word64 -> UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) ->
  UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () ->
  UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()
subst :: Word64
-> (Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x (UPLC.Apply () Term DeBruijn DefaultUni DefaultFun ()
yx Term DeBruijn DefaultUni DefaultFun ()
yy) = ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
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 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x Term DeBruijn DefaultUni DefaultFun ()
yx) (Word64
-> (Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x Term DeBruijn DefaultUni DefaultFun ()
yy)
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x (UPLC.LamAbs () DeBruijn
name Term DeBruijn DefaultUni DefaultFun ()
y) = ()
-> DeBruijn
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
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 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst (Word64
idx Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x Term DeBruijn DefaultUni DefaultFun ()
y)
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x (UPLC.Delay () Term DeBruijn DefaultUni DefaultFun ()
y) = ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Delay () (Word64
-> (Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x Term DeBruijn DefaultUni DefaultFun ()
y)
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x (UPLC.Force () Term DeBruijn DefaultUni DefaultFun ()
y) = ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Force () (Word64
-> (Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x Term DeBruijn DefaultUni DefaultFun ()
y)
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x y :: Term DeBruijn DefaultUni DefaultFun ()
y@(UPLC.Var () (DeBruijn (Index Word64
idx'))) =
  case Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word64
idx Word64
idx' of
    Ordering
EQ -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x Word64
idx
    Ordering
GT -> Term DeBruijn DefaultUni DefaultFun ()
y
    Ordering
LT -> () -> DeBruijn -> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann
UPLC.Var () (Index -> DeBruijn
DeBruijn (Index -> DeBruijn) -> (Word64 -> Index) -> Word64 -> DeBruijn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Index
Index (Word64 -> DeBruijn) -> Word64 -> DeBruijn
forall a b. (a -> b) -> a -> b
$ Word64
idx' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1)
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x (UPLC.Case () Term DeBruijn DefaultUni DefaultFun ()
t Vector (Term DeBruijn DefaultUni DefaultFun ())
handlers) = ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Vector (Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann
-> Term name uni fun ann
-> Vector (Term name uni fun ann)
-> Term name uni fun ann
UPLC.Case () (Word64
-> (Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x Term DeBruijn DefaultUni DefaultFun ()
t) ((Term DeBruijn DefaultUni DefaultFun ()
 -> Term DeBruijn DefaultUni DefaultFun ())
-> Vector (Term DeBruijn DefaultUni DefaultFun ())
-> Vector (Term DeBruijn DefaultUni DefaultFun ())
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64
-> (Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x) Vector (Term DeBruijn DefaultUni DefaultFun ())
handlers)
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x (UPLC.Constr () Word64
w [Term DeBruijn DefaultUni DefaultFun ()]
fields) = ()
-> Word64
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Word64 -> [Term name uni fun ann] -> Term name uni fun ann
UPLC.Constr () Word64
w ((Term DeBruijn DefaultUni DefaultFun ()
 -> Term DeBruijn DefaultUni DefaultFun ())
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> [Term DeBruijn DefaultUni DefaultFun ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64
-> (Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst Word64
idx Word64 -> Term DeBruijn DefaultUni DefaultFun ()
x) [Term DeBruijn DefaultUni DefaultFun ()]
fields)
subst Word64
_ Word64 -> Term DeBruijn DefaultUni DefaultFun ()
_ y :: Term DeBruijn DefaultUni DefaultFun ()
y@(UPLC.Constant () Some @Type (ValueOf DefaultUni)
_) = Term DeBruijn DefaultUni DefaultFun ()
y
subst Word64
_ Word64 -> Term DeBruijn DefaultUni DefaultFun ()
_ y :: Term DeBruijn DefaultUni DefaultFun ()
y@(UPLC.Builtin () DefaultFun
_) = Term DeBruijn DefaultUni DefaultFun ()
y
subst Word64
_ Word64 -> Term DeBruijn DefaultUni DefaultFun ()
_ y :: Term DeBruijn DefaultUni DefaultFun ()
y@(UPLC.Error ()) = Term DeBruijn DefaultUni DefaultFun ()
y

rawTermToUPLC ::
  (HoistedTerm -> Word64 -> UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) ->
  Word64 ->
  RawTerm ->
  UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()
rawTermToUPLC :: (HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
_ Word64
_ (RVar Word64
i) = () -> DeBruijn -> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann
UPLC.Var () (Index -> DeBruijn
DeBruijn (Index -> DeBruijn) -> (Word64 -> Index) -> Word64 -> DeBruijn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Index
Index (Word64 -> DeBruijn) -> Word64 -> DeBruijn
forall a b. (a -> b) -> a -> b
$ Word64
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) -- Why the fuck does it start from 1 and not 0?
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RLamAbs Word64
n RawTerm
t) =
  ((Term DeBruijn DefaultUni DefaultFun ()
  -> Term DeBruijn DefaultUni DefaultFun ())
 -> Term DeBruijn DefaultUni DefaultFun ()
 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> [Term DeBruijn DefaultUni DefaultFun ()
    -> Term DeBruijn DefaultUni DefaultFun ()]
-> Term DeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Term DeBruijn DefaultUni DefaultFun ()
 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
($) ((HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m (Word64
l Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) RawTerm
t) (Int
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> Term DeBruijn DefaultUni DefaultFun ())
-> [Term DeBruijn DefaultUni DefaultFun ()
    -> Term DeBruijn DefaultUni DefaultFun ()]
forall a. Int -> a -> [a]
replicate (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) ((Term DeBruijn DefaultUni DefaultFun ()
  -> Term DeBruijn DefaultUni DefaultFun ())
 -> [Term DeBruijn DefaultUni DefaultFun ()
     -> Term DeBruijn DefaultUni DefaultFun ()])
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> Term DeBruijn DefaultUni DefaultFun ())
-> [Term DeBruijn DefaultUni DefaultFun ()
    -> Term DeBruijn DefaultUni DefaultFun ()]
forall a b. (a -> b) -> a -> b
$ ()
-> DeBruijn
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann -> Term name uni fun ann
UPLC.LamAbs () (Index -> DeBruijn
DeBruijn (Index -> DeBruijn) -> (Word64 -> Index) -> Word64 -> DeBruijn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Index
Index (Word64 -> DeBruijn) -> Word64 -> DeBruijn
forall a b. (a -> b) -> a -> b
$ Word64
0))
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RApply RawTerm
x [RawTerm]
y) =
  let
    inline' ::
      Word64 ->
      UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () ->
      [UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()] ->
      (UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun (), [UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()])
    inline' :: Word64
-> Term DeBruijn DefaultUni DefaultFun ()
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> (Term DeBruijn DefaultUni DefaultFun (),
    [Term DeBruijn DefaultUni DefaultFun ()])
inline' Word64
_ Term DeBruijn DefaultUni DefaultFun ()
func [] = (Term DeBruijn DefaultUni DefaultFun ()
func, [])
    inline' Word64
target (UPLC.LamAbs () DeBruijn
_ Term DeBruijn DefaultUni DefaultFun ()
body) ((UPLC.Var () (DeBruijn (Index Word64
idx))) : [Term DeBruijn DefaultUni DefaultFun ()]
args) =
      Word64
-> Term DeBruijn DefaultUni DefaultFun ()
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> (Term DeBruijn DefaultUni DefaultFun (),
    [Term DeBruijn DefaultUni DefaultFun ()])
inline' Word64
target (Word64
-> (Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst Word64
1 (\Word64
lvl -> () -> DeBruijn -> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann
UPLC.Var () (Index -> DeBruijn
DeBruijn (Word64 -> Index
Index (Word64 -> Index) -> Word64 -> Index
forall a b. (a -> b) -> a -> b
$ Word64
idx Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
lvl Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
target))) Term DeBruijn DefaultUni DefaultFun ()
body) [Term DeBruijn DefaultUni DefaultFun ()]
args
    inline' Word64
target (UPLC.LamAbs () DeBruijn
_ Term DeBruijn DefaultUni DefaultFun ()
body) (arg :: Term DeBruijn DefaultUni DefaultFun ()
arg@UPLC.Builtin {} : [Term DeBruijn DefaultUni DefaultFun ()]
args) =
      Word64
-> Term DeBruijn DefaultUni DefaultFun ()
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> (Term DeBruijn DefaultUni DefaultFun (),
    [Term DeBruijn DefaultUni DefaultFun ()])
inline' Word64
target (Word64
-> (Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst Word64
1 (Term DeBruijn DefaultUni DefaultFun ()
-> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
forall a b. a -> b -> a
const Term DeBruijn DefaultUni DefaultFun ()
arg) Term DeBruijn DefaultUni DefaultFun ()
body) [Term DeBruijn DefaultUni DefaultFun ()]
args
    inline' Word64
target (UPLC.LamAbs () DeBruijn
_ Term DeBruijn DefaultUni DefaultFun ()
body) (arg :: Term DeBruijn DefaultUni DefaultFun ()
arg@UPLC.Constant {} : [Term DeBruijn DefaultUni DefaultFun ()]
args) =
      Word64
-> Term DeBruijn DefaultUni DefaultFun ()
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> (Term DeBruijn DefaultUni DefaultFun (),
    [Term DeBruijn DefaultUni DefaultFun ()])
inline' Word64
target (Word64
-> (Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
subst Word64
1 (Term DeBruijn DefaultUni DefaultFun ()
-> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
forall a b. a -> b -> a
const Term DeBruijn DefaultUni DefaultFun ()
arg) Term DeBruijn DefaultUni DefaultFun ()
body) [Term DeBruijn DefaultUni DefaultFun ()]
args
    -- inline' _ func@(UPLC.LamAbs () _ _ ) args = (func, args) -- This will skip inlining after first encounter of non-inlinable term
    inline' Word64
target (UPLC.LamAbs () DeBruijn
x Term DeBruijn DefaultUni DefaultFun ()
body) (Term DeBruijn DefaultUni DefaultFun ()
arg : [Term DeBruijn DefaultUni DefaultFun ()]
args) =
      let (Term DeBruijn DefaultUni DefaultFun ()
func', [Term DeBruijn DefaultUni DefaultFun ()]
args') = Word64
-> Term DeBruijn DefaultUni DefaultFun ()
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> (Term DeBruijn DefaultUni DefaultFun (),
    [Term DeBruijn DefaultUni DefaultFun ()])
inline' (Word64
target Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) Term DeBruijn DefaultUni DefaultFun ()
body [Term DeBruijn DefaultUni DefaultFun ()]
args
       in (()
-> DeBruijn
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann -> Term name uni fun ann
UPLC.LamAbs () DeBruijn
x Term DeBruijn DefaultUni DefaultFun ()
func', Term DeBruijn DefaultUni DefaultFun ()
arg Term DeBruijn DefaultUni DefaultFun ()
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> [Term DeBruijn DefaultUni DefaultFun ()]
forall a. a -> [a] -> [a]
: [Term DeBruijn DefaultUni DefaultFun ()]
args')
    inline' Word64
target Term DeBruijn DefaultUni DefaultFun ()
func (Term DeBruijn DefaultUni DefaultFun ()
arg : [Term DeBruijn DefaultUni DefaultFun ()]
args) =
      let (Term DeBruijn DefaultUni DefaultFun ()
func', [Term DeBruijn DefaultUni DefaultFun ()]
args') = Word64
-> Term DeBruijn DefaultUni DefaultFun ()
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> (Term DeBruijn DefaultUni DefaultFun (),
    [Term DeBruijn DefaultUni DefaultFun ()])
inline' Word64
target Term DeBruijn DefaultUni DefaultFun ()
func [Term DeBruijn DefaultUni DefaultFun ()]
args
       in (Term DeBruijn DefaultUni DefaultFun ()
func', Term DeBruijn DefaultUni DefaultFun ()
arg Term DeBruijn DefaultUni DefaultFun ()
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> [Term DeBruijn DefaultUni DefaultFun ()]
forall a. a -> [a] -> [a]
: [Term DeBruijn DefaultUni DefaultFun ()]
args')

    (Term DeBruijn DefaultUni DefaultFun ()
body, [Term DeBruijn DefaultUni DefaultFun ()]
args) = Word64
-> Term DeBruijn DefaultUni DefaultFun ()
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> (Term DeBruijn DefaultUni DefaultFun (),
    [Term DeBruijn DefaultUni DefaultFun ()])
inline' Word64
0 ((HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l RawTerm
x) ([Term DeBruijn DefaultUni DefaultFun ()]
-> [Term DeBruijn DefaultUni DefaultFun ()]
forall a. [a] -> [a]
reverse ([Term DeBruijn DefaultUni DefaultFun ()]
 -> [Term DeBruijn DefaultUni DefaultFun ()])
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> [Term DeBruijn DefaultUni DefaultFun ()]
forall a b. (a -> b) -> a -> b
$ (HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RawTerm -> Term DeBruijn DefaultUni DefaultFun ())
-> [RawTerm] -> [Term DeBruijn DefaultUni DefaultFun ()]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawTerm]
y)

    applied :: Term DeBruijn DefaultUni DefaultFun ()
applied
      | [Term DeBruijn DefaultUni DefaultFun ()] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Term DeBruijn DefaultUni DefaultFun ()]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 = (Term DeBruijn DefaultUni DefaultFun ()
 -> Term DeBruijn DefaultUni DefaultFun ()
 -> Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> Term DeBruijn DefaultUni DefaultFun ()
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
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 ()) Term DeBruijn DefaultUni DefaultFun ()
body [Term DeBruijn DefaultUni DefaultFun ()]
args
      | Bool
otherwise = ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Vector (Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann
-> Term name uni fun ann
-> Vector (Term name uni fun ann)
-> Term name uni fun ann
UPLC.Case () (()
-> Word64
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Word64 -> [Term name uni fun ann] -> Term name uni fun ann
UPLC.Constr () Word64
0 [Term DeBruijn DefaultUni DefaultFun ()]
args) (Term DeBruijn DefaultUni DefaultFun ()
-> Vector (Term DeBruijn DefaultUni DefaultFun ())
forall a. a -> Vector a
V.singleton Term DeBruijn DefaultUni DefaultFun ()
body)
   in
    Term DeBruijn DefaultUni DefaultFun ()
applied
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RDelay RawTerm
t) = ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Delay () ((HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l RawTerm
t)
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RForce RawTerm
t) = ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Force () ((HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l RawTerm
t)
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
_ Word64
_ (RBuiltin DefaultFun
f) = () -> DefaultFun -> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> fun -> Term name uni fun ann
UPLC.Builtin () DefaultFun
f
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
_ Word64
_ (RConstant Some @Type (ValueOf DefaultUni)
c) = ()
-> Some @Type (ValueOf DefaultUni)
-> Term DeBruijn DefaultUni DefaultFun ()
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 -> Term DeBruijn DefaultUni DefaultFun ()
_ Word64
_ (RCompiled Term DeBruijn DefaultUni DefaultFun ()
code) = Term DeBruijn DefaultUni DefaultFun ()
code
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
_ Word64
_ (RPlaceHolder Integer
_) = () -> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann
UPLC.Error ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
_ Word64
_ RawTerm
RError = () -> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann
UPLC.Error ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RConstr Word64
i [RawTerm]
xs) = ()
-> Word64
-> [Term DeBruijn DefaultUni DefaultFun ()]
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Word64 -> [Term name uni fun ann] -> Term name uni fun ann
UPLC.Constr () Word64
i ((HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RawTerm -> Term DeBruijn DefaultUni DefaultFun ())
-> [RawTerm] -> [Term DeBruijn DefaultUni DefaultFun ()]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawTerm]
xs)
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RCase RawTerm
x [RawTerm]
xs) = ()
-> Term DeBruijn DefaultUni DefaultFun ()
-> Vector (Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann
-> Term name uni fun ann
-> Vector (Term name uni fun ann)
-> Term name uni fun ann
UPLC.Case () ((HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l RawTerm
x) (Vector (Term DeBruijn DefaultUni DefaultFun ())
 -> Term DeBruijn DefaultUni DefaultFun ())
-> Vector (Term DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$ [Term DeBruijn DefaultUni DefaultFun ()]
-> Vector (Term DeBruijn DefaultUni DefaultFun ())
forall a. [a] -> Vector a
V.fromList ((HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RawTerm -> Term DeBruijn DefaultUni DefaultFun ())
-> [RawTerm] -> [Term DeBruijn DefaultUni DefaultFun ()]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawTerm]
xs)
-- rawTermToUPLC m l (RHoisted hoisted) = UPLC.Var () . DeBruijn . Index $ l - m hoisted
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RHoisted HoistedTerm
hoisted) = HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m HoistedTerm
hoisted Word64
l -- UPLC.Var () . DeBruijn . Index $ l - m hoisted
-- The second part of a let bind is the "function part" (to follow ordinary `let` semantics from Haskell & etc)
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RLet RawTerm
v RawTerm
f) = (HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
m Word64
l (RawTerm -> [RawTerm] -> RawTerm
RApply RawTerm
f [Item [RawTerm]
RawTerm
v])

smallEnoughToInline :: RawTerm -> Bool
smallEnoughToInline :: RawTerm -> Bool
smallEnoughToInline = \case
  RConstant (Some (ValueOf DefaultUni (Esc @Type a)
PLC.DefaultUniBool a
_)) -> Bool
True
  RConstant (Some (ValueOf DefaultUni (Esc @Type a)
PLC.DefaultUniUnit a
_)) -> Bool
True
  RConstant (Some (ValueOf DefaultUni (Esc @Type a)
PLC.DefaultUniInteger a
n)) | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
256 -> Bool
True
  RawTerm
_ -> Bool
False

-- The logic is mostly for hoisting.
compile' :: TermResult -> UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()
compile' :: TermResult -> Term DeBruijn DefaultUni DefaultFun ()
compile' TermResult
t =
  let t' :: RawTerm
t' = TermResult -> RawTerm
getTerm TermResult
t
      deps :: [HoistedTerm]
deps = TermResult -> [HoistedTerm]
getDeps TermResult
t

      g ::
        HoistedTerm ->
        (HM.HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64) ->
        (HM.HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64)
      g :: HoistedTerm
-> (HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64)
-> (HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64)
g hoistedTerm :: HoistedTerm
hoistedTerm@(HoistedTerm Int
_ RawTerm
term) (HashMap HoistedTerm Word64
m, [(Word64, RawTerm)]
defs, Word64
n) = case HoistedTerm -> HashMap HoistedTerm Word64 -> Maybe Word64
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HM.lookup HoistedTerm
hoistedTerm HashMap HoistedTerm Word64
m of
        Maybe Word64
Nothing -> (HoistedTerm
-> Word64
-> HashMap HoistedTerm Word64
-> HashMap HoistedTerm Word64
forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v
HM.insert HoistedTerm
hoistedTerm Word64
n HashMap HoistedTerm Word64
m, (Word64
n, RawTerm
term) (Word64, RawTerm) -> [(Word64, RawTerm)] -> [(Word64, RawTerm)]
forall a. a -> [a] -> [a]
: [(Word64, RawTerm)]
defs, Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)
        Just Word64
_w64 -> (HashMap HoistedTerm Word64
m, [(Word64, RawTerm)]
defs, Word64
n)

      toInline :: HM.HashMap HoistedTerm Int
      toInline :: HashMap HoistedTerm Int
toInline =
        -- keep only count "1"s or small enough to inline ones
        (HoistedTerm -> Int -> Bool)
-> HashMap HoistedTerm Int -> HashMap HoistedTerm Int
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HM.filterWithKey (\(HoistedTerm Int
_ RawTerm
term) Int
count -> Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
|| RawTerm -> Bool
smallEnoughToInline RawTerm
term) HashMap HoistedTerm Int
depsCount

      -- count how often a hoisted term occurs
      depsCount :: HM.HashMap HoistedTerm Int
      depsCount :: HashMap HoistedTerm Int
depsCount = (Int -> Int -> Int)
-> [(HoistedTerm, Int)] -> HashMap HoistedTerm Int
forall k v. Hashable k => (v -> v -> v) -> [(k, v)] -> HashMap k v
HM.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ([(HoistedTerm, Int)] -> HashMap HoistedTerm Int)
-> ([HoistedTerm] -> [(HoistedTerm, Int)])
-> [HoistedTerm]
-> HashMap HoistedTerm Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HoistedTerm -> (HoistedTerm, Int))
-> [HoistedTerm] -> [(HoistedTerm, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (,Int
1) ([HoistedTerm] -> HashMap HoistedTerm Int)
-> [HoistedTerm] -> HashMap HoistedTerm Int
forall a b. (a -> b) -> a -> b
$ [HoistedTerm]
deps

      -- map: term -> de Bruijn level
      -- defs: the terms, level 0 is last
      -- n: # of terms
      (HashMap HoistedTerm Word64
m :: HM.HashMap HoistedTerm Word64, [(Word64, RawTerm)]
defs, Word64
n) =
        (HoistedTerm
 -> (HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64)
 -> (HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64))
-> (HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64)
-> [HoistedTerm]
-> (HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HoistedTerm
-> (HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64)
-> (HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64)
g (HashMap HoistedTerm Word64
forall k v. HashMap k v
HM.empty, [], Word64
0) ([HoistedTerm]
 -> (HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64))
-> [HoistedTerm]
-> (HashMap HoistedTerm Word64, [(Word64, RawTerm)], Word64)
forall a b. (a -> b) -> a -> b
$ (HoistedTerm -> Bool) -> [HoistedTerm] -> [HoistedTerm]
forall a. (a -> Bool) -> [a] -> [a]
filter (\HoistedTerm
hoistedTerm -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HoistedTerm -> HashMap HoistedTerm Int -> Bool
forall k a. Hashable k => k -> HashMap k a -> Bool
HM.member HoistedTerm
hoistedTerm HashMap HoistedTerm Int
toInline) [HoistedTerm]
deps

      map' :: HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
map' hoistedTerm :: HoistedTerm
hoistedTerm@(HoistedTerm Int
_ RawTerm
term) Word64
l = case HoistedTerm -> HashMap HoistedTerm Word64 -> Maybe Word64
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HM.lookup HoistedTerm
hoistedTerm HashMap HoistedTerm Word64
m of
        Just Word64
l' -> () -> DeBruijn -> Term DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann
UPLC.Var () (DeBruijn -> Term DeBruijn DefaultUni DefaultFun ())
-> (Word64 -> DeBruijn)
-> Word64
-> Term DeBruijn DefaultUni DefaultFun ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index -> DeBruijn
DeBruijn (Index -> DeBruijn) -> (Word64 -> Index) -> Word64 -> DeBruijn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Index
Index (Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
forall a b. (a -> b) -> a -> b
$ Word64
l Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
l'
        Maybe Word64
Nothing -> (HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
map' Word64
l RawTerm
term

      body :: Term DeBruijn DefaultUni DefaultFun ()
body = (HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ())
-> Word64 -> RawTerm -> Term DeBruijn DefaultUni DefaultFun ()
rawTermToUPLC HoistedTerm -> Word64 -> Term DeBruijn DefaultUni DefaultFun ()
map' Word64
n RawTerm
t'

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

-- | Compile a (closed) Plutus Term to a usable script
compile :: forall (a :: S -> Type). Config -> (forall (s :: S). Term s a) -> Either Text Script
compile :: forall (a :: S -> Type).
Config -> (forall (s :: S). Term s a) -> Either Text Script
compile = InternalConfig
-> Config -> (forall {s :: S}. Term s a) -> Either Text Script
forall (a :: S -> Type).
InternalConfig
-> Config -> (forall (s :: S). Term s a) -> Either Text Script
compileWithInternalConfig InternalConfig
defaultInternalConfig

{- | As 'compile' but exposes 'InternalConfig' options.

@since 1.12.0
-}
compileWithInternalConfig ::
  forall (a :: S -> Type).
  InternalConfig -> Config -> (forall (s :: S). Term s a) -> Either Text Script
compileWithInternalConfig :: forall (a :: S -> Type).
InternalConfig
-> Config -> (forall (s :: S). Term s a) -> Either Text Script
compileWithInternalConfig InternalConfig
iconf Config
conf forall (s :: S). Term s a
t =
  case (Either Text TermResult, ()) -> Either Text TermResult
forall a b. (a, b) -> a
fst ((Either Text TermResult, ()) -> Either Text TermResult)
-> (() -> (Either Text TermResult, ()))
-> ()
-> Either Text TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RWS TermEnv () () (Either Text TermResult)
-> TermEnv -> () -> (Either Text TermResult, ())
forall w r s a. Monoid w => RWS r w s a -> r -> s -> (a, w)
evalRWS (ExceptT Text (RWS TermEnv () ()) TermResult
-> RWS TermEnv () () (Either Text TermResult)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text (RWS TermEnv () ()) TermResult
 -> RWS TermEnv () () (Either Text TermResult))
-> (Term (Any @S) a -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> Term (Any @S) a
-> RWS TermEnv () () (Either Text TermResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term (Any @S) a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm (Term (Any @S) a -> RWS TermEnv () () (Either Text TermResult))
-> Term (Any @S) a -> RWS TermEnv () () (Either Text TermResult)
forall a b. (a -> b) -> a -> b
$ Term (Any @S) a
forall (s :: S). Term s a
t) (Word64 -> InternalConfig -> Config -> TermEnv
TermEnv Word64
0 InternalConfig
iconf Config
conf) (() -> Either Text TermResult) -> () -> Either Text TermResult
forall a b. (a -> b) -> a -> b
$ () of
    Left Text
err -> Text -> Either Text Script
forall a b. a -> Either a b
Left Text
err
    Right TermResult
res -> Script -> Either Text Script
forall a. a -> Either Text a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Script -> Either Text Script)
-> (TermResult -> Script) -> TermResult -> Either Text Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program DeBruijn DefaultUni DefaultFun () -> Script
Script (Program DeBruijn DefaultUni DefaultFun () -> Script)
-> (TermResult -> Program DeBruijn DefaultUni DefaultFun ())
-> TermResult
-> Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ()
-> Version
-> Term DeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Version -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program () Version
uplcVersion (Term DeBruijn DefaultUni DefaultFun ()
 -> Program DeBruijn DefaultUni DefaultFun ())
-> (TermResult -> Term DeBruijn DefaultUni DefaultFun ())
-> TermResult
-> Program DeBruijn DefaultUni DefaultFun ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> Term DeBruijn DefaultUni DefaultFun ()
compile' (TermResult -> Either Text Script)
-> TermResult -> Either Text Script
forall a b. (a -> b) -> a -> b
$ TermResult
res

{- | As 'compile', but performs UPLC optimizations. Furthermore, this will
always elide tracing (as if with 'NoTracing').

@since 1.10.0
-}
compileOptimized ::
  forall (a :: S -> Type).
  (forall (s :: S). Term s a) ->
  Either Text Script
compileOptimized :: forall (a :: S -> Type).
(forall (s :: S). Term s a) -> Either Text Script
compileOptimized = InternalConfig -> (forall {s :: S}. Term s a) -> Either Text Script
forall (a :: S -> Type).
InternalConfig -> (forall (s :: S). Term s a) -> Either Text Script
compileOptimizedWithInternalConfig InternalConfig
defaultInternalConfig

{- | As 'compileOptimized' but exposes 'InternalConfig' options.

@since 1.12.0
-}
compileOptimizedWithInternalConfig ::
  forall (a :: S -> Type).
  InternalConfig ->
  (forall (s :: S). Term s a) ->
  Either Text Script
compileOptimizedWithInternalConfig :: forall (a :: S -> Type).
InternalConfig -> (forall (s :: S). Term s a) -> Either Text Script
compileOptimizedWithInternalConfig InternalConfig
internalConfig forall (s :: S). Term s a
t = do
  let env :: TermEnv
env = Word64 -> InternalConfig -> Config -> TermEnv
TermEnv Word64
0 InternalConfig
internalConfig Config
NoTracing
  TermResult
built <- (Either Text TermResult, ()) -> Either Text TermResult
forall a b. (a, b) -> a
fst ((Either Text TermResult, ()) -> Either Text TermResult)
-> (() -> (Either Text TermResult, ()))
-> ()
-> Either Text TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RWS TermEnv () () (Either Text TermResult)
-> TermEnv -> () -> (Either Text TermResult, ())
forall w r s a. Monoid w => RWS r w s a -> r -> s -> (a, w)
evalRWS (ExceptT Text (RWS TermEnv () ()) TermResult
-> RWS TermEnv () () (Either Text TermResult)
forall e (m :: Type -> Type) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text (RWS TermEnv () ()) TermResult
 -> RWS TermEnv () () (Either Text TermResult))
-> (Term (Any @S) a -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> Term (Any @S) a
-> RWS TermEnv () () (Either Text TermResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term (Any @S) a -> ExceptT Text (RWS TermEnv () ()) TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> ExceptT Text (RWS TermEnv () ()) TermResult
asRawTerm (Term (Any @S) a -> RWS TermEnv () () (Either Text TermResult))
-> Term (Any @S) a -> RWS TermEnv () () (Either Text TermResult)
forall a b. (a -> b) -> a -> b
$ Term (Any @S) a
forall (s :: S). Term s a
t) TermEnv
env (() -> Either Text TermResult) -> () -> Either Text TermResult
forall a b. (a -> b) -> a -> b
$ ()
  let compiled :: Term DeBruijn DefaultUni DefaultFun ()
compiled = TermResult -> Term DeBruijn DefaultUni DefaultFun ()
compile' TermResult
built
  case Term DeBruijn DefaultUni DefaultFun ()
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
go Term DeBruijn DefaultUni DefaultFun ()
compiled of
    Left FreeVariableError
err -> Text -> Either Text Script
forall a. Text -> Either Text a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (Text -> Either Text Script)
-> (FreeVariableError -> Text)
-> FreeVariableError
-> Either Text Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (FreeVariableError -> String) -> FreeVariableError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeVariableError -> String
forall a. Show a => a -> String
show (FreeVariableError -> Either Text Script)
-> FreeVariableError -> Either Text Script
forall a b. (a -> b) -> a -> b
$ FreeVariableError
err
    Right Term DeBruijn DefaultUni DefaultFun ()
simplified -> Script -> Either Text Script
forall a. a -> Either Text a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Script -> Either Text Script)
-> (Term DeBruijn DefaultUni DefaultFun () -> Script)
-> Term DeBruijn DefaultUni DefaultFun ()
-> Either Text Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program DeBruijn DefaultUni DefaultFun () -> Script
Script (Program DeBruijn DefaultUni DefaultFun () -> Script)
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> Program DeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ()
-> Version
-> Term DeBruijn DefaultUni DefaultFun ()
-> Program DeBruijn DefaultUni DefaultFun ()
forall name (uni :: Type -> Type) fun ann.
ann -> Version -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program () Version
uplcVersion (Term DeBruijn DefaultUni DefaultFun () -> Either Text Script)
-> Term DeBruijn DefaultUni DefaultFun () -> Either Text Script
forall a b. (a -> b) -> a -> b
$ Term DeBruijn DefaultUni DefaultFun ()
simplified
  where
    go ::
      UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () ->
      Either UPLC.FreeVariableError (UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ())
    go :: Term DeBruijn DefaultUni DefaultFun ()
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
go Term DeBruijn DefaultUni DefaultFun ()
compiled = QuoteT
  (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall (m :: Type -> Type) a. Monad m => QuoteT m a -> m a
PLC.runQuoteT (QuoteT
   (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
 -> Either
      FreeVariableError (Term DeBruijn DefaultUni DefaultFun ()))
-> QuoteT
     (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ do
      Term Name DefaultUni DefaultFun ()
unDB <- 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 ()
 -> QuoteT
      (Either FreeVariableError) (Term Name DefaultUni DefaultFun ()))
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (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 ()
 -> QuoteT
      (Either FreeVariableError) (Term Name DefaultUni DefaultFun ()))
-> Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ Term DeBruijn DefaultUni DefaultFun ()
compiled
      Term Name DefaultUni DefaultFun ()
optimized <- OptimizeOpts Name ()
-> BuiltinSemanticsVariant DefaultFun
-> Term Name DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term Name DefaultUni DefaultFun ())
forall name (uni :: Type -> Type) fun (m :: Type -> Type) a.
Compiling m uni fun name a =>
OptimizeOpts name a
-> BuiltinSemanticsVariant fun
-> Term name uni fun a
-> m (Term name uni fun a)
UPLC.optimizeTerm OptimizeOpts Name ()
forall name a. OptimizeOpts name a
UPLC.defaultOptimizeOpts BuiltinSemanticsVariant DefaultFun
forall a. Default a => a
def Term Name DefaultUni DefaultFun ()
unDB
      Term NamedDeBruijn DefaultUni DefaultFun ()
debruijnd <- Term Name DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (m :: Type -> Type) (uni :: Type -> Type) fun ann.
MonadError FreeVariableError m =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm Term Name DefaultUni DefaultFun ()
optimized
      Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
forall a. a -> QuoteT (Either FreeVariableError) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term DeBruijn DefaultUni DefaultFun ()
 -> QuoteT
      (Either FreeVariableError)
      (Term DeBruijn DefaultUni DefaultFun ()))
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> Term DeBruijn DefaultUni DefaultFun ())
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedDeBruijn -> DeBruijn)
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
forall name name' (uni :: Type -> Type) fun ann.
(name -> name') -> Term name uni fun ann -> Term name' uni fun ann
UPLC.termMapNames NamedDeBruijn -> DeBruijn
UPLC.unNameDeBruijn (Term NamedDeBruijn DefaultUni DefaultFun ()
 -> QuoteT
      (Either FreeVariableError)
      (Term DeBruijn DefaultUni DefaultFun ()))
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ Term NamedDeBruijn DefaultUni DefaultFun ()
debruijnd

{- | Given a closed 'Term', run the UPLC optimizer on it.

= Important note

If the input term has any hoisted dependencies, these are completely erased
by this process. Thus, if the resulting 'Term' is used as part of a larger
computation with the same dependencies, the Plutarch compiler will not be
aware of them, and will not be able to optimize them properly. More
concretely, in a case like this:

@@
padd # optimizeTerm (f # pexpensive) # optimizeTerm (g # pexpensive)
@@

@pexpensive@ will end up being duplicated entirely into each \'arm\' of the
@padd@, even though under normal circumstances it could be shared.

Thus, if you plan to use this, ensure that it is done \'as late as
possible\'; embedding 'Term's produced by 'optimizeTerm' into larger
computations can lead to size blowout if not done carefully.
-}
optimizeTerm ::
  forall (a :: S -> Type).
  (forall (s :: S). Term s a) ->
  (forall (s :: S). Term s a)
optimizeTerm :: forall (a :: S -> Type).
(forall (s :: S). Term s a) -> forall (s :: S). Term s a
optimizeTerm (Term ExceptT Text (RWS TermEnv () ()) TermResult
raw) = ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall (s :: S) (a :: S -> Type).
ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
Term (ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a)
-> ExceptT Text (RWS TermEnv () ()) TermResult -> Term s a
forall a b. (a -> b) -> a -> b
$ do
  TermResult
res <- ExceptT Text (RWS TermEnv () ()) TermResult
raw
  case Term DeBruijn DefaultUni DefaultFun ()
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
go (Term DeBruijn DefaultUni DefaultFun ()
 -> Either
      FreeVariableError (Term DeBruijn DefaultUni DefaultFun ()))
-> (TermResult -> Term DeBruijn DefaultUni DefaultFun ())
-> TermResult
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> Term DeBruijn DefaultUni DefaultFun ()
compile' (TermResult
 -> Either
      FreeVariableError (Term DeBruijn DefaultUni DefaultFun ()))
-> TermResult
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ TermResult
res of
    Left FreeVariableError
err -> Text -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. Text -> ExceptT Text (RWS TermEnv () ()) a
forall e (m :: Type -> Type) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> (FreeVariableError -> Text)
-> FreeVariableError
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (FreeVariableError -> String) -> FreeVariableError -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeVariableError -> String
forall a. Show a => a -> String
show (FreeVariableError -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> FreeVariableError -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ FreeVariableError
err
    Right Term DeBruijn DefaultUni DefaultFun ()
simplified -> TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a. a -> ExceptT Text (RWS TermEnv () ()) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> ([HoistedTerm] -> TermResult)
-> [HoistedTerm]
-> ExceptT Text (RWS TermEnv () ()) TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> [HoistedTerm] -> TermResult
TermResult (Term DeBruijn DefaultUni DefaultFun () -> RawTerm
RCompiled Term DeBruijn DefaultUni DefaultFun ()
simplified) ([HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult)
-> [HoistedTerm] -> ExceptT Text (RWS TermEnv () ()) TermResult
forall a b. (a -> b) -> a -> b
$ []
  where
    go ::
      UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () ->
      Either UPLC.FreeVariableError (UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ())
    go :: Term DeBruijn DefaultUni DefaultFun ()
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
go Term DeBruijn DefaultUni DefaultFun ()
compiled = QuoteT
  (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall (m :: Type -> Type) a. Monad m => QuoteT m a -> m a
PLC.runQuoteT (QuoteT
   (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
 -> Either
      FreeVariableError (Term DeBruijn DefaultUni DefaultFun ()))
-> QuoteT
     (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ do
      Term Name DefaultUni DefaultFun ()
unDB <- 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 ()
 -> QuoteT
      (Either FreeVariableError) (Term Name DefaultUni DefaultFun ()))
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (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 ()
 -> QuoteT
      (Either FreeVariableError) (Term Name DefaultUni DefaultFun ()))
-> Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ Term DeBruijn DefaultUni DefaultFun ()
compiled
      Term Name DefaultUni DefaultFun ()
optimized <- OptimizeOpts Name ()
-> BuiltinSemanticsVariant DefaultFun
-> Term Name DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term Name DefaultUni DefaultFun ())
forall name (uni :: Type -> Type) fun (m :: Type -> Type) a.
Compiling m uni fun name a =>
OptimizeOpts name a
-> BuiltinSemanticsVariant fun
-> Term name uni fun a
-> m (Term name uni fun a)
UPLC.optimizeTerm OptimizeOpts Name ()
forall name a. OptimizeOpts name a
UPLC.defaultOptimizeOpts BuiltinSemanticsVariant DefaultFun
forall a. Default a => a
def Term Name DefaultUni DefaultFun ()
unDB
      Term NamedDeBruijn DefaultUni DefaultFun ()
debruijnd <- Term Name DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError)
     (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (m :: Type -> Type) (uni :: Type -> Type) fun ann.
MonadError FreeVariableError m =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm Term Name DefaultUni DefaultFun ()
optimized
      Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
forall a. a -> QuoteT (Either FreeVariableError) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term DeBruijn DefaultUni DefaultFun ()
 -> QuoteT
      (Either FreeVariableError)
      (Term DeBruijn DefaultUni DefaultFun ()))
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> Term DeBruijn DefaultUni DefaultFun ())
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedDeBruijn -> DeBruijn)
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Term DeBruijn DefaultUni DefaultFun ()
forall name name' (uni :: Type -> Type) fun ann.
(name -> name') -> Term name uni fun ann -> Term name' uni fun ann
UPLC.termMapNames NamedDeBruijn -> DeBruijn
UPLC.unNameDeBruijn (Term NamedDeBruijn DefaultUni DefaultFun ()
 -> QuoteT
      (Either FreeVariableError)
      (Term DeBruijn DefaultUni DefaultFun ()))
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either FreeVariableError) (Term DeBruijn DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ Term NamedDeBruijn DefaultUni DefaultFun ()
debruijnd

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

  >>> f # x # y
  f x y
-}
(#) :: Term s (a :--> b) -> Term s a -> Term s b
# :: forall (s :: S) (a :: S -> Type) (b :: S -> Type).
Term s (a :--> b) -> Term s a -> Term s b
(#) = Term s (a :--> b) -> Term s a -> Term s b
forall (s :: S) (a :: S -> Type) (b :: S -> Type).
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)
-}
(#$) :: Term s (a :--> b) -> Term s a -> Term s b
#$ :: forall (s :: S) (a :: S -> Type) (b :: S -> Type).
Term s (a :--> b) -> Term s a -> Term s b
(#$) = Term s (a :--> b) -> Term s a -> Term s b
forall (s :: S) (a :: S -> Type) (b :: S -> Type).
Term s (a :--> b) -> Term s a -> Term s b
papp

infixr 0 #$