How to model mixins / multiple interfaces in Haskell?

Question

I came across this question on modeling inheritance in Haskell and it reminded me that I have a little more complicated version of the same problem. I\'ll adopt the example from

Answer 1

On further reflection, I suppose this is basically a job for extensible records assuming permutativity. As far as I can tell, you'd just have to work with values of the form (r, a), where r is a record containing all the mixed-in data, and a is the original value you wanted. Pairs are already a Functor over the second argument, so you can fmap all your existing functions. For the mixins you could define things like

pos :: (r <: {_pos :: Vec3}) => (r, a) -> Vec3
pos (r, a) = r._pos

and so on. Then a coloured physical camera would just be a value of type (r, Camera) where r <: {_pos :: Vec3, _vel :: Vec3, _colour :: Colour}.

It's too bad all this doesn't exist in standard Haskell yet. Oh well, time for me to go check out some of the extensible records libraries.

Answer 2

Are you aware that a Tuple with arity of 2 has a Functor instance, which maps over the second item? We can use it to our benefit.

data PositionAndVelocity = PositionAndVelocity Vec3 Vec3
data Colour = ...

f1 :: (PositionAndVelocity, Camera) -> ...
f2 :: (Colour, Camera) -> ...

Answer 3

Though I still suspect we should think about the whole think about the whole thing another way, less OO-inspired, here's another possible solution. I shall keep to the Monsters example, though a 2D graphics program seems indeed a better example.

