module Generics.OneLiner.Internal where
import GHC.Generics
import GHC.Types (Constraint)
import GHC.TypeLits
import Data.Proxy
import Data.Profunctor
type family Constraints' (t :: * -> *) (c :: * -> Constraint) :: Constraint
type instance Constraints' V1 c = ()
type instance Constraints' U1 c = ()
type instance Constraints' (f :+: g) c = (Constraints' f c, Constraints' g c)
type instance Constraints' (f :*: g) c = (Constraints' f c, Constraints' g c)
type instance Constraints' (M1 i t f) c = Constraints' f c
type instance Constraints' (K1 i a) c = c a
class ADT' (t :: * -> *) where
type CtorCount' t :: Nat
type CtorCount' t = 1
ctorIndex' :: t x -> Int
ctorIndex' _ = 0
ctorCount :: proxy t -> Int
ctorCount _ = 1
p :: (Constraints' t c, GenericProfunctor p)
=> for c -> (forall s. c s => p s s) -> p (t x) (t x)
instance ADT' V1 where
type CtorCount' V1 = 0
ctorCount _ = 0
p _ _ = zero
instance (ADT' f, ADT' g) => ADT' (f :+: g) where
type CtorCount' (f :+: g) = CtorCount' f + CtorCount' g
ctorIndex' (L1 l) = ctorIndex' l
ctorIndex' (R1 r) = ctorCount (Proxy :: Proxy f) + ctorIndex' r
ctorCount _ = ctorCount (Proxy :: Proxy f) + ctorCount (Proxy :: Proxy g)
p for f = plus (p for f) (p for f)
instance ADT' U1 where
p _ _ = unit
instance (ADT' f, ADT' g) => ADT' (f :*: g) where
p for f = mult (p for f) (p for f)
instance ADT' (K1 i v) where
p _ = dimap unK1 K1
instance ADT' f => ADT' (M1 i t f) where
type CtorCount' (M1 i t f) = CtorCount' f
ctorIndex' = ctorIndex' . unM1
ctorCount _ = ctorCount (Proxy :: Proxy f)
p for f = dimap unM1 M1 (p for f)
class Profunctor p => GenericProfunctor p where
zero :: p (V1 a) (V1 a)
unit :: p (U1 a) (U1 a)
plus :: p (f a) (f' a) -> p (g a) (g' a) -> p ((f :+: g) a) ((f' :+: g') a)
mult :: p (f a) (f' a) -> p (g a) (g' a) -> p ((f :*: g) a) ((f' :*: g') a)
instance Applicative f => GenericProfunctor (Star f) where
zero = Star pure
unit = Star pure
plus (Star f) (Star g) = Star $ \case
L1 l -> L1 <$> f l
R1 r -> R1 <$> g r
mult (Star f) (Star g) = Star $ \(l :*: r) -> (:*:) <$> f l <*> g r
generic :: (ADT t, Constraints t c, GenericProfunctor p)
=> for c -> (forall s. c s => p s s) -> p t t
generic for f = dimap from to $ p for f
type Constraints t c = Constraints' (Rep t) c
type ADT t = (Generic t, ADT' (Rep t))
type CtorCount t = CtorCount' (Rep t)
type ADTRecord t = (ADT t, 1 ~ CtorCount t)
type ADTNonEmpty t = (ADT t, 1 <= CtorCount t)
data For (c :: * -> Constraint) = For
ctorIndex :: ADT t => t -> Int
ctorIndex = ctorIndex' . from