{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE ViewPatterns        #-}

module PlutusCore.Executable.Common
    ( module PlutusCore.Executable.Types
    , PrintBudgetState
    , getInput
    , getInteresting
    , getPlcExamples
    , prettyPrintByMode
    , getUplcExamples
    , helpText
    , loadASTfromFlat
    , parseInput
    , parseNamedProgram
    , printBudgetState
    , readProgram
    , runConvert
    , runDumpModel
    , runPrint
    , runPrintBuiltinSignatures
    , runPrintExample
    , topSrcSpan
    , writeFlat
    , writePrettyToOutput
    , writeProgram
    , writeToOutput
    ) where

import PlutusPrelude

import PlutusCore.Executable.AstIO
import PlutusCore.Executable.Types

import PlutusCore qualified as PLC
import PlutusCore.Builtin qualified as PLC
import PlutusCore.Check.Uniques as PLC (checkProgram)
import PlutusCore.Compiler.Erase qualified as PLC
import PlutusCore.Error (AsUniqueError, ParserErrorBundle (..))
import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (..), ExRestrictingBudget (..))
import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC
import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..))
import PlutusCore.Generators.Hedgehog qualified as Gen
import PlutusCore.Generators.Hedgehog.Interesting qualified as Gen
import PlutusCore.Generators.Hedgehog.Test qualified as Gen
import PlutusCore.Normalize (normalizeType)
import PlutusCore.Parser qualified as PLC (program)
import PlutusCore.Pretty qualified as PP
import PlutusCore.Rename (rename)
import PlutusCore.StdLib.Data.Bool qualified as StdLib
import PlutusCore.StdLib.Data.ChurchNat qualified as StdLib
import PlutusCore.StdLib.Data.Integer qualified as StdLib
import PlutusCore.StdLib.Data.Unit qualified as StdLib

import UntypedPlutusCore qualified as UPLC
import UntypedPlutusCore.Check.Uniques qualified as UPLC (checkProgram)
import UntypedPlutusCore.Evaluation.Machine.Cek qualified as Cek
import UntypedPlutusCore.Parser qualified as UPLC (parse, program)

import PlutusIR.Check.Uniques as PIR (checkProgram)
import PlutusIR.Core.Instance.Pretty ()
import PlutusIR.Parser qualified as PIR (parse, program)

import Control.Monad.Except
import Data.Aeson qualified as Aeson
import Data.ByteString.Lazy qualified as BSL
import Data.HashMap.Monoidal qualified as H
import Data.Kind (Type)
import Data.List (intercalate)
import Data.List qualified as List
import Data.Maybe (fromJust)
import Data.Proxy (Proxy (..))
import Data.SatInt
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Flat (Flat)
import GHC.TypeLits (symbolVal)
import Prettyprinter ((<+>))

import Text.Megaparsec (errorBundlePretty)
import Text.Printf (printf)

----------- ProgramLike type class -----------

class ProgramLike p where
    -- | Parse a program.  The first argument (normally the file path) describes
    -- the input stream, the second is the program text.
    parseNamedProgram ::
        String -> T.Text -> Either ParserErrorBundle (p PLC.SrcSpan)

    -- | Check a program for unique names.
    -- Throws a @UniqueError@ when not all names are unique.
    checkUniques ::
        ( Ord ann
        , AsUniqueError e ann
        , MonadError e m
        ) =>
        p ann ->
        m ()

    -- | Convert names to de Bruijn indices and then serialise
    serialiseProgramFlat :: (Flat ann, PP.Pretty ann) => AstNameType -> p ann -> BSL.ByteString

    -- | Read and deserialise a Flat-encoded AST
    loadASTfromFlat :: Flat ann => AstNameType -> Input -> IO (p ann)

-- | Instance for PIR program.
instance ProgramLike PirProg where
    parseNamedProgram :: String -> ExampleName -> Either ParserErrorBundle (PirProg SrcSpan)
parseNamedProgram String
inputName = QuoteT (Either ParserErrorBundle) (PirProg SrcSpan)
-> Either ParserErrorBundle (PirProg SrcSpan)
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
PLC.runQuoteT (QuoteT (Either ParserErrorBundle) (PirProg SrcSpan)
 -> Either ParserErrorBundle (PirProg SrcSpan))
-> (ExampleName
    -> QuoteT (Either ParserErrorBundle) (PirProg SrcSpan))