{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, DeriveFunctor, FlexibleContexts #-}

import Control.Monad.Identity

class (Functor f, Functor (PropT f p)) => AttachProp f p where
  type PropT f p :: * -> *
  attachProp :: p -> f o -> PropT f p o
  detachProp :: PropT f p o -> (p, f o)

fmapProp :: (AttachProp f p, AttachProp f p')
  => f o -- dummy parameter (unevaluated), because type-functions aren't injective
         -> (p -> p') -> PropT f p o -> PropT f p' o
fmapProp q f pt = let (p, fo) = detachProp pt
                  in attachProp (f p) $ fo `asTypeOf` q


data R3Phys = R3Phys { position, momentum :: Vec3 }
data Colour = Colour

data Physical a = Physical R3Phys a deriving (Functor)
data Coloured a = Coloured Colour a deriving (Functor)
data PhysColoured a = PhysColoured Colour R3Phys a deriving (Functor)

instance AttachProp Identity R3Phys where
  type PropT Identity R3Phys = Physical
  attachProp rp = Physical rp . runIdentity
  detachProp (Physical rp o) = (rp, Identity o)
instance AttachProp Identity Colour where
  type PropT Identity Colour = Coloured
  attachProp c = Coloured c . runIdentity
  detachProp (Coloured c o) = (c, Identity o)
instance AttachProp Coloured R3Phys where
  type PropT Coloured R3Phys = PhysColoured
  attachProp rp (Coloured c o) = PhysColoured c rp o
  detachProp (PhysColoured c rp o) = (rp, Coloured c o)
instance AttachProp Physical Colour where
  type PropT Physical Colour = PhysColoured
  attachProp c (Physical rp o) = PhysColoured c rp o
  detachProp (PhysColoured c rp o) = (c, Physical rp o)

Note that PropT (PropT Identity R3Phys) Colour a and PropT (PropT Identity Colour) R3Phys a are the same type, namely PhysColoured a. Of course, we need again O (n²) instances for n mixins. Could easily be done with Template Haskell, though obviously you should think twice if you want that.

Answer 4

Perhaps it's just that this example with colours isn't particularly good, but it seems to me that you shouldn't ever truely need this and it wouldn't actually be good if it worked.

Physical is indeed perfectly natural the way you propose it: a Monster, Camera etc. doesn't have a position by itself, rather position is what you get by combining such a object with some space to live in.

But Coloured is different, for colour is a property of the thing itself and will probably have quite different meaning for a monster compared to a camera, so unlike Physical a type class would actually seem reasonable here. If at all – perhaps it would actually be better to simply use monomorphic functions for dealing with the various kinds of colour-ness manually.

Of course, you might be tempted think of it this way: things themselves aren't coloured, but they wear a skin that has colour. I don't think this should be the only way to have colour, but... fair enough, we can obviously provide such a "skin" so uncoloured objects become colourful too:

data ClSkin a = ClSkind { clSkinColour :: Colour
                        , clSkinned :: a         }
instance Coloured (Clsskin a) where
  colour = clSkinColour

Now you say it shouldn't matter if you use Physical (ClSkin a) or ClSkin (Physical a). I say it does matter. Again, Physical is sort-of a combination between an object and the entire space it lives in. Surely, you don't want to colourise that entire space! So really, Physical (ClSkin a) is the only meaningful variant. Or, alternatively, you might say colour is something that only makes sense for objects in a physical space. Well, then you'd just make the colour an extra field of that data!

data Physical a = Physical a Vec3 Vec3 (Maybe Colour)

Answer 5

Perhaps we could take a cue from the underappreciated mtl package, and combine the two previously suggested approaches: declare two type constructors (and make them functors) and declare corresponding typeclasses/instances.

But here's the trick: we will compose the functors using Data.Functor.Compose from transformers, and then define additional "pass-through" instances to make methods from the inner layers available in the outer layer. Just like mtl does for monad transformers!

First, some preliminaries:

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}

import Data.Functor.Compose

data Camera = Camera
data Light = SpotLight | DirectionalLight 
data Object = Monster | Player | NPC

data Vec3 = Vec3C -- dummy type 
data Colour = ColourC -- dummy type

The data definitions:

data Physical a = Physical a Vec3 Vec3 deriving Functor
data Coloured a = Coloured a Colour deriving Functor

The corresponding typeclasses:

class Functor g => FunctorPhysical g where
    vecs :: g a -> (Vec3,Vec3)  

class Functor g => FunctorColoured g where
    colour :: g a -> Colour

The base instances:

instance FunctorPhysical Physical where
    vecs (Physical _ v1 v2) = (v1,v2) 

instance FunctorColoured Coloured where
    colour (Coloured _ c) = c

And now the mtl-inspired trick. Passthrough instances!

instance Functor f => FunctorPhysical (Compose Physical f) where
    vecs (Compose f) = vecs f

instance Functor f => FunctorColoured (Compose Coloured f) where
    colour (Compose f) = colour f

instance FunctorPhysical f => FunctorPhysical (Compose Coloured f) where
    vecs (Compose (Coloured a _)) = vecs a

instance FunctorColoured f => FunctorColoured (Compose Physical f) where
    colour (Compose (Physical a _ _)) = colour a

An example value:

exampleLight :: Compose Physical Coloured Light
exampleLight = Compose (Physical (Coloured SpotLight ColourC) Vec3C Vec3C) 

You should be able to use both vecs and colour with the above value.

EDIT: The above solution has the problem that accessing the original wrapped value is cumbersome. Here is an alternate version using comonads that lets you use extract to get the wrapped value back.

import Control.Comonad
import Control.Comonad.Trans.Class
import Control.Comonad.Trans.Env
import Data.Functor.Identity

data PhysicalT w a = PhysicalT { unPhy :: EnvT (Vec3,Vec3) w a } 

instance Functor w => Functor (PhysicalT w) where
  fmap g (PhysicalT wa) = PhysicalT (fmap g wa)

instance Comonad w => Comonad (PhysicalT w) where
  duplicate (PhysicalT wa) = PhysicalT (extend PhysicalT wa)
  extract (PhysicalT wa) = extract wa

instance ComonadTrans PhysicalT where
  lower = lower . unPhy

--
data ColouredT w a = ColouredT { unCol :: EnvT Colour w a } 

instance Functor w => Functor (ColouredT w) where
  fmap g (ColouredT wa) = ColouredT (fmap g wa)

instance Comonad w => Comonad (ColouredT w) where
  duplicate (ColouredT wa) = ColouredT (extend ColouredT wa)
  extract (ColouredT wa) = extract wa

instance ComonadTrans ColouredT where
  lower = lower . unCol

class Functor g => FunctorPhysical g where
    vecs :: g a -> (Vec3,Vec3)  

class Functor g => FunctorColoured g where
    colour :: g a -> Colour

instance Comonad c => FunctorPhysical (PhysicalT c) where
    vecs = ask . unPhy

instance Comonad c => FunctorColoured (ColouredT c) where
    colour = ask . unCol

-- passthrough instances    
instance (Comonad c, FunctorPhysical c) => FunctorPhysical (ColouredT c) where
    vecs = vecs . lower

instance (Comonad c, FunctorColoured c) => FunctorColoured (PhysicalT c) where
    colour = colour . lower

-- example value
exampleLight :: PhysicalT (ColouredT Identity) Light
exampleLight = PhysicalT . EnvT (Vec3C,Vec3C) $ 
               ColouredT . EnvT ColourC       $ Identity SpotLight

Sadly, it requires even more boilerplate. Personally, I would just use nested EnvT transformers at the cost of less uniform access.