Навигация и модификация AST, построенных на монаде Free в Haskell

Question

Навигация и модификация AST, построенных на монаде Free в Haskell

Я пытаюсь структурировать AST, используя свободную монаду, основываясь на некоторой полезной литературе, которую я прочитал онлайн.

У меня есть несколько вопросов о работе с этими видами AST на практике, которые я привел к следующему примеру.

Предположим, что мой язык допускает следующие команды:

{-# LANGUAGE DeriveFunctor #-}

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

что позволяет мне указывать программы, подобные следующим:

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

Наблюдение AST в GHCI показывает, что это работает правильно, и действительно

λ> 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

14

haskell abstract-syntax-tree free-monad

Источник

user1330897 11 июн '14 в 20:35

4 ответа

Решение

Если ваша проблема связана с шаблоном, вы не сможете обойти ее, если будете использовать 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 (), поэтому, прежде чем применять его, вы должны получить замену () с 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 заменены на сопоставление с образцом на Free а также 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

Все остальные функции изменены аналогично.

10

Источник

user2407038 11 июн '14 в 23:00

Пожалуйста, не думайте о молниях, обходах, SYB или линзах, пока не воспользуетесь стандартными функциями Free, Ваш execute, optimize а также project это просто стандартные бесплатные схемы рекурсии монады, которые уже доступны в пакете:

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 тоже.

5

Источник

user997606 12 июн '14 в 08:57

Вы, конечно, можете сделать это проще. Еще предстоит проделать определенную работу, потому что она не выполнит полную оптимизацию на первом проходе, но после двух проходов она полностью оптимизирует вашу примерную программу. Я оставлю это упражнение на ваше усмотрение, но в противном случае вы можете сделать это очень просто с помощью сопоставления с шаблоном по оптимизации, которую вы хотите сделать. Это все еще немного повторяется, но устраняет много сложностей, которые у вас были:

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.

1

Источник

user839246 11 июн '14 в 22:11

Другие вопросы по тегам haskell abstract-syntax-tree free-monad

user1285443 12 июн '14 в 00:32 2014-06-12 00:32 · Accepted Answer · 2014-06-12 00:32

Вот мой пример использования 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

Можно было бы избавиться от *Free* с помощью синонимов шаблонов GHC 7.8, но по какой-то причине приведенный выше код работает только с использованием GHC 7.6, экземпляр Data Free отсутствует. Должен посмотреть на это...