haskell - trimaps的快捷方式融合

Question

当试图在 Haskell 中融合中间 trimaps 时出现了这个问题。

考虑皮亚诺自然数的特里:

data Nat = Zero | Succ Nat

data ExpoNat a = ExpoNat (Maybe a) (ExpoNat a)
               | NoExpoNat

我们可以轻松地在 ExpoNat 上定义折叠(它本质上是一个列表)并使用 foldr/build (a.k.a. finally tagless) 熔断 ExpoNat 的中间事件:

{-# NOINLINE fold #-}
fold :: (Maybe a -> b -> b) -> b -> ExpoNat a -> b
fold f z (ExpoNat x y) = f x (fold f z y)
fold f z NoExpoNat = z

{-# NOINLINE build #-}
build :: (forall b. (Maybe a -> b -> b) -> b -> b) -> ExpoNat a
build f = f ExpoNat NoExpoNat

{-# RULES "fold/build" forall f n (g :: forall b. (Maybe a -> b -> b) -> b -> b). fold f n (build g) = g f n #-}

以 match为例和 appl来自“ Is there a way to generalize this TrieMap code? ”并将它们组合成 ExpoNat被熔断了。 (请注意，我们必须在 appl 中“加强归纳假设”。)

{-# INLINE match #-}
match :: Nat -> ExpoNat ()
match n = build $ \f z ->
  let go Zero = f (Just ()) z
      go (Succ n) = f Nothing (go n)
  in go n

{-# INLINE appl #-}
appl :: ExpoNat a -> (Nat -> Maybe a)
appl
  = fold (\f z -> \n ->
            case n of Zero    -> f
                      Succ n' -> z n')
         (\n -> Nothing)

applmatch :: Nat -> Nat -> Maybe ()
applmatch x = appl (match x)

可以通过使用 -ddump-simpl 检查 Core 来验证融合。 .

现在我们想对 Tree 做同样的事情.

data Tree = Leaf | Node Tree Tree

data TreeMap a
  = TreeMap {
        tm_leaf :: Maybe a,
        tm_node :: TreeMap (TreeMap a)
    }
  | EmptyTreeMap

我们有麻烦了: TreeMap是一种非常规数据类型，因此如何编写其对应的折叠/构建对并不明显。

Haskell Programming with Nested Types: A Principled Approach似乎有答案(请参阅 Bush 类型)但凌晨 4:30 对我来说似乎为时已晚，无法让它工作。应该怎么写 hfmap ?此后是否有进一步的发展？

在 What's the type of a catamorphism (fold) for non-regular recursive types? 中提出了这个问题的类似变体。

Answer 1

我做了更多的工作，现在我有了融合，而不使用论文中的通用小工具。

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
module Tree where

data Tree = Leaf | Node Tree Tree
  deriving (Show)

data ExpoTree a = ExpoTree (Maybe a) (ExpoTree (ExpoTree a))
                | NoExpoTree
  deriving (Show, Functor)

我通过采用泛型构造然后内联类型定义直到我触底为止来派生出大多数专用类型。为了便于比较，我在这里保留了通用结构。

data HExpoTree f a = HExpoTree (Maybe a) (f (f a))
                   | HNoExpoTree

type g ~> h = forall a. g a -> h a

class HFunctor f where
  ffmap :: Functor g => (a -> b) -> f g a -> f g b
  hfmap :: (Functor g, Functor h) => (g ~> h) -> (f g ~> f h)

instance HFunctor HExpoTree where
  ffmap f HNoExpoTree = HNoExpoTree
  ffmap f (HExpoTree x y) = HExpoTree (fmap f x) (fmap (fmap f) y)
  hfmap f HNoExpoTree = HNoExpoTree
  hfmap f (HExpoTree x y) = HExpoTree x (f (fmap f y))

type Alg f g = f g ~> g

newtype Mu f a = In { unIn :: f (Mu f) a }

instance HFunctor f => Functor (Mu f) where
  fmap f (In r) = In (ffmap f r)

hfold :: (HFunctor f, Functor g) => Alg f g -> (Mu f ~> g)
hfold m (In u) = m (hfmap (hfold m) u)

安 Alg ExpoTreeH g可以分解为两个自然变换的乘积:

type ExpoTreeAlg g = forall a. Maybe a -> g (g a) -> g a
type NoExpoTreeAlg g = forall a. g a

{-# NOINLINE fold #-}
fold :: Functor g => ExpoTreeAlg g -> NoExpoTreeAlg g -> ExpoTree a -> g a
fold f z NoExpoTree = z
fold f z (ExpoTree x y) = f x (fold f z (fmap (fold f z) y))

这里的自然变换 c ~> x很有趣，结果证明是很有必要的。这是构建翻译:

hbuild :: HFunctor f => (forall x. Alg f x -> (c ~> x)) -> (c ~> Mu f)
hbuild g = g In

newtype I :: (* -> *) where
  I :: x -> I x
  deriving (Show, Eq, Functor, Foldable, Traversable)

-- Needs to be a newtype, otherwise RULE firer gets bamboozled
newtype ExpoTreeBuilder c = ETP {runETP :: (forall x. Functor x
                                        => (forall a. Maybe a -> x (x a) -> x a)
                                        -> (forall a. x a)
                                        -> (forall a. c a -> x a)
                                            )}

{-# NOINLINE build #-}
build :: ExpoTreeBuilder c -> forall a. c a -> ExpoTree a
build g = runETP g ExpoTree NoExpoTree

需要 builder 函数的 newtype，因为 GHC 8.0 不知道如何在没有的情况下触发 RULE。

现在，捷径融合规则:

{-# RULES "ExpoTree fold/build"
          forall (g :: ExpoTreeBuilder c) c (f :: ExpoTreeAlg g) (n :: NoExpoTreeAlg g).
          fold f n (build g c) = runETP g f n c #-}

'match' 与 'build' 的实现:

{-# INLINE match #-}
match :: Tree -> ExpoTree ()
match n = build (match_mk n) (I ())
  where
    match_mk :: Tree -> ExpoTreeBuilder I
    match_mk Leaf = ETP $ \ f z (I c) -> f (Just c) z
    match_mk (Node x y) = ETP $ \ f z c ->
      -- NB: This fmap is bad for performance
      f Nothing (fmap (const (runETP (match_mk y) f z c)) (runETP (match_mk x) f z c))

'appl' 与 'fold' 的实现(我们需要定义一个自定义仿函数来定义返回类型。)

newtype PFunTree a = PFunTree { runPFunTree :: Tree -> Maybe a }
  deriving (Functor)

{-# INLINE appl #-}
appl :: ExpoTree a -> PFunTree a
appl = fold appl_expoTree appl_noExpoTree
  where
    appl_expoTree :: ExpoTreeAlg PFunTree
    appl_expoTree = \z f -> PFunTree $ \n ->
                case n of Leaf       -> z
                          Node n1 n2 -> runPFunTree f n1 >>= flip runPFunTree n2
    appl_noExpoTree :: NoExpoTreeAlg PFunTree
    appl_noExpoTree = PFunTree $ \n -> Nothing

把它们放在一起:

applmatch :: Tree -> Tree -> Maybe ()
applmatch x = runPFunTree (appl (match x))

我们可以再次检查内核 -ddump-simpl .不幸的是，虽然我们已经成功地融合了 TrieMap数据结构，由于 fmap，我们留下了次优代码在 match .消除这种低效率留给 future 的工作。