extensible records supporting a monoid action relation between the records

Question

Say we have the following definition of monoid actions:

class Monoid m => Action m a where 
  act :: m -> a -> a 

I would like to be able to extend this idea to some sort of extensible record type:

class ... => ActionR mfields afields where 
  actR :: Rec mfields -> Rec afields -> Rec afields

such that actR is defined if Rec mfields and Rec afields have the same set of field labels, and the corresponding field values are related by Action. Essentially, I want to "zip" matching fields with act, and so I need to be able to apply a type-level zipping operation of kind * -> * -> Constraint.

Is there a way of using extensible records in Haskell that can express this idea?

Answer 1

Turns out this is fairly straightforward( if you ignore the mess of language extentions ) to implement using Vinyl records.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Monoid.Action where

import Data.Kind ( Constraint )
import Data.Vinyl
    ( rzipWith, rcast, RApply, RMap, Rec(..), type (⊆) )

class Monoid m => Action m a where

  act :: m -> a -> a

-- | A pair of field functions with the same label
newtype App f g l = App (f l, g l)

app :: f l -> g l -> App f g l
app a b = App (a, b)

instance ( Monoid (Rec f mls)
         , RecBiApply Action f g als g
         , RMap als
         , RApply als
         , als ⊆ mls
         )
         => Action (Rec f mls) (Rec g als) where

  act mr ar = rBiApplyMethod @Action act (rzipWith app (rcast mr) ar)

class RecBiApply (c :: * -> * -> Constraint) f g ls h where
  rBiApplyMethod :: (forall l. c (f l) (g l) => f l -> g l -> h l)
                 -> Rec (App f g) ls
                 -> Rec h ls

instance RecBiApply c f g '[] g where
  rBiApplyMethod _ _ = RNil

instance ( RecBiApply c f g ls h
         , c (f l) (g l)
         )
         => RecBiApply c
                       f
                       g
                       (l ': ls)
                       h
                       where
  rBiApplyMethod f (App (m, a) :& rest) = f m a :& rBiApplyMethod @c f rest

Then, we can define a little example, loosely based on the official vinyl tutorial:

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Example where

import Data.Vinyl ( Rec(..) )
import Control.Lens ( makeLenses )
import Data.Singletons.TH (genSingletons, Proxy(..))
import Data.Monoid (Sum(..), Last)
import Data.Vinyl.Class.Method (PayloadType)
import Data.Coerce (coerce)
import Data.Monoid.Action ( Action(..) )

newtype Vec2 = Vec2 (Sum Int, Sum Int)
  deriving (Semigroup, Monoid)

instance Show Vec2 where
  show (Vec2 (Sum x, Sum y)) = "Vec2 " <> show x <> " " <> show y

vec2 :: Int -> Int -> Vec2
vec2 x y = Vec2 (Sum x, Sum y)

newtype AList a = AList { unAList :: [a] }
  deriving (Semigroup, Monoid)

instance Show a => Show (AList a) where
  show (AList xs) = "AList " <> show xs

instance Monoid m => Action m (AList m) where
  act m = AList . fmap (m <>) . unAList

data Fields
  = Position
  | Classes
  deriving Show

type family ActF (f :: Fields) :: * where
  ActF Position = Vec2
  ActF Classes  = [String]
newtype Act f = Act { _unAct :: ActF f }
makeLenses ''Act

instance Semigroup (ActF l) => Semigroup (Act l) where
  Act m1 <> Act m2 = Act (m1 <> m2)

instance Monoid (ActF l) => Monoid (Act l) where
  mempty = Act mempty

type family AttrF (f :: Fields) :: * where
  AttrF Position = AList Vec2
  AttrF Classes  = AList [String]
newtype Attr f = Attr { _unAttr :: AttrF f }
makeLenses ''Attr

genSingletons [ ''Fields ]

class DisplayField l where
  dispF :: f l -> String

instance DisplayField Position where dispF _ = "pos"
instance DisplayField Classes  where dispF _ = "classes"

instance (DisplayField f, Show (AttrF f)) => Show (Attr f) where
  show f@(Attr x) = dispF f <> "=" <> show x

instance (DisplayField f, Show (ActF f)) => Show (Act f) where
  show f@(Act x) = dispF f<> "=" <> show x

instance Action (ActF l) (AttrF l) => Action (Act l) (Attr l) where
  act (Act m) (Attr a) = Attr $ act m a

-- | Creates an entry in a record of actions.
(=:!) :: sing f -> ActF f -> Act f
_ =:! x = Act x

-- | Creates an entry in a record of attributes.
(=::) :: sing f -> AttrF f -> Attr f
_ =:: x = Attr x

svgShapes :: Rec Attr '[ 'Position, 'Classes]
svgShapes = (SPosition =:: AList [vec2 3 5, vec2 4 10])
         :& (SClasses  =:: AList [["shape1"], ["shape2"]])
         :& RNil

svgShapesR :: Rec Attr '[ 'Classes, 'Position]
svgShapesR = (SClasses  =:: AList [["shape1"], ["shape2"]])
          :& (SPosition =:: AList [vec2 3 5, vec2 4 10])
          :& RNil

canvasShapes :: Rec Attr '[ 'Position ]
canvasShapes = (SPosition =:: AList [vec2 1 2, vec2 3 4])
            :& RNil

