-- 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)