-> ExampleName
-> Either ParserErrorBundle (PirProg SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (PirProg SrcSpan)
-> String
-> ExampleName
-> QuoteT (Either ParserErrorBundle) (PirProg SrcSpan)
forall e (m :: * -> *) a.
(AsParserErrorBundle e, MonadError e m, MonadQuote m) =>
Parser a -> String -> ExampleName -> m a
PIR.parse Parser (PirProg SrcSpan)
PIR.program String
inputName
    checkUniques :: forall ann e (m :: * -> *).
(Ord ann, AsUniqueError e ann, MonadError e m) =>
PirProg ann -> m ()
checkUniques = (UniqueError ann -> Bool)
-> Program TyName Name DefaultUni DefaultFun ann -> m ()
forall ann name tyname e (m :: * -> *) (uni :: * -> *) fun.
(Ord ann, HasUnique name TermUnique, HasUnique tyname TypeUnique,
 AsUniqueError e ann, MonadError e m) =>
(UniqueError ann -> Bool)
-> Program tyname name uni fun ann -> m ()
PIR.checkProgram (Bool -> UniqueError ann -> Bool
forall a b. a -> b -> a
const Bool
True)
    serialiseProgramFlat :: forall ann.
(Flat ann, Pretty ann) =>
AstNameType -> PirProg ann -> ByteString
serialiseProgramFlat = AstNameType -> PirProg ann -> ByteString
forall ann. Flat ann => AstNameType -> PirProg ann -> ByteString
serialisePirProgramFlat
    loadASTfromFlat :: forall ann. Flat ann => AstNameType -> Input -> IO (PirProg ann)
loadASTfromFlat = AstNameType -> Input -> IO (PirProg ann)
forall ann. Flat ann => AstNameType -> Input -> IO (PirProg ann)
loadPirASTfromFlat

-- | Instance for PLC program.
instance ProgramLike PlcProg where
    parseNamedProgram :: String -> ExampleName -> Either ParserErrorBundle (PlcProg SrcSpan)
parseNamedProgram String
inputName = QuoteT (Either ParserErrorBundle) (PlcProg SrcSpan)
-> Either ParserErrorBundle (PlcProg SrcSpan)
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
PLC.runQuoteT (QuoteT (Either ParserErrorBundle) (PlcProg SrcSpan)
 -> Either ParserErrorBundle (PlcProg SrcSpan))
-> (ExampleName
    -> QuoteT (Either ParserErrorBundle) (PlcProg SrcSpan))
-> ExampleName
-> Either ParserErrorBundle (PlcProg SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (PlcProg SrcSpan)
-> String
-> ExampleName
-> QuoteT (Either ParserErrorBundle) (PlcProg SrcSpan)
forall e (m :: * -> *) a.
(AsParserErrorBundle e, MonadError e m, MonadQuote m) =>
Parser a -> String -> ExampleName -> m a
UPLC.parse Parser (PlcProg SrcSpan)
PLC.program String
inputName
    checkUniques :: forall ann e (m :: * -> *).
(Ord ann, AsUniqueError e ann, MonadError e m) =>
PlcProg ann -> m ()
checkUniques = (UniqueError ann -> Bool)
-> Program TyName Name DefaultUni DefaultFun ann -> m ()
forall ann name tyname e (m :: * -> *) (uni :: * -> *) fun.
(Ord ann, HasUnique name TermUnique, HasUnique tyname TypeUnique,
 AsUniqueError e ann, MonadError e m) =>
(UniqueError ann -> Bool)
-> Program tyname name uni fun ann -> m ()
PLC.checkProgram (Bool -> UniqueError ann -> Bool
forall a b. a -> b -> a
const Bool
True)
    serialiseProgramFlat :: forall ann.
(Flat ann, Pretty ann) =>
AstNameType -> PlcProg ann -> ByteString
serialiseProgramFlat = AstNameType -> PlcProg ann -> ByteString
forall ann. Flat ann => AstNameType -> PlcProg ann -> ByteString
serialisePlcProgramFlat
    loadASTfromFlat :: forall ann. Flat ann => AstNameType -> Input -> IO (PlcProg ann)
loadASTfromFlat = AstNameType -> Input -> IO (PlcProg ann)
forall ann. Flat ann => AstNameType -> Input -> IO (PlcProg ann)
loadPlcASTfromFlat

-- | Instance for UPLC program.
instance ProgramLike UplcProg where
    parseNamedProgram :: String
-> ExampleName -> Either ParserErrorBundle (UplcProg SrcSpan)
parseNamedProgram String
inputName = QuoteT (Either ParserErrorBundle) (UplcProg SrcSpan)
-> Either ParserErrorBundle (UplcProg SrcSpan)
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
PLC.runQuoteT (QuoteT (Either ParserErrorBundle) (UplcProg SrcSpan)
 -> Either ParserErrorBundle (UplcProg SrcSpan))
-> (ExampleName
    -> QuoteT (Either ParserErrorBundle) (UplcProg SrcSpan))
-> ExampleName
-> Either ParserErrorBundle (UplcProg SrcSpan)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (UplcProg SrcSpan)
-> String
-> ExampleName
-> QuoteT (Either ParserErrorBundle) (UplcProg SrcSpan)
forall e (m :: * -> *) a.
(AsParserErrorBundle e, MonadError e m, MonadQuote m) =>
Parser a -> String -> ExampleName -> m a
UPLC.parse Parser (UplcProg SrcSpan)
UPLC.program String
inputName
    checkUniques :: forall ann e (m :: * -> *).
(Ord ann, AsUniqueError e ann, MonadError e m) =>
UplcProg ann -> m ()
checkUniques = (UniqueError ann -> Bool)
-> Program Name DefaultUni DefaultFun ann -> m ()
forall ann name e (m :: * -> *) (uni :: * -> *) fun.
(Ord ann, HasUnique name TermUnique, AsUniqueError e ann,
 MonadError e m) =>
(UniqueError ann -> Bool) -> Program name uni fun ann -> m ()
UPLC.checkProgram (Bool -> UniqueError ann -> Bool
forall a b. a -> b -> a
const Bool
True)
    serialiseProgramFlat :: forall ann.
(Flat ann, Pretty ann) =>
AstNameType -> UplcProg ann -> ByteString
serialiseProgramFlat = AstNameType -> UplcProg ann -> ByteString
forall ann. Flat ann => AstNameType -> UplcProg ann -> ByteString
serialiseUplcProgramFlat
    loadASTfromFlat :: forall ann. Flat ann => AstNameType -> Input -> IO (UplcProg ann)
loadASTfromFlat = AstNameType -> Input -> IO (UplcProg ann)
forall ann. Flat ann => AstNameType -> Input -> IO (UplcProg ann)
loadUplcASTfromFlat


---------------- Printing budgets and costs ----------------

-- Convert a time in picoseconds into a readable format with appropriate units
formatTimePicoseconds :: Double -> String
formatTimePicoseconds :: Double -> String
formatTimePicoseconds Double
t
    | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1e12 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.3f s" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e12)
    | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1e9 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.3f ms" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e9)
    | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1e6 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.3f μs" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e6)
    | Double
t Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= Double
1e3 = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%.3f ns" (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1e3)
    | Bool
otherwise = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%f ps" Double
t

printBudgetStateBudget :: CekModel -> ExBudget -> IO ()
printBudgetStateBudget :: CekModel -> ExBudget -> IO ()
printBudgetStateBudget CekModel
model ExBudget
b =
    case CekModel
model of
        CekModel
Unit -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        CekModel
_ ->
            let ExCPU CostingInteger
cpu = ExBudget -> ExCPU
exBudgetCPU ExBudget
b
                ExMemory CostingInteger
mem = ExBudget -> ExMemory
exBudgetMemory ExBudget
b
             in do
                    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"CPU budget:    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CostingInteger -> String
forall a. Show a => a -> String
show CostingInteger
cpu
                    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Memory budget: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CostingInteger -> String
forall a. Show a => a -> String
show CostingInteger
mem

printBudgetStateTally ::
    (Cek.Hashable fun, Show fun) =>
    UplcTerm () ->
    CekModel ->
    Cek.CekExTally fun ->
    IO ()
printBudgetStateTally :: forall fun.
(Hashable fun, Show fun) =>
UplcTerm () -> CekModel -> CekExTally fun -> IO ()
printBudgetStateTally UplcTerm ()
term CekModel
model (Cek.CekExTally MonoidalHashMap (ExBudgetCategory fun) ExBudget
costs) = do
    (StepKind -> IO ()) -> [StepKind] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ StepKind -> IO ()
printStepCost [StepKind]
allStepKinds
    String -> IO ()
putStrLn String
""
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"startup    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (ExBudget -> String
budgetToString (ExBudget -> String) -> ExBudget -> String
forall a b. (a -> b) -> a -> b
$ ExBudgetCategory fun -> ExBudget
getSpent ExBudgetCategory fun
forall fun. ExBudgetCategory fun
Cek.BStartup)
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"compute    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExBudget -> String
budgetToString ExBudget
totalComputeCost
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"AST nodes  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
"%15d" (Size -> Integer
UPLC.unSize (Size -> Integer) -> Size -> Integer
forall a b. (a -> b) -> a -> b
$ UplcTerm () -> Size
forall name (uni :: * -> *) fun ann. Term name uni fun ann -> Size
UPLC.termSize UplcTerm ()
term)
    String -> IO ()
putStrLn String
""
    case CekModel
model of
        CekModel
Default ->
            do
                String -> IO ()
putStrLn String
""
                ((fun, ExBudget) -> IO ()) -> [(fun, ExBudget)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
                    ( \(fun
b, ExBudget
cost) ->
                        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%-22s %s" (fun -> String
forall a. Show a => a -> String
show fun
b) (ExBudget -> String
budgetToString ExBudget
cost :: String)
                    )
                    [(fun, ExBudget)]
builtinsAndCosts
                String -> IO ()
putStrLn String
""
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Total builtin costs:   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ExBudget -> String
budgetToString ExBudget
totalBuiltinCosts
                String -> Double -> IO ()
forall r. PrintfType r => String -> r
printf String
"Time spent executing builtins:  %4.2f%%\n"
                        (Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* ExBudget -> Double
getCPU ExBudget
totalBuiltinCosts Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ ExBudget -> Double
getCPU ExBudget
totalCost)
                String -> IO ()
putStrLn String
""
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Total budget spent:    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall r. PrintfType r => String -> r
printf (ExBudget -> String
budgetToString ExBudget
totalCost)
                String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Predicted execution time: "
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Double -> String
formatTimePicoseconds (Double -> String) -> Double -> String
forall a b. (a -> b) -> a -> b
$ ExBudget -> Double
getCPU ExBudget
totalCost)
        CekModel
Unit -> do
            String -> IO ()
putStrLn String
""
            ((fun, ExBudget) -> IO ()) -> [(fun, ExBudget)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
                ( \(fun
b, ExBudget
cost) ->
                    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%-22s %s" (fun -> String
forall a. Show a => a -> String
show fun
b) (ExBudget -> String
budgetToString ExBudget
cost :: String)
                )
                [(fun, ExBudget)]
builtinsAndCosts
  where
    allStepKinds :: [StepKind]
allStepKinds = [StepKind
forall a. Bounded a => a
minBound..StepKind
forall a. Bounded a => a
maxBound] :: [Cek.StepKind]
    getSpent :: ExBudgetCategory fun -> ExBudget
getSpent ExBudgetCategory fun
k =
        case ExBudgetCategory fun
-> MonoidalHashMap (ExBudgetCategory fun) ExBudget
-> Maybe ExBudget
forall k v.
(Eq k, Hashable k) =>
k -> MonoidalHashMap k v -> Maybe v
H.lookup ExBudgetCategory fun
k MonoidalHashMap (ExBudgetCategory fun) ExBudget
costs of
            Just ExBudget
v  -> ExBudget
v
            Maybe ExBudget
Nothing -> ExCPU -> ExMemory -> ExBudget
ExBudget ExCPU
0 ExMemory
0
    totalComputeCost :: ExBudget
totalComputeCost =
        -- For unitCekCosts this will be the total number of compute steps
        (StepKind -> ExBudget) -> [StepKind] -> ExBudget
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (ExBudgetCategory fun -> ExBudget
getSpent (ExBudgetCategory fun -> ExBudget)
-> (StepKind -> ExBudgetCategory fun) -> StepKind -> ExBudget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StepKind -> ExBudgetCategory fun
forall fun. StepKind -> ExBudgetCategory fun
Cek.BStep) [StepKind]
allStepKinds
    budgetToString :: ExBudget -> String
budgetToString (ExBudget (ExCPU CostingInteger
cpu) (ExMemory CostingInteger
mem)) =
        case CekModel
model of
            -- Not %d: doesn't work when CostingInteger is SatInt.
            CekModel
Default -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%15s  %15s" (CostingInteger -> String
forall a. Show a => a -> String
show CostingInteger
cpu) (CostingInteger -> String
forall a. Show a => a -> String
show CostingInteger
mem) :: String
            -- Memory usage figures are meaningless in this case
            CekModel
Unit    -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%15s" (CostingInteger -> String
forall a. Show a => a -> String
show CostingInteger
cpu) :: String
    printStepCost :: StepKind -> IO ()