moveAndAddClass :: Rec Act '[ 'Position, 'Classes]
moveAndAddClass = (SPosition =:! vec2 100 50)
               :& (SClasses  =:! ["foo"])
               :& RNil

moveOnly :: Rec Act '[ 'Position]
moveOnly = (SPosition =:! vec2 200 100)
        :& RNil
newtype Vec2 = Vec2 (Sum Int, Sum Int)
  deriving (Semigroup, Monoid)

instance Show Vec2 where
  show (Vec2 (Sum x, Sum y)) = "Vec2 " <> show x <> " " <> show y

vec2 :: Int -> Int -> Vec2
vec2 x y = Vec2 (Sum x, Sum y)

newtype AList a = AList { unAList :: [a] }
  deriving (Semigroup, Monoid)

instance Show a => Show (AList a) where
  show (AList xs) = "AList " <> show xs

instance Monoid m => Action m (AList m) where
  act m = AList . fmap (m <>) . unAList

data Fields
  = Position
  | Classes
  deriving Show

-- | Monoidal action fields 
type family ActF (f :: Fields) :: * where
  ActF Position = Vec2
  ActF Classes  = [String]
newtype Act f = Act { _unAct :: ActF f }
makeLenses ''Act

-- | Attribute list fields. Items in the list correspond to different shapes.
type family AttrF (f :: Fields) :: * where
  AttrF Position = AList Vec2
  AttrF Classes  = AList [String]
newtype Attr f = Attr { _unAttr :: AttrF f }
makeLenses ''Attr

genSingletons [ ''Fields ]

-- | Implement a `FieldAction` relation between action fields and attribute fields. 
instance Action (ActF l) (AttrF l) => FieldAction Act Attr l where
  actF (Act m) (Attr a) = Attr $ act m a

class DisplayField l where
  dispF :: f l -> String

instance DisplayField Position where dispF _ = "pos"
instance DisplayField Classes  where dispF _ = "classes"

instance (DisplayField f, Show (AttrF f)) => Show (Attr f) where
  show f@(Attr x) = dispF f <> "=" <> show x

instance (DisplayField f, Show (ActF f)) => Show (Act f) where
  show f@(Act x) = dispF f<> "=" <> show x

instance Action (ActF l) (AttrF l) => Action (Act l) (Attr l) where
  act (Act m) (Attr a) = Attr $ act m a

-- | Creates an entry in a record of actions.
(=:!) :: sing f -> ActF f -> Act f
_ =:! x = Act x

-- | Creates an entry in a record of attributes.
(=::) :: sing f -> AttrF f -> Attr f
_ =:: x = Attr x

svgShapes :: Rec Attr '[ 'Position, 'Classes]
svgShapes = (SPosition =:: AList [vec2 3 5, vec2 4 10])
         :& (SClasses  =:: AList [["shape1"], ["shape2"]])
         :& RNil

svgShapesR :: Rec Attr '[ 'Classes, 'Position]
svgShapesR = (SClasses  =:: AList [["shape1"], ["shape2"]])
          :& (SPosition =:: AList [vec2 3 5, vec2 4 10])
          :& RNil

canvasShapes :: Rec Attr '[ 'Position ]
canvasShapes = (SPosition =:: AList [vec2 1 2, vec2 3 4])
            :& RNil

moveAndAddClass :: Rec Act '[ 'Position, 'Classes]
moveAndAddClass = (SPosition =:! vec2 100 50)
               :& (SClasses  =:! ["foo"])
               :& RNil

moveOnly :: Rec Act '[ 'Position]
moveOnly = (SPosition =:! vec2 200 100)
        :& RNil

And finally, we can apply records of actions to records of attributes:

ghci> act moveAndAddClass svgShapes
{pos=AList [Vec2 103 55,Vec2 104 60], classes=AList [["foo","shape1"],["foo","shape2"]]}
ghci> act moveAndAddClass svgShapesR
{classes=AList [["foo","shape1"],["foo","shape2"]], pos=AList [Vec2 103 55,Vec2 104 60]}
ghci> act moveAndAddClass canvasShapes
{pos=AList [Vec2 101 52,Vec2 103 54]}
ghci> act moveOnly canvasShapes
{pos=AList [Vec2 201 102,Vec2 203 104]}

Notice how we can still apply moveAndAddClass to canvasShapes even though it doesn't contain a Classes field!