Merge pull request #43 from input-output-hk/nc/ref-range

Support references in ranges

Author: nc6

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` 

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:

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

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

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