Crap

eblo.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}
module Composers where

import Control.Applicative (Applicative(..), liftA2)
import GHC.Exts (Constraint)

type family ForEach (c :: (* -> *) -> Constraint) (fs :: [* -> *]) :: Constraint where
    ForEach c '[] = ()
    ForEach c (f ': fs) = (c f, ForEach c fs)

data Compose :: [* -> *] -> * -> * where
  Pure :: a -> Compose '[] a
  Compose :: f (Compose fs a) -> Compose (f ': fs) a

instance ForEach Functor fs => Functor (Compose fs) where
  fmap :: (a -> b) -> Compose fs a -> Compose fs b
  fmap f (Pure x) = Pure (f x)
  fmap f (Compose g) = Compose (fmap (fmap f) g)

instance Applicative (Compose '[]) where
  pure :: a -> Compose '[] a
  pure = Pure
  (<*>) :: Compose '[] (a -> b) -> Compose '[] a -> Compose '[] b
  Pure f <*> Pure x = Pure (f x)

instance (ForEach Functor (f ': fs), Applicative f, Applicative (Compose fs)) => Applicative (Compose (f ': fs)) where
  pure :: a -> Compose (f ': fs) a
  pure = Compose . pure . pure
  (<*>) :: Compose (f ': fs) (a -> b) -> Compose (f ': fs) a -> Compose (f ': fs) b
  Compose f <*> Compose x = Compose (liftA2 (<*>) f x)