GenericEach.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- because GHC doesn't know how fundeps work
module GenericGenericEach where

import GHC.Generics
import Control.Applicative

type family Field f where
  Field (K1 i c)   = c
  Field (M1 i c f) = Field f
  Field (f :+: g)  = Field f
  Field (f :*: g)  = Field f
  Field U1         = ()

class Each' s t a b | s -> a, t -> b, b s -> t, a t -> s where
  each' :: Applicative f => (a -> f b) -> s -> f t

  default each' :: ( Generic s, Generic t
                   , GenericEach (Rep s) (Rep t)
                   , Applicative f) =>
                   (Field (Rep s) -> f (Field (Rep t))) -> s -> f t
  each' f s = to <$> geach f (from s)


instance (a ~ a', b ~ b') => Each' (a,a') (b,b') a b



class GenericEach g h where
  geach :: Applicative f => (Field g -> f (Field h)) -> g p -> f (h p)

instance
  ( Field f  ~ Field g
  , Field f' ~ Field g'
  , GenericEach f f'
  , GenericEach g g'
  ) =>
  GenericEach (f :+: g) (f' :+: g') where
  geach f (L1 x) = L1 <$> geach f x
  geach f (R1 x) = R1 <$> geach f x

instance
  ( Field f  ~ Field g
  , Field f' ~ Field g'
  , GenericEach f f'
  , GenericEach g g'
  ) =>
    GenericEach (f :*: g)  (f' :*: g') where
  geach f (x :*: y) = (:*:) <$> geach f x <*> geach f y

instance GenericEach f g => GenericEach (M1 i c f) (M1 j d g) where
  geach f (M1 x) = M1 <$> geach f x

instance GenericEach (K1 i c) (K1 j d) where
  geach f (K1 x) = K1 <$> f x

instance GenericEach U1 U1 where
  geach _ U1 = pure U1