{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Compose.List
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  sjoerd@w3future.com
--
-----------------------------------------------------------------------------
module Data.Functor.Compose.List where

import Data.Type.List

-- | N-ary composition of functors.
--
-- > FList '[] a ~ a
-- > FList '[f, g, h] a ~ h (g (f a))
data FList (fs :: [* -> *]) (a :: *) where
  Id :: { forall a. FList '[] a -> a
unId :: a } -> FList '[] a
  F :: { forall (g :: * -> *) a. FList '[g] a -> g a
unF :: f a } -> FList '[f] a
  FComp :: { forall (g :: * -> *) (gs :: [* -> *]) (f :: * -> *) a.
FList (f : g : gs) a -> FList (g : gs) (f a)
unFComp :: FList (g ': gs) (f a) } -> FList (f ': g ': gs) a

instance Functor (FList '[]) where
  fmap :: forall a b. (a -> b) -> FList '[] a -> FList '[] b
fmap a -> b
f = forall a. a -> FList '[] a
Id forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FList '[] a -> a
unId
instance Functor f => Functor (FList '[f]) where
  fmap :: forall a b. (a -> b) -> FList '[f] a -> FList '[f] b
fmap a -> b
f = forall (g :: * -> *) a. g a -> FList '[g] a
F forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (g :: * -> *) a. FList '[g] a -> g a
unF
instance (Functor f, Functor (FList (g ': gs))) => Functor (FList (f ': g ': gs)) where
  fmap :: forall a b.
(a -> b) -> FList (f : g : gs) a -> FList (f : g : gs) b
fmap a -> b
f = forall (g :: * -> *) (gs :: [* -> *]) (f :: * -> *) a.
FList (g : gs) (f a) -> FList (f : g : gs) a
FComp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (g :: * -> *) (gs :: [* -> *]) (f :: * -> *) a.
FList (f : g : gs) a -> FList (g : gs) (f a)
unFComp

-- | Calculate the simplified type of the composition of a list of functors.
type family PlainF (fs :: [* -> *]) (a :: *) :: *
type instance PlainF '[] a = a
type instance PlainF (f ': fs) a = PlainF fs (f a)

-- | Functions for working with `FList`s.
class IsFList fs where
  -- | Combine 2 nested `FList`s into one `FList`.
  fappend :: Functor (FList gs) => FList gs (FList fs a) -> FList (fs ++ gs) a
  -- | Split one `FList` into 2 nested `FList`s.
  funappend :: Functor (FList gs) => FList (fs ++ gs) a -> FList gs (FList fs a)
  -- | Convert an `FList` to its simplified form.
  toPlainF :: FList fs a -> PlainF fs a
  -- | Create an `FList` from its simplified form.
  fromPlainF :: PlainF fs a -> FList fs a
instance IsFList '[] where
  fappend :: forall (gs :: [* -> *]) a.
Functor (FList gs) =>
FList gs (FList '[] a) -> FList ('[] ++ gs) a
fappend = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FList '[] a -> a
unId
  funappend :: forall (gs :: [* -> *]) a.
Functor (FList gs) =>
FList ('[] ++ gs) a -> FList gs (FList '[] a)
funappend = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> FList '[] a
Id
  toPlainF :: forall a. FList '[] a -> PlainF '[] a
toPlainF (Id a
a) = a
a
  fromPlainF :: forall a. PlainF '[] a -> FList '[] a
fromPlainF PlainF '[] a
a = forall a. a -> FList '[] a
Id PlainF '[] a
a
instance IsFList '[f] where
  fappend :: forall (gs :: [* -> *]) a.
Functor (FList gs) =>
FList gs (FList '[f] a) -> FList ('[f] ++ gs) a
fappend (Id FList '[f] a
fa) = forall (g :: * -> *) a. g a -> FList '[g] a
F (forall (g :: * -> *) a. FList '[g] a -> g a
unF FList '[f] a
fa)
  fappend f :: FList gs (FList '[f] a)
f@F{} = forall (g :: * -> *) (gs :: [* -> *]) (f :: * -> *) a.
FList (g : gs) (f a) -> FList (f : g : gs) a
FComp forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (g :: * -> *) a. FList '[g] a -> g a
unF FList gs (FList '[f] a)
f
  fappend f :: FList gs (FList '[f] a)
f@FComp{} = forall (g :: * -> *) (gs :: [* -> *]) (f :: * -> *) a.
FList (g : gs) (f a) -> FList (f : g : gs) a
FComp forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (g :: * -> *) a. FList '[g] a -> g a
unF FList gs (FList '[f] a)
f
  funappend :: forall (gs :: [* -> *]) a.
Functor (FList gs) =>
FList ('[f] ++ gs) a -> FList gs (FList '[f] a)
funappend fa :: FList ('[f] ++ gs) a
fa@F{} = forall a. a -> FList '[] a
Id FList ('[f] ++ gs) a
fa
  funappend (FComp fga :: FList (g : gs) (f a)
fga@F{}) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (g :: * -> *) a. g a -> FList '[g] a
F FList (g : gs) (f a)
fga
  funappend (FComp fga :: FList (g : gs) (f a)
fga@FComp{}) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (g :: * -> *) a. g a -> FList '[g] a
F FList (g : gs) (f a)
fga
  toPlainF :: forall a. FList '[f] a -> PlainF '[f] a
toPlainF (F f a
fa) = f a
fa
  fromPlainF :: forall a. PlainF '[f] a -> FList '[f] a
fromPlainF PlainF '[f] a
fa = forall (g :: * -> *) a. g a -> FList '[g] a
F PlainF '[f] a
fa
instance IsFList (g ': gs) => IsFList (f ': g ': gs) where
  fappend :: forall (gs :: [* -> *]) a.
Functor (FList gs) =>
FList gs (FList (f : g : gs) a) -> FList ((f : g : gs) ++ gs) a
fappend = forall (g :: * -> *) (gs :: [* -> *]) (f :: * -> *) a.
FList (g : gs) (f a) -> FList (f : g : gs) a
FComp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fs :: [* -> *]) (gs :: [* -> *]) a.
(IsFList fs, Functor (FList gs)) =>
FList gs (FList fs a) -> FList (fs ++ gs) a
fappend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (g :: * -> *) (gs :: [* -> *]) (f :: * -> *) a.
FList (f : g : gs) a -> FList (g : gs) (f a)
unFComp
  funappend :: forall (gs :: [* -> *]) a.
Functor (FList gs) =>
FList ((f : g : gs) ++ gs) a -> FList gs (FList (f : g : gs) a)
funappend = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (g :: * -> *) (gs :: [* -> *]) (f :: * -> *) a.
FList (g : gs) (f a) -> FList (f : g : gs) a
FComp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (fs :: [* -> *]) (gs :: [* -> *]) a.
(IsFList fs, Functor (FList gs)) =>
FList (fs ++ gs) a -> FList gs (FList fs a)
funappend forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (g :: * -> *) (gs :: [* -> *]) (f :: * -> *) a.
FList (f : g : gs) a -> FList (g : gs) (f a)
unFComp
  toPlainF :: forall a. FList (f : g : gs) a -> PlainF (f : g : gs) a
toPlainF (FComp FList (g : gs) (f a)
fgs) = forall (fs :: [* -> *]) a. IsFList fs => FList fs a -> PlainF fs a
toPlainF FList (g : gs) (f a)
fgs
  fromPlainF :: forall a. PlainF (f : g : gs) a -> FList (f : g : gs) a
fromPlainF PlainF (f : g : gs) a
fgs = forall (g :: * -> *) (gs :: [* -> *]) (f :: * -> *) a.
FList (g : gs) (f a) -> FList (f : g : gs) a
FComp (forall (fs :: [* -> *]) a. IsFList fs => PlainF fs a -> FList fs a
fromPlainF PlainF (f : g : gs) a
fgs)


-- | Natural transformations between two functors. (Why is this still not in base??)
type f ~> g = forall a. f a -> g a