{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module UntypedPlutusCore.Analysis.Builtins
  ( BuiltinsInfo (..)
  , biSemanticsVariant
  , biUnserializableConstants
  , builtinArityInfo
  , constantIsSerializable
  , termIsSerializable
  , defaultUniUnserializableConstants
  ) where

import Control.Lens hiding (parts)
import Data.Kind
import Data.Proxy
import PlutusCore.Arity
import PlutusCore.Builtin
import PlutusCore.Builtin qualified as PLC
import PlutusCore.Default
import PlutusPrelude (Default (..))
import UntypedPlutusCore.Core (Term)
import UntypedPlutusCore.Core.Plated (termSubtermsDeep, _Constant)

-- | All non-static information about builtins that the compiler might want.
data BuiltinsInfo (uni :: Type -> Type) fun = BuiltinsInfo
  { forall (uni :: * -> *) fun.
BuiltinsInfo uni fun -> BuiltinSemanticsVariant fun
_biSemanticsVariant :: PLC.BuiltinSemanticsVariant fun
  , -- See Note [Unserializable constants]
    forall (uni :: * -> *) fun.
BuiltinsInfo uni fun -> Some (ValueOf uni) -> Bool
_biUnserializableConstants :: Some (ValueOf uni) -> Bool
  }

makeLenses ''BuiltinsInfo

instance Default (BuiltinsInfo DefaultUni DefaultFun) where
  def :: BuiltinsInfo DefaultUni DefaultFun
def =
    BuiltinsInfo
      { _biSemanticsVariant :: BuiltinSemanticsVariant DefaultFun
_biSemanticsVariant = BuiltinSemanticsVariant DefaultFun
forall a. Default a => a
def
      , _biUnserializableConstants :: Some (ValueOf DefaultUni) -> Bool
_biUnserializableConstants = Some (ValueOf DefaultUni) -> Bool
defaultUniUnserializableConstants
      }

-- | Get the arity of a builtin function from the 'PLC.BuiltinInfo'.
builtinArityInfo
  :: forall uni fun
   . ToBuiltinMeaning uni fun
  => BuiltinsInfo uni fun
  -> fun
  -> Arity
builtinArityInfo :: forall (uni :: * -> *) fun.
ToBuiltinMeaning uni fun =>
BuiltinsInfo uni fun -> fun -> Arity
builtinArityInfo BuiltinsInfo uni fun
binfo = Proxy uni -> BuiltinSemanticsVariant fun -> fun -> Arity
forall (uni :: * -> *) fun.
ToBuiltinMeaning uni fun =>
Proxy uni -> BuiltinSemanticsVariant fun -> fun -> Arity
builtinArity (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @uni) (BuiltinsInfo uni fun
binfo BuiltinsInfo uni fun
-> Getting
     (BuiltinSemanticsVariant fun)
     (BuiltinsInfo uni fun)
     (BuiltinSemanticsVariant fun)
-> BuiltinSemanticsVariant fun
forall s a. s -> Getting a s a -> a
^. Getting
  (BuiltinSemanticsVariant fun)
  (BuiltinsInfo uni fun)
  (BuiltinSemanticsVariant fun)
forall (uni :: * -> *) fun fun (f :: * -> *).
Functor f =>
(BuiltinSemanticsVariant fun -> f (BuiltinSemanticsVariant fun))
-> BuiltinsInfo uni fun -> f (BuiltinsInfo uni fun)
biSemanticsVariant)

constantIsSerializable
  :: forall uni fun
   . BuiltinsInfo uni fun
  -> Some (ValueOf uni)
  -> Bool
constantIsSerializable :: forall (uni :: * -> *) fun.
BuiltinsInfo uni fun -> Some (ValueOf uni) -> Bool
constantIsSerializable BuiltinsInfo uni fun
bi Some (ValueOf uni)
v = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ BuiltinsInfo uni fun -> Some (ValueOf uni) -> Bool
forall (uni :: * -> *) fun.
BuiltinsInfo uni fun -> Some (ValueOf uni) -> Bool
_biUnserializableConstants BuiltinsInfo uni fun
bi Some (ValueOf uni)
v

termIsSerializable :: BuiltinsInfo uni fun -> Term name uni fun a -> Bool
termIsSerializable :: forall (uni :: * -> *) fun name a.
BuiltinsInfo uni fun -> Term name uni fun a -> Bool
termIsSerializable BuiltinsInfo uni fun
binfo =
  Getting All (Term name uni fun a) (a, Some (ValueOf uni))
-> ((a, Some (ValueOf uni)) -> Bool) -> Term name uni fun a -> Bool
forall s a. Getting All s a -> (a -> Bool) -> s -> Bool
allOf
    ((Term name uni fun a -> Const All (Term name uni fun a))
-> Term name uni fun a -> Const All (Term name uni fun a)
forall name (uni :: * -> *) fun ann (f :: * -> *).
(Contravariant f, Applicative f) =>
(Term name uni fun ann -> f (Term name uni fun ann))
-> Term name uni fun ann -> f (Term name uni fun ann)
termSubtermsDeep ((Term name uni fun a -> Const All (Term name uni fun a))
 -> Term name uni fun a -> Const All (Term name uni fun a))
-> Getting All (Term name uni fun a) (a, Some (ValueOf uni))
-> Getting All (Term name uni fun a) (a, Some (ValueOf uni))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting All (Term name uni fun a) (a, Some (ValueOf uni))
forall name (uni :: * -> *) fun a (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p (a, Some (ValueOf uni)) (f (a, Some (ValueOf uni)))
-> p (Term name uni fun a) (f (Term name uni fun a))
_Constant)
    (BuiltinsInfo uni fun -> Some (ValueOf uni) -> Bool
forall (uni :: * -> *) fun.
BuiltinsInfo uni fun -> Some (ValueOf uni) -> Bool
constantIsSerializable BuiltinsInfo uni fun
binfo (Some (ValueOf uni) -> Bool)
-> ((a, Some (ValueOf uni)) -> Some (ValueOf uni))
-> (a, Some (ValueOf uni))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Some (ValueOf uni)) -> Some (ValueOf uni)
forall a b. (a, b) -> b
snd)

-- See Note [Unserializable constants]
defaultUniUnserializableConstants :: Some (ValueOf DefaultUni) -> Bool
defaultUniUnserializableConstants :: Some (ValueOf DefaultUni) -> Bool
defaultUniUnserializableConstants = \case
  Some (ValueOf DefaultUni (Esc a)
DefaultUniBLS12_381_G1_Element a
_) -> Bool
True
  Some (ValueOf DefaultUni (Esc a)
DefaultUniBLS12_381_G2_Element a
_) -> Bool
True
  Some (ValueOf DefaultUni (Esc a)
DefaultUniBLS12_381_MlResult a
_) -> Bool
True
  Some (ValueOf DefaultUni)
_ -> Bool
False

{- See Note [Unserializable constants] in PlutusIR.Analysis.Builtins.
-}