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

module PlutusLedgerApi.Common.ParamName where

import PlutusCore.Evaluation.Machine.CostModelInterface

import Control.Monad.Except
import Control.Monad.Writer.Strict
import Data.Bifunctor
import Data.Char (toLower)
import Data.List.Extra
import Data.Map as Map
import Data.Text qualified as Text
import GHC.Generics

{-| A valid parameter name has to be enumeration, bounded, ordered, and
prettyprintable in a "lowerKebab" way.

Each API version should expose such an enumeration as an ADT and create
an instance of ParamName out of it.
-}
class IsParamName a where
   showParamName :: a -> String

-- | A Generic wrapper for use with deriving via
newtype GenericParamName a = GenericParamName a

instance (Generic a, GIsParamName (Rep a)) => IsParamName (GenericParamName a) where
   showParamName :: GenericParamName a -> String
showParamName (GenericParamName a
a) = forall (f :: * -> *) p. GIsParamName f => f p -> String
gshowParamName forall a b. (a -> b) -> a -> b
$ 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 -> String

instance (GIsParamName a) => GIsParamName (M1 D i a) where
    gshowParamName :: forall p. M1 D i a p -> String
gshowParamName (M1 a p
x) = forall (f :: * -> *) p. GIsParamName f => f p -> String
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 -> String
gshowParamName = String -> String
lowerKebab forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName
      where
        lowerKebab :: String -> String
        lowerKebab :: String -> String
lowerKebab (Char
h:String
t) = Char -> Char
toLower Char
h forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
maybeKebab String
t
        lowerKebab 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 -> String
gshowParamName (L1 a p
x) = forall (f :: * -> *) p. GIsParamName f => f p -> String
gshowParamName a p
x
    gshowParamName (R1 b p
x) = forall (f :: * -> *) p. GIsParamName f => f p -> String
gshowParamName b p
x

-- | Given an ordered list of parameter values, tag them with their parameter names.
-- 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)
                  => [Integer] -> m [(k, Integer)]
tagWithParamNames :: forall k (m :: * -> *).
(Enum k, Bounded k, MonadError CostModelApplyError m,
 MonadWriter [CostModelApplyWarn] m) =>
[Integer] -> m [(k, Integer)]
tagWithParamNames [Integer]
ledgerParams =
    let paramNames :: [k]
paramNames = forall a. (Enum a, Bounded a) => [a]
enumerate @k
        lenExpected :: Int
lenExpected = forall (t :: * -> *) a. Foldable t => t a -> Int
length [k]
paramNames
        lenActual :: Int
lenActual = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
ledgerParams
    in case Int
lenExpected forall a. Ord a => a -> a -> Ordering
`compare` Int
lenActual of
        Ordering
EQ ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [k]
paramNames [Integer]
ledgerParams
        Ordering
LT -> do
            -- See Note [Cost model parameters from the ledger's point of view]
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
lenActual forall a. Ord a => a -> a -> Bool
> Int
lenExpected) forall a b. (a -> b) -> a -> b
$
                forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [CMTooManyParamsWarn {cmTooManyExpected :: Int
cmTooManyExpected = Int
lenExpected, cmTooManyActual :: Int
cmTooManyActual = Int
lenActual}]
            -- zip will truncate any extraneous params
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [k]
paramNames [Integer]
ledgerParams
        Ordering
GT ->
            -- See Note [Cost model parameters from the ledger's point of view]
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ CMTooFewParamsError {cmTooFewExpected :: Int
cmTooFewExpected = Int
lenExpected, cmTooFewActual :: Int
cmTooFewActual = Int
lenActual }

-- | Essentially untag the association of param names to values
-- so that CostModelInterface can make use of it.
toCostModelParams :: IsParamName k => [(k, Integer)] -> CostModelParams
toCostModelParams :: forall k. IsParamName k => [(k, Integer)] -> CostModelParams
toCostModelParams = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsParamName a => a -> String
showParamName)