Making QualifiedDo and ApplicativeDo work together when nesting applicative functors

Question

I want to define deeply nested compositions of applicative functors. For example something like this:

{-# LANGUAGE TypeOperators #-}
import Control.Monad.Trans.Cont
import Control.Arrow (Kleisli (..))
import Data.Aeson
import Data.Aeson.Types
import Data.Functor.Compose
import Data.Functor

type Configurator = Kleisli Parser Value
type Allocator = ContT () IO 
type Validator = Either String

someConfigurator :: Configurator Int
someConfigurator = undefined

someAllocator :: Allocator Char
someAllocator = undefined

-- the nested functor composition. left-associated
type Phases = Configurator `Compose` Allocator `Compose` Validator 

data Foo = Foo Int Char

-- I want to streamline writing this, without spamming the Compose constructor 
fooPhases :: Phases Foo
fooPhases = _ 

To streamline the syntax for creating the fooPhases value, I though of (ab)using QualifiedDo:

module Bind where
import Data.Functor
import Data.Functor.Compose

(>>=) :: Functor f => f a -> (a -> g b) -> Compose f g b 
(>>=) f k = bindPhase f k

(>>) :: Functor f => f a -> g b -> Compose f g b 
(>>) f g = Compose $ f <&> \_ -> g

fail :: MonadFail m => String -> m a
fail = Prelude.fail

bindPhase :: Functor f => f a -> (a -> g b) -> Compose f g b 
bindPhase f k = Compose (f <&> k)

Somewhat to my surprise, it worked:

{-# LANGUAGE QualifiedDo #-}
import qualified Bind
fooPhases :: Phases Foo
fooPhases = Bind.do 
    i <- someConfigurator 
    c <- someAllocator 
    pure (Foo i c)

Alas, when I add applicative-like functions to the Bind module

return :: Applicative f => a -> f a
return = Prelude.pure

pure :: Applicative f => a -> f a
pure = Prelude.pure

fmap :: Functor f => (a -> b) -> f a -> f b
fmap = Prelude.fmap

join :: f (g a) -> Compose f g a
join = Compose

(<*>) :: (Applicative f, Applicative g) => f (a -> b) -> g a -> Compose f g b
(<*>) f g = Compose $ f <&> \z -> Prelude.fmap (z $) g

and then enable ApplicativeDo in Main, I start to get errors like the following:

* Couldn't match type: Compose (Kleisli Parser Value) (ContT () IO)
                 with: Kleisli Parser Value
  Expected: Configurator (Compose Allocator Validator Foo)
    Actual: Compose
              (Kleisli Parser Value)
              (ContT () IO)
              (Compose Allocator Validator Foo)

Is there a way to use my Bind.do when both QualifiedDo and ApplicativeDo are enabled in Main?

Answer 1

To make this easier to reason about, first manually desugar fooPhases each way:

fooPhasesMonad = 
    someConfigurator Bind.>>= \i ->
    someAllocator Bind.>>= \c ->
    pure (Foo i c)

fooPhasesApplicative = Bind.fmap Foo someConfigurator Bind.<*> someAllocator

If you check their types in GHCi, you'll see that fooPhasesMonad has the type you want (as expected, since it works), but fooPhasesApplicative has type (Configurator `Compose` Allocator) Foo.

The first problem is that Bind.fmap f m isn't equivalent to m Bind.>>= (pure . f). In particular, the latter produces an extra layer of Compose but the former does not. When you use ApplicativeDo, using the former instead means you end up with just (Configurator `Compose` Allocator) instead of (Configurator `Compose` Allocator `Compose` Validator), which is the cause of your type error. To fix it, replace your definition of Bind.fmap with this one:

fmap :: (Functor f, Applicative g) => (a -> b) -> f a -> Compose f g b
fmap f k = bindPhase k (Prelude.pure . f)

The "monads" of your do-notation fail all of the monad laws, though (even the types of the results can't be right), so some rewrites that you take for granted aren't still valid. In particular, you'll still get an error unless you settle for your types being composed like this instead:

type Phases = (Configurator `Compose` Validator) `Compose` Allocator