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

时间：2014-06-11 20:35:34

标签： haskell abstract-syntax-tree free-monad

我试图使用Free 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，并对其执行转换。想象一下编译器中的优化。

这是一个简单的问题：如果Repeat块只包含DisplayChar个命令，那么我想用适当的DisplayString替换整个事件。换一种说法， 我想用repeat 2 (displayChar 'A' >> displayChar 'B')转换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表明这项工作正确，实际上

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


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

但我不开心。在我看来，这段代码是重复的。我必须定义每次想要检查它时如何遍历我的AST，或者定义像我project这样的函数来给我一个视图。当我想修改树时，我必须做同样的事情。

所以，我的问题：这种方法是我唯一的选择吗？我可以在我的AST上进行模式匹配而不需要处理大量的嵌套吗？我可以以一致且通用的方式遍历树（可能是Zippers，Traversable，还是其他东西）？这里通常采用什么方法？

整个文件如下：

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

4 个答案:

答案 0 :(得分：10)

如果您的问题是使用样板文件，如果您使用Free，则不会解决问题！在每个级别上，你总是会遇到额外的构造函数。

但另一方面，如果您使用的是Free，那么您可以通过一种非常简单的方法来推广数据结构的递归。你可以从头开始编写这个，但我使用了recursion-schemes包：

import Data.Functor.Foldable 

data (:+:) f g a = L (f a) | R (g a) deriving (Functor, Eq, Ord, Show)

type instance Base (Free f a) = f :+: Const a 
instance (Functor f) => Foldable (Free f a) where 
  project (Free f) = L f 
  project (Pure a) = R (Const a)
instance Functor f => Unfoldable (Free f a) where 
  embed (L f) = Free f
  embed (R (Const a)) = Pure a 
instance Functor f => Unfoldable (Free f a) where 
  embed (L f) = Free f
  embed (R (Const a)) = Pure a

如果你不熟悉这个（阅读文档），但基本上你需要知道的是project需要一些数据，比如Free f a，并且“取消它”一个级别，产生类似(f :+: Const a) (Free f a)的东西。现在，您已经提供了fmap，Data.Foldable.foldMap等常规函数来访问数据结构，因为仿函数的参数是子树。

执行非常简单，虽然不够简洁：

execute :: Free Command r -> IO ()
execute = cata go where 
  go (L (DisplayChar ch next)) = putChar ch >> next
  go (L (DisplayString str next)) = putStr str >> next
  go (L (Repeat n block next)) = forM_ [1 .. n] (const $ execute block) >> next
  go (L Done) = return ()
  go (R _) = return ()

然而，简化变得更容易。我们可以对具有Foldable和Unfoldable个实例的所有数据类型进行简化：

reduce :: (Foldable t, Functor (Base t), Unfoldable t) => (t -> Maybe t) -> t -> t 
reduce rule x = let y = embed $ fmap (reduce rule) $ project x in 
  case rule y of 
    Nothing -> y
    Just y' -> y'

简化规则只需要简化AST的一个级别（即最顶层）。然后，如果简化可以应用于子结构，它也将在那里执行。请注意，上述reduce自下而上;你也可以自上而下减少：

reduceTD :: (Foldable t, Functor (Base t), Unfoldable t) => (t -> Maybe t) -> t -> t 
reduceTD rule x = embed $ fmap (reduceTD rule) $ project y
  where y = case rule x of 
              Nothing -> x 
              Just x' -> x'

您的示例简化规则可以非常简单地编写：

getChrs :: (Command :+: Const ()) (Maybe String) -> Maybe String 
getChrs (L (DisplayChar c n)) = liftA (c:) n
getChrs (L Done) = Just []
getChrs (R _) = Just []
getChrs _ = Nothing 

optimize (Free (Repeat n dc next)) = do 
  chrs <- cata getChrs dc
  return $ Free $ DisplayString (concat $ map (replicate n) chrs) next
optimize _ = Nothing

由于您定义数据类型的方式，您无权访问Repeat的第二个争论，因此对于repeat' 5 (repeat' 3 (displayChar 'Z')) >> done这样的内容，repeat可以'简化。如果这是您希望处理的情况，您要么更改数据类型并接受更多样板，要么写一个例外：

