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

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

import Control.Monad.Reader (ReaderT (ReaderT), ask, local, runReaderT)
import Crypto.Hash (Context, Digest, hashFinalize, hashInit, hashUpdate)
import Crypto.Hash.Algorithms (Blake2b_160)
import Crypto.Hash.IO (HashAlgorithm)
import Data.Aeson (
  FromJSON (parseJSON),
  ToJSON (toEncoding, toJSON),
  object,
  pairs,
  withObject,
  withText,
  (.:),
  (.:?),
  (.=),
 )
import Data.ByteString qualified as BS
import Data.ByteString.Short qualified as SBS
import Data.Default (def)
import Data.Functor ((<&>))
import Data.Kind (Type)
import Data.List (foldl', groupBy, sortOn)
import Data.Map.Lazy qualified as M
import Data.Monoid (Last (Last))
import Data.Set qualified as S
import Data.String (fromString)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Vector qualified as V
import Flat.Run qualified as F
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 PlutusLedgerApi.Common (serialiseUPLC)
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.
-}

type Dig = Digest Blake2b_160

data HoistedTerm = HoistedTerm Dig 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)

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

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

addHashIndex :: forall alg. HashAlgorithm alg => Integer -> Context alg -> Context alg
addHashIndex :: forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
i = (Context alg -> ByteString -> Context alg)
-> ByteString -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> ByteString -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate ((String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show Integer
i) :: BS.ByteString)

hashUTerm :: forall alg. HashAlgorithm alg => UTerm -> Context alg -> Context alg
hashUTerm :: forall alg.
HashAlgorithm alg =>
UTerm -> Context alg -> Context alg
hashUTerm (UPLC.Var ()
_ DeBruijn
name) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
0 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> ByteString -> Context alg)
-> ByteString -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> ByteString -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (DeBruijn -> ByteString
forall a. Flat a => a -> ByteString
F.flat DeBruijn
name)
hashUTerm (UPLC.LamAbs ()
_ DeBruijn
name UTerm
uterm) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
1 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> ByteString -> Context alg)
-> ByteString -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> ByteString -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (DeBruijn -> ByteString
forall a. Flat a => a -> ByteString
F.flat DeBruijn
name) (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
UTerm -> Context alg -> Context alg
hashUTerm UTerm
uterm
hashUTerm (UPLC.Apply ()
_ UTerm
uterm1 UTerm
uterm2) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
2 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
UTerm -> Context alg -> Context alg
hashUTerm UTerm
uterm1 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
UTerm -> Context alg -> Context alg
hashUTerm UTerm
uterm2
hashUTerm (UPLC.Force ()
_ UTerm
uterm) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
3 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
UTerm -> Context alg -> Context alg
hashUTerm UTerm
uterm
hashUTerm (UPLC.Delay ()
_ UTerm
uterm) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
4 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
UTerm -> Context alg -> Context alg
hashUTerm UTerm
uterm
hashUTerm (UPLC.Constant ()
_ Some @Type (ValueOf DefaultUni)
val) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
5 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> ByteString -> Context alg)
-> ByteString -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> ByteString -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (Some @Type (ValueOf DefaultUni) -> ByteString
forall a. Flat a => a -> ByteString
F.flat Some @Type (ValueOf DefaultUni)
val)
hashUTerm (UPLC.Builtin ()
_ DefaultFun
fun) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
6 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> ByteString -> Context alg)
-> ByteString -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> ByteString -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (DefaultFun -> ByteString
forall a. Flat a => a -> ByteString
F.flat DefaultFun
fun)
hashUTerm (UPLC.Error ()
_) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
7
hashUTerm (UPLC.Constr ()
_ Word64
idx [UTerm]
uterms) =
  Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
8 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
idx) (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Context alg -> Context alg)
 -> (Context alg -> Context alg) -> Context alg -> Context alg)
-> [Context alg -> Context alg] -> Context alg -> Context alg
forall a. (a -> a -> a) -> [a] -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldl1 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (UTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
UTerm -> Context alg -> Context alg
hashUTerm (UTerm -> Context alg -> Context alg)
-> [UTerm] -> [Context alg -> Context alg]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [UTerm]
uterms)
hashUTerm (UPLC.Case ()
_ UTerm
uterm Vector UTerm
uterms) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
9 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
UTerm -> Context alg -> Context alg
hashUTerm UTerm
uterm (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Context alg -> Context alg)
 -> (Context alg -> Context alg) -> Context alg -> Context alg)
-> Vector (Context alg -> Context alg)
-> Context alg
-> Context alg
forall a. (a -> a -> a) -> Vector a -> a
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> a) -> t a -> a
foldl1 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (UTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
UTerm -> Context alg -> Context alg
hashUTerm (UTerm -> Context alg -> Context alg)
-> Vector UTerm -> Vector (Context alg -> Context alg)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector UTerm
uterms)

hashRawTerm' :: forall alg. HashAlgorithm alg => RawTerm -> Context alg -> Context alg
hashRawTerm' :: forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' (RVar Word64
x) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
0 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> ByteString -> Context alg)
-> ByteString -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> ByteString -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (Integer -> ByteString
forall a. Flat a => a -> ByteString
F.flat (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x :: Integer))
hashRawTerm' (RLamAbs Word64
n RawTerm
x) =
  Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
1 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> ByteString -> Context alg)
-> ByteString -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> ByteString -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (Integer -> ByteString
forall a. Flat a => a -> ByteString
F.flat (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n :: Integer)) (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' RawTerm
x
hashRawTerm' (RApply RawTerm
x [RawTerm]
y) =
  Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
