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

module Plutarch.Internal.Term (
  -- | \$hoisted
  (:-->) (PLam),
  PDelayed,
  -- | \$term
  Term (..),
  asClosedRawTerm,
  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,
  TermMonad (..),
  (#),
  (#$),
) where

import Control.Monad.Reader (ReaderT (ReaderT), ask, local)
import Control.Monad.State.Strict (evalStateT)
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]
  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
htHash :: 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)
  {-# INLINE hash #-}

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

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

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

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

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

{- | 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

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

type role Term nominal nominal

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

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

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

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 = (Word64 -> TermMonad TermResult) -> Term s (a :--> b)
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
i ->
  let v :: Term s a
v = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
j -> TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> TermMonad TermResult)
-> TermResult -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> TermResult
mkTermRes (RawTerm -> TermResult) -> RawTerm -> 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))
   in ((TermResult -> TermResult)
 -> TermMonad TermResult -> TermMonad TermResult)
-> TermMonad TermResult
-> (TermResult -> TermResult)
-> TermMonad TermResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TermResult -> TermResult)
-> TermMonad TermResult -> TermMonad TermResult
forall a b. (a -> b) -> TermMonad a -> TermMonad b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term s b -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v) (Word64
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)) \case
        -- eta-reduce for arity 1
        t :: TermResult
t@(TermResult -> RawTerm
getTerm -> RApply t' :: RawTerm
t'@(RawTerm -> Maybe Word64
getArity -> Just Word64
_) [RVar Word64
0]) -> TermResult
t {getTerm = t'}
        -- eta-reduce for arity 2 + n
        t :: TermResult
t@(TermResult -> RawTerm
getTerm -> RLamAbs Word64
n (RApply t' :: RawTerm
t'@(RawTerm -> Maybe Word64
getArity -> Just Word64
n') [RawTerm]
args))
          | (Maybe [Word64] -> Maybe [Word64] -> Bool
forall a. Eq a => a -> a -> Bool
== [Word64] -> Maybe [Word64]
forall a. a -> Maybe a
Just [Word64
Item [Word64]
0 .. Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1]) ((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) [RawTerm]
args)
              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 ->
              TermResult
t {getTerm = t'}
        -- increment arity
        t :: TermResult
t@(TermResult -> RawTerm
getTerm -> RLamAbs Word64
n RawTerm
t') -> TermResult
t {getTerm = RLamAbs (n + 1) t'}
        -- new lambda
        TermResult
t -> (RawTerm -> RawTerm) -> TermResult -> TermResult
mapTerm (Word64 -> RawTerm -> RawTerm
RLamAbs Word64
0) TermResult
t
  where
    -- 0 is 1
    getArity :: RawTerm -> Maybe Word64
    -- We only do this if it's hoisted, since it's only safe if it doesn't
    -- refer to any of the variables in the wrapping lambda.
    getArity :: RawTerm -> Maybe Word64
getArity (RHoisted (HoistedTerm Int
_ (RLamAbs Word64
n RawTerm
_))) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
n
    getArity (RHoisted (HoistedTerm Int
_ RawTerm
t)) = RawTerm -> Maybe Word64
getArityBuiltin RawTerm
t
    getArity RawTerm
t = RawTerm -> Maybe Word64
getArityBuiltin RawTerm
t

    getArityBuiltin :: RawTerm -> Maybe Word64
    getArityBuiltin :: RawTerm -> Maybe Word64
getArityBuiltin (RBuiltin DefaultFun
PLC.AddInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.SubtractInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.MultiplyInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.DivideInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.QuotientInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.RemainderInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.ModInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.ExpModInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.EqualsInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.LessThanInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.LessThanEqualsInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.AppendByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.ConsByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.SliceByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.LengthOfByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.IndexByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.EqualsByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.LessThanByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.LessThanEqualsByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.IntegerToByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.ByteStringToInteger) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.AndByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.OrByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.XorByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.ComplementByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.ReadBit) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.WriteBits) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.ReplicateByte) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.ShiftByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.RotateByteString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.CountSetBits) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.FindFirstSetBit) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G1_add) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G1_neg) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G1_scalarMul) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G1_equal) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G1_hashToGroup) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G1_compress) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G1_uncompress) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G2_add) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G2_neg) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G2_scalarMul) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G2_equal) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G2_hashToGroup) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G2_compress) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_G2_uncompress) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_millerLoop) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_mulMlResult) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Bls12_381_finalVerify) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.Sha2_256) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Sha3_256) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Blake2b_224) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Blake2b_256) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Keccak_256) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.Ripemd_160) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.VerifyEd25519Signature) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.VerifyEcdsaSecp256k1Signature) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.VerifySchnorrSecp256k1Signature) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RBuiltin DefaultFun
PLC.AppendString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.EqualsString) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.EncodeUtf8) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.DecodeUtf8) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.IfThenElse)) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.ChooseUnit)) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.Trace)) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RForce (RForce (RBuiltin DefaultFun
PLC.FstPair))) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RForce (RBuiltin DefaultFun
PLC.SndPair))) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RForce (RBuiltin DefaultFun
PLC.ChooseList))) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
2
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.MkCons)) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.HeadList)) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.TailList)) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.NullList)) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RForce (RBuiltin DefaultFun
PLC.ChooseData)) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
5
    getArityBuiltin (RBuiltin DefaultFun
PLC.ConstrData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.MapData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.ListData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.IData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.BData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.UnConstrData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.UnMapData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.UnListData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.UnIData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.UnBData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.EqualsData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.MkPairData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
1
    getArityBuiltin (RBuiltin DefaultFun
PLC.MkNilData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin (RBuiltin DefaultFun
PLC.MkNilPairData) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
0
    getArityBuiltin 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 = (Word64 -> TermMonad TermResult) -> Term s b
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
i ->
  Term s a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s a
v Word64
i TermMonad TermResult
-> (TermResult -> TermMonad TermResult) -> TermMonad TermResult
forall a b. TermMonad a -> (a -> TermMonad b) -> TermMonad b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- Inline sufficiently small terms in WHNF
    (TermResult -> RawTerm
getTerm -> RVar Word64
_) -> Term s b -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v) Word64
i
    (TermResult -> RawTerm
getTerm -> RBuiltin DefaultFun
_) -> Term s b -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v) Word64
i
    (TermResult -> RawTerm
getTerm -> RHoisted HoistedTerm
_) -> Term s b -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v) Word64
i
    TermResult
