{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Api.Experimental.AnyScript
  ( AnyScript (..)
  , AsType (..)
  , deserialiseAnyPlutusScriptOfLanguage
  , deserialiseAnySimpleScript
  , hashAnyScript
  )
where

import Cardano.Api.Experimental.Era
import Cardano.Api.Experimental.Plutus.Internal.Script hiding (AnyPlutusScript)
import Cardano.Api.Experimental.Simple.Script
import Cardano.Api.HasTypeProxy
import Cardano.Api.Ledger.Internal.Reexport qualified as L
import Cardano.Api.Serialise.Cbor

import Cardano.Ledger.Binary qualified as CBOR
import Cardano.Ledger.Core qualified as L
import Cardano.Ledger.Plutus.Language qualified as Plutus

import Data.ByteString qualified as BS
import Data.Either.Combinators (maybeToRight, rightToMaybe)
import Data.Foldable (asum)
import Data.Type.Equality ((:~:) (..))
import Data.Typeable (Typeable, eqT)

data AnyScript era where
  AnySimpleScript :: SimpleScript era -> AnyScript era
  AnyPlutusScript
    :: (Plutus.PlutusLanguage lang, Typeable lang) => PlutusScriptInEra lang era -> AnyScript era

instance L.Era era => HasTypeProxy (AnyScript era) where
  data AsType (AnyScript era) = AsAnyScript
  proxyToAsType :: Proxy (AnyScript era) -> AsType (AnyScript era)
proxyToAsType Proxy (AnyScript era)
_ = AsType (AnyScript era)
forall era. AsType (AnyScript era)
AsAnyScript

instance Show (AnyScript era) where
  show :: AnyScript era -> String
show (AnySimpleScript SimpleScript era
ss) = String
"AnySimpleScript " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SimpleScript era -> String
forall a. Show a => a -> String
show SimpleScript era
ss
  show (AnyPlutusScript PlutusScriptInEra lang era
ps) = String
"AnyPlutusScript " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PlutusScriptInEra lang era -> String
forall a. Show a => a -> String
show PlutusScriptInEra lang era
ps

instance Eq (AnyScript era) where
  AnySimpleScript SimpleScript era
s1 == :: AnyScript era -> AnyScript era -> Bool
== AnySimpleScript SimpleScript era
s2 = SimpleScript era
s1 SimpleScript era -> SimpleScript era -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleScript era
s2
  AnyPlutusScript (PlutusScriptInEra lang era
ps1 :: PlutusScriptInEra lang1 era) == AnyPlutusScript (PlutusScriptInEra lang era
ps2 :: PlutusScriptInEra lang2 era) =
    case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall (a :: Language) (b :: Language).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @lang1 @lang2 of
      Just lang :~: lang
Refl -> PlutusScriptInEra lang era
ps1 PlutusScriptInEra lang era -> PlutusScriptInEra lang era -> Bool
forall a. Eq a => a -> a -> Bool
== PlutusScriptInEra lang era
PlutusScriptInEra lang era
ps2
      Maybe (lang :~: lang)
Nothing -> Bool
False
  AnyScript era
_ == AnyScript era
_ = Bool
False

instance
  L.AlonzoEraScript era
  => SerialiseAsCBOR (AnyScript era)
  where
  serialiseToCBOR :: AnyScript era -> ByteString
serialiseToCBOR (AnySimpleScript (SimpleScript NativeScript era
ns)) =
    Version -> Script era -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
L.serialize' (forall era. Era era => Version
L.eraProtVerHigh @era) (NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
L.fromNativeScript NativeScript era
ns :: L.Script era)
  serialiseToCBOR (AnyPlutusScript PlutusScriptInEra lang era
ps) =
    Version -> Script era -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
L.serialize' (forall era. Era era => Version
L.eraProtVerHigh @era) (PlutusScriptInEra lang era -> Script era
forall (lang :: Language) era.
AlonzoEraScript era =>
PlutusScriptInEra lang era -> Script era
plutusScriptInEraToScript PlutusScriptInEra lang era
ps)

  deserialiseFromCBOR :: AsType (AnyScript era)
