How do I remove code duplication in two identical Haskell functions with different output type?

Question

I continue experimenting with Haskell and GUI https://github.com/bigos/cairo-example/blob/1c4448a936031b0e5b66b77027be975d040df01b/src/Main.hs and I've ran into another problem.

I have two identical functions with different result type:

getWidgetSize :: Gtk.DrawingArea -> Render (Int, Int)
getWidgetSize widget = do
  width'  <- fromIntegral <$> Gtk.widgetGetAllocatedWidth widget
  height' <- fromIntegral <$> Gtk.widgetGetAllocatedHeight widget
  return (width', height')

getWidgetSize2 :: Gtk.DrawingArea -> IO (Int, Int)
getWidgetSize2 widget = do
  width'  <- fromIntegral <$> Gtk.widgetGetAllocatedWidth widget
  height' <- fromIntegral <$> Gtk.widgetGetAllocatedHeight widget
  return (width', height')

One is used in this function

updateCanvas :: Gtk.DrawingArea -> Model -> Render ()

and the other is used in the main function.

Is it possible to remove the code duplication?

solution

Following Vora's advice I have used the following:

getWidgetSize :: Gtk.DrawingArea -> IO (Int, Int)
getWidgetSize widget = do
  width'  <- fromIntegral <$> Gtk.widgetGetAllocatedWidth widget
  height' <- fromIntegral <$> Gtk.widgetGetAllocatedHeight widget
  return (width', height')

updateCanvas :: Gtk.DrawingArea -> Model -> Render ()
updateCanvas canvas model = do
  size <- liftIO (getWidgetSize canvas)

Answer 1

Yes, we can reason over the types:

• widgetGetAllocatedWidth :: (HasCallStack, MonadIO m, IsWidget a) => a -> m Int32
• widgetGetAllocatedHeight :: (HasCallStack, MonadIO m, IsWidget a) => a -> m Int32
• (<$>) :: Functor f => (a -> b) -> f a -> f b
• fromIntegral :: (Integral a, Num b) => a -> b
• (>>=) :: Monad m => m a -> (a -> m b) -> m b
• return :: Monad m => a -> m a

First we can desugar the do-block:

getWidgetSize widget = do
  width'  <- fromIntegral <$> widgetGetAllocatedWidth widget
  height' <- fromIntegral <$> widgetGetAllocatedHeight widget
  return (width', height')

is syntactical sugar for:

getWidgetSize widget = fromIntegral <$> widgetGetAllocatedWidth widget >>= \w' -> (
    fromIntegral <$> widgetGetAllocatedHeight widget >>= \h' -> (
        return (w', h')
    )
)

So first we assume getWidgetSize has type a -> b, and we assume widget :: a (we will later work out what a, b, etc are).

Next we see that there is a call widgetGetAllocatedWidth widget, so that means that (HasCallStack, MonadIO m, IsWidget a) holds, and that widgetGetAllocatedWidth widget has return type m Int32, so we now know:

getWidgetSize :: (HasCallStack, MonadIO m, IsWidget a) => a -> b
widget :: (HasCallStack, MonadIO m, IsWidget a) => a
widgetGetAllocatedWidth widget :: (HasCallStack, MonadIO m, IsWidget a) => m Int32

So now we perform a (<$>) fromIntegral (widgetGetAllocatedWidth widget) so that means that:

(<$>) :: Functor f => (c -> d) -> f c -> f d
fromIntegral :: (Integral c, Num d) => c -> d
widgetGetAllocatedWidth widget :: (HasCallStack, MonadIO m, IsWidget a) => m Int32

So we conclude that f ~ m and c ~ Int32, and that:

(<$>) fromIntegral (widgetGetAllocatedWidth widget) :: (HasCallStack, MonadIO m, IsWidget a, Num d, Functor m) => m d

The same holds for the second part fromIntegral <$> widgetGetAllocatedHeight widget, since the signature of widgetGetAllocatedHeight is the same as widgetGetAllocatedWidth, we conclude that:

(<$>) fromIntegral (widgetGetAllocatedHeight widget) :: (HasCallStack, MonadIO n, IsWidget a, Num e, Functor n) => n e

Note that here the n is not per se the same as m (later it will turn out it is), and that e is not per se the same as d.

Now we thus have three parts of the function (we will shorter the first two parts to f and g, such that) our function looks like:

getWidgetSize widget = f widget >>= (\w -> g widget >>= (\h -> return (w, h)))

With

f :: (HasCallStack, MonadIO m, IsWidget a, Num e, Functor m) => m d
g :: (HasCallStack, MonadIO n, IsWidget a, Num e, Functor n) => n e

Since the (>>=) function has as signature (>>=) :: Monad m => m a -> (a -> m b) -> m b, we thus know that the w variable has type Num d => d.

We furthermore know that the part g >>= \h -> return (w, h) has as type:

g >>= \h -> return (w, h) :: (HasCallStack, MonadIO n, IsWidget a, Num d, Num e, Functor n) => n (d, e)

Since we we "bind" f with \w -> g >>= \h -> return (w, h), we know that m ~ n. And so we come to the conclusion that the type of the result is:

(HasCallStack, MonadIO m, IsWidget a, Num d, Num e, Functor m) => m (d, e)

Now we can remove some duplication: since a MonadIO is defined as:

class Monad m => MonadIO m where
    -- ...

and since that:

class Applicative m => Monad m where
    -- ...

(...)

class Functor m => Applicative m where
    -- ...

We know that MonadIO m, actually implies Functor m, so we can remove Functor m, so the final type for the implementation is:

getWidgetSize :: (HasCallStack, MonadIO m, IsWidget a, Num b, Num c) => a -> m (b, c)
getWidgetSize widget = do
  width'  <- fromIntegral <$> widgetGetAllocatedWidth widget
  height' <- fromIntegral <$> widgetGetAllocatedHeight widget
  return (width', height')

Answer 2

Easiest way would be to use the fact that Render is a MonadIO, meaning you could simply make one IO typed definition, and liftIO the call when inside the Render Monad.

Edit: As per Carl's suggestion, and since widgetGetAllocatedWidth/widgetGetAllocatedHeight are constrained on the MonadIO requisite, you could also make a

getWidgetSize :: MonadIO m => Gtk.DrawingArea -> m (Int, Int)
getWidgetSize widget = do
  width'  <- liftIO $ fromIntegral <$> Gtk.widgetGetAllocatedWidth widget
  height' <- liftIO $ fromIntegral <$> Gtk.widgetGetAllocatedHeight widget
  return (width', height')

which would then work in both scenario. This is mostly equivalent, however it allows it to be called the same way from any MonadIO context.

Edit2: (Because more edits is always better right guys)
Edit3: Because sometimes you look at something from too close, and you miss it.
The liftIO, which I moved inside the do block for clarity, can also be removed to declutter the field a bit :

getWidgetSize :: MonadIO m => Gtk.DrawingArea -> m (Int, Int)
getWidgetSize widget = do
  width'  <- fromIntegral <$> Gtk.widgetGetAllocatedWidth widget
  height' <- fromIntegral <$> Gtk.widgetGetAllocatedHeight widget
  return (width', height')