-- 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

type ChangedParams = BI.BuiltinList (BI.BuiltinPair 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
  -- See Note [Optional parameter values]
  ParamMaybe ParamValue
paramValue -> ParamValue -> BuiltinPair Integer (BuiltinList BuiltinData) -> Bool
validateMaybeParamValue ParamValue
paramValue (BuiltinPair Integer (BuiltinList BuiltinData) -> Bool)
-> (BuiltinData -> BuiltinPair Integer (BuiltinList BuiltinData))
-> BuiltinData
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuiltinData -> BuiltinPair Integer (BuiltinList BuiltinData)
BI.unsafeDataAsConstr
  where
    validateMaybeParamValue
      :: ParamValue -> BI.BuiltinPair Integer (BI.BuiltinList BuiltinData) -> Bool
    validateMaybeParamValue :: ParamValue -> BuiltinPair Integer (BuiltinList BuiltinData) -> Bool
validateMaybeParamValue ParamValue
paramValue BuiltinPair Integer (BuiltinList BuiltinData)
constr =
      Integer
-> [BuiltinList BuiltinData -> Bool]
-> BuiltinList BuiltinData
-> Bool
forall a. Integer -> [a] -> a
BI.caseInteger
        (BuiltinPair Integer (BuiltinList BuiltinData) -> Integer
forall a b. BuiltinPair a b -> a
BI.fst BuiltinPair Integer (BuiltinList BuiltinData)
constr)
        [ -- `Just v`: validate v
          (BuiltinData -> BuiltinList BuiltinData -> Bool)
-> BuiltinList BuiltinData -> Bool
forall a r. (a -> BuiltinList a -> r) -> BuiltinList a -> r
BI.unsafeCaseList
            ( \BuiltinData
x BuiltinList BuiltinData
xs ->
                ParamValue -> BuiltinData -> Bool
validateParamValue ParamValue
paramValue BuiltinData
x
                  Bool -> Bool -> Bool
&& Bool -> Bool
forall arep a. HasFromOpaque arep a => arep -> a
B.fromOpaque (BuiltinList BuiltinData -> Bool
forall a. BuiltinList a -> Bool
BI.null BuiltinList BuiltinData
xs)
            )
        , \BuiltinList BuiltinData
constrArgs ->
            -- `Nothing`: unsets the parameter
            Bool -> Bool
forall arep a. HasFromOpaque arep a => arep -> a
B.fromOpaque (BuiltinList BuiltinData -> Bool
forall a. BuiltinList a -> Bool
BI.null BuiltinList BuiltinData
constrArgs)
        ]
        (BuiltinPair Integer (BuiltinList BuiltinData)
-> BuiltinList BuiltinData
forall a b. BuiltinPair a b -> b
BI.snd BuiltinPair Integer (BuiltinList BuiltinData)
constr)

    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 =
      BuiltinPair Integer (BuiltinList BuiltinData)
-> (Integer -> BuiltinList BuiltinData -> Maybe ChangedParams)
-> Maybe ChangedParams
forall a b r. BuiltinPair a b -> (a -> b -> r) -> r
BI.casePair (BuiltinData -> BuiltinPair Integer (BuiltinList BuiltinData)
BI.unsafeDataAsConstr (GovernanceAction -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData GovernanceAction
govAction)) ((Integer -> BuiltinList BuiltinData -> Maybe ChangedParams)
 -> Maybe ChangedParams)
-> (Integer -> BuiltinList BuiltinData -> Maybe ChangedParams)
-> Maybe ChangedParams
forall a b. (a -> b) -> a -> b
$ \Integer
i BuiltinList BuiltinData
args ->
        Integer -> [Maybe ChangedParams] -> Maybe ChangedParams
forall a. Integer -> [a] -> a
BI.caseInteger
          Integer
i
          [ -- 0: ParameterChange
            ChangedParams -> Maybe ChangedParams
forall a. a -> Maybe a
Just (BuiltinData -> ChangedParams
BI.unsafeDataAsMap (BuiltinList BuiltinData -> BuiltinData
forall a. BuiltinList a -> a
BI.head (BuiltinList BuiltinData -> BuiltinList BuiltinData
forall a. BuiltinList a -> BuiltinList a
BI.tail BuiltinList BuiltinData
args)))
          , -- 1: HardForkInitiation
            BuiltinString -> Maybe ChangedParams
forall a. BuiltinString -> a
traceError
              BuiltinString
"Not a ChangedParams. This should not ever happen, because ledger should guard before, against it."
          , -- 2: TreasuryWithdrawals
            Maybe ChangedParams
forall a. Maybe a
Nothing
          ]
{-# INLINEABLE scriptContextToValidGovAction #-}