printStepCost StepKind
constr =
        String -> String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"%-10s %20s\n" (String -> String
forall a. HasCallStack => [a] -> [a]
tail (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ StepKind -> String
forall a. Show a => a -> String
show StepKind
constr) (ExBudget -> String
budgetToString (ExBudget -> String)
-> (ExBudgetCategory fun -> ExBudget)
-> ExBudgetCategory fun
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExBudgetCategory fun -> ExBudget
getSpent (ExBudgetCategory fun -> String) -> ExBudgetCategory fun -> String
forall a b. (a -> b) -> a -> b
$ StepKind -> ExBudgetCategory fun
forall fun. StepKind -> ExBudgetCategory fun
Cek.BStep StepKind
constr)
    getBuiltinCost :: [(a, b)] -> (ExBudgetCategory a, b) -> [(a, b)]
getBuiltinCost [(a, b)]
l (ExBudgetCategory a, b)
e = case (ExBudgetCategory a, b)
e of (Cek.BBuiltinApp a
b, b
cost) -> (a
b, b
cost) (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: [(a, b)]
l; (ExBudgetCategory a, b)
_ -> [(a, b)]
l
    builtinsAndCosts :: [(fun, ExBudget)]
builtinsAndCosts = ([(fun, ExBudget)]
 -> (ExBudgetCategory fun, ExBudget) -> [(fun, ExBudget)])
-> [(fun, ExBudget)]
-> [(ExBudgetCategory fun, ExBudget)]
-> [(fun, ExBudget)]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl [(fun, ExBudget)]
-> (ExBudgetCategory fun, ExBudget) -> [(fun, ExBudget)]
forall {a} {b}. [(a, b)] -> (ExBudgetCategory a, b) -> [(a, b)]
getBuiltinCost [] (MonoidalHashMap (ExBudgetCategory fun) ExBudget
-> [(ExBudgetCategory fun, ExBudget)]
forall k a. MonoidalHashMap k a -> [(k, a)]
H.toList MonoidalHashMap (ExBudgetCategory fun) ExBudget
costs)
    totalBuiltinCosts :: ExBudget
totalBuiltinCosts = [ExBudget] -> ExBudget
forall a. Monoid a => [a] -> a
mconcat (((fun, ExBudget) -> ExBudget) -> [(fun, ExBudget)] -> [ExBudget]
forall a b. (a -> b) -> [a] -> [b]
map (fun, ExBudget) -> ExBudget
forall a b. (a, b) -> b
snd [(fun, ExBudget)]
builtinsAndCosts)
    getCPU :: ExBudget -> Double
getCPU ExBudget
b = let ExCPU CostingInteger
b' = ExBudget -> ExCPU
exBudgetCPU ExBudget
b in CostingInteger -> Double
forall a. Num a => CostingInteger -> a
fromSatInt CostingInteger
b' :: Double
    totalCost :: ExBudget
totalCost = ExBudgetCategory fun -> ExBudget
getSpent ExBudgetCategory fun
forall fun. ExBudgetCategory fun
Cek.BStartup ExBudget -> ExBudget -> ExBudget
forall a. Semigroup a => a -> a -> a
<> ExBudget
totalComputeCost ExBudget -> ExBudget -> ExBudget
forall a. Semigroup a => a -> a -> a
<> ExBudget
totalBuiltinCosts :: ExBudget

class PrintBudgetState cost where
    printBudgetState ::
        UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun () ->
        CekModel ->
        cost ->
        IO ()

-- TODO: Tidy this up.  We're passing in the term and the CEK cost model
-- here, but we only need them in tallying mode (where we need the term so
-- we can print out the AST size and we need the model type to decide how
-- much information we're going to print out).

instance PrintBudgetState Cek.CountingSt where
    printBudgetState :: UplcTerm () -> CekModel -> CountingSt -> IO ()
printBudgetState UplcTerm ()
_term CekModel
model (Cek.CountingSt ExBudget
budget) = CekModel -> ExBudget -> IO ()
printBudgetStateBudget CekModel
model ExBudget
budget

instance (Cek.Hashable fun, Show fun) => PrintBudgetState (Cek.TallyingSt fun) where
    printBudgetState :: UplcTerm () -> CekModel -> TallyingSt fun -> IO ()
printBudgetState UplcTerm ()
term CekModel
model (Cek.TallyingSt CekExTally fun
tally ExBudget
budget) = do
        CekModel -> ExBudget -> IO ()
printBudgetStateBudget CekModel
model ExBudget
budget
        String -> IO ()
putStrLn String
""
        UplcTerm () -> CekModel -> CekExTally fun -> IO ()
forall fun.
(Hashable fun, Show fun) =>
UplcTerm () -> CekModel -> CekExTally fun -> IO ()
printBudgetStateTally UplcTerm ()
term CekModel
model CekExTally fun
tally

instance PrintBudgetState Cek.RestrictingSt where
    printBudgetState :: UplcTerm () -> CekModel -> RestrictingSt -> IO ()
printBudgetState UplcTerm ()
_term CekModel
model (Cek.RestrictingSt (ExRestrictingBudget ExBudget
budget)) =
        CekModel -> ExBudget -> IO ()
printBudgetStateBudget CekModel
model ExBudget
budget

helpText ::
    -- | Either "Untyped Plutus Core" or "Typed Plutus Core"
    String ->
    String
helpText :: String -> String
helpText String
lang =
    String
"This program provides a number of utilities for dealing with "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lang
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" programs, including application, evaluation, and conversion between a "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"number of different formats.  The program also provides a number of example "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"programs.  Some commands read or write Plutus Core abstract "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"syntax trees serialised in Flat format: ASTs are always written with "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"unit annotations, and any Flat-encoded AST supplied as input must also be "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"equipped with unit annotations.  Attempting to read a serialised AST with any "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"non-unit annotation type will cause an error."


---------------- Reading programs from files ----------------

-- Read a source program
getInput :: Input -> IO T.Text
getInput :: Input -> IO ExampleName
getInput (FileInput String
file) = String -> IO ExampleName
T.readFile String
file
getInput Input
StdInput         = IO ExampleName
T.getContents

-- | Read and parse and check the program for @UniqueError@'s.
parseInput ::
    (ProgramLike p, PLC.Rename (p PLC.SrcSpan)) =>
    -- | The source program
    Input ->
    -- | The output is a program with annotation
    IO (T.Text, p PLC.SrcSpan)
parseInput :: forall (p :: * -> *).
(ProgramLike p, Rename (p SrcSpan)) =>
Input -> IO (ExampleName, p SrcSpan)
parseInput Input
inp = do
    ExampleName
contents <- Input -> IO ExampleName
getInput Input
inp
    -- parse the program
    case String -> ExampleName -> Either ParserErrorBundle (p SrcSpan)
forall (p :: * -> *).
ProgramLike p =>
String -> ExampleName -> Either ParserErrorBundle (p SrcSpan)
parseNamedProgram (Input -> String
forall a. Show a => a -> String
show Input
inp) ExampleName
contents of
        -- when fail, pretty print the parse errors.
        Left (ParseErrorB ParseErrorBundle ExampleName ParserError
err) ->
            String -> IO (ExampleName, p SrcSpan)
forall a. HasCallStack => String -> a
error (String -> IO (ExampleName, p SrcSpan))
-> String -> IO (ExampleName, p SrcSpan)
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle ExampleName ParserError -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle ExampleName ParserError
err
        -- otherwise,
        Right p SrcSpan
p -> do
            -- run @rename@ through the program
            p SrcSpan
renamed <- QuoteT IO (p SrcSpan) -> IO (p SrcSpan)
forall (m :: * -> *) a. Monad m => QuoteT m a -> m a
PLC.runQuoteT (QuoteT IO (p SrcSpan) -> IO (p SrcSpan))
-> QuoteT IO (p SrcSpan) -> IO (p SrcSpan)
forall a b. (a -> b) -> a -> b
$ p SrcSpan -> QuoteT IO (p SrcSpan)
forall a (m :: * -> *). (Rename a, MonadQuote m) => a -> m a
forall (m :: * -> *). MonadQuote m => p SrcSpan -> m (p SrcSpan)
rename p SrcSpan
p
            -- check the program for @UniqueError@'s
            let checked :: Either (UniqueError SrcSpan) (p SrcSpan)
checked = (p SrcSpan -> Either (UniqueError SrcSpan) ())
-> p SrcSpan -> Either (UniqueError SrcSpan) (p SrcSpan)
forall (f :: * -> *) a b. Functor f => (a -> f b) -> a -> f a
through p SrcSpan -> Either (UniqueError SrcSpan) ()
forall ann e (m :: * -> *).
(Ord ann, AsUniqueError e ann, MonadError e m) =>
p ann -> m ()
forall (p :: * -> *) ann e (m :: * -> *).
(ProgramLike p, Ord ann, AsUniqueError e ann, MonadError e m) =>
p ann -> m ()
PlutusCore.Executable.Common.checkUniques p SrcSpan
renamed
            case Either (UniqueError SrcSpan) (p SrcSpan)
checked of
                -- pretty print the error
                Left (UniqueError SrcSpan
err :: PLC.UniqueError PLC.SrcSpan) ->
                    String -> IO (ExampleName, p SrcSpan)
forall a. HasCallStack => String -> a
error (String -> IO (ExampleName, p SrcSpan))
-> String -> IO (ExampleName, p SrcSpan)
forall a b. (a -> b) -> a -> b
$ Doc Any -> String
forall ann. Doc ann -> String
forall str ann. Render str => Doc ann -> str
PP.render (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ UniqueError SrcSpan -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. UniqueError SrcSpan -> Doc ann
pretty UniqueError SrcSpan
err
                Right p SrcSpan
_ -> (ExampleName, p SrcSpan) -> IO (ExampleName, p SrcSpan)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExampleName
contents, p SrcSpan
p)

-- Read UPLC/PLC/PIR code in either textual or Flat format, depending on 'fmt'
readProgram :: forall p.
    ( ProgramLike p
    , Functor p
    , PLC.Rename (p PLC.SrcSpan)
    ) =>
    Format ->
    Input ->
    IO (p PLC.SrcSpan)
readProgram :: forall (p :: * -> *).
(ProgramLike p, Functor p, Rename (p SrcSpan)) =>
Format -> Input -> IO (p SrcSpan)
readProgram Format
fmt Input
inp =
    case Format
fmt of
        Format
Textual -> (ExampleName, p SrcSpan) -> p SrcSpan
forall a b. (a, b) -> b
snd ((ExampleName, p SrcSpan) -> p SrcSpan)
-> IO (ExampleName, p SrcSpan) -> IO (p SrcSpan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Input -> IO (ExampleName, p SrcSpan)
forall (p :: * -> *).
(ProgramLike p, Rename (p SrcSpan)) =>
Input -> IO (ExampleName, p SrcSpan)
parseInput Input
inp
        Flat AstNameType
flatMode -> do
            p ()
prog <- forall (p :: * -> *) ann.
(ProgramLike p, Flat ann) =>
AstNameType -> Input -> IO (p ann)
loadASTfromFlat @p @() AstNameType
flatMode Input
inp
            p SrcSpan -> IO (p SrcSpan)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (p SrcSpan -> IO (p SrcSpan)) -> p SrcSpan -> IO (p SrcSpan)
forall a b. (a -> b) -> a -> b
$ SrcSpan
topSrcSpan SrcSpan -> p () -> p SrcSpan
forall a b. a -> p b -> p a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ p ()
prog

-- | A made-up `SrcSpan` since there's no source locations in Flat.
topSrcSpan :: PLC.SrcSpan
topSrcSpan :: SrcSpan
topSrcSpan = String -> Int -> Int -> Int -> Int -> SrcSpan
PLC.SrcSpan String
"top" Int
1 Int
1 Int
1 Int
2

---------------- Serialise a program using Flat and write it to a given output ----------------

writeFlat ::
    (ProgramLike p, Functor p) => Output -> AstNameType -> p ann -> IO ()
writeFlat :: forall (p :: * -> *) ann.
(ProgramLike p, Functor p) =>
Output -> AstNameType -> p ann -> IO ()
writeFlat Output
outp AstNameType
flatMode p ann
prog = do
    -- ASTs are always serialised with unit annotations to save space: `flat`
    -- does not need any space to serialise ().
    let flatProg :: ByteString
flatProg = AstNameType -> p () -> ByteString
forall ann.
(Flat ann, Pretty ann) =>
AstNameType -> p ann -> ByteString
forall (p :: * -> *) ann.
(ProgramLike p, Flat ann, Pretty ann) =>
AstNameType -> p ann -> ByteString
serialiseProgramFlat AstNameType
flatMode (p ann -> p ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void p ann
prog)
    case Output
outp of
        FileOutput String
file -> String -> ByteString -> IO ()
BSL.writeFile String
file ByteString
flatProg
        Output
StdOutput       -> ByteString -> IO ()
BSL.putStr ByteString
flatProg
        Output
NoOutput        -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

---------------- Write an AST as PLC source ----------------

prettyPrintByMode ::
    PP.PrettyPlc a => PrintMode -> (a -> Doc a)
prettyPrintByMode :: forall a. PrettyPlc a => PrintMode -> a -> Doc a
prettyPrintByMode = \case
  PrintMode
Classic        -> a -> Doc a
forall a ann. PrettyPlc a => a -> Doc ann
PP.prettyPlcClassic
  PrintMode
Simple         -> a -> Doc a
forall a ann. PrettyPlc a => a -> Doc ann
PP.prettyPlcClassicSimple
  PrintMode
Readable       -> a -> Doc a
forall a ann. PrettyPlc a => a -> Doc ann
PP.prettyPlcReadable
  PrintMode
ReadableSimple -> a -> Doc a
forall a ann. PrettyPlc a => a -> Doc ann
PP.prettyPlcReadableSimple

writeProgram ::
    ( ProgramLike p
    , Functor p
    , PP.PrettyBy PP.PrettyConfigPlc (p ann)
    ) =>
    Output ->
    Format ->
    PrintMode ->
    p ann ->
    IO ()
writeProgram :: forall (p :: * -> *) ann.
(ProgramLike p, Functor p, PrettyBy PrettyConfigPlc (p ann)) =>
Output -> Format -> PrintMode -> p ann -> IO ()
writeProgram Output
outp Format
Textual PrintMode
mode p ann
prog      = Output -> PrintMode -> p ann -> IO ()
forall (p :: * -> *) ann.
PrettyBy PrettyConfigPlc (p ann) =>
Output -> PrintMode -> p ann -> IO ()
writePrettyToOutput Output
outp PrintMode
mode p ann
prog
writeProgram Output
outp (Flat AstNameType
flatMode) PrintMode
_ p ann
prog = Output -> AstNameType -> p ann -> IO ()
forall (p :: * -> *) ann.
(ProgramLike p, Functor p) =>
Output -> AstNameType -> p ann -> IO ()
writeFlat Output
outp AstNameType
flatMode p ann
prog

writePrettyToOutput ::
    (PP.PrettyBy PP.PrettyConfigPlc (p ann)) => Output -> PrintMode -> p ann -> IO ()
writePrettyToOutput :: forall (p :: * -> *) ann.
PrettyBy PrettyConfigPlc (p ann) =>
Output -> PrintMode -> p ann -> IO ()
writePrettyToOutput Output
outp PrintMode
mode p ann
prog = do
    let printMethod :: p ann -> Doc (p ann)
printMethod = PrintMode -> p ann -> Doc (p ann)
forall a. PrettyPlc a => PrintMode -> a -> Doc a
prettyPrintByMode PrintMode
mode
    case Output
outp of
        FileOutput String
file -> String -> String -> IO ()
writeFile String
file (String -> IO ()) -> (p ann -> String) -> p ann -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc (p ann) -> String
forall a. Show a => a -> String
Prelude.show (Doc (p ann) -> String)
-> (p ann -> Doc (p ann)) -> p ann -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p ann -> Doc (p ann)
printMethod (p ann -> IO ()) -> p ann -> IO ()
forall a b. (a -> b) -> a -> b
$ p ann
prog
        Output
StdOutput       -> Doc (p ann) -> IO ()
forall a. Show a => a -> IO ()
print (Doc (p ann) -> IO ()) -> (p ann -> Doc (p ann)) -> p ann -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p ann -> Doc (p ann)
printMethod (p ann -> IO ()) -> p ann -> IO ()
forall a b. (a -> b) -> a -> b
$ p ann
prog
        Output
NoOutput        -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

writeToOutput ::
    Show a => Output -> a -> IO ()
writeToOutput :: forall a. Show a => Output -> a -> IO ()
writeToOutput Output
outp a
v = do
    case Output
outp of
        FileOutput String
file -> String -> String -> IO ()
writeFile String
file (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
v
        Output
StdOutput       -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
v
        Output
NoOutput        -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

---------------- Examples ----------------

data TypeExample = TypeExample (PLC.Kind ()) (PLC.Type PLC.TyName PLC.DefaultUni ())
data TypedTermExample
    = TypedTermExample
        (PLC.Type PLC.TyName PLC.DefaultUni ())
        (PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun ())
data SomeTypedExample = SomeTypeExample TypeExample | SomeTypedTermExample TypedTermExample

newtype UntypedTermExample
    = UntypedTermExample
        (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ())
newtype SomeUntypedExample = SomeUntypedTermExample UntypedTermExample

data SomeExample = SomeTypedExample SomeTypedExample | SomeUntypedExample SomeUntypedExample

prettySignature :: ExampleName -> SomeExample -> Doc ann
prettySignature :: forall ann. ExampleName -> SomeExample -> Doc ann
prettySignature ExampleName
name (SomeTypedExample (SomeTypeExample (TypeExample Kind ()
kind Type TyName DefaultUni ()
_))) =
    ExampleName -> Doc ann
forall ann. ExampleName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ExampleName
name Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"::" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Kind () -> Doc ann
forall a ann. PrettyPlc a => a -> Doc ann
PP.prettyPlc Kind ()
kind
prettySignature ExampleName
name (SomeTypedExample (SomeTypedTermExample (TypedTermExample Type TyName DefaultUni ()
ty Term TyName Name DefaultUni DefaultFun ()
_))) =
    ExampleName -> Doc ann
forall ann. ExampleName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ExampleName
name Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Type TyName DefaultUni () -> Doc ann
forall a ann. PrettyPlc a => a -> Doc ann
PP.prettyPlc Type TyName DefaultUni ()
ty
prettySignature ExampleName
name (SomeUntypedExample SomeUntypedExample
_) =
    ExampleName -> Doc ann
forall ann. ExampleName -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ExampleName
name

prettyExample :: SomeExample -> Doc ann
prettyExample :: forall ann. SomeExample -> Doc ann
prettyExample =
    \case
        SomeTypedExample (SomeTypeExample (TypeExample Kind ()
_ Type TyName DefaultUni ()
ty)) -> Type TyName DefaultUni () -> Doc ann
forall a ann. PrettyPlc a => a -> Doc ann
PP.prettyPlc Type TyName DefaultUni ()
ty
        SomeTypedExample (SomeTypedTermExample (TypedTermExample Type TyName DefaultUni ()
_ Term TyName Name DefaultUni DefaultFun ()
term)) ->
            Program TyName Name DefaultUni DefaultFun () -> Doc ann
forall a ann. PrettyPlc a => a -> Doc ann
PP.prettyPlc (Program TyName Name DefaultUni DefaultFun () -> Doc ann)
-> Program TyName Name DefaultUni DefaultFun () -> Doc ann
forall a b. (a -> b) -> a -> b
$ ()
-> Version
-> Term TyName Name DefaultUni DefaultFun ()
-> Program TyName Name DefaultUni DefaultFun ()
forall tyname name (uni :: * -> *) fun ann.
ann
-> Version
-> Term tyname name uni fun ann
-> Program tyname name uni fun ann
PLC.Program () Version
PLC.latestVersion Term TyName Name DefaultUni DefaultFun ()
term
        SomeUntypedExample (SomeUntypedTermExample (UntypedTermExample UplcTerm ()
term)) ->
            Program Name DefaultUni DefaultFun () -> Doc ann
forall a ann. PrettyPlc a => a -> Doc ann
PP.prettyPlc (Program Name DefaultUni DefaultFun () -> Doc ann)
-> Program Name DefaultUni DefaultFun () -> Doc ann
forall a b. (a -> b) -> a -> b
$ ()
-> Version -> UplcTerm () -> Program Name DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> Version -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program () Version
PLC.latestVersion UplcTerm ()
term

toTypedTermExample ::
    PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () -> TypedTermExample
toTypedTermExample :: Term TyName Name DefaultUni DefaultFun () -> TypedTermExample
toTypedTermExample Term TyName Name DefaultUni DefaultFun ()
term = Type TyName DefaultUni ()
-> Term TyName Name DefaultUni DefaultFun () -> TypedTermExample
TypedTermExample Type TyName DefaultUni ()
ty Term TyName Name DefaultUni DefaultFun ()
term
  where
    program :: Program TyName Name DefaultUni DefaultFun ()
program = ()
-> Version
-> Term TyName Name DefaultUni DefaultFun ()
-> Program TyName Name DefaultUni DefaultFun ()
forall tyname name (uni :: * -> *) fun ann.
ann
-> Version
-> Term tyname name uni fun ann
-> Program tyname name uni fun ann
PLC.Program () Version
PLC.latestVersion Term TyName Name DefaultUni DefaultFun ()
term
    errOrTy :: Either
  (Error DefaultUni DefaultFun ())
  (Normalized (Type TyName DefaultUni ()))
errOrTy = Quote
  (Either
     (Error DefaultUni DefaultFun ())
     (Normalized (Type TyName DefaultUni ())))
-> Either
     (Error DefaultUni DefaultFun ())
     (Normalized (Type TyName DefaultUni ()))
forall a. Quote a -> a
PLC.runQuote (Quote
   (Either
      (Error DefaultUni DefaultFun ())
      (Normalized (Type TyName DefaultUni ())))
 -> Either
      (Error DefaultUni DefaultFun ())
      (Normalized (Type TyName DefaultUni ())))
-> (ExceptT
      (Error DefaultUni DefaultFun ())
      (QuoteT Identity)
      (Normalized (Type TyName DefaultUni ()))
    -> Quote
         (Either
            (Error DefaultUni DefaultFun ())
            (Normalized (Type TyName DefaultUni ()))))
-> ExceptT
     (Error DefaultUni DefaultFun ())
     (QuoteT Identity)
     (Normalized (Type TyName DefaultUni ()))
-> Either
     (Error DefaultUni DefaultFun ())
     (Normalized (Type TyName DefaultUni ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT
  (Error DefaultUni DefaultFun ())
  (QuoteT Identity)
  (Normalized (Type TyName DefaultUni ()))
-> Quote
     (Either
        (Error DefaultUni DefaultFun ())
        (Normalized (Type TyName DefaultUni ())))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   (Error DefaultUni DefaultFun ())
   (QuoteT Identity)
   (Normalized (Type TyName DefaultUni ()))
 -> Either
      (Error DefaultUni DefaultFun ())
      (Normalized (Type TyName DefaultUni ())))
-> ExceptT
     (Error DefaultUni DefaultFun ())
     (QuoteT Identity)
     (Normalized (Type TyName DefaultUni ()))
-> Either
     (Error DefaultUni DefaultFun ())
     (Normalized (Type TyName DefaultUni ()))
forall a b. (a -> b) -> a -> b
$ do
        TypeCheckConfig DefaultUni DefaultFun
tcConfig <- ()
-> ExceptT
     (Error DefaultUni DefaultFun ())
     (QuoteT Identity)
     (TypeCheckConfig DefaultUni DefaultFun)
forall err term (uni :: * -> *) fun ann (m :: * -> *).
(MonadKindCheck err term uni fun ann m, Typecheckable uni fun) =>
ann -> m (TypeCheckConfig uni fun)
PLC.getDefTypeCheckConfig ()
        TypeCheckConfig DefaultUni DefaultFun
-> Program TyName Name DefaultUni DefaultFun ()
-> ExceptT
     (Error DefaultUni DefaultFun ())
     (QuoteT Identity)
     (Normalized (Type TyName DefaultUni ()))
forall err (uni :: * -> *) fun ann (m :: * -> *).
MonadTypeCheckPlc err uni fun ann m =>
TypeCheckConfig uni fun
-> Program TyName Name uni fun ann
-> m (Normalized (Type TyName uni ()))
PLC.inferTypeOfProgram TypeCheckConfig DefaultUni DefaultFun
tcConfig Program TyName Name DefaultUni DefaultFun ()
program
    ty :: Type TyName DefaultUni ()
ty = case Either
  (Error DefaultUni DefaultFun ())
  (Normalized (Type TyName DefaultUni ()))
errOrTy of
        Left (Error DefaultUni DefaultFun ()
err :: PLC.Error PLC.DefaultUni PLC.DefaultFun ()) ->
            String -> Type TyName DefaultUni ()
forall a. HasCallStack => String -> a
error (String -> Type TyName DefaultUni ())
-> String -> Type TyName DefaultUni ()
forall a b. (a -> b) -> a -> b
$ Error DefaultUni DefaultFun () -> String
forall a str. (PrettyPlc a, Render str) => a -> str
PP.displayPlc Error DefaultUni DefaultFun ()
err
        Right Normalized (Type TyName DefaultUni ())
vTy -> Normalized (Type TyName DefaultUni ()) -> Type TyName DefaultUni ()
forall a. Normalized a -> a
PLC.unNormalized Normalized (Type TyName DefaultUni ())
vTy

getInteresting :: IO [(ExampleName, PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun ())]
getInteresting :: IO [(ExampleName, Term TyName Name DefaultUni DefaultFun ())]
getInteresting =
    [IO (ExampleName, Term TyName Name DefaultUni DefaultFun ())]
-> IO [(ExampleName, Term TyName Name DefaultUni DefaultFun ())]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([IO (ExampleName, Term TyName Name DefaultUni DefaultFun ())]
 -> IO [(ExampleName, Term TyName Name DefaultUni DefaultFun ())])
-> [IO (ExampleName, Term TyName Name DefaultUni DefaultFun ())]
-> IO [(ExampleName, Term TyName Name DefaultUni DefaultFun ())]
forall a b. (a -> b) -> a -> b
$ (forall a.
 KnownType (Term TyName Name DefaultUni DefaultFun ()) a =>
 String
 -> TermGen a
 -> IO (ExampleName, Term TyName Name DefaultUni DefaultFun ()))
-> [IO (ExampleName, Term TyName Name DefaultUni DefaultFun ())]
forall c.
(forall a.
 KnownType (Term TyName Name DefaultUni DefaultFun ()) a =>
 String -> TermGen a -> c)
-> [c]
Gen.fromInterestingTermGens ((forall a.
  KnownType (Term TyName Name DefaultUni DefaultFun ()) a =>
  String
  -> TermGen a
  -> IO (ExampleName, Term TyName Name DefaultUni DefaultFun ()))
 -> [IO (ExampleName, Term TyName Name DefaultUni DefaultFun ())])
-> (forall a.
    KnownType (Term TyName Name DefaultUni DefaultFun ()) a =>
    String
    -> TermGen a
    -> IO (ExampleName, Term TyName Name DefaultUni DefaultFun ()))
-> [IO (ExampleName, Term TyName Name DefaultUni DefaultFun ())]
forall a b. (a -> b) -> a -> b
$ \String
name TermGen a
gen -> do
        Gen.TermOf Term TyName Name DefaultUni DefaultFun ()
term EvaluationResult (Term TyName Name DefaultUni DefaultFun ())
_ <- TermGen a
-> IO
     (TermOf
        (Term TyName Name DefaultUni DefaultFun ())
        (EvaluationResult (Term TyName Name DefaultUni DefaultFun ())))
forall (uni :: * -> *) fun a.
(uni ~ DefaultUni, fun ~ DefaultFun, KnownTypeAst TyName uni a,
 MakeKnown (Term TyName Name uni fun ()) a) =>
TermGen a
-> IO
     (TermOf
        (Term TyName Name uni fun ())
        (EvaluationResult (Term TyName Name uni fun ())))
Gen.getSampleTermValue TermGen a
gen
        (ExampleName, Term TyName Name DefaultUni DefaultFun ())
-> IO (ExampleName, Term TyName Name DefaultUni DefaultFun ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ExampleName
T.pack String
name, Term TyName Name DefaultUni DefaultFun ()
term)

simpleExamples :: [(ExampleName, SomeTypedExample)]
simpleExamples :: [(ExampleName, SomeTypedExample)]
simpleExamples =
    [ (ExampleName
"succInteger", TypedTermExample -> SomeTypedExample
SomeTypedTermExample (TypedTermExample -> SomeTypedExample)
-> TypedTermExample -> SomeTypedExample
forall a b. (a -> b) -> a -> b
$ Term TyName Name DefaultUni DefaultFun () -> TypedTermExample
toTypedTermExample Term TyName Name DefaultUni DefaultFun ()
forall (term :: * -> *) tyname (uni :: * -> *).
(TermLike term tyname Name uni DefaultFun,
 HasTypeAndTermLevel uni Integer) =>
term ()
StdLib.succInteger)
    , (ExampleName
"unit", TypeExample -> SomeTypedExample
SomeTypeExample (TypeExample -> SomeTypedExample)
-> TypeExample -> SomeTypedExample
forall a b. (a -> b) -> a -> b
$ Kind () -> Type TyName DefaultUni () -> TypeExample
TypeExample (() -> Kind ()
forall ann. ann -> Kind ann
PLC.Type ()) Type TyName DefaultUni ()
forall (uni :: * -> *) tyname.
HasTypeLevel uni () =>
Type tyname uni ()
StdLib.unit)
    , (ExampleName
"unitval", TypedTermExample -> SomeTypedExample
SomeTypedTermExample (TypedTermExample -> SomeTypedExample)
-> TypedTermExample -> SomeTypedExample
forall a b. (a -> b) -> a -> b
$ Term TyName Name DefaultUni DefaultFun () -> TypedTermExample
toTypedTermExample Term TyName Name DefaultUni DefaultFun ()
forall (term :: * -> *) tyname name (uni :: * -> *) fun.
(TermLike term tyname name uni fun, HasTermLevel uni ()) =>
term ()
StdLib.unitval)
    , (ExampleName
"bool", TypeExample -> SomeTypedExample
SomeTypeExample (TypeExample -> SomeTypedExample)
-> TypeExample -> SomeTypedExample
forall a b. (a -> b) -> a -> b
$ Kind () -> Type TyName DefaultUni () -> TypeExample
TypeExample (() -> Kind ()
forall ann. ann -> Kind ann
PLC.Type ()) Type TyName DefaultUni ()
forall (uni :: * -> *) tyname.
HasTypeLevel uni Bool =>
Type tyname uni ()
StdLib.bool)
    , (ExampleName
"true", TypedTermExample -> SomeTypedExample
SomeTypedTermExample (TypedTermExample -> SomeTypedExample)
-> TypedTermExample -> SomeTypedExample
forall a b. (a -> b) -> a -> b
$ Term TyName Name DefaultUni DefaultFun () -> TypedTermExample
toTypedTermExample Term TyName Name DefaultUni DefaultFun ()
forall (term :: * -> *) tyname name (uni :: * -> *) fun.
(TermLike term tyname name uni fun, HasTermLevel uni Bool) =>
term ()
StdLib.true)
    , (ExampleName
"false", TypedTermExample -> SomeTypedExample
SomeTypedTermExample (TypedTermExample -> SomeTypedExample)
-> TypedTermExample -> SomeTypedExample
forall a b. (a -> b) -> a -> b
$ Term TyName Name DefaultUni DefaultFun () -> TypedTermExample
toTypedTermExample Term TyName Name DefaultUni DefaultFun ()
forall (term :: * -> *) tyname name (uni :: * -> *) fun.
(TermLike term tyname name uni fun, HasTermLevel uni Bool) =>
term ()
StdLib.false)
    , (ExampleName
"churchNat", TypeExample -> SomeTypedExample
SomeTypeExample (TypeExample -> SomeTypedExample)
-> TypeExample -> SomeTypedExample
forall a b. (a -> b) -> a -> b
$ Kind () -> Type TyName DefaultUni () -> TypeExample
TypeExample (() -> Kind ()
forall ann. ann -> Kind ann
PLC.Type ()) Type TyName DefaultUni ()
forall (uni :: * -> *). Type TyName uni ()
StdLib.churchNat)
    , (ExampleName
"churchZero", TypedTermExample -> SomeTypedExample
SomeTypedTermExample (TypedTermExample -> SomeTypedExample)
-> TypedTermExample -> SomeTypedExample
forall a b. (a -> b) -> a -> b
$ Term TyName Name DefaultUni DefaultFun () -> TypedTermExample
toTypedTermExample Term TyName Name DefaultUni DefaultFun ()
forall (term :: * -> *) (uni :: * -> *) fun.
TermLike term TyName Name uni fun =>
term ()
StdLib.churchZero)
    , (ExampleName
"churchSucc", TypedTermExample -> SomeTypedExample
SomeTypedTermExample (TypedTermExample -> SomeTypedExample)
-> TypedTermExample -> SomeTypedExample
forall a b. (a -> b) -> a -> b
$ Term TyName Name DefaultUni DefaultFun () -> TypedTermExample
toTypedTermExample Term TyName Name DefaultUni DefaultFun ()
forall (term :: * -> *) (uni :: * -> *) fun.
TermLike term TyName Name uni fun =>
term ()
StdLib.churchSucc)
    ]

getInterestingExamples ::
    ([(ExampleName, SomeTypedExample)] -> [(ExampleName, SomeExample)]) ->
    IO [(ExampleName, SomeExample)]
getInterestingExamples :: ([(ExampleName, SomeTypedExample)] -> [(ExampleName, SomeExample)])
-> IO [(ExampleName, SomeExample)]
getInterestingExamples [(ExampleName, SomeTypedExample)] -> [(ExampleName, SomeExample)]
res = do
    [(ExampleName, Term TyName Name DefaultUni DefaultFun ())]
interesting <- IO [(ExampleName, Term TyName Name DefaultUni DefaultFun ())]
getInteresting
    let examples :: [(ExampleName, SomeTypedExample)]
examples =
            [(ExampleName, SomeTypedExample)]
simpleExamples
                [(ExampleName, SomeTypedExample)]
-> [(ExampleName, SomeTypedExample)]
-> [(ExampleName, SomeTypedExample)]
forall a. [a] -> [a] -> [a]
++ ((ExampleName, Term TyName Name DefaultUni DefaultFun ())
 -> (ExampleName, SomeTypedExample))
-> [(ExampleName, Term TyName Name DefaultUni DefaultFun ())]
-> [(ExampleName, SomeTypedExample)]
forall a b. (a -> b) -> [a] -> [b]
map ((Term TyName Name DefaultUni DefaultFun () -> SomeTypedExample)
-> (ExampleName, Term TyName Name DefaultUni DefaultFun ())
-> (ExampleName, SomeTypedExample)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Term TyName Name DefaultUni DefaultFun () -> SomeTypedExample)
 -> (ExampleName, Term TyName Name DefaultUni DefaultFun ())
 -> (ExampleName, SomeTypedExample))
-> (Term TyName Name DefaultUni DefaultFun () -> SomeTypedExample)
-> (ExampleName, Term TyName Name DefaultUni DefaultFun ())
-> (ExampleName, SomeTypedExample)
forall a b. (a -> b) -> a -> b
$ TypedTermExample -> SomeTypedExample
SomeTypedTermExample (TypedTermExample -> SomeTypedExample)
-> (Term TyName Name DefaultUni DefaultFun () -> TypedTermExample)
-> Term TyName Name DefaultUni DefaultFun ()
-> SomeTypedExample
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term TyName Name DefaultUni DefaultFun () -> TypedTermExample
toTypedTermExample) [(ExampleName, Term TyName Name DefaultUni DefaultFun ())]
interesting
    [(ExampleName, SomeExample)] -> IO [(ExampleName, SomeExample)]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(ExampleName, SomeExample)] -> IO [(ExampleName, SomeExample)])
-> [(ExampleName, SomeExample)] -> IO [(ExampleName, SomeExample)]
forall a b. (a -> b) -> a -> b
$ [(ExampleName, SomeTypedExample)] -> [(ExampleName, SomeExample)]
res [(ExampleName, SomeTypedExample)]
examples

-- | Get available typed examples.
getPlcExamples :: IO [(ExampleName, SomeExample)]
getPlcExamples :: IO [(ExampleName, SomeExample)]
getPlcExamples = ([(ExampleName, SomeTypedExample)] -> [(ExampleName, SomeExample)])
-> IO [(ExampleName, SomeExample)]
getInterestingExamples (([(ExampleName, SomeTypedExample)]
  -> [(ExampleName, SomeExample)])
 -> IO [(ExampleName, SomeExample)])
-> ([(ExampleName, SomeTypedExample)]
    -> [(ExampleName, SomeExample)])
-> IO [(ExampleName, SomeExample)]
forall a b. (a -> b) -> a -> b
$ ((ExampleName, SomeTypedExample) -> (ExampleName, SomeExample))
-> [(ExampleName, SomeTypedExample)]
-> [(ExampleName, SomeExample)]
forall a b. (a -> b) -> [a] -> [b]
map ((SomeTypedExample -> SomeExample)
-> (ExampleName, SomeTypedExample) -> (ExampleName, SomeExample)
forall a b. (a -> b) -> (ExampleName, a) -> (ExampleName, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SomeTypedExample -> SomeExample
SomeTypedExample)

{- | Get available untyped examples. Currently the untyped
 examples are obtained by erasing typed ones, but it might be useful to have
 some untyped ones that can't be obtained by erasure.
-}
getUplcExamples :: IO [(ExampleName, SomeExample)]
getUplcExamples :: IO [(ExampleName, SomeExample)]
getUplcExamples =
    ([(ExampleName, SomeTypedExample)] -> [(ExampleName, SomeExample)])
-> IO [(ExampleName, SomeExample)]
getInterestingExamples (([(ExampleName, SomeTypedExample)]
  -> [(ExampleName, SomeExample)])
 -> IO [(ExampleName, SomeExample)])
-> ([(ExampleName, SomeTypedExample)]
    -> [(ExampleName, SomeExample)])
-> IO [(ExampleName, SomeExample)]
forall a b. (a -> b) -> a -> b
$
        (SomeTypedExample -> Maybe SomeExample)
-> [(ExampleName, SomeTypedExample)]
-> [(ExampleName, SomeExample)]
forall {t} {b} {a}. (t -> Maybe b) -> [(a, t)] -> [(a, b)]
mapMaybeSnd SomeTypedExample -> Maybe SomeExample
convert
  where
    convert :: SomeTypedExample -> Maybe SomeExample
convert =
        \case
            SomeTypeExample TypeExample
_ -> Maybe SomeExample
forall a. Maybe a
Nothing
            SomeTypedTermExample (TypedTermExample Type TyName DefaultUni ()
_ Term TyName Name DefaultUni DefaultFun ()
e) ->
                SomeExample -> Maybe SomeExample
forall a. a -> Maybe a
Just (SomeExample -> Maybe SomeExample)
-> (UplcTerm () -> SomeExample) -> UplcTerm () -> Maybe SomeExample
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeUntypedExample -> SomeExample
SomeUntypedExample (SomeUntypedExample -> SomeExample)
-> (UplcTerm () -> SomeUntypedExample)
-> UplcTerm ()
-> SomeExample
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UntypedTermExample -> SomeUntypedExample
SomeUntypedTermExample (UntypedTermExample -> SomeUntypedExample)
-> (UplcTerm () -> UntypedTermExample)
-> UplcTerm ()
-> SomeUntypedExample
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UplcTerm () -> UntypedTermExample
UntypedTermExample (UplcTerm () -> Maybe SomeExample)
-> UplcTerm () -> Maybe SomeExample
forall a b. (a -> b) -> a -> b
$
                    Term TyName Name DefaultUni DefaultFun () -> UplcTerm ()
forall name tyname (uni :: * -> *) fun ann.
HasUnique name TermUnique =>
Term tyname name uni fun ann -> Term name uni fun ann
PLC.eraseTerm Term TyName Name DefaultUni DefaultFun ()
e
    mapMaybeSnd :: (t -> Maybe b) -> [(a, t)] -> [(a, b)]
mapMaybeSnd t -> Maybe b
_ [] = []
    mapMaybeSnd t -> Maybe b
f ((a
a, t
b) : [(a, t)]
r) =
        case t -> Maybe b
f t
b of
            Maybe b
Nothing -> (t -> Maybe b) -> [(a, t)] -> [(a, b)]
mapMaybeSnd t -> Maybe b
f [(a, t)]
r
            Just b
b' -> (a
a, b
b') (a, b) -> [(a, b)] -> [(a, b)]
forall a. a -> [a] -> [a]
: (t -> Maybe b) -> [(a, t)] -> [(a, b)]
mapMaybeSnd t -> Maybe b
f [(a, t)]
r

-- The implementation is a little hacky: we generate interesting examples when the list of examples
-- is requested and at each lookup of a particular example. I.e. each time we generate distinct
-- terms. But types of those terms must not change across requests, so we're safe.


----------------- Print examples -----------------------

runPrintExample ::
    IO [(ExampleName, SomeExample)] ->
    ExampleOptions ->
    IO ()
runPrintExample :: IO [(ExampleName, SomeExample)] -> ExampleOptions -> IO ()
runPrintExample IO [(ExampleName, SomeExample)]
getFn (ExampleOptions ExampleMode
ExampleAvailable) = do
    [(ExampleName, SomeExample)]
examples <- IO [(ExampleName, SomeExample)]
getFn
    ((ExampleName, SomeExample) -> IO ())
-> [(ExampleName, SomeExample)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ExampleName -> IO ()
T.putStrLn (ExampleName -> IO ())
-> ((ExampleName, SomeExample) -> ExampleName)
-> (ExampleName, SomeExample)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> ExampleName
forall ann. Doc ann -> ExampleName
forall str ann. Render str => Doc ann -> str
PP.render (Doc Any -> ExampleName)
-> ((ExampleName, SomeExample) -> Doc Any)
-> (ExampleName, SomeExample)
-> ExampleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExampleName -> SomeExample -> Doc Any)
-> (ExampleName, SomeExample) -> Doc Any
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ExampleName -> SomeExample -> Doc Any
forall ann. ExampleName -> SomeExample -> Doc ann
prettySignature) [(ExampleName, SomeExample)]
examples
runPrintExample IO [(ExampleName, SomeExample)]
getFn (ExampleOptions (ExampleSingle ExampleName
name)) = do
    [(ExampleName, SomeExample)]
examples <- IO [(ExampleName, SomeExample)]
getFn
    ExampleName -> IO ()
T.putStrLn (ExampleName -> IO ()) -> ExampleName -> IO ()
forall a b. (a -> b) -> a -> b
$ case ExampleName -> [(ExampleName, SomeExample)] -> Maybe SomeExample
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ExampleName
name [(ExampleName, SomeExample)]
examples of
        Maybe SomeExample
Nothing -> ExampleName
"Unknown name: " ExampleName -> ExampleName -> ExampleName
forall a. Semigroup a => a -> a -> a
<> ExampleName
name
        Just SomeExample
ex -> Doc Any -> ExampleName
forall ann. Doc ann -> ExampleName
forall str ann. Render str => Doc ann -> str
PP.render (Doc Any -> ExampleName) -> Doc Any -> ExampleName
forall a b. (a -> b) -> a -> b
$ SomeExample -> Doc Any
forall ann. SomeExample -> Doc ann
prettyExample SomeExample
ex

---------------- Print the cost model parameters ----------------

runDumpModel :: PLC.BuiltinSemanticsVariant PLC.DefaultFun -> IO ()
runDumpModel :: BuiltinSemanticsVariant DefaultFun -> IO ()
runDumpModel BuiltinSemanticsVariant DefaultFun
semvar = do
    let params :: CostModelParams
params = Maybe CostModelParams -> CostModelParams
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CostModelParams -> CostModelParams)
-> Maybe CostModelParams -> CostModelParams
forall a b. (a -> b) -> a -> b
$ BuiltinSemanticsVariant DefaultFun -> Maybe CostModelParams
PLC.defaultCostModelParamsForVariant BuiltinSemanticsVariant DefaultFun
semvar
    ByteString -> IO ()
BSL.putStr (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ CostModelParams -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode CostModelParams
params

---------------- Print the type signatures of the default builtins ----------------

-- Some types to represent signatures of built-in functions
type PlcType = PLC.Type PLC.TyName PLC.DefaultUni ()
data QVarOrType = QVar String | Type PlcType -- Quantified type variable or actual type

data Signature = Signature [QVarOrType] PlcType -- Argument types, return type
instance Show Signature where
    show :: Signature -> String
show (Signature [QVarOrType]
args Type TyName DefaultUni ()
res) =
        String
"[ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (QVarOrType -> String) -> [QVarOrType] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map QVarOrType -> String
showQT [QVarOrType]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ] -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type TyName DefaultUni () -> String
showTy (Type TyName DefaultUni () -> Type TyName DefaultUni ()
normTy Type TyName DefaultUni ()
res)
      where
        showQT :: QVarOrType -> String
showQT =
            \case
                QVar String
tv -> String
"forall " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tv
                Type Type TyName DefaultUni ()
ty -> Type TyName DefaultUni () -> String
showTy (Type TyName DefaultUni () -> Type TyName DefaultUni ()
normTy Type TyName DefaultUni ()
ty)
        normTy :: PlcType -> PlcType
        normTy :: Type TyName DefaultUni () -> Type TyName DefaultUni ()
normTy Type TyName DefaultUni ()
ty = Quote (Type TyName DefaultUni ()) -> Type TyName DefaultUni ()
forall a. Quote a -> a
PLC.runQuote (Quote (Type TyName DefaultUni ()) -> Type TyName DefaultUni ())
-> Quote (Type TyName DefaultUni ()) -> Type TyName DefaultUni ()
forall a b. (a -> b) -> a -> b
$ Normalized (Type TyName DefaultUni ()) -> Type TyName DefaultUni ()
forall a. Normalized a -> a
PLC.unNormalized (Normalized (Type TyName DefaultUni ())
 -> Type TyName DefaultUni ())
-> QuoteT Identity (Normalized (Type TyName DefaultUni ()))
-> Quote (Type TyName DefaultUni ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type TyName DefaultUni ()
-> QuoteT Identity (Normalized (Type TyName DefaultUni ()))
forall tyname (uni :: * -> *) (m :: * -> *) ann.
(HasUnique tyname TypeUnique, MonadNormalizeType uni m) =>
Type tyname uni ann -> m (Normalized (Type tyname uni ann))
normalizeType Type TyName DefaultUni ()
ty
        showTy :: Type TyName DefaultUni () -> String
showTy Type TyName DefaultUni ()
ty =
            case Type TyName DefaultUni ()
ty of
                PLC.TyBuiltin ()
_ SomeTypeIn DefaultUni
t -> Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ SomeTypeIn DefaultUni -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. SomeTypeIn DefaultUni -> Doc ann
PP.pretty SomeTypeIn DefaultUni
t
                PLC.TyApp{}       -> [Type TyName DefaultUni ()] -> String
showMultiTyApp ([Type TyName DefaultUni ()] -> String)
-> [Type TyName DefaultUni ()] -> String
forall a b. (a -> b) -> a -> b
$ Type TyName DefaultUni () -> [Type TyName DefaultUni ()]
forall {tyname} {uni :: * -> *} {ann}.
Type tyname uni ann -> [Type tyname uni ann]
unwrapTyApp Type TyName DefaultUni ()
ty
                -- prettyPlcClassicSimple -> omit indices in type variables.
                Type TyName DefaultUni ()
_                 -> Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ Type TyName DefaultUni () -> Doc Any
forall a ann. PrettyPlc a => a -> Doc ann
PP.prettyPlcClassicSimple Type TyName DefaultUni ()
ty
                -- We may want more cases here if more complex types (eg function types)
                -- are allowed for builtin arguments.
        unwrapTyApp :: Type tyname uni ann -> [Type tyname uni ann]
unwrapTyApp Type tyname uni ann
ty =
            case Type tyname uni ann
ty of
                PLC.TyApp ann
_ Type tyname uni ann
t1 Type tyname uni ann
t2 -> Type tyname uni ann -> [Type tyname uni ann]
unwrapTyApp Type tyname uni ann
t1 [Type tyname uni ann]
-> [Type tyname uni ann] -> [Type tyname uni ann]
forall a. [a] -> [a] -> [a]
++ [Type tyname uni ann
t2]
                -- Assumes iterated built-in type applications all associate to the left;
                -- if not, we'll just get some odd formatting.
                Type tyname uni ann
_                 -> [Type tyname uni ann
ty]
        showMultiTyApp :: [Type TyName DefaultUni ()] -> String
showMultiTyApp =
            \case
                []       -> String
"<empty type application>" -- Should never happen
                Type TyName DefaultUni ()
op : [Type TyName DefaultUni ()]
tys -> Type TyName DefaultUni () -> String
showTy Type TyName DefaultUni ()
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Type TyName DefaultUni () -> String)
-> [Type TyName DefaultUni ()] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Type TyName DefaultUni () -> String
showTy [Type TyName DefaultUni ()]
tys) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

