KindGenericSOP.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE PolyKinds #-}
module KindGenericSOP where

import Data.Kind
import Generics.SOP

-- | The 'SOP1' class corresponds to 'Generic'.
class All SListI (Code1 f) => SOP1 (f :: k -> Type) where
  type Code1 f :: [[ k -> Type ]]
  from1 :: f a -> Rep1 f a
  to1   :: Rep1 f a -> f a

type Rep1 f a = SOP (I1 a) (Code1 f)
newtype I1 a f = I1 { unI1 :: f a }

-- | Example: labelled trees.
data Tree a = Leaf a | Node (Tree a) (Tree a)
  deriving Show

instance SOP1 Tree where

  type Code1 Tree = '[ '[ I ], '[ Tree, Tree ] ]

  from1 (Leaf a) = SOP (Z (I1 (I a) :* Nil))
  from1 (Node l r) = SOP (S (Z (I1 l :* I1 r :* Nil)))

  to1 (SOP (Z (I1 (I a) :* Nil))) = Leaf a
  to1 (SOP (S (Z (I1 l :* I1 r :* Nil)))) = Node l r

-- | Generic map.
gfmap :: (SOP1 f, All2 Functor (Code1 f)) => (a -> b) -> f a -> f b
gfmap f =
  to1 . hcmap (Proxy :: Proxy Functor) (I1 . fmap f . unI1) . from1

-- | Generic foldMap.
gfoldMap :: (SOP1 f, All2 Foldable (Code1 f), Monoid m) => (a -> m) -> f a -> m
gfoldMap f =
    mconcat
  . hcollapse
  . hcmap (Proxy :: Proxy Foldable)
      (K . foldMap f . unI1)
  . from1

-- | Generic traverse.
gtraverse ::
  (SOP1 f, All2 Traversable (Code1 f), Applicative g) => (a -> g b) -> f a -> g (f b)
gtraverse f =
    (to1 <$>)
  . hsequence'
  . hcmap (Proxy :: Proxy Traversable)
      (Comp . (I1 <$>) . traverse f . unI1)
  . from1

-- | Example: lambda terms with a flexible variable type.
data Lam a = Var a | App (Lam a) (Lam a) | Abs a (Lam a)

instance SOP1 Lam where

  type Code1 Lam = '[ '[ I ], '[ Lam, Lam ], '[ I, Lam ] ]

  from1 (Var x) = SOP (Z (I1 (I x) :* Nil))
  from1 (App e1 e2) = SOP (S (Z (I1 e1 :* I1 e2 :* Nil)))
  from1 (Abs x e) = SOP (S (S (Z (I1 (I x) :* I1 e :* Nil))))

  to1 (SOP (Z (I1 (I x) :* Nil))) = Var x
  to1 (SOP (S (Z (I1 e1 :* I1 e2 :* Nil)))) = App e1 e2
  to1 (SOP (S (S (Z (I1 (I x) :* I1 e :* Nil))))) = Abs x e

-- | Example: Rose trees.
data Rose a = Fork a [Rose a]
  deriving Show

instance SOP1 Rose where

  type Code1 Rose = '[ '[ I, [] :.: Rose ] ]

  from1 (Fork x xs) = SOP (Z (I1 (I x) :* I1 (Comp xs) :* Nil))
  to1 (SOP (Z (I1 (I x) :* I1 (Comp xs) :* Nil))) = Fork x xs

instance Functor Tree where
  fmap = gfmap

instance Foldable Tree where
  foldMap = gfoldMap

instance Traversable Tree where
  traverse = gtraverse

instance Functor Lam where
  fmap = gfmap

instance Foldable Lam where
  foldMap = gfoldMap

instance Traversable Lam where
  traverse = gtraverse

instance Functor Rose where
  fmap = gfmap

instance Foldable Rose where
  foldMap = gfoldMap

instance Traversable Rose where
  traverse = gtraverse

-- | Similar approach for abstraction over two arguments.
class SOP2 (f :: k1 -> k2 -> Type) where
  type Code2 f :: [[ k1 -> k2 -> Type ]]
  from2 :: f a b -> Rep2 f a b
  to2   :: Rep2 f a b -> f a b

type Rep2 f a b = SOP (I2 a b) (Code2 f)

newtype I2 a b f = I2 { unI2 :: f a b }

class Bifunctor f where
  bimap :: (a -> b) -> (c -> d) -> f a c -> f b d

gbimap :: (SOP2 f, All2 Bifunctor (Code2 f)) => (a -> b) -> (c -> d) -> f a c -> f b d
gbimap f g =
  to2 . hcmap (Proxy :: Proxy Bifunctor) (I2 . bimap f g . unI2) . from2

data Product f g a b = Pair (f a b) (g a b)

instance SOP2 (Product f g) where

  type Code2 (Product f g) = '[ '[ f, g ] ]

  from2 (Pair f g) = SOP (Z (I2 f :* I2 g :* Nil))
  to2 (SOP (Z (I2 f :* I2 g :* Nil))) = Pair f g

instance (Bifunctor f, Bifunctor g) => Bifunctor (Product f g) where
  bimap = gbimap