Higher kinded data and Diff

Hi!

I’m trying to use Higher Kinded Data (HKD) for data types that I would like to diff, which for me means the following:

#!/usr/bin/env stack
-- stack --resolver=lts-13.19 script
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}

import Data.Functor.Identity (Identity)
import GHC.Generics (Generic)
import Data.Text

data Diff a
  = Changed a
  | Unchanged

type family HKD f a where
    HKD Identity a = a
    HKD Maybe a = Maybe a
    HKD Diff a = Diff a

data Person' f = Person
  { name      :: HKD f Text
  , age       :: HKD f (Maybe Int)
  , languages :: HKD f [Text]
  } deriving (Generic)

deriving instance Eq (Person' Identity)

-- The functions to apply and create a diff:
apply :: Person' Identity -> Person' Diff -> Person' Identity
apply (Person n a l) (Person n' a' l') =
    Person (n `ap` n') (a `ap` a') (l `ap` l')
  where
    ap x Unchanged   = x
    ap _ (Changed x) = x

diff :: Person' Identity -> Person' Identity -> Person' Diff
diff (Person n a l) (Person n' a' l') =
    Person (n `comp` n') (a `comp` a') (l `comp` l')
  where
    comp a b
      | a == b    = Unchanged
      | otherwise = Changed b

-- Initial data:
initialPerson :: Person' Identity
initialPerson = Person
  { name      = "Matthias"
  , age       = Nothing
  , languages = []
  }

-- A "diff":
setAge :: Person' Diff
setAge = Person
  { name      = Unchanged
  , age       = Changed (Just 36)
  , languages = Unchanged
  }

-- Now apply the diff to the initial data
main :: IO ()
main = putStrLn . show $ initialPerson `apply` setAge == initialPerson { age = Just 36 }

This works, but I would like to make a Generic apply and diff function (using GHC Generics). Which would work for any HKD type like Person' which has a Generic representation. However, I’m not able to come up with the code. I’ve started writing this:

class GDiffable f where
  genericDiff  :: a Identity -> a Identity -> a Diff
  genericApply :: a Identity -> a Diff -> a Identity

But this already gives me problems… How do I pattern match on the Diff type or how do I do something like this:

instance GDiffable (K1 i a) where -- I should probably have Diff here somewhere, extra type parameter?
  genericApply (K1 x) (K1 Unchanged) = K1 x
  genericApply (K1 _) (K1 (Changed x)) = K1 x

The source which I follow mainly is this article by Sandy Maguire.

I’ve also looked at Higgledy and Barbies, but I’m not quite sure if these libraries can help me. They also use a slightly different way to represent the HKD.

Any help to point me in to the right direction is much appreciated.

TIA!

OK, I’ve nailed it (thanks to inspiration from the aeson-default code):


class Diffable (t :: (Type -> Type) -> Type) where
  diff :: t Identity -> t Identity -> t Diff
  default diff :: ( Generic (t Identity)
                  , Generic (t Diff)
                  , GDiffable (Rep (t Identity)) (Rep (t Diff)))
               => t Identity -> t Identity -> t Diff
  diff a b = to $ genericDiff (from a) (from b)

  apply :: t Identity -> t Diff -> t Identity
  default apply :: ( Generic (t Identity)
                   , Generic (t Diff)
                   , GDiffable (Rep (t Identity)) (Rep (t Diff)))
                => t Identity -> t Diff -> t Identity
  apply a b = to $ genericApply (from a) (from b)

class GDiffable f g where
  genericDiff  :: f (t Identity) -> f (t Identity) -> g (t Diff)
  genericApply :: f (t Identity) -> g (t Diff) -> f (t Identity)

instance GDiffable U1 U1 where
  genericDiff  _ _ = U1
  genericApply _ _ = U1

instance GDiffable f g => GDiffable (D1 c f) (D1 c g) where
  genericDiff  (M1 a) (M1 b) = M1 $ genericDiff a b
  genericApply (M1 a) (M1 b) = M1 $ genericApply a b

instance GDiffable f g => GDiffable (C1 c f) (C1 c g) where
  genericDiff  (M1 a) (M1 b) = M1 $ genericDiff a b
  genericApply (M1 a) (M1 b) = M1 $ genericApply a b

instance GDiffable f g => GDiffable (S1 s f) (S1 s g) where
  genericDiff  (M1 a) (M1 b) = M1 $ genericDiff a b
  genericApply (M1 a) (M1 b) = M1 $ genericApply a b

instance (GDiffable f1 g1, GDiffable f2 g2) => GDiffable (f1 :*: f2) (g1 :*: g2) where
  genericDiff (a1 :*: a2) (b1 :*: b2) =
    genericDiff a1 b1 :*: genericDiff a2 b2
  genericApply (a1 :*: a2) (b1 :*: b2) =
    genericApply a1 b1 :*: genericApply a2 b2

instance Eq a => GDiffable (K1 i a) (K1 i (Diff a)) where
  genericDiff (K1 a) (K1 b)
    | a == b    = K1 $ Unchanged
    | otherwise = K1 $ Changed b

  genericApply (K1 x) (K1 Unchanged)   = K1 x
  genericApply (K1 _) (K1 (Changed x)) = K1 x
1 Like

The trouble is that your diff function requires the Eq constraint on every field of the Person record. The following shows how apply can be constructed using Rank2.liftA2 from rank2classes but diff cannot. I’ve been considering adding the indexed variants of all the classes, then it would be doable.

1 Like