在Haskell中导航和修改构建在Free monad上的AST

问题描述

我正在尝试使用免费monad基于一些我在网上阅读的有用文献构建AST。

我有一些关于使用这些工具的问题在实践中使用了几种AST，我将它们归结为以下示例。

假设我的语言允许使用以下命令：

  { - ＃LANGUAGE DeriveFunctor＃ - } 
 
 data下一个
 = DisplayChar Char下一个
 | DisplayString String next 
 |重复Int（Free Command（））next 
 |完成
派生（Eq，Show，Functor）
  

我定义了Free monad样板：

  displayChar :: Char  - > Free Command（）
 displayChar ch = liftF（DisplayChar ch（））
 
 displayString :: String  - > Free Command（）
 displayString str = liftF（DisplayString str（））
 
 repeat :: Int  - > Free Command（） - > Free Command（）
重复次数block = liftF（重复次数块（））
 
完成:: Free命令r 
完成= liftF完成
  
 $ p 
 $ b 
允许我指定如下程序：
 
 
  prog :: Free命令r 
 prog = 
做displayChar'A'
 displayStringabc
 
重复5 $ 
 displayChar 'Z'
 
 displayChar'\\\
'
完成
  
现在，我想执行我的程序，这似乎很简单。
  execute :: Free命令r  - > IO（）
 execute（Free（DisplayChar ch next））= putChar ch>>执行next 
 execute（Free（DisplayString str next））= putStr str>>执行next 
 execute（Free（Repeat n block next））= forM_ [1..n]（\  - >执行块）>>执行next 
 execute（Free Done）= return（）
 execute（Pure r）= return（）
  
和 
 
 
 λ>执执行
 AabcZZZZZ 
  
好的。这很好，但现在我想了解我的AST的一些事情，并对其执行转换。  
 
 
以下是一个简单的例子：如果 Repeat 块只包含 DisplayChar 命令，那么我想用适当的 DisplayString 替换整个事物。换句话说，
我想用重复2（displayChar'A'>>> displayChar'B'） displayStringABAB。
 
 
 
这是我的尝试： 
 
 
  optimize c @（Free（Repeat n block next））= 
如果全部是jrs charsToDisplay then 
 let chars = catMaybes charsToDisplay 
 in 
 displayString（concat $ replicate n个字符）>>优化next 
 else 
 c>>优化next 
 where 
 charsToDisplay = project getDisplayChar block 
 optimize（Free（DisplayChar ch next））= displayChar ch>>优化next 
 optimize（Free（DisplayString str next））= displayString str>>优化下一个
优化（免费完成）=完成
优化c @（Pure r）= c 
 
 getDisplayChar（Free（DisplayChar ch _））=只需ch 
 getDisplayChar _ = Nothing 
 
项目::（免费命令a  - >也许u） - >免费命令a  - > [也许你] 
 project f = maybes 
其中
 maybes（Pure a）= [] 
 maybes c @（Free cmd）= 
 let build next = fc ：maybes next 
 in 
 case cmd of 
 DisplayChar _ next  - >构建下一个
 DisplayString _ next  - >构建下一个
重复_ _ next  - >构建下一个
完成 - > [] 
  
观察GHCI中的AST显示，这个工作正确，实际上是
 λ>优化$ repeat 3（displayChar'A'>> displayChar'B'）
 Free（DisplayStringABABAB（Pure（）））
 
 
λ>执行 。优化$ prog 
 AabcZZZZZ 
λ>执执行
 AabcZZZZZ 
  
但我不高兴。在我看来，这个代码是重复的。我必须定义每次我想要检查AST时如何遍历AST，或者定义像我的项目这样的函数，以便我查看它。 
 
 
 
 所以，我的问题：这是我唯一的选择吗？我可以在AST上进行模式匹配而不需要处理大量的嵌套？我可以用一致和通用的方式遍历树吗（也许拉链，或者可穿越或其他）？ 
 
 
 
 
 
 $ p $ c> { - ＃LANGUAGE DeriveFunctor＃ - } 
 
模块Main其中
 
导入前导隐藏（重复）
 
导入Control.Monad.Free 
 
导入Control.Monad（forM_）
导入Data.Maybe（catMaybes，isJust）
 $ b $ main :: IO（）
 main = execute prog 
 
 prog :: Free命令r 
 prog = 
做displayChar'A'
 displayStringabc
 
重复5 $ 
 displayChar'Z'
 
 displayChar'\''
完成
 
优化c @（免费（下一个重复n块））= 
 if所有是charsToDisplay then 
 let chars = catMaybes charsToDisplay 
 in 
 displayString（concat $ replicate n chars）>>优化next 
 else 
 c>>优化next 
 where 
 charsToDisplay = project getDisplayChar block 
 optimize（Free（DisplayChar ch next））= displayChar ch>>优化next 
 optimize（Free（DisplayString str next））= displayString str>>优化下一个
优化（免费完成）=完成
优化c @（Pure r）= c 
 
 getDisplayChar（Free（DisplayChar ch _））=只需ch 
 getDisplayChar _ = Nothing 
 
项目::（免费命令a  - >也许u） - >免费命令a  - > [也许你] 
 project f = maybes 
