-- editorconfig-checker-disable-file
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict            #-}
{-# LANGUAGE TypeApplications  #-}
{-# LANGUAGE ViewPatterns      #-}
module Cardano.Constitution.Validator.Data.Common
    ( withChangedParams
    , ChangedParams
    , ConstitutionValidator
    , validateParamValue
    ) where

import Cardano.Constitution.Config
import Data.Coerce
import PlutusLedgerApi.Data.V3
import PlutusTx.Builtins qualified as B
import PlutusTx.Builtins.Internal qualified as BI
import PlutusTx.NonCanonicalRational as NCRatio
import PlutusTx.Prelude as Tx hiding (toList)

type ConstitutionValidator = ScriptContext -- ^ Deep inside is the changed-parameters proposal
                           -> BuiltinUnit -- ^ No-error means the proposal conforms to the constitution

-- OPTIMIZE: operate on BuiltinList<BuiltinPair> directly, needs major refactoring of sorted&unsorted Validators
type ChangedParams = [(BuiltinData, BuiltinData)]

{- HLINT ignore "Redundant lambda" -} -- I like to see until where it supposed to be first applied.
{- HLINT ignore "Collapse lambdas" -} -- I like to see and comment on each arg
withChangedParams :: (ChangedParams -> Bool) -> ConstitutionValidator
withChangedParams :: (ChangedParams -> Bool) -> ConstitutionValidator
withChangedParams ChangedParams -> Bool
fun (ScriptContext -> Maybe ChangedParams
scriptContextToValidGovAction -> Maybe ChangedParams
validGovAction) =
    case Maybe ChangedParams
validGovAction of
        Just ChangedParams
cparams ->  if ChangedParams -> Bool
fun ChangedParams
cparams
            then BuiltinUnit
BI.unitval
            else BuiltinString -> BuiltinUnit
forall a. BuiltinString -> a
traceError BuiltinString
"ChangedParams failed to validate"
        Maybe ChangedParams
Nothing -> BuiltinUnit
BI.unitval -- this is a treasury withdrawal, we just accept it
{-# INLINABLE withChangedParams #-}

validateParamValue :: ParamValue -> BuiltinData -> Bool
validateParamValue :: ParamValue -> BuiltinData -> Bool
validateParamValue = \case
    ParamInteger Predicates Integer
preds -> Predicates Integer -> Integer -> Bool
forall a. Ord a => Predicates a -> a -> Bool
validatePreds Predicates Integer
preds (Integer -> Bool)
-> (BuiltinData -> Integer) -> BuiltinData -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinData -> Integer
B.unsafeDataAsI
    ParamRational Predicates Rational
preds -> Predicates Rational -> Rational -> Bool
forall a. Ord a => Predicates a -> a -> Bool
validatePreds Predicates Rational
preds (Rational -> Bool)
-> (BuiltinData -> Rational) -> BuiltinData -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonCanonicalRational -> Rational
forall a b. Coercible a b => a -> b
coerce (NonCanonicalRational -> Rational)
-> (BuiltinData -> NonCanonicalRational) -> BuiltinData -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. UnsafeFromData a => BuiltinData -> a
unsafeFromBuiltinData @NonCanonicalRational
    ParamList [ParamValue]
paramValues -> [ParamValue] -> BuiltinList BuiltinData -> Bool
validateParamValues [ParamValue]
paramValues (BuiltinList BuiltinData -> Bool)
-> (BuiltinData -> BuiltinList BuiltinData) -> BuiltinData -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinData -> BuiltinList BuiltinData
BI.unsafeDataAsList
    -- accept the actual proposed value without examining it
    ParamValue
ParamAny -> Bool -> BuiltinData -> Bool
forall a b. a -> b -> a
const Bool
True
  where
      validateParamValues :: [ParamValue] -> BI.BuiltinList BuiltinData -> Bool
      validateParamValues :: [ParamValue] -> BuiltinList BuiltinData -> Bool
validateParamValues = \case
          (ParamValue
paramValueHd : [ParamValue]
paramValueTl) -> \BuiltinList BuiltinData
actualValueData ->
              -- if actualValueData is not a cons, it will error
              ParamValue -> BuiltinData -> Bool
validateParamValue ParamValue
paramValueHd (BuiltinList BuiltinData -> BuiltinData
forall a. BuiltinList a -> a
BI.head BuiltinList BuiltinData
actualValueData)
              Bool -> Bool -> Bool
&& [ParamValue] -> BuiltinList BuiltinData -> Bool
validateParamValues [ParamValue]
paramValueTl (BuiltinList BuiltinData -> BuiltinList BuiltinData
forall a. BuiltinList a -> BuiltinList a
BI.tail BuiltinList BuiltinData
actualValueData)
          -- if reached the end of list of param-values to check, ensure no more proposed data are left
          [] -> BuiltinBool -> Bool
forall arep a. HasFromOpaque arep a => arep -> a
B.fromOpaque (BuiltinBool -> Bool)
-> (BuiltinList BuiltinData -> BuiltinBool)
-> BuiltinList BuiltinData
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinList BuiltinData -> BuiltinBool
forall a. BuiltinList a -> BuiltinBool
BI.null

      validatePreds :: forall a. Tx.Ord a => Predicates a -> a -> Bool
      validatePreds :: forall a. Ord a => Predicates a -> a -> Bool
validatePreds (Predicates [Predicate a]
preds) (a -> Predicate a -> Bool
forall a. Ord a => a -> Predicate a -> Bool
validatePred -> Predicate a -> Bool
validatePredAppliedToActual) =
          (Predicate a -> Bool) -> [Predicate a] -> Bool
forall a. (a -> Bool) -> [a] -> Bool
Tx.all Predicate a -> Bool
validatePredAppliedToActual [Predicate a]
preds

      validatePred :: forall a. Tx.Ord a => a -> Predicate a -> Bool
      validatePred :: forall a. Ord a => a -> Predicate a -> Bool
validatePred a
actualValue (PredKey
predKey, [a]
expectedPredValues) =
          (a -> Bool) -> [a] -> Bool
forall a. (a -> Bool) -> [a] -> Bool
Tx.all a -> Bool
meaningWithActual [a]
expectedPredValues
        where
          -- we find the meaning (function) from the PredKey
          meaning :: a -> a -> Bool
meaning = PredKey -> PredMeaning a
forall a. PredKey -> PredMeaning a
defaultPredMeanings PredKey
predKey
          -- apply the meaning to actual value: expectedValue is 1st argument, actualValue is 2nd argument
          meaningWithActual :: a -> Bool
meaningWithActual = (a -> a -> Bool
`meaning` a
actualValue)
{-# INLINABLE validateParamValue #-}

scriptContextToValidGovAction :: ScriptContext-> Maybe ChangedParams
scriptContextToValidGovAction :: ScriptContext -> Maybe ChangedParams
scriptContextToValidGovAction =
    GovernanceAction -> Maybe ChangedParams
governanceActionToValidGovAction
    (GovernanceAction -> Maybe ChangedParams)
-> (ScriptContext -> GovernanceAction)
-> ScriptContext
-> Maybe ChangedParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProposalProcedure -> GovernanceAction
ppGovernanceAction
    (ProposalProcedure -> GovernanceAction)
-> (ScriptContext -> ProposalProcedure)
-> ScriptContext
-> GovernanceAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptInfo -> ProposalProcedure
scriptInfoToProposalProcedure
    (ScriptInfo -> ProposalProcedure)
-> (ScriptContext -> ScriptInfo)
-> ScriptContext
-> ProposalProcedure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptContext -> ScriptInfo
scriptContextScriptInfo

  where
    scriptInfoToProposalProcedure :: ScriptInfo -> ProposalProcedure
    scriptInfoToProposalProcedure :: ScriptInfo -> ProposalProcedure
scriptInfoToProposalProcedure ScriptInfo
si =
        case ScriptInfo
si of
            (ProposingScript Integer
_ ProposalProcedure
pp) -> ProposalProcedure
pp
            ScriptInfo
_ -> BuiltinString -> ProposalProcedure
forall a. BuiltinString -> a
traceError BuiltinString
"Not a ProposalProcedure. This should not ever happen, because ledger should guard before, against it."

    governanceActionToValidGovAction :: GovernanceAction -> Maybe ChangedParams
    governanceActionToValidGovAction :: GovernanceAction -> Maybe ChangedParams
governanceActionToValidGovAction GovernanceAction
govAction =
        case GovernanceAction
govAction of
            (ParameterChange Maybe GovernanceActionId
_ ChangedParameters
cparams Maybe ScriptHash
_) -> ChangedParams -> Maybe ChangedParams
forall a. a -> Maybe a
Just (ChangedParams -> Maybe ChangedParams)
-> (ChangedParameters -> ChangedParams)
-> ChangedParameters
-> Maybe ChangedParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinData -> ChangedParams
B.unsafeDataAsMap (BuiltinData -> ChangedParams)
-> (ChangedParameters -> BuiltinData)
-> ChangedParameters
-> ChangedParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChangedParameters -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData (ChangedParameters -> Maybe ChangedParams)
-> ChangedParameters -> Maybe ChangedParams
forall a b. (a -> b) -> a -> b
$ ChangedParameters
cparams
            (TreasuryWithdrawals Map Credential Lovelace
_ Maybe ScriptHash
_) -> Maybe ChangedParams
forall a. Maybe a
Nothing
            GovernanceAction
_ -> BuiltinString -> Maybe ChangedParams
forall a. BuiltinString -> a
traceError BuiltinString
"Not a ChangedParams. This should not ever happen, because ledger should guard before, against it."
{-# INLINABLE scriptContextToValidGovAction #-}