{-# LANGUAGE
TypeFamilies
, ConstraintKinds
, MultiParamTypeClasses
, FlexibleInstances
, UndecidableInstances
#-}
module Data.Algebra.Internal where
import GHC.Exts (Constraint)
import Control.Applicative (Const)
import Data.Monoid (Ap)
import GHC.Conc (STM)
import Control.Arrow ((&&&))
type family Signature (c :: * -> Constraint) :: * -> *
class Traversable f => AlgebraSignature f where
type Class f :: * -> Constraint
evaluate :: Class f b => f b -> b
class Algebra f a where
algebra :: AlgebraSignature f => f a -> a
algebraA :: (Applicative g, Class f b, AlgebraSignature f) => f (g b) -> g b
algebraA :: f (g b) -> g b
algebraA = (f b -> b) -> g (f b) -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f b -> b
forall (f :: * -> *) b. (AlgebraSignature f, Class f b) => f b -> b
evaluate (g (f b) -> g b) -> (f (g b) -> g (f b)) -> f (g b) -> g b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (g b) -> g (f b)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
instance Algebra f () where
algebra :: f () -> ()
algebra = () -> f () -> ()
forall a b. a -> b -> a
const ()
instance (Class f m, Class f n) => Algebra f (m, n) where
algebra :: f (m, n) -> (m, n)
algebra = f m -> m
forall (f :: * -> *) b. (AlgebraSignature f, Class f b) => f b -> b
evaluate (f m -> m) -> (f (m, n) -> f m) -> f (m, n) -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((m, n) -> m) -> f (m, n) -> f m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (m, n) -> m
forall a b. (a, b) -> a
fst (f (m, n) -> m) -> (f (m, n) -> n) -> f (m, n) -> (m, n)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& f n -> n
forall (f :: * -> *) b. (AlgebraSignature f, Class f b) => f b -> b
evaluate (f n -> n) -> (f (m, n) -> f n) -> f (m, n) -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((m, n) -> n) -> f (m, n) -> f n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (m, n) -> n
forall a b. (a, b) -> b
snd
instance Class f b => Algebra f (a -> b) where algebra :: f (a -> b) -> a -> b
algebra = f (a -> b) -> a -> b
forall (g :: * -> *) (f :: * -> *) b.
(Applicative g, Class f b, AlgebraSignature f) =>
f (g b) -> g b
algebraA
instance Class f b => Algebra f (IO b) where algebra :: f (IO b) -> IO b
algebra = f (IO b) -> IO b
forall (g :: * -> *) (f :: * -> *) b.
(Applicative g, Class f b, AlgebraSignature f) =>
f (g b) -> g b
algebraA
instance Class f b => Algebra f (Maybe b) where algebra :: f (Maybe b) -> Maybe b
algebra = f (Maybe b) -> Maybe b
forall (g :: * -> *) (f :: * -> *) b.
(Applicative g, Class f b, AlgebraSignature f) =>
f (g b) -> g b
algebraA
instance Class f b => Algebra f (Either a b) where algebra :: f (Either a b) -> Either a b
algebra = f (Either a b) -> Either a b
forall (g :: * -> *) (f :: * -> *) b.
(Applicative g, Class f b, AlgebraSignature f) =>
f (g b) -> g b
algebraA
instance Class f b => Algebra f (STM b) where algebra :: f (STM b) -> STM b
algebra = f (STM b) -> STM b
forall (g :: * -> *) (f :: * -> *) b.
(Applicative g, Class f b, AlgebraSignature f) =>
f (g b) -> g b
algebraA
instance (Class f b, Applicative g) => Algebra f (Ap g b) where algebra :: f (Ap g b) -> Ap g b
algebra = f (Ap g b) -> Ap g b
forall (g :: * -> *) (f :: * -> *) b.
(Applicative g, Class f b, AlgebraSignature f) =>
f (g b) -> g b
algebraA
instance (Monoid m, Class f b) => Algebra f (Const m b) where algebra :: f (Const m b) -> Const m b
algebra = f (Const m b) -> Const m b
forall (g :: * -> *) (f :: * -> *) b.
(Applicative g, Class f b, AlgebraSignature f) =>
f (g b) -> g b
algebraA