Merge pull request #23 from input-output-hk/nc/numbers

Fix handling of numbers.

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

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
 

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)

src/Codec/CBOR/Cuddle/Huddle.hs

@@ -92,14 +92,14 @@ 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))
 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,22 +282,32 @@ 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
 
 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

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

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

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