typeSchemeToSignature :: PLC.TypeScheme (PlcTerm ()) args res -> Signature
typeSchemeToSignature :: forall (args :: [*]) res.
TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
-> Signature
typeSchemeToSignature = [QVarOrType]
-> TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
-> Signature
forall (args :: [*]) res.
[QVarOrType]
-> TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
-> Signature
toSig []
  where
    toSig :: [QVarOrType] -> PLC.TypeScheme (PlcTerm ()) args res -> Signature
    toSig :: forall (args :: [*]) res.
[QVarOrType]
-> TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
-> Signature
toSig [QVarOrType]
acc =
        \case
            pR :: TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
pR@TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
PLC.TypeSchemeResult -> [QVarOrType] -> Type TyName DefaultUni () -> Signature
Signature [QVarOrType]
acc (TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
-> Type TyName DefaultUni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
PLC.toTypeAst TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
pR)
            arr :: TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
arr@(PLC.TypeSchemeArrow TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args1 res
schB) ->
                [QVarOrType]
-> TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args1 res
-> Signature
forall (args :: [*]) res.
[QVarOrType]
-> TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
-> Signature
toSig ([QVarOrType]
acc [QVarOrType] -> [QVarOrType] -> [QVarOrType]
forall a. [a] -> [a] -> [a]
++ [Type TyName DefaultUni () -> QVarOrType
Type (Type TyName DefaultUni () -> QVarOrType)
-> Type TyName DefaultUni () -> QVarOrType
forall a b. (a -> b) -> a -> b
$ Proxy arg -> Type TyName DefaultUni ()
forall a tyname (uni :: * -> *) (x :: a) (proxy :: a -> *).
KnownTypeAst tyname uni x =>
proxy x -> Type tyname uni ()
PLC.toTypeAst (Proxy arg -> Type TyName DefaultUni ())
-> Proxy arg -> Type TyName DefaultUni ()
forall a b. (a -> b) -> a -> b
$ TypeScheme
  (Term TyName Name DefaultUni DefaultFun ()) (arg : args1) res
-> Proxy arg
forall val arg (args :: [*]) res.
TypeScheme val (arg : args) res -> Proxy arg
PLC.argProxy TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
TypeScheme
  (Term TyName Name DefaultUni DefaultFun ()) (arg : args1) res
arr]) TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args1 res
schB
            PLC.TypeSchemeAll Proxy '(text, uniq, kind)
