Merge pull request #281 from mbj/fix/bounded-min-zero

[bounded] Fix 0 min bound JSON instance

Author: mbj

aws-secrets/test/stack-9.4-dependencies.txt

@@ -40,7 +40,7 @@ bitvec 1.1.5.0
 blaze-builder 0.4.2.3
 blaze-html 0.9.1.2
 blaze-markup 0.8.2.8
-bounded 0.0.5
+bounded 0.0.6
 byteorder 1.0.4
 bytestring 0.11.5.2
 cabal-doctest 1.0.9

aws-temporary-ingress-rule/test/stack-9.4-dependencies.txt

@@ -41,7 +41,7 @@ bitvec 1.1.5.0
 blaze-builder 0.4.2.3
 blaze-html 0.9.1.2
 blaze-markup 0.8.2.8
-bounded 0.0.5
+bounded 0.0.6
 byteorder 1.0.4
 bytestring 0.11.5.2
 cabal-doctest 1.0.9

bounded/bounded.cabal

@@ -1,11 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.2.
+-- This file has been generated from package.yaml by hpack version 0.35.5.
 --
 -- see: https://github.com/sol/hpack
 
 name:           bounded
-version:        0.0.5
+version:        0.0.6
 synopsis:       User definable Integral and Text bounded types
 homepage:       https://github.com/mbj/mhs#readme
 bug-reports:    https://github.com/mbj/mhs/issues

bounded/package.yaml

@@ -3,7 +3,7 @@ _common/package: !include "../common/package.yaml"
 maintainer: Markus Schirp mbj@schirp-dso.com, Allan Lukwago <epicallan.al@gmail.com>
 name:       bounded
 synopsis:   User definable Integral and Text bounded types
-version:    0.0.5
+version:    0.0.6
 
 <<: *defaults
 

bounded/src/Data/Bounded/JSON.hs

@@ -8,26 +8,6 @@ import Data.Scientific (Scientific)
 import qualified Data.Aeson       as JSON
 import qualified Data.Aeson.Types as JSON
 import qualified Data.Scientific  as Scientific
-import qualified Data.Text        as Text
-
-parseJSONTextBoundedLength
-  :: String
-  -> (Natural, Natural)
-  -> JSON.Value
-  -> JSON.Parser Text
-parseJSONTextBoundedLength field (min, max) = JSON.withText field parseLength
-  where
-    parseLength text
-      | length == 0  = failMessage "cannot be empty String"
-      | length < min = failMessage $ "cannot have less than " <> show min <> " characters"
-      | length > max = failMessage $ "cannot be longer than " <> show max <> " characters"
-      | otherwise    = pure text
-      where
-        length :: Natural
-        length = convertImpure $ Text.length text
-
-        failMessage :: String -> JSON.Parser Text
-        failMessage message = fail $ "parsing " <> field <> " failed, " <> message
 
 parseJSONIntegralBounded
   :: forall b a . (a ~ ToBoundedIntegral b, Conversion b a, Bounded a, Integral a, Integral b, Show b)

bounded/src/Data/Bounded/Text.hs

@@ -9,7 +9,6 @@ module Data.Bounded.Text
   )
 where
 
-import Data.Bounded.JSON
 import Data.Bounded.Prelude
 import Data.Bounded.TypeLevel
 import GHC.TypeLits (type (<=?))
