浏览和修改基于Haskell中的Free Monad构建的AST

根据我在线阅读的一些有用的文献,我试图使用免费monad构建AST.

我在实践中对这些类型的AST进行工作有一些疑问,我已经从下面的例子中了解到.

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

{-# LANGUAGE DeriveFunctor #-}

data Command next
  = DisplayChar Char next
  | DisplayString String next
  | Repeat Int (Free Command ()) next
  | Done
  deriving (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 ()
repeat times block = liftF (Repeat times block ())

done :: Free Command r
done = liftF Done

这允许我指定如下的程序:

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

     repeat 5 $
       displayChar 'Z'

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

λ> execute prog
AabcZZZZZ

好的.这很好,但是现在我想学习关于我的AST的事情,并且对它进行转换.想像编译器中的优化.

这是一个简单的例子:如果一个重复块只包含DisplayChar命令,那么我想用一个合适的DisplayString替换整个事物.换一种说法,
我想使用displayString“ABAB”转换repeat 2(displayChar’A’>> displayChar’B’).

这是我的尝试:

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表明,这项工作正确而且确实

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


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

但我不高兴在我看来,这段代码是重复的.我必须定义如何遍历我的AST每次我想检查它,或定义像我的项目,给我一个视图的功能.当我想修改树时,我必须做同样的事情.

所以我的问题是这种方法是我唯一的选择吗?我可以在我的AST上模拟匹配,而不是处理大量的嵌套?我可以以一致和通用的方式遍历树(也许是拉链,还是其他东西)?通常采取哪些方法?

整个文件如下:

{-# 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
这是我使用syb(如在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 ""

输出:

$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 *,但是由于某些原因,上述代码只能使用GHC 7.6,Free的Data实例似乎缺少.应该看看…

翻译自:https://stackoverflow.com/questions/24172117/navigating-and-modifying-asts-built-on-the-free-monad-in-haskell

转载注明原文:浏览和修改基于Haskell中的Free Monad构建的AST