-- editorconfig-checker-disable-file
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

module PlutusLedgerApi.Common.ParamName
  ( IsParamName (..)
  , GenericParamName (..)
  , toCostModelParams
  , tagWithParamNames
  , CostModelApplyError (..)
  , CostModelApplyWarn (..)
  ) where

import PlutusCore.Evaluation.Machine.CostModelInterface

import Control.Monad.Except
import Control.Monad.Writer.Strict
import Data.Char (toLower)
import Data.Int (Int64)
import Data.List as List (lookup)
import Data.Map qualified as Map
import Data.Text qualified as Text
import GHC.Generics
import PlutusPrelude

{-| A parameter name for different plutus versions.

Each Plutus version should expose such an enumeration as an ADT and create
an instance of 'ParamName' out of it.

A valid parameter name has to be enumeration, bounded, ordered, and
prettyprintable to a \"lower-Kebab\" string. -}
class (Enum a, Bounded a) => IsParamName a where
  {-| Produce the raw textual form for a given typed-by-plutus-version cost model parameter
  Any implementation *must be* an injective function.
  The 'GIsParamName' generic implementation guarantees injectivity. -}
  showParamName :: a -> Text.Text

  -- | default implementation that inverts the showParamName operation (not very efficient)
  readParamName :: Text.Text -> Maybe a
  readParamName Text
str = Text -> [(Text, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Text
str ([(Text, a)] -> Maybe a) -> [(Text, a)] -> Maybe a
forall a b. (a -> b) -> a -> b
$ (a -> (Text, a)) -> [a] -> [(Text, a)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
p -> (a -> Text
forall a. IsParamName a => a -> Text
showParamName a
p, a
p)) ([a] -> [(Text, a)]) -> [a] -> [(Text, a)]
forall a b. (a -> b) -> a -> b
$ forall a. (Enum a, Bounded a) => [a]
enumerate @a

-- | A Generic wrapper for use with deriving via
newtype GenericParamName a = GenericParamName a
  deriving newtype (Int -> GenericParamName a
GenericParamName a -> Int
GenericParamName a -> [GenericParamName a]
GenericParamName a -> GenericParamName a
GenericParamName a -> GenericParamName a -> [GenericParamName a]
GenericParamName a
-> GenericParamName a -> GenericParamName a -> [GenericParamName a]
(GenericParamName a -> GenericParamName a)
-> (GenericParamName a -> GenericParamName a)
-> (Int -> GenericParamName a)
-> (GenericParamName a -> Int)
-> (GenericParamName a -> [GenericParamName a])
-> (GenericParamName a
    -> GenericParamName a -> [GenericParamName a])
-> (GenericParamName a
    -> GenericParamName a -> [GenericParamName a])
-> (GenericParamName a
    -> GenericParamName a
    -> GenericParamName a
    -> [GenericParamName a])
-> Enum (GenericParamName a)
forall a. Enum a => Int -> GenericParamName a
forall a. Enum a => GenericParamName a -> Int
forall a. Enum a => GenericParamName a -> [GenericParamName a]
forall a. Enum a => GenericParamName a -> GenericParamName a
forall a.
Enum a =>
GenericParamName a -> GenericParamName a -> [GenericParamName a]
forall a.
Enum a =>
GenericParamName a
-> GenericParamName a -> GenericParamName a -> [GenericParamName a]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: forall a. Enum a => GenericParamName a -> GenericParamName a
succ :: GenericParamName a -> GenericParamName a
$cpred :: forall a. Enum a => GenericParamName a -> GenericParamName a
pred :: GenericParamName a -> GenericParamName a
$ctoEnum :: forall a. Enum a => Int -> GenericParamName a
toEnum :: Int -> GenericParamName a
$cfromEnum :: forall a. Enum a => GenericParamName a -> Int
fromEnum :: GenericParamName a -> Int
$cenumFrom :: forall a. Enum a => GenericParamName a -> [GenericParamName a]
enumFrom :: GenericParamName a -> [GenericParamName a]
$cenumFromThen :: forall a.
Enum a =>
GenericParamName a -> GenericParamName a -> [GenericParamName a]
enumFromThen :: GenericParamName a -> GenericParamName a -> [GenericParamName a]
$cenumFromTo :: forall a.
Enum a =>
GenericParamName a -> GenericParamName a -> [GenericParamName a]
enumFromTo :: GenericParamName a -> GenericParamName a -> [GenericParamName a]
$cenumFromThenTo :: forall a.
Enum a =>
GenericParamName a
-> GenericParamName a -> GenericParamName a -> [GenericParamName a]
enumFromThenTo :: GenericParamName a
-> GenericParamName a -> GenericParamName a -> [GenericParamName a]
Enum, GenericParamName a
GenericParamName a
-> GenericParamName a -> Bounded (GenericParamName a)
forall a. a -> a -> Bounded a
forall a. Bounded a => GenericParamName a
$cminBound :: forall a. Bounded a => GenericParamName a
minBound :: GenericParamName a
$cmaxBound :: forall a. Bounded a => GenericParamName a
maxBound :: GenericParamName a
Bounded)

instance (Enum (GenericParamName a), Bounded (GenericParamName a), Generic a, GIsParamName (Rep a)) => IsParamName (GenericParamName a) where
  showParamName :: GenericParamName a -> Text
showParamName (GenericParamName a
a) = Rep a Any -> Text
forall p. Rep a p -> Text
forall (f :: * -> *) p. GIsParamName f => f p -> Text
gshowParamName (Rep a Any -> Text) -> Rep a Any -> Text
forall a b. (a -> b) -> a -> b
$ a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
a

-- | A datatype-generic class to prettyprint 'sums of nullary constructors' in lower-kebab syntax.
class GIsParamName f where
  gshowParamName :: f p -> Text.Text

instance GIsParamName a => GIsParamName (M1 D i a) where
  gshowParamName :: forall p. M1 D i a p -> Text
gshowParamName (M1 a p
x) = a p -> Text
forall p. a p -> Text
forall (f :: * -> *) p. GIsParamName f => f p -> Text
gshowParamName a p
x

{- Note [Quotation marks in cost model parameter constructors]
We use the quotation mark <'> inside each nullary constructor of
a cost parameter name as a delimiter of sections when lowerKebab-prettyprinting.
The character <_> cannot be used as a delimiter because it may be part of the builtin's name (sha2_256,etc).
-}

instance Constructor i => GIsParamName (M1 C i U1) where
  gshowParamName :: forall p. M1 C i U1 p -> Text
gshowParamName = String -> Text
Text.pack (String -> Text) -> (M1 C i U1 p -> String) -> M1 C i U1 p -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
lowerKebab (String -> String)
-> (M1 C i U1 p -> String) -> M1 C i U1 p -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 C i U1 p -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t i f a -> String
conName
    where
      lowerKebab :: String -> String
      lowerKebab :: String -> String
lowerKebab (Char
h : String
t) = Char -> Char
toLower Char
h Char -> String -> String
forall a. a -> [a] -> [a]
: (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
maybeKebab String
t
      lowerKebab String
_ = String -> String
forall a. HasCallStack => String -> a
error String
"this should not happen because constructors cannot have empty names"

      maybeKebab :: Char -> Char
maybeKebab Char
'\'' = Char
'-'
      maybeKebab Char
c = Char
c

instance (GIsParamName a, GIsParamName b) => GIsParamName ((:+:) a b) where
  gshowParamName :: forall p. (:+:) a b p -> Text
gshowParamName (L1 a p
x) = a p -> Text
forall p. a p -> Text
forall (f :: * -> *) p. GIsParamName f => f p -> Text
gshowParamName a p
x
  gshowParamName (R1 b p
x) = b p -> Text
forall p. b p -> Text
forall (f :: * -> *) p. GIsParamName f => f p -> Text
gshowParamName b p
x

{-| Given an ordered list of parameter values, tag them with their parameter
names.  If the passed parameter values are more than expected: the function
will ignore the extraneous values at the tail of the list, if the passed
values are less than expected: the function will throw an error; for more
information, see Note [Cost model parameters from the ledger's point of view] -}
tagWithParamNames
  :: forall k m
   . ( Enum k
     , Bounded k
     , MonadError CostModelApplyError m
     , -- OPTIMIZE: MonadWriter.CPS is probably better than MonadWriter.Strict but needs mtl>=2.3
       -- OPTIMIZE: using List [] as the log datatype is worse than others (DList/Endo) but does not matter much here
       MonadWriter [CostModelApplyWarn] m
     )
  => [Int64] -> m [(k, Int64)]
tagWithParamNames :: forall k (m :: * -> *).
(Enum k, Bounded k, MonadError CostModelApplyError m,
 MonadWriter [CostModelApplyWarn] m) =>
[Int64] -> m [(k, Int64)]
tagWithParamNames [Int64]
ledgerParams =
  let paramNames :: [k]
paramNames = forall a. (Enum a, Bounded a) => [a]
enumerate @k
      lenExpected :: Int
lenExpected = [k] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [k]
paramNames
      lenActual :: Int
lenActual = [Int64] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int64]
ledgerParams
   in case Int
lenExpected Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int
lenActual of
        Ordering
EQ ->
          [(k, Int64)] -> m [(k, Int64)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(k, Int64)] -> m [(k, Int64)]) -> [(k, Int64)] -> m [(k, Int64)]
forall a b. (a -> b) -> a -> b
$ [k] -> [Int64] -> [(k, Int64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k]
paramNames [Int64]
ledgerParams
        Ordering
LT -> do
          -- See Note [Cost model parameters from the ledger's point of view]
          [CostModelApplyWarn] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [CMTooManyParamsWarn {cmExpected :: Int
cmExpected = Int
lenExpected, cmActual :: Int
cmActual = Int
lenActual}]
          -- zip will truncate/ignore any extraneous parameter values
          [(k, Int64)] -> m [(k, Int64)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(k, Int64)] -> m [(k, Int64)]) -> [(k, Int64)] -> m [(k, Int64)]
forall a b. (a -> b) -> a -> b
$ [k] -> [Int64] -> [(k, Int64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k]
paramNames [Int64]
ledgerParams
        Ordering
GT -> do
          -- Too few parameters - substitute a large number for the missing parameters
          -- See Note [Cost model parameters from the ledger's point of view]
          [CostModelApplyWarn] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [CMTooFewParamsWarn {cmExpected :: Int
cmExpected = Int
lenExpected, cmActual :: Int
cmActual = Int
lenActual}]
          [(k, Int64)] -> m [(k, Int64)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(k, Int64)] -> m [(k, Int64)]) -> [(k, Int64)] -> m [(k, Int64)]
forall a b. (a -> b) -> a -> b
$ [k] -> [Int64] -> [(k, Int64)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k]
paramNames ([Int64]
ledgerParams [Int64] -> [Int64] -> [Int64]
forall a. [a] -> [a] -> [a]
++ Int64 -> [Int64]
forall a. a -> [a]
repeat Int64
forall a. Bounded a => a
maxBound)

{-| Untags the plutus version from the typed cost model parameters and returns their raw textual form
(internally used by CostModelInterface). -}
toCostModelParams :: IsParamName p => [(p, Int64)] -> CostModelParams
toCostModelParams :: forall p. IsParamName p => [(p, Int64)] -> CostModelParams
toCostModelParams = [(Text, Int64)] -> CostModelParams
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Int64)] -> CostModelParams)
-> ([(p, Int64)] -> [(Text, Int64)])
-> [(p, Int64)]
-> CostModelParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((p, Int64) -> (Text, Int64)) -> [(p, Int64)] -> [(Text, Int64)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((p -> Text) -> (p, Int64) -> (Text, Int64)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first p -> Text
forall a. IsParamName a => a -> Text
showParamName)