diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -4,11 +4,23 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.6.3] - 2022-01-14 +### Added +- `Hashable` instance for `Refined` +- `FromJSONKey` instance for `Refined` +- `ToJSONKey` instance for `Refined` +- `shrink` for `Refined`'s `Arbitrary` instance. +- `refineEither` function + +### Changed +- improved efficiency of `strengthen` +- bump multiple dependency upper bounds + ## [0.6.2] - 2021-01-31 ### Changed - `strengthen` no longer returns an `Either`, since the proof that it should always succeed is in its constraints. -- correct `success` documentation +- correct `success` documentation ## [0.6.1] - 2020-08-02 ### Changed @@ -36,7 +48,7 @@ ### Added - sized Predicate instances for `Text` - sized Predicate instances for strict and lazy `ByteString` -- INLINABLE pragmas on `refine_` `reifyPredicate` +- INLINABLE pragmas on `refine_` `reifyPredicate` - `NFData` instance for `Refined` - RefineSomeException constructor. Enables recovering specific validation exceptions. @@ -47,7 +59,7 @@ - @since pragmas to EVERYTHING. ### Changed -- lower bound on mtl to 2.2.2 due to use of liftEither. +- lower bound on mtl to 2.2.2 due to use of liftEither. Thanks to @k0ral for reporting this - Generalize sized predicates - Allow newer template-haskell (< 0.16 ==> < 0.17) diff --git a/refined.cabal b/refined.cabal --- a/refined.cabal +++ b/refined.cabal @@ -3,7 +3,7 @@ name: refined version: - 0.6.2 + 0.6.3 synopsis: Refinement types with static and runtime checking description: @@ -32,8 +32,10 @@ tested-with: GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.3 - , GHC == 8.10.1 + , GHC == 8.8.5 + , GHC == 8.10.7 + , GHC == 9.0.2 + , GHC == 9.2.1 extra-source-files: README.md , changelog.md @@ -70,30 +72,31 @@ default-language: Haskell2010 build-depends: - base >= 4.11 && < 4.15 - , bytestring >= 0.10 && < 0.11 + base >= 4.11 && < 4.17 + , bytestring >= 0.10 && < 0.12 , deepseq >= 1.4 && < 1.5 , exceptions >= 0.8 && < 0.11 + , hashable >= 1.0 && < 1.5 , mtl >= 2.2.2 && < 2.3 - , template-haskell >= 2.9 && < 2.17 - , text >= 1.2 && < 1.3 - , these-skinny >= 0.7.4 && < 0.8 + , template-haskell >= 2.9 && < 2.19 + , text >= 1.2 && < 2.1 + , these-skinny >= 0.7.5 && < 0.8 if flag(aeson) - build-depends: aeson >= 0.9 && < 1.6 + build-depends: aeson >= 0.9 && < 2.1 cpp-options: -DHAVE_AESON if flag(QuickCheck) build-depends: QuickCheck >= 2.1 && < 2.15 cpp-options: -DHAVE_QUICKCHECK -test-suite doctest - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Doctests.hs - build-depends: - base - , refined - , doctest >= 0.10 - default-language: Haskell2010 +--test-suite doctest +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: test +-- main-is: Doctests.hs +-- build-depends: +-- base +-- , refined +-- , doctest >= 0.10 +-- default-language: Haskell2010 test-suite arbitrary type: exitcode-stdio-1.0 diff --git a/src/Refined.hs b/src/Refined.hs --- a/src/Refined.hs +++ b/src/Refined.hs @@ -74,6 +74,7 @@ , refineThrow , refineFail , refineError + , refineEither , refineTH , refineTH_ @@ -160,8 +161,9 @@ import Control.Exception (Exception (displayException)) import Data.Coerce (coerce) -import Data.Either (isRight) +import Data.Either (isRight, rights) import Data.Foldable (foldl') +import Data.Functor.Contravariant ((>$<)) import Data.Proxy (Proxy(Proxy)) import Data.Text (Text) import qualified Data.Text as Text @@ -191,7 +193,8 @@ #if HAVE_AESON import Control.Monad ((<=<)) -import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON)) +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import qualified Data.Aeson as Aeson #endif #if HAVE_QUICKCHECK @@ -279,11 +282,28 @@ #if HAVE_AESON -- | @since 0.4 instance (FromJSON a, Predicate p a) => FromJSON (Refined p a) where - parseJSON = refineFail <=< parseJSON + parseJSON = refineFail <=< Aeson.parseJSON +instance (FromJSONKey a, Predicate p a) => FromJSONKey (Refined p a) where + fromJSONKey = case Aeson.fromJSONKey @a of + Aeson.FromJSONKeyCoerce -> Aeson.FromJSONKeyTextParser $ refineFail . coerce + Aeson.FromJSONKeyText f -> Aeson.FromJSONKeyTextParser $ refineFail . f + Aeson.FromJSONKeyTextParser f -> Aeson.FromJSONKeyTextParser $ refineFail <=< f + Aeson.FromJSONKeyValue f -> Aeson.FromJSONKeyValue $ refineFail <=< f + + fromJSONKeyList = case Aeson.fromJSONKeyList @a of + Aeson.FromJSONKeyText f -> Aeson.FromJSONKeyTextParser $ traverse refineFail . f + Aeson.FromJSONKeyTextParser f -> Aeson.FromJSONKeyTextParser $ traverse refineFail <=< f + Aeson.FromJSONKeyValue f -> Aeson.FromJSONKeyValue $ traverse refineFail <=< f + -- | @since 0.4 instance (ToJSON a, Predicate p a) => ToJSON (Refined p a) where - toJSON = toJSON . unrefine + toJSON = Aeson.toJSON . unrefine + +-- | @since 0.6.3 +instance (ToJSONKey a, Predicate p a) => ToJSONKey (Refined p a) where + toJSONKey = unrefine >$< Aeson.toJSONKey + toJSONKeyList = map unrefine >$< Aeson.toJSONKeyList #endif /* HAVE_AESON */ #if HAVE_QUICKCHECK @@ -301,6 +321,7 @@ Nothing -> do loop (runs + 1) gen | otherwise = error (refinedGenError (Proxy @p) (Proxy @a)) + shrink = rights . map refine . QC.shrink . unrefine refinedGenError :: (Typeable p, Typeable a) => Proxy p -> Proxy a -> String @@ -371,6 +392,23 @@ refineError = refine .> either MonadError.throwError pure {-# INLINABLE refineError #-} +-- | Like 'refine', but, when the value doesn't satisfy the predicate, returns +-- a 'Refined' value with the predicate negated, instead of returning +-- 'RefineException'. +-- +-- >>> isRight (refineEither @Even @Int 42) +-- True +-- +-- >>> isLeft (refineEither @Even @Int 43) +-- True +-- +refineEither :: forall p x. (Predicate p x) => x -> Either (Refined (Not p) x) (Refined p x) +refineEither x = + case validate (Proxy @p) x of + Nothing -> Right $ Refined x + Just _ -> Left $ Refined x +{-# INLINABLE refineEither #-} + -------------------------------------------------------------------------------- -- | Constructs a 'Refined' value at compile-time using @-XTemplateHaskell@. @@ -399,23 +437,50 @@ -- . -- -- @since 0.1.0.0 -refineTH :: forall p x. (Predicate p x, TH.Lift x) => x -> TH.Q (TH.TExp (Refined p x)) +#if MIN_VERSION_template_haskell(2,17,0) +refineTH :: forall p x. (Predicate p x, TH.Lift x) + => x + -> TH.Code TH.Q (Refined p x) refineTH = let showException = refineExceptionToTree .> showTree True .> fail + .> TH.liftCode in refine @p @x + .> either showException TH.liftTyped +#else +refineTH :: forall p x. (Predicate p x, TH.Lift x) + => x + -> TH.Q (TH.TExp (Refined p x)) +refineTH = + let showException = refineExceptionToTree + .> showTree True + .> fail + in refine @p @x .> either showException TH.lift .> fmap TH.TExp +#endif + -- | Like 'refineTH', but immediately unrefines the value. -- This is useful when some value need only be refined -- at compile-time. -- -- @since 0.4.4 +#if MIN_VERSION_template_haskell(2,17,0) refineTH_ :: forall p x. (Predicate p x, TH.Lift x) => x + -> TH.Code TH.Q x +refineTH_ = + refineTH @p @x + .> TH.examineCode + .> fmap unsafeUnrefineTExp + .> TH.liftCode +#else +refineTH_ :: forall p x. (Predicate p x, TH.Lift x) + => x -> TH.Q (TH.TExp x) refineTH_ = refineTH @p @x .> fmap unsafeUnrefineTExp +#endif unsafeUnrefineTExp :: TH.TExp (Refined p x) -> TH.TExp x unsafeUnrefineTExp (TH.TExp e) = TH.TExp @@ -1315,7 +1380,9 @@ strengthen :: forall p p' x. (Predicate p x, Predicate p' x) => Refined p x -> Either RefineException (Refined (p && p') x) -strengthen = unrefine .> refine +strengthen r = do + Refined x <- refine @p' @x (unrefine r) + pure (Refined x) {-# inlineable strengthen #-} -------------------------------------------------------------------------------- diff --git a/src/Refined/Unsafe.hs b/src/Refined/Unsafe.hs --- a/src/Refined/Unsafe.hs +++ b/src/Refined/Unsafe.hs @@ -28,6 +28,7 @@ -------------------------------------------------------------------------------- {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} #if __GLASGOW_HASKELL__ >= 805 {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} diff --git a/src/Refined/Unsafe/Type.hs b/src/Refined/Unsafe/Type.hs --- a/src/Refined/Unsafe/Type.hs +++ b/src/Refined/Unsafe/Type.hs @@ -48,6 +48,7 @@ ) where import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) import qualified Language.Haskell.TH.Syntax as TH -- | A refinement type, which wraps a value of type @x@. @@ -58,6 +59,7 @@ deriving newtype ( Eq -- ^ @since 0.1.0.0 , Ord -- ^ @since 0.1.0.0 + , Hashable -- ^ @since 0.6.3 , NFData -- ^ @since 0.5 ) deriving stock @@ -76,4 +78,3 @@ #if MIN_VERSION_template_haskell(2,16,0) liftTyped (Refined a) = [||Refined a||] #endif - diff --git a/test/Doctests.hs b/test/Doctests.hs deleted file mode 100644 --- a/test/Doctests.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Main (main) where - -import Test.DocTest - -main :: IO () -main = doctest $ srcFiles ++ compFlags - -srcFiles :: [String] -srcFiles = - [ "src/Refined.hs" - , "src/Refined/Unsafe/Type.hs" - , "src/Refined/Unsafe.hs" - ] - -compFlags :: [String] -compFlags = - [ "-XScopedTypeVariables" - ] diff --git a/test/QuickCheck.hs b/test/QuickCheck.hs --- a/test/QuickCheck.hs +++ b/test/QuickCheck.hs @@ -19,6 +19,8 @@ , prop_from , prop_to , prop_bad + , prop_shrink_lt + , prop_shrink_gt ] iddy :: (Eq a) => Refined p a -> Bool @@ -37,10 +39,25 @@ prop_to = property $ \(r :: Refined (To 9) MyInt) -> iddy r prop_bad :: Property -prop_bad = expectFailure $ \(r :: Refined (EqualTo 2 && EqualTo 3) MyInt) -> iddy r +prop_bad = expectFailure $ ioProperty $ do + -- expectFailure expects the error inside the property itself, not while + -- generating the argument to the property. So we need to hide generation from + -- it. + r :: Refined (EqualTo 2 && EqualTo 3) MyInt <- generate arbitrary + return $ iddy r +prop_shrink_lt :: Property +prop_shrink_lt = property $ \(r :: Refined (LessThan 5) MyInt) -> + (unrefine <$> shrink r) == shrink (unrefine r) + +prop_shrink_gt :: Property +prop_shrink_gt = property $ \(r :: Refined (GreaterThan 5) MyInt) -> + (unrefine <$> shrink r) == (filter (> 5) $ shrink (unrefine r)) + newtype MyInt = MyInt Int deriving (Eq, Ord, Show, Num) instance Arbitrary MyInt where arbitrary = MyInt <$> choose (0,100) + shrink (MyInt 0) = [] + shrink (MyInt n) = MyInt <$> [0..n-1]