2 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' RawTerm
x (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> [RawTerm] -> Context alg)
-> [RawTerm] -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Context alg -> RawTerm -> Context alg)
-> Context alg -> [RawTerm] -> Context alg
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' ((Context alg -> RawTerm -> Context alg)
 -> Context alg -> [RawTerm] -> Context alg)
-> (Context alg -> RawTerm -> Context alg)
-> Context alg
-> [RawTerm]
-> Context alg
forall a b. (a -> b) -> a -> b
$ (RawTerm -> Context alg -> Context alg)
-> Context alg -> RawTerm -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip RawTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm') [RawTerm]
y
hashRawTerm' (RForce RawTerm
x) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
3 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' RawTerm
x
hashRawTerm' (RDelay RawTerm
x) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
4 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' RawTerm
x
hashRawTerm' (RConstant Some @Type (ValueOf DefaultUni)
x) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
5 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> ByteString -> Context alg)
-> ByteString -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> ByteString -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (Some @Type (ValueOf DefaultUni) -> ByteString
forall a. Flat a => a -> ByteString
F.flat Some @Type (ValueOf DefaultUni)
x)
hashRawTerm' (RBuiltin DefaultFun
x) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
6 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> ByteString -> Context alg)
-> ByteString -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> ByteString -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (DefaultFun -> ByteString
forall a. Flat a => a -> ByteString
F.flat DefaultFun
x)
hashRawTerm' RawTerm
RError = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
7
hashRawTerm' (RHoisted (HoistedTerm Dig
hash RawTerm
_)) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
8 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> Dig -> Context alg)
-> Dig -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> Dig -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate Dig
hash
hashRawTerm' (RCompiled UTerm
code) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
9 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> Context alg -> Context alg)
-> Context alg -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> Context alg -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (forall alg.
HashAlgorithm alg =>
UTerm -> Context alg -> Context alg
hashUTerm @alg UTerm
code Context alg
forall a. HashAlgorithm a => Context a
hashInit)
hashRawTerm' (RPlaceHolder Integer
x) = Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
10 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
x
hashRawTerm' (RConstr Word64
x [RawTerm]
y) =
  Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
11 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> ByteString -> Context alg)
-> ByteString -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context alg -> ByteString -> Context alg
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (Integer -> ByteString
forall a. Flat a => a -> ByteString
F.flat (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x :: Integer)) (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> [RawTerm] -> Context alg)
-> [RawTerm] -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Context alg -> RawTerm -> Context alg)
-> Context alg -> [RawTerm] -> Context alg
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' ((Context alg -> RawTerm -> Context alg)
 -> Context alg -> [RawTerm] -> Context alg)
-> (Context alg -> RawTerm -> Context alg)
-> Context alg
-> [RawTerm]
-> Context alg
forall a b. (a -> b) -> a -> b
$ (RawTerm -> Context alg -> Context alg)
-> Context alg -> RawTerm -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip RawTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm') [RawTerm]
y
hashRawTerm' (RCase RawTerm
x [RawTerm]
y) =
  Integer -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
Integer -> Context alg -> Context alg
addHashIndex Integer
12 (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm' RawTerm
x (Context alg -> Context alg)
-> (Context alg -> Context alg) -> Context alg -> Context alg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context alg -> [RawTerm] -> Context alg)
-> [RawTerm] -> Context alg -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Context alg -> RawTerm -> Context alg)
-> Context alg -> [RawTerm] -> Context alg
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' ((Context alg -> RawTerm -> Context alg)
 -> Context alg -> [RawTerm] -> Context alg)
-> (Context alg -> RawTerm -> Context alg)
-> Context alg
-> [RawTerm]
-> Context alg
forall a b. (a -> b) -> a -> b
$ (RawTerm -> Context alg -> Context alg)
-> Context alg -> RawTerm -> Context alg
forall a b c. (a -> b -> c) -> b -> a -> c
flip RawTerm -> Context alg -> Context alg
forall alg.
HashAlgorithm alg =>
RawTerm -> Context alg -> Context alg
hashRawTerm') [RawTerm]
y

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

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

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

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

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

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

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

{- | 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
-}
data Config = Config
  { Config -> Last (LogLevel, TracingMode)
trace'config :: Last (LogLevel, TracingMode)
  , Config -> Last Integer
constantHoist'config :: Last Integer
  }
  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 WIP
instance Semigroup Config where
  (Config Last (LogLevel, TracingMode)
a Last Integer
b) <> :: Config -> Config -> Config
<> (Config Last (LogLevel, TracingMode)
a' Last Integer
b') = Last (LogLevel, TracingMode) -> Last Integer -> Config
Config (Last (LogLevel, TracingMode)
a Last (LogLevel, TracingMode)
-> Last (LogLevel, TracingMode) -> Last (LogLevel, TracingMode)
forall a. Semigroup a => a -> a -> a
<> Last (LogLevel, TracingMode)
a') (Last Integer
b Last Integer -> Last Integer -> Last Integer
forall a. Semigroup a => a -> a -> a
<> Last Integer
b')

-- | @since WIP
instance Monoid Config where
  mempty :: Config
mempty = Last (LogLevel, TracingMode) -> Last Integer -> Config
Config Last (LogLevel, TracingMode)
forall a. Monoid a => a
mempty Last Integer
forall a. Monoid a => a
mempty

-- | @since 1.6.0
instance Pretty Config where
  pretty :: forall ann. Config -> Doc ann
pretty (Config (Last Maybe (LogLevel, TracingMode)
x) Last Integer
_) = 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
. \cfg :: Config
cfg@(Config Last (LogLevel, TracingMode)
_ (Last Maybe Integer
constantHoist)) ->
      case Config
cfg of
        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)
          , Key
"constantHoistThreshold" Key -> Maybe Integer -> Item [Pair]
forall v. ToJSON v => Key -> v -> Item [Pair]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Integer
constantHoist
          ]
        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
          , Key
