haskell - 使用 de Bruijn 索引将 Data.Reify 显式共享图转换为 AST

Question

我正在尝试使用 Data.Reify 为简单的 AST 恢复共享(在 Type-Safe Observable Sharing in Haskell 意义上) :

{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveTraversable, TypeFamilies #-}
module Sharing where

import Data.Foldable
import Data.Reify
import Data.Traversable

-- Original AST, without sharing. Expressed as a functor for ease of
-- use with Data.Reify.
data AstF f =
      LitF Int
    | AddF f f
    deriving (Foldable, Functor, Show, Traversable)

newtype Fix f = In { out :: f (Fix f) }

instance Traversable a => MuRef (Fix a) where
    type DeRef (Fix a) = a
    mapDeRef f = traverse f . out

type Ast' = Fix AstF

-- Final AST, with explicit sharing.
data Ast =
      Var Name
    | Let Ast Ast
    | Lit Int
    | Add Ast Ast
    deriving Show

type Name = Int  -- de Bruijn index

-- Recover sharing and introduce Lets/Vars.
recoverSharing :: Ast' -> IO Ast
recoverSharing e = introduceLets `fmap` reifyGraph e
  where
    introduceLets :: Graph (DeRef Ast') -> Ast
    introduceLets = undefined  -- ???

我有实现 introduceLets 的感觉(应该同时引入 Let s 和 Var s)应该简单而简短，但我对 de Bruijn 指数没有足够的经验来知道是否有标准的方法来做到这一点。你会如何转换 Graph代表进入 Ast表示？

附言请注意，这是一个非常退化的情况，如 Ast'实际上没有自己的绑定(bind)构造函数；所有绑定(bind)都来自共享恢复。

P.P.S.理想情况下我们不会引入 Let s 用于一次性表达式(尽管如果我们这样做，我们可以使用内联传递删除它们。)

Answer 1

我们将把这个问题分成 3 个部分。第一部分是使用data-reify library恢复 AstF 的图形.第二部分将创建一个带有 Let 的抽象语法树。用 de Bruijn 索引表示的绑定(bind)。最后，我们将删除所有不必要的 let 绑定(bind)。

这些都是我们一路上会用到的玩具。 StandaloneDeriving和 UndecidableInstances只需要提供Eq和 Show诸如 Fix 之类的实例.

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

import Data.Foldable
import Data.Reify
import Data.Traversable
import qualified Data.List as List

import Data.IntMap ((!))
import qualified Data.IntMap as IntMap

import Prelude hiding (any)

使用数据具体化

您几乎已准备好使用 data-reify 库的所有部分。

data AstF f =
      LitF Int
    | AddF f f
    deriving (Eq, Show, Functor, Foldable, Traversable)


newtype Fix f = In { out :: f (Fix f) }

deriving instance Eq (f (Fix f)) => Eq (Fix f)
deriving instance Show (f (Fix f)) => Show (Fix f)

instance Traversable a => MuRef (Fix a) where
    type DeRef (Fix a) = a
    mapDeRef f = traverse f . out

唯一缺少的就是拨打 reifyGraph .让我们尝试一个小例子

do
    let example = In (AddF (In (AddF (In (LitF 1)) (In (LitF 2)))) example)
    graph <- reifyGraph example
    print graph

这输出

let [(1,AddF 2 1),(2,AddF 3 4),(4,LitF 2),(3,LitF 1)] in 1

graph有类型 Graph AstF , 由构造函数 Graph [(Unique, AstF Unique)] Unique 构造.构造函数的第一个参数是具有新唯一键的节点列表。结构中的每条边都被替换为该边头部节点的新唯一键。构造函数的第二个参数是树根节点的唯一键。

将图形转换为 Let 表示

我们将转换 Graph从数据具体化到 de Bruijn 索引的抽象语法树 Let绑定(bind)。我们将使用以下类型表示 AST。这种类型不需要了解有关 AST 内部表示的任何信息。

type Index = Int

-- This can be rewritten in terms of Fix and Functor composition
data Indexed f
    = Var Index
    | Let (Indexed f) (Indexed f)
    | Exp (f (Indexed f))

deriving instance Eq (f (Indexed f)) => Eq (Indexed f)
deriving instance Show (f (Indexed f)) => Show (Indexed f)

Index es代表 Let的数量s 之间使用变量的位置和 Let它被宣布的地方。您应该阅读 Let a b如 let (Var 0)=a in b
我们将图转换为 Indexed 的策略AST 是从根节点开始遍历图。在每个节点，我们都会引入一个 Let绑定(bind)该节点。对于每条边，我们将检查它所引用的节点是否已经在引入的 Let 中。范围内的绑定(bind)。如果是，我们将用该 Let 的变量替换边。捆绑。如果它不是由 Let 引入的绑定(bind)，我们将遍历它。关于我们正在操作的 AST，我们唯一需要知道的是它是一个 Functor .

index :: Functor f => Graph (DeRef (Fix f)) -> Indexed f
index (Graph edges root) = go [root]
    where
        go keys@(key:_) =
            Let (Exp (fmap lookup (map ! key))) (Var 0)
                where
                    lookup unique = 
                        case List.elemIndex unique keys of
                            Just n -> Var n
                            Nothing -> go (unique:keys)
        map = IntMap.fromList edges

为方便起见，我们将定义以下内容。

reifyLet :: Traversable f => Fix f -> IO (Indexed f)
reifyLet = fmap index . reifyGraph

我们将尝试与以前相同的示例

do
    let example = In (AddF (In (AddF (In (LitF 1)) (In (LitF 2)))) example)
    lets <- reifyLet example
    print lets

这输出

Let (Exp (AddF (Let (Exp (AddF (Let (Exp (LitF 1)) (Var 0)) (Let (Exp (LitF 2)) (Var 0)))) (Var 0)) (Var 0))) (Var 0)

我们只有 1 let绑定(bind)在 example但这有 4 Let s。我们将删除不必要的 Let下一步绑定(bind)。

删除不必要的`Let`绑定(bind)

删除 Let引入未使用变量的绑定(bind)，我们需要一个使用变量的概念。我们将为任何 Foldable 定义它AST。

used :: (Foldable f) => Index -> Indexed f -> Bool
used x (Var y) = x == y
used x (Let a b) = used (x+1) a || used (x+1) b
used x (Exp a)  = any (used x) a

当我们删除 Let绑定(bind)，介入次数 Let绑定(bind)，因此变量的 de Bruijn 索引将改变。我们需要能够从 Indexed 中删除一个变量AST

remove x :: (Functor f) => Index -> Indexed f -> Indexed f
remove x (Var y) =
    case y `compare` x of
        EQ -> error "Removed variable that's being used`
        LT -> Var y
        GT -> Var (y-1)
remove x (Let a b) = Let (remove (x+1) a) (remove (x+1) b)
remove x (Exp a) = Exp (fmap (remove x) a)

Let有两种方式绑定(bind)可以引入一个未使用的变量。该变量可以完全不用，例如 let a = 1 in 2 ，或者它可以被简单地使用，如 let a = 1 in a .第一个可以替换为 2第二个可以替换为 1 .当我们删除 Let绑定(bind)，我们还需要用 remove 调整 AST 中所有剩余的变量.不是的东西 Let不要引入未使用的变量，也没有什么可以替换的。

removeUnusedLet :: (Functor f, Foldable f) => Indexed f -> Indexed f
removeUnusedLet (Let a b) =
    if (used 0 b) 
    then
        case b of
            Var 0 ->
                if (used 0 a)
                then (Let a b)
                else remove 0 a
            _     -> (Let a b)
    else remove 0 b
removeUnusedLet x = x

我们希望能够申请 removeUnusedLet处处 Indexed AST。我们可以为此使用更通用的东西，但我们只会为自己定义如何在 Indexed 中的任何地方应用函数。 AST

mapIndexed :: (Functor f) => (Indexed f -> Indexed f) -> Indexed f -> Indexed f
mapIndexed f (Let a b) = Let (f a) (f b)
mapIndexed f (Exp a)   = Exp (fmap f a)
mapIndexed f x         = x

postMap :: (Functor f) => (Indexed f -> Indexed f) -> Indexed f -> Indexed f
postMap f = go
    where
        go = f . mapIndexed go

然后我们可以删除所有未使用的让

removeUnusedLets = postMap removeUnusedLet

我们将再次尝试我们的示例

do
    let example = In (AddF (In (AddF (In (LitF 1)) (In (LitF 2)))) example)
    lets <- reifyLet example
    let simplified = removeUnusedLets lets
    print simplified

这仅引入了一个 Let

   Let (Exp (AddF (Exp (AddF (Exp (LitF 1)) (Exp (LitF 2)))) (Var 0))) (Var 0)

限制

相互递归的定义不会导致相互递归 Let绑定(bind)。例如

do
    let
        left   =  In (AddF (In (LitF 1)) right       )
        right   = In (AddF left         (In (LitF 2)))
        example = In (AddF left          right       )
    lets <- reifyLet example
    let simplified = removeUnusedLets lets
    print simplified

结果是

Exp (AddF
    (Let (Exp (AddF
        (Exp (LitF 1))
        (Exp (AddF (Var 0) (Exp (LitF 2))))
    )) (Var 0))
    (Let (Exp (AddF
        (Exp (AddF (Exp (LitF 1)) (Var 0)))
        (Exp (LitF 2))
    )) (Var 0)))

我不相信这些在 Indexed 中存在相互递归的表示形式。不使用负值 Index .