iso based gmappend for records

gmappend.hs

{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE BlockArguments        #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

module GMappend where

import           Generics.SOP

-- for the example
import           Control.Applicative
import           Data.Semigroup      (Sum (..))
import           Generics.SOP.TH
-- /for the example

type family IsoF a b where
    IsoF '[] '[] = '[]
    IsoF (x:xs) (y:ys) = (x -> y, y -> x) : IsoF xs ys

class UpOp b c  where
    upOp :: NP I (IsoF b c) -> NP I b -> NP I c

instance UpOp '[] '[]
    where
    upOp _ _ = Nil

instance UpOp xs ys => UpOp (x:xs) (y:ys)
    where
    upOp (I (f, _) :* fs) (I x :* xs) = (I $ f x) :* upOp fs xs

class DownOp b c  where
    downOp :: NP I (IsoF b c) -> NP I c -> NP I b

instance DownOp '[] '[]
    where
    downOp _ _ = Nil

instance DownOp xs ys => DownOp (x:xs) (y:ys)
    where
    downOp (I (_, f) :* fs) (I x :* xs) = (I $ f x) :* downOp fs xs

up :: forall a b xs
    . (UpOp xs b, Generic a, Code a ~ '[xs])
   => NP I (IsoF xs b)
   -> a
   -> NP I b
up f = upOp f . unZ . unSOP . from

down :: forall b a xs
      . (Generic a, Code a ~ '[xs], DownOp xs b)
     => NP I (IsoF xs b)
     -> NP I b
     -> a
down f = to . SOP . Z . downOp f


gmappend :: forall ys a xs
          . ( Code a ~ '[xs]
            , UpOp xs ys
            , DownOp xs ys
            , Generic a
            , All Semigroup ys
            )
         => NP I (IsoF xs ys)
         -> a
         -> a
         -> a
gmappend dss x y = down @ys dss $ hcliftA2
    do Proxy :: Proxy Semigroup
    do liftA2 (<>)
    do up dss x
    do up dss y

type Iso a b = I (a -> b, b -> a)

(=:=) :: (a -> b) -> (b -> a) -> Iso a b
(=:=) = fmap I . (,)

noOp :: Iso a a
noOp = id =:= id

-- example

data T = T
    { text :: String
    , num :: Int
    } deriving (Show)

deriveGeneric ''T


instance Semigroup T where
    (<>) = gmappend @'[String, Sum Int] do
        noOp :* Sum =:= getSum :* Nil

mkT :: String -> T
mkT x = T x $ Prelude.length x

main :: IO ()
main = print $ mkT "ciao " <> mkT "mamma"