其中
 maybes（Pure a）= [] 
 maybes c @（Free cmd）= 
 let build next = fc ：maybes next 
 in 
 case cmd of 
 DisplayChar _ next  - >构建下一个
 DisplayString _ next  - >构建下一个
重复_ _ next  - >构建下一个
完成 - > [] 
 
执行:: Free命令r  - > IO（）
 execute（Free（DisplayChar ch next））= putChar ch>>执行next 
 execute（Free（DisplayString str next））= putStr str>>执行next 
 execute（Free（Repeat n block next））= forM_ [1..n]（\  - >执行块）>>执行next 
 execute（Free Done）= return（）
 execute（Pure r）= return（）
 
 data命令next 
 = DisplayChar Char next 
 | DisplayString String next 
 |重复Int（Free Command（））next 
 |完成
导出（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（）
重复次数block = liftF（重复次数块（））
 
完成:: Free命令r 
完成= liftF完成
  

解决方案

这是我使用 syb

  { - ＃LANGUAGE LambdaCase＃ - } 
 { - ＃LANGUAGE DeriveFunctor＃ - } 
 { - ＃ ＃LANGUAGE TemplateHaskell＃ - } 
 { - ＃LANGUAGE FlexibleContexts＃ - } 
 { - ＃LANGUAGE DeriveDataTypeable＃ - } 
 
模块Main其中
 
导入Prelude隐藏（重复）
 
导入Data.Data 
 
导入Control.Monad（forM_）
 
导入Control.Monad.Free 
 import Control.Monad.Free.TH 
 
 import Data.Generics（everywhere，mkT）
 
 data CommandF next = DisplayChar Char next 
 | DisplayString String next 
 |重复Int（自由CommandF（））next 
 |完成
导出（Eq，Show，Functor，Data，Typeable）
 
 makeFree''CommandF 
 
类型Command = Free CommandF 
 
 execute :: Command（） - > IO（）
 execute = iterM句柄
其中
句柄= \ case 
 DisplayChar ch next  - > putChar ch>> next 
 DisplayString str next  - > putStr str>>下一个
下一个重复n块 - > forM_ [1..n]（\ _→>执行块）>>下一个
完成 - > return（）
 
 optimize :: Command（） - > Command（）
 optimize = optimize'。优化'
 where 
 optimize'=无处不在（mkT inner）
 
 inner :: Command（） - > Command（）
  -  char + char变成字符串
 inner（Free（DisplayChar c1（Free（DisplayChar c2 next））））= do 
 displayString [c1，c2] 
下一个
 
  -  char +字符串变成字符串
 inner（Free（DisplayChar c（Free（DisplayString s next））））= do 
 displayString $ c：s 
下一个
 
  - 字符串+字符串变为字符串
内部（Free（DisplayString s1（Free（DisplayString s2 next））））= do 
 displayString $ s1 ++ s2 
 next 
 
  - 循环展开
内部f @（Free（重复n个下一个块））| n< 5 = forM_ [1..n]（\→→block）>>下一个
 |否则= f 
 
内部a = a 
 
编程:: Command（）
编程=执行
 displayChar'a'
 displayChar' b'
重复1 $ displayChar'c'>> displayStringdef
 displayChar'g'
 displayChar'h'
 repeat 10 $ do 
 displayChar'i'
 displayChar'j'
 displayString klm
 repeat 3 $ displayChar'n'
 
 main :: IO（）
 main = do 
 putStrLn原始程序：
 print prog 
 putStrLn评估原始程序：
执行prog 
 putStrLn\\\

 
 let opt =优化编程
 putStrLn优化程序： 
打印opt 
 putStrLn优化程序评估：
执行opt 
 putStrLn
  

输出：

  $ cabal exec runhaskell ast.hs 
原始程序：
 Free（DisplayChar'a'（Free（DisplayChar'b'（Free（Repeat 1）（Free（DisplayChar'c'（Free（DisplayStringdef（Pure（））））））（Free（DisplayChar 'g'（Free（DisplayChar'h'（Free）（Repeat 10（Free（DisplayChar'i'（Fre e（DisplayChar'j'（Free（DisplayStringklm（Pure（））））））））（Free（Repeat3（Free（DisplayChar'n'（Pure（））））（Pure（）））） ）））））））））））））））））））
原始程序的评估：
 abcdefghijklmijklmijklmijklmijklmijklmijklmijklmijklmijklmijklmijklmijklmijklmijklmnnn 
 
优化程序：
 Free（DisplayStringabcdefgh（Free 10（自由（DisplayStringijklm（Pure（））））（Free（DisplayStringnnn（Pure（）））））））
优化程序的评估：
 abcdefghijklmijklmijklmijklmijklmijklmijklmijklmijklmijklmijklmnnn 
  

使用GHC 7.8 模式同义词可以消除* Free * ，但出于某种原因，上述代码仅适用于GHC 7.6， 的 Data 实例似乎缺失。应该看看......

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

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)

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 '\n'
     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 ()

and

λ> execute prog
AabcZZZZZ

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.

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".

Here's my attempt:

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 -> []

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 

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.

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?

The whole file is below:

{-# 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 '\n'
     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

解决方案

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 "\n"

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

Output:

$ 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

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的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！