diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Changelog +## [0.4.0.0] - 2024-07-26 + +This is technically a breaking change but it's unlikely that you'll need to +change any of your codecs. + +### Changed + +* Changed `NumberBounds` to `Bounds` and made both bounds optional. +* Added `IntegerCodec` as distinct from `NumberCodec` to represent integers + effectively in documentation. + ## [0.3.0.0] - 2024-07-19 ### Added diff --git a/autodocodec.cabal b/autodocodec.cabal --- a/autodocodec.cabal +++ b/autodocodec.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: autodocodec -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Self-documenting encoder and decoder homepage: https://github.com/NorfairKing/autodocodec#readme bug-reports: https://github.com/NorfairKing/autodocodec/issues diff --git a/src/Autodocodec.hs b/src/Autodocodec.hs --- a/src/Autodocodec.hs +++ b/src/Autodocodec.hs @@ -74,14 +74,20 @@ boolCodec, textCodec, stringCodec, + integerCodec, + integerWithBoundsCodec, scientificCodec, scientificWithBoundsCodec, valueCodec, + -- *** Bounds + Bounds (..), + emptyBounds, + boundedBounds, + checkBounds, + -- *** Integral codecs boundedIntegralCodec, - boundedIntegralNumberBounds, - integerCodec, unsafeUnboundedIntegerCodec, naturalCodec, unsafeUnboundedNaturalCodec, diff --git a/src/Autodocodec/Aeson/Decode.hs b/src/Autodocodec/Aeson/Decode.hs --- a/src/Autodocodec/Aeson/Decode.hs +++ b/src/Autodocodec/Aeson/Decode.hs @@ -29,6 +29,7 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) +import Data.Scientific as Scientific import Data.Text (Text) import qualified Data.Text as T import Data.Vector (Vector) @@ -69,13 +70,36 @@ StringCodec mname -> case mname of Nothing -> coerce (parseJSON value :: JSON.Parser Text) Just name -> coerce $ withText (T.unpack name) pure value - NumberCodec mname mBounds -> + IntegerCodec mname bounds -> coerce $ + ( \f -> do + let safetyBounds = + Bounds + { boundsLower = Just $ scientific (-1) 1024, + boundsUpper = Just $ scientific 1 1024 + } + checkSafetyBounds s = + case checkBounds safetyBounds s of + Left err -> fail err + Right i' -> pure i' + s <- case mname of + Nothing -> parseJSON value >>= checkSafetyBounds + Just name -> withScientific (T.unpack name) checkSafetyBounds value + case Scientific.floatingOrInteger s :: Either Double Integer of + Left _ -> fail $ "Number was not integer: " <> show s + Right i -> f (i :: Integer) + ) + ( \i -> case checkBounds bounds i of + Left err -> fail err + Right i' -> pure i' + ) + NumberCodec mname bounds -> + coerce $ ( \f -> case mname of Nothing -> parseJSON value >>= f Just name -> withScientific (T.unpack name) f value ) - ( \s -> case maybe Right checkNumberBounds mBounds s of + ( \s -> case checkBounds bounds s of Left err -> fail err Right s' -> pure s' ) diff --git a/src/Autodocodec/Aeson/Encode.hs b/src/Autodocodec/Aeson/Encode.hs --- a/src/Autodocodec/Aeson/Encode.hs +++ b/src/Autodocodec/Aeson/Encode.hs @@ -76,6 +76,7 @@ NullCodec -> JSON.Null BoolCodec _ -> toJSON (coerce a :: Bool) StringCodec _ -> toJSON (coerce a :: Text) + IntegerCodec _ _ -> toJSON (coerce a :: Integer) NumberCodec _ _ -> toJSON (coerce a :: Scientific) ArrayOfCodec _ c -> toJSON (fmap (`go` c) (coerce a :: Vector _)) ObjectOfCodec _ oc -> JSON.Object (toJSONObjectVia oc a) @@ -131,6 +132,7 @@ NullCodec -> JSON.null_ BoolCodec _ -> JSON.bool (coerce a :: Bool) StringCodec _ -> JSON.text (coerce a :: Text) + IntegerCodec _ _ -> JSON.scientific (fromInteger (coerce a :: Integer) :: Scientific) NumberCodec _ _ -> JSON.scientific (coerce a :: Scientific) ArrayOfCodec _ c -> JSON.list (`go` c) (V.toList (coerce a :: Vector _)) ObjectOfCodec _ oc -> JSON.pairs (toSeriesVia oc a) diff --git a/src/Autodocodec/Codec.hs b/src/Autodocodec/Codec.hs --- a/src/Autodocodec/Codec.hs +++ b/src/Autodocodec/Codec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} @@ -98,9 +99,24 @@ -- | Name of the @string@, for error messages and documentation. Maybe Text -> ValueCodec a b + -- | Encode 'Integer' to a @number@ value, and decode a @number@ value as an 'Integer'. + -- + -- The number has 'Bounds Integer'. + -- These are only enforced at decoding time, not at encoding-time. + -- + -- NOTE: Decoding 'Integer's is dangerous so decoding may fail for enormous numbers. + -- API NOTE: This is separate from 'NumberCodec' so that we can produce + -- more precise documentation about whether the numbers are integers. + IntegerCodec :: + (Coercible a Integer, Coercible b Integer) => + -- | Name of the @integer@, for error messages and documentation. + Maybe Text -> + -- | Bounds for the integer, these are checked and documented + Bounds Integer -> + ValueCodec a b -- | Encode 'Scientific' to a @number@ value, and decode a @number@ value as a 'Scientific'. -- - -- The number has optional 'NumberBounds'. + -- The number has 'Bounds Scientific'. -- These are only enforced at decoding time, not at encoding-time. -- -- NOTE: We use 'Scientific' here because that is what aeson uses. @@ -109,7 +125,7 @@ -- | Name of the @number@, for error messages and documentation. Maybe Text -> -- | Bounds for the number, these are checked and documented - Maybe NumberBounds -> + Bounds Scientific -> ValueCodec a b -- | Encode a 'HashMap', and decode any 'HashMap'. HashMapCodec :: @@ -279,72 +295,68 @@ ObjectCodec input output -> ObjectCodec input newOutput -data NumberBounds = NumberBounds - { numberBoundsLower :: !Scientific, - numberBoundsUpper :: !Scientific +data Bounds a = Bounds + { -- | Lower bound, inclusive + boundsLower :: !(Maybe a), + -- Upper bound, inclusive + boundsUpper :: !(Maybe a) } - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Ord, Generic, Functor) -instance Validity NumberBounds +instance (Validity a) => Validity (Bounds a) -optionalKeyWithDefaultCodec :: - -- | Key - Text -> - -- | Codec for the value - ValueCodec value value -> - -- | Default value - value -> - -- | Documentation - Maybe Text -> - ObjectCodec value value -optionalKeyWithDefaultCodec = OptionalKeyWithDefaultCodec +emptyBounds :: Bounds a +emptyBounds = Bounds Nothing Nothing +boundedBounds :: (Bounded a) => Bounds a +boundedBounds = + Bounds + { boundsLower = Just minBound, + boundsUpper = Just maxBound + } + -- | Check if a number falls within given 'NumberBounds'. -checkNumberBounds :: NumberBounds -> Scientific -> Either String Scientific -checkNumberBounds NumberBounds {..} s = - if numberBoundsLower <= s - then - if s <= numberBoundsUpper - then Right s - else Left $ unwords ["Number", show s, "is bigger than the upper bound", show numberBoundsUpper] - else Left $ unwords ["Number", show s, "is smaller than the lower bound", show numberBoundsUpper] +checkBounds :: (Show a, Ord a) => Bounds a -> a -> Either String a +checkBounds Bounds {..} s = + case boundsLower of + Just lo | s < lo -> Left $ unwords ["Number", show s, "is smaller than the lower bound", show lo] + _ -> case boundsUpper of + Just hi | s > hi -> Left $ unwords ["Number", show s, "is bigger than the upper bound", show hi] + _ -> Right s -data NumberBoundsSymbolic +data IntegerBoundsSymbolic = BitUInt !Word8 -- w bit unsigned int | BitSInt !Word8 -- w bit signed int - | OtherNumberBounds !ScientificSymbolic !ScientificSymbolic + | OtherIntegerBounds !(Maybe IntegerSymbolic) !(Maybe IntegerSymbolic) -guessNumberBoundsSymbolic :: NumberBounds -> NumberBoundsSymbolic -guessNumberBoundsSymbolic NumberBounds {..} = - case (guessScientificSymbolic numberBoundsLower, guessScientificSymbolic numberBoundsUpper) of - (Zero, PowerOf2MinusOne w) -> BitUInt w - (MinusPowerOf2 w1, PowerOf2MinusOne w2) | w1 == w2 -> BitSInt (succ w1) - (l, u) -> OtherNumberBounds l u +guessIntegerBoundsSymbolic :: Bounds Integer -> IntegerBoundsSymbolic +guessIntegerBoundsSymbolic Bounds {..} = + case (guessIntegerSymbolic <$> boundsLower, guessIntegerSymbolic <$> boundsUpper) of + (Just Zero, Just (PowerOf2MinusOne w)) -> BitUInt w + (Just (MinusPowerOf2 w1), Just (PowerOf2MinusOne w2)) | w1 == w2 -> BitSInt (succ w1) + (l, u) -> OtherIntegerBounds l u -data ScientificSymbolic +data IntegerSymbolic = Zero | PowerOf2 !Word8 -- 2^w | PowerOf2MinusOne !Word8 -- 2^w -1 | MinusPowerOf2 !Word8 -- - 2^w | MinusPowerOf2MinusOne !Word8 -- - (2^w -1) | OtherInteger !Integer - | OtherDouble !Double -guessScientificSymbolic :: Scientific -> ScientificSymbolic -guessScientificSymbolic s = case floatingOrInteger s of - Left d -> OtherDouble d - Right i -> - let log2Rounded :: Word8 - log2Rounded = round (logBase 2 (fromInteger (abs i)) :: Double) - guess :: Integer - guess = 2 ^ log2Rounded - in if - | i == 0 -> Zero - | guess == i -> PowerOf2 log2Rounded - | (guess - 1) == i -> PowerOf2MinusOne log2Rounded - | -guess == i -> MinusPowerOf2 log2Rounded - | -(guess - 1) == i -> MinusPowerOf2MinusOne log2Rounded - | otherwise -> OtherInteger i +guessIntegerSymbolic :: Integer -> IntegerSymbolic +guessIntegerSymbolic i = + let log2Rounded :: Word8 + log2Rounded = round (logBase 2 (fromInteger (abs i)) :: Double) + guess :: Integer + guess = 2 ^ log2Rounded + in if + | i == 0 -> Zero + | guess == i -> PowerOf2 log2Rounded + | (guess - 1) == i -> PowerOf2MinusOne log2Rounded + | -guess == i -> MinusPowerOf2 log2Rounded + | -(guess - 1) == i -> MinusPowerOf2MinusOne log2Rounded + | otherwise -> OtherInteger i -- | What type of union the encoding uses data Union @@ -398,6 +410,7 @@ NullCodec -> pure $ showString "NullCodec" BoolCodec mName -> pure $ showParen (d > 10) $ showString "BoolCodec " . showsPrec 11 mName StringCodec mName -> pure $ showParen (d > 10) $ showString "StringCodec " . showsPrec 11 mName + IntegerCodec mName mbs -> pure $ showParen (d > 10) $ showString "IntegerCodec " . showsPrec 11 mName . showString " " . showsPrec 11 mbs NumberCodec mName mbs -> pure $ showParen (d > 10) $ showString "NumberCodec " . showsPrec 11 mName . showString " " . showsPrec 11 mbs ArrayOfCodec mName c -> (\s -> showParen (d > 10) $ showString "ArrayOfCodec " . showsPrec 11 mName . showString " " . s) <$> go 11 c ObjectOfCodec mName oc -> (\s -> showParen (d > 10) $ showString "ObjectOfCodec " . showsPrec 11 mName . showString " " . s) <$> go 11 oc @@ -864,6 +877,18 @@ optionalKeyCodec :: Text -> ValueCodec input output -> Maybe Text -> ObjectCodec (Maybe input) (Maybe output) optionalKeyCodec = OptionalKeyCodec +optionalKeyWithDefaultCodec :: + -- | Key + Text -> + -- | Codec for the value + ValueCodec value value -> + -- | Default value + value -> + -- | Documentation + Maybe Text -> + ObjectCodec value value +optionalKeyWithDefaultCodec = OptionalKeyWithDefaultCodec + -- | Build a codec for nonempty lists of values from a codec for a single value. -- -- @@ -1319,14 +1344,67 @@ -- -- > scientificCodec = NumberCodec Nothing Nothing scientificCodec :: JSONCodec Scientific -scientificCodec = NumberCodec Nothing Nothing +scientificCodec = NumberCodec Nothing emptyBounds +-- | Codec for 'Integer' values +-- +-- This codec does a bounds check for the range [-10^1024, 10^1024] it can safely parse very large numbers. +-- +-- +-- === Example usage +-- +-- >>> toJSONVia integerCodec 5 +-- Number 5.0 +-- >>> toJSONVia integerCodec (-1000000000000) +-- Number (-1.0e12) +-- >>> JSON.parseMaybe (parseJSONVia integerCodec) (Number (-4.0)) +-- Just (-4) +-- >>> JSON.parseMaybe (parseJSONVia integerCodec) (Number (scientific 1 100000000)) +-- Nothing +-- +-- +-- ==== API Note +-- +-- This is a forward-compatible version of 'IntegerCodec' without a name. +-- +-- > scientificCodec = IntegerCodec Nothing Nothing +-- +-- For a codec without this protection, see 'unsafeUnboundedIntegerCodec'. +integerCodec :: JSONCodec Integer +integerCodec = IntegerCodec Nothing emptyBounds + +-- | A codec for 'Natural' values. +-- +-- This codec does a bounds check for the range [0, 10^1024] it can safely parse very large numbers. +-- +-- For a codec without this protection, see 'unsafeUnboundedNaturalCodec'. +-- +-- === Example usage +-- +-- >>> toJSONVia naturalCodec 5 +-- Number 5.0 +-- >>> toJSONVia naturalCodec (1000000000000) +-- Number 1.0e12 +-- >>> JSON.parseMaybe (parseJSONVia naturalCodec) (Number 4.0) +-- Just 4 +-- >>> JSON.parseMaybe (parseJSONVia naturalCodec) (Number (scientific 1 100000000)) +-- Nothing +naturalCodec :: JSONCodec Natural +naturalCodec = + dimapCodec fromIntegral fromIntegral $ + integerWithBoundsCodec + ( Bounds + { boundsLower = Just 0, + boundsUpper = Nothing + } + ) + -- | Codec for 'Scientific' values with bounds -- -- -- === Example usage -- --- >>> let c = scientificWithBoundsCodec NumberBounds {numberBoundsLower = 2, numberBoundsUpper = 4} +-- >>> let c = scientificWithBoundsCodec Bounds {boundsLower = Just 2, boundsUpper = Just 4} -- >>> toJSONVia c 3 -- Number 3.0 -- >>> toJSONVia c 5 @@ -1353,10 +1431,33 @@ -- -- This is a forward-compatible version of 'NumberCodec' without a name. -- --- > scientificWithBoundsCodec bounds = NumberCodec Nothing (Just bounds) -scientificWithBoundsCodec :: NumberBounds -> JSONCodec Scientific -scientificWithBoundsCodec bounds = NumberCodec Nothing (Just bounds) +-- > scientificWithBoundsCodec bounds = NumberCodec Nothing bounds +scientificWithBoundsCodec :: Bounds Scientific -> JSONCodec Scientific +scientificWithBoundsCodec bounds = NumberCodec Nothing bounds +-- | Codec for 'Integer' values with bounds +-- +-- +-- === Example usage +-- +-- >>> let c = integerWithBoundsCodec Bounds {boundsLower = Just 2, boundsUpper = Just 4} +-- >>> toJSONVia c 3 +-- Number 3.0 +-- >>> toJSONVia c 5 +-- Number 5.0 +-- >>> JSON.parseMaybe (parseJSONVia c) (Number 3) +-- Just 3 +-- >>> JSON.parseMaybe (parseJSONVia c) (Number 5) +-- Nothing +-- +-- ==== API Note +-- +-- This is a forward-compatible version of 'IntegerCodec' without a name. +-- +-- > integerWithBoundsCodec bounds = IntegerCodec Nothing bounds +integerWithBoundsCodec :: Bounds Integer -> JSONCodec Integer +integerWithBoundsCodec bounds = IntegerCodec Nothing bounds + -- | An object codec with a given name -- -- @@ -1396,51 +1497,13 @@ -- Nothing boundedIntegralCodec :: forall i. (Integral i, Bounded i) => JSONCodec i boundedIntegralCodec = - bimapCodec go fromIntegral $ scientificWithBoundsCodec (boundedIntegralNumberBounds @i) - where - go s = case Scientific.toBoundedInteger s of - Nothing -> Left $ "Number did not fit into bounded integer: " <> show s - Just i -> Right i + dimapCodec fromIntegral fromIntegral $ integerWithBoundsCodec (boundedIntegralBounds @i) -- | 'NumberBounds' for a bounded integral type. -- --- You can call this using @TypeApplications@: @boundedIntegralNumberBounds @Word@ -boundedIntegralNumberBounds :: forall i. (Integral i, Bounded i) => NumberBounds -boundedIntegralNumberBounds = - NumberBounds - { numberBoundsLower = fromIntegral (minBound :: i), - numberBoundsUpper = fromIntegral (maxBound :: i) - } - --- | A safe codec for 'Integer'. --- --- This codec does a bounds check for the range [-10^1024, 10^1024] it can safely parse very large numbers. --- --- For a codec without this protection, see 'unsafeUnboundedIntegerCodec'. --- --- === Example usage --- --- >>> toJSONVia integerCodec 5 --- Number 5.0 --- >>> toJSONVia integerCodec (-1000000000000) --- Number (-1.0e12) --- >>> JSON.parseMaybe (parseJSONVia integerCodec) (Number (-4.0)) --- Just (-4) --- >>> JSON.parseMaybe (parseJSONVia integerCodec) (Number (scientific 1 100000000)) --- Nothing -integerCodec :: JSONCodec Integer -integerCodec = - bimapCodec go fromIntegral $ - scientificWithBoundsCodec - ( NumberBounds - { numberBoundsLower = scientific (-1) 1024, - numberBoundsUpper = scientific 1 1024 - } - ) - where - go s = case Scientific.floatingOrInteger s :: Either Float Integer of - Right i -> Right i - Left _ -> Left ("Number is not an integer: " <> show s) +-- You can call this using @TypeApplications@: @boundedIntegralBounds @Word@ +boundedIntegralBounds :: forall i. (Integral i, Bounded i) => Bounds Integer +boundedIntegralBounds = fromIntegral <$> boundedBounds @i -- | This is an unsafe (unchecked) version of 'integerCodec'. unsafeUnboundedIntegerCodec :: JSONCodec Integer @@ -1448,36 +1511,6 @@ bimapCodec go fromIntegral scientificCodec where go s = case Scientific.floatingOrInteger s :: Either Float Integer of - Right i -> Right i - Left _ -> Left ("Number is not an integer: " <> show s) - --- | A safe codec for 'Natural'. --- --- This codec does a bounds check for the range [0, 10^1024] it can safely parse very large numbers. --- --- For a codec without this protection, see 'unsafeUnboundedNaturalCodec'. --- --- === Example usage --- --- >>> toJSONVia naturalCodec 5 --- Number 5.0 --- >>> toJSONVia naturalCodec (1000000000000) --- Number 1.0e12 --- >>> JSON.parseMaybe (parseJSONVia naturalCodec) (Number 4.0) --- Just 4 --- >>> JSON.parseMaybe (parseJSONVia naturalCodec) (Number (scientific 1 100000000)) --- Nothing -naturalCodec :: JSONCodec Natural -naturalCodec = - bimapCodec go fromIntegral $ - scientificWithBoundsCodec - ( NumberBounds - { numberBoundsLower = scientific 0 0, - numberBoundsUpper = scientific 1 1024 - } - ) - where - go s = case Scientific.floatingOrInteger s :: Either Float Natural of Right i -> Right i Left _ -> Left ("Number is not an integer: " <> show s)