proxy TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
schK ->
                case Proxy '(text, uniq, kind)
proxy of
                    (Proxy '(text, uniq, kind)
_ :: Proxy '(text, uniq, kind)) ->
                        [QVarOrType]
-> TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
-> Signature
forall (args :: [*]) res.
[QVarOrType]
-> TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
-> Signature
toSig ([QVarOrType]
acc [QVarOrType] -> [QVarOrType] -> [QVarOrType]
forall a. [a] -> [a] -> [a]
++ [String -> QVarOrType
QVar (String -> QVarOrType) -> String -> QVarOrType
forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @text Proxy text
forall {k} (t :: k). Proxy t
Proxy]) TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
schK

runPrintBuiltinSignatures :: IO ()
runPrintBuiltinSignatures :: IO ()
runPrintBuiltinSignatures = do
    let builtins :: [DefaultFun]
builtins = forall a. (Enum a, Bounded a) => [a]
enumerate @PLC.DefaultFun
    (DefaultFun -> IO ()) -> [DefaultFun] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      (\DefaultFun
x -> String -> IO ()
putStr (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%-35s: %s\n" (Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String) -> Doc Any -> String
forall a b. (a -> b) -> a -> b
$ DefaultFun -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. DefaultFun -> Doc ann
PP.pretty DefaultFun
x) (Signature -> String
forall a. Show a => a -> String
show (Signature -> String) -> Signature -> String
forall a b. (a -> b) -> a -> b
$ DefaultFun -> Signature
getSignature DefaultFun
x)))
      [DefaultFun]
