module Generics.OneLiner (
create, createA, ctorIndex,
gmap, gfoldMap, gtraverse,
gzipWith, mzipWith, zipWithA,
op0, op1, op2,
ADT, ADTRecord, Constraints, For(..)
) where
import GHC.Generics
import GHC.Prim (Constraint)
import Control.Applicative
import Data.Functor.Identity
import Data.Monoid
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' (K1 i v) c = c v
type instance Constraints' (M1 i t f) c = Constraints' f c
class ADT' (t :: * -> *) where
ctorIndex' :: t x -> Int
ctorIndex' _ = 0
ctorCount :: proxy (t x) -> Int
ctorCount _ = 1
f0 :: (Constraints' t c, Applicative f)
=> for c -> (forall s. c s => f s) -> [f (t ())]
f1 :: (Constraints' t c, Applicative f)
=> for c -> (forall s. c s => s -> f s) -> t x -> f (t x)
f2 :: (Constraints' t c, Applicative f)
=> for c -> (forall s. c s => s -> s -> f s) -> t x -> t x -> Maybe (f (t x))
instance ADT' V1 where
ctorCount _ = 0
f0 _ _ = []
f1 _ _ = pure
f2 _ _ _ = Just . pure
instance (ADT' f, ADT' g) => ADT' (f :+: g) where
ctorIndex' (L1 l) = ctorIndex' l
ctorIndex' (R1 r) = ctorCount (undefined :: [f ()]) + ctorIndex' r
ctorCount _ = ctorCount (undefined :: [f ()]) + ctorCount (undefined :: [g ()])
f0 for f = map (fmap L1) (f0 for f) ++ map (fmap R1) (f0 for f)
f1 for f (L1 l) = L1 <$> f1 for f l
f1 for f (R1 r) = R1 <$> f1 for f r
f2 for f (L1 a) (L1 b) = fmap (fmap L1) (f2 for f a b)
f2 for f (R1 a) (R1 b) = fmap (fmap R1) (f2 for f a b)
f2 _ _ _ _ = Nothing
instance ADT' U1 where
f0 _ _ = [pure U1]
f1 _ _ = pure
f2 _ _ _ = Just . pure
instance (ADT' f, ADT' g) => ADT' (f :*: g) where
f0 for f = [(:*:) <$> head (f0 for f) <*> head (f0 for f)]
f1 for f (l :*: r) = (:*:) <$> f1 for f l <*> f1 for f r
f2 for f (al :*: ar) (bl :*: br) = liftA2 (:*:) <$> f2 for f al bl <*> f2 for f ar br
instance ADT' (K1 i v) where
f0 _ f = [K1 <$> f]
f1 _ f (K1 v) = K1 <$> f v
f2 _ f (K1 l) (K1 r) = Just $ K1 <$> f l r
instance ADT' f => ADT' (M1 i t f) where
ctorIndex' = ctorIndex' . unM1
ctorCount _ = ctorCount (undefined :: [M1 i t f ()])
f0 for f = map (fmap M1) (f0 for f)
f1 for f = fmap M1 . f1 for f . unM1
f2 for f (M1 l) (M1 r) = fmap (fmap M1) (f2 for f l r)
class ADTRecord' (f :: * -> *) where
instance ADTRecord' U1
instance ADTRecord' (f :*: g)
instance ADTRecord' (K1 i v)
instance ADTRecord' f => ADTRecord' (M1 i t f)
instance ADTRecord' f => ADTRecord' (V1 :+: f)
instance ADTRecord' f => ADTRecord' (f :+: V1)
type Constraints t c = Constraints' (Rep t) c
type ADT t = (Generic t, ADT' (Rep t))
type ADTRecord t = (ADT t, ADTRecord' (Rep t))
data For (c :: * -> Constraint) = For
create :: (ADT t, Constraints t c)
=> for c -> (forall s. c s => s) -> [t]
create for f = map runIdentity (createA for (Identity f))
createA :: (ADT t, Constraints t c, Applicative f)
=> for c -> (forall s. c s => f s) -> [f t]
createA for f = map (fmap to) (f0 for f)
ctorIndex :: ADT t => t -> Int
ctorIndex = ctorIndex' . from
gmap :: (ADT t, Constraints t c)
=> for c -> (forall s. c s => s -> s) -> t -> t
gmap for f = runIdentity . gtraverse for (Identity . f)
gfoldMap :: (ADT t, Constraints t c, Monoid m)
=> for c -> (forall s. c s => s -> m) -> t -> m
gfoldMap for f = getConst . gtraverse for (Const . f)
gtraverse :: (ADT t, Constraints t c, Applicative f)
=> for c -> (forall s. c s => s -> f s) -> t -> f t
gtraverse for f = fmap to . f1 for f . from
gzipWith :: (ADT t, Constraints t c)
=> for c -> (forall s. c s => s -> s -> s) -> t -> t -> Maybe t
gzipWith for f l r = runIdentity <$> zipWithA for (\x y -> Identity (f x y)) l r
mzipWith :: (ADT t, Constraints t c, Monoid m)
=> for c -> (forall s. c s => s -> s -> m) -> t -> t -> m
mzipWith for f l r = maybe mempty getConst $ zipWithA for (\x y -> Const (f x y)) l r
zipWithA :: (ADT t, Constraints t c, Applicative f)
=> for c -> (forall s. c s => s -> s -> f s) -> t -> t -> Maybe (f t)
zipWithA for f l r = fmap (fmap to) (f2 for f (from l) (from r))
op0 :: (ADTRecord t, Constraints t c)
=> for c -> (forall s. c s => s) -> t
op0 for f = head $ create for f
op1 :: (ADTRecord t, Constraints t c)
=> for c -> (forall s. c s => s -> s) -> t -> t
op1 = gmap
op2 :: (ADTRecord t, Constraints t c)
=> for c -> (forall s. c s => s -> s -> s) -> t -> t -> t
op2 for f l r = case gzipWith for f l r of
Just t -> t
Nothing -> error "op2: constructor mismatch should not be possible for ADTRecord"