Putting the FUN in Functors

Deriving.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Deriving where

import Data.Kind (Type)

newtype Cst a   i = MkCst { runCst :: a }
newtype Idt     i = MkIdt { runIdt :: i }
newtype Prd k l i = MkPrd { runPrd :: (k i, l i) }
newtype Sum k l i = MkSum { runSum :: Either (k i) (l i) }
newtype Fun a k i = MkFun { runFun :: a -> k i }

instance Functor (Cst a) where
  fmap f (MkCst v) = MkCst v
instance Functor Idt where
  fmap f (MkIdt v) = MkIdt (f v)
instance (Functor k, Functor l) => Functor (Prd k l) where
  fmap f (MkPrd (a, b)) = MkPrd (fmap f a, fmap f b)
instance (Functor k, Functor l) => Functor (Sum k l) where
  fmap f (MkSum (Left a)) = MkSum (Left (fmap f a))
  fmap f (MkSum (Right b)) = MkSum (Right (fmap f b))
instance Functor k => Functor (Fun a k) where
  fmap f (MkFun g) = MkFun (\ x -> fmap f (g x))

instance Monoid a => Applicative (Cst a) where
  pure _ = MkCst mempty
  MkCst v <*> MkCst w = MkCst (v <> w)
instance Applicative Idt where
  pure x = MkIdt x
  MkIdt f <*> MkIdt v = MkIdt (f v)
instance (Applicative k, Applicative l) => Applicative (Prd k l) where
  pure x = MkPrd (pure x, pure x)
  MkPrd (f, g) <*> MkPrd (x, y) = MkPrd (f <*> x, g <*> y)
instance Applicative k => Applicative (Fun a k) where
  pure x = MkFun (\ _ -> pure x)
  MkFun g <*> MkFun x = MkFun (\ r -> g r <*> x r)


instance Show a => Show (Cst a i) where
  show (MkCst v) = show v
instance Show i => Show (Idt i) where
  show (MkIdt v) = show v
instance (Show (k i), Show (l i)) => Show (Prd k l i) where
  show (MkPrd p) = show p
instance (Show (k i), Show (l i)) => Show (Sum k l i) where
  show (MkSum s) = show s

class Encodable t where
  type Code t :: Type -> Type
  encode :: t a -> Code t a
  decode :: Code t a -> t a

gfmap :: (Encodable t, Functor (Code t))
     => (a -> b)
     -> t a
     -> t b
gfmap f = decode . fmap f . encode

gpure :: (Encodable t, Applicative (Code t))
      => a -> t a
gpure = decode . pure

gap :: (Encodable t, Applicative (Code t))
    => t (a -> b) -> t a -> t b
gap tf tx = decode (encode tf <*> encode tx)

-- Breaking the abstraction
gshow :: (Encodable t, Show (Code t a))
      => t a -> String
gshow = show . encode

data Tuple a = MkTuple a a a
  deriving (Show)

instance Encodable Tuple where
  type Code Tuple = Prd Idt (Prd Idt Idt)
  encode (MkTuple a b c) = MkPrd (MkIdt a, MkPrd (MkIdt b, MkIdt c))
  decode (MkPrd (MkIdt a, MkPrd (MkIdt b, MkIdt c))) = MkTuple a b c

instance Functor Tuple where
  fmap = gfmap

instance Applicative Tuple where
  pure = gpure
  (<*>) = gap


data Optional a = None | Some a

instance Encodable Optional where
  type Code Optional = Sum (Cst ()) Idt
  encode None = MkSum (Left (MkCst ()))
  encode (Some x) = MkSum (Right (MkIdt x))
  decode (MkSum (Left (MkCst ()))) =  None
  decode (MkSum (Right (MkIdt x))) = Some x

instance Functor Optional where
  fmap = gfmap

instance Show a => Show (Optional a) where
  show = gshow

IDeriving.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Deriving where

import Data.Kind (Type)

newtype Cst a   f i = MkCst { runCst :: a }
newtype Idt     f i = MkIdt { runVar :: i }
newtype Rec     f i = MkRec { runIdt :: f i }
newtype Prd k l f i = MkPrd { runPrd :: (k f i, l f i) }
newtype Sum k l f i = MkSum { runSum :: Either (k f i) (l f i) }
newtype Fun a k f i = MkFun { runFun :: a -> k f i }

data Fix f i where
  MkFix :: f (Fix f) i -> Fix f i

instance Functor (Cst f a) where
  fmap f (MkCst v) = MkCst v
instance Functor (Idt f) where
  fmap f (MkIdt v) = MkIdt (f v)
instance Functor f => Functor (Rec f) where
  fmap f (MkRec v) = MkRec (fmap f v)
instance (Functor (k f), Functor (l f)) => Functor (Prd k l f) where
  fmap f (MkPrd (a, b)) = MkPrd (fmap f a, fmap f b)
instance (Functor (k f), Functor (l f)) => Functor (Sum k l f) where
  fmap f (MkSum (Left a)) = MkSum (Left (fmap f a))
  fmap f (MkSum (Right b)) = MkSum (Right (fmap f b))
instance Functor (k f) => Functor (Fun a k f) where
  fmap f (MkFun g) = MkFun (\ x -> fmap f (g x))

instance Functor (f (Fix f)) => Functor (Fix f) where
  fmap f (MkFix t) = MkFix (fmap f t)

class Encodable t where
  type Code t :: Type -> Type
  encode :: t a -> Code t a
  decode :: Code t a -> t a

gfmap :: (Encodable t, Functor (Code t))
     => (a -> b)
     -> t a
     -> t b
gfmap f = decode . fmap f . encode

data Tuple a = MkTuple a a a
  deriving (Show)

instance Encodable Tuple where
  type Code Tuple = Prd Idt (Prd Idt Idt) Int
  encode (MkTuple a b c) = MkPrd (MkIdt a, MkPrd (MkIdt b, MkIdt c))
  decode (MkPrd (MkIdt a, MkPrd (MkIdt b, MkIdt c))) = MkTuple a b c

instance Functor Tuple where
  fmap = gfmap

instance Encodable [] where
  type Code [] = Fix (Sum (Cst ()) (Prd Idt Rec))
  encode [] = MkFix (MkSum (Left (MkCst ())))
  encode (x:xs) = MkFix (MkSum (Right (MkPrd (MkIdt x, MkRec (encode xs)))))
  decode (MkFix (MkSum (Left (MkCst ())))) = []
  decode (MkFix (MkSum (Right (MkPrd (MkIdt x, MkRec xs))))) = x:decode xs

listMap :: (a -> b) -> [a] -> [b]
listMap = gfmap

test :: [Int]
test = listMap (+1) [1..10]