module IsomorphismClass.Proxies.ViaIsSome where

import IsomorphismClass.Classes.IsSome
import IsomorphismClass.Prelude
import qualified Test.QuickCheck as QuickCheck

-- |
-- Helper for deriving common instances on types which have an instance of @'IsSome' sup@ using the @DerivingVia@ extension.
--
-- E.g.,
--
-- > newtype Percent = Percent Double
-- >   deriving newtype (Show, Eq, Ord)
-- >   deriving (Read, IsString, Arbitrary) via (ViaIsSome Double Percent)
-- >
-- > instance IsSome Double Percent where
-- >   to (Percent double) = double
-- >   maybeFrom double =
-- >     if double < 0 || double > 1
-- >       then Nothing
-- >       else Just (Percent double)
--
-- In the code above all the instances that are able to construct the values of 'Percent' are automatically derived based on the @IsSome Double Percent@ instance.
-- This guarantees that they only construct values that pass thru the checks defined in 'maybeFrom'.
newtype ViaIsSome sup sub = ViaIsSome sub

instance (IsSome sup sub) => IsSome sup (ViaIsSome sup sub) where
  to :: ViaIsSome sup sub -> sup
to (ViaIsSome sub
a) = sub -> sup
forall sup sub. IsSome sup sub => sub -> sup
to sub
a
  maybeFrom :: sup -> Maybe (ViaIsSome sup sub)
maybeFrom = (sub -> ViaIsSome sup sub)
-> Maybe sub -> Maybe (ViaIsSome sup sub)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap sub -> ViaIsSome sup sub
forall sup sub. sub -> ViaIsSome sup sub
ViaIsSome (Maybe sub -> Maybe (ViaIsSome sup sub))
-> (sup -> Maybe sub) -> sup -> Maybe (ViaIsSome sup sub)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. sup -> Maybe sub
forall sup sub. IsSome sup sub => sup -> Maybe sub
maybeFrom

instance (IsSome sup sub, Show sup) => Show (ViaIsSome sup sub) where
  show :: ViaIsSome sup sub -> String
show (ViaIsSome sub
a) = sup -> String
forall a. Show a => a -> String
show (forall sup sub. IsSome sup sub => sub -> sup
to @sup sub
a)

instance (IsSome sup sub, Read sup) => Read (ViaIsSome sup sub) where
  readPrec :: ReadPrec (ViaIsSome sup sub)
readPrec = do
    sup <- ReadPrec sup
forall a. Read a => ReadPrec a
readPrec
    case maybeFrom @sup sup of
      Just sub
a -> ViaIsSome sup sub -> ReadPrec (ViaIsSome sup sub)
forall a. a -> ReadPrec a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (sub -> ViaIsSome sup sub
forall sup sub. sub -> ViaIsSome sup sub
ViaIsSome sub
a)
      Maybe sub
Nothing -> String -> ReadPrec (ViaIsSome sup sub)
forall a. String -> ReadPrec a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Value is not from the subset"

instance (IsSome sup sub, IsString sup) => IsString (ViaIsSome sup sub) where
  fromString :: String -> ViaIsSome sup sub
fromString =
    ViaIsSome sup sub
-> (sub -> ViaIsSome sup sub) -> Maybe sub -> ViaIsSome sup sub
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ViaIsSome sup sub
forall a. HasCallStack => String -> a
error String
"Value is not from the subset") sub -> ViaIsSome sup sub
forall sup sub. sub -> ViaIsSome sup sub
ViaIsSome (Maybe sub -> ViaIsSome sup sub)
-> (String -> Maybe sub) -> String -> ViaIsSome sup sub
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall sup sub. IsSome sup sub => sup -> Maybe sub
maybeFrom @sup (sup -> Maybe sub) -> (String -> sup) -> String -> Maybe sub
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> sup
forall a. IsString a => String -> a
fromString

instance (IsSome sup sub, Eq sup) => Eq (ViaIsSome sup sub) where
  == :: ViaIsSome sup sub -> ViaIsSome sup sub -> Bool
(==) = (sup -> sup -> Bool)
-> (ViaIsSome sup sub -> sup)
-> ViaIsSome sup sub
-> ViaIsSome sup sub
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on sup -> sup -> Bool
forall a. Eq a => a -> a -> Bool
(==) (forall sup sub. IsSome sup sub => sub -> sup
to @sup)

instance (IsSome sup sub, Ord sup) => Ord (ViaIsSome sup sub) where
  compare :: ViaIsSome sup sub -> ViaIsSome sup sub -> Ordering
compare = (sup -> sup -> Ordering)
-> (ViaIsSome sup sub -> sup)
-> ViaIsSome sup sub
-> ViaIsSome sup sub
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on sup -> sup -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (forall sup sub. IsSome sup sub => sub -> sup
to @sup)

instance (IsSome sup sub, QuickCheck.Arbitrary sup) => QuickCheck.Arbitrary (ViaIsSome sup sub) where
  arbitrary :: Gen (ViaIsSome sup sub)
arbitrary =
    Gen sup
-> (sup -> Maybe (ViaIsSome sup sub)) -> Gen (ViaIsSome sup sub)
forall a b. Gen a -> (a -> Maybe b) -> Gen b
QuickCheck.suchThatMap Gen sup
forall a. Arbitrary a => Gen a
QuickCheck.arbitrary (forall sup sub. IsSome sup sub => sup -> Maybe sub
maybeFrom @sup)
  shrink :: ViaIsSome sup sub -> [ViaIsSome sup sub]
shrink ViaIsSome sup sub
value = do
    shrunkValue <- sup -> [sup]
forall a. Arbitrary a => a -> [a]
QuickCheck.shrink (forall sup sub. IsSome sup sub => sub -> sup
to @sup ViaIsSome sup sub
value)
    shrunkValue
      & maybeFrom
      & maybeToList