{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}

module Cardano.Ledger.Plutus.Preprocessor (display) where

import Cardano.Ledger.Plutus.Language (
  Language (..),
  Plutus (..),
  PlutusBinary (..),
  asSLanguage,
  hashPlutusScript,
  withSLanguage,
 )
import qualified Cardano.Ledger.Plutus.Preprocessor.Binary.V1 as V1
import qualified Cardano.Ledger.Plutus.Preprocessor.Binary.V2 as V2
import qualified Cardano.Ledger.Plutus.Preprocessor.Binary.V3 as V3
import Data.ByteString.Short as SBS (fromShort)
import Data.Foldable (forM_)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import Language.Haskell.TH
import System.IO (Handle, hPutStr)
import Test.Cardano.Ledger.Binary.TreeDiff (showHexBytesGrouped)

-- =============================================
-- how to display a preprocessed script

display :: Handle -> IO ()
display :: Handle -> IO ()
display Handle
h = do
  let indent :: [Char] -> [Char]
indent = ([Char]
"  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
  Handle -> [Char] -> IO ()
hPutStr Handle
h ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
    [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
      [ [Char]
"{-# LANGUAGE DataKinds #-}"
      , [Char]
"{-# LANGUAGE GADTs #-}"
      , [Char]
"{-# LANGUAGE LambdaCase #-}"
      , [Char]
"{-# LANGUAGE OverloadedStrings #-}"
      , [Char]
""
      , [Char]
"-- | This file is generated by \"plutus-preprocessor:plutus-preprocessor\""
      , [Char]
"module Test.Cardano.Ledger.Plutus.Examples ("
      , [Char] -> [Char]
indent ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
",\n  " [[Char]
name | ([Char]
name, Language -> (Q [Dec], PlutusBinary)
_, NonEmpty [Char]
_) <- [([Char], Language -> (Q [Dec], PlutusBinary), NonEmpty [Char])]
allTestScripts] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
","
      , [Char]
") where"
      , [Char]
""
      , [Char]
"import Cardano.Ledger.Plutus.Language (Plutus (..), PlutusBinary (..), SLanguage (..))"
      , [Char]
"import Data.ByteString (ByteString)"
      , [Char]
"import qualified Data.ByteString.Base16 as Base16 (decode)"
      , [Char]
"import qualified Data.ByteString.Short as SBS (toShort)"
      , [Char]
"import GHC.Stack"
      , [Char]
""
      , [Char]
"decodeHexPlutus :: HasCallStack => ByteString -> Plutus l"
      , [Char]
"decodeHexPlutus = either error (Plutus . PlutusBinary . SBS.toShort) . Base16.decode"
      ]
  [([Char], Language -> (Q [Dec], PlutusBinary), NonEmpty [Char])]
-> (([Char], Language -> (Q [Dec], PlutusBinary), NonEmpty [Char])
    -> IO ())
-> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [([Char], Language -> (Q [Dec], PlutusBinary), NonEmpty [Char])]
allTestScripts ((([Char], Language -> (Q [Dec], PlutusBinary), NonEmpty [Char])
  -> IO ())
 -> IO ())
-> (([Char], Language -> (Q [Dec], PlutusBinary), NonEmpty [Char])
    -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \([Char]
scriptName, Language -> (Q [Dec], PlutusBinary)
scriptLangLookup, [Char]
haddockFirst :| [[Char]]
haddockRest) -> do
    Handle -> [Char] -> IO ()
hPutStr Handle
h ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
      [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
        [ [Char]
""
        , [Char]
"-- | " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
haddockFirst
        ]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"-- " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
l | [Char]
l <- [[Char]]
haddockRest]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [ [Char]
scriptName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" :: SLanguage l -> Plutus l"
             , [Char]
scriptName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ="
             , [Char] -> [Char]
indent [Char]
"decodeHexPlutus . mconcat . \\case"
             ]
    [Language] -> (Language -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Language
forall a. Bounded a => a
minBound .. Language
forall a. Bounded a => a
maxBound] ((Language -> IO ()) -> IO ()) -> (Language -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Language
lang -> do
      let (Q [Dec]
scriptQ, script :: PlutusBinary
script@(PlutusBinary ShortByteString
scriptBytes)) = Language -> (Q [Dec], PlutusBinary)
scriptLangLookup Language
lang
      [Dec]
compiledScript <- Q [Dec] -> IO [Dec]
forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ Q [Dec]
scriptQ
      Handle -> [Char] -> IO ()
hPutStr Handle
h ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
          [ [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"-- " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
              ScriptHash -> [Char]
forall a. Show a => a -> [Char]
show (ScriptHash -> [Char]) -> ScriptHash -> [Char]
forall a b. (a -> b) -> a -> b
$
                Language
-> (forall {l :: Language}.
    PlutusLanguage l =>
    SLanguage l -> ScriptHash)
-> ScriptHash
forall a.
Language
-> (forall (l :: Language). PlutusLanguage l => SLanguage l -> a)
-> a
withSLanguage Language
lang ((forall {l :: Language}.
  PlutusLanguage l =>
  SLanguage l -> ScriptHash)
 -> ScriptHash)
-> (forall {l :: Language}.
    PlutusLanguage l =>
    SLanguage l -> ScriptHash)
-> ScriptHash
forall a b. (a -> b) -> a -> b
$
                  \SLanguage l
slang -> Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript (SLanguage l -> Plutus l -> Plutus l
forall (l :: Language) (proxy :: Language -> *).
SLanguage l -> proxy l -> proxy l
asSLanguage SLanguage l
slang (PlutusBinary -> Plutus l
forall (l :: Language). PlutusBinary -> Plutus l
Plutus PlutusBinary
script))
          , [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"-- Preprocessed " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows Language
lang ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
" Script:"
          , [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"-- @@@"
          ]
            [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"-- " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)) ([Char] -> [[Char]]
lines ([Dec] -> [Char]
forall a. Ppr a => a -> [Char]
pprint [Dec]
compiledScript))
            [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [ [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"-- @@@"
               , [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"S" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Language -> [Char]
forall a. Show a => a -> [Char]
show Language
lang [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" ->"
               , [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
                   let sep :: [Char]
sep = (([Char]
"\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
", ")
                       hexChunks :: [[Char]]
hexChunks = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
forall a. Show a => a -> [Char]
show ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> [[Char]]
showHexBytesGrouped Int
90 (ShortByteString -> ByteString
SBS.fromShort ShortByteString
scriptBytes)
                    in [Char]
"[ " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
sep [[Char]]
hexChunks
               , [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
indent ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"]"
               ]

-- ========================================================================
-- Generate the PlutusScripts.hs which does not depend on plutus-plugin.
-- write out the file header (module and imports), then 'display' the result
-- for each plutus script.

allTestScripts :: [(String, Language -> (Q [Dec], PlutusBinary), NonEmpty String)]
allTestScripts :: [([Char], Language -> (Q [Dec], PlutusBinary), NonEmpty [Char])]
allTestScripts =
  [
    ( [Char]
"alwaysSucceedsNoDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.alwaysSucceedsNoDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.alwaysSucceedsNoDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.alwaysSucceedsNoDatumBytes
    , [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"Script that always succeeds, unless arguments are malformed or context contains a datum"
    )
  ,
    ( [Char]
"alwaysSucceedsWithDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.alwaysSucceedsWithDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.alwaysSucceedsWithDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.alwaysSucceedsWithDatumBytes
    , [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [Char]
"Script that always succeeds, unless arguments are malformed or context does not contain a datum"
    )
  ,
    ( [Char]
"alwaysFailsNoDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.alwaysFailsNoDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.alwaysFailsNoDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.alwaysFailsNoDatumBytes
    , [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"Script that always fails, unless arguments are malformed or context contains a datum"
    )
  ,
    ( [Char]
"alwaysFailsWithDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.alwaysFailsWithDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.alwaysFailsWithDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.alwaysFailsWithDatumBytes
    , [Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
"Script that always fails, unless arguments are malformed or context does not contain a datum"
    )
  ,
    ( [Char]
"redeemerSameAsDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.redeemerSameAsDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.redeemerSameAsDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.redeemerSameAsDatumBytes
    , [Char]
"Script that succeeds whenever redeemer equals to the datum"
        [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [ [Char]
"Fails on malformed arguments"
           ]
    )
  ,
    ( [Char]
"evenDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.evenDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.evenDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.evenDatumBytes
    , [Char]
"Script that succeeds whenever Integer datum is supplied and it's value is even."
        [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [ [Char]
"Fails on malformed arguments"
           ]
    )
  ,
    ( [Char]
"evenRedeemerNoDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.evenRedeemerNoDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.evenRedeemerNoDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.evenRedeemerNoDatumBytes
    , [Char]
"Script that succeeds whenever Integer redeemer is supplied and it's value is even"
        [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [ [Char]
"Fails on malformed arguments or whenever datum is present in the context"
           ]
    )
  ,
    ( [Char]
"evenRedeemerWithDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.evenRedeemerWithDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.evenRedeemerWithDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.evenRedeemerWithDatumBytes
    , [Char]
"Script that succeeds whenever Integer redeemer is supplied and it's value is even"
        [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [ [Char]
"Fails on malformed arguments or whenever datum is missing from the context"
           ]
    )
  ,
    ( [Char]
"purposeIsWellformedNoDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.purposeIsWellformedNoDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.purposeIsWellformedNoDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.purposeIsWellformedNoDatumBytes
    , [Char]
"Script that succeeds when datum is not expected and purpose arguments are validated against txInfo"
        [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [ [Char]
"Fails on malformed arguments"
           ]
    )
  ,
    ( [Char]
"purposeIsWellformedWithDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.purposeIsWellformedWithDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.purposeIsWellformedWithDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.purposeIsWellformedWithDatumBytes
    , [Char]
"Script that succeeds when datum is expected and purpose arguments are validated against txInfo"
        [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [ [Char]
"Fails on malformed arguments"
           ]
    )
  ,
    ( [Char]
"datumIsWellformed"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.datumIsWellformedBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.datumIsWellformedBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.datumIsWellformedBytes
    , [Char]
"Script that succeeds when datum is expected and datum is validated against txInfo"
        [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [ [Char]
"Fails on malformed arguments"
           ]
    )
  ,
    ( [Char]
"inputsOutputsAreNotEmptyNoDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.inputsOutputsAreNotEmptyNoDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.inputsOutputsAreNotEmptyNoDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.inputsOutputsAreNotEmptyNoDatumBytes
    , [Char]
"Script that succeeds when inputs and outputs are not empty validated against txInfo"
        [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [ [Char]
"Fails on malformed arguments and also if inputs or outputs are empty"
           ]
    )
  ,
    ( [Char]
"inputsOutputsAreNotEmptyWithDatum"
    , \case
        Language
PlutusV1 -> (Q [Dec], PlutusBinary)
V1.inputsOutputsAreNotEmptyWithDatumBytes
        Language
PlutusV2 -> (Q [Dec], PlutusBinary)
V2.inputsOutputsAreNotEmptyWithDatumBytes
        Language
PlutusV3 -> (Q [Dec], PlutusBinary)
V3.inputsOutputsAreNotEmptyWithDatumBytes
    , [Char]
"Script that succeeds when inputs and outputs are not empty validated against txInfo"
        [Char] -> [[Char]] -> NonEmpty [Char]
forall a. a -> [a] -> NonEmpty a
:| [ [Char]
"Fails on malformed arguments and also if inputs or outputs are empty"
           ]
    )
  ]