-> ByteString -> Either DecoderError (AnyScript era)
deserialiseFromCBOR AsType (AnyScript era)
_ ByteString
bs = do
    script <- Either DecoderError (Script era)
decodeScript
    maybeToRight noParseError $
      asum
        [ tryNativeScript script
        , tryPlutusScript script
        ]
   where
    decodeScript :: Either CBOR.DecoderError (L.Script era)
    decodeScript :: Either DecoderError (Script era)
decodeScript = do
      r <- Annotator (Script era) -> FullByteString -> Script era
forall a. Annotator a -> FullByteString -> a
CBOR.runAnnotator (Annotator (Script era) -> FullByteString -> Script era)
-> Either DecoderError (Annotator (Script era))
-> Either DecoderError (FullByteString -> Script era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Version
-> ByteString -> Either DecoderError (Annotator (Script era))
forall a.
DecCBOR a =>
Version -> ByteString -> Either DecoderError a
CBOR.decodeFull' (forall era. Era era => Version
L.eraProtVerHigh @era) ByteString
bs
      return $ r $ CBOR.Full $ BS.fromStrict bs

    tryNativeScript :: L.Script era -> Maybe (AnyScript era)
    tryNativeScript :: Script era -> Maybe (AnyScript era)
tryNativeScript = (NativeScript era -> AnyScript era)
-> Maybe (NativeScript era) -> Maybe (AnyScript era)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SimpleScript era -> AnyScript era
forall era. SimpleScript era -> AnyScript era
AnySimpleScript (SimpleScript era -> AnyScript era)
-> (NativeScript era -> SimpleScript era)
-> NativeScript era
-> AnyScript era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NativeScript era -> SimpleScript era
forall era. EraScript era => NativeScript era -> SimpleScript era
SimpleScript) (Maybe (NativeScript era) -> Maybe (AnyScript era))
-> (Script era -> Maybe (NativeScript era))
-> Script era
-> Maybe (AnyScript era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Script era -> Maybe (NativeScript era)
forall era. EraScript era => Script era -> Maybe (NativeScript era)
L.getNativeScript

    tryPlutusScript :: L.Script era -> Maybe (AnyScript era)
    tryPlutusScript :: Script era -> Maybe (AnyScript era)
tryPlutusScript Script era
script = do
      ps <- Script era -> Maybe (PlutusScript era)
forall era.
AlonzoEraScript era =>
Script era -> Maybe (PlutusScript era)
L.toPlutusScript Script era
script
      L.withPlutusScript ps $ \(Plutus l
plutus :: Plutus.Plutus l) ->
        PlutusScriptInEra l era -> AnyScript era
forall (lang :: Language) era.
(PlutusLanguage lang, Typeable lang) =>
PlutusScriptInEra lang era -> AnyScript era
AnyPlutusScript (PlutusScriptInEra l era -> AnyScript era)
-> (PlutusRunnable l -> PlutusScriptInEra l era)
-> PlutusRunnable l
-> AnyScript era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlutusRunnable l -> PlutusScriptInEra l era
forall (lang :: Language) era.
PlutusLanguage lang =>
PlutusRunnable lang -> PlutusScriptInEra lang era
PlutusScriptInEra
          (PlutusRunnable l -> AnyScript era)
-> Maybe (PlutusRunnable l) -> Maybe (AnyScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either ScriptDecodeError (PlutusRunnable l)
-> Maybe (PlutusRunnable l)
forall a b. Either a b -> Maybe b
rightToMaybe (Version -> Plutus l -> Either ScriptDecodeError (PlutusRunnable l)
forall (l :: Language).
PlutusLanguage l =>
Version -> Plutus l -> Either ScriptDecodeError (PlutusRunnable l)
Plutus.decodePlutusRunnable (forall era. Era era => Version
L.eraProtVerHigh @era) Plutus l
plutus)

    noParseError :: CBOR.DecoderError
    noParseError :: DecoderError
noParseError =
      Text -> Text -> DecoderError
CBOR.DecoderErrorCustom
        Text
"AnyScript"
        Text
"Decoded Script era is neither a NativeScript nor a PlutusScript"

hashAnyScript :: forall era. IsEra era => AnyScript (LedgerEra era) -> L.ScriptHash
hashAnyScript :: forall era. IsEra era => AnyScript (LedgerEra era) -> ScriptHash
hashAnyScript (AnySimpleScript SimpleScript (LedgerEra era)
ss) =
  SimpleScript (LedgerEra era) -> ScriptHash
forall era. IsEra era => SimpleScript (LedgerEra era) -> ScriptHash
hashSimpleScript SimpleScript (LedgerEra era)
ss
hashAnyScript (AnyPlutusScript PlutusScriptInEra lang (LedgerEra era)
ps) =
  PlutusScriptInEra lang (LedgerEra era) -> ScriptHash
forall era (lang :: Language).
IsEra era =>
PlutusScriptInEra lang (LedgerEra era) -> ScriptHash
hashPlutusScriptInEra PlutusScriptInEra lang (LedgerEra era)
ps

deserialiseAnySimpleScript
  :: forall era. IsEra era => BS.ByteString -> Either CBOR.DecoderError (AnyScript (LedgerEra era))
deserialiseAnySimpleScript :: forall era.
IsEra era =>
ByteString -> Either DecoderError (AnyScript (LedgerEra era))
deserialiseAnySimpleScript ByteString
bs =
  SimpleScript (LedgerEra era) -> AnyScript (LedgerEra era)
forall era. SimpleScript era -> AnyScript era
AnySimpleScript (SimpleScript (LedgerEra era) -> AnyScript (LedgerEra era))
-> Either DecoderError (SimpleScript (LedgerEra era))
-> Either DecoderError (AnyScript (LedgerEra era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Era era
-> (EraCommonConstraints era =>
    Either DecoderError (SimpleScript (LedgerEra era)))
-> Either DecoderError (SimpleScript (LedgerEra era))
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints (forall era. IsEra era => Era era
useEra @era) (ByteString -> Either DecoderError (SimpleScript (LedgerEra era))
forall era.
EraScript era =>
ByteString -> Either DecoderError (SimpleScript era)
deserialiseSimpleScript ByteString
bs)

deserialiseAnyPlutusScriptOfLanguage
  :: forall era lang
   . (IsEra era, Plutus.PlutusLanguage lang, HasTypeProxy (Plutus.SLanguage lang))
  => BS.ByteString -> L.SLanguage lang -> Either CBOR.DecoderError (AnyScript (LedgerEra era))
deserialiseAnyPlutusScriptOfLanguage :: forall era (lang :: Language).
(IsEra era, PlutusLanguage lang, HasTypeProxy (SLanguage lang)) =>
ByteString
-> SLanguage lang
-> Either DecoderError (AnyScript (LedgerEra era))
deserialiseAnyPlutusScriptOfLanguage ByteString
bs SLanguage lang
lang = do
  s :: (PlutusScriptInEra lang (LedgerEra era)) <-
    Era era
-> (EraCommonConstraints era =>
    Either DecoderError (PlutusScriptInEra lang (LedgerEra era)))
-> Either DecoderError (PlutusScriptInEra lang (LedgerEra era))
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints (forall era. IsEra era => Era era
useEra @era) (SLanguage lang
-> ByteString
-> Either DecoderError (PlutusScriptInEra lang (LedgerEra era))
forall era (lang :: Language).
(PlutusLanguage lang, HasTypeProxy (SLanguage lang), Era era) =>
SLanguage lang
-> ByteString -> Either DecoderError (PlutusScriptInEra lang era)
deserialisePlutusScriptInEra SLanguage lang
lang ByteString
bs)
  return $ AnyPlutusScript s