diff --git a/example/Conway.hs b/example/Conway.hs index 6936dda..6f0c173 100644 --- a/example/Conway.hs +++ b/example/Conway.hs @@ -10,14 +10,14 @@ module Conway where import Codec.CBOR.Cuddle.Huddle import Data.Function (($)) -import Data.Int (Int, Int64) import Data.Semigroup ((<>)) import Data.Text qualified as T +import Data.Word (Word64) import GHC.Float (Double) -import GHC.Num () +import GHC.Num (Integer) import GHC.Show (Show (show)) -default (Int, Double) +default (Integer, Double) conway :: Huddle conway = collectFrom block @@ -46,7 +46,7 @@ transaction = ] transaction_index :: Rule -transaction_index = "transaction_index" =:= VUInt `sized` (2 :: Int) +transaction_index = "transaction_index" =:= VUInt `sized` (2 :: Word64) header :: Rule header = "header" =:= arr [a header_body, "body_signature" ==> kes_signature] @@ -81,10 +81,10 @@ protocol_version :: Named Group protocol_version = "protocol_version" =:~ grp [a major_protocol_version, a VUInt] next_major_protocol_version :: Rule -next_major_protocol_version = "next_major_protocol_version" =:= (10 :: Int64) +next_major_protocol_version = "next_major_protocol_version" =:= (10 :: Integer) major_protocol_version :: Rule -major_protocol_version = "major_protocol_version" =:= (1 :: Int64) +major_protocol_version = "major_protocol_version" =:= (1 :: Integer) transaction_body :: Rule transaction_body = @@ -412,13 +412,13 @@ port :: Rule port = "port" =:= VUInt `le` 65535 ipv4 :: Rule -ipv4 = "ipv4" =:= VBytes `sized` (4 :: Int) +ipv4 = "ipv4" =:= VBytes `sized` (4 :: Word64) ipv6 :: Rule -ipv6 = "ipv6" =:= VBytes `sized` (16 :: Int) +ipv6 = "ipv6" =:= VBytes `sized` (16 :: Word64) dns_name :: Rule -dns_name = "dns_name" =:= VText `sized` (0 :: Int, 128 :: Int) +dns_name = "dns_name" =:= VText `sized` (0 :: Word64, 128 :: Word64) single_host_addr :: Named Group single_host_addr = @@ -460,7 +460,7 @@ pool_metadata :: Rule pool_metadata = "pool_metadata" =:= arr [a url, a pool_metadata_hash] url :: Rule -url = "url" =:= VText `sized` (0 :: Int, 128 :: Int) +url = "url" =:= VText `sized` (0 :: Word64, 128 :: Word64) withdrawals :: Rule withdrawals = "withdrawals" =:= mp [1 <+ asKey reward_account ==> coin] @@ -663,8 +663,8 @@ transaction_metadatum = =:= smp [0 <+ asKey transaction_metadatum ==> transaction_metadatum] // sarr [0 <+ a transaction_metadatum] // VInt - // (VBytes `sized` (0 :: Int, 64 :: Int)) - // (VText `sized` (0 :: Int, 64 :: Int)) + // (VBytes `sized` (0 :: Word64, 64 :: Word64)) + // (VText `sized` (0 :: Word64, 64 :: Word64)) transaction_metadatum_label :: Rule transaction_metadatum_label = "transaction_metadatum_label" =:= VUInt @@ -703,7 +703,7 @@ bootstrap_witness = =:= arr [ "public_key" ==> vkey, "signature" ==> signature, - "chain_code" ==> (VBytes `sized` (32 :: Int)), + "chain_code" ==> (VBytes `sized` (32 :: Word64)), "attributes" ==> VBytes ] @@ -756,7 +756,7 @@ policy_id :: Rule policy_id = "policy_id" =:= scripthash asset_name :: Rule -asset_name = "asset_name" =:= VBytes `sized` (0 :: Int, 32 :: Int) +asset_name = "asset_name" =:= VBytes `sized` (0 :: Word64, 32 :: Word64) negInt64 :: Rule negInt64 = "negInt64" =:= (-9223372036854775808) ... (-1) @@ -847,31 +847,31 @@ script = -------------------------------------------------------------------------------- hash28 :: Rule -hash28 = "hash28" =:= VBytes `sized` (28 :: Int) +hash28 = "hash28" =:= VBytes `sized` (28 :: Word64) hash32 :: Rule -hash32 = "hash32" =:= VBytes `sized` (32 :: Int) +hash32 = "hash32" =:= VBytes `sized` (32 :: Word64) vkey :: Rule -vkey = "vkey" =:= VBytes `sized` (32 :: Int) +vkey = "vkey" =:= VBytes `sized` (32 :: Word64) vrf_vkey :: Rule -vrf_vkey = "vrf_vkey" =:= VBytes `sized` (32 :: Int) +vrf_vkey = "vrf_vkey" =:= VBytes `sized` (32 :: Word64) vrf_cert :: Rule -vrf_cert = "vrf_cert" =:= arr [a VBytes, a (VBytes `sized` (80 :: Int))] +vrf_cert = "vrf_cert" =:= arr [a VBytes, a (VBytes `sized` (80 :: Word64))] kes_vkey :: Rule -kes_vkey = "kes_vkey" =:= VBytes `sized` (32 :: Int) +kes_vkey = "kes_vkey" =:= VBytes `sized` (32 :: Word64) kes_signature :: Rule -kes_signature = "kes_signature" =:= VBytes `sized` (448 :: Int) +kes_signature = "kes_signature" =:= VBytes `sized` (448 :: Word64) signkeyKES :: Rule -signkeyKES = "signkeyKES" =:= VBytes `sized` (64 :: Int) +signkeyKES = "signkeyKES" =:= VBytes `sized` (64 :: Word64) signature :: Rule -signature = "signature" =:= VBytes `sized` (64 :: Int) +signature = "signature" =:= VBytes `sized` (64 :: Word64) -------------------------------------------------------------------------------- -- Extras @@ -934,7 +934,7 @@ reward_account = // bstr "F0A0000000000000000000000000000000000000000000000000000000" bounded_bytes :: Rule -bounded_bytes = "bounded_bytes" =:= VBytes `sized` (0 :: Int, 64 :: Int) +bounded_bytes = "bounded_bytes" =:= VBytes `sized` (0 :: Word64, 64 :: Word64) -- the real bounded_bytes does not have this limit. it instead has a different -- limit which cannot be expressed in CDDL. @@ -952,9 +952,9 @@ distinct :: (IsSizeable s) => Value s -> Rule distinct x = "distinct_" <> T.pack (show x) - =:= (x `sized` (8 :: Int)) - // (x `sized` (16 :: Int)) - // (x `sized` (20 :: Int)) - // (x `sized` (24 :: Int)) - // (x `sized` (30 :: Int)) - // (x `sized` (32 :: Int)) + =:= (x `sized` (8 :: Word64)) + // (x `sized` (16 :: Word64)) + // (x `sized` (20 :: Word64)) + // (x `sized` (24 :: Word64)) + // (x `sized` (30 :: Word64)) + // (x `sized` (32 :: Word64)) diff --git a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs index b62d5d4..3737215 100644 --- a/src/Codec/CBOR/Cuddle/CBOR/Gen.hs +++ b/src/Codec/CBOR/Cuddle/CBOR/Gen.hs @@ -271,8 +271,8 @@ genForCTree (CTree.Control op target controller) = do tt <- resolveIfRef target ct <- resolveIfRef controller case (op, ct) of - (CtlOp.Size, CTree.Literal (VNum n)) -> case tt of - CTree.Postlude PTBytes -> S . TBytes <$> genBytes n + (CtlOp.Size, CTree.Literal (VUInt n)) -> case tt of + CTree.Postlude PTBytes -> S . TBytes <$> genBytes (fromIntegral n) CTree.Postlude PTUInt -> S . TInteger <$> genUniformRM (0, 2 ^ n - 1) _ -> error "Cannot apply size operator to target " (CtlOp.Size, _) -> @@ -344,7 +344,12 @@ applyOccurenceIndicator (OIBounded mlb mub) oldGen = >>= \i -> G <$> replicateM i oldGen genValue :: Value -> Gen Term -genValue (VNum i) = pure . TInteger $ fromIntegral i +genValue (VUInt i) = pure . TInt $ fromIntegral i +genValue (VNInt i) = pure . TInt $ fromIntegral (-i) +genValue (VBignum i) = pure $ TInteger i +genValue (VFloat16 i) = pure . THalf $ i +genValue (VFloat32 i) = pure . TFloat $ i +genValue (VFloat64 i) = pure . TDouble $ i genValue (VText t) = pure $ TString t genValue (VBytes b) = pure $ TBytes b diff --git a/src/Codec/CBOR/Cuddle/CDDL.hs b/src/Codec/CBOR/Cuddle/CDDL.hs index 0089a30..7296e97 100644 --- a/src/Codec/CBOR/Cuddle/CDDL.hs +++ b/src/Codec/CBOR/Cuddle/CDDL.hs @@ -7,6 +7,7 @@ import Data.ByteString qualified as B import Data.Hashable (Hashable) import Data.List.NonEmpty qualified as NE import Data.Text qualified as T +import Data.Word (Word64) import GHC.Generics (Generic) newtype CDDL = CDDL (NE.NonEmpty (WithComments Rule)) @@ -293,8 +294,12 @@ data MemberKey deriving (Eq, Generic, Show) data Value - = -- Should be bigger than just Int - VNum Int + = VUInt Word64 + | VNInt Word64 + | VBignum Integer + | VFloat16 Float + | VFloat32 Float + | VFloat64 Double | VText T.Text | VBytes B.ByteString deriving (Eq, Generic, Show) diff --git a/src/Codec/CBOR/Cuddle/Huddle.hs b/src/Codec/CBOR/Cuddle/Huddle.hs index da55b33..84fe44f 100644 --- a/src/Codec/CBOR/Cuddle/Huddle.hs +++ b/src/Codec/CBOR/Cuddle/Huddle.hs @@ -92,7 +92,6 @@ import Control.Monad.State (MonadState (get), execState, modify) import Data.ByteString (ByteString) import Data.Default.Class (Default (..)) import Data.Generics.Product (HasField, field) -import Data.Int (Int64) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as HaskMap import Data.String (IsString (fromString)) @@ -100,6 +99,7 @@ import Data.Text qualified as T import Data.Tuple.Optics (Field1 (..), Field2 (..), Field3 (..)) import Data.Void (Void) import GHC.Exts (IsList (Item, fromList, toList)) +import Data.Word (Word64) import GHC.Generics (Generic) import Optics.Core (over, view, (%~), (&), (.~)) import Prelude hiding ((/)) @@ -159,7 +159,7 @@ instance IsString Key where fromString = LiteralKey . LText . T.pack -- | Use a number as a key -idx :: Int64 -> Key +idx :: Word64 -> Key idx = LiteralKey . LInt asKey :: (IsType0 r) => r -> Key @@ -282,15 +282,19 @@ deriving instance Show (Value a) -------------------------------------------------------------------------------- data Literal where - LInt :: Int64 -> Literal + -- | We store both int and nint as a Word64, since the sign is indicated in + -- the type. + LInt :: Word64 -> Literal + LNInt :: Word64 -> Literal + LBignum :: Integer -> Literal LText :: T.Text -> Literal LFloat :: Float -> Literal LDouble :: Double -> Literal LBytes :: ByteString -> Literal deriving (Show) -int :: Int64 -> Literal -int = LInt +int :: Integer -> Literal +int = inferInteger bstr :: ByteString -> Literal bstr = LBytes @@ -298,6 +302,12 @@ bstr = LBytes text :: T.Text -> Literal text = LText +inferInteger :: Integer -> Literal +inferInteger i + | i >= 0 && i < fromIntegral (maxBound @Word64) = LInt (fromInteger i) + | i < 0 && (-i) < fromIntegral (maxBound @Word64) = LNInt (fromInteger (-i)) + | otherwise = LBignum i + -------------------------------------------------------------------------------- -- Constraints and Ranges -------------------------------------------------------------------------------- @@ -348,17 +358,17 @@ class IsSize a where sizeAsCDDL :: a -> C.Type2 sizeAsString :: a -> String -instance IsSize Int where - sizeAsCDDL = C.T2Value . C.VNum +instance IsSize Word64 where + sizeAsCDDL = C.T2Value . C.VUInt sizeAsString = show -instance IsSize (Int, Int) where +instance IsSize (Word64, Word64) where sizeAsCDDL (x, y) = C.T2Group ( C.Type0 ( C.Type1 - (C.T2Value (C.VNum x)) - (Just (C.RangeOp C.Closed, C.T2Value (C.VNum y))) + (C.T2Value (C.VUInt x)) + (Just (C.RangeOp C.Closed, C.T2Value (C.VUInt y))) NE.:| [] ) ) @@ -387,14 +397,14 @@ cbor v (Named n _ _) = showConstraint = ".cbor " <> T.unpack n } -le :: Value Int -> Int64 -> Constrained +le :: Value Int -> Word64 -> Constrained le v bound = Constrained v $ ValueConstraint { applyConstraint = \t2 -> C.Type1 t2 - (Just (C.CtrlOp CtlOp.Le, C.T2Value (C.VNum $ fromIntegral bound))), + (Just (C.CtrlOp CtlOp.Le, C.T2Value (C.VUInt $ fromIntegral bound))), showConstraint = ".le " <> show bound } @@ -412,8 +422,8 @@ data Ranged where -- | Establish a closed range bound. Currently specialised to Int for type -- inference purposes. -(...) :: Int64 -> Int64 -> Ranged -l ... u = Ranged (LInt l) (LInt u) C.Closed +(...) :: Integer -> Integer -> Ranged +l ... u = Ranged (inferInteger l) (inferInteger u) C.Closed infixl 9 ... @@ -452,8 +462,8 @@ instance IsType0 Literal where toType0 = NoChoice . T2Literal . Unranged -- We also allow going directly from primitive types to Type2 -instance IsType0 Int64 where - toType0 = NoChoice . T2Literal . Unranged . LInt +instance IsType0 Integer where + toType0 = NoChoice . T2Literal . Unranged . inferInteger instance IsType0 T.Text where toType0 :: T.Text -> Type0 @@ -837,10 +847,13 @@ toCDDL hdl = ) (fmap C.Comment c) toCDDLValue :: Literal -> C.Value - toCDDLValue (LInt i) = C.VNum $ fromIntegral i + toCDDLValue (LInt i) = C.VUInt i + toCDDLValue (LNInt i) = C.VNInt i + toCDDLValue (LBignum i) = C.VBignum i + toCDDLValue (LFloat i) = C.VFloat32 i + toCDDLValue (LDouble d) = C.VFloat64 d toCDDLValue (LText t) = C.VText t toCDDLValue (LBytes b) = C.VBytes b - toCDDLValue _ = error "I haven't done this bit yet" mapToCDDLGroup :: Map -> C.Group mapToCDDLGroup xs = C.Group $ mapChoiceToCDDL <$> choiceToNE xs diff --git a/src/Codec/CBOR/Cuddle/Parser.hs b/src/Codec/CBOR/Cuddle/Parser.hs index d835f33..eccc345 100644 --- a/src/Codec/CBOR/Cuddle/Parser.hs +++ b/src/Codec/CBOR/Cuddle/Parser.hs @@ -202,13 +202,17 @@ pOccur = pValue :: Parser Value pValue = choice - [ pNumber, + [ try pUInt, + try pNInt, + pFloat, pText ] where -- Need to ensure that number values are not actually bounds on a later -- value. - pNumber = VNum <$> L.decimal <* notFollowedBy (char '*') + pUInt = VUInt <$> L.decimal <* notFollowedBy (oneOf ['*', '.']) + pNInt = VNInt <$> (char '-' *> L.decimal <* notFollowedBy (oneOf ['*', '.'])) + pFloat = VFloat64 <$> L.float pText = VText <$> (char '"' *> pSChar <* char '"') -- Currently this doesn't allow string escaping pSChar :: Parser Text diff --git a/src/Codec/CBOR/Cuddle/Pretty.hs b/src/Codec/CBOR/Cuddle/Pretty.hs index c0694ac..74fbe5a 100644 --- a/src/Codec/CBOR/Cuddle/Pretty.hs +++ b/src/Codec/CBOR/Cuddle/Pretty.hs @@ -114,6 +114,11 @@ instance Pretty MemberKey where pretty (MKValue v) = pretty v <+> ":" instance Pretty Value where - pretty (VNum i) = pretty i + pretty (VUInt i) = pretty i + pretty (VNInt i) = "-" <> pretty i + pretty (VBignum i) = pretty i + pretty (VFloat16 i) = pretty i + pretty (VFloat32 i) = pretty i + pretty (VFloat64 i) = pretty i pretty (VText t) = enclose "\"" "\"" $ pretty t pretty (VBytes b) = fromString $ "h" <> "'" <> BS.unpack b <> "'" diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs index 8df16c9..b044d6e 100644 --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Gen.hs @@ -127,7 +127,11 @@ genMemberKey = genValue :: (MonadGen m) => m Value genValue = Gen.choice - [ VNum <$> Gen.int (Range.linear 0 255), + [ VUInt <$> Gen.word64 (Range.linear 0 255), + VNInt <$> Gen.word64 (Range.linear 0 255), + VFloat16 <$> Gen.float (Range.linearFrac 0.0 10.0), + VFloat32 <$> Gen.float (Range.linearFrac 0.0 10.0), + VFloat64 <$> Gen.double (Range.linearFrac 0.0 200), VText <$> Gen.text (Range.linear 0 1000) Gen.alphaNum -- VBytes <$> Gen.bytes (Range.linear 0 1100) ] diff --git a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs index 8bd31a3..8674480 100644 --- a/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs +++ b/test/Test/Codec/CBOR/Cuddle/CDDL/Parser.hs @@ -56,7 +56,11 @@ roundtripSpec = describe "Roundtripping should be id" $ do valueSpec :: Spec valueSpec = describe "pValue" $ do it "Parses integer" $ - parse pValue "" "123" `shouldParse` VNum 123 + parse pValue "" "123" `shouldParse` VUInt 123 + it "Parses negative integer" $ + parse pValue "" "-123" `shouldParse` VNInt 123 + it "Parses float" $ + parse pValue "" "3.1415" `shouldParse` VFloat64 3.1415 it "Parses text" $ parse pValue "" "\"Hello World\"" `shouldParse` VText "Hello World" @@ -105,7 +109,7 @@ genericSpec = describe "generics" $ do ( Just ( GenericArg ( Type1 - (T2Value (VNum 0)) + (T2Value (VUInt 0)) Nothing NE.:| [] ) @@ -131,8 +135,8 @@ genericSpec = describe "generics" $ do ( Just ( GenericArg ( Type1 - (T2Value (VNum 0)) - (Just (RangeOp ClOpen, T2Value (VNum 1))) + (T2Value (VUInt 0)) + (Just (RangeOp ClOpen, T2Value (VUInt 1))) NE.:| [] ) ) @@ -148,7 +152,7 @@ type2Spec :: SpecWith () type2Spec = describe "type2" $ do describe "Value" $ do it "Parses a value" $ - parse pType2 "" "123" `shouldParse` T2Value (VNum 123) + parse pType2 "" "123" `shouldParse` T2Value (VUInt 123) describe "Map" $ do it "Parses a basic group" $ parse pType2 "" "{ int => string }" @@ -212,12 +216,12 @@ type2Spec = describe "type2" $ do ( [ GEType Nothing Nothing - (Type0 (NE.singleton (Type1 (T2Value (VNum 0)) Nothing))) + (Type0 (NE.singleton (Type1 (T2Value (VUInt 0)) Nothing))) ] NE.:| [ [ GEType Nothing Nothing - (Type0 (NE.singleton (Type1 (T2Value (VNum 1)) Nothing))) + (Type0 (NE.singleton (Type1 (T2Value (VUInt 1)) Nothing))) ] ] ) @@ -261,10 +265,10 @@ grpEntrySpec = describe "GroupEntry" $ do ( Just ( GenericArg ( Type1 - (T2Value (VNum 0)) + (T2Value (VUInt 0)) ( Just ( RangeOp ClOpen, - T2Tag Nothing (Type0 (Type1 (T2Value (VNum 0)) Nothing NE.:| [])) + T2Tag Nothing (Type0 (Type1 (T2Value (VUInt 0)) Nothing NE.:| [])) ) ) NE.:| [] @@ -306,15 +310,15 @@ type1Spec = describe "Type1" $ do parse pType1 "" "uint .size 3" `shouldParse` Type1 (T2Name (Name "uint") Nothing) - (Just (CtrlOp CtlOp.Size, T2Value (VNum 3))) + (Just (CtrlOp CtlOp.Size, T2Value (VUInt 3))) describe "RangeOp" $ do it "Should parse a closed range operator" $ parse pType1 "" "0 .. 3" `shouldParse` Type1 - (T2Value (VNum 0)) - (Just (RangeOp Closed, T2Value (VNum 3))) + (T2Value (VUInt 0)) + (Just (RangeOp Closed, T2Value (VUInt 3))) it "Should parse a clopen range operator" $ parse pType1 "" "0 ... 3" `shouldParse` Type1 - (T2Value (VNum 0)) - (Just (RangeOp ClOpen, T2Value (VNum 3))) + (T2Value (VUInt 0)) + (Just (RangeOp ClOpen, T2Value (VUInt 3)))