From e6d124ad908ee9d77c502f47ff37e2c6e0ccf77c Mon Sep 17 00:00:00 2001 From: Nicholas Clarke Date: Mon, 25 Nov 2024 15:54:39 +0100 Subject: [PATCH] Support references in ranges This addresses issue #29. Note that this does introduce a backwards incompatibility, since now range arguments numeric literals need additional hints. --- CHANGELOG.md | 9 ++++ cuddle.cabal | 2 +- example/Conway.hs | 12 ++--- src/Codec/CBOR/Cuddle/Huddle.hs | 69 ++++++++++++++++++--------- test/Test/Codec/CBOR/Cuddle/Huddle.hs | 7 ++- 5 files changed, 69 insertions(+), 30 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7ac18ea..85d3e67 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -29,3 +29,12 @@ control over the order that items are presented in the CDDL, at the cost of making it somewhat harder to re-use items (they need to be returned from the monad). + +## O.3.5.0 -- 2024-11-25 + +* Add support for constraints on references and generic references. +* Add support for using references as range bounds. Note that this breaks + backwards compatibility - because the range arguments are now more generic, + additional hints are required to type literal numerics correctly. Typically + this is most easily fixed by adding a call `int` for any numeric literals in + ranges. An example is shown in `example/Conway.hs` diff --git a/cuddle.cabal b/cuddle.cabal index a477f95..88943a7 100644 --- a/cuddle.cabal +++ b/cuddle.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: cuddle -version: 0.3.4.0 +version: 0.3.5.0 synopsis: CDDL Generator and test utilities -- description: diff --git a/example/Conway.hs b/example/Conway.hs index 90ad50e..40ff3cd 100644 --- a/example/Conway.hs +++ b/example/Conway.hs @@ -647,7 +647,7 @@ language = / int 2 -- Plutus v3 potential_languages :: Rule -potential_languages = "potential_languages" =:= 0 ... 255 +potential_languages = "potential_languages" =:= int 0 ... int 255 -- The format for costmdls is flexible enough to allow adding Plutus built-ins and language -- versions in the future. @@ -767,16 +767,16 @@ asset_name :: Rule asset_name = "asset_name" =:= VBytes `sized` (0 :: Word64, 32 :: Word64) negInt64 :: Rule -negInt64 = "negInt64" =:= (-9223372036854775808) ... (-1) +negInt64 = "negInt64" =:= int (-9223372036854775808) ... int (-1) posInt64 :: Rule -posInt64 = "posInt64" =:= 1 ... 9223372036854775807 +posInt64 = "posInt64" =:= int 1 ... int 9223372036854775807 nonZeroInt64 :: Rule nonZeroInt64 = "nonZeroInt64" =:= negInt64 / posInt64 -- this is the same as the current int64 definition but without zero positive_coin :: Rule -positive_coin = "positive_coin" =:= 1 ... 18446744073709551615 +positive_coin = "positive_coin" =:= int 1 ... int 18446744073709551615 value :: Rule value = "value" =:= coin / sarr [a coin, a (multiasset positive_coin)] @@ -785,7 +785,7 @@ mint :: Rule mint = "mint" =:= multiasset nonZeroInt64 int64 :: Rule -int64 = "int64" =:= (-9223372036854775808) ... 9223372036854775807 +int64 = "int64" =:= int (-9223372036854775808) ... int 9223372036854775807 network_id :: Rule network_id = "network_id" =:= int 0 / int 1 @@ -900,7 +900,7 @@ nonempty_oset :: (IsType0 t0) => t0 -> GRuleCall nonempty_oset = nonempty_set positive_int :: Rule -positive_int = "positive_int" =:= 1 ... 18446744073709551615 +positive_int = "positive_int" =:= int 1 ... int 18446744073709551615 unit_interval :: Rule unit_interval = "unit_interval" =:= tag 30 (arr [1, 2]) diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs index 842853d..ae0e1fd 100644 --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -234,7 +234,7 @@ instance Num ArrayEntry where fromInteger i = ArrayEntry Nothing - (NoChoice . T2Literal . Unranged $ LInt (fromIntegral i)) + (NoChoice . T2Range . Unranged $ LInt (fromIntegral i)) def Nothing (+) = error "Cannot treat ArrayEntry as a number" @@ -265,7 +265,7 @@ instance IsList Group where data Type2 = T2Constrained Constrained - | T2Literal Ranged + | T2Range Ranged | T2Map Map | T2Array Array | T2Tagged (Tagged Type0) @@ -280,7 +280,7 @@ data Type2 type Type0 = Choice Type2 instance Num Type0 where - fromInteger i = NoChoice . T2Literal . Unranged $ LInt (fromIntegral i) + fromInteger i = NoChoice . T2Range . Unranged $ LInt (fromIntegral i) (+) = error "Cannot treat Type0 as a number" (*) = error "Cannot treat Type0 as a number" abs = error "Cannot treat Type0 as a number" @@ -512,20 +512,36 @@ le v bound = -- Ranges +data RangeBound = + RangeBoundLiteral Literal + | RangeBoundRef (Named Type0) + deriving Show + +class IsRangeBound a where + toRangeBound :: a -> RangeBound + +instance IsRangeBound Literal where + toRangeBound = RangeBoundLiteral + +instance IsRangeBound Integer where + toRangeBound = RangeBoundLiteral . inferInteger + +instance IsRangeBound (Named Type0) where + toRangeBound = RangeBoundRef + data Ranged where Ranged :: - { lb :: Literal, - ub :: Literal, + { lb :: RangeBound, + ub :: RangeBound, bounds :: C.RangeBound } -> Ranged Unranged :: Literal -> Ranged deriving (Show) --- | Establish a closed range bound. Currently specialised to Int for type --- inference purposes. -(...) :: Integer -> Integer -> Ranged -l ... u = Ranged (inferInteger l) (inferInteger u) C.Closed +-- | Establish a closed range bound. +(...) :: (IsRangeBound a, IsRangeBound b) => a -> b -> Ranged +l ... u = Ranged (toRangeBound l) (toRangeBound u) C.Closed infixl 9 ... @@ -558,27 +574,27 @@ instance IsType0 ArrayChoice where toType0 = NoChoice . T2Array . NoChoice instance IsType0 Ranged where - toType0 = NoChoice . T2Literal + toType0 = NoChoice . T2Range instance IsType0 Literal where - toType0 = NoChoice . T2Literal . Unranged + toType0 = NoChoice . T2Range . Unranged -- We also allow going directly from primitive types to Type2 instance IsType0 Integer where - toType0 = NoChoice . T2Literal . Unranged . inferInteger + toType0 = NoChoice . T2Range . Unranged . inferInteger instance IsType0 T.Text where toType0 :: T.Text -> Type0 - toType0 = NoChoice . T2Literal . Unranged . LText + toType0 = NoChoice . T2Range . Unranged . LText instance IsType0 ByteString where - toType0 = NoChoice . T2Literal . Unranged . LBytes + toType0 = NoChoice . T2Range . Unranged . LBytes instance IsType0 Float where - toType0 = NoChoice . T2Literal . Unranged . LFloat + toType0 = NoChoice . T2Range . Unranged . LFloat instance IsType0 Double where - toType0 = NoChoice . T2Literal . Unranged . LDouble + toType0 = NoChoice . T2Range . Unranged . LDouble instance IsType0 (Value a) where toType0 = NoChoice . T2Constrained . unconstrained @@ -722,7 +738,7 @@ instance IsChoosable GRef Type2 where toChoice = toChoice . T2GenericRef instance IsChoosable ByteString Type2 where - toChoice = toChoice . T2Literal . Unranged . LBytes + toChoice = toChoice . T2Range . Unranged . LBytes instance IsChoosable Constrained Type2 where toChoice = toChoice . T2Constrained @@ -731,7 +747,7 @@ instance (IsType0 a) => IsChoosable (Tagged a) Type2 where toChoice = toChoice . T2Tagged . fmap toType0 instance IsChoosable Literal Type2 where - toChoice = toChoice . T2Literal . Unranged + toChoice = toChoice . T2Range . Unranged instance IsChoosable (Value a) Type2 where toChoice = toChoice . T2Constrained . unconstrained @@ -944,6 +960,7 @@ collectFrom topRs = goChoice f (NoChoice x) = f x goChoice f (ChoiceOf x xs) = f x >> goChoice f xs goT0 = goChoice goT2 + goT2 (T2Range r) = goRanged r goT2 (T2Map m) = goChoice (mapM_ goMapEntry . unMapChoice) m goT2 (T2Array m) = goChoice (mapM_ goArrayEntry . unArrayChoice) m goT2 (T2Tagged (Tagged _ t0)) = goT0 t0 @@ -975,7 +992,11 @@ collectFrom topRs = goKey (TypeKey k) = goT2 k goKey _ = pure () goGroup (Group g) = mapM_ goT0 g - + goRanged (Unranged _) = pure () + goRanged (Ranged lb ub _) = goRangeBound lb >> goRangeBound ub + goRangeBound (RangeBoundLiteral _) = pure () + goRangeBound (RangeBoundRef r) = goRule r + -------------------------------------------------------------------------------- -- Conversion to CDDL -------------------------------------------------------------------------------- @@ -1052,7 +1073,7 @@ toCDDL' mkPseudoRoot hdl = T2Constrained (Constrained x constr _) -> -- TODO Need to handle choices at the top level applyConstraint constr (C.T2Name (toCDDLConstrainable x) Nothing) - T2Literal l -> toCDDLRanged l + T2Range l -> toCDDLRanged l T2Map m -> C.Type1 (C.T2Map $ mapToCDDLGroup m) @@ -1112,8 +1133,12 @@ toCDDL' mkPseudoRoot hdl = C.Type1 (C.T2Value $ toCDDLValue x) Nothing toCDDLRanged (Ranged lb ub rop) = C.Type1 - (C.T2Value $ toCDDLValue lb) - (Just (C.RangeOp rop, C.T2Value $ toCDDLValue ub)) + (toCDDLRangeBound lb) + (Just (C.RangeOp rop, toCDDLRangeBound ub)) + + toCDDLRangeBound :: RangeBound -> C.Type2 + toCDDLRangeBound (RangeBoundLiteral l) = C.T2Value $ toCDDLValue l + toCDDLRangeBound (RangeBoundRef (Named n _ _)) = C.T2Name (C.Name n) Nothing toCDDLGroup :: Named Group -> C.WithComments C.Rule toCDDLGroup (Named n (Group t0s) c) = diff --git a/test/Test/Codec/CBOR/Cuddle/Huddle.hs b/test/Test/Codec/CBOR/Cuddle/Huddle.hs index 27cdfda..7ccfba2 100644 --- a/test/Test/Codec/CBOR/Cuddle/Huddle.hs +++ b/test/Test/Codec/CBOR/Cuddle/Huddle.hs @@ -114,10 +114,15 @@ genericSpec = constraintSpec :: Spec constraintSpec = - describe "Constraints" $ + describe "Constraints" $ do it "Size can take a Word" $ toSortedCDDL (collectFrom ["sz" =:= VUInt `sized` (2 :: Word)]) `shouldMatchParseCDDL` "sz = uint .size 2" + + it "Range bound can take a reference" $ + let b = "b" =:= (16 :: Integer) in + toSortedCDDL (collectFrom ["b" =:= (16 :: Integer), "c" =:= int 0 ... b]) + `shouldMatchParseCDDL` "b = 16\n c = 0 .. b" -------------------------------------------------------------------------------- -- Helper functions --------------------------------------------------------------------------------