"constantHoistThreshold" Key -> Maybe Integer -> Item [Pair]
forall v. ToJSON v => Key -> v -> Item [Pair]
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Integer
constantHoist
          ]
  {-# 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
. \cfg :: Config
cfg@(Config Last (LogLevel, TracingMode)
_ (Last Maybe Integer
constantHoist)) ->
      case Config
cfg of
        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))
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (Key
"constantHoistThreshold" Key -> Maybe Integer -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Integer
constantHoist)
        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)
            Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> (Key
"constantHoistThreshold" Key -> Maybe Integer -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Integer
constantHoist)

-- | @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 -> do
    Config
choist <-
      Object
v Object -> Key -> Parser (Maybe Integer)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"constantHoistThreshold"
        Parser (Maybe Integer)
-> (Maybe Integer -> Config) -> Parser Config
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
          Maybe Integer
Nothing -> Config
forall a. Monoid a => a
mempty
          Just Integer
choist' -> Integer -> Config
ConstantHoistThreshold Integer
choist'

    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 (f :: Type -> Type) a. Applicative f => a -> f a
pure (Config -> Parser Config) -> Config -> Parser Config
forall a b. (a -> b) -> a -> b
$ Config
choist Config -> Config -> Config
forall a. Semigroup a => a -> a -> a
<> Config
NoTracing
      Int
1 -> (Config
choist <>) (Config -> Config) -> Parser Config -> Parser Config
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (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) Last Integer
_) = (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) Last Integer
_) = (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) -> Last Integer -> Config
Config (Maybe (LogLevel, TracingMode) -> Last (LogLevel, TracingMode)
forall a. Maybe a -> Last a
Last Maybe (LogLevel, TracingMode)
forall a. Maybe a
Nothing) (Maybe Integer -> Last Integer
forall a. Maybe a -> Last a
Last Maybe Integer
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) -> Last Integer -> 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))) (Maybe Integer -> Last Integer
forall a. Maybe a -> Last a
Last Maybe Integer
forall a. Maybe a
Nothing)

{- | Pattern for matching constant hoist configuration

@since WIP
-}
pattern ConstantHoistNever :: Config
pattern $mConstantHoistNever :: forall {r}. Config -> ((# #) -> r) -> ((# #) -> r) -> r
$bConstantHoistNever :: Config
ConstantHoistNever <- Config _ (Last (Just (-1)))
  where
    ConstantHoistNever = Last (LogLevel, TracingMode) -> Last Integer -> Config
Config (Maybe (LogLevel, TracingMode) -> Last (LogLevel, TracingMode)
forall a. Maybe a -> Last a
Last Maybe (LogLevel, TracingMode)
forall a. Maybe a
Nothing) (Maybe Integer -> Last Integer
forall a. Maybe a -> Last a
Last (Maybe Integer -> Last Integer) -> Maybe Integer -> Last Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
-1)

{- | Pattern for matching constant hoist configuration

@since WIP
-}
pattern ConstantHoistThreshold :: Integer -> Config
pattern $mConstantHoistThreshold :: forall {r}. Config -> (Integer -> r) -> ((# #) -> r) -> r
$bConstantHoistThreshold :: Integer -> Config
ConstantHoistThreshold ch <- Config _ (Last (Just ch))
  where
    ConstantHoistThreshold Integer
ch = Last (LogLevel, TracingMode) -> Last Integer -> Config
Config (Maybe (LogLevel, TracingMode) -> Last (LogLevel, TracingMode)
forall a. Maybe a -> Last a
Last Maybe (LogLevel, TracingMode)
forall a. Maybe a
Nothing) (Maybe Integer -> Last Integer
forall a. Maybe a -> Last a
Last (Maybe Integer -> Last Integer) -> Maybe Integer -> Last Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
ch)

{-# COMPLETE NoTracing, Tracing #-}

-- These are settings we need internally
newtype InternalConfig = InternalConfig
  { InternalConfig -> Bool
internalConfig'dataRecPMatchOptimization :: 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 -> InternalConfig
InternalConfig 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 :: PType) = Term {forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm :: Word64 -> TermMonad TermResult}

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

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

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

{- |
  Lambda abstraction.

  Only works with a single argument.
  Use 'plam' instead, to support currying.
-}
plam' :: (Term s a -> Term s b) -> Term s (a :--> b)
plam' :: forall (s :: S) (a :: PType) (b :: PType).
(Term s a -> Term s b) -> Term s (a :--> b)
plam' Term s a -> Term s b
f = (Word64 -> TermMonad TermResult) -> Term s (a :--> b)
forall (s :: S) (a :: PType).
(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 :: PType).
(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 :: PType).
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 Dig
_ (RLamAbs Word64
n RawTerm
_))) = Word64 -> Maybe Word64
forall a. a -> Maybe a
Just Word64
n
    getArity (RHoisted (HoistedTerm Dig
_ RawTerm
t)) = RawTerm -> Maybe Word64
getArityBuiltin RawTerm
t
    getArity RawTerm
t = RawTerm -> Maybe Word64
getArityBuiltin RawTerm
t

    getArityBuiltin :: RawTerm -> Maybe Word64
    getArityBuiltin :: RawTerm -> Maybe Word64
getArityBuiltin (RBuiltin DefaultFun
PLC.AddInteger) = 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 :: PType) (b :: PType).
Term s a -> (Term s a -> Term s b) -> Term s b
plet Term s a
v Term s a -> Term s b
f = (Word64 -> TermMonad TermResult) -> Term s b
forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
i ->
  Term s a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: PType).
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 :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v) Word64
i
    (TermResult -> RawTerm
getTerm -> RBuiltin DefaultFun
_) -> Term s b -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v) Word64
i
    (TermResult -> RawTerm
getTerm -> RHoisted HoistedTerm
_) -> Term s b -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s a -> Term s b
f Term s a
v) Word64
i
    TermResult
