Deriving semidirect products for transformation monoids

Transform.hs

{-# LANGUAGE DerivingVia, PatternSynonyms #-}
{-# LANGUAGE UndecidableInstances, MonoLocalBinds #-}

module Transform where

import Data.Functor ((<&>))
import Data.Monoid (Sum(..), Product(..), Ap(..))


test1a :: Transformable p s => Transform p s
test1a = Tr1 1 10 <> Tr1 4 11 <> Tr1 7 12

test1b :: Transformable p s => Transform p s
test1b = mempty <> test1a <> mempty

test2 :: Transformable (V2 a) a => Transform (V2 a) a
test2 = Tr2 1 2 10 <> Tr2 4 5 11 <> Tr2 7 8 12

test3 :: Transformable (V3 a) a => Transform (V3 a) a
test3 = Tr3 1 2 3 10 <> Tr3 4 5 6 11 <> Tr3 7 8 9 12


newtype Transform p s = Tr (p, s)
  deriving Show

type Transformable p s = (Num p, Num s, RightAction (Product s) (Sum p))

deriving via SemiDirect (Sum p) (Product s)
  instance Transformable p s => Semigroup (Transform p s)
deriving via SemiDirect (Sum p) (Product s)
  instance Transformable p s => Monoid    (Transform p s)

{-# COMPLETE Tr1 #-}
pattern Tr1 :: a -> s -> Transform a s
pattern Tr1 x s = Tr (x, s)

{-# COMPLETE Tr2 #-}
pattern Tr2 :: a -> a -> s -> Transform (V2 a) s
pattern Tr2 x y s = Tr (V2 x y, s)

{-# COMPLETE Tr3 #-}
pattern Tr3 :: a -> a -> a -> s -> Transform (V3 a) s
pattern Tr3 x y z s = Tr (V3 x y z, s)


newtype SemiDirect l r = SemiDirect (l, r)
  deriving Monoid

instance (Semigroup l, RightAction r l) => Semigroup (SemiDirect l r) where
  SemiDirect (l1, r1) <> SemiDirect (l2, r2)
    = SemiDirect ((l1 *| r2) <> l2, r1 <> r2)


class Monoid r => RightAction r a where
  (*|) :: a -> r -> a
  infixl 5 *|

-- N.B. These instances overlap.
-- Instantiate tyvars concretely or use the 'Transformable' constraint synonym.

instance Num a => RightAction (Product a) a where
  x *| Product y = x * y

instance (RightAction r a, Functor f) => RightAction r (F f a) where
  s *| r = s <&> (*| r)

deriving via F Sum a instance RightAction r a => RightAction r (Sum a)
deriving via F V2  a instance RightAction r a => RightAction r (V2  a)
deriving via F V3  a instance RightAction r a => RightAction r (V3  a)


-- The equivalent of 'Ap' for 'Functor'.
newtype F f a = F (f a)
  deriving Functor


-- As in Linear.V2/V3.

data V2 a = V2 !a !a
  deriving (Show, Functor)
  deriving Num via Ap V2 a

instance Applicative V2 where
  pure x = V2 x x
  V2 f g <*> V2 x y = V2 (f x) (g y)

data V3 a = V3 !a !a !a
  deriving (Show, Functor)
  deriving Num via Ap V3 a

instance Applicative V3 where
  pure x = V3 x x x
  V3 f g h <*> V3 x y z = V3 (f x) (g y) (h z)