{-# LANGUAGE ConstraintKinds   #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE TypeOperators     #-}

module PlutusCore.Builtin.HasConstant
    ( BuiltinError (..)
    , throwNotAConstant
    , HasConstant (..)
    , HasConstantIn
    , fromValueOf
    , fromValue
    ) where

import PlutusCore.Builtin.Result
import PlutusCore.Core
import PlutusCore.Name.Unique

import Universe

{- Note [Existence of HasConstant]
We don't really need 'HasConstant' and could get away with only having 'HasConstantIn', however
defining the latter directly as a @class@ instead of a type synonym in terms of the former is
detrimental to performance, see the comments in https://github.com/IntersectMBO/plutus/pull/4417

This is likely due to the same reason as in 'mkMachineParameters',
see Note [The CostingPart constraint in mkMachineParameters].
-}

-- See Note [Existence of HasConstant].
-- We name it @term@ rather than @val@, because various @Term@ (UPLC/TPLC/PIR) data types have
-- 'Constant'-like constructors too and we lift to / unlift from those in tests.
-- | Ensures that @term@ has a 'Constant'-like constructor to lift values to and unlift values from.
class HasConstant term where
    -- Switching from 'MonadError' to 'Either' here gave us a speedup of 2-4%.
    -- | Unwrap from a 'Constant'-like constructor throwing an 'UnliftingError' if the provided
    -- @term@ is not a wrapped Haskell value.
    asConstant :: term -> Either BuiltinError (Some (ValueOf (UniOf term)))

    -- | Wrap a Haskell value as a @term@.
    fromConstant :: Some (ValueOf (UniOf term)) -> term

-- | Ensures that @term@ has a 'Constant'-like constructor to lift values to and unlift values from
-- and connects @term@ and its @uni@.
type HasConstantIn uni term = (UniOf term ~ uni, HasConstant term)

-- | Wrap a Haskell value (given its explicit type tag) as a @term@.
fromValueOf :: forall a term. HasConstant term => UniOf term (Esc a) -> a -> term
fromValueOf :: forall a term. HasConstant term => UniOf term (Esc a) -> a -> term
fromValueOf UniOf term (Esc a)
uni = Some (ValueOf (UniOf term)) -> term
forall term.
HasConstant term =>
Some (ValueOf (UniOf term)) -> term
fromConstant (Some (ValueOf (UniOf term)) -> term)
-> (a -> Some (ValueOf (UniOf term))) -> a -> term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniOf term (Esc a) -> a -> Some (ValueOf (UniOf term))
forall a (uni :: * -> *). uni (Esc a) -> a -> Some (ValueOf uni)
someValueOf UniOf term (Esc a)
uni
{-# INLINE fromValueOf #-}

-- | Wrap a Haskell value (provided its type is in the universe) as a @term@.
fromValue :: forall a term. (HasConstant term, UniOf term `HasTermLevel` a) => a -> term
fromValue :: forall a term.
(HasConstant term, HasTermLevel (UniOf term) a) =>
a -> term
fromValue = UniOf term (Esc a) -> a -> term
forall a term. HasConstant term => UniOf term (Esc a) -> a -> term
fromValueOf UniOf term (Esc a)
forall k (uni :: * -> *) (a :: k). Contains uni a => uni (Esc a)
knownUni
{-# INLINE fromValue #-}

instance HasConstant (Term TyName Name uni fun ()) where
    asConstant :: Term TyName Name uni fun ()
-> Either
     BuiltinError (Some (ValueOf (UniOf (Term TyName Name uni fun ()))))
asConstant (Constant ()
_ Some (ValueOf uni)
val) = Some (ValueOf uni) -> Either BuiltinError (Some (ValueOf uni))
forall a. a -> Either BuiltinError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Some (ValueOf uni)
val
    asConstant Term TyName Name uni fun ()
_                = Either BuiltinError (Some (ValueOf uni))
Either
  BuiltinError (Some (ValueOf (UniOf (Term TyName Name uni fun ()))))
forall (m :: * -> *) void. MonadError BuiltinError m => m void
throwNotAConstant

    fromConstant :: Some (ValueOf (UniOf (Term TyName Name uni fun ())))
-> Term TyName Name uni fun ()
fromConstant = () -> Some (ValueOf uni) -> Term TyName Name uni fun ()
forall tyname name (uni :: * -> *) fun ann.
ann -> Some (ValueOf uni) -> Term tyname name uni fun ann
Constant ()