_ -> Term s b -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm (Term s (a :--> b) -> Term s a -> Term s b
forall (s :: S) (a :: PType) (b :: PType).
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 :: PType) (b :: PType).
(Term s a -> Term s b) -> Term s (a :--> b)
plam' Term s a -> Term s b
f) Term s a
v) Word64
i

pthrow' :: HasCallStack => Text -> TermMonad a
pthrow' :: forall a. HasCallStack => Text -> TermMonad a
pthrow' Text
msg = 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 :: PType). HasCallStack => Text -> Term s a
pthrow = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: PType).
(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 :: PType) (b :: PType).
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 :: PType).
(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 :: PType).
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 :: PType).
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 Dig
_ (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 :: PType). Term s a -> Term s (PDelayed a)
pdelay Term s a
x = (Word64 -> TermMonad TermResult) -> Term s (PDelayed a)
forall (s :: S) (a :: PType).
(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 :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term s a
x)

{- |
  Plutus \'force\',
  used to force evaluation of 'PDelayed' terms.
-}
pforce :: Term s (PDelayed a) -> Term s a
pforce :: forall (s :: S) (a :: PType). Term s (PDelayed a) -> Term s a
pforce Term s (PDelayed a)
x =
  (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: PType).
(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 :: PType).
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 :: PType). Term s a
perror = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: PType).
(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 :: PType). Integer -> Term s a
pplaceholder Integer
x = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: PType).
(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 :: PType). (Config -> Term s a) -> Term s a
pgetConfig Config -> Term s a
f = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: PType).
(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 :: PType).
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 :: PType).
(InternalConfig -> Term s a) -> Term s a
pgetInternalConfig InternalConfig -> Term s a
f = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: PType).
(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 :: PType).
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 :: PType).
InternalConfig -> Term s a -> Term s a
pwithInternalConfig InternalConfig
cfg Term s a
t = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: PType).
(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 :: PType).
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 :: PType) (a :: PType) (s :: S). Term s a -> Term s b
punsafeCoerce (Term Word64 -> TermMonad TermResult
x) = (Word64 -> TermMonad TermResult) -> Term s b
forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term Word64 -> TermMonad TermResult
x

