-- editorconfig-checker-disable-file
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RoleAnnotations       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
module PlutusTx.Code where

import PlutusTx.Coverage
import PlutusTx.Lift.Instances ()

import PlutusIR qualified as PIR

import PlutusCore qualified as PLC
import UntypedPlutusCore qualified as UPLC

import Control.Exception
import Flat (Flat (..), unflat)
import Flat.Decoder (DecodeException)

import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BSL
import ErrorCode
-- We do not use qualified import because the whole module contains off-chain code
import Prelude as Haskell

-- The final type parameter is inferred to be phantom, but we give it a nominal
-- role, since it corresponds to the Haskell type of the program that was compiled into
-- this 'CompiledCodeIn'. It could be okay to give it a representational role, since
-- we compile newtypes the same as their underlying types, but people probably just
-- shouldn't coerce the final parameter regardless, so we play it safe with a nominal role.
type role CompiledCodeIn representational representational nominal
-- NOTE: any changes to this type must be paralleled by changes
-- in the plugin code that generates values of this type. That is
-- done by code generation so it's not typechecked normally.
-- | A compiled Plutus Tx program. The last type parameter indicates
-- the type of the Haskell expression that was compiled, and
-- hence the type of the compiled code.
--
-- Note: the compiled PLC program does *not* have normalized types,
-- if you want to put it on the chain you must normalize the types first.
data CompiledCodeIn uni fun a =
    -- | Serialized UPLC code and possibly serialized PIR code with metadata used for program coverage.
    SerializedCode BS.ByteString (Maybe BS.ByteString) CoverageIndex
    -- | Deserialized UPLC program, and possibly deserialized PIR program with metadata used for program coverage.
    | DeserializedCode (UPLC.Program UPLC.NamedDeBruijn uni fun ()) (Maybe (PIR.Program PLC.TyName PLC.Name uni fun ())) CoverageIndex

-- | 'CompiledCodeIn' instantiated with default built-in types and functions.
type CompiledCode = CompiledCodeIn PLC.DefaultUni PLC.DefaultFun

-- | Apply a compiled function to a compiled argument.
applyCode
    :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun)
    => CompiledCodeIn uni fun (a -> b) -> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b
applyCode :: forall (uni :: * -> *) fun a b.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b
applyCode CompiledCodeIn uni fun (a -> b)
fun CompiledCodeIn uni fun a
arg = forall (uni :: * -> *) fun a.
Program NamedDeBruijn uni fun ()
-> Maybe (Program TyName Name uni fun ())
-> CoverageIndex
-> CompiledCodeIn uni fun a
DeserializedCode (forall name (uni :: * -> *) fun.
Program name uni fun ()
-> Program name uni fun () -> Program name uni fun ()
UPLC.applyProgram (forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Program NamedDeBruijn uni fun ()
getPlc CompiledCodeIn uni fun (a -> b)
fun) (forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Program NamedDeBruijn uni fun ()
getPlc CompiledCodeIn uni fun a
arg)) (forall a tyname name (uni :: * -> *) fun.
Monoid a =>
Program tyname name uni fun a
-> Program tyname name uni fun a -> Program tyname name uni fun a
PIR.applyProgram forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Maybe (Program TyName Name uni fun ())
getPir CompiledCodeIn uni fun (a -> b)
fun forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Maybe (Program TyName Name uni fun ())
getPir CompiledCodeIn uni fun a
arg) (forall (uni :: * -> *) fun a.
CompiledCodeIn uni fun a -> CoverageIndex
getCovIdx CompiledCodeIn uni fun (a -> b)
fun forall a. Semigroup a => a -> a -> a
<> forall (uni :: * -> *) fun a.
CompiledCodeIn uni fun a -> CoverageIndex
getCovIdx CompiledCodeIn uni fun a
arg)

-- | The size of a 'CompiledCodeIn', in AST nodes.
sizePlc :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun) => CompiledCodeIn uni fun a -> Integer
sizePlc :: forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Integer
sizePlc = forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> Integer
UPLC.programSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Program NamedDeBruijn uni fun ()
getPlc

instance (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun)
    => Flat (CompiledCodeIn uni fun a) where
    encode :: CompiledCodeIn uni fun a -> Encoding
encode CompiledCodeIn uni fun a
c = forall a. Flat a => a -> Encoding
encode (forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Program NamedDeBruijn uni fun ()
getPlc CompiledCodeIn uni fun a
c)

    decode :: Get (CompiledCodeIn uni fun a)
decode = do
        Program NamedDeBruijn uni fun ()
p <- forall a. Flat a => Get a
decode
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (uni :: * -> *) fun a.
Program NamedDeBruijn uni fun ()
-> Maybe (Program TyName Name uni fun ())
-> CoverageIndex
-> CompiledCodeIn uni fun a
DeserializedCode Program NamedDeBruijn uni fun ()
p forall a. Maybe a
Nothing forall a. Monoid a => a
mempty

    size :: CompiledCodeIn uni fun a -> NumBits -> NumBits
