Generic foldMap using Decidable1

DecidingL1.hs

class Contravariant1 p where
  contramap1 :: (a -> b) -> p b x -> p a x

class Contravariant1 p => Divisible1 p where
  conquer1 :: p a x
  divide1 :: (a -> (b, c)) -> p b x -> p c x -> p a x

class Divisible1 p => Decidable1 p where
  lose1 :: (a -> Void) -> p a x
  choose1 :: (a -> Either b c) -> p b x -> p c x -> p a x

newtype FM m a b = FM { getFM :: (b -> m) -> a -> m }

instance Contravariant1 (FM m) where
  contramap1 f (FM k) = FM (\h -> k h . f)

instance Monoid m => Divisible1 (FM m) where
  conquer1 = FM mempty
  divide1 f (FM k) (FM l) = FM $ \h a ->
    case f a of
      (b, c) -> k h b <> l h c

instance Monoid m => Decidable1 (FM m) where
  lose1 k = FM (\_ -> absurd . k)
  choose1 k (FM f) (FM g) = FM $ \h a ->
    case k a of
      Left b  -> f h b
      Right c -> g h c

class (Generic1 t, GDecidingL1 q (Rep1 t)) => DecidingL1 q t where
  decidingL1 :: Decidable1 f => p q -> (forall g x. q g => f (g x) x) -> f a a -> f (t a) a

instance (Generic1 t, GDecidingL1 q (Rep1 t)) => DecidingL1 q t where
  decidingL1 p f r = contramap1 from1 $ gdecidingL1 p f r

class GDecidingL1 q t where
  gdecidingL1 :: Decidable1 f => p q -> (forall g x. q g => f (g x) x) -> f a a -> f (t a) a

instance GDecidingL1 q U1 where
  gdecidingL1 _ _ _ = conquer1

instance GDecidingL1 q V1 where
  gdecidingL1 _ _ _ = lose1 absurdV1
    where
      absurdV1 :: V1 p -> b
      absurdV1 a = case a of {}

instance (GDecidingL1 q f, GDecidingL1 q g) => GDecidingL1 q (f :*: g) where
  gdecidingL1 p f r = divide1 (\(x :*: y) -> (x, y)) (gdecidingL1 p f r) (gdecidingL1 p f r)

instance (GDecidingL1 q f, GDecidingL1 q g) => GDecidingL1 q (f :+: g) where
  gdecidingL1 p f r = choose1 case_ (gdecidingL1 p f r) (gdecidingL1 p f r)
    where
      case_ (L1 x) = Left x
      case_ (R1 y) = Right y

instance GDecidingL1 q (K1 i c) where
  gdecidingL1 _ _ _ = conquer1

instance GDecidingL1 q f => GDecidingL1 q (M1 i c f) where
  gdecidingL1 p f r = contramap1 unM1 $ gdecidingL1 p f r

instance q f => GDecidingL1 q (Rec1 f) where
  gdecidingL1 _ f _ = contramap1 unRec1 f

instance GDecidingL1 q Par1 where
  gdecidingL1 _ _ r = contramap1 unPar1 r

gfoldMap :: (DecidingL1 Foldable f, Monoid m) => (a -> m) -> f a -> m
gfoldMap = getFM $ decidingL1 (Proxy :: Proxy Foldable) (FM foldMap) (FM id)