builtins
  where
    getSignature :: DefaultFun -> Signature
getSignature DefaultFun
b =
      case forall (uni :: * -> *) fun val.
(ToBuiltinMeaning uni fun, HasMeaningIn uni val) =>
BuiltinSemanticsVariant fun
-> fun -> BuiltinMeaning val (CostingPart uni fun)
PLC.toBuiltinMeaning @PLC.DefaultUni @PLC.DefaultFun @(PlcTerm ()) BuiltinSemanticsVariant DefaultFun
forall a. Default a => a
def DefaultFun
b of
        PLC.BuiltinMeaning TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
sch FoldArgs args res
_ CostingPart DefaultUni DefaultFun
-> BuiltinRuntime (Term TyName Name DefaultUni DefaultFun ())
_ -> TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
-> Signature
forall (args :: [*]) res.
TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
-> Signature
typeSchemeToSignature TypeScheme (Term TyName Name DefaultUni DefaultFun ()) args res
sch

---------------- Parse and print a PLC/UPLC source file ----------------

runPrint
    :: forall p .
       ( ProgramLike p
       , PLC.Rename (p PLC.SrcSpan)
       , PrettyBy PP.PrettyConfigPlc (p PLC.SrcSpan)
       )
    => PrintOptions
    -> IO ()
