{-# 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
class (Enum a, Bounded a) => IsParamName a where
showParamName :: a -> Text.Text
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
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
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
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
tagWithParamNames :: forall k m. (Enum k, Bounded k,
MonadError CostModelApplyError m,
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
[CostModelApplyWarn] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [CMTooManyParamsWarn {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
Ordering
GT -> do
[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)
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)