-- editorconfig-checker-disable-file
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}

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.List as List
import PlutusTx.NonCanonicalRational as NCRatio
import PlutusTx.Prelude as Tx

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
{-# INLINEABLE 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
      [] -> Bool -> Bool
forall arep a. HasFromOpaque arep a => arep -> a
B.fromOpaque (Bool -> Bool)
-> (BuiltinList BuiltinData -> Bool)
-> BuiltinList BuiltinData
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinList BuiltinData -> Bool
forall a. BuiltinList a -> Bool
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
List.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
List.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)
{-# INLINEABLE 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."
{-# INLINEABLE scriptContextToValidGovAction #-}