Generic1 ((->) a) instance

GenericArrow.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
module GenericArrow where

import GHC.Generics
import Data.Kind (Type)

instance (Generic a, GenericArrow (Rep a)) => Generic1 ((->) a) where
  type Rep1 ((->) a) = RepArr (Rep a)
  to1 r = toArr @(Rep a) r . from
  from1 f = fromArr @(Rep a) (f . to)

class GenericArrow a where
  type RepArr a :: Type -> Type
  toArr :: RepArr a b -> a x -> b
  fromArr :: (a x -> b) -> RepArr a b
instance GenericArrow V1 where
  type RepArr V1 = U1
  toArr _ v = case v of {}
  fromArr _ = U1
instance GenericArrow U1 where
  type RepArr U1 = Par1
  toArr (Par1 b) U1 = b
  fromArr f = Par1 (f U1)
instance GenericArrow (K1 i c) where
  type RepArr (K1 i c) = Rec1 ((->) c)
  toArr (Rec1 r) (K1 c) = r c
  fromArr f = Rec1 (f . K1)
instance (GenericArrow a) => GenericArrow (M1 i c a) where
  type RepArr (M1 i c a) = RepArr a
  toArr r (M1 x) = toArr r x
  fromArr f = fromArr (f . M1)
instance (GenericArrow l, GenericArrow r) => GenericArrow (l :+: r) where
  type RepArr (l :+: r) = RepArr l :*: RepArr r
  toArr (repl :*: _) (L1 l) = toArr repl l
  toArr (_ :*: repr) (R1 r) = toArr repr r
  fromArr f = fromArr @l (f . L1) :*: fromArr @r (f . R1)
instance (GenericArrow l, GenericArrow r) => GenericArrow (l :*: r) where
  type RepArr (l :*: r) = RepArr l :.: RepArr r
  toArr (Comp1 rep) (l :*: r) = toArr (toArr rep l) r
  fromArr f = Comp1 (fromArr @l $ \l -> fromArr @r $ \r -> f (l :*: r))