size CompiledCodeIn uni fun a
c = forall a. Flat a => a -> NumBits -> NumBits
size (forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Program NamedDeBruijn uni fun ()
getPlc CompiledCodeIn uni fun a
c)

{- Note [Deserializing the AST]
The types suggest that we can fail to deserialize the AST that we embedded in the program.
However, we just did it ourselves, so this should be impossible, and we signal this with an
exception.
-}
newtype ImpossibleDeserialisationFailure = ImpossibleDeserialisationFailure DecodeException
    deriving anyclass (Show ImpossibleDeserialisationFailure
Typeable ImpossibleDeserialisationFailure
SomeException -> Maybe ImpossibleDeserialisationFailure
ImpossibleDeserialisationFailure -> String
ImpossibleDeserialisationFailure -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: ImpossibleDeserialisationFailure -> String
$cdisplayException :: ImpossibleDeserialisationFailure -> String
fromException :: SomeException -> Maybe ImpossibleDeserialisationFailure
$cfromException :: SomeException -> Maybe ImpossibleDeserialisationFailure
toException :: ImpossibleDeserialisationFailure -> SomeException
$ctoException :: ImpossibleDeserialisationFailure -> SomeException
Exception)
instance Show ImpossibleDeserialisationFailure where
    show :: ImpossibleDeserialisationFailure -> String
show (ImpossibleDeserialisationFailure DecodeException
e) = String
"Failed to deserialise our own program! This is a bug, please report it. Caused by: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DecodeException
e

instance HasErrorCode ImpossibleDeserialisationFailure where
      errorCode :: ImpossibleDeserialisationFailure -> ErrorCode
errorCode ImpossibleDeserialisationFailure {} = Natural -> ErrorCode
ErrorCode Natural
40

-- | Get the actual Plutus Core program out of a 'CompiledCodeIn'.
getPlc
    :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun)
    => CompiledCodeIn uni fun a -> UPLC.Program UPLC.NamedDeBruijn uni fun ()
getPlc :: forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Program NamedDeBruijn uni fun ()
getPlc CompiledCodeIn uni fun a
wrapper = case CompiledCodeIn uni fun a
wrapper of
    SerializedCode ByteString
plc Maybe ByteString
_ CoverageIndex
_ -> case forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (ByteString -> ByteString
BSL.fromStrict ByteString
plc) of
        Left DecodeException
e  -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ DecodeException -> ImpossibleDeserialisationFailure
ImpossibleDeserialisationFailure DecodeException
e
        Right Program NamedDeBruijn uni fun ()
p -> Program NamedDeBruijn uni fun ()
p
    DeserializedCode Program NamedDeBruijn uni fun ()
plc Maybe (Program TyName Name uni fun ())
_ CoverageIndex
_ -> Program NamedDeBruijn uni fun ()
plc

-- | Get the Plutus IR program, if there is one, out of a 'CompiledCodeIn'.
getPir
    :: (PLC.Closed uni, uni `PLC.Everywhere` Flat, Flat fun)
    => CompiledCodeIn uni fun a -> Maybe (PIR.Program PIR.TyName PIR.Name uni fun ())
getPir :: forall (uni :: * -> *) fun a.
(Closed uni, Everywhere uni Flat, Flat fun) =>
CompiledCodeIn uni fun a -> Maybe (Program TyName Name uni fun ())
getPir CompiledCodeIn uni fun a
wrapper = case CompiledCodeIn uni fun a
wrapper of
    SerializedCode ByteString
_ Maybe ByteString
pir CoverageIndex
_ -> case Maybe ByteString
pir of
        Just ByteString
bs -> case forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat (ByteString -> ByteString
BSL.fromStrict ByteString
bs) of
            Left DecodeException
e  -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ DecodeException -> ImpossibleDeserialisationFailure
ImpossibleDeserialisationFailure DecodeException
e
            Right Program TyName Name uni fun ()
p -> forall a. a -> Maybe a
Just Program TyName Name uni fun ()
p
        Maybe ByteString
Nothing -> forall a. Maybe a
Nothing
    DeserializedCode Program NamedDeBruijn uni fun ()
_ Maybe (Program TyName Name uni fun ())
pir CoverageIndex
_ -> Maybe (Program TyName Name uni fun ())
pir

getCovIdx :: CompiledCodeIn uni fun a -> CoverageIndex
getCovIdx :: forall (uni :: * -> *) fun a.
CompiledCodeIn uni fun a -> CoverageIndex
getCovIdx CompiledCodeIn uni fun a
wrapper = case CompiledCodeIn uni fun a
wrapper of
  SerializedCode ByteString
_ Maybe ByteString
_ CoverageIndex
idx   -> CoverageIndex
idx
  DeserializedCode Program NamedDeBruijn uni fun ()
_ Maybe (Program TyName Name uni fun ())
_ CoverageIndex
idx -> CoverageIndex
idx