-- Following is for tx compilation
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:remove-trace #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:target-version=1.1.0 #-}

module Cardano.Constitution.Validator.Data.Sorted
  ( constitutionValidator
  , defaultConstitutionValidator
  , mkConstitutionCode
  , defaultConstitutionCode
  ) where

import Cardano.Constitution.Config
import Cardano.Constitution.Validator.Data.Common as Common
import PlutusCore.Version (plcVersion110)
import PlutusTx as Tx
import PlutusTx.Builtins as B
import PlutusTx.List as List
import PlutusTx.Prelude as Tx

-- | Expects a constitution-configuration, statically *OR* at runtime via Tx.liftCode
constitutionValidator :: ConstitutionConfig -> ConstitutionValidator
constitutionValidator :: ConstitutionConfig -> ConstitutionValidator
constitutionValidator (ConstitutionConfig [Param]
cfg) =
  (ChangedParams -> Bool) -> ConstitutionValidator
Common.withChangedParams ([Param] -> ChangedParams -> Bool
runRules [Param]
cfg)

-- | The `runRules` is a loop that works element-wise from left-to-right on the 2 sorted maps.
runRules
  :: [Param]
  -- ^ the config (sorted by default)
  -> ChangedParams
  -- ^ the params (came sorted by the ledger)
  -> Bool
runRules :: [Param] -> ChangedParams -> Bool
runRules
  ((Integer
expectedPid, ParamValue
paramValue) : [Param]
cfgRest)
  cparams :: ChangedParams
cparams@((BuiltinData -> Integer
B.unsafeDataAsI -> Integer
actualPid, BuiltinData
actualValueData) : ChangedParams
cparamsRest) =
    case Integer
actualPid Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Integer
expectedPid of
      Ordering
EQ ->
        ParamValue -> BuiltinData -> Bool
Common.validateParamValue ParamValue
paramValue BuiltinData
actualValueData
          -- drop both heads, and continue checking the next changed param
          Bool -> Bool -> Bool
&& [Param] -> ChangedParams -> Bool
runRules [Param]
cfgRest ChangedParams
cparamsRest
      Ordering
GT ->
        -- skip configHead pointing to a parameter not being proposed
        [Param] -> ChangedParams -> Bool
runRules [Param]
cfgRest ChangedParams
cparams
      Ordering
LT ->
        -- actualPid not found in json config, the constitution fails
        Bool
False
-- if no cparams left: success
-- if cparams left: it means we reached the end of config without validating all cparams
runRules [Param]
_ ChangedParams
cparams = ChangedParams -> Bool
forall a. [a] -> Bool
List.null ChangedParams
cparams

-- | Statically configure the validator with the `defaultConstitutionConfig`.
defaultConstitutionValidator :: ConstitutionValidator
defaultConstitutionValidator :: ConstitutionValidator
defaultConstitutionValidator = ConstitutionConfig -> ConstitutionValidator
constitutionValidator ConstitutionConfig
defaultConstitutionConfig

{-| Make a constitution code by supplied the config at runtime.

See Note [Manually constructing a Configuration value] -}
mkConstitutionCode :: ConstitutionConfig -> CompiledCode ConstitutionValidator
mkConstitutionCode :: ConstitutionConfig -> CompiledCode ConstitutionValidator
mkConstitutionCode ConstitutionConfig
cCfg =
  $$(compile [||constitutionValidator||])
    CompiledCode (ConstitutionConfig -> ConstitutionValidator)
-> CompiledCodeIn DefaultUni DefaultFun ConstitutionConfig
-> CompiledCode ConstitutionValidator
forall (uni :: * -> *) fun a b.
(Closed uni, Everywhere uni Flat, Flat fun, Pretty fun,
 Everywhere uni PrettyConst,
 PrettyBy RenderContext (SomeTypeIn uni)) =>
CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b
`unsafeApplyCode` Version
-> ConstitutionConfig
-> CompiledCodeIn DefaultUni DefaultFun ConstitutionConfig
forall (uni :: * -> *) a fun.
(Lift uni a, GEq uni, Everywhere uni Eq, ThrowableBuiltins uni fun,
 Typecheckable uni fun, CaseBuiltin uni,
 Default (CostingPart uni fun), Default (BuiltinsInfo uni fun),
 Default (RewriteRules uni fun), Hashable fun) =>
Version -> a -> CompiledCodeIn uni fun a
liftCode Version
plcVersion110 ConstitutionConfig
cCfg

-- | The code of the constitution statically configured with the `defaultConstitutionConfig`.
defaultConstitutionCode :: CompiledCode ConstitutionValidator
defaultConstitutionCode :: CompiledCode ConstitutionValidator
defaultConstitutionCode = $$(compile [||defaultConstitutionValidator||])