Перемещение и изменение АСЦ построен на свободной монады в Haskell

Если ваша проблема с шаблоном, вы не обойдете его, если используете 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' 

В правило упрощения должно упростить только один уровень АСТ (а именно, самый верхний уровень). Затем, если упрощение можно применить к субструктуре, оно будет выполнять его и там. Обратите внимание, что выше 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

Из-за того, как вы определили свой тип данных, у вас нет доступа ко 2-му аргументу 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 

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

Пожалуйста, не думайте о молниях, траверсах, Сиб или линзах, пока не воспользуетесь стандартными функциями 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 тоже.

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

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.