runPrint :: forall (p :: * -> *).
(ProgramLike p, Rename (p SrcSpan),
 PrettyBy PrettyConfigPlc (p SrcSpan)) =>
PrintOptions -> IO ()
runPrint (PrintOptions Input
inp Output
outp PrintMode
mode) = do
    p SrcSpan
parsed <- ((ExampleName, p SrcSpan) -> p SrcSpan
forall a b. (a, b) -> b
snd ((ExampleName, p SrcSpan) -> p SrcSpan)
-> IO (ExampleName, p SrcSpan) -> IO (p SrcSpan)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Input -> IO (ExampleName, p SrcSpan)
forall (p :: * -> *).
(ProgramLike p, Rename (p SrcSpan)) =>
Input -> IO (ExampleName, p SrcSpan)
parseInput Input
inp :: IO (p PLC.SrcSpan))
    let printed :: String
printed = Doc (p SrcSpan) -> String
forall a. Show a => a -> String
show (Doc (p SrcSpan) -> String) -> Doc (p SrcSpan) -> String
forall a b. (a -> b) -> a -> b
$ PrintMode -> p SrcSpan -> Doc (p SrcSpan)
forall a. PrettyPlc a => PrintMode -> a -> Doc a
prettyPrintByMode PrintMode
mode p SrcSpan
parsed
    case Output