punsafeBuiltin :: UPLC.DefaultFun -> Term s a
punsafeBuiltin :: forall (s :: S) (a :: PType). DefaultFun -> Term s a
punsafeBuiltin DefaultFun
f = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: PType).
(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

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

punsafeConstantInternal :: Some (ValueOf PLC.DefaultUni) -> Term s a
punsafeConstantInternal :: forall (s :: S) (a :: PType).
Some @Type (ValueOf DefaultUni) -> Term s a
punsafeConstantInternal Some @Type (ValueOf DefaultUni)
c = (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
_ ->
  let hoisted :: HoistedTerm
hoisted = Dig -> RawTerm -> HoistedTerm
HoistedTerm (RawTerm -> Dig
hashRawTerm (RawTerm -> Dig) -> RawTerm -> Dig
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 :: ClosedTerm a -> TermMonad TermResult
asClosedRawTerm :: forall (a :: PType). ClosedTerm a -> TermMonad TermResult
asClosedRawTerm ClosedTerm a
t = Term (Any @S) a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term (Any @S) a
ClosedTerm a
t Word64
0

-- FIXME: Give proper error message when mutually recursive.
phoistAcyclic :: HasCallStack => ClosedTerm a -> Term s a
phoistAcyclic :: forall (a :: PType) (s :: S).
HasCallStack =>
ClosedTerm a -> Term s a
phoistAcyclic ClosedTerm a
t = (Config -> Term s a) -> Term s a
forall (s :: S) (a :: PType). (Config -> Term s a) -> Term s a
pgetConfig ((Config -> Term s a) -> Term s a)
-> (Config -> Term s a) -> Term s a
forall a b. (a -> b) -> a -> b
$ \Config
cfg -> (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: PType).
(Word64 -> TermMonad TermResult) -> Term s a
Term \Word64
_ ->
  Term (Any @S) a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term (Any @S) a
ClosedTerm 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' -> case Script -> (Either EvalError Script, ExBudget, [Text])
evalScript (Script -> (Either EvalError Script, ExBudget, [Text]))
-> (UTerm -> Script)
-> UTerm
-> (Either EvalError Script, ExBudget, [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program DeBruijn DefaultUni DefaultFun () -> Script
Script (Program DeBruijn DefaultUni DefaultFun () -> Script)
-> (UTerm -> Program DeBruijn DefaultUni DefaultFun ())
-> UTerm
-> Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Version -> UTerm -> 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 (UTerm -> (Either EvalError Script, ExBudget, [Text]))
-> UTerm -> (Either EvalError Script, ExBudget, [Text])
forall a b. (a -> b) -> a -> b
$ Config -> TermResult -> UTerm
compile' Config
cfg TermResult
t' of
      (Right Script
_, ExBudget
_, [Text]
_) ->
        let hoisted :: HoistedTerm
hoisted = Dig -> RawTerm -> HoistedTerm
HoistedTerm (RawTerm -> Dig
hashRawTerm (RawTerm -> Dig) -> (TermResult -> RawTerm) -> TermResult -> Dig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> RawTerm
getTerm (TermResult -> Dig) -> TermResult -> Dig
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 EvalError
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 (EvalError -> String
forall a. Show a => a -> String
show EvalError
e)

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

rawTermToUPLC ::
  (HoistedTerm -> Word64 -> UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()) ->
  Word64 ->
  RawTerm ->
  UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ()
rawTermToUPLC :: (HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
_ Word64
_ (RVar Word64
i) = () -> DeBruijn -> UTerm
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 -> UTerm
m Word64
l (RLamAbs Word64
n RawTerm
t) =
  ((UTerm -> UTerm) -> UTerm -> UTerm)
-> UTerm -> [UTerm -> UTerm] -> UTerm
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 (UTerm -> UTerm) -> UTerm -> UTerm
forall a b. (a -> b) -> a -> b
($) ((HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
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 -> (UTerm -> UTerm) -> [UTerm -> UTerm]
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) ((UTerm -> UTerm) -> [UTerm -> UTerm])
-> (UTerm -> UTerm) -> [UTerm -> UTerm]
forall a b. (a -> b) -> a -> b
$ () -> DeBruijn -> UTerm -> UTerm
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 -> UTerm
m Word64
l (RApply RawTerm
x [RawTerm]
y) =
  let
    inline' :: Word64 -> UTerm -> [UTerm] -> (UTerm, [UTerm])
    inline' :: Word64 -> UTerm -> [UTerm] -> (UTerm, [UTerm])
inline' Word64
_ UTerm
func [] = (UTerm
func, [])
    inline' Word64
target (UPLC.LamAbs () DeBruijn
_ UTerm
body) ((UPLC.Var () (DeBruijn (Index Word64
idx))) : [UTerm]
args) =
      Word64 -> UTerm -> [UTerm] -> (UTerm, [UTerm])
inline' Word64
target (Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst Word64
1 (\Word64
lvl -> () -> DeBruijn -> UTerm
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))) UTerm
body) [UTerm]
args
    inline' Word64
target (UPLC.LamAbs () DeBruijn
_ UTerm
body) (arg :: UTerm
arg@UPLC.Builtin {} : [UTerm]
args) =
      Word64 -> UTerm -> [UTerm] -> (UTerm, [UTerm])
inline' Word64
target (Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst Word64
1 (UTerm -> Word64 -> UTerm
forall a b. a -> b -> a
const UTerm
arg) UTerm
body) [UTerm]
args
    inline' Word64
target (UPLC.LamAbs () DeBruijn
_ UTerm
body) (arg :: UTerm
arg@UPLC.Constant {} : [UTerm]
args) =
      Word64 -> UTerm -> [UTerm] -> (UTerm, [UTerm])
inline' Word64
target (Word64 -> (Word64 -> UTerm) -> UTerm -> UTerm
subst Word64
1 (UTerm -> Word64 -> UTerm
forall a b. a -> b -> a
const UTerm
arg) UTerm
body) [UTerm]
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 UTerm
body) (UTerm
arg : [UTerm]
args) =
      let (UTerm
func', [UTerm]
args') = Word64 -> UTerm -> [UTerm] -> (UTerm, [UTerm])
inline' (Word64
target Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1) UTerm
body [UTerm]
args
       in (() -> DeBruijn -> UTerm -> UTerm
forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann -> Term name uni fun ann
UPLC.LamAbs () DeBruijn
x UTerm
func', UTerm
arg UTerm -> [UTerm] -> [UTerm]
forall a. a -> [a] -> [a]
: [UTerm]
args')
    inline' Word64
target UTerm
func (UTerm
arg : [UTerm]
args) =
      let (UTerm
func', [UTerm]
args') = Word64 -> UTerm -> [UTerm] -> (UTerm, [UTerm])
inline' Word64
target UTerm
func [UTerm]
args
       in (UTerm
func', UTerm
arg UTerm -> [UTerm] -> [UTerm]
forall a. a -> [a] -> [a]
: [UTerm]
args')

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

    applied :: UTerm
applied
      | [UTerm] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [UTerm]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2 = (UTerm -> UTerm -> UTerm) -> UTerm -> [UTerm] -> UTerm
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 (() -> UTerm -> UTerm -> UTerm
forall name (uni :: Type -> Type) fun ann.
ann
-> Term name uni fun ann
-> Term name uni fun ann
-> Term name uni fun ann
UPLC.Apply ()) UTerm
body [UTerm]
args
      | Bool
otherwise = () -> UTerm -> Vector UTerm -> UTerm
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 -> [UTerm] -> UTerm
forall name (uni :: Type -> Type) fun ann.
ann -> Word64 -> [Term name uni fun ann] -> Term name uni fun ann
UPLC.Constr () Word64
0 [UTerm]
args) (UTerm -> Vector UTerm
forall a. a -> Vector a
V.singleton UTerm
body)
   in
    UTerm
applied
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l (RDelay RawTerm
t) = () -> UTerm -> UTerm
forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Delay () ((HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l RawTerm
t)
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l (RForce RawTerm
t) = () -> UTerm -> UTerm
forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann -> Term name uni fun ann
UPLC.Force () ((HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l RawTerm
t)
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
_ Word64
_ (RBuiltin DefaultFun
f) = () -> DefaultFun -> UTerm
forall name (uni :: Type -> Type) fun ann.
ann -> fun -> Term name uni fun ann
UPLC.Builtin () DefaultFun
f
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
_ Word64
_ (RConstant Some @Type (ValueOf DefaultUni)
c) = () -> Some @Type (ValueOf DefaultUni) -> UTerm
forall name (uni :: Type -> Type) fun ann.
ann -> Some @Type (ValueOf uni) -> Term name uni fun ann
UPLC.Constant () Some @Type (ValueOf DefaultUni)
c
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
_ Word64
_ (RCompiled UTerm
code) = UTerm
code
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
_ Word64
_ (RPlaceHolder Integer
_) = () -> UTerm
forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann
UPLC.Error ()
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
_ Word64
_ RawTerm
RError = () -> UTerm
forall name (uni :: Type -> Type) fun ann.
ann -> Term name uni fun ann
UPLC.Error ()
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l (RConstr Word64
i [RawTerm]
xs) = () -> Word64 -> [UTerm] -> UTerm
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 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l (RawTerm -> UTerm) -> [RawTerm] -> [UTerm]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [RawTerm]
xs)
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l (RCase RawTerm
x [RawTerm]
xs) = () -> UTerm -> Vector UTerm -> UTerm
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 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l RawTerm
x) (Vector UTerm -> UTerm) -> Vector UTerm -> UTerm
forall a b. (a -> b) -> a -> b
$ [UTerm] -> Vector UTerm
forall a. [a] -> Vector a
V.fromList ((HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
m Word64
l (RawTerm -> UTerm) -> [RawTerm] -> [UTerm]
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 -> UTerm
m Word64
l (RHoisted HoistedTerm
hoisted) = HoistedTerm -> Word64 -> UTerm
m HoistedTerm
hoisted Word64
l -- UPLC.Var () . DeBruijn . Index $ l - m hoisted

-- Not sure why this match isn't sufficient to cover all pattern.
smallEnoughToInline :: Config -> RawTerm -> Bool
smallEnoughToInline :: Config -> RawTerm -> Bool
smallEnoughToInline (Config Last (LogLevel, TracingMode)
_ (Last Maybe Integer
ch)) = \case
  -- These are always good to line, it is cheaper than variable reference.
  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
  RConstant Some @Type (ValueOf DefaultUni)
c ->
    case Maybe Integer
ch of
      -- Sensible default to inline anything smaller than 20 bytes
      Maybe Integer
Nothing -> Some @Type (ValueOf DefaultUni) -> Integer
getConstantSize Some @Type (ValueOf DefaultUni)
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
20
      Just Integer
inlineThreshold -> (Integer
inlineThreshold Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) Bool -> Bool -> Bool
|| (Some @Type (ValueOf DefaultUni) -> Integer
getConstantSize Some @Type (ValueOf DefaultUni)
c Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
inlineThreshold)
  RawTerm
_ -> Bool
False
  where
    getConstantSize :: Some @Type (ValueOf DefaultUni) -> Integer
getConstantSize Some @Type (ValueOf DefaultUni)
c =
      Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ShortByteString -> Int
SBS.length (ShortByteString -> Int) -> ShortByteString -> Int
forall a b. (a -> b) -> a -> b
$ Program DeBruijn DefaultUni DefaultFun () -> ShortByteString
serialiseUPLC (Program DeBruijn DefaultUni DefaultFun () -> ShortByteString)
-> Program DeBruijn DefaultUni DefaultFun () -> ShortByteString
forall a b. (a -> b) -> a -> b
$ () -> Version -> UTerm -> 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 (() -> Some @Type (ValueOf DefaultUni) -> UTerm
forall name (uni :: Type -> Type) fun ann.
ann -> Some @Type (ValueOf uni) -> Term name uni fun ann
UPLC.Constant () Some @Type (ValueOf DefaultUni)
c)

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

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

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

      hoistedTermRaw :: HoistedTerm -> RawTerm
      hoistedTermRaw :: HoistedTerm -> RawTerm
hoistedTermRaw (HoistedTerm Dig
_ RawTerm
t) = RawTerm
t

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

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

      map' :: HoistedTerm -> Word64 -> UTerm
map' (HoistedTerm Dig
hash RawTerm
term) Word64
l = case Dig -> Map Dig Word64 -> Maybe Word64
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Dig
hash Map Dig Word64
m of
        Just Word64
l' -> () -> DeBruijn -> UTerm
forall name (uni :: Type -> Type) fun ann.
ann -> name -> Term name uni fun ann
UPLC.Var () (DeBruijn -> UTerm) -> (Word64 -> DeBruijn) -> Word64 -> UTerm
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 -> UTerm) -> Word64 -> UTerm
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 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
map' Word64
l RawTerm
term

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

      wrapped :: UTerm
wrapped =
        (UTerm -> (Word64, RawTerm) -> UTerm)
-> UTerm -> [(Word64, RawTerm)] -> UTerm
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'
          (\UTerm
b (Word64
lvl, RawTerm
def) -> () -> UTerm -> UTerm -> UTerm
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 -> UTerm -> UTerm
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) UTerm
b) ((HoistedTerm -> Word64 -> UTerm) -> Word64 -> RawTerm -> UTerm
rawTermToUPLC HoistedTerm -> Word64 -> UTerm
map' Word64
lvl RawTerm
def))
          UTerm
body
          [(Word64, RawTerm)]
defs
   in UTerm
wrapped

-- | Compile a (closed) Plutus Term to a usable script
compile :: Config -> ClosedTerm a -> Either Text Script
compile :: forall (a :: PType). Config -> ClosedTerm a -> Either Text Script
compile Config
config ClosedTerm a
t = case ClosedTerm a -> TermMonad TermResult
forall (a :: PType). ClosedTerm a -> TermMonad TermResult
asClosedRawTerm Term s a
ClosedTerm 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 -> UTerm -> 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 (UTerm -> Program DeBruijn DefaultUni DefaultFun ())
-> (TermResult -> UTerm)
-> TermResult
-> Program DeBruijn DefaultUni DefaultFun ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> TermResult -> UTerm
compile' Config
config (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
defaultInternalConfig, 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 :: PType).
(forall (s :: S). Term s a) -> Either Text Script
compileOptimized forall (s :: S). Term s a
t = case (forall (s :: S). Term s a) -> TermMonad TermResult
forall (a :: PType). ClosedTerm 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
defaultInternalConfig, Config
NoTracing)
    let compiled :: UTerm
compiled = Config -> TermResult -> UTerm
compile' Config
forall a. Monoid a => a
mempty TermResult
configured
    case UTerm -> Either (Error DefaultUni DefaultFun ()) UTerm
go UTerm
compiled of
      Left Error DefaultUni DefaultFun ()
err -> Text -> Either Text Script
forall a b. a -> Either a b
Left (Text -> Either Text Script)
-> (Error DefaultUni DefaultFun () -> Text)
-> Error DefaultUni DefaultFun ()
-> Either Text Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (Error DefaultUni DefaultFun () -> String)
-> Error DefaultUni DefaultFun ()
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error DefaultUni DefaultFun () -> String
forall a. Show a => a -> String
show (Error DefaultUni DefaultFun () -> Either Text Script)
-> Error DefaultUni DefaultFun () -> Either Text Script
forall a b. (a -> b) -> a -> b
$ Error DefaultUni DefaultFun ()
err
      Right UTerm
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)
-> (UTerm -> Script) -> UTerm -> Either Text Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program DeBruijn DefaultUni DefaultFun () -> Script
Script (Program DeBruijn DefaultUni DefaultFun () -> Script)
-> (UTerm -> Program DeBruijn DefaultUni DefaultFun ())
-> UTerm
-> Script
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Version -> UTerm -> 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 (UTerm -> Either Text Script) -> UTerm -> Either Text Script
forall a b. (a -> b) -> a -> b
$ UTerm
simplified
  where
    go ::
      UPLC.Term UPLC.DeBruijn UPLC.DefaultUni UPLC.DefaultFun () ->
      Either (PLC.Error UPLC.DefaultUni UPLC.DefaultFun ()) (UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ())
    go :: UTerm -> Either (Error DefaultUni DefaultFun ()) UTerm
go UTerm
compiled = QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
-> Either (Error DefaultUni DefaultFun ()) UTerm
forall (m :: Type -> Type) a. Monad m => QuoteT m a -> m a
PLC.runQuoteT (QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
 -> Either (Error DefaultUni DefaultFun ()) UTerm)
-> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
-> Either (Error DefaultUni DefaultFun ()) UTerm
forall a b. (a -> b) -> a -> b
$ do
      Term Name DefaultUni DefaultFun ()
unDB <- Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either (Error DefaultUni DefaultFun ()))
     (Term Name DefaultUni DefaultFun ())
forall (m :: Type -> Type) e (uni :: Type -> Type) fun ann.
(MonadQuote m, AsFreeVariableError e, MonadError e m) =>
Term NamedDeBruijn uni fun ann -> m (Term Name uni fun ann)
UPLC.unDeBruijnTerm (Term NamedDeBruijn DefaultUni DefaultFun ()
 -> QuoteT
      (Either (Error DefaultUni DefaultFun ()))
      (Term Name DefaultUni DefaultFun ()))
-> (UTerm -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> UTerm
-> QuoteT
     (Either (Error DefaultUni DefaultFun ()))
     (Term Name DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeBruijn -> NamedDeBruijn)
-> UTerm -> 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 (UTerm
 -> QuoteT
      (Either (Error DefaultUni DefaultFun ()))
      (Term Name DefaultUni DefaultFun ()))
-> UTerm
-> QuoteT
     (Either (Error DefaultUni DefaultFun ()))
     (Term Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ UTerm
compiled
      Term Name DefaultUni DefaultFun ()
simplified <- SimplifyOpts Name ()
-> BuiltinSemanticsVariant DefaultFun
-> Term Name DefaultUni DefaultFun ()
-> QuoteT
     (Either (Error DefaultUni DefaultFun ()))
     (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
     (Either (Error DefaultUni DefaultFun ()))
     (Term NamedDeBruijn DefaultUni DefaultFun ())
forall e (m :: Type -> Type) (uni :: Type -> Type) fun ann.
(AsFreeVariableError e, MonadError e m) =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm Term Name DefaultUni DefaultFun ()
simplified
      UTerm -> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
forall a. a -> QuoteT (Either (Error DefaultUni DefaultFun ())) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (UTerm -> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm)
-> (Term NamedDeBruijn DefaultUni DefaultFun () -> UTerm)
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedDeBruijn -> DeBruijn)
-> Term NamedDeBruijn DefaultUni DefaultFun () -> UTerm
forall name name' (uni :: Type -> Type) fun ann.
(name -> name') -> Term name uni fun ann -> Term name' uni fun ann
UPLC.termMapNames NamedDeBruijn -> DeBruijn
UPLC.unNameDeBruijn (Term NamedDeBruijn DefaultUni DefaultFun ()
 -> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm)
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
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 :: PType).
(forall (s :: S). Term s a) -> forall (s :: S). Term s a
optimizeTerm (Term Word64 -> TermMonad TermResult
raw) = (Config -> Term s a) -> Term s a
forall (s :: S) (a :: PType). (Config -> Term s a) -> Term s a
pgetConfig ((Config -> Term s a) -> Term s a)
-> (Config -> Term s a) -> Term s a
forall a b. (a -> b) -> a -> b
$ \Config
cfg -> (Word64 -> TermMonad TermResult) -> Term s a
forall (s :: S) (a :: PType).
(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 :: UTerm
compiled = Config -> TermResult -> UTerm
compile' Config
cfg TermResult
res
        case UTerm -> Either (Error DefaultUni DefaultFun ()) UTerm
go UTerm
compiled of
          Left Error DefaultUni DefaultFun ()
err -> Text -> Either Text TermResult
forall a b. a -> Either a b
Left (Text -> Either Text TermResult)
-> (Error DefaultUni DefaultFun () -> Text)
-> Error DefaultUni DefaultFun ()
-> Either Text TermResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (Error DefaultUni DefaultFun () -> String)
-> Error DefaultUni DefaultFun ()
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error DefaultUni DefaultFun () -> String
forall a. Show a => a -> String
show (Error DefaultUni DefaultFun () -> Either Text TermResult)
-> Error DefaultUni DefaultFun () -> Either Text TermResult
forall a b. (a -> b) -> a -> b
$ Error DefaultUni DefaultFun ()
err
          Right UTerm
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 (UTerm -> RawTerm
RCompiled UTerm
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 (PLC.Error UPLC.DefaultUni UPLC.DefaultFun ()) (UPLC.Term DeBruijn UPLC.DefaultUni UPLC.DefaultFun ())
    go :: UTerm -> Either (Error DefaultUni DefaultFun ()) UTerm
go UTerm
compiled = QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
-> Either (Error DefaultUni DefaultFun ()) UTerm
forall (m :: Type -> Type) a. Monad m => QuoteT m a -> m a
PLC.runQuoteT (QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
 -> Either (Error DefaultUni DefaultFun ()) UTerm)
-> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
-> Either (Error DefaultUni DefaultFun ()) UTerm
forall a b. (a -> b) -> a -> b
$ do
      Term Name DefaultUni DefaultFun ()
unDB <- Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT
     (Either (Error DefaultUni DefaultFun ()))
     (Term Name DefaultUni DefaultFun ())
forall (m :: Type -> Type) e (uni :: Type -> Type) fun ann.
(MonadQuote m, AsFreeVariableError e, MonadError e m) =>
Term NamedDeBruijn uni fun ann -> m (Term Name uni fun ann)
UPLC.unDeBruijnTerm (Term NamedDeBruijn DefaultUni DefaultFun ()
 -> QuoteT
      (Either (Error DefaultUni DefaultFun ()))
      (Term Name DefaultUni DefaultFun ()))
-> (UTerm -> Term NamedDeBruijn DefaultUni DefaultFun ())
-> UTerm
-> QuoteT
     (Either (Error DefaultUni DefaultFun ()))
     (Term Name DefaultUni DefaultFun ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeBruijn -> NamedDeBruijn)
-> UTerm -> 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 (UTerm
 -> QuoteT
      (Either (Error DefaultUni DefaultFun ()))
      (Term Name DefaultUni DefaultFun ()))
-> UTerm
-> QuoteT
     (Either (Error DefaultUni DefaultFun ()))
     (Term Name DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ UTerm
compiled
      Term Name DefaultUni DefaultFun ()
simplified <- SimplifyOpts Name ()
-> BuiltinSemanticsVariant DefaultFun
-> Term Name DefaultUni DefaultFun ()
-> QuoteT
     (Either (Error DefaultUni DefaultFun ()))
     (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
     (Either (Error DefaultUni DefaultFun ()))
     (Term NamedDeBruijn DefaultUni DefaultFun ())
forall e (m :: Type -> Type) (uni :: Type -> Type) fun ann.
(AsFreeVariableError e, MonadError e m) =>
Term Name uni fun ann -> m (Term NamedDeBruijn uni fun ann)
UPLC.deBruijnTerm Term Name DefaultUni DefaultFun ()
simplified
      UTerm -> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
forall a. a -> QuoteT (Either (Error DefaultUni DefaultFun ())) a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (UTerm -> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm)
-> (Term NamedDeBruijn DefaultUni DefaultFun () -> UTerm)
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedDeBruijn -> DeBruijn)
-> Term NamedDeBruijn DefaultUni DefaultFun () -> UTerm
forall name name' (uni :: Type -> Type) fun ann.
(name -> name') -> Term name uni fun ann -> Term name' uni fun ann
UPLC.termMapNames NamedDeBruijn -> DeBruijn
UPLC.unNameDeBruijn (Term NamedDeBruijn DefaultUni DefaultFun ()
 -> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm)
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> QuoteT (Either (Error DefaultUni DefaultFun ())) UTerm
forall a b. (a -> b) -> a -> b
$ Term NamedDeBruijn DefaultUni DefaultFun ()
debruijnd

hashTerm :: Config -> ClosedTerm a -> Either Text Dig
hashTerm :: forall (a :: PType). Config -> ClosedTerm a -> Either Text Dig
hashTerm Config
config ClosedTerm a
t = RawTerm -> Dig
hashRawTerm (RawTerm -> Dig) -> (TermResult -> RawTerm) -> TermResult -> Dig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermResult -> RawTerm
getTerm (TermResult -> Dig) -> Either Text TermResult -> Either Text Dig
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (InternalConfig, Config) (Either Text) TermResult
-> (InternalConfig, Config) -> Either Text TermResult
forall r (m :: Type -> Type) a. ReaderT r m a -> r -> m a
runReaderT (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 (Any @S) a -> Word64 -> TermMonad TermResult
forall (s :: S) (a :: PType).
Term s a -> Word64 -> TermMonad TermResult
asRawTerm Term (Any @S) a
ClosedTerm a
t Word64
0) (InternalConfig
defaultInternalConfig, Config
config)

{- |
  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 :: PType) (b :: PType).
Term s (a :--> b) -> Term s a -> Term s b
(#) = Term s (a :--> b) -> Term s a -> Term s b
forall (s :: S) (a :: PType) (b :: PType).
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 :: PType) (b :: PType).
Term s (a :--> b) -> Term s a -> Term s b
(#$) = Term s (a :--> b) -> Term s a -> Term s b
forall (s :: S) (a :: PType) (b :: PType).
Term s (a :--> b) -> Term s a -> Term s b
papp

infixr 0 #$