module Generics.OneLiner (
create, createA, ctorIndex,
create1, createA1, ctorIndex1,
createA_,
gmap, gfoldMap, gtraverse,
gmap1, gfoldMap1, gtraverse1,
mzipWith, zipWithA,
mzipWith1, zipWithA1,
consume, consume1,
nullaryOp, unaryOp, binaryOp, createA', algebra, dialgebra,
createA1', gcotraverse1,
GenericRecordProfunctor(..), record, record1,
GenericNonEmptyProfunctor(..), nonEmpty, nonEmpty1,
GenericProfunctor(..), generic, generic1,
ADT, ADTNonEmpty, ADTRecord, Constraints,
ADT1, ADTNonEmpty1, ADTRecord1, Constraints1,
For(..), AnyType
) where
import GHC.Generics
import Control.Applicative
import Data.Bifunctor.Biff
import Data.Bifunctor.Clown
import Data.Bifunctor.Joker
import Data.Functor.Compose
import Data.Functor.Contravariant.Divisible
import Data.Profunctor
import Data.Tagged
import Generics.OneLiner.Internal
create :: (ADT t, Constraints t c)
=> for c -> (forall s. c s => [s]) -> [t]
create = createA
createA :: (ADT t, Constraints t c, Alternative f)
=> for c -> (forall s. c s => f s) -> f t
createA for f = runJoker $ generic for $ Joker f
consume :: (ADT t, Constraints t c, Decidable f)
=> for c -> (forall s. c s => f s) -> f t
consume for f = runClown $ generic for $ Clown f
create1 :: (ADT1 t, Constraints1 t c)
=> for c -> (forall b s. c s => [b] -> [s b]) -> [a] -> [t a]
create1 = createA1
createA1 :: (ADT1 t, Constraints1 t c, Alternative f)
=> for c -> (forall b s. c s => f b -> f (s b)) -> f a -> f (t a)
createA1 for f = dimap Joker runJoker $ generic1 for $ dimap runJoker Joker f
createA_ :: (FunConstraints t c, Applicative f)
=> for c -> (forall s. c s => f s) -> t -> f (Result t)
createA_ for run = autoApply for run . pure
consume1 :: (ADT1 t, Constraints1 t c, Decidable f)
=> for c -> (forall b s. c s => f b -> f (s b)) -> f a -> f (t a)
consume1 for f = dimap Clown runClown $ generic1 for $ dimap runClown Clown f
gmap :: (ADT t, Constraints t c)
=> for c -> (forall s. c s => s -> s) -> t -> t
gmap = generic
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 = runStar $ generic for $ Star f
gmap1 :: (ADT1 t, Constraints1 t c)
=> for c -> (forall d e s. c s => (d -> e) -> s d -> s e) -> (a -> b) -> t a -> t b
gmap1 = generic1
gfoldMap1 :: (ADT1 t, Constraints1 t c, Monoid m)
=> for c -> (forall s b. c s => (b -> m) -> s b -> m) -> (a -> m) -> t a -> m
gfoldMap1 for f = dimap (Const .) (getConst .) $ gtraverse1 for $ dimap (getConst .) (Const .) f
gtraverse1 :: (ADT1 t, Constraints1 t c, Applicative f)
=> for c -> (forall d e s. c s => (d -> f e) -> s d -> f (s e)) -> (a -> f b) -> t a -> f (t b)
gtraverse1 for f = dimap Star runStar $ generic1 for $ dimap runStar Star f
mzipWith :: (ADT t, Constraints t c, Monoid m)
=> for c -> (forall s. c s => s -> s -> m) -> t -> t -> m
mzipWith for f = outm2 $ zipWithA for $ inm2 f
zipWithA :: (ADT t, Constraints t c, Alternative f)
=> for c -> (forall s. c s => s -> s -> f s) -> t -> t -> f t
zipWithA for f = runZip $ generic for $ Zip f
mzipWith1 :: (ADT1 t, Constraints1 t c, Monoid m)
=> for c -> (forall s b. c s => (b -> b -> m) -> s b -> s b -> m)
-> (a -> a -> m) -> t a -> t a -> m
mzipWith1 for f = dimap inm2 outm2 $ zipWithA1 for $ dimap outm2 inm2 f
zipWithA1 :: (ADT1 t, Constraints1 t c, Alternative f)
=> for c -> (forall d e s. c s => (d -> d -> f e) -> s d -> s d -> f (s e))
-> (a -> a -> f b) -> t a -> t a -> f (t b)
zipWithA1 for f = dimap Zip runZip $ generic1 for $ dimap runZip Zip f
newtype Zip f a b = Zip { runZip :: a -> a -> f b }
instance Functor f => Profunctor (Zip f) where
dimap f g (Zip h) = Zip $ \a1 a2 -> fmap g (h (f a1) (f a2))
instance Applicative f => GenericRecordProfunctor (Zip f) where
unit = Zip $ \_ _ -> pure U1
mult (Zip f) (Zip g) = Zip $ \(al :*: ar) (bl :*: br) -> (:*:) <$> f al bl <*> g ar br
instance Alternative f => GenericNonEmptyProfunctor (Zip f) where
plus (Zip f) (Zip g) = Zip h where
h (L1 a) (L1 b) = fmap L1 (f a b)
h (R1 a) (R1 b) = fmap R1 (g a b)
h _ _ = empty
instance Alternative f => GenericProfunctor (Zip f) where
zero = Zip absurd
identity = Zip $ \_ _ -> empty
inm2 :: (t -> t -> m) -> t -> t -> Compose Maybe (Const m) a
inm2 f = Compose .: Just .: Const .: f
outm2 :: Monoid m => (t -> t -> Compose Maybe (Const m) a) -> t -> t -> m
outm2 f = maybe mempty getConst .: getCompose .: f
nullaryOp :: (ADTRecord t, Constraints t c)
=> for c -> (forall s. c s => s) -> t
nullaryOp for f = unTagged $ record for $ Tagged f
unaryOp :: (ADTRecord t, Constraints t c)
=> for c -> (forall s. c s => s -> s) -> t -> t
unaryOp = record
binaryOp :: (ADTRecord t, Constraints t c)
=> for c -> (forall s. c s => s -> s -> s) -> t -> t -> t
binaryOp for f = algebra for (\(Pair a b) -> f a b) .: Pair
createA' :: (ADTRecord t, Constraints t c, Applicative f)
=> for c -> (forall s. c s => f s) -> f t
createA' for f = runJoker $ record for $ Joker f
data Pair a = Pair a a
instance Functor Pair where
fmap f (Pair a b) = Pair (f a) (f b)
algebra :: (ADTRecord t, Constraints t c, Functor f)
=> for c -> (forall s. c s => f s -> s) -> f t -> t
algebra for f = runCostar $ record for $ Costar f
dialgebra :: (ADTRecord t, Constraints t c, Functor f, Applicative g)
=> for c -> (forall s. c s => f s -> g s) -> f t -> g t
dialgebra for f = runBiff $ record for $ Biff f
createA1' :: (ADTRecord1 t, Constraints1 t c, Applicative f)
=> for c -> (forall b s. c s => f b -> f (s b)) -> f a -> f (t a)
createA1' for f = dimap Joker runJoker $ record1 for $ dimap runJoker Joker f
gcotraverse1 :: (ADTRecord1 t, Constraints1 t c, Functor f)
=> for c -> (forall d e s. c s => (f d -> e) -> f (s d) -> s e) -> (f a -> b) -> f (t a) -> t b
gcotraverse1 for f p = runCostar $ record1 for (Costar . f . runCostar) (Costar p)
infixr 9 .:
(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
(.:) = (.) . (.)