content: {-# 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 h = do
    let indent = ("  " ++)
    hPutStr h $
      unlines
        [ "{-# LANGUAGE DataKinds #-}"
        , "{-# LANGUAGE GADTs #-}"
        , "{-# LANGUAGE LambdaCase #-}"
        , "{-# LANGUAGE OverloadedStrings #-}"
        , ""
        , "-- | This file is generated by \"plutus-preprocessor:plutus-preprocessor\""
        , "module Test.Cardano.Ledger.Plutus.Examples ("
        , indent $ intercalate ",\n  " [name | (name, _, _) <- allTestScripts] ++ ","
        , ") where"
        , ""
        , "import Cardano.Ledger.Plutus.Language (Plutus (..), PlutusBinary (..), SLanguage (..))"
        , "import Data.ByteString (ByteString)"
        , "import qualified Data.ByteString.Base16 as Base16 (decode)"
        , "import qualified Data.ByteString.Short as SBS (toShort)"
        , "import GHC.Stack"
        , ""
        , "decodeHexPlutus :: HasCallStack => ByteString -> Plutus l"
        , "decodeHexPlutus = either error (Plutus . PlutusBinary . SBS.toShort) . Base16.decode"
        ]
    forM_ allTestScripts $ \(scriptName, scriptLangLookup, haddockFirst :| haddockRest) -> do
      hPutStr h $
        unlines $
          [ ""
          , "-- | " ++ haddockFirst
          ]
            ++ ["-- " ++ l | l <- haddockRest]
            ++ [ scriptName ++ " :: SLanguage l -> Plutus l"
               , scriptName ++ " ="
               , indent "decodeHexPlutus . mconcat . \\case"
               ]
      forM_ [minBound .. maxBound] $ \lang -> case scriptLangLookup lang of
        Just (scriptQ, script@(PlutusBinary scriptBytes)) -> do
          let
          compiledScript <- runQ scriptQ
          hPutStr h $
            unlines $
              [ indent . indent . ("-- " ++) $
                  show $
                    withSLanguage lang $
                      \slang -> hashPlutusScript (asSLanguage slang (Plutus script))
              , indent . indent . ("-- Preprocessed " ++) . shows lang $ " Script:"
              , indent . indent $ "-- @@@"
              ]
                ++ map (indent . indent . ("-- " ++)) (lines (pprint compiledScript))
                ++ [ indent . indent $ "-- @@@"
                   , indent . indent $ "S" ++ show lang ++ " ->"
                   , indent . indent . indent $
                       let sep = (("\n" ++) . indent . indent . indent $ ", ")
                           hexChunks = map show $ showHexBytesGrouped 90 (SBS.fromShort scriptBytes)
                        in "[ " ++ intercalate sep hexChunks
                   , indent . indent . indent $ "]"
                   ]
        Nothing ->
          hPutStr h . indent . indent $
            "S" ++ show lang ++ " -> error \"Script not available in " ++ show lang ++ "\"\n"
  
  -- ========================================================================
  -- 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 -> Maybe (Q [Dec], PlutusBinary), NonEmpty String)]
  allTestScripts =
    [
      ( "alwaysSucceedsNoDatum"
      , \case
          PlutusV1 -> Just V1.alwaysSucceedsNoDatumBytes
          PlutusV2 -> Just V2.alwaysSucceedsNoDatumBytes
          PlutusV3 -> Just V3.alwaysSucceedsNoDatumBytes
          PlutusV4 -> Just V3.alwaysSucceedsNoDatumBytes
      , pure "Script that always succeeds, unless arguments are malformed or context contains a datum"
      )
    ,
      ( "alwaysSucceedsWithDatum"
      , \case
          PlutusV1 -> Just V1.alwaysSucceedsWithDatumBytes
          PlutusV2 -> Just V2.alwaysSucceedsWithDatumBytes
          PlutusV3 -> Just V3.alwaysSucceedsWithDatumBytes
          PlutusV4 -> Just V3.alwaysSucceedsWithDatumBytes
      , pure
          "Script that always succeeds, unless arguments are malformed or context does not contain a datum"
      )
    ,
      ( "alwaysFailsNoDatum"
      , \case
          PlutusV1 -> Just V1.alwaysFailsNoDatumBytes
          PlutusV2 -> Just V2.alwaysFailsNoDatumBytes
          PlutusV3 -> Just V3.alwaysFailsNoDatumBytes
          PlutusV4 -> Just V3.alwaysFailsNoDatumBytes
      , pure "Script that always fails, unless arguments are malformed or context contains a datum"
      )
    ,
      ( "alwaysFailsWithDatum"
      , \case
          PlutusV1 -> Just V1.alwaysFailsWithDatumBytes
          PlutusV2 -> Just V2.alwaysFailsWithDatumBytes
          PlutusV3 -> Just V3.alwaysFailsWithDatumBytes
          PlutusV4 -> Just V3.alwaysFailsWithDatumBytes
      , pure "Script that always fails, unless arguments are malformed or context does not contain a datum"
      )
    ,
      ( "redeemerSameAsDatum"
      , \case
          PlutusV1 -> Just V1.redeemerSameAsDatumBytes
          PlutusV2 -> Just V2.redeemerSameAsDatumBytes
          PlutusV3 -> Just V3.redeemerSameAsDatumBytes
          PlutusV4 -> Just V3.redeemerSameAsDatumBytes
      , "Script that succeeds whenever redeemer equals to the datum"
          :| [ "Fails on malformed arguments"
             ]
      )
    ,
      ( "evenDatum"
      , \case
          PlutusV1 -> Just V1.evenDatumBytes
          PlutusV2 -> Just V2.evenDatumBytes
          PlutusV3 -> Just V3.evenDatumBytes
          PlutusV4 -> Just V3.evenDatumBytes
      , "Script that succeeds whenever Integer datum is supplied and it's value is even."
          :| [ "Fails on malformed arguments"
             ]
      )
    ,
      ( "evenRedeemerNoDatum"
      , \case
          PlutusV1 -> Just V1.evenRedeemerNoDatumBytes
          PlutusV2 -> Just V2.evenRedeemerNoDatumBytes
          PlutusV3 -> Just V3.evenRedeemerNoDatumBytes
          PlutusV4 -> Just V3.evenRedeemerNoDatumBytes
      , "Script that succeeds whenever Integer redeemer is supplied and it's value is even"
          :| [ "Fails on malformed arguments or whenever datum is present in the context"
             ]
      )
    ,
      ( "evenRedeemerWithDatum"
      , \case
          PlutusV1 -> Just V1.evenRedeemerWithDatumBytes
          PlutusV2 -> Just V2.evenRedeemerWithDatumBytes
          PlutusV3 -> Just V3.evenRedeemerWithDatumBytes
          PlutusV4 -> Just V3.evenRedeemerWithDatumBytes
      , "Script that succeeds whenever Integer redeemer is supplied and it's value is even"
          :| [ "Fails on malformed arguments or whenever datum is missing from the context"
             ]
      )
    ,
      ( "purposeIsWellformedNoDatum"
      , \case
          PlutusV1 -> Just V1.purposeIsWellformedNoDatumBytes
          PlutusV2 -> Just V2.purposeIsWellformedNoDatumBytes
          PlutusV3 -> Just V3.purposeIsWellformedNoDatumBytes
          PlutusV4 -> Just V3.purposeIsWellformedNoDatumBytes
      , "Script that succeeds when datum is not expected and purpose arguments are validated against txInfo"
          :| [ "Fails on malformed arguments"
             ]
      )
    ,
      ( "purposeIsWellformedWithDatum"
      , \case
          PlutusV1 -> Just V1.purposeIsWellformedWithDatumBytes
          PlutusV2 -> Just V2.purposeIsWellformedWithDatumBytes
          PlutusV3 -> Just V3.purposeIsWellformedWithDatumBytes
          PlutusV4 -> Just V3.purposeIsWellformedWithDatumBytes
      , "Script that succeeds when datum is expected and purpose arguments are validated against txInfo"
          :| [ "Fails on malformed arguments"
             ]
      )
    ,
      ( "datumIsWellformed"
      , \case
          PlutusV1 -> Just V1.datumIsWellformedBytes
          PlutusV2 -> Just V2.datumIsWellformedBytes
          PlutusV3 -> Just V3.datumIsWellformedBytes
          PlutusV4 -> Just V3.datumIsWellformedBytes
      , "Script that succeeds when datum is expected and datum is validated against txInfo"
          :| [ "Fails on malformed arguments"
             ]
      )
    ,
      ( "inputsOutputsAreNotEmptyNoDatum"
      , \case
          PlutusV1 -> Just V1.inputsOutputsAreNotEmptyNoDatumBytes
          PlutusV2 -> Just V2.inputsOutputsAreNotEmptyNoDatumBytes
          PlutusV3 -> Just V3.inputsOutputsAreNotEmptyNoDatumBytes
          PlutusV4 -> Just V3.inputsOutputsAreNotEmptyNoDatumBytes
      , "Script that succeeds when inputs and outputs are not empty validated against txInfo"
          :| [ "Fails on malformed arguments and also if inputs or outputs are empty"
             ]
      )
    ,
      ( "inputsOutputsAreNotEmptyWithDatum"
      , \case
          PlutusV1 -> Just V1.inputsOutputsAreNotEmptyWithDatumBytes
          PlutusV2 -> Just V2.inputsOutputsAreNotEmptyWithDatumBytes
          PlutusV3 -> Just V3.inputsOutputsAreNotEmptyWithDatumBytes
          PlutusV4 -> Just V3.inputsOutputsAreNotEmptyWithDatumBytes
      , "Script that succeeds when inputs and outputs are not empty validated against txInfo"
          :| [ "Fails on malformed arguments and also if inputs or outputs are empty"
             ]
      )
    ,
      ( "inputsOverlapsWithRefInputs"
      , \case
          PlutusV1 -> Nothing
          PlutusV2 -> Just V2.inputsOverlapsWithRefInputsBytes
          PlutusV3 -> Just V3.inputsOverlapsWithRefInputsBytes
          PlutusV4 -> Just V3.inputsOverlapsWithRefInputsBytes
      , "Script that succeeds only if any the inputs also appears in the reference inputs" :| []
      )
    ]
  