Haskell嵌套应用函子时让QualifiedDo与ApplicativeDo协同工作的方案

报错原因 #

开启ApplicativeDo扩展后，GHC会自动将do块语法重写为pure Foo <$> someConfigurator <*> someAllocator的Applicative风格调用，你自定义的Bind模块中<*>的实现逻辑是每次调用都新增一层Compose包装，和预先定义的左结合多层Compose类型Phases结构不匹配，因此触发类型错误。

解决方案 #

方案一（最简便，无需修改Bind模块）

在用到Bind.do的位置局部关闭ApplicativeDo扩展，不影响模块其他位置的ApplicativeDo使用：

{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE ApplicativeDo #-}
import qualified Bind

fooPhases :: Phases Foo
fooPhases = 
  let {-# LANGUAGE NoApplicativeDo #-} 
  in Bind.do 
    i <- someConfigurator 
    c <- someAllocator 
    pure (Foo i c)

该方案下GHC不会对目标do块做Applicative重写，仍然使用你原本定义的>>=逻辑，可正常编译运行。

方案二（完全适配ApplicativeDo重写逻辑）

修改Bind模块，通过类型类和类型族自动匹配多层Compose的堆叠结构：

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverlappingInstances #-}
module Bind where
import Data.Functor
import Data.Functor.Compose
import Prelude hiding ((>>=), (>>), fail, return, pure, fmap, (<*>))

-- 原有绑定逻辑保持不变
(>>=) :: Functor f => f a -> (a -> g b) -> Compose f g b 
(>>=) f k = Compose (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

-- 类型族计算多层Compose堆叠后的结果类型
type family ComposeStack f g where
  ComposeStack (Compose f g) h = Compose f (Compose g h)
  ComposeStack f g = Compose f g

-- 重载<*>适配不同层级的Compose
class ApplicativeApply f g where
  (<*>) :: f (a -> b) -> g a -> ComposeStack f g b

instance {-# OVERLAPS #-} (Applicative f, Applicative g, Applicative h) => ApplicativeApply (Compose f g) h where
  (<*>) (Compose fgh) ha = Compose $ fmap Compose $ fgh <&> \gh -> gh <*> ha

instance (Applicative f, Applicative g) => ApplicativeApply f g where
  (<*>) fg ga = Compose $ fmap ($ ga) fg

-- 其余通用操作保持适配
fmap :: Functor f => (a -> b) -> f a -> f b
fmap = Prelude.fmap

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

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

修改后即使全局开启ApplicativeDo也可以正常编译运行。

内容的提问来源于stack exchange，提问作者danidiaz