Foldable for GHC.Generic instances

generic-fold.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

import GHC.Generics
import Data.Foldable as Foldable
import Data.Monoid

main :: IO ()
main = do
  print . Foldable.sum $ GFold (Right (1 :: Int))
  print . Foldable.sum $ GFold (1 :: Int, 2, 3, 4)
  print . Foldable.sum $ GFold (Left (10 :: Int))
  print . Foldable.product $ GFold (10 :: Int, 20)
  print . Foldable.toList $ GFold (1 :: Int, 2, 3, 4)
  print . Foldable.concat $ GFold ([1 :: Int, 2, 3, 4], [5, 6, 7, 8])

-- | GADT that packs up the constraints needed for a Generic Foldable instance
data GFold a where
  GFold :: (Generic a, GFoldable (Rep a)) => a -> GFold (GFoldableType (Rep a))

-- | Convert 'a' to a Generic representation and traverse via induction
instance Foldable GFold where
  foldMap f (GFold a) = gfoldMap f (from a)

-- | A minimal 'Foldable'-like class that works over the Generic structure
class GFoldable (f :: * -> *) where
  type GFoldableType f :: *
  gfoldMap :: Monoid m => (GFoldableType f -> m) -> f a -> m

-- | Ignore meta information: data types, data constructors, record field names..
instance GFoldable f => GFoldable (M1 i c f) where
  type GFoldableType (M1 i c f) = GFoldableType f
  gfoldMap f = gfoldMap f . unM1

-- | Process both sides of a product type and mappend the results together
--   Also note: both sides must contain the same type so that 'f' can be applied
instance (GFoldable x, GFoldable y, GFoldableType x ~ GFoldableType y) => GFoldable (x :*: y) where
  type GFoldableType (x :*: y) = GFoldableType x
  gfoldMap f (x :*: y) = gfoldMap f x <> gfoldMap f y

-- | Process the defined side of a sum type, type equality is still required for 'f'
instance (GFoldable x, GFoldable y, GFoldableType x ~ GFoldableType y) => GFoldable (x :+: y) where
  type GFoldableType (x :+: y) = GFoldableType x
  gfoldMap f (L1 x) = gfoldMap f x
  gfoldMap f (R1 y) = gfoldMap f y

-- | A value has been reached, apply 'f' and return
instance GFoldable (K1 i c) where
  type GFoldableType (K1 i c) = c
  gfoldMap f (K1 x) = f x