{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
module Cardano.Constitution.Config.Instance.FromJSON () where
import Cardano.Constitution.Config.Types
import PlutusPrelude (lowerInitialChar)
import PlutusTx.Ratio as Tx
import Control.Monad
import Data.Aeson.Key qualified as Aeson
import Data.Aeson.KeyMap qualified as Aeson
import Data.Aeson.Types as Aeson
import Data.Foldable
import Data.List as Haskell.List
import Data.Map qualified as M
import GHC.IsList
import Safe
import Text.Regex.TDFA as Rx
data RawParamValue =
RawParamInteger (Predicates Integer)
| RawParamRational (Predicates Tx.Rational)
| RawParamList (M.Map Integer RawParamValue)
| RawParamAny
newtype RawConstitutionConfig = RawConstitutionConfig (M.Map Integer RawParamValue)
instance FromJSON PredKey where
parseJSON :: Value -> Parser PredKey
parseJSON = Options -> Value -> Parser PredKey
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON (Options
defaultOptions { constructorTagModifier = lowerInitialChar })
instance Aeson.FromJSONKey PredKey where
fromJSONKey :: FromJSONKeyFunction PredKey
fromJSONKey = JSONKeyOptions -> FromJSONKeyFunction PredKey
forall a.
(Generic a, GFromJSONKey (Rep a)) =>
JSONKeyOptions -> FromJSONKeyFunction a
genericFromJSONKey (JSONKeyOptions
defaultJSONKeyOptions { keyModifier = lowerInitialChar })
instance FromJSON a => FromJSON (Predicates a) where
parseJSON :: Value -> Parser (Predicates a)
parseJSON Value
val = do
[Object]
ms <- forall a. FromJSON a => Value -> Parser a
parseJSON @[Object] Value
val
let ms' :: [Value]
ms' = (Object -> Value) -> [Object] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Object -> Value
Object (Object -> Value) -> (Object -> Object) -> Object -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
Aeson.delete Key
commentKey) [Object]
ms
[Map PredKey a]
m <- forall a. FromJSON a => Value -> Parser a
parseJSON @[M.Map PredKey a] (Array -> Value
Aeson.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Item Array] -> Array
forall l. IsList l => [Item l] -> l
fromList [Item Array]
[Value]
ms')
Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Map PredKey a -> Bool) -> [Map PredKey a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
1) (Int -> Bool) -> (Map PredKey a -> Int) -> Map PredKey a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PredKey a -> Int
forall a. Map PredKey a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [Map PredKey a]
m) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$
String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Only one predicate-key per predicate inside the predicate list"
Predicates a -> Parser (Predicates a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Predicates a -> Parser (Predicates a))
-> Predicates a -> Parser (Predicates a)
forall a b. (a -> b) -> a -> b
$ [Predicate a] -> Predicates a
forall v. [Predicate v] -> Predicates v
Predicates ([Predicate a] -> Predicates a) -> [Predicate a] -> Predicates a
forall a b. (a -> b) -> a -> b
$
Map PredKey [a] -> [Predicate a]
forall k a. Map k a -> [(k, a)]
M.toAscList
(Map PredKey [a] -> [Predicate a])
-> Map PredKey [a] -> [Predicate a]
forall a b. (a -> b) -> a -> b
$ ([a] -> [a] -> [a]) -> [Map PredKey [a]] -> Map PredKey [a]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
(<>)
([Map PredKey [a]] -> Map PredKey [a])
-> [Map PredKey [a]] -> Map PredKey [a]
forall a b. (a -> b) -> a -> b
$ (Map PredKey a -> Map PredKey [a])
-> [Map PredKey a] -> [Map PredKey [a]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> [a]) -> Map PredKey a -> Map PredKey [a]
forall a b. (a -> b) -> Map PredKey a -> Map PredKey b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> [a]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure) [Map PredKey a]
m
instance FromJSON ConstitutionConfig where
parseJSON :: Value -> Parser ConstitutionConfig
parseJSON =
Value -> Parser RawConstitutionConfig
forall a. FromJSON a => Value -> Parser a
parseJSON
(Value -> Parser RawConstitutionConfig)
-> (RawConstitutionConfig -> Parser ConstitutionConfig)
-> Value
-> Parser ConstitutionConfig
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
RawConstitutionConfig -> Parser ConstitutionConfig
forall (m :: * -> *).
MonadFail m =>
RawConstitutionConfig -> m ConstitutionConfig
fromRaw
instance FromJSON RawConstitutionConfig where
parseJSON :: Value -> Parser RawConstitutionConfig
parseJSON = (Map Integer RawParamValue -> RawConstitutionConfig)
-> Parser (Map Integer RawParamValue)
-> Parser RawConstitutionConfig
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map Integer RawParamValue -> RawConstitutionConfig
RawConstitutionConfig
(Parser (Map Integer RawParamValue)
-> Parser RawConstitutionConfig)
-> (Value -> Parser (Map Integer RawParamValue))
-> Value
-> Parser RawConstitutionConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> (Object -> Parser (Map Integer RawParamValue))
-> Value
-> Parser (Map Integer RawParamValue)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RawConstitutionConfig" ((Map Integer RawParamValue
-> (Key, Value) -> Parser (Map Integer RawParamValue))
-> Map Integer RawParamValue
-> [(Key, Value)]
-> Parser (Map Integer RawParamValue)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Map Integer RawParamValue
-> (Key, Value) -> Parser (Map Integer RawParamValue)
insertParam Map Integer RawParamValue
forall a. Monoid a => a
mempty ([(Key, Value)] -> Parser (Map Integer RawParamValue))
-> (Object -> [(Key, Value)])
-> Object
-> Parser (Map Integer RawParamValue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
Aeson.toAscList)
where
insertParam :: Map Integer RawParamValue
-> (Key, Value) -> Parser (Map Integer RawParamValue)
insertParam Map Integer RawParamValue
acc (Key
outerKey, Value
outerValue) = do
(Integer
index, Maybe Integer
msubIndex) <- Key -> Parser (Integer, Maybe Integer)
parseParamKey Key
outerKey
Bool -> Parser () -> Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
index Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0) (Parser () -> Parser ()) -> Parser () -> Parser ()
forall a b. (a -> b) -> a -> b
$ String -> Parser ()
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Negative Integer ParamKey given"
RawParamValue
paramValue <- Maybe Integer -> Value -> Parser RawParamValue
parseParamValue Maybe Integer
msubIndex Value
outerValue
(Maybe RawParamValue -> Parser (Maybe RawParamValue))
-> Integer
-> Map Integer RawParamValue
-> Parser (Map Integer RawParamValue)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
M.alterF (\case
Maybe RawParamValue
Nothing -> Maybe RawParamValue -> Parser (Maybe RawParamValue)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe RawParamValue -> Parser (Maybe RawParamValue))
-> Maybe RawParamValue -> Parser (Maybe RawParamValue)
forall a b. (a -> b) -> a -> b
$ RawParamValue -> Maybe RawParamValue
forall a. a -> Maybe a
Just RawParamValue
paramValue
Just RawParamValue
paramValue' -> RawParamValue -> Maybe RawParamValue
forall a. a -> Maybe a
Just (RawParamValue -> Maybe RawParamValue)
-> Parser RawParamValue -> Parser (Maybe RawParamValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawParamValue -> RawParamValue -> Parser RawParamValue
forall (m :: * -> *).
MonadFail m =>
RawParamValue -> RawParamValue -> m RawParamValue
mergeParamValues RawParamValue
paramValue' RawParamValue
paramValue
) Integer
index Map Integer RawParamValue
acc
fromRaw :: MonadFail m => RawConstitutionConfig -> m ConstitutionConfig
fromRaw :: forall (m :: * -> *).
MonadFail m =>
RawConstitutionConfig -> m ConstitutionConfig
fromRaw (RawConstitutionConfig Map Integer RawParamValue
rc) = [Param] -> ConstitutionConfig
ConstitutionConfig ([Param] -> ConstitutionConfig)
-> (Map Integer ParamValue -> [Param])
-> Map Integer ParamValue
-> ConstitutionConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Integer ParamValue -> [Param]
forall k a. Map k a -> [(k, a)]
M.toAscList (Map Integer ParamValue -> ConstitutionConfig)
-> m (Map Integer ParamValue) -> m ConstitutionConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RawParamValue -> m ParamValue)
-> Map Integer RawParamValue -> m (Map Integer ParamValue)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map Integer a -> f (Map Integer b)
traverse RawParamValue -> m ParamValue
forall (m :: * -> *). MonadFail m => RawParamValue -> m ParamValue
flattenParamValue Map Integer RawParamValue
rc
where
flattenParamValue :: MonadFail m => RawParamValue -> m ParamValue
flattenParamValue :: forall (m :: * -> *). MonadFail m => RawParamValue -> m ParamValue
flattenParamValue = \case
RawParamList Map Integer RawParamValue
m -> do
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map Integer RawParamValue -> [Integer]
forall k a. Map k a -> [k]
M.keys Map Integer RawParamValue
m [Integer] -> [Integer] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Integer
0..]) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"The sub-indices are not in order."
[ParamValue] -> ParamValue
ParamList ([ParamValue] -> ParamValue) -> m [ParamValue] -> m ParamValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RawParamValue -> m ParamValue)
-> [RawParamValue] -> m [ParamValue]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse RawParamValue -> m ParamValue
forall (m :: * -> *). MonadFail m => RawParamValue -> m ParamValue
flattenParamValue (Map Integer RawParamValue -> [RawParamValue]
forall k a. Map k a -> [a]
M.elems Map Integer RawParamValue
m)
RawParamInteger Predicates Integer
x -> ParamValue -> m ParamValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParamValue -> m ParamValue) -> ParamValue -> m ParamValue
forall a b. (a -> b) -> a -> b
$ Predicates Integer -> ParamValue
ParamInteger Predicates Integer
x
RawParamRational Predicates Rational
x -> ParamValue -> m ParamValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParamValue -> m ParamValue) -> ParamValue -> m ParamValue
forall a b. (a -> b) -> a -> b
$ Predicates Rational -> ParamValue
ParamRational Predicates Rational
x
RawParamValue
RawParamAny -> ParamValue -> m ParamValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParamValue
ParamAny
parseParamKey :: Aeson.Key -> Aeson.Parser (Integer, Maybe Integer)
parseParamKey :: Key -> Parser (Integer, Maybe Integer)
parseParamKey (Key -> String
Aeson.toString -> String
s) = do
[[String
_, String
indexS,String
_,String
subIndexS]] :: [[String]] <- String
s String -> String -> Parser [[String]]
forall source source1 target (m :: * -> *).
(RegexMaker Regex CompOption ExecOption source,
RegexContext Regex source1 target, MonadFail m) =>
source1 -> source -> m target
Rx.=~~ (String
"^(0|[1-9][0-9]*)(\\[(0|[1-9][0-9]*)\\])?$" :: String)
Integer
indexI <- (String -> Parser Integer)
-> (Integer -> Parser Integer)
-> Either String Integer
-> Parser Integer
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Integer
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Integer -> Parser Integer
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String Integer -> Parser Integer)
-> Either String Integer -> Parser Integer
forall a b. (a -> b) -> a -> b
$ String -> Either String Integer
forall a. Read a => String -> Either String a
readEitherSafe String
indexS
Maybe Integer
mSubIndexI <-
if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
subIndexS
then Maybe Integer -> Parser (Maybe Integer)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing
else Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer)
-> Parser Integer -> Parser (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Parser Integer)
-> (Integer -> Parser Integer)
-> Either String Integer
-> Parser Integer
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Parser Integer
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Integer -> Parser Integer
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String Integer
forall a. Read a => String -> Either String a
readEitherSafe String
subIndexS)
(Integer, Maybe Integer) -> Parser (Integer, Maybe Integer)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer
indexI,Maybe Integer
mSubIndexI)
parseParamValue :: Maybe ParamKey -> Value -> Parser RawParamValue
parseParamValue :: Maybe Integer -> Value -> Parser RawParamValue
parseParamValue = \case
Maybe Integer
Nothing -> Value -> Parser RawParamValue
parseTypedParamValue
Just Integer
subIndex -> (RawParamValue -> RawParamValue)
-> Parser RawParamValue -> Parser RawParamValue
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map Integer RawParamValue -> RawParamValue
RawParamList (Map Integer RawParamValue -> RawParamValue)
-> (RawParamValue -> Map Integer RawParamValue)
-> RawParamValue
-> RawParamValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> RawParamValue -> Map Integer RawParamValue
forall k a. k -> a -> Map k a
M.singleton Integer
subIndex) (Parser RawParamValue -> Parser RawParamValue)
-> (Value -> Parser RawParamValue) -> Value -> Parser RawParamValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser RawParamValue
parseTypedParamValue
where
parseTypedParamValue :: Value -> Parser RawParamValue
parseTypedParamValue :: Value -> Parser RawParamValue
parseTypedParamValue = String
-> (Object -> Parser RawParamValue)
-> Value
-> Parser RawParamValue
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RawParamValue" ((Object -> Parser RawParamValue) -> Value -> Parser RawParamValue)
-> (Object -> Parser RawParamValue)
-> Value
-> Parser RawParamValue
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
Key
ty <- Object
o Object -> Key -> Parser Key
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
typeKey
Key -> Object -> Parser RawParamValue
parseSynonymType Key
ty Object
o
parseBaseType :: Key -> Object -> Parser RawParamValue
parseBaseType :: Key -> Object -> Parser RawParamValue
parseBaseType Key
ty Object
o = case Key
ty of
Key
"integer" -> Predicates Integer -> RawParamValue
RawParamInteger (Predicates Integer -> RawParamValue)
-> Parser (Predicates Integer) -> Parser RawParamValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser (Predicates Integer)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
predicatesKey)
Key
"rational" -> Predicates Rational -> RawParamValue
RawParamRational (Predicates Rational -> RawParamValue)
-> Parser (Predicates Rational) -> Parser RawParamValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser (Predicates Rational)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
predicatesKey)
Key
"any" -> RawParamValue -> Parser RawParamValue
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawParamValue
RawParamAny
Key
_ -> String -> Parser RawParamValue
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid type tag"
parseSynonymType :: Key -> Object -> Parser RawParamValue
parseSynonymType = \case
Key
"coin" -> Key -> Object -> Parser RawParamValue
parseBaseType Key
"integer"
Key
"uint.size4" -> Key -> Object -> Parser RawParamValue
parseBaseType Key
"integer"
Key
"uint.size2" -> Key -> Object -> Parser RawParamValue
parseBaseType Key
"integer"
Key
"uint" -> Key -> Object -> Parser RawParamValue
parseBaseType Key
"integer"
Key
"epoch_interval" -> Key -> Object -> Parser RawParamValue
parseBaseType Key
"integer"
Key
"unit_interval" -> Key -> Object -> Parser RawParamValue
parseBaseType Key
"rational"
Key
"nonnegative_interval" -> Key -> Object -> Parser RawParamValue
parseBaseType Key
"rational"
Key
"costMdls" -> Key -> Object -> Parser RawParamValue
parseBaseType Key
"any"
Key
x -> Key -> Object -> Parser RawParamValue
parseBaseType Key
x
mergeParamValues :: MonadFail m => RawParamValue -> RawParamValue -> m RawParamValue
mergeParamValues :: forall (m :: * -> *).
MonadFail m =>
RawParamValue -> RawParamValue -> m RawParamValue
mergeParamValues (RawParamList Map Integer RawParamValue
m1) = \case
RawParamList Map Integer RawParamValue
m2 -> RawParamValue -> m RawParamValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawParamValue -> m RawParamValue)
-> RawParamValue -> m RawParamValue
forall a b. (a -> b) -> a -> b
$ Map Integer RawParamValue -> RawParamValue
RawParamList (Map Integer RawParamValue -> RawParamValue)
-> Map Integer RawParamValue -> RawParamValue
forall a b. (a -> b) -> a -> b
$ Map Integer RawParamValue
m1 Map Integer RawParamValue
-> Map Integer RawParamValue -> Map Integer RawParamValue
forall a. Semigroup a => a -> a -> a
<> Map Integer RawParamValue
m2
RawParamValue
_ -> String -> m RawParamValue
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"param matched with subparam"
mergeParamValues RawParamValue
_ = \case
RawParamList Map Integer RawParamValue
_ -> String -> m RawParamValue
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"param matched with subparam"
RawParamValue
_ -> String -> m RawParamValue
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"this should not happen"
predicatesKey, typeKey, commentKey :: Aeson.Key
predicatesKey :: Key
predicatesKey = Key
"predicates"
typeKey :: Key
typeKey = Key
"type"
= Key
"$comment"