{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Variant
(
VariantF (..)
, Variant
, variantF
, variant
, case_
, caseF
, CouldBeF (..)
, CouldBe (..)
, CouldBeAnyOfF
, CouldBeAnyOf
, CatchF (..)
, Catch (..)
, EithersF (..)
, Eithers (..)
, FoldF (..)
, Fold (..)
, preposterous
, postposterous
) where
import Data.Bifunctor (first)
import Data.Function ((&))
import Data.Functor.Identity (Identity (..))
import Data.Kind (Constraint, Type)
import Data.Void (Void, absurd)
import GHC.TypeLits (ErrorMessage (..), TypeError)
import Test.QuickCheck.Arbitrary (Arbitrary (..))
data VariantF (f :: k -> Type) (xs :: [k]) where
Here :: f x -> VariantF f (x ': xs)
There :: VariantF f xs -> VariantF f (x ': xs)
type family AllF (c :: Type -> Constraint) (f :: k -> Type) (xs :: [k]) :: Constraint where
AllF c f '[ ] = ()
AllF c f (x ': xs) = (c (f x), AllF c f xs)
deriving instance AllF Eq f xs => Eq (VariantF f xs)
deriving instance AllF Show f xs => Show (VariantF f xs)
deriving instance (AllF Eq f xs, AllF Ord f xs) => Ord (VariantF f xs)
instance (AllF Semigroup f xs) => Semigroup (VariantF f xs) where
Here f x
x <> :: VariantF f xs -> VariantF f xs -> VariantF f xs
<> Here f x
y = forall {k} (f :: k -> *) (xs :: k) (x :: [k]).
f xs -> VariantF f (xs : x)
Here (f x
x forall a. Semigroup a => a -> a -> a
<> f x
y)
Here f x
_ <> There VariantF f xs
y = forall {k} (f :: k -> *) (xs :: [k]) (x :: k).
VariantF f xs -> VariantF f (x : xs)
There VariantF f xs
y
There VariantF f xs
x <> Here f x
_ = forall {k} (f :: k -> *) (xs :: [k]) (x :: k).
VariantF f xs -> VariantF f (x : xs)
There VariantF f xs
x
There VariantF f xs
x <> There VariantF f xs
y = forall {k} (f :: k -> *) (xs :: [k]) (x :: k).
VariantF f xs -> VariantF f (x : xs)
There (VariantF f xs
x forall a. Semigroup a => a -> a -> a
<> VariantF f xs
y)
instance (Monoid (f x), Semigroup (VariantF f (x ': xs)))
=> Monoid (VariantF f (x ': xs)) where
mempty :: VariantF f (x : xs)
mempty = forall {k} (f :: k -> *) (xs :: k) (x :: [k]).
f xs -> VariantF f (xs : x)
Here forall a. Monoid a => a
mempty
type Variant (xs :: [Type])
= VariantF Identity xs
variantF :: (f x -> r) -> (VariantF f xs -> r) -> VariantF f (x ': xs) -> r
variantF :: forall {a} (f :: a -> *) (x :: a) r (xs :: [a]).
(f x -> r) -> (VariantF f xs -> r) -> VariantF f (x : xs) -> r
variantF f x -> r
here VariantF f xs -> r
there = \case Here f x
x -> f x -> r
here f x
x; There VariantF f xs
xs -> VariantF f xs -> r
there VariantF f xs
xs
variant :: (x -> r) -> (Variant xs -> r) -> Variant (x ': xs) -> r
variant :: forall x r (xs :: [*]).
(x -> r) -> (Variant xs -> r) -> Variant (x : xs) -> r
variant x -> r
here = forall {a} (f :: a -> *) (x :: a) r (xs :: [a]).
(f x -> r) -> (VariantF f xs -> r) -> VariantF f (x : xs) -> r
variantF (x -> r
here forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity)
class CaseF (xs :: [Type]) (f :: Type -> Type) (r :: Type) (o :: Type)
| xs f r -> o, o -> f r xs where
caseF' :: Either r (VariantF f xs) -> o
instance CaseF '[x] f r ((f x -> r) -> r) where
caseF' :: Either r (VariantF f '[x]) -> (f x -> r) -> r
caseF' (Left r
r) f x -> r
_ = r
r
caseF' (Right VariantF f '[x]
xs) f x -> r
f = VariantF f '[x]
xs forall a b. a -> (a -> b) -> b
& forall {a} (f :: a -> *) (x :: a) r (xs :: [a]).
(f x -> r) -> (VariantF f xs -> r) -> VariantF f (x : xs) -> r
variantF f x -> r
f \VariantF f '[]
_ ->
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Impossible case - something isn't happy when performing the "
forall a. Semigroup a => a -> a -> a
<> String
"exhaustivity check as this case shouldn't need a pattern-match."
instance CaseF (y ': zs) f r ((f y -> r) -> o)
=> CaseF (x ': y ': zs) f r ((f x -> r) -> (f y -> r) -> o) where
caseF' :: Either r (VariantF f (x : y : zs)) -> (f x -> r) -> (f y -> r) -> o
caseF' Either r (VariantF f (x : y : zs))
xs f x -> r
f = forall (xs :: [*]) (f :: * -> *) r o.
CaseF xs f r o =>
Either r (VariantF f xs) -> o
caseF' (Either r (VariantF f (x : y : zs))
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a} (f :: a -> *) (x :: a) r (xs :: [a]).
(f x -> r) -> (VariantF f xs -> r) -> VariantF f (x : xs) -> r
variantF (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> r
f) forall a b. b -> Either a b
Right)
caseF :: CaseF xs f r fold => VariantF f xs -> fold
caseF :: forall (xs :: [*]) (f :: * -> *) r fold.
CaseF xs f r fold =>
VariantF f xs -> fold
caseF = forall (xs :: [*]) (f :: * -> *) r o.
CaseF xs f r o =>
Either r (VariantF f xs) -> o
caseF' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
class Case (xs :: [Type]) (r :: Type) (o :: Type)
| xs r -> o, o -> r xs where
case_' :: Either r (Variant xs) -> o
instance Case '[x] r ((x -> r) -> r) where
case_' :: Either r (Variant '[x]) -> (x -> r) -> r
case_' (Left r
r) x -> r
_ = r
r
case_' (Right Variant '[x]
xs) x -> r
f = Variant '[x]
xs forall a b. a -> (a -> b) -> b
& forall {a} (f :: a -> *) (x :: a) r (xs :: [a]).
(f x -> r) -> (VariantF f xs -> r) -> VariantF f (x : xs) -> r
variantF (x -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity) \VariantF Identity '[]
_ ->
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Impossible case - something isn't happy when performing the "
forall a. Semigroup a => a -> a -> a
<> String
"exhaustivity check as this case shouldn't need a pattern-match."
instance Case (y ': zs) r ((y -> r) -> o)
=> Case (x ': y ': zs) r ((x -> r) -> (y -> r) -> o) where
case_' :: Either r (Variant (x : y : zs)) -> (x -> r) -> (y -> r) -> o
case_' Either r (Variant (x : y : zs))
xs x -> r
f = forall (xs :: [*]) r o. Case xs r o => Either r (Variant xs) -> o
case_' (Either r (Variant (x : y : zs))
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {a} (f :: a -> *) (x :: a) r (xs :: [a]).
(f x -> r) -> (VariantF f xs -> r) -> VariantF f (x : xs) -> r
variantF (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> r
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity) forall a b. b -> Either a b
Right)
case_ :: Case xs r fold => Variant xs -> fold
case_ :: forall (xs :: [*]) r fold. Case xs r fold => Variant xs -> fold
case_ = forall (xs :: [*]) r o. Case xs r o => Either r (Variant xs) -> o
case_' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
type family TypeNotFound (x :: k) :: l where
TypeNotFound x
= TypeError ( 'Text "Uh oh! I couldn't find " ':<>: 'ShowType x
':<>: 'Text " inside the variant!"
':$$: 'Text "If you're pretty sure I'm wrong, perhaps the variant "
':<>: 'Text "type is ambiguous;"
':$$: 'Text "could you add some annotations?" )
class CouldBeF (xs :: [k]) (x :: k) where
throwF :: f x -> VariantF f xs
snatchF :: VariantF f xs -> Either (VariantF f xs) (f x)
instance CouldBeF (x ': xs) x where
throwF :: forall (f :: k -> *). f x -> VariantF f (x : xs)
throwF = forall {k} (f :: k -> *) (xs :: k) (x :: [k]).
f xs -> VariantF f (xs : x)
Here
snatchF :: forall (f :: k -> *).
VariantF f (x : xs) -> Either (VariantF f (x : xs)) (f x)
snatchF = \case
Here f x
x -> forall a b. b -> Either a b
Right f x
x
There VariantF f xs
xs -> forall a b. a -> Either a b
Left (forall {k} (f :: k -> *) (xs :: [k]) (x :: k).
VariantF f xs -> VariantF f (x : xs)
There VariantF f xs
xs)
instance {-# OVERLAPPABLE #-} CouldBeF xs x
=> CouldBeF (y ': xs) x where
throwF :: forall (f :: k -> *). f x -> VariantF f (y : xs)
throwF = forall {k} (f :: k -> *) (xs :: [k]) (x :: k).
VariantF f xs -> VariantF f (x : xs)
There forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (xs :: [k]) (x :: k) (f :: k -> *).
CouldBeF xs x =>
f x -> VariantF f xs
throwF
snatchF :: forall (f :: k -> *).
VariantF f (y : xs) -> Either (VariantF f (y : xs)) (f x)
snatchF = \case
There VariantF f xs
xs -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall {k} (f :: k -> *) (xs :: [k]) (x :: k).
VariantF f xs -> VariantF f (x : xs)
There (forall k (xs :: [k]) (x :: k) (f :: k -> *).
CouldBeF xs x =>
VariantF f xs -> Either (VariantF f xs) (f x)
snatchF VariantF f xs
xs)
Here f x
_ ->
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Impossible case - something isn't happy when performing the "
forall a. Semigroup a => a -> a -> a
<> String
"exhaustivity check as this case shouldn't need a pattern-match."
instance TypeNotFound x => CouldBeF '[] x where
throwF :: forall (f :: k -> *). f x -> VariantF f '[]
throwF = forall a. HasCallStack => String -> a
error String
"Impossible!"
snatchF :: forall (f :: k -> *).
VariantF f '[] -> Either (VariantF f '[]) (f x)
snatchF = forall a. HasCallStack => String -> a
error String
"Impossible!"
class CouldBeF xs x => CouldBe (xs :: [Type]) (x :: Type) where
throw :: x -> Variant xs
snatch :: Variant xs -> Either (Variant xs) x
instance CouldBeF xs x => CouldBe xs x where
throw :: x -> Variant xs
throw = forall k (xs :: [k]) (x :: k) (f :: k -> *).
CouldBeF xs x =>
f x -> VariantF f xs
throwF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Identity a
Identity
snatch :: Variant xs -> Either (Variant xs) x
snatch = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (xs :: [k]) (x :: k) (f :: k -> *).
CouldBeF xs x =>
VariantF f xs -> Either (VariantF f xs) (f x)
snatchF
type family All (cs :: [Constraint]) = (c :: Constraint) | c -> cs where
All '[] = ()
All (c ': cs) = (c, All cs)
type family Map (f :: k -> l) (xs :: [k]) = (ys :: [l]) where
Map f (x ': xs) = f x ': Map f xs
Map f '[] = '[]
type e `CouldBeAnyOfF` xs = All (Map (CouldBeF e) xs)
type e `CouldBeAnyOf` xs = All (Map (CouldBe e) xs)
class CatchF x xs ys | xs x -> ys, xs ys -> x, x ys -> xs where
catchF :: VariantF f xs -> Either (VariantF f ys) (f x)
instance CatchF x (x ': xs) xs where
catchF :: forall (f :: a -> *).
VariantF f (x : xs) -> Either (VariantF f xs) (f x)
catchF = \case
Here f x
x -> forall a b. b -> Either a b
Right f x
x
There VariantF f xs
xs -> forall a b. a -> Either a b
Left VariantF f xs
xs
instance {-# INCOHERENT #-} (y ~ z, CatchF x xs ys)
=> CatchF x (y ': xs) (z ': ys) where
catchF :: forall (f :: a -> *).
VariantF f (y : xs) -> Either (VariantF f (z : ys)) (f x)
catchF = \case
There VariantF f xs
xs -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall {k} (f :: k -> *) (xs :: [k]) (x :: k).
VariantF f xs -> VariantF f (x : xs)
There (forall {k} (x :: k) (xs :: [k]) (ys :: [k]) (f :: k -> *).
CatchF x xs ys =>
VariantF f xs -> Either (VariantF f ys) (f x)
catchF VariantF f xs
xs)
Here f x
_ ->
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Impossible case - something isn't happy when performing the "
forall a. Semigroup a => a -> a -> a
<> String
"exhaustivity check as this case shouldn't need a pattern-match."
class CatchF x xs ys => Catch (x :: Type) (xs :: [Type]) (ys :: [Type]) where
catch :: Variant xs -> Either (Variant ys) x
instance CatchF x xs ys => Catch x xs ys where
catch :: Variant xs -> Either (Variant ys) x
catch = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (x :: k) (xs :: [k]) (ys :: [k]) (f :: k -> *).
CatchF x xs ys =>
VariantF f xs -> Either (VariantF f ys) (f x)
catchF
class EithersF (f :: Type -> Type) (xs :: [Type]) (o :: Type)
| f xs -> o, o f -> xs where
toEithersF :: VariantF f xs -> o
fromEithersF :: o -> VariantF f xs
instance EithersF f '[x] (f x) where
toEithersF :: VariantF f '[x] -> f x
toEithersF = forall {a} (f :: a -> *) (x :: a) r (xs :: [a]).
(f x -> r) -> (VariantF f xs -> r) -> VariantF f (x : xs) -> r
variantF forall a. a -> a
id \VariantF f '[]
_ ->
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Impossible case - something isn't happy when performing the "
forall a. Semigroup a => a -> a -> a
<> String
"exhaustivity check as this case shouldn't need a pattern-match."
fromEithersF :: f x -> VariantF f '[x]
fromEithersF = forall {k} (f :: k -> *) (xs :: k) (x :: [k]).
f xs -> VariantF f (xs : x)
Here
instance (Functor f, EithersF f (y ': xs) zs)
=> EithersF f (x ': y ': xs) (Either (f x) zs) where
toEithersF :: VariantF f (x : y : xs) -> Either (f x) zs
toEithersF = forall {a} (f :: a -> *) (x :: a) r (xs :: [a]).
(f x -> r) -> (VariantF f xs -> r) -> VariantF f (x : xs) -> r
variantF forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (xs :: [*]) o.
EithersF f xs o =>
VariantF f xs -> o
toEithersF)
fromEithersF :: Either (f x) zs -> VariantF f (x : y : xs)
fromEithersF = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall {k} (f :: k -> *) (xs :: k) (x :: [k]).
f xs -> VariantF f (xs : x)
Here (forall {k} (f :: k -> *) (xs :: [k]) (x :: k).
VariantF f xs -> VariantF f (x : xs)
There forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) (xs :: [*]) o.
EithersF f xs o =>
o -> VariantF f xs
fromEithersF)
class Eithers (xs :: [Type]) (o :: Type) | xs -> o where
toEithers :: Variant xs -> o
fromEithers :: o -> Variant xs
instance Eithers '[x] x where
toEithers :: Variant '[x] -> x
toEithers = forall x r (xs :: [*]).
(x -> r) -> (Variant xs -> r) -> Variant (x : xs) -> r
variant forall a. a -> a
id \VariantF Identity '[]
_ ->
forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Impossible case - something isn't happy when performing the "
forall a. Semigroup a => a -> a -> a
<> String
"exhaustivity check as this case shouldn't need a pattern-match."
fromEithers :: x -> Variant '[x]
fromEithers = forall {k} (f :: k -> *) (xs :: k) (x :: [k]).
f xs -> VariantF f (xs : x)
Here forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Identity a
Identity
instance Eithers (y ': xs) zs => Eithers (x ': y ': xs) (Either x zs) where
toEithers :: Variant (x : y : xs) -> Either x zs
toEithers = forall x r (xs :: [*]).
(x -> r) -> (Variant xs -> r) -> Variant (x : xs) -> r
variant forall a b. a -> Either a b
Left (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (xs :: [*]) o. Eithers xs o => Variant xs -> o
toEithers)
fromEithers :: Either x zs -> Variant (x : y : xs)
fromEithers = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall {k} (f :: k -> *) (xs :: k) (x :: [k]).
f xs -> VariantF f (xs : x)
Here forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Identity a
Identity) (forall {k} (f :: k -> *) (xs :: [k]) (x :: k).
VariantF f xs -> VariantF f (x : xs)
There forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (xs :: [*]) o. Eithers xs o => o -> Variant xs
fromEithers)
class FoldF (c :: Type -> Constraint) (xs :: [Type]) where
foldF :: VariantF f xs -> (forall x. c x => f x -> m) -> m
instance FoldF c '[] where
foldF :: forall (f :: * -> *) m.
VariantF f '[] -> (forall x. c x => f x -> m) -> m
foldF VariantF f '[]
xs forall x. c x => f x -> m
_ = forall a. Void -> a
absurd (forall {k} (f :: k -> *). VariantF f '[] -> Void
preposterous VariantF f '[]
xs)
instance (c x, FoldF c xs) => FoldF c (x ': xs) where
foldF :: forall (f :: * -> *) m.
VariantF f (x : xs) -> (forall x. c x => f x -> m) -> m
foldF (Here f x
x ) forall x. c x => f x -> m
f = forall x. c x => f x -> m
f f x
x
foldF (There VariantF f xs
xs) forall x. c x => f x -> m
f = forall (c :: * -> Constraint) (xs :: [*]) (f :: * -> *) m.
FoldF c xs =>
VariantF f xs -> (forall x. c x => f x -> m) -> m
foldF @c VariantF f xs
xs forall x. c x => f x -> m
f
class FoldF c xs => Fold (c :: Type -> Constraint) (xs :: [Type]) where
fold :: Variant xs -> (forall x. c x => x -> m) -> m
instance FoldF c xs => Fold c xs where
fold :: forall m. Variant xs -> (forall x. c x => x -> m) -> m
fold Variant xs
xs forall x. c x => x -> m
f = forall (c :: * -> Constraint) (xs :: [*]) (f :: * -> *) m.
FoldF c xs =>
VariantF f xs -> (forall x. c x => f x -> m) -> m
foldF @c Variant xs
xs (forall x. c x => x -> m
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
runIdentity)
preposterous :: VariantF f '[] -> Void
preposterous :: forall {k} (f :: k -> *). VariantF f '[] -> Void
preposterous = VariantF f '[] -> Void
\case
postposterous :: Void -> VariantF f '[]
postposterous :: forall {k} (f :: k -> *). Void -> VariantF f '[]
postposterous = Void -> VariantF f '[]
\case
instance (EithersF f xs nested, Arbitrary nested) => Arbitrary (VariantF f xs) where
arbitrary :: Gen (VariantF f xs)
arbitrary = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) (xs :: [*]) o.
EithersF f xs o =>
o -> VariantF f xs
fromEithersF forall a. Arbitrary a => Gen a
arbitrary