Haskell 地图的快捷融合

在Haskell中尝试融合中间映射时出现了此问题

考虑Peano自然数的trie：

data Nat = Zero | Succ Nat

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

我们可以很容易地定义

ExpoNat

（它本质上是一个列表）上的折叠，并使用（又称a.a.）来融合

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

，并将它们组合成

ExpoNat

。（注意，我们必须在

appl

中“加强归纳假设”）

可通过使用

-ddump siml

检查堆芯来验证熔合

{-# 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)

现在我们想对

树

执行同样的操作

data Tree = Leaf | Node Tree Tree

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

我们遇到了麻烦：

TreeMap

是一种不规则的数据类型，因此不清楚如何编写相应的折叠/构建对

似乎有答案（见

Bush

type），但凌晨4:30似乎太晚了，我无法让它工作。一个人应该如何编写hfmap？此后是否有进一步的发展

---

这个问题的一个类似变体在

中被提出，这篇论文似乎在作为递归类型的ExpoNat A和作为递归类型构造函数的树（

类型->类型

）之间画了一条平行线

fixf

表示类型和函数类别上内函式的最小不动点，

f:：Type->Type

HFix h

表示一类函子和自然变换上的内函子

h

的最小不动点，

h:（Type->Type）->（Type->Type）

• 内函子产生代数

  type  Alg f a = f a -> a
  type HAlg h f = h f ~> f
  

• fold

  或

  cata

  将任何代数映射到态射（函数|自然变换）

• build

  根据其编码构造一个值

  type  Church f = forall a.  Alg f a -> a
  type HChurch h = forall f. HAlg h f ~> f
  
   build ::  Church f ->  Fix f
  hbuild :: HChurch h -> HFix h a
  
  -- The paper actually has a slightly different type for Church encodings, derived from the categorical view, but I'm pretty sure they're equivalent
  

• build/fold

  fusion由一个等式概括

   cata alg ( build f) = f alg
  hcata alg (hbuild f) = f alg
  

---

我在这方面做了更多的工作，现在我有了工作fusion，没有使用论文中的通用小工具

{-# 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不知道如何在没有规则的情况下触发规则

现在，快捷融合规则：

{-# 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 #-}

使用“构建”实现“匹配”：

{-# 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))

使用“fold”实现“appl”（我们需要定义一个自定义functor来定义返回类型。）

总而言之：

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

---

我们可以再次使用

-ddump siml

检查堆芯。不幸的是，虽然我们成功地融合了

TrieMap

数据结构，但由于

match

中的

fmap

，我们的代码不是最理想的。消除这种低效率有待于今后的工作。

对于HFix，我们可以使用HBase（作为Kmett递归方案基的高阶版本的替代品）

{-# 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 #-}

{-# 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))

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))