outp of
        FileOutput String
path -> String -> String -> IO ()
writeFile String
path String
printed
        Output
StdOutput       -> String -> IO ()
putStrLn String
printed
        Output
NoOutput        -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

---------------- Conversions ----------------

-- | Convert between textual and FLAT representations.
runConvert
    :: forall (p :: Type -> Type).
       ( ProgramLike p
       , Functor p
       , PLC.Rename (p PLC.SrcSpan)
       , PP.PrettyBy PP.PrettyConfigPlc (p PLC.SrcSpan))
    => ConvertOptions
    -> IO ()
runConvert :: forall (p :: * -> *).
(ProgramLike p, Functor p, Rename (p SrcSpan),
 PrettyBy PrettyConfigPlc (p SrcSpan)) =>
ConvertOptions -> IO ()
runConvert (ConvertOptions Input
inp Format
ifmt Output
outp Format
ofmt PrintMode
mode) = do
    p SrcSpan
program :: p PLC.SrcSpan <- Format -> Input -> IO (p SrcSpan)
forall (p :: * -> *).
(ProgramLike p, Functor p, Rename (p SrcSpan)) =>
Format -> Input -> IO (p SrcSpan)
readProgram Format
ifmt Input
inp
    Output -> Format -> PrintMode -> p SrcSpan -> IO ()
forall (p :: * -> *) ann.
(ProgramLike p, Functor p, PrettyBy PrettyConfigPlc (p ann)) =>
Output -> Format -> PrintMode -> p ann -> IO ()
writeProgram Output
outp Format
ofmt PrintMode
mode p SrcSpan
program