reduceCmd rule (Free (Repeat n c r)) = 
let x = Free (Repeat n (reduceCmd rule c) (reduceCmd rule r)) in 
    case rule x of
      Nothing -> x
      Just x' -> x' 
reduceCmd rule x = embed $ fmap (reduceCmd rule) $ project x

使用recursion-schemes等可能会使您的代码更容易扩展。但无论如何都没有必要：

execute = iterM go where 
  go (DisplayChar ch next) = putChar ch >> next
  go (DisplayString str next) = putStr str >> next
  go (Repeat n block next) = forM_ [1 .. n] (const $ execute block) >> next
  go Done = return ()

getChrs无法访问Pure，您的程序将采用Free Command ()格式，因此在应用之前，您必须使用{替换() {1}}。 

Maybe String

请注意getChrs :: Command (Maybe String) -> Maybe String getChrs (DisplayChar c n) = liftA (c:) n getChrs (DisplayString s n) = liftA (s++) n getChrs Done = Just [] getChrs _ = Nothing optimize :: Free Command a -> Maybe (Free Command a) optimize (Free (Repeat n dc next)) = do chrs <- iter getChrs $ fmap (const $ Just []) dc return $ Free $ DisplayString (concat $ map (replicate n) chrs) next optimize _ = Nothing 几乎与以前完全相同，只有两件事：reduce和project被embed和{{1}上的模式匹配所取代}， 分别;你需要一个单独的Free案例。这应该告诉您Free和Pure概括了“看起来像”Foldable的内容。 

Unfoldable

所有其他功能的修改方式相似。

答案 1 :(得分：5)

这是我使用 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 模式同义词来摆脱* Free * s，但由于某种原因，上述代码仅适用于GHC 7.6， Data Free 的实例似乎缺失了。应该考虑一下......

答案 2 :(得分：5)

在您充分利用Free的标准功能之前，请不要考虑拉链，遍历，SYB或镜头。您的execute，optimize和project只是标准的免费monad递归方案，已在套餐中提供：

optimize :: Free Command a -> Free Command a
optimize = iterM $ \f -> case f of
  c@(Repeat n block next) ->
    let charsToDisplay = project getDisplayChar block in
    if all isJust charsToDisplay then
      let chars = catMaybes charsToDisplay in
      displayString (concat $ replicate n chars) >> next
    else
      liftF c >> next
  DisplayChar ch next -> displayChar ch >> next
  DisplayString str next -> displayString str >> next
  Done -> done

getDisplayChar :: Command t -> Maybe Char
getDisplayChar (DisplayChar ch _) = Just ch
getDisplayChar _ = Nothing

project' :: (Command [u] -> u) -> Free Command [u] -> [u]
project' f = iter $ \c -> f c : case c of
  DisplayChar _ next -> next
  DisplayString _ next -> next
  Repeat _ _ next -> next
  Done -> []

project :: (Command [u] -> u) -> Free Command a -> [u]
project f = project' f . fmap (const [])

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

由于你的组件最多只有一个延续，你可以找到一种聪明的方法来摆脱所有>> next。

答案 3 :(得分：1)

你当然可以更轻松地做到这一点。还有一些工作要做，因为它在第一次通过时不会执行完全优化，但是在两次通过之后它会完全优化你的示例程序。我将这项练习留给您，但除此之外，您可以通过对要进行的优化进行模式匹配来做到这一点。它仍然有点重复，但消除了你的许多复杂情况：

optimize (Free (Repeat n block next)) = optimize (replicateM n block >> next)
optimize (Free (DisplayChar ch1 (Free (DisplayChar ch2 next)))) = optimize (displayString [ch1, ch2] >> next)
optimize (Free (DisplayChar ch (Free (DisplayString str next)))) = optimize (displayString (ch:str) >> next)
optimize (Free (DisplayString s1 (Free (DisplayString s2 next)))) = optimize (displayString (s1 ++ s2) >> next)
optimize (Free (DisplayString s (Free (DisplayChar ch next)))) = optimize (displayString (s ++ [ch]) >> next)
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

我所做的只是repeat n (displayChar c)，displayChar c1 >> displayChar c2，displayChar c >> displayString s，displayString s >> displayChar c和displayString s1 >> displayString s2上的模式匹配。还有其他优化可以完成，但这很简单，并且不依赖于扫描其他任何东西，只是迭代地逐步优化AST。

相关问题
最新问题