{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Boring (
Boring (..),
Absurd (..),
vacuous,
boringRep,
untainted,
devoid,
united,
) where
import Prelude ()
import Prelude.Compat
import Control.Applicative (Const (..))
import Data.Functor.Identity (Identity (..))
import Data.Functor.Compose (Compose (..))
import Data.Functor.Product (Product (..))
import Data.Functor.Sum (Sum (..))
import Data.Functor.Rep (Representable (..))
import Data.Constraint (Dict (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.Proxy (Proxy (..))
import Data.Tagged (Tagged (..))
import Data.Stream.Infinite (Stream (..))
import qualified Data.Fin as Fin
import qualified Data.Nat as Nat
import qualified Data.Vec.Lazy as Vec
import qualified Data.Vec.Pull as Vec.Pull
import qualified Data.Void as V
import qualified Generics.SOP as SOP
#if MIN_VERSION_base(4,7,0)
import qualified Data.Type.Equality as Eq
#endif
class Boring a where
boring :: a
instance Boring () where
boring = ()
instance Boring b => Boring (a -> b) where
boring = const boring
instance Boring (Proxy a) where
boring = Proxy
instance Boring a => Boring (Const a b) where
boring = Const boring
instance Boring b => Boring (Tagged a b) where
boring = Tagged boring
instance Boring a => Boring (Identity a) where
boring = Identity boring
instance Boring a => Boring (SOP.I a) where
boring = SOP.I boring
instance Boring b => Boring (SOP.K b a) where
boring = SOP.K boring
instance Boring (f (g a)) => Boring (Compose f g a) where
boring = Compose boring
instance (Boring (f a), Boring (g a)) => Boring (Product f g a) where
boring = Pair boring boring
instance c => Boring (Dict c) where
boring = Dict
instance (Boring a, Boring b) => Boring (a, b) where
boring = (boring, boring)
instance (Boring a, Boring b, Boring c) => Boring (a, b, c) where
boring = (boring, boring, boring)
instance (Boring a, Boring b, Boring c, Boring d) => Boring (a, b, c, d) where
boring = (boring, boring, boring, boring)
instance (Boring a, Boring b, Boring c, Boring d, Boring e) => Boring (a, b, c, d, e) where
boring = (boring, boring, boring, boring, boring)
instance Boring a => Boring (Stream a) where
boring = boring :> boring
instance Absurd a => Boring [a] where
boring = []
instance Absurd a => Boring (Maybe a) where
boring = Nothing
#if MIN_VERSION_base(4,7,0)
instance a ~ b => Boring (a Eq.:~: b) where
boring = Eq.Refl
#endif
instance n ~ 'Nat.Z => Boring (Vec.Vec n a) where
boring = Vec.empty
instance n ~ 'Nat.Z => Boring (Vec.Pull.Vec n a) where
boring = Vec.Pull.empty
instance n ~ ('Nat.S 'Nat.Z) => Boring (Fin.Fin n) where
boring = Fin.boring
class Absurd a where
absurd :: a -> b
instance Absurd V.Void where
absurd = V.absurd
instance (Absurd a, Absurd b) => Absurd (Either a b) where
absurd (Left a) = absurd a
absurd (Right b) = absurd b
instance Absurd a => Absurd (NonEmpty a) where
absurd (x :| _) = absurd x
instance Absurd a => Absurd (Stream a) where
absurd (x :> _) = absurd x
instance Absurd a => Absurd (Identity a) where
absurd = absurd . runIdentity
instance Absurd (f (g a)) => Absurd (Compose f g a) where
absurd = absurd . getCompose
instance (Absurd (f a), Absurd (g a)) => Absurd (Sum f g a) where
absurd (InL fa) = absurd fa
absurd (InR ga) = absurd ga
instance Absurd b => Absurd (Const b a) where
absurd = absurd . getConst
instance Absurd a => Absurd (Tagged b a) where
absurd = absurd . unTagged
instance Absurd a => Absurd (SOP.I a) where
absurd = absurd . SOP.unI
instance Absurd b => Absurd (SOP.K b a) where
absurd = absurd . SOP.unK
instance n ~ 'Nat.Z => Absurd (Fin.Fin n) where
absurd = Fin.absurd
vacuous :: (Functor f, Absurd a) => f a -> f b
vacuous = fmap absurd
boringRep :: (Representable f, Absurd (Rep f)) => f a
boringRep = tabulate absurd
untainted :: (Representable f, Boring (Rep f)) => f a -> a
untainted = flip index boring
devoid :: Absurd s => p a (f b) -> s -> f s
devoid _ = absurd
united :: (Boring a, Functor f) => (a -> f a) -> s -> f s
united f v = v <$ f boring