_ -> Term s b -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (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 ((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) Term s a
v) Word64
i

pthrow' :: HasCallStack => Text -> TermMonad a
pthrow' :: forall a. HasCallStack => Text -> TermMonad a
pthrow' Text
msg = ReaderT (InternalConfig, Config) (Either Text) a -> TermMonad a
forall m.
ReaderT (InternalConfig, Config) (Either Text) m -> TermMonad m
TermMonad (ReaderT (InternalConfig, Config) (Either Text) a -> TermMonad a)
-> ReaderT (InternalConfig, Config) (Either Text) a -> TermMonad a
forall a b. (a -> b) -> a -> b
$ ((InternalConfig, Config) -> Either Text a)
-> ReaderT (InternalConfig, Config) (Either Text) a
forall r (m :: Type -> Type) a. (r -> m a) -> ReaderT r m a
ReaderT (((InternalConfig, Config) -> Either Text a)
 -> ReaderT (InternalConfig, Config) (Either Text) a)
-> ((InternalConfig, Config) -> Either Text a)
-> ReaderT (InternalConfig, Config) (Either Text) a
forall a b. (a -> b) -> a -> b
$ Either Text a -> (InternalConfig, Config) -> Either Text a
forall a b. a -> b -> a
const (Either Text a -> (InternalConfig, Config) -> Either Text a)
-> Either Text a -> (InternalConfig, Config) -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text -> Either Text a
forall a b. a -> Either a b
Left (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)

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

-- | 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 = (Word64 -> TermMonad TermResult) -> Term s b
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
i ->
  (,) (TermResult -> TermResult -> (TermResult, TermResult))
-> TermMonad TermResult
-> TermMonad (TermResult -> (TermResult, TermResult))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Term s (a :--> b) -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s (a :--> b)
x Word64
i TermMonad (TermResult -> (TermResult, TermResult))
-> TermMonad TermResult -> TermMonad (TermResult, TermResult)
forall a b. TermMonad (a -> b) -> TermMonad a -> TermMonad b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Term s a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s a
y Word64
i TermMonad (TermResult, TermResult)
-> ((TermResult, TermResult) -> TermMonad TermResult)
-> TermMonad TermResult
forall a b. TermMonad a -> (a -> TermMonad b) -> TermMonad b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- Applying anything to an error is an error.
    (TermResult -> RawTerm
getTerm -> RawTerm
RError, TermResult
_) -> TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> TermMonad TermResult)
-> TermResult -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> TermResult
mkTermRes RawTerm
RError
    -- Applying an error to anything is an error.
    (TermResult
_, TermResult -> RawTerm
getTerm -> RawTerm
RError) -> TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> TermMonad TermResult)
-> TermResult -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> TermResult
mkTermRes RawTerm
RError
    -- Applying to `id` changes nothing.
    (TermResult -> RawTerm
getTerm -> RLamAbs Word64
0 (RVar Word64
0), TermResult
y') -> TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TermResult
y'
    (TermResult -> RawTerm
getTerm -> RHoisted (HoistedTerm Int
_ (RLamAbs Word64
0 (RVar Word64
0))), TermResult
y') -> TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TermResult
y'
    -- append argument
    (x' :: TermResult
x'@(TermResult -> RawTerm
getTerm -> RApply RawTerm
x'l [RawTerm]
x'r), TermResult
y') -> TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> TermMonad TermResult)
-> TermResult -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> [HoistedTerm] -> TermResult
TermResult (RawTerm -> [RawTerm] -> RawTerm
RApply RawTerm
x'l (TermResult -> RawTerm
getTerm TermResult
y' RawTerm -> [RawTerm] -> [RawTerm]
forall a. a -> [a] -> [a]
: [RawTerm]
x'r)) (TermResult -> [HoistedTerm]
getDeps TermResult
x' [HoistedTerm] -> [HoistedTerm] -> [HoistedTerm]
forall a. Semigroup a => a -> a -> a
<> TermResult -> [HoistedTerm]
getDeps TermResult
y')
    -- new RApply
    (TermResult
x', TermResult
y') -> TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> TermMonad TermResult)
-> TermResult -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> [HoistedTerm] -> TermResult
TermResult (RawTerm -> [RawTerm] -> RawTerm
RApply (TermResult -> RawTerm
getTerm TermResult
x') [TermResult -> RawTerm
getTerm TermResult
y']) (TermResult -> [HoistedTerm]
getDeps TermResult
x' [HoistedTerm] -> [HoistedTerm] -> [HoistedTerm]
forall a. Semigroup a => a -> a -> a
<> TermResult -> [HoistedTerm]
getDeps TermResult
y')

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

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

{- |
  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 = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
_ -> TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> TermMonad TermResult)
-> TermResult -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> TermResult
mkTermRes 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 Integer
x = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
_ -> TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> TermMonad TermResult)
-> TermResult -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> TermResult
mkTermRes (RawTerm -> TermResult) -> RawTerm -> TermResult
forall a b. (a -> b) -> a -> b
$ Integer -> RawTerm
RPlaceHolder Integer
x

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 = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
lvl -> ReaderT (InternalConfig, Config) (Either Text) TermResult
-> TermMonad TermResult
forall m.
ReaderT (InternalConfig, Config) (Either Text) m -> TermMonad m
TermMonad (ReaderT (InternalConfig, Config) (Either Text) TermResult
 -> TermMonad TermResult)
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
-> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ do
  (InternalConfig, Config)
config <- ReaderT
  (InternalConfig, Config) (Either Text) (InternalConfig, Config)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
  TermMonad TermResult
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
forall m.
TermMonad m -> ReaderT (InternalConfig, Config) (Either Text) m
runTermMonad (TermMonad TermResult
 -> ReaderT (InternalConfig, Config) (Either Text) TermResult)
-> TermMonad TermResult
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
forall a b. (a -> b) -> a -> b
$ Term s a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Config -> Term s a
f (Config -> Term s a) -> Config -> Term s a
forall a b. (a -> b) -> a -> b
$ (InternalConfig, Config) -> Config
forall a b. (a, b) -> b
snd (InternalConfig, Config)
config) Word64
lvl

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 = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
lvl -> ReaderT (InternalConfig, Config) (Either Text) TermResult
-> TermMonad TermResult
forall m.
ReaderT (InternalConfig, Config) (Either Text) m -> TermMonad m
TermMonad (ReaderT (InternalConfig, Config) (Either Text) TermResult
 -> TermMonad TermResult)
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
-> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ do
  (InternalConfig, Config)
config <- ReaderT
  (InternalConfig, Config) (Either Text) (InternalConfig, Config)
forall r (m :: Type -> Type). MonadReader r m => m r
ask
  TermMonad TermResult
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
forall m.
TermMonad m -> ReaderT (InternalConfig, Config) (Either Text) m
runTermMonad (TermMonad TermResult
 -> ReaderT (InternalConfig, Config) (Either Text) TermResult)
-> TermMonad TermResult
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
forall a b. (a -> b) -> a -> b
$ Term s a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (InternalConfig -> Term s a
f (InternalConfig -> Term s a) -> InternalConfig -> Term s a
forall a b. (a -> b) -> a -> b
$ (InternalConfig, Config) -> InternalConfig
forall a b. (a, b) -> a
fst (InternalConfig, Config)
config) Word64
lvl

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 = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
lvl -> ReaderT (InternalConfig, Config) (Either Text) TermResult
-> TermMonad TermResult
forall m.
ReaderT (InternalConfig, Config) (Either Text) m -> TermMonad m
TermMonad (ReaderT (InternalConfig, Config) (Either Text) TermResult
 -> TermMonad TermResult)
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
-> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ do
  ((InternalConfig, Config) -> (InternalConfig, Config))
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
forall a.
((InternalConfig, Config) -> (InternalConfig, Config))
-> ReaderT (InternalConfig, Config) (Either Text) a
-> ReaderT (InternalConfig, Config) (Either Text) a
forall r (m :: Type -> Type) a.
MonadReader r m =>
(r -> r) -> m a -> m a
local (\(InternalConfig
_, Config
c) -> (InternalConfig
cfg, Config
c)) (ReaderT (InternalConfig, Config) (Either Text) TermResult
 -> ReaderT (InternalConfig, Config) (Either Text) TermResult)
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
forall a b. (a -> b) -> a -> b
$
    TermMonad TermResult
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
forall m.
TermMonad m -> ReaderT (InternalConfig, Config) (Either Text) m
runTermMonad (TermMonad TermResult
 -> ReaderT (InternalConfig, Config) (Either Text) TermResult)
-> TermMonad TermResult
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
forall a b. (a -> b) -> a -> b
$
      Term s a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s a
t Word64
lvl

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

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

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

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 = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
_ ->
  let hoisted :: HoistedTerm
hoisted = Int -> RawTerm -> HoistedTerm
HoistedTerm (RawTerm -> Int
forall a. Hashable a => a -> Int
hash (RawTerm -> Int) -> RawTerm -> Int
forall a b. (a -> b) -> a -> b
$ Some @Type (ValueOf DefaultUni) -> RawTerm
RConstant Some @Type (ValueOf DefaultUni)
c) (Some @Type (ValueOf DefaultUni) -> RawTerm
RConstant Some @Type (ValueOf DefaultUni)
c)
   in TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> TermMonad TermResult)
-> TermResult -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> [HoistedTerm] -> TermResult
TermResult (HoistedTerm -> RawTerm
RHoisted HoistedTerm
hoisted) [Item [HoistedTerm]
HoistedTerm
hoisted]

asClosedRawTerm :: forall (a :: S -> Type). (forall (s :: S). Term s a) -> TermMonad TermResult
asClosedRawTerm :: forall (a :: S -> Type).
(forall (s :: S). Term s a) -> TermMonad TermResult
asClosedRawTerm forall (s :: S). Term s a
t = Term (Any @S) a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term (Any @S) a
forall (s :: S). Term s a
t Word64
0

-- FIXME: 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 {internalConfig'phoistAcyclicEvalCheck :: InternalConfig -> Bool
internalConfig'phoistAcyclicEvalCheck = Bool
chk} -> (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
_ ->
  Term (Any @S) a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: S -> Type).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term (Any @S) a
forall (s' :: S). Term s' a
t Word64
0 TermMonad TermResult
-> (TermResult -> TermMonad TermResult) -> TermMonad TermResult
forall a b. TermMonad a -> (a -> TermMonad b) -> TermMonad b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- Built-ins are smaller than variable references
    t' :: TermResult
t'@(TermResult -> RawTerm
getTerm -> RBuiltin DefaultFun
_) -> TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure TermResult
t'
    TermResult
t' | Bool
chk -> case Script
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      Script,
    ExBudget, [Text])
evalScript (Script
 -> (Either
       (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
       Script,
     ExBudget, [Text]))
-> (Term DeBruijn DefaultUni DefaultFun () -> Script)
-> Term DeBruijn DefaultUni DefaultFun ()
-> (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)
-> (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
       (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
       Script,
     ExBudget, [Text]))
-> Term DeBruijn DefaultUni DefaultFun ()
-> (Either
      (CekEvaluationException NamedDeBruijn DefaultUni DefaultFun)
      Script,
    ExBudget, [Text])
forall a b. (a -> b) -> a -> b
$ TermResult -> Term DeBruijn DefaultUni DefaultFun ()
compile' TermResult
t' of
      (Right Script
_, ExBudget
_, [Text]
_) ->
        let hoisted :: HoistedTerm
hoisted = Int -> RawTerm -> HoistedTerm
HoistedTerm (RawTerm -> Int
forall a. Hashable a => a -> Int
hash (RawTerm -> Int) -> (TermResult -> RawTerm) -> TermResult -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> RawTerm
getTerm (TermResult -> Int) -> TermResult -> Int
forall a b. (a -> b) -> a -> b
$ TermResult
t') (TermResult -> RawTerm
getTerm TermResult
t')
         in TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> TermMonad TermResult)
-> TermResult -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> [HoistedTerm] -> TermResult
TermResult (HoistedTerm -> RawTerm
RHoisted HoistedTerm
hoisted) (HoistedTerm
hoisted HoistedTerm -> [HoistedTerm] -> [HoistedTerm]
forall a. a -> [a] -> [a]
: TermResult -> [HoistedTerm]
getDeps TermResult
t')
      (Left CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
e, ExBudget
_, [Text]
_) -> Text -> TermMonad TermResult
forall a. HasCallStack => Text -> TermMonad a
pthrow' (Text -> TermMonad TermResult) -> Text -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ Text
"Hoisted term errs! " 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)
    TermResult
t' ->
      let hoisted :: HoistedTerm
hoisted = Int -> RawTerm -> HoistedTerm
HoistedTerm (RawTerm -> Int
forall a. Hashable a => a -> Int
hash (RawTerm -> Int) -> (TermResult -> RawTerm) -> TermResult -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> RawTerm
getTerm (TermResult -> Int) -> TermResult -> Int
forall a b. (a -> b) -> a -> b
$ TermResult
t') (TermResult -> RawTerm
getTerm TermResult
t')
       in TermResult -> TermMonad TermResult
forall a. a -> TermMonad a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> TermMonad TermResult)
-> TermResult -> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ RawTerm -> [HoistedTerm] -> TermResult
TermResult (HoistedTerm -> RawTerm
RHoisted HoistedTerm
hoisted) (HoistedTerm
hoisted HoistedTerm -> [HoistedTerm] -> [HoistedTerm]
forall a. a -> [a] -> [a]
: TermResult -> [HoistedTerm]
getDeps TermResult
t')

-- 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

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
internalConfig Config
config forall (s :: S). Term s a
t = case (forall (s :: S). Term s a) -> TermMonad TermResult
forall (a :: S -> Type).
(forall (s :: S). Term s a) -> TermMonad TermResult
asClosedRawTerm Term s a
forall (s :: S). Term s a
t of
  TermMonad (ReaderT (InternalConfig, Config) -> Either Text TermResult
t') -> 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 -> Script)
-> Either Text TermResult -> Either Text Script
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (InternalConfig, Config) -> Either Text TermResult
t' (InternalConfig
internalConfig, Config
config)

{- | 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 = case (forall (s :: S). Term s a) -> TermMonad TermResult
forall (a :: S -> Type).
(forall (s :: S). Term s a) -> TermMonad TermResult
asClosedRawTerm Term s a
forall (s :: S). Term s a
t of
  TermMonad (ReaderT (InternalConfig, Config) -> Either Text TermResult
t') -> do
    TermResult
configured <- (InternalConfig, Config) -> Either Text TermResult
t' (InternalConfig
internalConfig, Config
NoTracing)
    let compiled :: Term DeBruijn DefaultUni DefaultFun ()
compiled = TermResult -> Term DeBruijn DefaultUni DefaultFun ()
compile' TermResult
configured
    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 b. a -> Either a b
Left (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 = (StateT
   (SimplifierTrace
      (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
   (Either FreeVariableError)
   (Term DeBruijn DefaultUni DefaultFun ())
 -> SimplifierTrace
      (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type)
 -> Either
      FreeVariableError (Term DeBruijn DefaultUni DefaultFun ()))
-> SimplifierTrace
     (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type)
-> StateT
     (SimplifierTrace
        (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
     (Either FreeVariableError)
     (Term DeBruijn DefaultUni DefaultFun ())
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (SimplifierTrace
     (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
  (Either FreeVariableError)
  (Term DeBruijn DefaultUni DefaultFun ())
-> SimplifierTrace
     (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type)
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m a
evalStateT SimplifierTrace
  (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type)
forall name (uni :: Type -> Type) fun a.
SimplifierTrace name uni fun a
UPLC.initSimplifierTrace (StateT
   (SimplifierTrace
      (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
   (Either FreeVariableError)
   (Term DeBruijn DefaultUni DefaultFun ())
 -> Either
      FreeVariableError (Term DeBruijn DefaultUni DefaultFun ()))
-> (QuoteT
      (StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError))
      (Term DeBruijn DefaultUni DefaultFun ())
    -> StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError)
         (Term DeBruijn DefaultUni DefaultFun ()))
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (Either FreeVariableError))
     (Term DeBruijn DefaultUni DefaultFun ())
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuoteT
  (StateT
     (SimplifierTrace
        (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
     (Either FreeVariableError))
  (Term DeBruijn DefaultUni DefaultFun ())
-> StateT
     (SimplifierTrace
        (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
     (Either FreeVariableError)
     (Term DeBruijn DefaultUni DefaultFun ())
forall (m :: Type -> Type) a. Monad m => QuoteT m a -> m a
PLC.runQuoteT (QuoteT
   (StateT
      (SimplifierTrace
         (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
      (Either FreeVariableError))
   (Term DeBruijn DefaultUni DefaultFun ())
 -> Either
      FreeVariableError (Term DeBruijn DefaultUni DefaultFun ()))
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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
      (StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError))
      (Term Name DefaultUni DefaultFun ()))
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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
      (StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError))
      (Term Name DefaultUni DefaultFun ()))
-> Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (Either FreeVariableError))
     (Term Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ Term DeBruijn DefaultUni DefaultFun ()
compiled
      Term Name DefaultUni DefaultFun ()
simplified <- SimplifyOpts Name ()
-> BuiltinSemanticsVariant DefaultFun
-> Term Name DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (Either FreeVariableError))
     (Term Name DefaultUni DefaultFun ())
forall name (uni :: Type -> Type) fun (m :: Type -> Type) a.
Compiling m uni fun name a =>
SimplifyOpts name a
-> BuiltinSemanticsVariant fun
-> Term name uni fun a
-> m (Term name uni fun a)
UPLC.simplifyTerm SimplifyOpts Name ()
forall name a. SimplifyOpts name a
UPLC.defaultSimplifyOpts BuiltinSemanticsVariant DefaultFun
forall a. Default a => a
def Term Name DefaultUni DefaultFun ()
unDB
      Term NamedDeBruijn DefaultUni DefaultFun ()
debruijnd <- Term Name DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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 ()
simplified
      Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (Either FreeVariableError))
     (Term DeBruijn DefaultUni DefaultFun ())
forall a.
a
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (Either FreeVariableError))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term DeBruijn DefaultUni DefaultFun ()
 -> QuoteT
      (StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError))
      (Term DeBruijn DefaultUni DefaultFun ()))
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> Term DeBruijn DefaultUni DefaultFun ())
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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
      (StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError))
      (Term DeBruijn DefaultUni DefaultFun ()))
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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 Word64 -> TermMonad TermResult
raw) = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: S -> Type).
(Word64 -> TermMonad TermResult) -> Term s a
Term ((Word64 -> TermMonad TermResult) -> Term s a)
-> (Word64 -> TermMonad TermResult) -> Term s a
forall a b. (a -> b) -> a -> b
$ \Word64
w64 ->
  let TermMonad (ReaderT (InternalConfig, Config) -> Either Text TermResult
comp) = Word64 -> TermMonad TermResult
raw Word64
w64
   in ReaderT (InternalConfig, Config) (Either Text) TermResult
-> TermMonad TermResult
forall m.
ReaderT (InternalConfig, Config) (Either Text) m -> TermMonad m
TermMonad (ReaderT (InternalConfig, Config) (Either Text) TermResult
 -> TermMonad TermResult)
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
-> TermMonad TermResult
forall a b. (a -> b) -> a -> b
$ ((InternalConfig, Config) -> Either Text TermResult)
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
forall r (m :: Type -> Type) a. (r -> m a) -> ReaderT r m a
ReaderT (((InternalConfig, Config) -> Either Text TermResult)
 -> ReaderT (InternalConfig, Config) (Either Text) TermResult)
-> ((InternalConfig, Config) -> Either Text TermResult)
-> ReaderT (InternalConfig, Config) (Either Text) TermResult
forall a b. (a -> b) -> a -> b
$ \(InternalConfig, Config)
conf -> do
        TermResult
res <- (InternalConfig, Config) -> Either Text TermResult
comp (InternalConfig, Config)
conf
        let compiled :: Term DeBruijn DefaultUni DefaultFun ()
compiled = TermResult -> Term DeBruijn DefaultUni DefaultFun ()
compile' TermResult
res
        case Term DeBruijn DefaultUni DefaultFun ()
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
go Term DeBruijn DefaultUni DefaultFun ()
compiled of
          Left FreeVariableError
err -> Text -> Either Text TermResult
forall a b. a -> Either a b
Left (Text -> Either Text TermResult)
-> (FreeVariableError -> Text)
-> FreeVariableError
-> Either Text 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 -> Either Text TermResult)
-> FreeVariableError -> Either Text TermResult
forall a b. (a -> b) -> a -> b
$ FreeVariableError
err
          Right Term DeBruijn DefaultUni DefaultFun ()
simplified -> TermResult -> Either Text TermResult
forall a. a -> Either Text a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (TermResult -> Either Text TermResult)
-> ([HoistedTerm] -> TermResult)
-> [HoistedTerm]
-> Either Text 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] -> Either Text TermResult)
-> [HoistedTerm] -> Either Text 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 = (StateT
   (SimplifierTrace
      (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
   (Either FreeVariableError)
   (Term DeBruijn DefaultUni DefaultFun ())
 -> SimplifierTrace
      (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type)
 -> Either
      FreeVariableError (Term DeBruijn DefaultUni DefaultFun ()))
-> SimplifierTrace
     (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type)
-> StateT
     (SimplifierTrace
        (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
     (Either FreeVariableError)
     (Term DeBruijn DefaultUni DefaultFun ())
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (SimplifierTrace
     (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
  (Either FreeVariableError)
  (Term DeBruijn DefaultUni DefaultFun ())
-> SimplifierTrace
     (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type)
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m a
evalStateT SimplifierTrace
  (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type)
forall name (uni :: Type -> Type) fun a.
SimplifierTrace name uni fun a
UPLC.initSimplifierTrace (StateT
   (SimplifierTrace
      (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
   (Either FreeVariableError)
   (Term DeBruijn DefaultUni DefaultFun ())
 -> Either
      FreeVariableError (Term DeBruijn DefaultUni DefaultFun ()))
-> (QuoteT
      (StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError))
      (Term DeBruijn DefaultUni DefaultFun ())
    -> StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError)
         (Term DeBruijn DefaultUni DefaultFun ()))
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (Either FreeVariableError))
     (Term DeBruijn DefaultUni DefaultFun ())
-> Either
     FreeVariableError (Term DeBruijn DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuoteT
  (StateT
     (SimplifierTrace
        (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
     (Either FreeVariableError))
  (Term DeBruijn DefaultUni DefaultFun ())
-> StateT
     (SimplifierTrace
        (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
     (Either FreeVariableError)
     (Term DeBruijn DefaultUni DefaultFun ())
forall (m :: Type -> Type) a. Monad m => QuoteT m a -> m a
PLC.runQuoteT (QuoteT
   (StateT
      (SimplifierTrace
         (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
      (Either FreeVariableError))
   (Term DeBruijn DefaultUni DefaultFun ())
 -> Either
      FreeVariableError (Term DeBruijn DefaultUni DefaultFun ()))
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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
      (StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError))
      (Term Name DefaultUni DefaultFun ()))
-> (Term DeBruijn DefaultUni DefaultFun ()
    -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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
      (StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError))
      (Term Name DefaultUni DefaultFun ()))
-> Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (Either FreeVariableError))
     (Term Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ Term DeBruijn DefaultUni DefaultFun ()
compiled
      Term Name DefaultUni DefaultFun ()
simplified <- SimplifyOpts Name ()
-> BuiltinSemanticsVariant DefaultFun
-> Term Name DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (Either FreeVariableError))
     (Term Name DefaultUni DefaultFun ())
forall name (uni :: Type -> Type) fun (m :: Type -> Type) a.
Compiling m uni fun name a =>
SimplifyOpts name a
-> BuiltinSemanticsVariant fun
-> Term name uni fun a
-> m (Term name uni fun a)
UPLC.simplifyTerm SimplifyOpts Name ()
forall name a. SimplifyOpts name a
UPLC.defaultSimplifyOpts BuiltinSemanticsVariant DefaultFun
forall a. Default a => a
def Term Name DefaultUni DefaultFun ()
unDB
      Term NamedDeBruijn DefaultUni DefaultFun ()
debruijnd <- Term Name DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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 ()
simplified
      Term DeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (Either FreeVariableError))
     (Term DeBruijn DefaultUni DefaultFun ())
forall a.
a
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (Either FreeVariableError))
     a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term DeBruijn DefaultUni DefaultFun ()
 -> QuoteT
      (StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError))
      (Term DeBruijn DefaultUni DefaultFun ()))
-> (Term NamedDeBruijn DefaultUni DefaultFun ()
    -> Term DeBruijn DefaultUni DefaultFun ())
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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
      (StateT
         (SimplifierTrace
            (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
         (Either FreeVariableError))
      (Term DeBruijn DefaultUni DefaultFun ()))
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (StateT
        (SimplifierTrace
           (Any @Type) (Any @(Type -> Type)) (Any @Type) (Any @Type))
        (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 #$