{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module PlutusCore.Evaluation.Machine.CostModelInterface
( CostModelParams
, CekMachineCosts
, extractCostModelParams
, applyCostModelParams
, CostModelApplyError (..)
, CostModelApplyWarn (..)
)
where
import PlutusCore.Evaluation.Machine.MachineParameters (CostModel (..))
import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts (CekMachineCosts,
cekMachineCostsPrefix)
import Control.DeepSeq (NFData)
import Control.Exception
import Control.Monad.Except
import Data.Aeson
import Data.Aeson.Flatten
import Data.Data (Data)
import Data.HashMap.Strict qualified as HM
import Data.Int (Int64)
import Data.Map qualified as Map
import Data.Map.Merge.Lazy qualified as Map
import Data.Text qualified as Text
import GHC.Generics (Generic)
import NoThunks.Class
import Prettyprinter
type CostModelParams = Map.Map Text.Text Int64
extractParams :: ToJSON a => a -> Maybe CostModelParams
a
cm = case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
cm of
Object Object
o ->
let
flattened :: HashMap Text Value
flattened = Object -> HashMap Text Value
objToHm (Object -> HashMap Text Value) -> Object -> HashMap Text Value
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Object
flattenObject Text
"-" Object
o
usingCostingIntegers :: HashMap Text Int64
usingCostingIntegers = (Value -> Maybe Int64) -> HashMap Text Value -> HashMap Text Int64
forall v1 v2 k. (v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2
HM.mapMaybe (\case { Number Scientific
n -> Int64 -> Maybe Int64
forall a. a -> Maybe a
Just (Int64 -> Maybe Int64) -> Int64 -> Maybe Int64
forall a b. (a -> b) -> a -> b
$ Scientific -> Int64
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Scientific
n; Value
_ -> Maybe Int64
forall a. Maybe a
Nothing }) HashMap Text Value
flattened
mapified :: CostModelParams
mapified = [(Text, Int64)] -> CostModelParams
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Int64)] -> CostModelParams)
-> [(Text, Int64)] -> CostModelParams
forall a b. (a -> b) -> a -> b
$ HashMap Text Int64 -> [(Text, Int64)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Text Int64
usingCostingIntegers
in CostModelParams -> Maybe CostModelParams
forall a. a -> Maybe a
Just CostModelParams
mapified
Value
_ -> Maybe CostModelParams
forall a. Maybe a
Nothing
data CostModelApplyError =
CMUnknownParamError !Text.Text
| CMInternalReadError
| CMInternalWriteError !String
deriving stock (CostModelApplyError -> CostModelApplyError -> Bool
(CostModelApplyError -> CostModelApplyError -> Bool)
-> (CostModelApplyError -> CostModelApplyError -> Bool)
-> Eq CostModelApplyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CostModelApplyError -> CostModelApplyError -> Bool
== :: CostModelApplyError -> CostModelApplyError -> Bool
$c/= :: CostModelApplyError -> CostModelApplyError -> Bool
/= :: CostModelApplyError -> CostModelApplyError -> Bool
Eq, Int -> CostModelApplyError -> ShowS
[CostModelApplyError] -> ShowS
CostModelApplyError -> String
(Int -> CostModelApplyError -> ShowS)
-> (CostModelApplyError -> String)
-> ([CostModelApplyError] -> ShowS)
-> Show CostModelApplyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CostModelApplyError -> ShowS
showsPrec :: Int -> CostModelApplyError -> ShowS
$cshow :: CostModelApplyError -> String
show :: CostModelApplyError -> String
$cshowList :: [CostModelApplyError] -> ShowS
showList :: [CostModelApplyError] -> ShowS
Show, (forall x. CostModelApplyError -> Rep CostModelApplyError x)
-> (forall x. Rep CostModelApplyError x -> CostModelApplyError)
-> Generic CostModelApplyError
forall x. Rep CostModelApplyError x -> CostModelApplyError
forall x. CostModelApplyError -> Rep CostModelApplyError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CostModelApplyError -> Rep CostModelApplyError x
from :: forall x. CostModelApplyError -> Rep CostModelApplyError x
$cto :: forall x. Rep CostModelApplyError x -> CostModelApplyError
to :: forall x. Rep CostModelApplyError x -> CostModelApplyError
Generic, Typeable CostModelApplyError
Typeable CostModelApplyError =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> CostModelApplyError
-> c CostModelApplyError)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CostModelApplyError)
-> (CostModelApplyError -> Constr)
-> (CostModelApplyError -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CostModelApplyError))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CostModelApplyError))
-> ((forall b. Data b => b -> b)
-> CostModelApplyError -> CostModelApplyError)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CostModelApplyError -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CostModelApplyError -> r)
-> (forall u.
(forall d. Data d => d -> u) -> CostModelApplyError -> [u])
-> (forall u.
Int -> (forall d. Data d => d -> u) -> CostModelApplyError -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> CostModelApplyError -> m CostModelApplyError)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> CostModelApplyError -> m CostModelApplyError)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> CostModelApplyError -> m CostModelApplyError)
-> Data CostModelApplyError
CostModelApplyError -> Constr
CostModelApplyError -> DataType
(forall b. Data b => b -> b)
-> CostModelApplyError -> CostModelApplyError
forall a.
Typeable a =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u.
Int -> (forall d. Data d => d -> u) -> CostModelApplyError -> u
forall u.
(forall d. Data d => d -> u) -> CostModelApplyError -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CostModelApplyError -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CostModelApplyError -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> CostModelApplyError -> m CostModelApplyError
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> CostModelApplyError -> m CostModelApplyError
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CostModelApplyError
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> CostModelApplyError
-> c CostModelApplyError
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CostModelApplyError)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CostModelApplyError)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> CostModelApplyError
-> c CostModelApplyError
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g)
-> CostModelApplyError
-> c CostModelApplyError
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CostModelApplyError
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CostModelApplyError
$ctoConstr :: CostModelApplyError -> Constr
toConstr :: CostModelApplyError -> Constr
$cdataTypeOf :: CostModelApplyError -> DataType
dataTypeOf :: CostModelApplyError -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CostModelApplyError)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CostModelApplyError)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CostModelApplyError)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CostModelApplyError)
$cgmapT :: (forall b. Data b => b -> b)
-> CostModelApplyError -> CostModelApplyError
gmapT :: (forall b. Data b => b -> b)
-> CostModelApplyError -> CostModelApplyError
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CostModelApplyError -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CostModelApplyError -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CostModelApplyError -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CostModelApplyError -> r
$cgmapQ :: forall u.
(forall d. Data d => d -> u) -> CostModelApplyError -> [u]
gmapQ :: forall u.
(forall d. Data d => d -> u) -> CostModelApplyError -> [u]
$cgmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> CostModelApplyError -> u
gmapQi :: forall u.
Int -> (forall d. Data d => d -> u) -> CostModelApplyError -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> CostModelApplyError -> m CostModelApplyError
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d)
-> CostModelApplyError -> m CostModelApplyError
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> CostModelApplyError -> m CostModelApplyError
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> CostModelApplyError -> m CostModelApplyError
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> CostModelApplyError -> m CostModelApplyError
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d)
-> CostModelApplyError -> m CostModelApplyError
Data)
deriving anyclass (Show CostModelApplyError
Typeable CostModelApplyError
(Typeable CostModelApplyError, Show CostModelApplyError) =>
(CostModelApplyError -> SomeException)
-> (SomeException -> Maybe CostModelApplyError)
-> (CostModelApplyError -> String)
-> Exception CostModelApplyError
SomeException -> Maybe CostModelApplyError
CostModelApplyError -> String
CostModelApplyError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: CostModelApplyError -> SomeException
toException :: CostModelApplyError -> SomeException
$cfromException :: SomeException -> Maybe CostModelApplyError
fromException :: SomeException -> Maybe CostModelApplyError
$cdisplayException :: CostModelApplyError -> String
displayException :: CostModelApplyError -> String
Exception, CostModelApplyError -> ()
(CostModelApplyError -> ()) -> NFData CostModelApplyError
forall a. (a -> ()) -> NFData a
$crnf :: CostModelApplyError -> ()
rnf :: CostModelApplyError -> ()
NFData, Context -> CostModelApplyError -> IO (Maybe ThunkInfo)
Proxy CostModelApplyError -> String
(Context -> CostModelApplyError -> IO (Maybe ThunkInfo))
-> (Context -> CostModelApplyError -> IO (Maybe ThunkInfo))
-> (Proxy CostModelApplyError -> String)
-> NoThunks CostModelApplyError
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> CostModelApplyError -> IO (Maybe ThunkInfo)
noThunks :: Context -> CostModelApplyError -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> CostModelApplyError -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> CostModelApplyError -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy CostModelApplyError -> String
showTypeOf :: Proxy CostModelApplyError -> String
NoThunks)
data CostModelApplyWarn =
CMTooManyParamsWarn { CostModelApplyWarn -> Int
cmExpected :: !Int, CostModelApplyWarn -> Int
cmActual :: !Int }
| CMTooFewParamsWarn { cmExpected :: !Int, cmActual :: !Int }
instance Pretty CostModelApplyError where
pretty :: forall ann. CostModelApplyError -> Doc ann
pretty = (Doc ann
preamble Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann)
-> (CostModelApplyError -> Doc ann)
-> CostModelApplyError
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
CMUnknownParamError Text
k -> Doc ann
"No such parameter in target cost model:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
k
CostModelApplyError
CMInternalReadError -> Doc ann
"Internal problem occurred upon reading the given cost model parameters"
CMInternalWriteError String
str -> Doc ann
"Internal problem occurred upon generating the applied cost model parameters with JSON error:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
str
where
preamble :: Doc ann
preamble = Doc ann
"applyParams error:"
instance Pretty CostModelApplyWarn where
pretty :: forall ann. CostModelApplyWarn -> Doc ann
pretty = (Doc ann
preamble Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+>) (Doc ann -> Doc ann)
-> (CostModelApplyWarn -> Doc ann) -> CostModelApplyWarn -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
CMTooManyParamsWarn{Int
cmExpected :: CostModelApplyWarn -> Int
cmActual :: CostModelApplyWarn -> Int
cmExpected :: Int
cmActual :: Int
..} -> Doc ann
"Too many cost model parameters passed, expected" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
cmExpected Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"but got" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
cmActual
CMTooFewParamsWarn{Int
cmExpected :: CostModelApplyWarn -> Int
cmActual :: CostModelApplyWarn -> Int
cmExpected :: Int
cmActual :: Int
..} -> Doc ann
"Too few cost model parameters passed, expected" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
cmExpected Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"but got" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
cmActual
where
preamble :: Doc ann
preamble = Doc ann
"applyParams warn:"
applyParams :: (FromJSON a, ToJSON a, MonadError CostModelApplyError m)
=> a
-> CostModelParams
-> m a
applyParams :: forall a (m :: * -> *).
(FromJSON a, ToJSON a, MonadError CostModelApplyError m) =>
a -> CostModelParams -> m a
applyParams a
cm CostModelParams
params = case a -> Value
forall a. ToJSON a => a -> Value
toJSON a
cm of
Object Object
o ->
let
usingScientific :: Map Text Value
usingScientific = (Int64 -> Value) -> CostModelParams -> Map Text Value
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Scientific -> Value
Number (Scientific -> Value) -> (Int64 -> Scientific) -> Int64 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral) CostModelParams
params
flattened :: Map Text Value
flattened = HashMap Text Value -> Map Text Value
forall {a}. HashMap Text a -> Map Text a
fromHash (HashMap Text Value -> Map Text Value)
-> HashMap Text Value -> Map Text Value
forall a b. (a -> b) -> a -> b
$ Object -> HashMap Text Value
objToHm (Object -> HashMap Text Value) -> Object -> HashMap Text Value
forall a b. (a -> b) -> a -> b
$ Text -> Object -> Object
flattenObject Text
"-" Object
o
in do
Map Text Value
merged <- WhenMissing m Text Value Value
-> WhenMissing m Text Value Value
-> WhenMatched m Text Value Value Value
-> Map Text Value
-> Map Text Value
-> m (Map Text Value)
forall (f :: * -> *) k a c b.
(Applicative f, Ord k) =>
WhenMissing f k a c
-> WhenMissing f k b c
-> WhenMatched f k a b c
-> Map k a
-> Map k b
-> f (Map k c)
Map.mergeA WhenMissing m Text Value Value
forall {x} {y}. WhenMissing m Text x y
failMissing WhenMissing m Text Value Value
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
Map.preserveMissing ((Text -> Value -> Value -> Value)
-> WhenMatched m Text Value Value Value
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched Text -> Value -> Value -> Value
forall {p} {p} {p}. p -> p -> p -> p
leftBiased) Map Text Value
usingScientific Map Text Value
flattened
let unflattened :: Object
unflattened = Text -> Object -> Object
unflattenObject Text
"-" (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ HashMap Text Value -> Object
hmToObj (HashMap Text Value -> Object) -> HashMap Text Value -> Object
forall a b. (a -> b) -> a -> b
$ Map Text Value -> HashMap Text Value
forall {v}. Map Text v -> HashMap Text v
toHash Map Text Value
merged
case Value -> Result a
forall a. FromJSON a => Value -> Result a
fromJSON (Object -> Value
Object Object
unflattened) of
Success a
a -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
Error String
str -> CostModelApplyError -> m a
forall a. CostModelApplyError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CostModelApplyError -> m a) -> CostModelApplyError -> m a
forall a b. (a -> b) -> a -> b
$ String -> CostModelApplyError
CMInternalWriteError String
str
Value
_ -> CostModelApplyError -> m a
forall a. CostModelApplyError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError CostModelApplyError
CMInternalReadError
where
toHash :: Map Text v -> HashMap Text v
toHash = [(Text, v)] -> HashMap Text v
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, v)] -> HashMap Text v)
-> (Map Text v -> [(Text, v)]) -> Map Text v -> HashMap Text v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text v -> [(Text, v)]
forall k a. Map k a -> [(k, a)]
Map.toList
fromHash :: HashMap Text a -> Map Text a
fromHash = [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, a)] -> Map Text a)
-> (HashMap Text a -> [(Text, a)]) -> HashMap Text a -> Map Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text a -> [(Text, a)]
forall k v. HashMap k v -> [(k, v)]
HM.toList
failMissing :: WhenMissing m Text x y
failMissing = (Text -> x -> m y) -> WhenMissing m Text x y
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f y) -> WhenMissing f k x y
Map.traverseMissing ((Text -> x -> m y) -> WhenMissing m Text x y)
-> (Text -> x -> m y) -> WhenMissing m Text x y
forall a b. (a -> b) -> a -> b
$ \ Text
k x
_v -> CostModelApplyError -> m y
forall a. CostModelApplyError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CostModelApplyError -> m y) -> CostModelApplyError -> m y
forall a b. (a -> b) -> a -> b
$ Text -> CostModelApplyError
CMUnknownParamError Text
k
leftBiased :: p -> p -> p -> p
leftBiased p
_k p
l p
_r = p
l
data SplitCostModelParams =
SplitCostModelParams {
SplitCostModelParams -> CostModelParams
_machineParams :: CostModelParams
, SplitCostModelParams -> CostModelParams
_builtinParams :: CostModelParams
}
splitParams :: Text.Text -> CostModelParams -> SplitCostModelParams
splitParams :: Text -> CostModelParams -> SplitCostModelParams
splitParams Text
prefix CostModelParams
params =
let (CostModelParams
machineparams, CostModelParams
builtinparams) = (Text -> Int64 -> Bool)
-> CostModelParams -> (CostModelParams, CostModelParams)
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey (\Text
k Int64
_ -> Text -> Text -> Bool
Text.isPrefixOf Text
prefix Text
k) CostModelParams
params
in CostModelParams -> CostModelParams -> SplitCostModelParams
SplitCostModelParams CostModelParams
machineparams CostModelParams
builtinparams
extractCostModelParams
:: (ToJSON machinecosts, ToJSON builtincosts)
=> CostModel machinecosts builtincosts -> Maybe CostModelParams
CostModel machinecosts builtincosts
model =
CostModelParams -> CostModelParams -> CostModelParams
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (CostModelParams -> CostModelParams -> CostModelParams)
-> Maybe CostModelParams
-> Maybe (CostModelParams -> CostModelParams)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> machinecosts -> Maybe CostModelParams
forall a. ToJSON a => a -> Maybe CostModelParams
extractParams (CostModel machinecosts builtincosts -> machinecosts
forall machinecosts builtincosts.
CostModel machinecosts builtincosts -> machinecosts
_machineCostModel CostModel machinecosts builtincosts
model) Maybe (CostModelParams -> CostModelParams)
-> Maybe CostModelParams -> Maybe CostModelParams
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> builtincosts -> Maybe CostModelParams
forall a. ToJSON a => a -> Maybe CostModelParams
extractParams (CostModel machinecosts builtincosts -> builtincosts
forall machinecosts builtincosts.
CostModel machinecosts builtincosts -> builtincosts
_builtinCostModel CostModel machinecosts builtincosts
model)
applySplitCostModelParams
:: (FromJSON evaluatorcosts, FromJSON builtincosts, ToJSON evaluatorcosts, ToJSON builtincosts, MonadError CostModelApplyError m)
=> Text.Text
-> CostModel evaluatorcosts builtincosts
-> CostModelParams
-> m (CostModel evaluatorcosts builtincosts)
applySplitCostModelParams :: forall evaluatorcosts builtincosts (m :: * -> *).
(FromJSON evaluatorcosts, FromJSON builtincosts,
ToJSON evaluatorcosts, ToJSON builtincosts,
MonadError CostModelApplyError m) =>
Text
-> CostModel evaluatorcosts builtincosts
-> CostModelParams
-> m (CostModel evaluatorcosts builtincosts)
applySplitCostModelParams Text
prefix CostModel evaluatorcosts builtincosts
model CostModelParams
params =
let SplitCostModelParams CostModelParams
machineparams CostModelParams
builtinparams = Text -> CostModelParams -> SplitCostModelParams
splitParams Text
prefix CostModelParams
params
in evaluatorcosts
-> builtincosts -> CostModel evaluatorcosts builtincosts
forall machinecosts builtincosts.
machinecosts -> builtincosts -> CostModel machinecosts builtincosts
CostModel (evaluatorcosts
-> builtincosts -> CostModel evaluatorcosts builtincosts)
-> m evaluatorcosts
-> m (builtincosts -> CostModel evaluatorcosts builtincosts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> evaluatorcosts -> CostModelParams -> m evaluatorcosts
forall a (m :: * -> *).
(FromJSON a, ToJSON a, MonadError CostModelApplyError m) =>
a -> CostModelParams -> m a
applyParams (CostModel evaluatorcosts builtincosts -> evaluatorcosts
forall machinecosts builtincosts.
CostModel machinecosts builtincosts -> machinecosts
_machineCostModel CostModel evaluatorcosts builtincosts
model) CostModelParams
machineparams
m (builtincosts -> CostModel evaluatorcosts builtincosts)
-> m builtincosts -> m (CostModel evaluatorcosts builtincosts)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> builtincosts -> CostModelParams -> m builtincosts
forall a (m :: * -> *).
(FromJSON a, ToJSON a, MonadError CostModelApplyError m) =>
a -> CostModelParams -> m a
applyParams (CostModel evaluatorcosts builtincosts -> builtincosts
forall machinecosts builtincosts.
CostModel machinecosts builtincosts -> builtincosts
_builtinCostModel CostModel evaluatorcosts builtincosts
model) CostModelParams
builtinparams
applyCostModelParams
:: (FromJSON evaluatorcosts, FromJSON builtincosts, ToJSON evaluatorcosts, ToJSON builtincosts, MonadError CostModelApplyError m)
=> CostModel evaluatorcosts builtincosts
-> CostModelParams
-> m (CostModel evaluatorcosts builtincosts)
applyCostModelParams :: forall evaluatorcosts builtincosts (m :: * -> *).
(FromJSON evaluatorcosts, FromJSON builtincosts,
ToJSON evaluatorcosts, ToJSON builtincosts,
MonadError CostModelApplyError m) =>
CostModel evaluatorcosts builtincosts
-> CostModelParams -> m (CostModel evaluatorcosts builtincosts)
applyCostModelParams = Text
-> CostModel evaluatorcosts builtincosts
-> CostModelParams
-> m (CostModel evaluatorcosts builtincosts)
forall evaluatorcosts builtincosts (m :: * -> *).
(FromJSON evaluatorcosts, FromJSON builtincosts,
ToJSON evaluatorcosts, ToJSON builtincosts,
MonadError CostModelApplyError m) =>
Text
-> CostModel evaluatorcosts builtincosts
-> CostModelParams
-> m (CostModel evaluatorcosts builtincosts)
applySplitCostModelParams Text
cekMachineCostsPrefix