@@ -57,11 +56,20 @@ instance (KnownSymbol a, Typeable b) => BoundTextLabel (a ++: b) where
 instance
   ( KnownNat min, KnownNat max, BoundTextLabel label
   , HasValidTypeRange '(min, max) (min <=? max)
-  )
-  => JSON.FromJSON (BoundText' label '( min, max) ) where
-  parseJSON value
-    = BoundText
-   <$> parseJSONTextBoundedLength (labelName @label) (mkRange @min @max) value
+  ) => JSON.FromJSON (BoundText' label '( min, max) ) where
+    parseJSON = JSON.withText field (either failError pure . convert)
+      where
+        field = labelName @label
+        failError BoundTextError{..} =
+          fail
+            $  "parsing "
+            <> field
+            <> " failed, actual length: "
+            <> show actual
+            <> " needs to be within min: "
+            <> show min
+            <> " and max: "
+            <> show max
 
 instance
   ( length ~ Length value

bounded/test/Test/Bounded/Text.hs

@@ -15,7 +15,8 @@ import Test.Tasty.HUnit
 import Test.TypeSpec (Expect, ShouldBe, TypeSpec(..))
 import Test.TypedSpec
 
-type Example = BoundText' "Example" '(2, 2)
+type Example  = BoundText' "Example" '(2, 2)
+type Example0 = BoundText' "Example0" '(0, 2)
 
 testTree :: TestTree
 testTree = testGroup "BoundText Tests"
@@ -26,12 +27,18 @@ testTree = testGroup "BoundText Tests"
 valueSpec :: TestTree
 valueSpec = testGroup "BoundText value tests"
   [ acceptsValidJson
+  , acceptsValidJson0
   , invalidExamples
   , rejectsInvalidJson
   , truncateExamples
   , validExamples
   ]
   where
+    acceptsValidJson0 :: TestTree
+    acceptsValidJson0 = testGroup "Accepts bound JSON 0 values"
+      [ acceptJSONText ("", fromType @"" @Example0)
+      ]
+
     acceptsValidJson :: TestTree
     acceptsValidJson = testGroup "Accepts bound JSON values"
       [ acceptJSONText ("CA", fromType @"CA" @Example)
@@ -40,8 +47,8 @@ valueSpec = testGroup "BoundText value tests"
 
     rejectsInvalidJson :: TestTree
     rejectsInvalidJson = testGroup "Rejects out of bound JSON values"
-      [ rejectJSONText @Example (mempty, "parsing Example failed, cannot be empty String")
-      , rejectJSONText @Example ("Foo", "parsing Example failed, cannot be longer than 2 characters")
+      [ rejectJSONText @Example ("", "parsing Example failed, actual length: 0 needs to be within min: 2 and max: 2")
+      , rejectJSONText @Example ("Foo", "parsing Example failed, actual length: 3 needs to be within min: 2 and max: 2")
       ]
 
     invalidExamples :: TestTree

bounded/test/stack-9.4-dependencies.txt

@@ -20,7 +20,7 @@ base-orphans 0.9.0
 bifunctors 5.5.15
 binary 0.8.9.1
 bitvec 1.1.5.0
-bounded 0.0.5
+bounded 0.0.6
 bytestring 0.11.5.2
 call-stack 0.4.0
 clock 0.8.4

lambda-alb/test/stack-9.4-dependencies.txt

@@ -22,7 +22,7 @@ bifunctors 5.5.15
 binary 0.8.9.1
 bitvec 1.1.5.0
 blaze-builder 0.4.2.3
-bounded 0.0.5
+bounded 0.0.6
 byteorder 1.0.4
 bytestring 0.11.5.2
 call-stack 0.4.0

lambda-runtime/test/stack-9.4-dependencies.txt

@@ -22,7 +22,7 @@ bifunctors 5.5.15
 binary 0.8.9.1
 bitvec 1.1.5.0
 blaze-builder 0.4.2.3
-bounded 0.0.5
+bounded 0.0.6
 byteorder 1.0.4
 bytestring 0.11.5.2
 call-stack 0.4.0

oauth/test/stack-9.4-dependencies.txt

@@ -22,7 +22,7 @@ bifunctors 5.5.15
 binary 0.8.9.1
 bitvec 1.1.5.0
 blaze-builder 0.4.2.3
-bounded 0.0.5
+bounded 0.0.6
 byteorder 1.0.4
 bytestring 0.11.5.2
 call-stack 0.4.0

stack-deploy/test/stack-9.4-dependencies.txt

@@ -38,7 +38,7 @@ bitvec 1.1.5.0
 blaze-builder 0.4.2.3
 blaze-html 0.9.1.2
 blaze-markup 0.8.2.8
-bounded 0.0.5
+bounded 0.0.6
 byteorder 1.0.4
 bytestring 0.11.5.2
 cabal-doctest 1.0.9

xray/test/stack-9.4-dependencies.txt

@@ -19,7 +19,7 @@ base-orphans 0.9.0
 bifunctors 5.5.15
 binary 0.8.9.1
 bitvec 1.1.5.0
-bounded 0.0.5
+bounded 0.0.6
 bytestring 0.11.5.2
 call-stack 0.4.0
 case-insensitive 1.2.1.0