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

我试图根据我在网上阅读的一些有用的文献,使用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

user2407038.. 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 ()

但是,简化变得更容易.我们可以定义具有和实例的所有数据类型的简化:FoldableUnfoldable

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 (),让您应用它之前,你必须得到替换()用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分别用on Free和pattern匹配替换Free; 你需要一个单独的案例Pure.这应该告诉你Foldable并Unfoldable概括"看起来像"的东西Free.

reduce
  :: Functor f =>
     (Free f a -> Maybe (Free f a)) -> Free f a -> Free f a

reduce rule (Free x) = let y = Free $ fmap (reduce rule) $ x in 
  case rule y of 
    Nothing -> y
    Just y' -> y' 
reduce rule a@(Pure _) = case rule a of 
                           Nothing -> a
                           Just  b -> b 

所有其他功能都进行了类似的修改.