在 Haskell 中导航和修改基于 Free monad 的 AST [英] Navigating and modifying ASTs built on the Free monad in Haskell

问题描述

我正在尝试根据我在网上阅读的一些有用文献，使用 Free monad 来构建 AST.

I'm attempting to structure an AST using the Free monad based on some helpful literature that I've read online.

我有一些关于在实践中使用这些类型的 AST 的问题，我已将其归结为以下示例.

I have some questions about working with these kinds of ASTs in practice, which I've boiled down to the following example.

假设我的语言允许以下命令:

Suppose my language allows for the following commands:

{-# LANGUAGE DeriveFunctor #-}

data Command next
  = DisplayChar Char next
  | DisplayString String next
  | Repeat Int (Free Command ()) next
  | Done
  deriving (Eq, Show, Functor)

我手动定义了 Free monad 样板:

and I define the Free monad boilerplate manually:

displayChar :: Char -> Free Command ()
displayChar ch = liftF (DisplayChar ch ())

displayString :: String -> Free Command ()
displayString str = liftF (DisplayString str ())

repeat :: Int -> Free Command () -> Free Command ()
repeat times block = liftF (Repeat times block ())

done :: Free Command r
done = liftF Done

它允许我指定如下程序:

which allows me to specify programs like the following:

prog :: Free Command r
prog =
  do displayChar 'A'
     displayString "abc"

     repeat 5 $
       displayChar 'Z'

     displayChar '
'
     done

现在，我想执行我的程序，这看起来很简单.

Now, I'd like to execute my program, which seems simple enough.

execute :: Free Command r -> IO ()
execute (Free (DisplayChar ch next)) = putChar ch >> execute next
execute (Free (DisplayString str next)) = putStr str >> execute next
execute (Free (Repeat n block next)) = forM_ [1 .. n] (\_ -> execute block) >> execute next
execute (Free Done) = return ()
execute (Pure r) = return ()

和

λ> execute prog
AabcZZZZZ

好的.一切都很好，但现在我想了解有关我的 AST 的知识，并对其执行转换.像编译器中的优化一样思考.

Okay. That's all nice, but now I want to learn things about my AST, and execute transformations on it. Think like optimizations in a compiler.

这是一个简单的:如果 Repeat 块只包含 DisplayChar 命令，那么我想用适当的 DisplayString 替换整个内容代码>.换句话说，我想用 displayString "ABAB" 转换 repeat 2 (displayChar 'A' >> displayChar 'B').

Here's a simple one: If a Repeat block only contains DisplayChar commands, then I'd like to replace the whole thing with an appropriate DisplayString. In other words, I'd like to transform repeat 2 (displayChar 'A' >> displayChar 'B') with displayString "ABAB".

这是我的尝试:

optimize c@(Free (Repeat n block next)) =
  if all isJust charsToDisplay then
    let chars = catMaybes charsToDisplay
    in
      displayString (concat $ replicate n chars) >> optimize next
  else
    c >> optimize next
  where
    charsToDisplay = project getDisplayChar block
optimize (Free (DisplayChar ch next)) = displayChar ch >> optimize next
optimize (Free (DisplayString str next)) = displayString str >> optimize next
optimize (Free Done) = done
optimize c@(Pure r) = c

getDisplayChar (Free (DisplayChar ch _)) = Just ch
getDisplayChar _ = Nothing

project :: (Free Command a -> Maybe u) -> Free Command a -> [Maybe u]
project f = maybes
  where
    maybes (Pure a) = []
    maybes c@(Free cmd) =
      let build next = f c : maybes next
      in
        case cmd of
          DisplayChar _ next -> build next
          DisplayString _ next -> build next
          Repeat _ _ next -> build next
          Done -> []

在 GHCI 中观察 AST 表明它可以正常工作，而且确实

Observing the AST in GHCI shows that this work correctly, and indeed

λ> optimize $ repeat 3 (displayChar 'A' >> displayChar 'B')
Free (DisplayString "ABABAB" (Pure ()))


λ> execute . optimize $ prog
AabcZZZZZ
λ> execute prog
AabcZZZZZ 

但是我不高兴.在我看来，这段代码是重复的.每次我想检查它时，我都必须定义如何遍历我的 AST，或者定义像我的 project 这样的函数，让我可以查看它.当我想修改树时，我必须做同样的事情.

But I'm not happy. In my opinion, this code is repetitive. I have to define how to traverse through my AST every time I want to examine it, or define functions like my project that give me a view into it. I have to do this same thing when I want to modify the tree.

那么，我的问题:这种方法是我唯一的选择吗?我可以在不处理大量嵌套的情况下在我的 AST 上进行模式匹配吗?我可以以一致和通用的方式遍历树吗(可能是拉链、可遍历或其他东西)?这里通常采用哪些方法?

So, my question: is this approach my only option? Can I pattern-match on my AST without dealing with tonnes of nesting? Can I traverse the tree in a consistent and generic way (maybe Zippers, or Traversable, or something else)? What approaches are commonly taken here?

整个文件如下:

{-# LANGUAGE DeriveFunctor #-}

module Main where

import Prelude hiding (repeat)

import Control.Monad.Free

import Control.Monad (forM_)
import Data.Maybe (catMaybes, isJust)

main :: IO ()
main = execute prog

prog :: Free Command r
prog =
  do displayChar 'A'
     displayString "abc"

     repeat 5 $
       displayChar 'Z'

     displayChar '
'
     done

optimize c@(Free (Repeat n block next)) =
  if all isJust charsToDisplay then
    let chars = catMaybes charsToDisplay
    in
      displayString (concat $ replicate n chars) >> optimize next
  else
    c >> optimize next
  where
    charsToDisplay = project getDisplayChar block
optimize (Free (DisplayChar ch next)) = displayChar ch >> optimize next
optimize (Free (DisplayString str next)) = displayString str >> optimize next
optimize (Free Done) = done
optimize c@(Pure r) = c

getDisplayChar (Free (DisplayChar ch _)) = Just ch
getDisplayChar _ = Nothing

project :: (Free Command a -> Maybe u) -> Free Command a -> [Maybe u]
project f = maybes
  where
    maybes (Pure a) = []
    maybes c@(Free cmd) =
      let build next = f c : maybes next
      in
        case cmd of
          DisplayChar _ next -> build next
          DisplayString _ next -> build next
          Repeat _ _ next -> build next
          Done -> []

execute :: Free Command r -> IO ()
execute (Free (DisplayChar ch next)) = putChar ch >> execute next
execute (Free (DisplayString str next)) = putStr str >> execute next
execute (Free (Repeat n block next)) = forM_ [1 .. n] (\_ -> execute block) >> execute next
execute (Free Done) = return ()
execute (Pure r) = return ()

data Command next
  = DisplayChar Char next
  | DisplayString String next
  | Repeat Int (Free Command ()) next
  | Done
  deriving (Eq, Show, Functor)

displayChar :: Char -> Free Command ()
displayChar ch = liftF (DisplayChar ch ())

displayString :: String -> Free Command ()
displayString str = liftF (DisplayString str ())

repeat :: Int -> Free Command () -> Free Command ()
repeat times block = liftF (Repeat times block ())

done :: Free Command r
done = liftF Done

推荐答案

这是我使用 syb 的看法(如 Reddit 上所述):

Here's my take using syb (as mentioned on Reddit):

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}

module Main where

import Prelude hiding (repeat)

import Data.Data

import Control.Monad (forM_)

import Control.Monad.Free
import Control.Monad.Free.TH

import Data.Generics (everywhere, mkT)

data CommandF next = DisplayChar Char next
                   | DisplayString String next
                   | Repeat Int (Free CommandF ()) next
                   | Done
  deriving (Eq, Show, Functor, Data, Typeable)

makeFree ''CommandF

type Command = Free CommandF

execute :: Command () -> IO ()
execute = iterM handle
  where
    handle = case
        DisplayChar ch next -> putChar ch >> next
        DisplayString str next -> putStr str >> next
        Repeat n block next -> forM_ [1 .. n] (\_ -> execute block) >> next
        Done -> return ()

optimize :: Command () -> Command ()
optimize = optimize' . optimize'
  where
    optimize' = everywhere (mkT inner)

    inner :: Command () -> Command ()
    -- char + char becomes string
    inner (Free (DisplayChar c1 (Free (DisplayChar c2 next)))) = do
        displayString [c1, c2]
        next

    -- char + string becomes string
    inner (Free (DisplayChar c (Free (DisplayString s next)))) = do
        displayString $ c : s
        next

    -- string + string becomes string
    inner (Free (DisplayString s1 (Free (DisplayString s2 next)))) = do
        displayString $ s1 ++ s2
        next

    -- Loop unrolling
    inner f@(Free (Repeat n block next)) | n < 5 = forM_ [1 .. n] (\_ -> block) >> next
                                         | otherwise = f

    inner a = a

prog :: Command ()
prog = do
    displayChar 'a'
    displayChar 'b'
    repeat 1 $ displayChar 'c' >> displayString "def"
    displayChar 'g'
    displayChar 'h'
    repeat 10 $ do
        displayChar 'i'
        displayChar 'j'
        displayString "klm"
    repeat 3 $ displayChar 'n'

main :: IO ()
main = do
    putStrLn "Original program:"
    print prog
    putStrLn "Evaluation of original program:"
    execute prog
    putStrLn "
"

    let opt = optimize prog
    putStrLn "Optimized program:"
    print opt
    putStrLn "Evaluation of optimized program:"
    execute opt
    putStrLn ""

输出:

$ cabal exec runhaskell ast.hs
Original program:
Free (DisplayChar 'a' (Free (DisplayChar 'b' (Free (Repeat 1 (Free (DisplayChar 'c' (Free (DisplayString "def" (Pure ()))))) (Free (DisplayChar 'g' (Free (DisplayChar 'h' (Free (Repeat 10 (Free (DisplayChar 'i' (Free (DisplayChar 'j' (Free (DisplayString "klm" (Pure ()))))))) (Free (Repeat 3 (Free (DisplayChar 'n' (Pure ()))) (Pure ()))))))))))))))
Evaluation of original program:
abcdefghijklmijklmijklmijklmijklmijklmijklmijklmijklmijklmnnn

Optimized program:
Free (DisplayString "abcdefgh" (Free (Repeat 10 (Free (DisplayString "ijklm" (Pure ()))) (Free (DisplayString "nnn" (Pure ()))))))
Evaluation of optimized program:
abcdefghijklmijklmijklmijklmijklmijklmijklmijklmijklmijklmnnn

使用 GHC 7.8 Pattern Synonyms 可能摆脱 *Free*s，但由于某种原因，上述代码仅适用于 GHC 7.6，Data Free 的实例似乎丢失了.应该调查一下...

It might be possible to get rid of the *Free*s using GHC 7.8 Pattern Synonyms, but for some reason the above code only works using GHC 7.6, the Data instance of Free seems to be missing. Should look into that...

这篇关于在 Haskell 中导航和修改基于 Free monad 的 AST的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！