How can I fix this type mess of nested fmap functors?

user_3994249 0
Viewed 141
data Color = White | Black deriving (Eq, Show)
data Role = King | Queen | Rook deriving (Eq, Show)

data Piece = Piece { color :: Color, 
                     role  :: Role } deriving (Eq)

data Piese = Piese { piece :: Piece,
                     coord :: Coord } deriving (Eq)

data ColorMap a = ColorMap {
    white :: a,
    black :: a
  } deriving (Eq)

instance Functor ColorMap where
  fmap fn (ColorMap white black) = 
    ColorMap (fn white) (fn black)

colorMapFromList :: (a -> Color) -> [a] -> ColorMap [a]
colorMapFromList fn lst = ColorMap 
    (filter ((== White) . fn) lst)
    (filter ((== Black) . fn) lst)
                  
data RoleMap a = RoleMap {
    king  :: a,
    queen :: a,
    rook  :: a }

instance Functor RoleMap where
  fmap fn (RoleMap king queen rook) = 
    RoleMap (fn king) (fn queen) (fn rook)

roleMapFromList :: (a -> Role) -> [a] -> RoleMap [a]
roleMapFromList fn lst = RoleMap
    (filter ((== King ) . fn) lst)
    (filter ((== Queen) . fn) lst)
    (filter ((== Rook ) . fn) lst)

mapso :: [Piese] -> ColorMap (RoleMap [Coord])
mapso lst = 
 fmap (fmap (fmap coord))                -- ColorMap (RoleMap [Coord])
   (fmap (roleMapFromList (role . piece))  -- ColorMap (RoleMap [Piese])
         (colorMapFromList (color . piece)   -- ColorMap [Piese]
              lst))                            -- [Piese]

I've just jumped into Haskell, this compiles, but it seems error prone to me. Is there a pattern here I can simplify this into? Specifically the mapso function.

map-function functor nested functional-programming haskell
2 Answers

You can take advantage of the fact that functors compose. While you can represent this fairly explicitly by defining new types with Data.Functor.Compose, practically speaking it just means that you can compose fmap with itself.

mapso :: [Piese] -> ColorMap (RoleMap [Coord])
mapso lst = fmap (fmap (fmap coord))
  (fmap (roleMapFromList (role.piece)) (colorMapFromList (color.piece) lst))

becomes

mapso = (fmap . fmap . fmap) coord . 
        fmap (roleMapFromList (role.piece)) .
        colorMapFromList (color.piece)

or with some refactoring:

mapso = let fffmap = fmap . fmap . fmap
            makeColorMap = colorMapFromList (color.piece)
            makeRoleMap = roleMapFromList (role.piece)
        in fffmap coord . 
           fmap makeRoleMap .
           makeColorMap

I've switched to a point-free form to highlight the three stages:

  1. Create the ColorMap
  2. Create the RoleMap
  3. Map coord over the [Piese] value wrapped inside the RoleMap wrapped inside the ColorMap.

We use function composition to reduce the amount of explicit nesting in the definition of mapso.

If you aren't comfortable thinking in terms of function composition yet, you can just define more temporary variables in the let expression:

mapso lst = let fffmap = fmap . fmap . fmap
                makeColorMap = colorMapFromList (color.piece)
                makeRoleMap = fmap (roleMapFromList (role.piece))
            in let colorMap = makeColorMap lst
                   rolemap = makeRoleMap colorMap
            in fffmap coord roleMap

(Do we need two let expressions? No. But it might be helpful to separate the helper functions from the values the helper functions compute.)

user_11268410

One option is to make your maps Monoid instances. So:

instance Semigroup a => Semigroup (RoleMap a) where
    RoleMap ks qs rs <> RoleMap ks' qs' rs' = 
        RoleMap (ks <> ks') (qs <> qs') (rs <> rs')
instance Monoid a => Monoid (RoleMap a) where 
    mempty = RoleMap mempty mempty mempty

instance Semigroup a => Semigroup (ColorMap a) where
    ColorMap ws bs <> ColorMap ws' bs' = 
        ColorMap (ws <> ws') (bs <> bs')
instance Monoid a => Monoid (ColorMap a) where 
    mempty = ColorMap mempty mempty

Now, instead of filtering, provide a function that creates singleton maps.

singletonRole :: Monoid a => Role -> a -> RoleMap a
singletonRole r a = case r of
    King  -> mempty { king  = a }
    Queen -> mempty { queen = a }
    Rook  -> mempty { rook  = a }

singletonColor :: Monoid a => Color -> a -> ColorMap a
singletonColor c a = case c of
    White -> mempty { white = a }
    Black -> mempty { black = a }

Using these, it's easy to write a function that consumes a single Piese:

singletonFromPiese :: Piese -> ColorMap (RoleMap [Coord])
singletonFromPiese (Piese p c) = 
    singletonColor (color p) . 
        singletonRole (role p) $ [c]

Consuming lots of Pieses is just a foldMap:

mapso :: [Piese] -> ColorMap (RoleMap [Coord])
mapso = foldMap singletonFromPiese

One thing that's nice about this approach is that, to me, each individual piece of code looks obvious and doesn't require mental type inference. Nested fmaps -- even if we think of them as a single fmap on a composed type -- don't have that property, at least for me.

Another nice property is that we make only one pass over the list; in the obvious implementation of the fmap version, we make three passes for the three filters of creating a RoleMap and two passes for the two filters of creating a ColorMap, for a total of five passes.

user_7916040
Related