Skip to content
Draft
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
The table of contents is too big for display.
Diff view
Diff view
  •  
  •  
  •  
33 changes: 0 additions & 33 deletions .stylish-haskell.yaml

This file was deleted.

25 changes: 13 additions & 12 deletions cardano-constitution/src/Cardano/Constitution/Config.hs
Original file line number Diff line number Diff line change
@@ -1,11 +1,12 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Cardano.Constitution.Config
( defaultConstitutionConfig
, defaultPredMeanings
, module Export
) where

module Cardano.Constitution.Config (
defaultConstitutionConfig,
defaultPredMeanings,
module Export,
) where

import Cardano.Constitution.Config.Instance.FromJSON ()
import Cardano.Constitution.Config.Instance.TxLift ()
Expand All @@ -19,12 +20,12 @@ import Data.Aeson.THReader as Aeson
-- | The default config read from "data/defaultConstitution.json"
defaultConstitutionConfig :: ConstitutionConfig
defaultConstitutionConfig = $$(Aeson.readJSONFromFile DFP.defaultConstitutionConfigFile)
{-# INLINABLE defaultConstitutionConfig #-}
{-# INLINEABLE defaultConstitutionConfig #-}

-- | NOTE: **BE CAREFUL** of the ordering. Expected value is first arg, Proposed Value is second arg
defaultPredMeanings :: PredKey -> PredMeaning a
defaultPredMeanings = \case
MinValue -> (Tx.<=)
MaxValue -> (Tx.>=)
NotEqual -> (Tx./=)
{-# INLINABLE defaultPredMeanings #-}
MinValue -> (Tx.<=)
MaxValue -> (Tx.>=)
NotEqual -> (Tx./=)
{-# INLINEABLE defaultPredMeanings #-}
Original file line number Diff line number Diff line change
@@ -1,9 +1,10 @@
{-# LANGUAGE LambdaCase #-}
-- editorconfig-checker-disable-file
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}

module Cardano.Constitution.Config.Instance.FromJSON () where

import Cardano.Constitution.Config.Types
Expand All @@ -24,135 +25,141 @@ import Text.Regex.TDFA as Rx

-- | Replica ADTs of ParamValue & ConstitutionConfig , specialised only for FromJSON.
-- Alternatively, we could generalise the aforementationed ADTs (needs barbies, breaks TxLifting)
data RawParamValue =
RawParamInteger (Predicates Integer)
| RawParamRational (Predicates Tx.Rational)
| RawParamList (M.Map Integer RawParamValue)
| RawParamAny
data RawParamValue
= RawParamInteger (Predicates Integer)
| RawParamRational (Predicates Tx.Rational)
| RawParamList (M.Map Integer RawParamValue)
| RawParamAny

newtype RawConstitutionConfig = RawConstitutionConfig (M.Map Integer RawParamValue)

-- TODO: move to deriving-aeson
instance FromJSON PredKey where
parseJSON = genericParseJSON (defaultOptions { constructorTagModifier = lowerInitialChar })
parseJSON = genericParseJSON (defaultOptions {constructorTagModifier = lowerInitialChar})

-- TODO: move to deriving-aeson
instance Aeson.FromJSONKey PredKey where
fromJSONKey = genericFromJSONKey (defaultJSONKeyOptions { keyModifier = lowerInitialChar })
fromJSONKey = genericFromJSONKey (defaultJSONKeyOptions {keyModifier = lowerInitialChar})

instance FromJSON a => FromJSON (Predicates a) where
parseJSON val = do
-- TODO: ugly code, refactor
ms <- parseJSON @[Object] val
-- filter out "$comment" from all keymaps
let ms' = fmap (Object . Aeson.delete commentKey) ms
-- re-parse correctly this time
m <- parseJSON @[M.Map PredKey a] (Aeson.Array $ fromList ms')
when (any ((/= 1) . length) m) $
fail "Only one predicate-key per predicate inside the predicate list"
pure $ Predicates $
-- using toAscList here ensures that the inner map is sorted
M.toAscList
-- combine the duplicate predicates into a list of predicate values
-- entries with same key combine their values with (++)
$ M.unionsWith (<>)
$ fmap (fmap pure) m
parseJSON val = do
-- TODO: ugly code, refactor
ms <- parseJSON @[Object] val
-- filter out "$comment" from all keymaps
let ms' = fmap (Object . Aeson.delete commentKey) ms
-- re-parse correctly this time
m <- parseJSON @[M.Map PredKey a] (Aeson.Array $ fromList ms')
when (any ((/= 1) . length) m) $
fail "Only one predicate-key per predicate inside the predicate list"
pure $
Predicates $
-- using toAscList here ensures that the inner map is sorted
M.toAscList
-- combine the duplicate predicates into a list of predicate values
-- entries with same key combine their values with (++)
$
M.unionsWith (<>) $
fmap (fmap pure) m

instance FromJSON ConstitutionConfig where
parseJSON =
parseJSON -- first pass, parse raw
>=>
fromRaw -- second pass, flatten maps to lists, and check for contiguity
parseJSON =
parseJSON -- first pass, parse raw
>=> fromRaw -- second pass, flatten maps to lists, and check for contiguity

-- 1st pass
instance FromJSON RawConstitutionConfig where
parseJSON = fmap RawConstitutionConfig
. withObject "RawConstitutionConfig" (foldlM insertParam mempty . Aeson.toAscList)
parseJSON =
fmap RawConstitutionConfig
. withObject "RawConstitutionConfig" (foldlM insertParam mempty . Aeson.toAscList)
where
insertParam acc (outerKey, outerValue) = do
(index, msubIndex) <- parseParamKey outerKey
when (index < 0) $ fail "Negative Integer ParamKey given"
paramValue <- parseParamValue msubIndex outerValue
-- flipped version of Lens.at
M.alterF (\case
Nothing -> pure $ Just paramValue
Just paramValue' -> Just <$> mergeParamValues paramValue' paramValue
) index acc
(index, msubIndex) <- parseParamKey outerKey
when (index < 0) $ fail "Negative Integer ParamKey given"
paramValue <- parseParamValue msubIndex outerValue
-- flipped version of Lens.at
M.alterF
( \case
Nothing -> pure $ Just paramValue
Just paramValue' -> Just <$> mergeParamValues paramValue' paramValue
)
index
acc

-- second pass, flatten maps to lists, and check for contiguity
fromRaw :: MonadFail m => RawConstitutionConfig -> m ConstitutionConfig
fromRaw (RawConstitutionConfig rc) = ConstitutionConfig . M.toAscList <$> traverse flattenParamValue rc
where
flattenParamValue :: MonadFail m => RawParamValue -> m ParamValue
flattenParamValue = \case
RawParamList m -> do
-- This is the CONTIGUOUS check.
when (not $ M.keys m `isPrefixOf` [0..]) $ fail "The sub-indices are not in order."
-- the M.elems will be in ascending order
ParamList <$> traverse flattenParamValue (M.elems m)
-- boilerplate follows
RawParamInteger x -> pure $ ParamInteger x
RawParamRational x -> pure $ ParamRational x
RawParamAny -> pure ParamAny
RawParamList m -> do
-- This is the CONTIGUOUS check.
when (not $ M.keys m `isPrefixOf` [0 ..]) $ fail "The sub-indices are not in order."
-- the M.elems will be in ascending order
ParamList <$> traverse flattenParamValue (M.elems m)
-- boilerplate follows
RawParamInteger x -> pure $ ParamInteger x
RawParamRational x -> pure $ ParamRational x
RawParamAny -> pure ParamAny

-- MAYBE: use instead attoparsec-aeson.jsonWith/jsonNoDup to fail on parsing duplicate Keys,
-- because right now Aeson silently ignores duplicated param entries (arbitrarily picks the last of duplicates)
parseParamKey :: Aeson.Key -> Aeson.Parser (Integer, Maybe Integer)
parseParamKey (Aeson.toString -> s) = do
-- MAYBE: fetch the regex pattern from the schema itself, it is easy
[[_, indexS,_,subIndexS]] :: [[String]] <- s Rx.=~~ ("^(0|[1-9][0-9]*)(\\[(0|[1-9][0-9]*)\\])?$" :: String)
indexI <- either fail pure $ readEitherSafe indexS
mSubIndexI <-
if null subIndexS
then pure Nothing
else Just <$> either fail pure (readEitherSafe subIndexS)
pure (indexI,mSubIndexI)
-- MAYBE: fetch the regex pattern from the schema itself, it is easy
[[_, indexS, _, subIndexS]] :: [[String]] <- s Rx.=~~ ("^(0|[1-9][0-9]*)(\\[(0|[1-9][0-9]*)\\])?$" :: String)
indexI <- either fail pure $ readEitherSafe indexS
mSubIndexI <-
if null subIndexS
then pure Nothing
else Just <$> either fail pure (readEitherSafe subIndexS)
pure (indexI, mSubIndexI)

-- | If there is a subkey given, treat the param as a paramlist
-- Otherwise, parse it based on the json's "type"
parseParamValue :: Maybe ParamKey -> Value -> Parser RawParamValue
parseParamValue = \case
Nothing -> parseTypedParamValue
-- if we parsed a sub-index, treat the param value as a `M.singleton subIndex value`
Just subIndex -> fmap (RawParamList . M.singleton subIndex) . parseTypedParamValue
Nothing -> parseTypedParamValue
-- if we parsed a sub-index, treat the param value as a `M.singleton subIndex value`
Just subIndex -> fmap (RawParamList . M.singleton subIndex) . parseTypedParamValue
where
parseTypedParamValue :: Value -> Parser RawParamValue
parseTypedParamValue = withObject "RawParamValue" $ \o -> do
ty <- o .: typeKey
parseSynonymType ty o

-- the base types we support
parseBaseType :: Key -> Object -> Parser RawParamValue
parseBaseType ty o = case ty of
"integer" -> RawParamInteger <$> (o .: predicatesKey)
-- NOTE: even if the Tx.Ratio.Rational constructor is not exposed, the 2 arguments to the constructor
-- will be normalized (co-primed) when Tx.lift is called on them.
-- SO there is no speed benefit to statically co-prime them ourselves for efficiency.
"rational" -> RawParamRational <$> (o .: predicatesKey)
"any" -> pure RawParamAny
_ -> fail "invalid type tag"

-- synonyms to ease the transition from cddl
parseSynonymType = \case
"coin" -> parseBaseType "integer"
"uint.size4" -> parseBaseType "integer"
"uint.size2" -> parseBaseType "integer"
"uint" -> parseBaseType "integer" -- For ex units
"epoch_interval" -> parseBaseType "integer" -- Rename of uint.size4
"unit_interval" -> parseBaseType "rational"
"nonnegative_interval" -> parseBaseType "rational"
"costMdls" -> parseBaseType "any"
x -> parseBaseType x -- didn't find synonym, try as basetype
parseTypedParamValue :: Value -> Parser RawParamValue
parseTypedParamValue = withObject "RawParamValue" $ \o -> do
ty <- o .: typeKey
parseSynonymType ty o

-- the base types we support
parseBaseType :: Key -> Object -> Parser RawParamValue
parseBaseType ty o = case ty of
"integer" -> RawParamInteger <$> (o .: predicatesKey)
-- NOTE: even if the Tx.Ratio.Rational constructor is not exposed, the 2 arguments to the constructor
-- will be normalized (co-primed) when Tx.lift is called on them.
-- SO there is no speed benefit to statically co-prime them ourselves for efficiency.
"rational" -> RawParamRational <$> (o .: predicatesKey)
"any" -> pure RawParamAny
_ -> fail "invalid type tag"

-- synonyms to ease the transition from cddl
parseSynonymType = \case
"coin" -> parseBaseType "integer"
"uint.size4" -> parseBaseType "integer"
"uint.size2" -> parseBaseType "integer"
"uint" -> parseBaseType "integer" -- For ex units
"epoch_interval" -> parseBaseType "integer" -- Rename of uint.size4
"unit_interval" -> parseBaseType "rational"
"nonnegative_interval" -> parseBaseType "rational"
"costMdls" -> parseBaseType "any"
x -> parseBaseType x -- didn't find synonym, try as basetype

-- | It is like an `mappend` when both inputs are ParamList's.
mergeParamValues :: MonadFail m => RawParamValue -> RawParamValue -> m RawParamValue
mergeParamValues (RawParamList m1) = \case
RawParamList m2 -> pure $ RawParamList $ m1 <> m2
_ -> fail "param matched with subparam"
RawParamList m2 -> pure $ RawParamList $ m1 <> m2
_ -> fail "param matched with subparam"
mergeParamValues _ = \case
RawParamList _ -> fail "param matched with subparam"
-- in reality this cannot be triggered, because we would then have duplicate params
-- , which default aeson and json allow
_ -> fail "this should not happen"
RawParamList _ -> fail "param matched with subparam"
-- in reality this cannot be triggered, because we would then have duplicate params
-- , which default aeson and json allow
_ -> fail "this should not happen"

predicatesKey, typeKey, commentKey :: Aeson.Key
predicatesKey = "predicates"
Expand Down
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Constitution.Config.Instance.TxLift () where

import Cardano.Constitution.Config.Types
Expand All @@ -14,8 +15,9 @@ import PlutusTx.Lift.Class as Tx

Tx.makeLift ''PredKey

deriving newtype instance (Tx.Typeable Tx.DefaultUni predValue, Tx.Lift Tx.DefaultUni predValue)
=> Tx.Lift Tx.DefaultUni (Predicates predValue)
deriving newtype instance
(Tx.Typeable Tx.DefaultUni predValue, Tx.Lift Tx.DefaultUni predValue) =>
Tx.Lift Tx.DefaultUni (Predicates predValue)

Tx.makeTypeable (TH.ConT ''Tx.DefaultUni) ''Predicates
Tx.makeLift ''ParamValue
Expand Down
Loading